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 37 of file check_remote_surface_state.F.

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