OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
spmd_getstif25_edg.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23!||====================================================================
24!|| spmd_get_stif25_edg ../engine/source/mpi/interfaces/spmd_getstif25_edg.F
25!||--- called by ------------------------------------------------------
26!|| i25main_free ../engine/source/interfaces/intsort/i25main_free.F
27!|| inttri ../engine/source/interfaces/intsort/inttri.F
28!||--- calls -----------------------------------------------------
29!||--- uses -----------------------------------------------------
30!|| tri25ebox ../engine/share/modules/tri25ebox.F
31!|| tri7box ../engine/share/modules/tri7box.F
32!||====================================================================
33 SUBROUTINE spmd_get_stif25_edg(
34 . STFE, NEDGE, LEDGE,
35 . NIN , ISENDTO, IRCVFROM, COMM, RANK, COMSIZE)
36C-----------------------------------------------
37C Description:
38C A domain that own an edge warn others when
39C - This edge is deleted
40C - this edge is now free (one of the segment is
41C deleted)
42C Comment:
43C The two communications are done using ALLGATHERV
44C to remote domain's LEDGE_FIE even when _SI structures
45C are not updated yet according to SPMD_IFRONT
46C-----------------------------------------------
47C M o d u l e s
48C-----------------------------------------------
49 USE tri25ebox
50 USE tri7box
51C-----------------------------------------------
52C I m p l i c i t T y p e s
53C-----------------------------------------------
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 "com01_c.inc"
63#include "com04_c.inc"
64#include "param_c.inc"
65#include "i25edge_c.inc"
66C-----------------------------------------------
67C D u m m y A r g u m e n t s
68C-----------------------------------------------
69 INTEGER, INTENT(IN) :: NEDGE
70 INTEGER, INTENT(INOUT) :: LEDGE(NLEDGE,NEDGE)
71 INTEGER, INTENT(IN) :: NIN,
72 . isendto(ninter+1,*), ircvfrom(ninter+1,*)
73 INTEGER :: COMM,RANK,COMSIZE
74 my_real
75 . stfe(nedge)
76C-----------------------------------------------
77C L o c a l V a r i a b l e s
78C-----------------------------------------------
79
80 INTEGER, DIMENSION(:), ALLOCATABLE :: BUFFER_SEND,BUFFER_RECV
81 INTEGER :: LOCAL_SIZE(COMSIZE,2), TOTAL_SIZE
82 INTEGER :: DISPL(COMSIZE)
83 INTEGER :: I,J, UID
84 INTEGER :: COMSIZE2,LS
85 INTEGER :: S_LEFT,S_RIGHT
86 INTEGER :: ID_LEFT,ID_RIGHT
87#ifdef MPI
88 INTEGER DATA MSGOFF/1001/
89 INTEGER STATUS(MPI_STATUS_SIZE),IERROR
90C-----------------------------------------------
91C S o u r c e L i n e s
92C-----------------------------------------------
93C
94 IF(.NOT. (nspmd == 1 .OR. comm == mpi_comm_null)) THEN
95! Count fully broken edge
96 local_size(1:comsize,1:2) = 0
97 local_size(rank+1,1) = count(stfe(1:nedge) < zero)
98
99! count new free edges
100 DO i = 1,nedge
101 IF(ledge(ledge_global_id,i) < 0) THEN
102 local_size(rank+1,2) = local_size(rank+1,2) + 1
103 ENDIF
104 ENDDO
105
106 comsize2 = comsize * 2
107 CALL mpi_allreduce(mpi_in_place,
108 . local_size,
109 . comsize2,
110 . mpi_integer,
111 . mpi_sum,
112 . comm,
113 . ierror)
114
115
116C
117C Send broken edges
118C
119 total_size = sum(local_size(1:comsize,1))
120 IF(total_size > 0) THEN
121 ALLOCATE(buffer_send(local_size(rank+1,1)))
122 ALLOCATE(buffer_recv(total_size))
123 j = 0
124 DO i = 1, nedge
125 IF( stfe(i) < 0 ) THEN
126 j = j + 1
127Cfill with global ID
128 buffer_send(j) = abs(ledge(ledge_global_id,i))
129#ifdef D_ES
130 IF(abs(ledge(ledge_global_id,i)) == d_es) THEN
131 WRITE(6,*) __file__,d_es,"is deleted",stfe(i)
132 ENDIF
133#endif
134 ENDIF
135 ENDDO
136 displ(1)=0
137 DO i=2,comsize
138 displ(i)=local_size(i-1,1)+displ(i-1)
139 ENDDO
140 CALL mpi_allgatherv(buffer_send,
141 . local_size(rank+1,1),
142 . mpi_integer,
143 . buffer_recv,
144 . local_size(:,1),
145 . displ,
146 . mpi_integer,
147 . comm,
148 . ierror)
149
150 DEALLOCATE(buffer_send)
151C hash table would be better here (UID -> index in LEDEG_FIE)
152 DO j = 1, total_size
153 uid = buffer_recv(j)
154 DO i = 1,nedge_remote
155 IF(ledge_fie(nin)%P(e_global_id,i) == uid) THEN
156 stifie(nin)%P(i) = zero
157#ifdef D_ES
158 IF(uid == d_es) WRITE(6,*) __file__,"STF <- 0"
159#endif
160 ENDIF
161 ENDDO
162 ENDDO
163 DEALLOCATE(buffer_recv)
164 ENDIF
165C
166C Send Free edges
167C
168 total_size = sum(local_size(1:comsize,2))
169 IF(total_size > 0) THEN
170 ALLOCATE(buffer_send(5*local_size(rank+1,2)))
171 ALLOCATE(buffer_recv(5*total_size))
172 j = 0
173 DO i = 1, nedge
174 IF( ledge(ledge_global_id,i) < 0 ) THEN
175 j = j + 1
176Cfill with global ID
177 buffer_send(5*(j-1)+1) = abs(ledge(ledge_global_id,i))
178 buffer_send(5*(j-1)+2) = ledge(ledge_left_seg,i)
179 buffer_send(5*(j-1)+3) = ledge(ledge_right_seg,i)
180 buffer_send(5*(j-1)+2) = ledge(ledge_left_id,i)
181 buffer_send(5*(j-1)+3) = ledge(ledge_right_id,i)
182#ifdef D_ES
183 IF(abs(ledge(ledge_global_id,i)) == d_es) THEN
184 WRITE(6,*) __file__,d_es,"is Free"
185 ENDIF
186#endif
187 ENDIF
188 ENDDO
189 DO i=1,comsize
190 local_size(i,2) = local_size(i,2) * 5
191 ENDDO
192 displ(1)=0
193 DO i=2,comsize
194 displ(i)=local_size(i-1,2)+displ(i-1)
195 ENDDO
196 ls = local_size(rank+1,2)
197 CALL mpi_allgatherv(buffer_send,
198 . ls,
199 . mpi_integer,
200 . buffer_recv,
201 . local_size(:,2),
202 . displ,
203 . mpi_integer,
204 . comm,
205 . ierror)
206
207 DEALLOCATE(buffer_send)
208C hash table would be better here (UID -> index in LEDEG_FIE)
209 DO j = 1, total_size
210 uid = buffer_recv(5*(j-1)+1)
211 s_left = buffer_recv(5*(j-1)+2)
212 s_right = buffer_recv(5*(j-1)+3)
213 id_left = buffer_recv(5*(j-1)+4)
214 id_right = buffer_recv(5*(j-1)+5)
215
216 DO i = 1,nedge_remote
217 IF(ledge_fie(nin)%P(e_global_id,i) == uid) THEN
218 ledge_fie(nin)%P(e_left_seg,i) = s_left
219 ledge_fie(nin)%P(e_right_seg,i) = s_right
220 ledge_fie(nin)%P(e_left_id,i) = id_left
221 ledge_fie(nin)%P(e_right_id,i) = id_right
222 ENDIF
223 ENDDO
224 ENDDO
225 DEALLOCATE(buffer_recv)
226 ENDIF
227 ENDIF ! NSPMD > 0 and MPI_COMM EXIST
228#endif
229
230 WHERE(stfe < zero) stfe = zero
231 DO i = 1,nedge
232 IF(ledge(ledge_global_id,i) < 0) THEN
233 ledge(ledge_global_id,i) = abs(ledge(ledge_global_id,i))
234 ENDIF
235 ENDDO
236
237C DO i = 1,nedge
238C IF(STFE(i) < ZERO) STFE(i) = ZERO
239C ENDDO
240 RETURN
241 END
242
mpi_allreduce
subroutine mpi_allreduce(sendbuf, recvbuf, cnt, datatype, operation, comm, ierr)
Definition mpi.f:103
tri25ebox::nedge_remote
integer nedge_remote
Definition tri25ebox.F:73
tri25ebox::ledge_fie
type(int_pointer2), dimension(:), allocatable ledge_fie
Definition tri25ebox.F:88
tri7box::stifie
type(real_pointer), dimension(:), allocatable stifie
Definition tri7box.F:449
spmd_get_stif25_edg
subroutine spmd_get_stif25_edg(stfe, nedge, ledge, nin, isendto, ircvfrom, comm, rank, comsize)
Definition spmd_getstif25_edg.F:36