FrontISTR  5.7.1
Large-scale structural analysis program with finit element method
fstr_contact_def.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 !-------------------------------------------------------------------------------
13 
14  use hecmw
15  use msurfelement
16  use m_contact_lib
18  use bucket_search
19  use mcontactparam
21 
22  implicit none
23 
25  type tcontact
26  ! following contact definition
27  character(len=HECMW_NAME_LEN) :: name
28  integer :: ctype
29  integer :: group
30  character(len=HECMW_NAME_LEN) :: pair_name
31  integer :: surf_id1, surf_id2
32  integer :: surf_id1_sgrp
33  type(tsurfelement), pointer :: master(:)=>null()
34  integer, pointer :: slave(:)=>null()
35  real(kind=kreal) :: fcoeff
36  real(kind=kreal) :: tpenalty
37 
38  real(kind=kreal) :: ctime
39  integer(kind=kint) :: if_type
40  real(kind=kreal) :: if_etime
41  real(kind=kreal) :: initial_pos
42  real(kind=kreal) :: end_pos
43  ! following algorithm
44  ! -1: not initialized
45  ! 1: TIED-Just rigidly fixed the two surfaces
46  ! 2: GLUED-Distance between the two surfaces to zero and glue them
47  ! 3: SSLID-Small sliding contact( no position but with contact state change)
48  ! 4: FSLID-Finite sliding contact (both changes in contact state and position possible)
49  integer :: algtype
50 
51  logical :: mpced
52  logical :: symmetric
53 
54  ! following contact state
55  type(tcontactstate), pointer :: states(:)=>null()
56 
57  type(hecmwst_contact_comm) :: comm
58  type(bucketdb) :: master_bktdb
59 
60  type(tcontactparam), pointer :: cparam=>null()
61  end type tcontact
62 
64  logical :: active
65  integer(kind=kint) :: contact2free
66  integer(kind=kint) :: contact2neighbor
67  integer(kind=kint) :: contact2difflpos
68  integer(kind=kint) :: free2contact
69  integer(kind=kint) :: contactnode_previous
70  integer(kind=kint) :: contactnode_current
72 
73  private :: is_mpc_available
74  private :: is_active_contact
75  private :: cal_node_normal
76  private :: track_contact_position
77  private :: reset_contact_force
78 
79 contains
80 
82  logical function is_mpc_available( contact )
83  type(tcontact), intent(in) :: contact
84  is_mpc_available = .true.
85  if( contact%fcoeff/=0.d0 ) is_mpc_available = .false.
86  end function
87 
89  subroutine fstr_write_contact( file, contact )
90  integer(kind=kint), intent(in) :: file
91  type(tcontact), intent(in) :: contact
92  integer :: i
93  write(file,*) "CONTACT:", contact%ctype,contact%group,trim(contact%pair_name),contact%fcoeff
94  write(file,*) "---Slave----"
95  write(file,*) "num.slave",size(contact%slave)
96  if( associated(contact%slave) ) then
97  do i=1,size(contact%slave)
98  write(file, *) contact%slave(i)
99  enddo
100  endif
101  write(file,*) "----master---"
102  write(file,*) "num.master",size(contact%master)
103  if( associated(contact%master) ) then
104  do i=1,size(contact%master)
105  call write_surf( file, contact%master(i) )
106  enddo
107  endif
108  end subroutine
109 
111  subroutine fstr_contact_finalize( contact )
112  type(tcontact), intent(inout) :: contact
113  integer :: i
114  if( associated( contact%slave ) ) deallocate(contact%slave)
115  if( associated( contact%master ) ) then
116  do i=1,size( contact%master )
117  call finalize_surf( contact%master(i) )
118  enddo
119  deallocate(contact%master)
120  endif
121  if( associated(contact%states) ) deallocate(contact%states)
122  call hecmw_contact_comm_finalize(contact%comm)
123  call bucketdb_finalize( contact%master_bktDB )
124  end subroutine
125 
127  logical function fstr_contact_check( contact, hecMESH )
128  type(tcontact), intent(inout) :: contact
129  type(hecmwst_local_mesh), pointer :: hecmesh
130 
131  integer :: i
132  logical :: isfind
133 
134  fstr_contact_check = .false.
135 
136  ! if contact pair exist?
137  isfind = .false.
138  do i=1,hecmesh%contact_pair%n_pair
139  if( hecmesh%contact_pair%name(i) == contact%pair_name ) then
140  contact%ctype = hecmesh%contact_pair%type(i)
141  contact%surf_id1 = hecmesh%contact_pair%slave_grp_id(i)
142  contact%surf_id2 = hecmesh%contact_pair%master_grp_id(i)
143  contact%surf_id1_sgrp = hecmesh%contact_pair%slave_orisgrp_id(i)
144  isfind = .true.
145  endif
146  enddo
147  if( .not. isfind ) return;
148  if( contact%fcoeff<=0.d0 ) contact%fcoeff=0.d0
149  if( contact%ctype < 1 .and. contact%ctype > 3 ) return
150  if( contact%group<=0 ) return
151 
152  fstr_contact_check = .true.
153  end function
154 
156  logical function fstr_contact_init( contact, hecMESH, cparam, myrank )
157  type(tcontact), intent(inout) :: contact
158  type(hecmwst_local_mesh), pointer :: hecmesh
159  type(tcontactparam), target :: cparam
160  integer(kint),intent(in),optional :: myrank
161 
162  integer :: i, j, is, ie, cgrp, nsurf, nslave, ic, ic_type, iss, nn, ii
163  integer :: count,nodeid
164 
165  fstr_contact_init = .false.
166 
167  contact%cparam => cparam
168 
169  ! master surface
170  cgrp = contact%surf_id2
171  if( cgrp<=0 ) return
172  is= hecmesh%surf_group%grp_index(cgrp-1) + 1
173  ie= hecmesh%surf_group%grp_index(cgrp )
174 
175  if(present(myrank)) then
176  ! PARA_CONTACT
177  count = 0
178  do i=is,ie
179  ic = hecmesh%surf_group%grp_item(2*i-1)
180  if(hecmesh%elem_ID(ic*2) /= myrank) cycle
181  count = count + 1
182  enddo
183  allocate( contact%master(count) )
184  count = 0
185  do i=is,ie
186  ic = hecmesh%surf_group%grp_item(2*i-1)
187  if(hecmesh%elem_ID(ic*2) /= myrank) cycle
188  count = count + 1
189  nsurf = hecmesh%surf_group%grp_item(2*i)
190  ic_type = hecmesh%elem_type(ic)
191  call initialize_surf( ic, ic_type, nsurf, contact%master(count) )
192  iss = hecmesh%elem_node_index(ic-1)
193  do j=1, size( contact%master(count)%nodes )
194  nn = contact%master(count)%nodes(j)
195  contact%master(count)%nodes(j) = hecmesh%elem_node_item( iss+nn )
196  enddo
197  enddo
198 
199  else
200  ! not PARA_CONTACT
201  allocate( contact%master(ie-is+1) )
202  do i=is,ie
203  ic = hecmesh%surf_group%grp_item(2*i-1)
204  nsurf = hecmesh%surf_group%grp_item(2*i)
205  ic_type = hecmesh%elem_type(ic)
206  call initialize_surf( ic, ic_type, nsurf, contact%master(i-is+1) )
207  iss = hecmesh%elem_node_index(ic-1)
208  do j=1, size( contact%master(i-is+1)%nodes )
209  nn = contact%master(i-is+1)%nodes(j)
210  contact%master(i-is+1)%nodes(j) = hecmesh%elem_node_item( iss+nn )
211  enddo
212  enddo
213 
214  endif
215 
216  call update_surface_reflen( contact%master, hecmesh%node )
217 
218  cgrp = contact%surf_id1
219  if( cgrp<=0 ) return
220  is= hecmesh%node_group%grp_index(cgrp-1) + 1
221  ie= hecmesh%node_group%grp_index(cgrp )
222  nslave = 0
223  do i=is,ie
224  nodeid = hecmesh%global_node_ID(hecmesh%node_group%grp_item(i))
225  if(present(myrank)) then
226  ! PARA_CONTACT
227  nslave = nslave + 1
228  else
229  ! not PARA_CONTACT
230  if( hecmesh%node_group%grp_item(i) <= hecmesh%nn_internal) then
231  nslave = nslave + 1
232  endif
233  endif
234  enddo
235  allocate( contact%slave(nslave) )
236  allocate( contact%states(nslave) )
237  ii = 0
238  do i=is,ie
239  if(.not.present(myrank)) then
240  ! not PARA_CONTACT
241  if( hecmesh%node_group%grp_item(i) > hecmesh%nn_internal) cycle
242  endif
243  ii = ii + 1
244  contact%slave(ii) = hecmesh%node_group%grp_item(i)
245  contact%states(ii)%state = -1
246  contact%states(ii)%multiplier(:) = 0.d0
247  contact%states(ii)%tangentForce(:) = 0.d0
248  contact%states(ii)%tangentForce1(:) = 0.d0
249  contact%states(ii)%tangentForce_trial(:) = 0.d0
250  contact%states(ii)%tangentForce_final(:) = 0.d0
251  contact%states(ii)%reldisp(:) = 0.d0
252  contact%states(ii)%time_factor = 0.d0
253  contact%states(ii)%interference_flag = 0
254  enddo
255  ! endif
256 
257  ! contact state
258  ! allocate( contact%states(nslave) )
259  do i=1,nslave
260  call contact_state_init( contact%states(i) )
261  enddo
262 
263  ! neighborhood of surface group
264  call update_surface_box_info( contact%master, hecmesh%node )
265  call bucketdb_init( contact%master_bktDB )
266  call update_surface_bucket_info( contact%master, contact%master_bktDB )
267  call find_surface_neighbor( contact%master, contact%master_bktDB )
268 
269  ! initialize contact communication table
270  call hecmw_contact_comm_init( contact%comm, hecmesh, 1, nslave, contact%slave )
271 
272  contact%symmetric = .true.
273  fstr_contact_init = .true.
274  end function
275 
277  logical function fstr_embed_init( embed, hecMESH, cparam, myrank )
278  type(tcontact), intent(inout) :: embed
279  type(hecmwst_local_mesh), pointer :: hecmesh
280  type(tcontactparam), target :: cparam
281  integer(kint),intent(in),optional :: myrank
282 
283  integer :: i, j, is, ie, cgrp, nsurf, nslave, ic, ic_type, iss, nn, ii
284  integer :: count,nodeid
285 
286  fstr_embed_init = .false.
287 
288  embed%cparam => cparam
289 
290  ! master surface
291  cgrp = embed%surf_id2
292  if( cgrp<=0 ) return
293  is= hecmesh%elem_group%grp_index(cgrp-1) + 1
294  ie= hecmesh%elem_group%grp_index(cgrp )
295 
296  if(present(myrank)) then
297  ! PARA_CONTACT
298  count = 0
299  do i=is,ie
300  ic = hecmesh%elem_group%grp_item(i)
301  if(hecmesh%elem_ID(ic*2) /= myrank) cycle
302  count = count + 1
303  enddo
304  allocate( embed%master(count) )
305  count = 0
306  do i=is,ie
307  ic = hecmesh%elem_group%grp_item(i)
308  if(hecmesh%elem_ID(ic*2) /= myrank) cycle
309  count = count + 1
310  ic_type = hecmesh%elem_type(ic)
311  call initialize_surf( ic, ic_type, 0, embed%master(count) )
312  iss = hecmesh%elem_node_index(ic-1)
313  do j=1, size( embed%master(count)%nodes )
314  nn = embed%master(count)%nodes(j)
315  embed%master(count)%nodes(j) = hecmesh%elem_node_item( iss+nn )
316  enddo
317  enddo
318 
319  else
320  ! not PARA_CONTACT
321  allocate( embed%master(ie-is+1) )
322  do i=is,ie
323  ic = hecmesh%elem_group%grp_item(i)
324  ic_type = hecmesh%elem_type(ic)
325  call initialize_surf( ic, ic_type, 0, embed%master(i-is+1) )
326  iss = hecmesh%elem_node_index(ic-1)
327  do j=1, size( embed%master(i-is+1)%nodes )
328  nn = embed%master(i-is+1)%nodes(j)
329  embed%master(i-is+1)%nodes(j) = hecmesh%elem_node_item( iss+nn )
330  enddo
331  enddo
332 
333  endif
334 
335  !call update_surface_reflen( embed%master, hecMESH%node )
336 
337  ! slave surface
338  ! if( contact%ctype==1 ) then
339  cgrp = embed%surf_id1
340  if( cgrp<=0 ) return
341  is= hecmesh%node_group%grp_index(cgrp-1) + 1
342  ie= hecmesh%node_group%grp_index(cgrp )
343  nslave = 0
344  do i=is,ie
345  nodeid = hecmesh%global_node_ID(hecmesh%node_group%grp_item(i))
346  if(present(myrank)) then
347  ! PARA_CONTACT
348  nslave = nslave + 1
349  else
350  ! not PARA_CONTACT
351  if( hecmesh%node_group%grp_item(i) <= hecmesh%nn_internal) then
352  nslave = nslave + 1
353  endif
354  endif
355  enddo
356  allocate( embed%slave(nslave) )
357  allocate( embed%states(nslave) )
358  ii = 0
359  do i=is,ie
360  if(.not.present(myrank)) then
361  ! not PARA_CONTACT
362  if( hecmesh%node_group%grp_item(i) > hecmesh%nn_internal) cycle
363  endif
364  ii = ii + 1
365  embed%slave(ii) = hecmesh%node_group%grp_item(i)
366  embed%states(ii)%state = -1
367  embed%states(ii)%multiplier(:) = 0.d0
368  embed%states(ii)%tangentForce(:) = 0.d0
369  embed%states(ii)%tangentForce1(:) = 0.d0
370  embed%states(ii)%tangentForce_trial(:) = 0.d0
371  embed%states(ii)%tangentForce_final(:) = 0.d0
372  embed%states(ii)%reldisp(:) = 0.d0
373  enddo
374  ! endif
375 
376  ! contact state
377  ! allocate( contact%states(nslave) )
378  do i=1,nslave
379  call contact_state_init( embed%states(i) )
380  enddo
381 
382  ! neighborhood of surface group
383  call update_surface_box_info( embed%master, hecmesh%node )
384  call bucketdb_init( embed%master_bktDB )
385  call update_surface_bucket_info( embed%master, embed%master_bktDB )
386  call find_surface_neighbor( embed%master, embed%master_bktDB )
387 
388  ! initialize contact communication table
389  call hecmw_contact_comm_init( embed%comm, hecmesh, 1, nslave, embed%slave )
390 
391  embed%symmetric = .true.
392  fstr_embed_init = .true.
393  end function
394 
395  function check_apply_contact_if( contact_if, contacts )
396  type(tcontactinterference), intent(inout) :: contact_if
397  type(tcontact) :: contacts(:)
398 
399  integer :: i, j
400  logical :: isfind
401  integer(kind=kint) :: check_apply_contact_if
402 
404  ! if contact pair exist?
405  isfind = .false.
406  do i = 1, size(contacts)
407  if( contacts(i)%pair_name == contact_if%cp_name ) then
408  contacts(i)%if_type = contact_if%if_type
409  contacts(i)%if_etime = contact_if%etime
410  contacts(i)%initial_pos = contact_if%initial_pos
411  contacts(i)%end_pos = contact_if%end_pos
412  do j = 1, size(contacts(i)%states)
413  contacts(i)%states(j)%interference_flag = contact_if%if_type
414  contacts(i)%states(j)%init_pos = contact_if%initial_pos
415  contacts(i)%states(j)%end_pos = contact_if%end_pos
416  if( contact_if%if_type /= c_if_slave )then
417  contacts(i)%states(j)%time_factor = (contact_if%end_pos - contact_if%initial_pos) / contact_if%etime
418  else
419  contacts(i)%states(j)%time_factor = contact_if%etime
420  end if
421  end do
422  isfind = .true.
423  check_apply_contact_if = 0; return
424  endif
425  enddo
426  if( .not. isfind ) return;
428 
429  end function
430 
432  subroutine clear_contact_state( contact )
433  type(tcontact), intent(inout) :: contact
434  integer :: i
435  if( .not. associated(contact%states) ) return
436  do i=1,size( contact%states )
437  contact%states(i)%state = -1
438  enddo
439  end subroutine
440 
442  logical function is_active_contact( acgrp, contact )
443  integer, intent(in) :: acgrp(:)
444  type(tcontact), intent(in) :: contact
445  if( any( acgrp==contact%group ) ) then
446  is_active_contact = .true.
447  else
448  is_active_contact = .false.
449  endif
450  end function
451 
455  subroutine scan_contact_state( flag_ctAlgo, contact, currpos, currdisp, ndforce, infoCTChange, &
456  nodeID, elemID, is_init, active, mu, B )
457  character(len=9), intent(in) :: flag_ctAlgo
458  type( tcontact ), intent(inout) :: contact
459  type( fstr_info_contactchange ), intent(inout) :: infoCTChange
460  real(kind=kreal), intent(in) :: currpos(:)
461  real(kind=kreal), intent(in) :: currdisp(:)
462  real(kind=kreal), intent(in) :: ndforce(:)
463  integer(kind=kint), intent(in) :: nodeID(:)
464  integer(kind=kint), intent(in) :: elemID(:)
465  logical, intent(in) :: is_init
466  logical, intent(out) :: active
467  real(kind=kreal), intent(in) :: mu
468  real(kind=kreal), optional, target :: b(:)
469 
470  real(kind=kreal) :: distclr
471  integer(kind=kint) :: slave, id, etype
472  integer(kind=kint) :: nn, i, j, iSS, nactive
473  real(kind=kreal) :: coord(3), elem(3, l_max_elem_node )
474  real(kind=kreal) :: nlforce, slforce(3)
475  logical :: isin
476  integer(kind=kint), allocatable :: contact_surf(:), states_prev(:)
477  !
478  integer, pointer :: indexMaster(:),indexCand(:)
479  integer :: nMaster,idm,nMasterMax,bktID,nCand
480  logical :: is_cand, is_present_B
481  real(kind=kreal), pointer :: bp(:)
482 
483  if( is_init ) then
484  distclr = contact%cparam%DISTCLR_INIT
485  else
486  distclr = contact%cparam%DISTCLR_FREE
487  if( contact%algtype == contacttied ) then
488  active = .false.
489  do i= 1, size(contact%slave)
490  if( contact%states(i)%state==contactstick ) then
491  active = .true.
492  exit
493  endif
494  enddo
495  endif
496  endif
497 
498  allocate(contact_surf(size(nodeid)))
499  allocate(states_prev(size(contact%slave)))
500  contact_surf(:) = huge(0)
501  do i = 1, size(contact%slave)
502  states_prev(i) = contact%states(i)%state
503  enddo
504 
505  call update_surface_box_info( contact%master, currpos )
506  call update_surface_bucket_info( contact%master, contact%master_bktDB )
507 
508  ! for gfortran-10: optional parameter seems not allowed within omp parallel
509  is_present_b = present(b)
510  if( is_present_b ) bp => b
511 
512  !$omp parallel do &
513  !$omp& default(none) &
514  !$omp& private(i,slave,slforce,id,nlforce,coord,indexMaster,nMaster,nn,j,iSS,elem,is_cand,idm,etype,isin, &
515  !$omp& bktID,nCand,indexCand) &
516  !$omp& firstprivate(nMasterMax,is_present_B) &
517  !$omp& shared(contact,ndforce,flag_ctAlgo,infoCTChange,currpos,currdisp,mu,nodeID,elemID,Bp,distclr,contact_surf,is_init) &
518  !$omp& reduction(.or.:active) &
519  !$omp& schedule(dynamic,1)
520  do i= 1, size(contact%slave)
521  if(contact%if_type /= 0) call set_shrink_factor(contact%ctime, contact%states(i), contact%if_etime, contact%if_type)
522  slave = contact%slave(i)
523  if( contact%states(i)%state==contactstick .or. contact%states(i)%state==contactslip ) then
524  slforce(1:3)=ndforce(3*slave-2:3*slave)
525  id = contact%states(i)%surface
526  nlforce = contact%states(i)%multiplier(1)
527 
528  ! update direction of TIED contact
529  if( contact%algtype == contacttied ) then
530  call update_direction( i, contact, currpos )
531  if (.not.is_init) cycle
532  endif
533 
534  if( nlforce < contact%cparam%TENSILE_FORCE ) then
535  contact%states(i)%state = contactfree
536  contact%states(i)%multiplier(:) = 0.d0
537  write(*,'(A,i10,A,i10,A,e12.3)') "Node",nodeid(slave)," free from contact with element", &
538  elemid(contact%master(id)%eid), " with tensile force ", nlforce
539  cycle
540  endif
541  if( contact%algtype /= contactfslid .or. (.not. is_present_b) ) then ! small slide problem
542  contact_surf(contact%slave(i)) = -elemid(contact%master(id)%eid)
543  else
544  call track_contact_position( flag_ctalgo, i, contact, currpos, currdisp, mu, infoctchange, nodeid, elemid, bp )
545  if( contact%states(i)%state /= contactfree ) then
546  id = contact%states(i)%surface
547  contact_surf(contact%slave(i)) = -elemid(contact%master(id)%eid)
548  endif
549  endif
550 
551  else if( contact%states(i)%state==contactfree ) then
552  if( contact%algtype == contacttied .and. .not. is_init ) cycle
553  coord(:) = currpos(3*slave-2:3*slave)
554 
555  ! get master candidates from bucketDB
556  bktid = bucketdb_getbucketid(contact%master_bktDB, coord)
557  ncand = bucketdb_getnumcand(contact%master_bktDB, bktid)
558  if (ncand == 0) cycle
559  allocate(indexcand(ncand))
560  call bucketdb_getcand(contact%master_bktDB, bktid, ncand, indexcand)
561 
562  nmastermax = ncand
563  allocate(indexmaster(nmastermax))
564  nmaster = 0
565 
566  ! narrow down candidates
567  do idm= 1, ncand
568  id = indexcand(idm)
569  if (.not. is_in_surface_box( contact%master(id), coord(1:3), contact%cparam%BOX_EXP_RATE )) cycle
570  nmaster = nmaster + 1
571  indexmaster(nmaster) = id
572  enddo
573  deallocate(indexcand)
574 
575  if(nmaster == 0) then
576  deallocate(indexmaster)
577  cycle
578  endif
579 
580  do idm = 1,nmaster
581  id = indexmaster(idm)
582  etype = contact%master(id)%etype
583  nn = size( contact%master(id)%nodes )
584  do j=1,nn
585  iss = contact%master(id)%nodes(j)
586  elem(1:3,j)=currpos(3*iss-2:3*iss)
587  enddo
588  call project_point2element( coord,etype,nn,elem,contact%master(id)%reflen,contact%states(i), &
589  isin,distclr,localclr=contact%cparam%CLEARANCE )
590  if( .not. isin ) cycle
591  contact%states(i)%surface = id
592  contact%states(i)%multiplier(:) = 0.d0
593  iss = isinsideelement( etype, contact%states(i)%lpos(1:2), contact%cparam%CLR_CAL_NORM )
594  if( iss>0 ) &
595  call cal_node_normal( id, iss, contact%master, currpos, contact%states(i)%lpos(1:2), &
596  contact%states(i)%direction(:) )
597  contact_surf(contact%slave(i)) = elemid(contact%master(id)%eid)
598  write(*,'(A,i10,A,i10,A,f7.3,A,2f7.3,A,3f7.3,A,i6)') "Node",nodeid(slave)," contact with element", &
599  elemid(contact%master(id)%eid), &
600  " with distance ", contact%states(i)%distance," at ",contact%states(i)%lpos(1:2), &
601  " along direction ", contact%states(i)%direction," rank=",hecmw_comm_get_rank()
602  exit
603  enddo
604  deallocate(indexmaster)
605  endif
606  enddo
607  !$omp end parallel do
608 
609  if( contact%algtype == contacttied .and. .not. is_init ) then
610  deallocate(contact_surf)
611  deallocate(states_prev)
612  return
613  endif
614 
615  call hecmw_contact_comm_allreduce_i(contact%comm, contact_surf, hecmw_min)
616  nactive = 0
617  do i = 1, size(contact%slave)
618  if (contact%states(i)%state /= contactfree) then ! any slave in contact
619  id = contact%states(i)%surface
620  if (abs(contact_surf(contact%slave(i))) /= elemid(contact%master(id)%eid)) then ! that is in contact with other surface
621  contact%states(i)%state = contactfree ! should be freed
622  write(*,'(A,i10,A,i10,A,i6,A,i6,A)') "Node",nodeid(contact%slave(i))," contact with element", &
623  & elemid(contact%master(id)%eid), " in rank",hecmw_comm_get_rank()," freed due to duplication"
624  else
625  nactive = nactive + 1
626  endif
627  endif
628  if (states_prev(i) == contactfree .and. contact%states(i)%state /= contactfree) then
629  infoctchange%free2contact = infoctchange%free2contact + 1
630  elseif (states_prev(i) /= contactfree .and. contact%states(i)%state == contactfree) then
631  infoctchange%contact2free = infoctchange%contact2free + 1
632  endif
633  enddo
634  active = (nactive > 0)
635  deallocate(contact_surf)
636  deallocate(states_prev)
637  end subroutine scan_contact_state
638 
642  subroutine scan_embed_state( flag_ctAlgo, embed, currpos, currdisp, ndforce, infoCTChange, &
643  nodeID, elemID, is_init, active, mu, B )
644  character(len=9), intent(in) :: flag_ctAlgo
645  type( tcontact ), intent(inout) :: embed
646  type( fstr_info_contactchange ), intent(inout) :: infoCTChange
647  real(kind=kreal), intent(in) :: currpos(:)
648  real(kind=kreal), intent(in) :: currdisp(:)
649  real(kind=kreal), intent(in) :: ndforce(:)
650  integer(kind=kint), intent(in) :: nodeID(:)
651  integer(kind=kint), intent(in) :: elemID(:)
652  logical, intent(in) :: is_init
653  logical, intent(out) :: active
654  real(kind=kreal), intent(in) :: mu
655  real(kind=kreal), optional, target :: b(:)
656 
657  real(kind=kreal) :: distclr
658  integer(kind=kint) :: slave, id, etype
659  integer(kind=kint) :: nn, i, j, iSS, nactive
660  real(kind=kreal) :: coord(3), elem(3, l_max_elem_node )
661  real(kind=kreal) :: nlforce, slforce(3)
662  logical :: isin
663  integer(kind=kint), allocatable :: contact_surf(:), states_prev(:)
664  !
665  integer, pointer :: indexMaster(:),indexCand(:)
666  integer :: nMaster,idm,nMasterMax,bktID,nCand
667  logical :: is_cand, is_present_B
668  real(kind=kreal), pointer :: bp(:)
669 
670  if( is_init ) then
671  distclr = embed%cparam%DISTCLR_INIT
672  else
673  distclr = embed%cparam%DISTCLR_FREE
674  active = .false.
675  do i= 1, size(embed%slave)
676  if( embed%states(i)%state==contactstick ) then
677  active = .true.
678  exit
679  endif
680  enddo
681  return
682  endif
683 
684  allocate(contact_surf(size(nodeid)))
685  allocate(states_prev(size(embed%slave)))
686  contact_surf(:) = huge(0)
687  do i = 1, size(embed%slave)
688  states_prev(i) = embed%states(i)%state
689  enddo
690 
691  call update_surface_box_info( embed%master, currpos )
692  call update_surface_bucket_info( embed%master, embed%master_bktDB )
693 
694  ! for gfortran-10: optional parameter seems not allowed within omp parallel
695  is_present_b = present(b)
696  if( is_present_b ) bp => b
697 
698  !$omp parallel do &
699  !$omp& default(none) &
700  !$omp& private(i,slave,slforce,id,nlforce,coord,indexMaster,nMaster,nn,j,iSS,elem,is_cand,idm,etype,isin, &
701  !$omp& bktID,nCand,indexCand) &
702  !$omp& firstprivate(nMasterMax,is_present_B) &
703  !$omp& shared(embed,ndforce,flag_ctAlgo,infoCTChange,currpos,currdisp,mu,nodeID,elemID,Bp,distclr,contact_surf) &
704  !$omp& reduction(.or.:active) &
705  !$omp& schedule(dynamic,1)
706  do i= 1, size(embed%slave)
707  slave = embed%slave(i)
708  if( embed%states(i)%state==contactfree ) then
709  coord(:) = currpos(3*slave-2:3*slave)
710 
711  ! get master candidates from bucketDB
712  bktid = bucketdb_getbucketid(embed%master_bktDB, coord)
713  ncand = bucketdb_getnumcand(embed%master_bktDB, bktid)
714  if (ncand == 0) cycle
715  allocate(indexcand(ncand))
716  call bucketdb_getcand(embed%master_bktDB, bktid, ncand, indexcand)
717 
718  nmastermax = ncand
719  allocate(indexmaster(nmastermax))
720  nmaster = 0
721 
722  ! narrow down candidates
723  do idm= 1, ncand
724  id = indexcand(idm)
725  if (.not. is_in_surface_box( embed%master(id), coord(1:3), embed%cparam%BOX_EXP_RATE )) cycle
726  nmaster = nmaster + 1
727  indexmaster(nmaster) = id
728  enddo
729  deallocate(indexcand)
730 
731  if(nmaster == 0) then
732  deallocate(indexmaster)
733  cycle
734  endif
735 
736  do idm = 1,nmaster
737  id = indexmaster(idm)
738  etype = embed%master(id)%etype
739  if( mod(etype,10) == 2 ) etype = etype - 1 !search by 1st-order shape function
740  nn = getnumberofnodes(etype)
741  do j=1,nn
742  iss = embed%master(id)%nodes(j)
743  elem(1:3,j)=currpos(3*iss-2:3*iss)
744  enddo
745  call project_point2solidelement( coord,etype,nn,elem,embed%master(id)%reflen,embed%states(i), &
746  isin,distclr,localclr=embed%cparam%CLEARANCE )
747  if( .not. isin ) cycle
748  embed%states(i)%surface = id
749  embed%states(i)%multiplier(:) = 0.d0
750  contact_surf(embed%slave(i)) = elemid(embed%master(id)%eid)
751  write(*,'(A,i10,A,i10,A,3f7.3,A,i6)') "Node",nodeid(slave)," embeded to element", &
752  elemid(embed%master(id)%eid), " at ",embed%states(i)%lpos(:)," rank=",hecmw_comm_get_rank()
753  exit
754  enddo
755  deallocate(indexmaster)
756  endif
757  enddo
758  !$omp end parallel do
759 
760  call hecmw_contact_comm_allreduce_i(embed%comm, contact_surf, hecmw_min)
761  nactive = 0
762  do i = 1, size(embed%slave)
763  if (embed%states(i)%state /= contactfree) then ! any slave in contact
764  id = embed%states(i)%surface
765  if (abs(contact_surf(embed%slave(i))) /= elemid(embed%master(id)%eid)) then ! that is in contact with other surface
766  embed%states(i)%state = contactfree ! should be freed
767  write(*,'(A,i10,A,i10,A,i6,A,i6,A)') "Node",nodeid(embed%slave(i))," contact with element", &
768  & elemid(embed%master(id)%eid), " in rank",hecmw_comm_get_rank()," freed due to duplication"
769  else
770  nactive = nactive + 1
771  endif
772  endif
773  if (states_prev(i) == contactfree .and. embed%states(i)%state /= contactfree) then
774  infoctchange%free2contact = infoctchange%free2contact + 1
775  elseif (states_prev(i) /= contactfree .and. embed%states(i)%state == contactfree) then
776  infoctchange%contact2free = infoctchange%contact2free + 1
777  endif
778  enddo
779  active = (nactive > 0)
780  deallocate(contact_surf)
781  deallocate(states_prev)
782  end subroutine scan_embed_state
783 
784 
786  subroutine cal_node_normal( csurf, isin, surf, currpos, lpos, normal )
788  integer, intent(in) :: csurf
789  integer, intent(in) :: isin
790  type(tsurfelement), intent(in) :: surf(:)
791  real(kind=kreal), intent(in) :: currpos(:)
792  real(kind=kreal), intent(in) :: lpos(:)
793  real(kind=kreal), intent(out) :: normal(3)
794  integer(kind=kint) :: cnode, i, j, cnt, nd1, gn, etype, iSS, nn,cgn
795  real(kind=kreal) :: cnpos(2), elem(3, l_max_elem_node )
796  integer(kind=kint) :: cnode1, cnode2, gn1, gn2, nsurf, cgn1, cgn2, isin_n
797  real(kind=kreal) :: x=0, normal_n(3), lpos_n(2)
798 
799  if( 1 <= isin .and. isin <= 4 ) then ! corner
800  cnode = isin
801  gn = surf(csurf)%nodes(cnode)
802  etype = surf(csurf)%etype
803  call getvertexcoord( etype, cnode, cnpos )
804  nn = size( surf(csurf)%nodes )
805  do j=1,nn
806  iss = surf(csurf)%nodes(j)
807  elem(1:3,j)=currpos(3*iss-2:3*iss)
808  enddo
809  normal = surfacenormal( etype, nn, cnpos, elem )
810  cnt = 1
811  do i=1,surf(csurf)%n_neighbor
812  nd1 = surf(csurf)%neighbor(i)
813  nn = size( surf(nd1)%nodes )
814  etype = surf(nd1)%etype
815  cgn = 0
816  do j=1,nn
817  iss = surf(nd1)%nodes(j)
818  elem(1:3,j)=currpos(3*iss-2:3*iss)
819  if( iss==gn ) cgn=j
820  enddo
821  if( cgn>0 ) then
822  call getvertexcoord( etype, cgn, cnpos )
823  !normal = normal+SurfaceNormal( etype, nn, cnpos, elem )
824  normal_n = surfacenormal( etype, nn, cnpos, elem )
825  normal = normal+normal_n
826  cnt = cnt+1
827  endif
828  enddo
829  !normal = normal/cnt !!-???
830  elseif( 12 <= isin .and. isin <= 41 ) then ! edge
831  cnode1 = isin / 10
832  cnode2 = mod(isin, 10)
833  gn1 = surf(csurf)%nodes(cnode1)
834  gn2 = surf(csurf)%nodes(cnode2)
835  etype = surf(csurf)%etype
836  nn = size( surf(csurf)%nodes )
837  do j=1,nn
838  iss = surf(csurf)%nodes(j)
839  elem(1:3,j)=currpos(3*iss-2:3*iss)
840  enddo
841  normal = surfacenormal( etype, nn, lpos, elem )
842  select case (etype)
843  case (fe_tri3n, fe_tri6n, fe_tri6nc)
844  if ( isin==12 ) then; x=lpos(2)-lpos(1)
845  elseif( isin==23 ) then; x=1.d0-2.d0*lpos(2)
846  elseif( isin==31 ) then; x=2.d0*lpos(1)-1.d0
847  else; stop "Error: cal_node_normal: invalid isin"
848  endif
849  case (fe_quad4n, fe_quad8n)
850  if ( isin==12 ) then; x=lpos(1)
851  elseif( isin==23 ) then; x=lpos(2)
852  elseif( isin==34 ) then; x=-lpos(1)
853  elseif( isin==41 ) then; x=-lpos(2)
854  else; stop "Error: cal_node_normal: invalid isin"
855  endif
856  end select
857  ! find neighbor surf that includes cnode1 and cnode2
858  nsurf = 0
859  neib_loop: do i=1, surf(csurf)%n_neighbor
860  nd1 = surf(csurf)%neighbor(i)
861  nn = size( surf(nd1)%nodes )
862  etype = surf(nd1)%etype
863  cgn1 = 0
864  cgn2 = 0
865  do j=1,nn
866  iss = surf(nd1)%nodes(j)
867  elem(1:3,j)=currpos(3*iss-2:3*iss)
868  if( iss==gn1 ) cgn1=j
869  if( iss==gn2 ) cgn2=j
870  enddo
871  if( cgn1>0 .and. cgn2>0 ) then
872  nsurf = nd1
873  isin_n = 10*cgn2 + cgn1
874  x = -x
875  select case (etype)
876  case (fe_tri3n, fe_tri6n, fe_tri6nc)
877  if ( isin_n==12 ) then; lpos_n(1)=0.5d0*(1.d0-x); lpos_n(2)=0.5d0*(1.d0+x)
878  elseif( isin_n==23 ) then; lpos_n(1)=0.d0; lpos_n(2)=0.5d0*(1.d0-x)
879  elseif( isin_n==31 ) then; lpos_n(1)=0.5d0*(1.d0+x); lpos_n(2)=0.d0
880  else; stop "Error: cal_node_normal: invalid isin_n"
881  endif
882  case (fe_quad4n, fe_quad8n)
883  if ( isin_n==12 ) then; lpos_n(1)= x; lpos_n(2)=-1.d0
884  elseif( isin_n==23 ) then; lpos_n(1)= 1.d0; lpos_n(2)= x
885  elseif( isin_n==34 ) then; lpos_n(1)=-x; lpos_n(2)= 1.d0
886  elseif( isin_n==41 ) then; lpos_n(1)=-1.d0; lpos_n(2)=-x
887  else; stop "Error: cal_node_normal: invalid isin_n"
888  endif
889  end select
890  !normal = normal + SurfaceNormal( etype, nn, lpos_n, elem )
891  normal_n = surfacenormal( etype, nn, lpos_n, elem )
892  normal = normal+normal_n
893  exit neib_loop
894  endif
895  enddo neib_loop
896  !if( nsurf==0 ) write(0,*) "Warning: cal_node_normal: neighbor surf not found"
897  !normal = normal/2
898  endif
899  normal = normal/ dsqrt( dot_product( normal, normal ) )
900  end subroutine cal_node_normal
901 
903  subroutine track_contact_position( flag_ctAlgo, nslave, contact, currpos, currdisp, mu, infoCTChange, nodeID, elemID, B )
904  character(len=9), intent(in) :: flag_ctAlgo
905  integer, intent(in) :: nslave
906  type( tcontact ), intent(inout) :: contact
907  type( fstr_info_contactchange ), intent(inout) :: infoCTChange
908  real(kind=kreal), intent(in) :: currpos(:)
909  real(kind=kreal), intent(in) :: currdisp(:)
910  real(kind=kreal), intent(in) :: mu
911  integer(kind=kint), intent(in) :: nodeID(:)
912  integer(kind=kint), intent(in) :: elemID(:)
913  real(kind=kreal), intent(inout) :: b(:)
914 
915  integer(kind=kint) :: slave, sid0, sid, etype
916  integer(kind=kint) :: nn, i, j, iSS
917  real(kind=kreal) :: coord(3), elem(3, l_max_elem_node ), elem0(3, l_max_elem_node )
918  logical :: isin
919  real(kind=kreal) :: opos(2), odirec(3)
920  integer(kind=kint) :: bktID, nCand, idm
921  integer(kind=kint), allocatable :: indexCand(:)
922 
923  sid = 0
924 
925  slave = contact%slave(nslave)
926  coord(:) = currpos(3*slave-2:3*slave)
928  sid0 = contact%states(nslave)%surface
929  opos = contact%states(nslave)%lpos(1:2)
930  odirec = contact%states(nslave)%direction
931  etype = contact%master(sid0)%etype
932  nn = getnumberofnodes( etype )
933  do j=1,nn
934  iss = contact%master(sid0)%nodes(j)
935  elem(1:3,j)=currpos(3*iss-2:3*iss)
936  elem0(1:3,j)=currpos(3*iss-2:3*iss)-currdisp(3*iss-2:3*iss)
937  enddo
938  call project_point2element( coord,etype,nn,elem,contact%master(sid0)%reflen,contact%states(nslave), &
939  isin,contact%cparam%DISTCLR_NOCHECK,contact%states(nslave)%lpos(1:2),contact%cparam%CLR_SAME_ELEM )
940  if( .not. isin ) then
941  do i=1, contact%master(sid0)%n_neighbor
942  sid = contact%master(sid0)%neighbor(i)
943  etype = contact%master(sid)%etype
944  nn = getnumberofnodes( etype )
945  do j=1,nn
946  iss = contact%master(sid)%nodes(j)
947  elem(1:3,j)=currpos(3*iss-2:3*iss)
948  enddo
949  call project_point2element( coord,etype,nn,elem,contact%master(sid)%reflen,contact%states(nslave), &
950  isin,contact%cparam%DISTCLR_NOCHECK,localclr=contact%cparam%CLEARANCE )
951  if( isin ) then
952  contact%states(nslave)%surface = sid
953  exit
954  endif
955  enddo
956  endif
957 
958  if( .not. isin ) then ! such case is considered to rarely or never occur
959  write(*,*) 'Warning: contact moved beyond neighbor elements'
960  ! get master candidates from bucketDB
961  bktid = bucketdb_getbucketid(contact%master_bktDB, coord)
962  ncand = bucketdb_getnumcand(contact%master_bktDB, bktid)
963  if (ncand > 0) then
964  allocate(indexcand(ncand))
965  call bucketdb_getcand(contact%master_bktDB, bktid, ncand, indexcand)
966  do idm= 1, ncand
967  sid = indexcand(idm)
968  if( sid==sid0 ) cycle
969  if( associated(contact%master(sid0)%neighbor) ) then
970  if( any(sid==contact%master(sid0)%neighbor(:)) ) cycle
971  endif
972  if (.not. is_in_surface_box( contact%master(sid), coord(1:3), contact%cparam%BOX_EXP_RATE )) cycle
973  etype = contact%master(sid)%etype
974  nn = size( contact%master(sid)%nodes )
975  do j=1,nn
976  iss = contact%master(sid)%nodes(j)
977  elem(1:3,j)=currpos(3*iss-2:3*iss)
978  enddo
979  call project_point2element( coord,etype,nn,elem,contact%master(sid)%reflen,contact%states(nslave), &
980  isin,contact%cparam%DISTCLR_NOCHECK,localclr=contact%cparam%CLEARANCE )
981  if( isin ) then
982  contact%states(nslave)%surface = sid
983  exit
984  endif
985  enddo
986  deallocate(indexcand)
987  endif
988  endif
989 
990  if( isin ) then
991  if( contact%states(nslave)%surface==sid0 ) then
992  if(any(dabs(contact%states(nslave)%lpos(1:2)-opos(:)) >= contact%cparam%CLR_DIFFLPOS)) then
993  !$omp atomic
994  infoctchange%contact2difflpos = infoctchange%contact2difflpos + 1
995  endif
996  else
997  write(*,'(A,i10,A,i10,A,f7.3,A,2f7.3)') "Node",nodeid(slave)," move to contact with", &
998  elemid(contact%master(sid)%eid), " with distance ", &
999  contact%states(nslave)%distance," at ",contact%states(nslave)%lpos(1:2)
1000  !$omp atomic
1001  infoctchange%contact2neighbor = infoctchange%contact2neighbor + 1
1002  if( flag_ctalgo=='ALagrange' ) &
1003  call reset_contact_force( contact, currpos, nslave, sid0, opos, odirec, b )
1004  endif
1005  if( flag_ctalgo=='SLagrange' ) call update_tangentforce(etype,nn,elem0,elem,contact%states(nslave))
1006  iss = isinsideelement( etype, contact%states(nslave)%lpos(1:2), contact%cparam%CLR_CAL_NORM )
1007  if( iss>0 ) &
1008  call cal_node_normal( contact%states(nslave)%surface, iss, contact%master, currpos, &
1009  contact%states(nslave)%lpos(1:2), contact%states(nslave)%direction(:) )
1010  else if( .not. isin ) then
1011  write(*,'(A,i10,A)') "Node",nodeid(slave)," move out of contact"
1012  contact%states(nslave)%state = contactfree
1013  contact%states(nslave)%multiplier(:) = 0.d0
1014  endif
1015 
1016  end subroutine track_contact_position
1017 
1019  subroutine update_direction( nslave, contact, currpos )
1020  integer, intent(in) :: nslave
1021  type( tcontact ), intent(inout) :: contact
1022  real(kind=kreal), intent(in) :: currpos(:)
1023 
1024  integer(kind=kint) :: slave, sid0, sid, etype
1025  integer(kind=kint) :: nn, i, j, iSS
1026  real(kind=kreal) :: coord(3), elem(3, l_max_elem_node ), elem0(3, l_max_elem_node )
1027  logical :: isin
1028  real(kind=kreal) :: opos(2), odirec(3)
1029  integer(kind=kint) :: bktID, nCand, idm
1030  integer(kind=kint), allocatable :: indexCand(:)
1031  type(tcontactstate) :: cstate_tmp
1032 
1033  sid = 0
1034 
1035  slave = contact%slave(nslave)
1036  coord(:) = currpos(3*slave-2:3*slave)
1038  sid0 = contact%states(nslave)%surface
1039  opos = contact%states(nslave)%lpos(1:2)
1040  odirec = contact%states(nslave)%direction
1041  etype = contact%master(sid0)%etype
1042  nn = getnumberofnodes( etype )
1043  do j=1,nn
1044  iss = contact%master(sid0)%nodes(j)
1045  elem(1:3,j)=currpos(3*iss-2:3*iss)
1046  enddo
1047 
1048  cstate_tmp%state = contact%states(nslave)%state
1049  cstate_tmp%surface = sid0
1050  call project_point2element( coord,etype,nn,elem,contact%master(sid0)%reflen,cstate_tmp, &
1051  isin,contact%cparam%DISTCLR_NOCHECK,contact%states(nslave)%lpos,contact%cparam%CLR_SAME_ELEM )
1052 
1053  if( isin ) then
1054  iss = isinsideelement( etype, cstate_tmp%lpos, contact%cparam%CLR_CAL_NORM )
1055  if( iss>0 ) &
1056  call cal_node_normal( cstate_tmp%surface, iss, contact%master, currpos, &
1057  cstate_tmp%lpos, cstate_tmp%direction(:) )
1058  endif
1059 
1060  contact%states(nslave)%direction = cstate_tmp%direction
1061 
1062  end subroutine
1063 
1064 
1067  subroutine reset_contact_force( contact, currpos, lslave, omaster, opos, odirec, B )
1068  type( tcontact ), intent(inout) :: contact
1069  real(kind=kreal), intent(in) :: currpos(:)
1070  integer, intent(in) :: lslave
1071  integer, intent(in) :: omaster
1072  real(kind=kreal), intent(in) :: opos(2)
1073  real(kind=kreal), intent(in) :: odirec(3)
1074  real(kind=kreal), intent(inout) :: b(:)
1075 
1076  integer(kind=kint) :: slave, etype, master
1077  integer(kind=kint) :: nn, j, iSS
1078  real(kind=kreal) :: nrlforce, fcoeff, tangent(3,2)
1079  real(kind=kreal) :: elemcrd(3, l_max_elem_node )
1080  real(kind=kreal) :: shapefunc(l_max_surface_node)
1081  real(kind=kreal) :: metric(2,2), dispmat(2,l_max_elem_node*3+3)
1082  real(kind=kreal) :: fric(2), f3(l_max_elem_node*3+3)
1083  integer(kind=kint) :: i, idx0
1084 
1085  slave = contact%slave(lslave)
1086  fcoeff = contact%fcoeff
1087  ! clear contact force in former contacted element
1088  nrlforce = contact%states(lslave)%multiplier(1)
1089  b(3*slave-2:3*slave) = b(3*slave-2:3*slave)+nrlforce*odirec
1090  nn = size( contact%master(omaster)%nodes )
1091  etype = contact%master(omaster)%etype
1092  call getshapefunc( etype, opos(:), shapefunc )
1093  do j=1,nn
1094  iss = contact%master(omaster)%nodes(j)
1095  ! B(3*iSS-2:3*iSS) = B(3*iSS-2:3*iSS)-nrlforce*shapefunc(j)*odirec
1096  idx0 = 3*(iss-1)
1097  do i=1,3
1098  !$omp atomic
1099  b(idx0+i) = b(idx0+i)-nrlforce*shapefunc(j)*odirec(i)
1100  enddo
1101  enddo
1102  if( fcoeff/=0.d0 ) then
1103  do j=1,nn
1104  iss = contact%master(omaster)%nodes(j)
1105  elemcrd(:,j) = currpos(3*iss-2:3*iss)
1106  enddo
1107  call dispincrematrix( opos(:), etype, nn, elemcrd, tangent, &
1108  metric, dispmat )
1109  fric(1:2) = contact%states(lslave)%multiplier(2:3)
1110  f3(:) = fric(1)*dispmat(1,:)+fric(2)*dispmat(2,:)
1111  b(3*slave-2:3*slave) = b(3*slave-2:3*slave)+f3(1:3)
1112  do j=1,nn
1113  iss = contact%master(omaster)%nodes(j)
1114  ! B(3*iSS-2:3*iSS) = B(3*iSS-2:3*iSS)+f3(3*j+1:3*j+3)
1115  idx0 = 3*(iss-1)
1116  do i=1,3
1117  !$omp atomic
1118  b(idx0+i) = b(idx0+i)+f3(3*j+i)
1119  enddo
1120  enddo
1121  endif
1122 
1123  ! reset contact force in new contacting element
1124  master = contact%states(lslave)%surface
1125  nn = size( contact%master(master)%nodes )
1126  etype = contact%master(master)%etype
1127  call getshapefunc( etype, contact%states(lslave)%lpos(1:2), shapefunc )
1128  b(3*slave-2:3*slave) = b(3*slave-2:3*slave)-nrlforce*contact%states(lslave)%direction
1129  do j=1,nn
1130  iss = contact%master(master)%nodes(j)
1131  ! B(3*iSS-2:3*iSS) = B(3*iSS-2:3*iSS)+nrlforce* &
1132  ! shapefunc(j)*contact%states(lslave)%direction
1133  idx0 = 3*(iss-1)
1134  do i=1,3
1135  !$omp atomic
1136  b(idx0+i) = b(idx0+i)+nrlforce* &
1137  shapefunc(j)*contact%states(lslave)%direction(i)
1138  enddo
1139  enddo
1140  if( fcoeff/=0.d0 ) then
1141  do j=1,nn
1142  iss = contact%master(master)%nodes(j)
1143  elemcrd(:,j) = currpos(3*iss-2:3*iss)
1144  enddo
1145  call dispincrematrix( contact%states(lslave)%lpos(1:2), etype, nn, elemcrd, tangent, &
1146  metric, dispmat )
1147  fric(1:2) = contact%states(lslave)%multiplier(2:3)
1148  f3(:) = fric(1)*dispmat(1,:)+fric(2)*dispmat(2,:)
1149  b(3*slave-2:3*slave) = b(3*slave-2:3*slave)-f3(1:3)
1150  do j=1,nn
1151  iss = contact%master(master)%nodes(j)
1152  ! B(3*iSS-2:3*iSS) = B(3*iSS-2:3*iSS)-f3(3*j+1:3*j+3)
1153  idx0 = 3*(iss-1)
1154  do i=1,3
1155  !$omp atomic
1156  b(idx0+i) = b(idx0+i)-f3(3*j+i)
1157  enddo
1158  enddo
1159  endif
1160 
1161  end subroutine reset_contact_force
1162 
1166  subroutine calcu_contact_force0( contact, coord, disp, ddisp, fcoeff, mu, &
1167  mut, B )
1168  type( tcontact ), intent(inout) :: contact
1169  real(kind=kreal), intent(in) :: coord(:)
1170  real(kind=kreal), intent(in) :: disp(:)
1171  real(kind=kreal), intent(in) :: ddisp(:)
1172  real(kind=kreal), intent(in) :: fcoeff
1173  real(kind=kreal), intent(in) :: mu, mut
1174  real(kind=kreal), intent(inout) :: b(:)
1175 
1176  integer(kind=kint) :: slave, etype, master
1177  integer(kind=kint) :: nn, i, j, iSS
1178  real(kind=kreal) :: nrlforce, elemdisp(3,l_max_elem_node), tangent(3,2)
1179  real(kind=kreal) :: dg(3), elemg(3), elemcrd(3, l_max_elem_node )
1180  real(kind=kreal) :: dgn, dxi(2), dxy(2), shapefunc(l_max_surface_node)
1181  real(kind=kreal) :: metric(2,2), dispmat(2,l_max_elem_node*3+3)
1182  real(kind=kreal) :: fric(2), f3(3*l_max_elem_node+3), edisp(3*l_max_elem_node+3)
1183 
1184  do i= 1, size(contact%slave)
1185  if( contact%states(i)%state==contactfree ) cycle ! not in contact
1186  slave = contact%slave(i)
1187  edisp(1:3) = ddisp(3*slave-2:3*slave)
1188  master = contact%states(i)%surface
1189 
1190  nn = size( contact%master(master)%nodes )
1191  etype = contact%master(master)%etype
1192  do j=1,nn
1193  iss = contact%master(master)%nodes(j)
1194  elemdisp(:,j) = ddisp(3*iss-2:3*iss)
1195  edisp(3*j+1:3*j+3) = ddisp(3*iss-2:3*iss)
1196  elemcrd(:,j) = coord(3*iss-2:3*iss)+disp(3*iss-2:3*iss)
1197  enddo
1198  call getshapefunc( etype, contact%states(i)%lpos(1:2), shapefunc )
1199 
1200  ! normal component
1201  elemg = 0.d0
1202  do j=1,nn
1203  elemg(:) = elemg(:)+shapefunc(j)*elemdisp(:,j)
1204  enddo
1205  dg(:) = ddisp(3*slave-2:3*slave) - elemg(:)
1206  dgn = dot_product( contact%states(i)%direction, dg )
1207  nrlforce = contact%states(i)%multiplier(1)- mu*(contact%states(i)%wkdist-dgn)
1208  b(3*slave-2:3*slave) = b(3*slave-2:3*slave)-nrlforce*contact%states(i)%direction
1209 
1210  do j=1,nn
1211  iss = contact%master(master)%nodes(j)
1212  b(3*iss-2:3*iss) = b(3*iss-2:3*iss)+nrlforce* &
1213  shapefunc(j)*contact%states(i)%direction
1214  enddo
1215 
1216  if( fcoeff==0.d0 ) cycle
1217  ! tangent component
1218  call dispincrematrix( contact%states(i)%lpos(1:2), etype, nn, elemcrd, tangent, &
1219  metric, dispmat )
1220  dxi(1) = dot_product( dispmat(1,1:nn*3+3), edisp(1:nn*3+3) )
1221  dxi(2) = dot_product( dispmat(2,1:nn*3+3), edisp(1:nn*3+3) )
1222  dxy(:) = matmul( metric, dxi )
1223  fric(1:2) = contact%states(i)%multiplier(2:3) + mut*dxy(1:2)
1224  f3(:) = fric(1)*dispmat(1,:)+fric(2)*dispmat(2,:)
1225 
1226  if( contact%states(i)%state==contactslip ) then
1227  dgn = dsqrt( f3(1)*f3(1)+f3(2)*f3(2)+f3(3)*f3(3) )
1228  f3(:) = f3(:)*fcoeff*contact%states(i)%multiplier(1)/dgn
1229  endif
1230  b(3*slave-2:3*slave) = b(3*slave-2:3*slave)-f3(1:3)
1231  do j=1,nn
1232  iss = contact%master(master)%nodes(j)
1233  b(3*iss-2:3*iss) = b(3*iss-2:3*iss)-f3(3*j+1:3*j+3)
1234  enddo
1235  enddo
1236  end subroutine calcu_contact_force0
1237 
1241  subroutine calcu_tied_force0( contact, disp, ddisp, mu, B )
1242  type( tcontact ), intent(inout) :: contact
1243  real(kind=kreal), intent(in) :: disp(:)
1244  real(kind=kreal), intent(in) :: ddisp(:)
1245  real(kind=kreal), intent(in) :: mu
1246  real(kind=kreal), intent(inout) :: b(:)
1247 
1248  integer(kind=kint) :: slave, etype, master
1249  integer(kind=kint) :: nn, i, j, iss
1250  real(kind=kreal) :: nrlforce(3)
1251  real(kind=kreal) :: dg(3)
1252  real(kind=kreal) :: shapefunc(l_max_surface_node)
1253  real(kind=kreal) :: edisp(3*l_max_elem_node+3)
1254 
1255  do i= 1, size(contact%slave)
1256  if( contact%states(i)%state==contactfree ) cycle ! not in contact
1257  slave = contact%slave(i)
1258  edisp(1:3) = disp(3*slave-2:3*slave)+ddisp(3*slave-2:3*slave)
1259  master = contact%states(i)%surface
1260 
1261  nn = size( contact%master(master)%nodes )
1262  etype = contact%master(master)%etype
1263  do j=1,nn
1264  iss = contact%master(master)%nodes(j)
1265  edisp(3*j+1:3*j+3) = disp(3*iss-2:3*iss)+ddisp(3*iss-2:3*iss)
1266  enddo
1267  call getshapefunc( etype, contact%states(i)%lpos(1:2), shapefunc )
1268 
1269  ! normal component
1270  dg(1:3) = edisp(1:3)
1271  do j=1,nn
1272  dg(1:3) = dg(1:3)-shapefunc(j)*edisp(3*j+1:3*j+3)
1273  enddo
1274 
1275  nrlforce(1:3) = contact%states(i)%multiplier(1:3)+mu*dg(1:3)
1276 
1277  b(3*slave-2:3*slave) = b(3*slave-2:3*slave)-nrlforce(1:3)
1278  do j=1,nn
1279  iss = contact%master(master)%nodes(j)
1280  b(3*iss-2:3*iss) = b(3*iss-2:3*iss) + shapefunc(j)*nrlforce(1:3)
1281  enddo
1282  enddo
1283 
1284  end subroutine
1285 
1288  subroutine update_contact_multiplier( contact, coord, disp, ddisp, fcoeff, mu, mut, &
1289  gnt, ctchanged )
1290  type( tcontact ), intent(inout) :: contact
1291  real(kind=kreal), intent(in) :: coord(:)
1292  real(kind=kreal), intent(in) :: disp(:)
1293  real(kind=kreal), intent(in) :: ddisp(:)
1294  real(kind=kreal), intent(in) :: fcoeff
1295  real(kind=kreal), intent(in) :: mu, mut
1296  real(kind=kreal), intent(out) :: gnt(2)
1297  logical, intent(inout) :: ctchanged
1298 
1299  integer(kind=kint) :: slave, etype, master
1300  integer(kind=kint) :: nn, i, j, iss, cnt
1301  real(kind=kreal) :: elemdisp(3,l_max_elem_node), tangent(3,2)
1302  real(kind=kreal) :: dg(3), elemg(3), elemcrd(3, l_max_elem_node )
1303  real(kind=kreal) :: dgn, dxi(2), dxy(2), shapefunc(l_max_surface_node)
1304  real(kind=kreal) :: metric(2,2), dispmat(2,l_max_elem_node*3+3)
1305  real(kind=kreal) :: lgnt(2), fric(2), f3(3*l_max_elem_node+3), edisp(3*l_max_elem_node+3)
1306 
1307  cnt =0; lgnt(:)=0.d0
1308  do i= 1, size(contact%slave)
1309  if( contact%states(i)%state==contactfree ) cycle ! not in contact
1310  slave = contact%slave(i)
1311  edisp(1:3) = ddisp(3*slave-2:3*slave)
1312  master = contact%states(i)%surface
1313 
1314  nn = size( contact%master(master)%nodes )
1315  etype = contact%master(master)%etype
1316  do j=1,nn
1317  iss = contact%master(master)%nodes(j)
1318  elemdisp(:,j) = ddisp(3*iss-2:3*iss)
1319  edisp(3*j+1:3*j+3) = ddisp(3*iss-2:3*iss)
1320  elemcrd(:,j) = coord(3*iss-2:3*iss)+disp(3*iss-2:3*iss)
1321  enddo
1322  call getshapefunc( etype, contact%states(i)%lpos(1:2), shapefunc )
1323 
1324  ! normal component
1325  elemg = 0.d0
1326  do j=1,nn
1327  elemg(:) = elemg(:)+shapefunc(j)*elemdisp(:,j)
1328  enddo
1329  dg(:) = ddisp(3*slave-2:3*slave) - elemg(:)
1330  dgn = dot_product( contact%states(i)%direction, dg )
1331  contact%states(i)%wkdist = contact%states(i)%wkdist-dgn
1332  contact%states(i)%multiplier(1) = contact%states(i)%multiplier(1)- mu*contact%states(i)%wkdist
1333  contact%states(i)%distance = contact%states(i)%distance - dgn
1334  cnt = cnt+1
1335  lgnt(1) = lgnt(1)- contact%states(i)%wkdist
1336 
1337  if( fcoeff==0.d0 ) cycle
1338  ! tangent component
1339  call dispincrematrix( contact%states(i)%lpos(1:2), etype, nn, elemcrd, tangent, &
1340  metric, dispmat )
1341  dxi(1) = dot_product( dispmat(1,1:nn*3+3), edisp(1:nn*3+3) )
1342  dxi(2) = dot_product( dispmat(2,1:nn*3+3), edisp(1:nn*3+3) )
1343  dxy(:) = matmul( metric, dxi )
1344  fric(1:2) = contact%states(i)%multiplier(2:3) + mut*dxy(1:2)
1345  f3(:) = fric(1)*dispmat(1,:)+fric(2)*dispmat(2,:)
1346  dgn = dsqrt( f3(1)*f3(1)+f3(2)*f3(2)+f3(3)*f3(3) )
1347  if( contact%states(i)%multiplier(1)>0.d0 ) then
1348  if( dgn > fcoeff*contact%states(i)%multiplier(1) ) then
1349  if( contact%states(i)%state==contactstick ) then
1350  ctchanged= .true.
1351  print *, "Node", slave, "to slip state",dgn, fcoeff*contact%states(i)%multiplier(1)
1352  endif
1353  contact%states(i)%state = contactslip
1354  fric(:) = fric(:)*fcoeff*contact%states(i)%multiplier(1)/dgn
1355  else
1356  if( contact%states(i)%state==contactslip ) then
1357  ctchanged= .true.
1358  print *, "Node", slave, "to stick state",dgn, fcoeff*contact%states(i)%multiplier(1)
1359  endif
1360  contact%states(i)%state = contactstick
1361  endif
1362  endif
1363  contact%states(i)%multiplier(2:3) = fric(:)
1364  dxy(:) = matmul( dg, tangent )
1365  lgnt(2) = lgnt(2)+dsqrt( dxy(1)*dxy(1)+dxy(2)*dxy(2) )
1366  enddo
1367  if(cnt>0) lgnt(:) = lgnt(:)/cnt
1368  gnt = gnt + lgnt
1369  end subroutine update_contact_multiplier
1370 
1373  subroutine update_tied_multiplier( contact, disp, ddisp, mu, ctchanged )
1374  type( tcontact ), intent(inout) :: contact
1375  real(kind=kreal), intent(in) :: disp(:)
1376  real(kind=kreal), intent(in) :: ddisp(:)
1377  real(kind=kreal), intent(in) :: mu
1378  logical, intent(inout) :: ctchanged
1379 
1380  integer(kind=kint) :: slave, etype, master
1381  integer(kind=kint) :: nn, i, j, iss, cnt
1382  real(kind=kreal) :: dg(3), dgmax
1383  real(kind=kreal) :: shapefunc(l_max_surface_node)
1384  real(kind=kreal) :: edisp(3*l_max_elem_node+3)
1385 
1386  do i= 1, size(contact%slave)
1387  if( contact%states(i)%state==contactfree ) cycle ! not in contact
1388  slave = contact%slave(i)
1389  edisp(1:3) = disp(3*slave-2:3*slave)+ddisp(3*slave-2:3*slave)
1390  master = contact%states(i)%surface
1391 
1392  nn = size( contact%master(master)%nodes )
1393  etype = contact%master(master)%etype
1394  do j=1,nn
1395  iss = contact%master(master)%nodes(j)
1396  edisp(3*j+1:3*j+3) = disp(3*iss-2:3*iss)+ddisp(3*iss-2:3*iss)
1397  enddo
1398  call getshapefunc( etype, contact%states(i)%lpos(1:2), shapefunc )
1399 
1400  ! normal component
1401  dg(1:3) = edisp(1:3)
1402  do j=1,nn
1403  dg(1:3) = dg(1:3)-shapefunc(j)*edisp(3*j+1:3*j+3)
1404  enddo
1405 
1406  contact%states(i)%multiplier(1:3) = contact%states(i)%multiplier(1:3) + mu*dg(1:3)
1407 
1408  ! check if tied constraint converged
1409  dgmax = 0.d0
1410  do j=1,(nn+1)*3
1411  dgmax = dgmax + dabs(edisp(j))
1412  enddo
1413  dgmax = dgmax/dble((nn+1)*3)
1414  do j=1,3
1415  if( dabs(dg(j))/dmax1(1.d0,dgmax) > 1.d-3 ) ctchanged = .true.
1416  enddo
1417 
1418  enddo
1419  end subroutine
1420 
1422  subroutine ass_contact_force( contact, coord, disp, B )
1423  type( tcontact ), intent(in) :: contact
1424  real(kind=kreal), intent(in) :: coord(:)
1425  real(kind=kreal), intent(in) :: disp(:)
1426  real(kind=kreal), intent(inout) :: b(:)
1427 
1428  integer(kind=kint) :: slave, etype, master
1429  integer(kind=kint) :: nn, i, j, iss
1430  real(kind=kreal) :: fcoeff, nrlforce, tangent(3,2)
1431  real(kind=kreal) :: elemcrd(3, l_max_elem_node )
1432  real(kind=kreal) :: shapefunc(l_max_surface_node)
1433  real(kind=kreal) :: metric(2,2), dispmat(2,l_max_elem_node*3+3)
1434  real(kind=kreal) :: fric(2), f3(l_max_elem_node*3+3)
1435  fcoeff = contact%fcoeff
1436  do i= 1, size(contact%slave)
1437  if( contact%states(i)%state==contactfree ) cycle ! not in contact
1438  slave = contact%slave(i)
1439  master = contact%states(i)%surface
1440 
1441  nn = size( contact%master(master)%nodes )
1442  etype = contact%master(master)%etype
1443  call getshapefunc( etype, contact%states(i)%lpos(1:2), shapefunc )
1444 
1445  ! normal component
1446  nrlforce = contact%states(i)%multiplier(1)
1447  b(3*slave-2:3*slave) = b(3*slave-2:3*slave)-nrlforce*contact%states(i)%direction
1448 
1449  do j=1,nn
1450  iss = contact%master(master)%nodes(j)
1451  b(3*iss-2:3*iss) = b(3*iss-2:3*iss)+nrlforce* &
1452  shapefunc(j)*contact%states(i)%direction
1453  enddo
1454 
1455  if( fcoeff==0.d0 ) cycle
1456  ! tangent component
1457  do j=1,nn
1458  iss = contact%master(master)%nodes(j)
1459  elemcrd(:,j) = coord(3*iss-2:3*iss)+disp(3*iss-2:3*iss)
1460  enddo
1461  call dispincrematrix( contact%states(i)%lpos(1:2), etype, nn, elemcrd, tangent, &
1462  metric, dispmat )
1463 
1464  fric(1:2) = contact%states(i)%multiplier(2:3)
1465  f3(:) = fric(1)*dispmat(1,:)+fric(2)*dispmat(2,:)
1466  b(3*slave-2:3*slave) = b(3*slave-2:3*slave)-f3(1:3)
1467  do j=1,nn
1468  iss = contact%master(master)%nodes(j)
1469  b(3*iss-2:3*iss) = b(3*iss-2:3*iss)-f3(3*j+1:3*j+3)
1470  enddo
1471  enddo
1472 
1473  end subroutine ass_contact_force
1474 
1476  subroutine set_contact_state_vector( contact, dt, relvel_vec, state_vec )
1477  type( tcontact ), intent(in) :: contact
1478  real(kind=kreal), intent(in) :: dt
1479  real(kind=kreal), intent(inout) :: relvel_vec(:)
1480  real(kind=kreal), intent(inout) :: state_vec(:)
1481 
1482  integer(kind=kint) :: i, slave
1483 
1484  do i= 1, size(contact%slave)
1485  slave = contact%slave(i)
1486  if( state_vec(slave) < 0.1d0 .or. contact%states(i)%state > 0 ) &
1487  & state_vec(slave) = dble(contact%states(i)%state)
1488 
1489  if( contact%states(i)%state==contactfree ) cycle ! not in contact
1490  if( dt < 1.d-16 ) cycle ! too small delta t
1491  relvel_vec(3*slave-2:3*slave) = contact%states(i)%reldisp(1:3)/dt
1492  enddo
1493 
1494  end subroutine set_contact_state_vector
1495 
1496  subroutine update_contact_tangentforce( contact )
1497  type( tcontact ), intent(inout) :: contact
1498 
1499  integer(kind=kint) :: i
1500 
1501  do i= 1, size(contact%slave)
1502  if( contact%states(i)%state==contactfree ) then
1503  contact%states(i)%tangentForce(1:3) = 0.d0
1504  contact%states(i)%tangentForce_trial(1:3) = 0.d0
1505  contact%states(i)%tangentForce_final(1:3) = 0.d0
1506  else
1507  contact%states(i)%tangentForce(1:3) = contact%states(i)%tangentForce_final(1:3)
1508  end if
1509  contact%states(i)%tangentForce1(1:3) = contact%states(i)%tangentForce(1:3)
1510  enddo
1511  end subroutine update_contact_tangentforce
1512 
1514  subroutine track_contact_position_exp( nslave, contact, currpos, currdisp, infoCTChange, nodeID, elemID )
1515  integer, intent(in) :: nslave
1516  type( tcontact ), intent(inout) :: contact
1517  type( fstr_info_contactchange ), intent(inout) :: infoCTChange
1518  real(kind=kreal), intent(in) :: currpos(:)
1519  real(kind=kreal), intent(in) :: currdisp(:)
1520  integer(kind=kint), intent(in) :: nodeID(:)
1521  integer(kind=kint), intent(in) :: elemID(:)
1522 
1523  integer(kind=kint) :: slave, sid0, sid, etype
1524  integer(kind=kint) :: nn, i, j, iSS
1525  real(kind=kreal) :: coord(3), elem(3, l_max_elem_node ), elem0(3, l_max_elem_node )
1526  logical :: isin
1527  real(kind=kreal) :: opos(2), odirec(3)
1528  integer(kind=kint) :: bktID, nCand, idm
1529  integer(kind=kint), allocatable :: indexCand(:)
1530 
1531  sid = 0
1532 
1533  slave = contact%slave(nslave)
1534  coord(:) = currpos(3*slave-2:3*slave)
1536  sid0 = contact%states(nslave)%surface
1537  opos = contact%states(nslave)%lpos(1:2)
1538  odirec = contact%states(nslave)%direction
1539  etype = contact%master(sid0)%etype
1540  nn = getnumberofnodes( etype )
1541  do j=1,nn
1542  iss = contact%master(sid0)%nodes(j)
1543  elem(1:3,j)=currpos(3*iss-2:3*iss)
1544  elem0(1:3,j)=currpos(3*iss-2:3*iss)-currdisp(3*iss-2:3*iss)
1545  enddo
1546  call project_point2element( coord,etype,nn,elem,contact%master(sid0)%reflen,contact%states(nslave), &
1547  isin,contact%cparam%DISTCLR_NOCHECK,contact%states(nslave)%lpos(1:2),contact%cparam%CLR_SAME_ELEM )
1548  if( .not. isin ) then
1549  do i=1, contact%master(sid0)%n_neighbor
1550  sid = contact%master(sid0)%neighbor(i)
1551  etype = contact%master(sid)%etype
1552  nn = getnumberofnodes( etype )
1553  do j=1,nn
1554  iss = contact%master(sid)%nodes(j)
1555  elem(1:3,j)=currpos(3*iss-2:3*iss)
1556  enddo
1557  call project_point2element( coord,etype,nn,elem,contact%master(sid)%reflen,contact%states(nslave), &
1558  isin,contact%cparam%DISTCLR_NOCHECK,localclr=contact%cparam%CLEARANCE )
1559  if( isin ) then
1560  contact%states(nslave)%surface = sid
1561  exit
1562  endif
1563  enddo
1564  endif
1565 
1566  if( .not. isin ) then ! such case is considered to rarely or never occur
1567  write(*,*) 'Warning: contact moved beyond neighbor elements'
1568  ! get master candidates from bucketDB
1569  bktid = bucketdb_getbucketid(contact%master_bktDB, coord)
1570  ncand = bucketdb_getnumcand(contact%master_bktDB, bktid)
1571  if (ncand > 0) then
1572  allocate(indexcand(ncand))
1573  call bucketdb_getcand(contact%master_bktDB, bktid, ncand, indexcand)
1574  do idm= 1, ncand
1575  sid = indexcand(idm)
1576  if( sid==sid0 ) cycle
1577  if( any(sid==contact%master(sid0)%neighbor(:)) ) cycle
1578  if (.not. is_in_surface_box( contact%master(sid), coord(1:3), contact%cparam%BOX_EXP_RATE )) cycle
1579  etype = contact%master(sid)%etype
1580  nn = size( contact%master(sid)%nodes )
1581  do j=1,nn
1582  iss = contact%master(sid)%nodes(j)
1583  elem(1:3,j)=currpos(3*iss-2:3*iss)
1584  enddo
1585  call project_point2element( coord,etype,nn,elem,contact%master(sid)%reflen,contact%states(nslave), &
1586  isin,contact%cparam%DISTCLR_NOCHECK,localclr=contact%cparam%CLEARANCE )
1587  if( isin ) then
1588  contact%states(nslave)%surface = sid
1589  exit
1590  endif
1591  enddo
1592  deallocate(indexcand)
1593  endif
1594  endif
1595 
1596  if( isin ) then
1597  if( contact%states(nslave)%surface==sid0 ) then
1598  if(any(dabs(contact%states(nslave)%lpos(1:2)-opos(:)) >= contact%cparam%CLR_DIFFLPOS)) then
1599  !$omp atomic
1600  infoctchange%contact2difflpos = infoctchange%contact2difflpos + 1
1601  endif
1602  else
1603  write(*,'(A,i10,A,i10,A,f7.3,A,2f7.3)') "Node",nodeid(slave)," move to contact with", &
1604  elemid(contact%master(sid)%eid), " with distance ", &
1605  contact%states(nslave)%distance," at ",contact%states(nslave)%lpos(1:2)
1606  !$omp atomic
1607  infoctchange%contact2neighbor = infoctchange%contact2neighbor + 1
1608  endif
1609  iss = isinsideelement( etype, contact%states(nslave)%lpos(1:2), contact%cparam%CLR_CAL_NORM )
1610  if( iss>0 ) then
1611  call cal_node_normal( contact%states(nslave)%surface, iss, contact%master, currpos, &
1612  contact%states(nslave)%lpos(1:2), contact%states(nslave)%direction(:) )
1613  endif
1614  else if( .not. isin ) then
1615  write(*,'(A,i10,A)') "Node",nodeid(slave)," move out of contact"
1616  contact%states(nslave)%state = contactfree
1617  contact%states(nslave)%multiplier(:) = 0.d0
1618  endif
1619 
1620  end subroutine track_contact_position_exp
1621 
1625  subroutine scan_contact_state_exp( contact, currpos, currdisp, infoCTChange, &
1626  nodeID, elemID, is_init, active )
1627  type( tcontact ), intent(inout) :: contact
1628  type( fstr_info_contactchange ), intent(inout) :: infoCTChange
1629  real(kind=kreal), intent(in) :: currpos(:)
1630  real(kind=kreal), intent(in) :: currdisp(:)
1631  integer(kind=kint), intent(in) :: nodeID(:)
1632  integer(kind=kint), intent(in) :: elemID(:)
1633  logical, intent(in) :: is_init
1634  logical, intent(out) :: active
1635 
1636  real(kind=kreal) :: distclr
1637  integer(kind=kint) :: slave, id, etype
1638  integer(kind=kint) :: nn, i, j, iSS, nactive
1639  real(kind=kreal) :: coord(3), elem(3, l_max_elem_node )
1640  real(kind=kreal) :: nlforce
1641  logical :: isin
1642  integer(kind=kint), allocatable :: contact_surf(:), states_prev(:)
1643  !
1644  integer, pointer :: indexMaster(:),indexCand(:)
1645  integer :: nMaster,idm,nMasterMax,bktID,nCand
1646  logical :: is_cand
1647 
1648  if( is_init ) then
1649  distclr = contact%cparam%DISTCLR_INIT
1650  else
1651  distclr = contact%cparam%DISTCLR_FREE
1652  if( contact%algtype == contacttied ) then
1653  active = .false.
1654  do i= 1, size(contact%slave)
1655  if( contact%states(i)%state==contactstick ) then
1656  active = .true.
1657  exit
1658  endif
1659  enddo
1660  return
1661  endif
1662  endif
1663 
1664  allocate(contact_surf(size(nodeid)))
1665  allocate(states_prev(size(contact%slave)))
1666  contact_surf(:) = size(elemid)+1
1667  do i = 1, size(contact%slave)
1668  states_prev(i) = contact%states(i)%state
1669  enddo
1670 
1671  call update_surface_box_info( contact%master, currpos )
1672  call update_surface_bucket_info( contact%master, contact%master_bktDB )
1673 
1674  !$omp parallel do &
1675  !$omp& default(none) &
1676  !$omp& private(i,slave,id,nlforce,coord,indexMaster,nMaster,nn,j,iSS,elem,is_cand,idm,etype,isin, &
1677  !$omp& bktID,nCand,indexCand) &
1678  !$omp& firstprivate(nMasterMax) &
1679  !$omp& shared(contact,infoCTChange,currpos,currdisp,nodeID,elemID,distclr,contact_surf) &
1680  !$omp& reduction(.or.:active) &
1681  !$omp& schedule(dynamic,1)
1682  do i= 1, size(contact%slave)
1683  slave = contact%slave(i)
1684  if( contact%states(i)%state==contactstick .or. contact%states(i)%state==contactslip ) then
1685  call track_contact_position_exp( i, contact, currpos, currdisp, infoctchange, nodeid, elemid )
1686  if( contact%states(i)%state /= contactfree ) then
1687  contact_surf(contact%slave(i)) = -contact%states(i)%surface
1688  endif
1689  else if( contact%states(i)%state==contactfree ) then
1690  coord(:) = currpos(3*slave-2:3*slave)
1691 
1692  ! get master candidates from bucketDB
1693  bktid = bucketdb_getbucketid(contact%master_bktDB, coord)
1694  ncand = bucketdb_getnumcand(contact%master_bktDB, bktid)
1695  if (ncand == 0) cycle
1696  allocate(indexcand(ncand))
1697  call bucketdb_getcand(contact%master_bktDB, bktid, ncand, indexcand)
1698 
1699  nmastermax = ncand
1700  allocate(indexmaster(nmastermax))
1701  nmaster = 0
1702 
1703  ! narrow down candidates
1704  do idm= 1, ncand
1705  id = indexcand(idm)
1706  if (.not. is_in_surface_box( contact%master(id), coord(1:3), contact%cparam%BOX_EXP_RATE )) cycle
1707  nmaster = nmaster + 1
1708  indexmaster(nmaster) = id
1709  enddo
1710  deallocate(indexcand)
1711 
1712  if(nmaster == 0) then
1713  deallocate(indexmaster)
1714  cycle
1715  endif
1716 
1717  do idm = 1,nmaster
1718  id = indexmaster(idm)
1719  etype = contact%master(id)%etype
1720  nn = size( contact%master(id)%nodes )
1721  do j=1,nn
1722  iss = contact%master(id)%nodes(j)
1723  elem(1:3,j)=currpos(3*iss-2:3*iss)
1724  enddo
1725  call project_point2element( coord,etype,nn,elem,contact%master(id)%reflen,contact%states(i), &
1726  isin,distclr,localclr=contact%cparam%CLEARANCE )
1727  if( .not. isin ) cycle
1728  contact%states(i)%surface = id
1729  contact%states(i)%multiplier(:) = 0.d0
1730  iss = isinsideelement( etype, contact%states(i)%lpos(1:2), contact%cparam%CLR_CAL_NORM )
1731  if( iss>0 ) &
1732  call cal_node_normal( id, iss, contact%master, currpos, contact%states(i)%lpos(1:2), &
1733  contact%states(i)%direction(:) )
1734  contact_surf(contact%slave(i)) = id
1735  write(*,'(A,i10,A,i10,A,f7.3,A,2f7.3,A,3f7.3)') "Node",nodeid(slave)," contact with element", &
1736  elemid(contact%master(id)%eid), &
1737  " with distance ", contact%states(i)%distance," at ",contact%states(i)%lpos(1:2), &
1738  " along direction ", contact%states(i)%direction
1739  exit
1740  enddo
1741  deallocate(indexmaster)
1742  endif
1743  enddo
1744  !$omp end parallel do
1745 
1746  call hecmw_contact_comm_allreduce_i(contact%comm, contact_surf, hecmw_min)
1747  nactive = 0
1748  do i = 1, size(contact%slave)
1749  if (contact%states(i)%state /= contactfree) then ! any slave in contact
1750  if (abs(contact_surf(contact%slave(i))) /= contact%states(i)%surface) then ! that is in contact with other surface
1751  contact%states(i)%state = contactfree ! should be freed
1752  write(*,'(A,i10,A,i6,A,i6,A)') "Node",nodeid(contact%slave(i)), &
1753  " in rank",hecmw_comm_get_rank()," freed due to duplication"
1754  else
1755  nactive = nactive + 1
1756  endif
1757  endif
1758  if (states_prev(i) == contactfree .and. contact%states(i)%state /= contactfree) then
1759  infoctchange%free2contact = infoctchange%free2contact + 1
1760  elseif (states_prev(i) /= contactfree .and. contact%states(i)%state == contactfree) then
1761  infoctchange%contact2free = infoctchange%contact2free + 1
1762  endif
1763  enddo
1764  active = (nactive > 0)
1765  deallocate(contact_surf)
1766  deallocate(states_prev)
1767  end subroutine scan_contact_state_exp
1768 
1769 end module mcontactdef
This module provides bucket-search functionality It provides definition of bucket info and its access...
integer(kind=kint) function, public bucketdb_getbucketid(bktdb, x)
Get bucket ID that includes given point.
subroutine, public bucketdb_finalize(bktdb)
Finalizer.
integer(kind=kint) function, public bucketdb_getnumcand(bktdb, bid)
Get number of candidates within neighboring buckets of a given bucket Bucket ID has to be obtained wi...
subroutine, public bucketdb_init(bktdb)
Initializer.
subroutine, public bucketdb_getcand(bktdb, bid, ncand, cand)
Get candidates within neighboring buckets of a given bucket Number of candidates has to be obtained w...
This module encapsulate the basic functions of all elements provide by this software.
Definition: element.f90:43
subroutine getvertexcoord(fetype, cnode, localcoord)
Get the natural coord of a vertex node.
Definition: element.f90:1136
real(kind=kreal) function, dimension(3) surfacenormal(fetype, nn, localcoord, elecoord)
Calculate normal of 3d-surface.
Definition: element.f90:870
Definition: hecmw.f90:6
This module provide functions of contact stiffness calculation.
Definition: contact_lib.f90:6
integer, parameter contacttied
contact type or algorithm definition
Definition: contact_lib.f90:21
integer, parameter contactfslid
Definition: contact_lib.f90:24
subroutine project_point2solidelement(xyz, etype, nn, elemt, reflen, cstate, isin, distclr, ctpos, localclr)
This subroutine find the projection of a slave point onto master surface.
subroutine project_point2element(xyz, etype, nn, elemt, reflen, cstate, isin, distclr, ctpos, localclr)
This subroutine find the projection of a slave point onto master surface.
subroutine update_tangentforce(etype, nn, elemt0, elemt, cstate)
This subroutine find the projection of a slave point onto master surface.
subroutine contact_state_init(cstate)
Initializer.
Definition: contact_lib.f90:57
subroutine set_shrink_factor(ctime, cstate, etime, if_type)
integer, parameter contactslip
Definition: contact_lib.f90:18
integer, parameter contactfree
contact state definition
Definition: contact_lib.f90:16
integer, parameter c_if_slave
contact interference type
Definition: contact_lib.f90:27
subroutine dispincrematrix(pos, etype, nnode, ele, tangent, tensor, matrix)
This subroutine calculate the relation between global disp and displacement along natural coordinate ...
integer, parameter contactstick
Definition: contact_lib.f90:17
subroutine, public hecmw_contact_comm_allreduce_i(conComm, vec, op)
subroutine, public hecmw_contact_comm_init(conComm, hecMESH, ndof, n_contact_dof, contact_dofs)
subroutine, public hecmw_contact_comm_finalize(conComm)
This module manages the data structure for contact calculation.
subroutine set_contact_state_vector(contact, dt, relvel_vec, state_vec)
This subroutine setup contact output nodal vectors.
subroutine update_contact_multiplier(contact, coord, disp, ddisp, fcoeff, mu, mut, gnt, ctchanged)
This subroutine update lagrangian multiplier and the distance between contacting nodes.
integer(kind=kint) function check_apply_contact_if(contact_if, contacts)
subroutine update_tied_multiplier(contact, disp, ddisp, mu, ctchanged)
This subroutine update lagrangian multiplier and the distance between contacting nodes.
logical function fstr_contact_check(contact, hecMESH)
Check the consistency with given mesh of contact definition.
subroutine clear_contact_state(contact)
Reset contact state all to free.
subroutine update_contact_tangentforce(contact)
subroutine track_contact_position_exp(nslave, contact, currpos, currdisp, infoCTChange, nodeID, elemID)
This subroutine tracks down next contact position after a finite slide.
subroutine scan_contact_state_exp(contact, currpos, currdisp, infoCTChange, nodeID, elemID, is_init, active)
This subroutine update contact states, which include.
subroutine scan_embed_state(flag_ctAlgo, embed, currpos, currdisp, ndforce, infoCTChange, nodeID, elemID, is_init, active, mu, B)
This subroutine update contact states, which include.
subroutine fstr_write_contact(file, contact)
Write out contact definition.
subroutine fstr_contact_finalize(contact)
Finalizer.
subroutine update_direction(nslave, contact, currpos)
This subroutine tracks down next contact position after a finite slide.
logical function fstr_embed_init(embed, hecMESH, cparam, myrank)
Initializer of tContactState for embed case.
subroutine ass_contact_force(contact, coord, disp, B)
This subroutine assemble contact force into contacing nodes.
subroutine calcu_contact_force0(contact, coord, disp, ddisp, fcoeff, mu, mut, B)
This subroutine updates contact condition as follows:
subroutine scan_contact_state(flag_ctAlgo, contact, currpos, currdisp, ndforce, infoCTChange, nodeID, elemID, is_init, active, mu, B)
This subroutine update contact states, which include.
logical function fstr_contact_init(contact, hecMESH, cparam, myrank)
Initializer of tContactState.
subroutine calcu_tied_force0(contact, disp, ddisp, mu, B)
This subroutine updates contact condition as follows:
This module manage the parameters for contact calculation.
This module manages surface elements in 3D It provides basic definition of surface elements (triangla...
Definition: surf_ele.f90:8
subroutine initialize_surf(eid, etype, nsurf, surf)
Initializer.
Definition: surf_ele.f90:38
subroutine update_surface_reflen(surf, coord)
Compute reference length of surface elements.
Definition: surf_ele.f90:220
subroutine write_surf(file, surf)
Write out elemental surface.
Definition: surf_ele.f90:76
subroutine update_surface_box_info(surf, currpos)
Update info of cubic box including surface elements.
Definition: surf_ele.f90:240
subroutine find_surface_neighbor(surf, bktDB)
Find neighboring surface elements.
Definition: surf_ele.f90:88
subroutine update_surface_bucket_info(surf, bktDB)
Update bucket info for searching surface elements.
Definition: surf_ele.f90:280
subroutine finalize_surf(surf)
Memory management subroutine.
Definition: surf_ele.f90:69
logical function is_in_surface_box(surf, x0, exp_rate)
Check if given point is within cubic box including surface element.
Definition: surf_ele.f90:265
This structure records contact status.
Definition: contact_lib.f90:30
Structure to includes all info needed by contact calculation.
Structure to define surface group.
Definition: surf_ele.f90:19