OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
check_remote_surface_state.F File Reference
#include "implicit_f.inc"
#include "spmd.inc"
#include "task_c.inc"
#include "com04_c.inc"
#include "scr17_c.inc"
#include "param_c.inc"
#include "com01_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine check_remote_surface_state (surfarce_nb, surface_id, shift_interface, intbuf_tab, ipari, iad_elem, shoot_struct)

Function/Subroutine Documentation

◆ check_remote_surface_state()

subroutine check_remote_surface_state ( integer, intent(in) surfarce_nb,
integer, dimension(surfarce_nb), intent(in) surface_id,
integer, dimension(ninter+1,2), intent(in) shift_interface,
type(intbuf_struct_), dimension(ninter), intent(inout) intbuf_tab,
integer, dimension(npari,ninter), intent(in) ipari,
integer, dimension(2,nspmd+1), intent(in) iad_elem,
type(shooting_node_type), intent(inout) shoot_struct )

Definition at line 39 of file check_remote_surface_state.F.

41!$COMMENT
42! CHECK_SURFACE_STATE description
43! deactivation of surface from an interface
44! CHECK_SURFACE_STATE organization
45!$ENDCOMMENT
46 USE intbufdef_mod
47 USE shooting_node_mod
48 USE array_mod
49 use remove_neighbour_segment_mod , only : remove_neighbour_segment
50C-----------------------------------------------
51C I m p l i c i t T y p e s
52C-----------------------------------------------
53 USE spmd_comm_world_mod, ONLY : spmd_comm_world
54#include "implicit_f.inc"
55C-----------------------------------------------
56C M e s s a g e P a s s i n g
57C-----------------------------------------------
58#include "spmd.inc"
59C-----------------------------------------------
60C C o m m o n B l o c k s
61C-----------------------------------------------
62#include "task_c.inc"
63#include "com04_c.inc"
64#include "scr17_c.inc"
65#include "param_c.inc"
66
67
68#include "com01_c.inc"
69C-----------------------------------------------
70C D u m m y A r g u m e n t s
71C-----------------------------------------------
72 INTEGER, INTENT(in) :: SURFARCE_NB ! number of local deactivated surface
73 INTEGER, DIMENSION(SURFARCE_NB), INTENT(in) :: SURFACE_ID ! id of surface that need to be deactivated
74 INTEGER, DIMENSION(NINTER+1,2), INTENT(in) :: SHIFT_INTERFACE ! interface shift
75 TYPE(INTBUF_STRUCT_), DIMENSION(NINTER), INTENT(inout) :: INTBUF_TAB ! interface data
76 INTEGER, DIMENSION(NPARI,NINTER), INTENT(in) :: IPARI
77 INTEGER, DIMENSION(2,NSPMD+1), INTENT(in) :: IAD_ELEM ! index for frontier elements
78 TYPE(shooting_node_type), INTENT(inout) :: SHOOT_STRUCT ! structure for shooting node algo
79C-----------------------------------------------
80C L o c a l V a r i a b l e s
81C-----------------------------------------------
82 INTEGER :: I,K,J,IJK,FIRST,LAST
83 INTEGER :: NIN,ID_INTER,NUMBER_INTER,NRTM ! related to the surface : interface id, number of surface...
84 INTEGER :: ITY,IDEL
85 INTEGER :: NODE_ID
86 INTEGER :: SHIFT
87 INTEGER :: DICHOTOMIC_SEARCH_I_ASC ! function
88 TYPE(array_type), DIMENSION(:), ALLOCATABLE :: S_BUFFER
89 TYPE(array_type), DIMENSION(:), ALLOCATABLE :: R_BUFFER
90
91 INTEGER :: GLOBAL_SURFACE_ID ! global surface id
92 INTEGER :: PROC_ID,REMOTE_PROC ! processor id and remote processor id
93 INTEGER :: NB_PROC ! number of processor
94 INTEGER :: FRONTIER_ELM ! number of frontier elements between 2 processors
95 INTEGER, DIMENSION(NSPMD) :: NUMBER_REMOTE_SURF,NUMBER_REMOTE_SURF_R ! number of remote surface per proc
96 LOGICAL, DIMENSION(NSPMD) :: ALREADY_DONE ! boolean to avoid to send 2 times the same surface
97
98 INTEGER :: IERROR ! error for mpi commm
99 INTEGER :: MSGTYP,MSGOFF1,MSGOFF2 ! mpi message id
100 INTEGER :: RECV_NB,RECV_NB_2 ! number of received message
101 INTEGER :: SIZE_R,SIZE_S ! size of mpi message
102 INTEGER, DIMENSION(NSPMD) :: INDEX_R_PROC,INDEX_R_PROC_2 ! index of processor for rcv comm
103 INTEGER, DIMENSION(NSPMD) :: REQUEST_SIZE_R,REQUEST_SIZE_R_2 ! array of request : rcv
104 INTEGER, DIMENSION(NSPMD) :: REQUEST_SIZE_S,REQUEST_SIZE_S_2 ! array of request : send
105#ifdef MPI
106 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: STATUS_MPI
107 INTEGER, DIMENSION(MPI_STATUS_SIZE,NSPMD) :: ARRAY_STATUSES
108#endif
109 DATA msgoff1/13014/
110 DATA msgoff2/13015/
111C-----------------------------------------------
112 first = 1
113 last = surfarce_nb
114 number_inter = shift_interface(ninter+1,2)
115
116 ALLOCATE( s_buffer(nspmd), r_buffer(nspmd) )
117 s_buffer(1:nspmd)%SIZE_INT_ARRAY_2D(1) = 2
118 s_buffer(1:nspmd)%SIZE_INT_ARRAY_2D(2) = surfarce_nb
119 number_remote_surf(1:nspmd) = 0
120
121 ! --------------------------
122 ! loop over the deactivated surface
123 DO i=first,last
124 k = surface_id(i) ! get the global surface id
125 id_inter = dichotomic_search_i_asc(k, shift_interface(1,1), number_inter+1) ! find the interface of the surface
126 nin = shift_interface(id_inter,2)
127 k = k - shift_interface(id_inter,1) + 1 ! get the surface id in the NIN interface
128 ity = ipari(7,nin)
129 idel = ipari(17,nin)
130 nrtm = ipari(4,nin)
131 ! *----*----*----* 1/2/3 surfaces need to deactivate the neighbouring deleted surface
132 ! | 1 | | | the deleted surface must be deactivate
133 ! | | 4 | | not sure about 4 & 5
134 ! *----*----*----*
135 ! |dele| 3 | |
136 ! |ted | | |
137 ! *----*----*----*
138 ! | | 5 | |
139 ! | 2 | | |
140 ! *----*----*----*
141
142 IF(ity==25) THEN
143 global_surface_id = k
144 ELSEIF(ity==24) THEN
145 global_surface_id = intbuf_tab(nin)%MSEGLO(k)
146 ENDIF
147 ! --------------
148 ! for interface type 24 : classical searching
149 ! for interface type 25 : hash table gives a direct access to the mvoisin array
150 if(ity==24) then
151 call surface_deactivation(ity,nrtm,global_surface_id,intbuf_tab(nin)%mseglo,intbuf_tab(nin)%mvoisin)
152 elseif(ity==25) then
153 call remove_neighbour_segment( nin,global_surface_id,intbuf_tab(nin),shoot_struct )
154 endif
155 ! --------------
156
157 IF(nspmd>1) THEN
158 ! --------------
159 already_done(1:nspmd) = .false.
160 already_done(ispmd+1) = .true.
161 DO j=1,4
162 node_id = intbuf_tab(nin)%IRECTM((k-1)*4+j)
163 nb_proc = shoot_struct%SHIFT_M_NODE_PROC(node_id+1) - shoot_struct%SHIFT_M_NODE_PROC(node_id) ! get the number of processor of the node
164 IF(nb_proc>1) THEN
165 shift = shoot_struct%SHIFT_M_NODE_PROC(node_id)
166 DO ijk=1,nb_proc
167 remote_proc = shoot_struct%M_NODE_PROC( shift+ijk )
168 IF(.NOT.already_done(remote_proc) ) THEN
169 already_done(remote_proc) = .true.
170 number_remote_surf(remote_proc) = number_remote_surf(remote_proc) + 1
171 IF(.NOT.ALLOCATED( s_buffer(remote_proc)%INT_ARRAY_2D ) ) THEN
172 CALL alloc_2d_array(s_buffer(remote_proc))
173 ENDIF
174 IF(ity==24) THEN
175 s_buffer(remote_proc)%INT_ARRAY_2D(1,number_remote_surf(remote_proc)) = intbuf_tab(nin)%MSEGLO(k)
176 ELSEIF(ity==25) THEN
177 s_buffer(remote_proc)%INT_ARRAY_2D(1,number_remote_surf(remote_proc)) = -intbuf_tab(nin)%MSEGLO(k)
178 ENDIF
179 s_buffer(remote_proc)%INT_ARRAY_2D(2,number_remote_surf(remote_proc)) = nin
180 ENDIF
181 ENDDO
182 ENDIF
183 ENDDO
184 ! --------------
185 ENDIF
186 ENDDO
187 ! --------------------------
188
189 IF(nspmd>1) THEN
190#ifdef MPI
191
192 ! ----------------
193 ! receive the data : "number of deleted surface of interface type 24 or 25"
194 recv_nb = 0
195 DO i=1,nspmd
196 frontier_elm = iad_elem(1,i+1)-iad_elem(1,i)
197 IF(frontier_elm>0) THEN
198 recv_nb = recv_nb + 1
199 index_r_proc(recv_nb) = i
200 msgtyp = msgoff1
201 CALL mpi_irecv( number_remote_surf_r(i),1,mpi_integer,it_spmd(i),msgtyp,
202 . spmd_comm_world,request_size_r(recv_nb),ierror )
203 ENDIF
204 ENDDO
205 ! ----------------
206
207 ! ----------------
208 ! send the data : "number of deleted surface of interface type 24 or 25"
209 DO i=1,nspmd
210 frontier_elm = iad_elem(1,i+1)-iad_elem(1,i)
211 IF(frontier_elm>0) THEN
212 msgtyp = msgoff1
213 CALL mpi_isend( number_remote_surf(i),1,mpi_integer,it_spmd(i),msgtyp,
214 . spmd_comm_world,request_size_s(i),ierror )
215 ENDIF
216 ENDDO
217 ! ----------------
218
219 ! ----------------
220 ! wait the R comm "number of deleted surface of interface type 24 or 25"
221 IF(recv_nb>0) CALL mpi_waitall(recv_nb,request_size_r,array_statuses,ierror)
222
223 ! ----------------
224 ! receive the data : "list of deleted surface of interface type 24 or 25"
225 recv_nb_2 = 0
226 DO i=1,recv_nb
227 proc_id = index_r_proc(i)
228 IF(number_remote_surf_r(proc_id)>0) THEN
229 recv_nb_2 = recv_nb_2 + 1
230 index_r_proc_2(recv_nb_2) = proc_id
231 r_buffer(proc_id)%SIZE_INT_ARRAY_2D(1) = 2
232 r_buffer(proc_id)%SIZE_INT_ARRAY_2D(2) = number_remote_surf_r(proc_id)
233 CALL alloc_2d_array(r_buffer(proc_id))
234 size_r = r_buffer(proc_id)%SIZE_INT_ARRAY_2D(1) * r_buffer(proc_id)%SIZE_INT_ARRAY_2D(2)
235 msgtyp = msgoff2
236 CALL mpi_irecv(r_buffer(proc_id)%INT_ARRAY_2D(1,1),size_r,
237 . mpi_integer,it_spmd(proc_id),msgtyp,
238 . spmd_comm_world,request_size_r_2(recv_nb_2),ierror )
239 ENDIF
240 ENDDO
241 ! ----------------
242
243 ! ----------------
244 ! send the data : "list of deleted surface of interface type 24 or 25"
245 DO i=1,nspmd
246 IF(number_remote_surf(i)>0) THEN
247 msgtyp = msgoff2
248 size_s = number_remote_surf(i) * s_buffer(i)%SIZE_INT_ARRAY_2D(1)
249 CALL mpi_isend( s_buffer(i)%INT_ARRAY_2D(1,1),size_s,mpi_integer,it_spmd(i),msgtyp,
250 . spmd_comm_world,request_size_s_2(i),ierror )
251 ENDIF
252 ENDDO
253 ! ----------------
254
255 ! ----------------
256 DO i=1,recv_nb_2
257 CALL mpi_waitany(recv_nb_2,request_size_r_2,k,status_mpi,ierror)
258 proc_id = index_r_proc_2(k)
259 ! --------------
260 DO j=1,number_remote_surf_r(proc_id)
261 nin = r_buffer(proc_id)%INT_ARRAY_2D(2,j) ! get the interface id
262 ity = ipari(7,nin) ! get the type of interface
263 idel = ipari(17,nin) ! get the kind of idel (1 or 2)
264 nrtm = ipari(4,nin) ! get the number of surfaces of the interface NIN
265 ! --------------
266 ! for interface type 24 : classical searching
267 ! for interface type 25 : hash table gives a direct access to the mvoisin array
268 global_surface_id = r_buffer(proc_id)%INT_ARRAY_2D(1,j) ! get the global deleted surface id
269 if(ity==24)then
270 call surface_deactivation(ity,nrtm,global_surface_id,intbuf_tab(nin)%mseglo,intbuf_tab(nin)%mvoisin)
271 elseif(ity==25) then
272 call remove_neighbour_segment( nin,global_surface_id,intbuf_tab(nin),shoot_struct )
273 endif
274 ! --------------
275 ENDDO
276 CALL dealloc_2d_array(r_buffer(proc_id))
277 ! --------------
278 ENDDO
279 ! ----------------
280
281 ! ----------------
282 ! wait the S comm : "number of deleted surface of interface type 24 or 25"
283 DO i=1,nspmd
284 frontier_elm = iad_elem(1,i+1)-iad_elem(1,i)
285 IF(frontier_elm>0) THEN
286 CALL mpi_wait(request_size_s(i),status_mpi,ierror)
287 ENDIF
288 ENDDO
289 ! ----------------
290
291 ! ----------------
292 ! wait the S comm : "list of deleted surface of interface type 24 or 25"
293 DO i=1,nspmd
294 IF(number_remote_surf(i)>0) THEN
295 CALL mpi_wait(request_size_s_2(i),status_mpi,ierror)
296 CALL dealloc_2d_array(s_buffer(i))
297 ENDIF
298 ENDDO
299 ! ----------------
300#endif
301 ENDIF
302
303 DEALLOCATE( s_buffer, r_buffer )
304
305 ! --------------------------
306 RETURN
dichotomic_search_i_asc
integer function dichotomic_search_i_asc(val, array, len)
Definition dichotomic_search_i_asc.F:27
mpi_isend
subroutine mpi_isend(buf, cnt, datatype, dest, tag, comm, ireq, ierr)
Definition mpi.f:382
mpi_wait
subroutine mpi_wait(ireq, status, ierr)
Definition mpi.f:525
mpi_waitall
subroutine mpi_waitall(cnt, array_of_requests, status, ierr)
Definition mpi.f:536
mpi_waitany
subroutine mpi_waitany(cnt, array_of_requests, index, status, ierr)
Definition mpi.f:549
mpi_irecv
subroutine mpi_irecv(buf, cnt, datatype, source, tag, comm, ireq, ierr)
Definition mpi.f:372
array_mod
Definition array_mod.F:51
array_mod::dealloc_2d_array
subroutine dealloc_2d_array(this)
Definition array_mod.F:200
array_mod::alloc_2d_array
subroutine alloc_2d_array(this)
Definition array_mod.F:142
surface_deactivation
subroutine surface_deactivation(ity, nrtm, glocal_surface_id, mseglo, mvoisin)
Definition surface_deactivation.F:29