OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
spmd_vgath_err.F File Reference
#include "implicit_f.inc"
#include "spmd.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "scr18_c.inc"
#include "task_c.inc"
#include "units_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine spmd_vgath_err (x, ms, msini, nodglob, weight, num, iflag, itab, leng)

Function/Subroutine Documentation

◆ spmd_vgath_err()

subroutine spmd_vgath_err ( x,
ms,
msini,
integer, dimension(*) nodglob,
integer, dimension(*) weight,
integer num,
integer iflag,
integer, dimension(*) itab,
integer leng )

Definition at line 32 of file spmd_vgath_err.F.

34C-----------------------------------------------
35C I m p l i c i t T y p e s
36C-----------------------------------------------
37 USE spmd_comm_world_mod, ONLY : spmd_comm_world
38#include "implicit_f.inc"
39#include "spmd.inc"
40C-----------------------------------------------
41C C o m m o n B l o c k s
42C-----------------------------------------------
43#include "com01_c.inc"
44#include "com04_c.inc"
45#include "scr18_c.inc"
46#include "task_c.inc"
47#include "units_c.inc"
48C-----------------------------------------------
49C D u m m y A r g u m e n t s
50C-----------------------------------------------
51 my_real
52 . x(3,*),ms(*),msini(*)
53 INTEGER WEIGHT(*),NODGLOB(*),NUM,IFLAG,ITAB(*),LENG
54C-----------------------------------------------
55C L O C A L V A R I A B L E S
56C-----------------------------------------------
57#ifdef MPI
58 REAL, DIMENSION(:) , ALLOCATABLE :: MAXV0, MAXV1, MAXV2
59
60 my_real
61 . , DIMENSION(:), ALLOCATABLE :: v, maxv, maxv_1, maxv_2, maxv_res0,
62 . maxv_res1, maxv_res2
63
64 INTEGER STATUS(MPI_STATUS_SIZE),IERROR,MSGOFF,FLAG,ITABG(LENG)
65 INTEGER SIZ,MSGTYP,I,J,K,MSGOFF2,
66 . L,ISMASSCHANGE,MSGOFF3,MSGOFF4
67 INTEGER, DIMENSION(:) , ALLOCATABLE :: IDNOD0, IDNOD, IDNOD_RES
68
69 DATA msgoff/7007/
70 DATA msgoff2/7008/
71 DATA msgoff3/7009/
72 DATA msgoff4/7010/
73C=======================================================================
74 IF (nspmd > 1)
75 . CALL spmd_outpitab(itab,weight,nodglob,itabg)
76c
77 ALLOCATE(maxv0(num),maxv1(num),maxv2(num))
78
79 ALLOCATE(v(numnod),maxv(num),maxv_1(num),maxv_2(num),maxv_res0(num),
80 . maxv_res1(num),maxv_res2(num))
81
82 ALLOCATE(idnod0(num),idnod(num),idnod_res(num))
83
84 idnod(1:num) = 0
85 idnod0(1:num) = 0
86 maxv(1:num) = zero
87 maxv_1(1:num) = zero
88 maxv_2(1:num) = zero
89 maxv0(1:num) = zero
90 siz = num
91 IF(iflag==1)THEN
92 DO i=1,numnod
93 v(i)=sqrt(x(1,i)**2+x(2,i)**2+x(3,i)**2)
94 ENDDO
95 ELSEIF(iflag==2)THEN
96 DO i=1,numnod
97 v(i)=half*ms(i)*(x(1,i)**2+x(2,i)**2+x(3,i)**2)
98 ENDDO
99 ELSEIF(iflag==3)THEN
100 DO i=1,numnod
101 v(i)=ms(i)
102 ENDDO
103 ELSEIF(iflag==4)THEN
104 DO i=1,numnod
105 v(i)=(ms(i)-msini(i))/max(em20,msini(i))
106 ENDDO
107 ENDIF
108 IF (ispmd/=0) THEN
109
110 DO i=1,numnod
111 IF (weight(i)==1) THEN
112 flag = 0
113 DO j=1,num
114 IF(v(i) > maxv0(j) .AND. flag == 0) THEN
115 DO k=1,num-j
116 idnod0(num-k+1) = idnod0(num-k)
117 maxv0(num-k+1) = maxv0(num-k)
118 maxv1(num-k+1) = maxv1(num-k)
119 maxv2(num-k+1) = maxv2(num-k)
120 ENDDO
121 idnod0(j) = nodglob(i)
122 maxv0(j) = v(i)
123 maxv1(j) = ms(i)
124 maxv2(j) = msini(i)
125 flag = 1
126 ENDIF
127 ENDDO
128 END IF
129 END DO
130
131C Because of the simple precision version, we cannot put the integer
132C In the floating buffer because there are only 2 24 bits available ~ 16 million
133C of nodes at most
134
135 msgtyp = msgoff
136 CALL mpi_send(idnod0,siz,mpi_integer,it_spmd(1),msgtyp,
137 . spmd_comm_world,ierror)
138
139 msgtyp = msgoff2
140 CALL mpi_send(maxv0,siz,mpi_real,it_spmd(1),msgtyp,
141 . spmd_comm_world,ierror)
142
143 msgtyp = msgoff3
144 CALL mpi_send(maxv1,siz,mpi_real,it_spmd(1),msgtyp,
145 . spmd_comm_world,ierror)
146
147 msgtyp = msgoff4
148 CALL mpi_send(maxv2,siz,mpi_real,it_spmd(1),msgtyp,
149 . spmd_comm_world,ierror)
150
151 ELSE ! ISPMD == 0
152 DO i=1,numnod
153 IF (weight(i)==1) THEN
154 flag = 0
155 DO j=1,num
156 IF(v(i) > maxv(j) .AND. flag == 0) THEN
157 DO k=1,num-j
158 idnod(num-k+1) = idnod(num-k)
159 maxv(num-k+1) = maxv(num-k)
160 maxv_1(num-k+1) = maxv_1(num-k)
161 maxv_2(num-k+1) = maxv_2(num-k)
162 ENDDO
163 idnod(j) = nodglob(i)
164 maxv(j) = v(i)
165 maxv_1(j) = ms(i)
166 maxv_2(j) = msini(i)
167 flag = 1
168 ENDIF
169 ENDDO
170
171 ENDIF
172 ENDDO
173
174 DO i=2,nspmd
175
176C Reception
177 msgtyp = msgoff
178
179 CALL mpi_probe(it_spmd(i),msgtyp,
180 . spmd_comm_world,status,ierror)
181 CALL mpi_get_count(status,mpi_integer,siz,ierror)
182
183 CALL mpi_recv(idnod0,siz,mpi_integer,it_spmd(i),msgtyp,
184 . spmd_comm_world,status,ierror)
185
186C Reception
187
188 msgtyp = msgoff2
189 CALL mpi_recv(maxv0,siz,mpi_real,it_spmd(i),msgtyp,
190 . spmd_comm_world,status,ierror)
191
192 msgtyp = msgoff3
193 CALL mpi_recv(maxv1,siz,mpi_real,it_spmd(i),msgtyp,
194 . spmd_comm_world,status,ierror)
195
196 msgtyp = msgoff4
197 CALL mpi_recv(maxv2,siz,mpi_real,it_spmd(i),msgtyp,
198 . spmd_comm_world,status,ierror)
199
200
201 j = 1
202 k = 1
203 l = 1
204 DO WHILE( j <= siz .AND. k <= siz .AND. l <= siz)
205 IF(maxv(j) > maxv0(k))THEN
206 maxv_res0(l) = maxv(j)
207 idnod_res(l) = idnod(j)
208 maxv_res1(l) = maxv_1(j)
209 maxv_res2(l) = maxv_2(j)
210 j = j + 1
211 l = l + 1
212 ELSEIF(maxv0(k) > maxv(j))THEN
213 maxv_res0(l) = maxv0(k)
214 idnod_res(l) = idnod0(k)
215 maxv_res1(l) = maxv1(k)
216 maxv_res2(l) = maxv2(k)
217 k = k + 1
218 l = l + 1
219 ELSE
220 maxv_res0(l) = maxv0(k)
221 idnod_res(l) = idnod0(k)
222 maxv_res1(l) = maxv1(k)
223 maxv_res2(l) = maxv2(k)
224 j = j + 1
225 k = k + 1
226 l = l + 1
227 ENDIF
228 ENDDO
229 DO j=1,siz
230 maxv(j) = maxv_res0(j)
231 idnod(j) = idnod_res(j)
232 maxv_1(j) = maxv_res1(j)
233 maxv_2(j) = maxv_res2(j)
234 ENDDO
235
236 ENDDO
237 IF(iflag == 1)THEN
238 WRITE(iout,2000)
239 WRITE(iout,1000)
240 WRITE(iout,2000)
241 WRITE(iout,1001)
242 DO i=1,num
243 IF(maxv_res0(i) /= zero)THEN
244 WRITE(iout,1100) itabg(idnod_res(i)),maxv_res0(i),
245 . half*(maxv_res1(i))*maxv_res0(i)**2,
246 . maxv_res1(i),maxv_res2(i),
247 . (maxv_res1(i)-maxv_res2(i))/max(em20,maxv_res2(i))
248 ENDIF
249 ENDDO
250 ELSEIF(iflag == 2)THEN
251 WRITE(iout,2000)
252 WRITE(iout,1200)
253 WRITE(iout,2000)
254 WRITE(iout,1201)
255 DO i=1,num
256 WRITE(iout,1300) itabg(idnod_res(i)),maxv_res0(i)
257 ENDDO
258 ELSEIF(iflag == 3)THEN
259 WRITE(iout,2000)
260 WRITE(iout,1400)
261 WRITE(iout,2000)
262 WRITE(iout,1401)
263 DO i=1,num
264 WRITE(iout,1500) itabg(idnod_res(i)),maxv_res0(i)
265 ENDDO
266 ELSEIF(iflag == 4 .AND. (idtmin(11) == 3 .OR.idtmin(11)==8))THEN
267 ismasschange = 0
268 DO i=1,num
269 IF(maxv_res0(i) /=zero) ismasschange = 1
270 ENDDO
271 IF(ismasschange /= 0)THEN
272 WRITE(iout,2000)
273 WRITE(iout,1600)
274 WRITE(iout,2000)
275 WRITE(iout,1601)
276 DO i=1,num
277 IF(maxv_res0(i) /= zero)
278 . WRITE(iout,1700) itabg(idnod_res(i)),maxv_res1(i),
279 . maxv_res2(i),maxv_res0(i)
280 ENDDO
281 ENDIF
282 ENDIF
283 ENDIF
284C
285 1000 FORMAT('*** NODES WITH HIGHEST VELOCITY')
286 1001 FORMAT(' NODE VELOCITY K-ENER MASS MASS0
287 . DM/MASS0')
288 1100 FORMAT(i10,5g11.4)
289c
290 1200 FORMAT('*** NODES WITH HIGHEST KINEMATIC ENERGY')
291 1201 FORMAT(' NODE K-ENER MASS MASS0 MASS/MASS0')
292 1300 FORMAT(i10,g11.4)
293c
294 1400 FORMAT('*** NODES WITH HIGHEST MASS')
295 1401 FORMAT(' NODE MASS MASS0 MASS/MASS0')
296 1500 FORMAT(i10,g11.4)
297c
298 1600 FORMAT('*** NODES WITH HIGHEST MASS CHANGE')
299 1601 FORMAT(' NODE MASS MASS0 DM/MASS0')
300 1700 FORMAT(i10,3g11.4)
301c
302 2000 FORMAT(' ')
303 2100 FORMAT(' ** STATISTICS **')
304c
305 DEALLOCATE(maxv0,maxv1,maxv2)
306 DEALLOCATE(v,maxv,maxv_res0,maxv_res1,maxv_res2)
307 DEALLOCATE(idnod0,idnod,idnod_res)
308
309#endif
310 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
max
#define max(a, b)
Definition macros.h:21
mpi_recv
subroutine mpi_recv(buf, cnt, datatype, source, tag, comm, status, ierr)
Definition mpi.f:461
mpi_get_count
subroutine mpi_get_count(status, datatype, cnt, ierr)
Definition mpi.f:296
mpi_send
subroutine mpi_send(buf, cnt, datatype, dest, tag, comm, ierr)
Definition mpi.f:480
mpi_probe
subroutine mpi_probe(source, tag, comm, status, ierr)
Definition mpi.f:449
spmd_outpitab
subroutine spmd_outpitab(v, weight, nodglob, vglob)
Definition spmd_outp.F:1081