OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
r2r_init.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!|| r2r_init ../engine/source/coupling/rad2rad/r2r_init.F
25!||--- called by ------------------------------------------------------
26!|| resol_init ../engine/source/engine/resol_init.F
27!||--- calls -----------------------------------------------------
28!|| connection_sock_c ../engine/source/coupling/rad2rad/rad2rad_c.c
29!|| get_fbuf_c ../engine/source/coupling/rad2rad/rad2rad_c.c
30!|| get_ibuf_c ../engine/source/coupling/rad2rad/rad2rad_c.c
31!|| get_mass_c ../engine/source/coupling/rad2rad/rad2rad_c.c
32!|| get_mass_rby_c ../engine/source/coupling/rad2rad/rad2rad_c.c
33!|| get_mass_rby_spmd ../engine/source/coupling/rad2rad/r2r_init.F
34!|| get_mass_spmd ../engine/source/coupling/rad2rad/r2r_init.F
35!|| get_name_c ../engine/source/coupling/rad2rad/rad2rad_c.c
36!|| init_activ_c ../engine/source/coupling/rad2rad/rad2rad_c.c
37!|| init_link_c ../engine/source/coupling/rad2rad/rad2rad_c.c
38!|| init_link_nl_c ../engine/source/coupling/rad2rad/rad2rad_c.c
39!|| init_link_spmd ../engine/source/coupling/rad2rad/r2r_init.F
40!|| omp_get_thread_num ../engine/source/engine/openmp_stub.F90
41!|| openfifo_c ../engine/source/coupling/rad2rad/rad2rad_c.c
42!|| opensem_c ../engine/source/coupling/rad2rad/rad2rad_c.c
43!|| openshm_c ../engine/source/coupling/rad2rad/rad2rad_c.c
44!|| r2r_rby ../engine/source/coupling/rad2rad/r2r_init.F
45!|| send_fbuf_c ../engine/source/coupling/rad2rad/rad2rad_c.c
46!|| send_ibuf_c ../engine/source/coupling/rad2rad/rad2rad_c.c
47!|| send_mass_c ../engine/source/coupling/rad2rad/rad2rad_c.c
48!|| send_mass_nl_c ../engine/source/coupling/rad2rad/rad2rad_c.c
49!|| send_mass_rby_c ../engine/source/coupling/rad2rad/rad2rad_c.c
50!|| send_mass_rby_spmd ../engine/source/coupling/rad2rad/r2r_init.F
51!|| send_mass_spmd ../engine/source/coupling/rad2rad/r2r_init.F
52!|| send_sock_init_c ../engine/source/coupling/rad2rad/rad2rad_c.c
53!|| spmd_allglob_isum9 ../engine/source/mpi/generic/spmd_allglob_isum9.F
54!|| spmd_exch_r2r ../engine/source/mpi/r2r/spmd_r2r.F
55!|| spmd_exch_r2r_rby ../engine/source/mpi/r2r/spmd_r2r.F
56!|| spmd_ibcast ../engine/source/mpi/generic/spmd_ibcast.F
57!|| spmd_r2r_sync ../engine/source/mpi/r2r/spmd_r2r.F
58!||--- uses -----------------------------------------------------
59!|| groupdef_mod ../common_source/modules/groupdef_mod.F
60!|| message_mod ../engine/share/message_module/message_mod.F
61!|| nlocal_reg_mod ../common_source/modules/nlocal_reg_mod.F
62!|| rad2r_mod ../engine/share/modules/rad2r.F
63!||====================================================================
64 SUBROUTINE r2r_init(IEXLNK ,ITAB,IGRNOD,X ,
65 2 MS ,IN ,DD_R2R,WEIGHT ,IAD_ELEM,
66 3 FR_ELEM,ADDCNEL,CNEL,IXC,IPARG,ICODT,ICODR,
67 4 IBFV,DX,RBY,NPBY,XDP,STIFN,STIFR,DD_R2R_ELEM,
68 5 SDD_R2R_ELEM,WEIGHT_MD,ILENXV,NUMSPH_GLO_R2R,
69 6 FLG_SPHINOUT_R2R,IPARI,NLOC_DMG)
70C-----------------------------------------------
71C M o d u l e s
72C-----------------------------------------------
73 USE rad2r_mod
74 USE groupdef_mod
75 USE message_mod
76 USE nlocal_reg_mod
77C-----------------------------------------------
78C I m p l i c i t T y p e s
79C-----------------------------------------------
80#include "implicit_f.inc"
81C-----------------------------------------------
82C C o m m o n B l o c k s
83C-----------------------------------------------
84#include "chara_c.inc"
85#include "com01_c.inc"
86#include "com04_c.inc"
87#include "com06_c.inc"
88#include "com08_c.inc"
89#include "param_c.inc"
90#include "scr18_c.inc"
91#include "scr17_c.inc"
92#include "rad2r_c.inc"
93#include "scr05_c.inc"
94#include "scr03_c.inc"
95#include "task_c.inc"
96#include "sphcom.inc"
97C-----------------------------------------------
98C D u m m y A r g u m e n t s
99C-----------------------------------------------
100 INTEGER IEXLNK(NR2R,NR2RLNK), ITAB(*),
101 . WEIGHT(*), DD_R2R(NSPMD+1,*), IAD_ELEM(2,*), FR_ELEM(*),
102 . IROOT(100), ADDCNEL(0:*),CNEL(0:*),IXC(NIXC,*),ICODR(*),
103 . IPARG(NPARG,*),ICODT(*),IBFV(*),NPBY(*),DD_R2R_ELEM(*),
104 . SDD_R2R_ELEM,WEIGHT_MD(*),ILENXV,NUMSPH_GLO_R2R,FLG_SPHINOUT_R2R,
105 . ipari(npari,*)
106C REAL
107 my_real x(3,*), dx(3,*),ms(*),in(*),rby(*),stifn(*),stifr(*)
108 .
109 DOUBLE PRECISION XDP(3,*)
110!
111 TYPE (GROUP_) , TARGET, DIMENSION(NGRNOD) :: IGRNOD
112 TYPE(nlocal_str_), TARGET, INTENT(IN) :: NLOC_DMG
113C-----------------------------------------------
114C L o c a l V a r i a b l e s
115C-----------------------------------------------
116 INTEGER I, J, IEX, IDP, IDG, NNG, OFC,NFTC,INFO,TYP,ITSK
117 INTEGER OMP_GET_THREAD_NUM,NUM_SOCK,SIZE_TAG_RBY,LENR,SIZE
118 INTEGER NN,N,SUM,PPID,IDEL_LOC,NSN_GLOB,COMPT
119 INTEGER, DIMENSION(:), ALLOCATABLE :: NDOF_NL
120 CHARACTER*35 ADDR
121C
122 INTEGER, DIMENSION(:), POINTER :: GRNOD
123 INTEGER, POINTER, DIMENSION(:) :: IDXI,POSI
124 my_real, POINTER, DIMENSION(:) :: msnl
125C-----------------------------------------------
126C S o u r c e L i n e s
127C-----------------------------------------------
128 info=numels+numelq+numelc
129 nbk = 0
130 size_tag_rby = 0
131 IF((ninter>0).AND.(idtmin(10)/=3).AND.(idtmin(11)/=3).AND.(idtmin(11)/=8)) THEN
132 ilenxv = ilenxv + 2
133 ENDIF
134C
135 IF ((r2r_siu==1).OR.(nspmd==1)) THEN
136C------SPH+Multidomains--------------------->
137 IF (r2r_siu==1) THEN
138 numsph_glo_r2r = numsph
139 IF (nspmd>1) CALL spmd_allglob_isum9(numsph_glo_r2r,1)
140 IF ((nsphio>0).AND.(numsph_glo_r2r>0)) flg_sphinout_r2r = 1
141 IF (nspmd>1) THEN
142 CALL spmd_allglob_isum9(flg_sphinout_r2r,1)
143 flg_sphinout_r2r = min(1,flg_sphinout_r2r)
144 ENDIF
145 ENDIF
146C------Elimination of TYPE2 interfaces without second. nodes---------------->
147 IF (r2r_siu==1) THEN
148 DO i=1,ninter
149 nsn_glob = ipari(5,i)
150 IF (nspmd>1) CALL spmd_allglob_isum9(nsn_glob,1)
151 IF ((nsn_glob==0).AND.(ipari(7,i)==2)) ipari(7,i) = 0
152 END DO
153 ENDIF
154C------Cas SMP initialization---------------c
155 ALLOCATE(typlnk(nr2rlnk),rbylnk(nr2rlnk),kinlnk(nr2rlnk))
156 ALLOCATE(add_rby(nr2rlnk))
157 ALLOCATE(socket(nthread))
158 ALLOCATE(nllnk(nr2rlnk))
159 ALLOCATE(nbdof_nl(nr2rlnk))
160 nbdof_nl(1:nr2rlnk) = 0
161C
162 DO i = 1, rootlen
163 iroot(i) = ichar(rootnam(i:i))
164 END DO
165C----- Connection of first socket-----------c
166 IF (ispmd==0) THEN
167 socket(1)=sock0
168 CALL send_sock_init_c(iroot,rootlen,ispmd,socket(1),nthread,nspmd)
169 ENDIF
170C----- Synchronisation of the process - transfer of hostname
171 IF (nspmd>1) CALL spmd_r2r_sync(addr)
172C----- Connection of socket of threads--------c
173 IF(ispmd==0) THEN
174 DO itsk=2,nthread
175 CALL get_name_c(addr)
176 addr=trim(addr)
177 CALL connection_sock_c(itsk-1,socket(itsk),addr)
178 END DO
179 ELSE
180 DO itsk=1,nthread
181 num_sock = nthread*ispmd+itsk
182 CALL connection_sock_c(num_sock-1,socket(itsk),addr)
183 END DO
184 ENDIF
185C----- Initialize Fifos
186 CALL openfifo_c(iroot,rootlen,r2r_fdw,r2r_fdr,socket(1),ispmd,nthread,ppid)
187C----- set signal catch
188 CALL get_ibuf_c(r2r_ipid,1)
189C----- send link interface data
190 CALL send_ibuf_c(nr2rlnk,1)
191 CALL send_ibuf_c(iroddl,1)
192 CALL send_fbuf_c(tt,1)
193 CALL send_fbuf_c(tstop,1)
194 CALL send_ibuf_c(ncrst,1)
195 CALL send_ibuf_c(idel7ng,1)
196 CALL send_ibuf_c(flg_sphinout_r2r,1)
197C----- get info for th
198 IF (r2r_siu==1) THEN
199 IF (ispmd==0) THEN
200 DO j=1,10
201 CALL get_ibuf_c(seek0(j),1)
202 CALL get_ibuf_c(seekc(j),1)
203 ENDDO
204 ENDIF
205 IF (nspmd>1) THEN
206 CALL spmd_ibcast(seek0,seek0,10,1,0,2)
207 CALL spmd_ibcast(seekc,seekc,10,1,0,2)
208 ENDIF
209 ENDIF
210C-----
211 CALL send_ibuf_c(irun,1)
212 ofc=numels+numelq
213C
214 DO iex = 1, nr2rlnk
215 idg = iexlnk(1,iex)
216 idp = iexlnk(2,iex)
217 nng = igrnod(idg)%NENTITY
218 nftc = 0
219!
220 grnod => igrnod(idg)%ENTITY
221!
222 IF (idp>nbk) nbk = idp
223C------ determination of the type of the interface
224 CALL send_ibuf_c(idp,1)
225 CALL get_ibuf_c(typlnk(iex),1)
226 CALL get_ibuf_c(main_side,1)
227 CALL get_ibuf_c(rbylnk(iex),1)
228 CALL get_ibuf_c(kinlnk(iex),1)
229 CALL get_ibuf_c(nllnk(iex),1)
230 IF (rbylnk(iex)==1) THEN
231 add_rby(iex) = size_tag_rby
232 size_tag_rby = size_tag_rby + nng
233 ENDIF
234
235C--------------Reset of weight2 for duplicated nodes--------
236 IF ((typlnk(iex)==5).AND.(main_side==1)) THEN
237 DO nn=1,nng
238 n = igrnod(idg)%ENTITY(nn)
239 weight_md(n) = 0
240 END DO
241 ENDIF
242C--------------Initialisation of arrays for rlinks/cyljoints------
243 IF ((typlnk(iex)==5).AND.(kinlnk(iex)==1)) THEN
244 ALLOCATE(r2r_kine(3,nng))
245 r2r_kine(:,:)=0
246 ENDIF
247C----------------------------------------------------------------------
248C------
249 IF (nllnk(iex)==1) THEN
250C-------- Coupling of non local dof
251 idxi => nloc_dmg%IDXI(1:numnod)
252 posi => nloc_dmg%POSI(1:nloc_dmg%NNOD+1)
253 compt = 0
254 ALLOCATE(ndof_nl(nng))
255 DO i=1,nng
256 nn = idxi(grnod(i))
257 ndof_nl(i) = posi(nn+1)-posi(nn)
258 compt = compt + ndof_nl(i)
259 ENDDO
260 nbdof_nl(iex) = compt
261 ALLOCATE(iadd_nl(compt))
262 compt = 0
263 DO i=1,nng
264 nn = idxi(grnod(i))
265 DO j=posi(nn),posi(nn+1)-1
266 compt = compt + 1
267 iadd_nl(compt) = j
268 ENDDO
269 ENDDO
270 CALL init_link_nl_c(idp,nng,itab,grnod,x,ncpri,dx,ndof_nl,nbdof_nl(iex),nbk)
271 DEALLOCATE(ndof_nl)
272C
273 IF ((nspmd > 1).AND.(sdd_r2r_elem>0)) THEN
274 dd_r2r_nl(1:2) = 0
275 DO i=1,nspmd
276 dd_r2r_nl(1) = dd_r2r_nl(1) + dd_r2r(i+1,3)-dd_r2r(i,3)
277 ENDDO
278 DO i=1,nspmd
279 dd_r2r_nl(2) = dd_r2r_nl(2) + dd_r2r(i+1,4)-dd_r2r(i,4)
280 ENDDO
281 ENDIF
282C
283 ELSE
284 CALL init_link_c(idp,nng,itab,grnod,x,addcnel,cnel,ixc,
285 . ofc,info,typlnk(iex),icodt,icodr,ncpri,iroddl,nbk,dx)
286 ENDIF
287C
288 END DO
289!
290 CALL init_activ_c(r2r_activ)
291C CALL CHECK_RODDL_C()
292C----- Initialize Shared Memory
293 CALL openshm_c()
294C
295 CALL get_fbuf_c(tstop,1)
296 CALL get_ibuf_c(idel_loc,1)
297 idel7ng = max(idel7ng,idel_loc)
298 IF (idel7ng>=1) idel7nok = 1
299C----- Update mass and inertia
300C
301 r2rfx1 = zero
302 r2rfx2 = zero
303 ALLOCATE (tag_rby(size_tag_rby))
304 DO iex = 1, nr2rlnk
305 idg = iexlnk(1,iex)
306 idp = iexlnk(2,iex)
307 nng = igrnod(idg)%NENTITY
308 grnod => igrnod(idg)%ENTITY
309 IF (rbylnk(iex)==1) THEN
310 CALL send_mass_rby_c(idp,nng,grnod,ms,in,npby,
311 . nrbody,rby,tag_rby,add_rby(iex),nnpby,nrby)
312 ELSEIF (nllnk(iex)==1) THEN
313C---------- Coupling of non local dof
314 msnl => nloc_dmg%MASS(1:nloc_dmg%L_NLOC)
315 CALL send_mass_nl_c(idp,nbdof_nl(iex),iadd_nl,msnl)
316 ELSE
317 CALL send_mass_c(idp,nng,grnod,ms,in)
318 ENDIF
319 END DO
320C
321 IF (tt==zero) THEN
322 DO iex = 1, nr2rlnk
323 idg = iexlnk(1,iex)
324 idp = iexlnk(2,iex)
325 nng = igrnod(idg)%NENTITY
326 grnod => igrnod(idg)%ENTITY
327 IF (rbylnk(iex)==1) THEN
328 CALL get_mass_rby_c(idp,nng,grnod,ms,in,x,npby,nrbody,rby,nnpby,nrby)
329 CALL r2r_rby(nng,itab,grnod,x,ms,in,npby,rby,xdp,1,weight)
330 ELSEIF (nllnk(iex)==1) THEN
331C---------- Coupling of non local dof - mass not modified -
332 CALL send_ibuf_c(idp,1)
333 ELSE
334 CALL get_mass_c(idp,nng,grnod,ms,in)
335 ENDIF
336 END DO
337C
338C---------------Synchronisation (not needed for NL coupling)------C
339 IF (nspmd>1) THEN
340 IF (sdd_r2r_elem>0) THEN
341 SIZE = 3 + iroddl*3
342 lenr = iad_elem(1,nspmd+1)-iad_elem(1,1)
343C
344 CALL spmd_exch_r2r(
345 1 x ,x ,stifn,stifr ,ms ,
346 2 iad_elem,fr_elem,SIZE ,
347 3 lenr ,dd_r2r,dd_r2r_elem,2)
348C
349 SIZE = 1 + iroddl*1
350 CALL spmd_exch_r2r(
351 1 x ,x ,ms,in ,ms ,
352 2 iad_elem,fr_elem,SIZE ,
353 3 lenr ,dd_r2r,dd_r2r_elem,1)
354C
355 SIZE = 28
356 IF (iresp==1) THEN
357 CALL spmd_exch_r2r_rby(
358 1 npby, rby,
359 2 iad_elem,fr_elem,SIZE ,
360 3 lenr ,dd_r2r,dd_r2r_elem,xdp)
361 ELSE
362 CALL spmd_exch_r2r_rby(
363 1 npby, rby,
364 2 iad_elem,fr_elem,SIZE ,
365 3 lenr ,dd_r2r,dd_r2r_elem,x)
366 ENDIF
367C
368 ENDIF
369 ENDIF
370
371 ENDIF
372
373 ELSE
374
375C------Allocation of common arrays
376 ALLOCATE(typlnk(nr2rlnk),rotlnk(nr2rlnk))
377 ALLOCATE(dbn(nr2rlnk,nspmd),nbel(nr2rlnk,nspmd))
378 ALLOCATE(tbcnel(nr2rlnk,nspmd),tbcneldb(nr2rlnk,nspmd))
379 ALLOCATE(nbeln(nr2rlnk,nspmd))
380 ALLOCATE(dbno(nr2rlnk),tcnelt(nr2rlnk),nbelt_r2r(nr2rlnk))
381 ALLOCATE(tcneltdb(nr2rlnk),offset(nspmd),nbeltn_r2r(nr2rlnk))
382 ALLOCATE(rbylnk(nr2rlnk),add_rby(nr2rlnk),kinlnk(nr2rlnk))
383 ALLOCATE(nllnk(nr2rlnk))
384C---------------------------------------
385
386 DO i = 1, rootlen
387 iroot(i) = ichar(rootnam(i:i))
388 END DO
389
390 IF(ispmd==0) THEN
391C----- Initialize Sockets
392 ALLOCATE(socket(nthread))
393 socket(1)=sock0
394 CALL send_sock_init_c(iroot,rootlen,ispmd,socket(1),
395 1 nthread,nspmd)
396 ENDIF
397C----- Synchronisation of the process - transfer of hostname
398 CALL spmd_r2r_sync(addr)
399C----- ----- ----- ----- ----- -----
400 IF(ispmd==0) THEN
401 DO itsk=2,nthread
402 CALL connection_sock_c(itsk-1,socket(itsk),addr)
403 END DO
404C----- Initialize Fifos
405 CALL openfifo_c(iroot,rootlen,r2r_fdw,r2r_fdr,socket(1),ispmd,nthread,ppid)
406 CALL opensem_c(iroot,rootlen,ispmd,nthread,ppid)
407C----- set signal catch
408 CALL get_ibuf_c(r2r_ipid,1)
409C----- send link interface data
410 CALL send_ibuf_c(nr2rlnk,1)
411 CALL send_ibuf_c(iroddl,1)
412 CALL send_fbuf_c(tt,1)
413 CALL send_fbuf_c(tstop,1)
414 CALL send_ibuf_c(ncrst,1)
415 CALL send_ibuf_c(idel7ng,1)
416 CALL send_ibuf_c(flg_sphinout_r2r,1)
417 CALL send_ibuf_c(irun,1)
418 CALL spmd_ibcast(ppid,ppid,1,1,0,2)
419 ELSE
420C----- Connect Sockets
421 ALLOCATE(socket(nthread))
422 DO itsk=1,nthread
423 num_sock = nthread*ispmd+itsk
424 CALL connection_sock_c(num_sock-1,socket(itsk),addr)
425 END DO
426 CALL spmd_ibcast(ppid,ppid,1,1,0,2)
427 CALL opensem_c(iroot,rootlen,ispmd,nthread,ppid)
428 ENDIF
429
430C----- ----- ----- ----- ----- -----
431 DO iex = 1, nr2rlnk
432 idg = iexlnk(1,iex)
433 idp = iexlnk(2,iex)
434 nng = igrnod(idg)%NENTITY
435 grnod => igrnod(idg)%ENTITY
436C------ determination of the type of interface and link
437 IF (idp>nbk) nbk = idp
438 IF(ispmd==0) THEN
439 CALL send_ibuf_c(idp,1)
440 CALL get_ibuf_c(typlnk(iex),1)
441 CALL get_ibuf_c(main_side,1)
442 CALL get_ibuf_c(rbylnk(iex),1)
443 CALL get_ibuf_c(kinlnk(iex),1)
444 CALL get_ibuf_c(nllnk(iex),1)
445 ENDIF
446c------
447 IF(nspmd>1) THEN
448 CALL spmd_ibcast(typlnk(iex),typlnk(iex),1,1,0,2)
449 CALL spmd_ibcast(main_side,main_side,1,1,0,2)
450 CALL spmd_ibcast(rbylnk(iex),rbylnk(iex),1,1,0,2)
451 CALL spmd_ibcast(kinlnk(iex),kinlnk(iex),1,1,0,2)
452 ENDIF
453C--------------Reset of weight2 for duplicated nodes--------
454 IF ((typlnk(iex)==5).AND.(main_side==1)) THEN
455 DO nn=1,nng
456 n = igrnod(idg)%ENTITY(nn)
457 weight_md(n) = 0
458 END DO
459 ENDIF
460C
461 IF (rbylnk(iex)==1) THEN
462 add_rby(iex) = size_tag_rby
463 size_tag_rby = size_tag_rby + nng
464 ENDIF
465c------
466 CALL init_link_spmd(
467 1 idp ,nng ,itab ,grnod,x,
468 2 dd_r2r(1,iex),dd_r2r(nspmd+1,iex),weight,addcnel,cnel,ixc,
469 3 ofc,iex,info,typlnk(iex),icodt,icodr,ibfv,dx)
470 END DO
471
472 IF(ispmd==0) THEN
473!
474 CALL init_activ_c(r2r_activ)
475C----- Initialize Shared Memory
476 CALL openshm_c()
477C----- CALL CHECK_RODDL_C()
478 CALL get_fbuf_c(tstop,1)
479 CALL get_ibuf_c(idel_loc,1)
480 idel7ng = max(idel7ng,idel_loc)
481 END IF
482 CALL spmd_ibcast(idel7ng,idel7ng,1,1,0,2)
483 IF (idel7ng>=1) idel7nok = 1
484C----- Actualize mass and inertia
485C IF (TT==ZERO) THEN
486 r2rfx1 = zero
487 r2rfx2 = zero
488 DO iex = 1, nr2rlnk
489 idg = iexlnk(1,iex)
490 idp = iexlnk(2,iex)
491 nng = igrnod(idg)%NENTITY
492 grnod => igrnod(idg)%ENTITY
493 IF (rbylnk(iex)==0) THEN
494 CALL send_mass_spmd(
495 1 idp,nng,grnod,ms,in,
496 2 dd_r2r(1,iex),dd_r2r(nspmd+1,iex),weight,rotlnk(iex))
497 ELSE
498 ALLOCATE (tag_rby(size_tag_rby))
499 CALL send_mass_rby_spmd(
500 1 idp,nng,grnod,ms,in,
501 2 dd_r2r(1,iex),dd_r2r(nspmd+1,iex),weight,rotlnk(iex),
502 3 npby,rby,add_rby(iex))
503 ENDIF
504 CALL spmd_ibcast(rotlnk(iex),rotlnk(iex),1,1,0,2)
505 END DO
506C
507 IF (tt==zero) THEN
508 DO iex = 1, nr2rlnk
509 idg = iexlnk(1,iex)
510 idp = iexlnk(2,iex)
511 nng = igrnod(idg)%NENTITY
512 grnod => igrnod(idg)%ENTITY
513 IF (rbylnk(iex)==0) THEN
514 CALL get_mass_spmd(
515 1 idp,nng,grnod,ms ,in ,
516 2 dd_r2r(1,iex),dd_r2r(nspmd+1,iex),weight,iad_elem,
517 3 fr_elem,rotlnk(iex))
518 ELSE
519 CALL get_mass_rby_spmd(
520 1 idp,nng,grnod,ms ,in ,
521 2 dd_r2r(1,iex),dd_r2r(nspmd+1,iex),weight,iad_elem,
522 3 fr_elem,rotlnk(iex),x,npby,rby,itab,iex,xdp)
523 ENDIF
524 END DO
525 ENDIF
526
527 END IF
528C-----------------------------------------------------------------
529 RETURN
530 END SUBROUTINE r2r_init
531!||====================================================================
532!|| init_link_spmd ../engine/source/coupling/rad2rad/r2r_init.f
533!||--- called by ------------------------------------------------------
534!|| r2r_init ../engine/source/coupling/rad2rad/r2r_init.F
535!||--- calls -----------------------------------------------------
536!|| init_buf_spmd_c ../engine/source/coupling/rad2rad/rad2rad_c.c
537!|| init_link_spmd_c ../engine/source/coupling/rad2rad/rad2rad_c.c
538!|| spmd_r2r_idef ../engine/source/mpi/r2r/spmd_r2r.F
539!|| spmd_r2r_iget ../engine/source/mpi/r2r/spmd_r2r.F
540!|| spmd_r2r_iget2 ../engine/source/mpi/r2r/spmd_r2r.F
541!|| spmd_r2r_iget4 ../engine/source/mpi/r2r/spmd_r2r.F
542!|| spmd_r2r_rget3 ../engine/source/mpi/r2r/spmd_r2r.F
543!||--- uses -----------------------------------------------------
544!|| rad2r_mod ../engine/share/modules/rad2r.F
545!||====================================================================
546 SUBROUTINE init_link_spmd(
547 1 IDP ,NNG ,ITAB ,GRNOD,X,
548 2 DD_R2R,NGLOB,WEIGHT,ADDCNEL,CNEL,IXC,OFC,IEX,INFO,TYP,
549 3 ICODT,ICODR,IBFV,DX)
550C-----------------------------------------------
551C M o d u l e s
552C-----------------------------------------------
553 USE rad2r_mod
554C-----------------------------------------------
555C I m p l i c i t T y p e s
556C-----------------------------------------------
557#include "implicit_f.inc"
558C-----------------------------------------------
559C C o m m o n B l o c k s
560C-----------------------------------------------
561#include "com01_c.inc"
562#include "com04_c.inc"
563#include "param_c.inc"
564#include "rad2r_c.inc"
565#include "task_c.inc"
566C-----------------------------------------------
567C D u m m y A r g u m e n t s
568C-----------------------------------------------
569 INTEGER IDP, NNG, NGLOB,ITAB(*), GRNOD(*),
570 . WEIGHT(*), DD_R2R(*),OFC,
571 . ADDCNEL(0:*),CNEL(0:*),IXC(NIXC,*),IEX,
572 . INFO,TYP,ICODT(*),ICODR(*),IBFV(NIFV,*)
573 my_real
574 . X(3,*),DX(3,*)
575C-----------------------------------------------
576C L o c a l V a r i a b l e s
577C-----------------------------------------------
578 INTEGER IBUF(NGLOB),TLEL,LEL(9*NNG),LELNBNOD(9*NNG),TLELN,
579 . LELNOD(9*NNG),NBELEM(NNG),CNELEM(9*NNG),IBUFNONBEL(NGLOB),
580 . TCNEL,TCNELDB,NNGDB,N,K,J,DBNBUF(NSPMD),DDBUF(NSPMD),
581 . bcs(nglob),ibufbcs(nglob),i
582 INTEGER, ALLOCATABLE :: IBUFEL(:),IBUFELNBNOD(:),IBUFELNOD(:),
583 . IBUFCNEL(:),CNELEMDB(:),DBIBUF(:),DBIBUFNONBEL(:),
584 . IBUFCNELDB(:)
585 my_real BUFR(3,NGLOB),BUFR2(3,NGLOB)
586C-----------------------------------------------
587C*******************************************************************************************************************************************************C
588C- Array: (for each spmd domain) concatenation on proc 0 : length :
589C......... BCS : boundary conditions on interface nodes -----------------------------------------------------> IBUFBCS NNG
590C......... CNELEM : list of elements attached to interface nodes --------------------------------------------> IBUFCNEL TCNELT(IEX)
591C......... NBELEM : nb of elements attached to interface nodes ----------------------------------------------> IBUFNONBEL NNG
592C......... CNELEMDB : list of elements attached to interface nodes that are on severla SPMD domains ---------> IBUFCNELDB TCNELTDB(IEX)
593C......... NBELEMDB : nb of elements attached to interface nodes that are on severla SPMD domains -----------> DBIBUFNONBEL DBNO(IEX)
594C..........LEL : List of id ( local numerotation + offset) of elements connected to the interface------------> IBUFEL NBELT_R2R(IEX)
595C..........LELNBNOD : nb of interface nodes attached to each elements connected to the interface ------------> IBUFELNBNOD NBELT_R2R(IEX)
596C..........LELNOD : List of interface nodes attached to elements of LEL -------------------------------------> IBUFELNOD NBELTN_R2R(IEX)
597C*******************************************************************************************************************************************************C
598
599 nngdb = 0
600
601 DO k = 1, nng
602 n=grnod(k)
603 IF(weight(n)==1)THEN
604 bcs(k) = 10*icodt(n)
605 IF (iroddl==1) bcs(k) = bcs(k) + icodr(n)
606 ELSE
607 nngdb = nngdb + 1
608 END IF
609 END DO
610
611C DO J = 1, NFXVEL
612C DO K = 1, NNG
613C IF ((IBFV(1,J)==GRNOD(K)).AND.(IBFV(2,J)>0)) THEN
614C BCS(K) = BCS(K) +100 ;
615C ENDIF
616C END DO
617C END DO
618
619C--------------------Search of noeuds/elements connectivities ( coupling type 1,2)-----C
620 IF (typ<4) THEN
621 ALLOCATE(cnelemdb(9*nngdb))
622 CALL init_buf_spmd_c(idp,nng,itab,grnod,x,addcnel,cnel,ixc,
623 . ofc,tlel,lel,lelnbnod,tleln,lelnod,nbelem,tcnel,cnelem,
624 . weight,tcneldb,cnelemdb,info,typ,nglob)
625 ENDIF
626
627C-----------------------------------------------------------------------------------------C
628
629 CALL spmd_r2r_idef(nng,grnod,weight,iex,tlel,tleln,tcnel,
630 . tcneldb)
631 CALL spmd_r2r_rget3(x,nng,grnod,dd_r2r,weight,bufr2)
632 CALL spmd_r2r_rget3(dx,nng,grnod,dd_r2r,weight,bufr)
633 CALL spmd_r2r_iget(itab,nng,grnod,dd_r2r,weight,ibuf,1)
634
635C--------------------Computation of initial coordinates in case of rerun------------------C
636
637 DO i=1,nglob
638 DO j=1,3
639 bufr(j,i)= bufr2(j,i)-bufr(j,i)
640 END DO
641 END DO
642
643C--------------------Allocation of buffers------------------------------------------------C
644 IF (ispmd>0) THEN
645 ALLOCATE(dbibuf(nngdb))
646 ELSE
647 ALLOCATE(dbibuf(dbno(iex)))
648 ENDIF
649
650C--------------------Allocation of element buffers ( coupling type 1,2)-------------------C
651
652 IF (typ<4) THEN
653 IF (ispmd>0) THEN
654 ALLOCATE(ibufel(tlel),ibufelnbnod(tlel),ibufelnod(tleln))
655 ALLOCATE(ibufcnel(tcnel),dbibufnonbel(nngdb))
656 ALLOCATE(ibufcneldb(tcneldb))
657 ELSE
658 ALLOCATE(ibufel(nbelt_r2r(iex)),ibufelnbnod(nbelt_r2r(iex)))
659 ALLOCATE(ibufelnod(nbeltn_r2r(iex)),ibufcnel(tcnelt(iex)))
660 ALLOCATE(dbibufnonbel(dbno(iex)))
661 ALLOCATE(ibufcneldb(tcneltdb(iex)))
662 ENDIF
663 ENDIF
664
665C--------------------Creation of buffers by concatenation of arrays------------------------C
666 CALL spmd_r2r_iget4(itab,nng,grnod,dd_r2r,weight,dbibuf,iex,
667 . dbnbuf,ddbuf,1)
668 CALL spmd_r2r_iget(bcs,nng,grnod,dd_r2r,weight,ibufbcs,0)
669
670 IF (typ<4) THEN
671 CALL spmd_r2r_iget(nbelem,nng,grnod,dd_r2r,weight,ibufnonbel,0)
672 CALL spmd_r2r_iget2(lel,tlel,iex,ibufel,1)
673 CALL spmd_r2r_iget2(cnelem,tcnel,iex,ibufcnel,3)
674 CALL spmd_r2r_iget2(cnelemdb,tcneldb,iex,ibufcneldb,4)
675 CALL spmd_r2r_iget2(lelnbnod,tlel,iex,ibufelnbnod,0)
676 CALL spmd_r2r_iget2(lelnod,tleln,iex,ibufelnod,2)
677 CALL spmd_r2r_iget4(nbelem,nng,grnod,dd_r2r,weight,
678 . dbibufnonbel,iex,dbnbuf,ddbuf,0)
679 ENDIF
680
681C--------------------Send Rad2rad-------------------------------------------------------C
682
683 IF(ispmd==0)
684 . CALL init_link_spmd_c(idp,nglob,dbno(iex),nspmd,ibuf,dbibuf,
685 . dbnbuf,ddbuf,bufr,tcnelt(iex),ibufnonbel,ibufcnel,
686 . nbelt_r2r(iex),nbeltn_r2r(iex),ibufel,ibufelnbnod,
687 . ibufelnod,tcneltdb(iex),ibufcneldb,dbibufnonbel,typ,
688 . ibufbcs,ncpri,iroddl,nbk,nr2rlnk,iex)
689
690C------------------------------------------------------------------------C
691 DEALLOCATE(dbibuf)
692
693 IF (typ<4) THEN
694 DEALLOCATE(ibufel,ibufelnbnod,ibufelnod,ibufcnel,cnelemdb)
695 DEALLOCATE(dbibufnonbel,ibufcneldb)
696 ENDIF
697
698 RETURN
699 END SUBROUTINE init_link_spmd
700C
701!||====================================================================
702!|| send_mass_spmd ../engine/source/coupling/rad2rad/r2r_init.F
703!||--- called by ------------------------------------------------------
704!|| r2r_init ../engine/source/coupling/rad2rad/r2r_init.F
705!||--- calls -----------------------------------------------------
706!|| send_mass_spmd_c ../engine/source/coupling/rad2rad/rad2rad_c.c
707!|| spmd_r2r_rget ../engine/source/mpi/r2r/spmd_r2r.F
708!||====================================================================
709 SUBROUTINE send_mass_spmd(
710 1 IDP ,NNG ,GRNOD, MS, IN,
711 2 DD_R2R ,NGLOB ,WEIGHT ,FLAG_ROT )
712C----6---------------------------------------------------------------7---------8
713C I m p l i c i t T y p e s
714C-----------------------------------------------
715#include "implicit_f.inc"
716C-----------------------------------------------
717C C o m m o n B l o c k s
718C-----------------------------------------------
719#include "com01_c.inc"
720#include "task_c.inc"
721C-----------------------------------------------
722C D u m m y A r g u m e n t s
723C-----------------------------------------------
724 INTEGER IDP, NNG, NGLOB, GRNOD(*),WEIGHT(*), DD_R2R(*),FLAG_ROT
725 my_real MS(*), IN(*)
726C-----------------------------------------------
727C L o c a l V a r i a b l e s
728C-----------------------------------------------
729 my_real BUFR1(NGLOB), BUFR2(NGLOB)
730C
731C******************************************************************************C
732 CALL SPMD_R2R_RGET(MS,NNG,GRNOD,DD_R2R,WEIGHT,BUFR1)
733 IF(IRODDL /= 0)then
734 CALL spmd_r2r_rget(in,nng,grnod,dd_r2r,weight,bufr2)
735 ENDIF
736 IF(ispmd==0)
737 . CALL send_mass_spmd_c(idp,nglob,bufr1,bufr2,flag_rot)
738C-----------------------------------------------------------------
739 RETURN
740 END SUBROUTINE send_mass_spmd
741C
742!||====================================================================
743!|| get_mass_spmd ../engine/source/coupling/rad2rad/r2r_init.F
744!||--- called by ------------------------------------------------------
745!|| r2r_init ../engine/source/coupling/rad2rad/r2r_init.F
746!||--- calls -----------------------------------------------------
747!|| get_mass_spmd_c ../engine/source/coupling/rad2rad/rad2rad_c.c
748!|| spmd_r2r_rset4 ../engine/source/mpi/r2r/spmd_r2r.F
749!||====================================================================
750 SUBROUTINE get_mass_spmd(
751 1 IDP ,NNG ,GRNOD,MS ,IN,DD_R2R ,
752 2 NGLOB ,WEIGHT ,IAD_ELEM,FR_ELEM,FLAG_ROT)
753C-----------------------------------------------
754C I m p l i c i t T y p e s
755C-----------------------------------------------
756#include "implicit_f.inc"
757C-----------------------------------------------
758C C o m m o n B l o c k s
759C-----------------------------------------------
760#include "com01_c.inc"
761#include "task_c.inc"
762C-----------------------------------------------
763C D u m m y A r g u m e n t s
764C-----------------------------------------------
765 INTEGER IDP, NNG, NGLOB,
766 . GRNOD(*),FLAG_ROT,
767 . WEIGHT(*), DD_R2R(*), IAD_ELEM(2,*), FR_ELEM(*)
768 my_real MS(*), IN(*)
769C-----------------------------------------------
770C L o c a l V a r i a b l e s
771C-----------------------------------------------
772 INTEGER LRBUF
773 my_real BUFR1(NGLOB), BUFR2(NGLOB)
774C
775C******************************************************************************C
776 IF(ISPMD==0)
777 . CALL get_mass_spmd_c(idp,nglob,bufr1,bufr2)
778 lrbuf = 2*2*(iad_elem(1,nspmd+1)-iad_elem(1,1))+2*nspmd
779 CALL spmd_r2r_rset4(ms ,nng ,grnod,dd_r2r,weight,
780 . bufr1,iad_elem,fr_elem,lrbuf )
781 IF(flag_rot /= 0)THEN
782 CALL spmd_r2r_rset4(in ,nng ,grnod,dd_r2r,weight,
783 . bufr2,iad_elem,fr_elem,lrbuf )
784 ENDIF
785C-----------------------------------------------------------------
786 RETURN
787 END SUBROUTINE get_mass_spmd
788C
789!||====================================================================
790!|| send_mass_rby_spmd ../engine/source/coupling/rad2rad/r2r_init.F
791!||--- called by ------------------------------------------------------
792!|| r2r_init ../engine/source/coupling/rad2rad/r2r_init.F
793!||--- calls -----------------------------------------------------
794!|| send_mass_rby_spmd_c ../engine/source/coupling/rad2rad/rad2rad_c.c
795!|| spmd_r2r_iget ../engine/source/mpi/r2r/spmd_r2r.F
796!|| spmd_r2r_rget ../engine/source/mpi/r2r/spmd_r2r.F
797!||--- uses -----------------------------------------------------
798!|| rad2r_mod ../engine/share/modules/rad2r.F
799!||====================================================================
800 SUBROUTINE send_mass_rby_spmd(
801 1 IDP ,NNG ,GRNOD, MS, IN,
802 2 DD_R2R ,NGLOB ,WEIGHT ,FLAG_ROT,
803 3 NPBY ,RBY, ADDR)
804C-----------------------------------------------
805C M o d u l e s
806C-----------------------------------------------
807 USE rad2r_mod
808C-----------------------------------------------
809C I m p l i c i t T y p e s
810C-----------------------------------------------
811#include "implicit_f.inc"
812C-----------------------------------------------
813C C o m m o n B l o c k s
814C-----------------------------------------------
815#include "com01_c.inc"
816#include "com04_c.inc"
817#include "param_c.inc"
818#include "task_c.inc"
819C-----------------------------------------------
820C D u m m y A r g u m e n t s
821C-----------------------------------------------
822 INTEGER IDP, NNG, NGLOB,GRNOD(*),
823 . WEIGHT(*), DD_R2R(*),FLAG_ROT,
824 . NPBY(*), ADDR
825 my_real
826 . MS(*), IN(*), RBY(NRBY,*)
827C-----------------------------------------------
828C L o c a l V a r i a b l e s
829C-----------------------------------------------
830 INTEGER I,J,IDRBY(NNG),N,IBUF(NGLOB),BUFR3(NGLOB)
831 my_real
832 . BUFR1(NGLOB),BUFR2(NGLOB),BUFR4(NGLOB),
833 . BUFR5(9*NGLOB)
834C
835C******************************************************************************C
836 CALL SPMD_R2R_RGET(MS,NNG,GRNOD,DD_R2R,WEIGHT,BUFR1)
837 IF(iroddl /= 0)THEN
838 CALL spmd_r2r_rget(in,nng,grnod,dd_r2r,weight,bufr2)
839 ENDIF
840
841C-----------------------------------------------------------------------
842 DO i=1,nng
843 n=grnod(i)
844 DO j = 1,nrbody
845 IF ((n==npby(nnpby*(j-1)+1)).AND.(n>0)) THEN
846 idrby(i) = j
847 tag_rby(addr+i) = j
848 ENDIF
849 END DO
850 END DO
851
852 CALL spmd_r2r_iget(idrby,nng,grnod,dd_r2r,weight,ibuf,0)
853C-----------------------------------------------------------------------
854
855 IF(ispmd==0) THEN
856C-----------------------------------------------------------------------
857 DO i = 1, nglob
858 n = ibuf(i)
859 bufr3(i)= npby(nnpby*(n-1)+3)
860 bufr4(i)= rby(15,n)
861 DO j = 1,9
862 bufr5(9*(i-1)+j)= rby(16+j,n)
863 END DO
864 END DO
865C-----------------------------------------------------------------------
866 CALL send_mass_rby_spmd_c(idp,nglob,bufr1,bufr2,bufr3,
867 . bufr4,bufr5,flag_rot)
868 ENDIF
869C-----------------------------------------------------------------
870 RETURN
871 END SUBROUTINE send_mass_rby_spmd
872C
873!||====================================================================
874!|| get_mass_rby_spmd ../engine/source/coupling/rad2rad/r2r_init.F
875!||--- called by ------------------------------------------------------
876!|| r2r_init ../engine/source/coupling/rad2rad/r2r_init.F
877!||--- calls -----------------------------------------------------
878!|| get_mass_rby_spmd_c ../engine/source/coupling/rad2rad/rad2rad_c.c
879!|| r2r_rby ../engine/source/coupling/rad2rad/r2r_init.F
880!|| spmd_ibcast ../engine/source/mpi/generic/spmd_ibcast.F
881!|| spmd_r2r_iget ../engine/source/mpi/r2r/spmd_r2r.f
882!|| spmd_rbcast ../engine/source/mpi/generic/spmd_rbcast.F
883!||====================================================================
884 SUBROUTINE get_mass_rby_spmd(
885 1 IDP ,NNG ,GRNOD,MS ,IN,DD_R2R ,
886 2 NGLOB ,WEIGHT ,IAD_ELEM,FR_ELEM,FLAG_ROT,
887 3 X,NPBY,RBY,ITAB,IEX,XDP)
888C-----------------------------------------------
889C I m p l i c i t T y p e s
890C-----------------------------------------------
891#include "implicit_f.inc"
892C-----------------------------------------------
893C C o m m o n B l o c k s
894C-----------------------------------------------
895#include "com01_c.inc"
896#include "com04_c.inc"
897#include "param_c.inc"
898#include "task_c.inc"
899#include "scr05_c.inc"
900C-----------------------------------------------
901C D u m m y A r g u m e n t s
902C-----------------------------------------------
903 INTEGER IDP, NNG, NGLOB,
904 . GRNOD(*),FLAG_ROT,IEX,
905 . WEIGHT(*), DD_R2R(*), IAD_ELEM(2,*), FR_ELEM(*),
906 . NPBY(*),ITAB(*)
907 my_real MS(*), IN(*), X(3,*), RBY(NRBY,*)
908 DOUBLE PRECISION XDP(3,*)
909C-----------------------------------------------
910C L o c a l V a r i a b l e s
911C-----------------------------------------------
912 INTEGER LRBUF,I,N,J,IDRBY(NNG),IBUF(NGLOB),IBUF2(NGLOB),
913 . ID_RB
914 my_real
915 . BUFR1(NGLOB),BUFR2(NGLOB),BUFR3(3*NGLOB),BUFR4(9*NGLOB),
916 . RBY_X(3,NRBODY)
917C-----------------------------------------------
918
919C--------------> Computation of RBY on proc 0---------------------------
920
921C-----------------------------------------------------------------------
922 DO i=1,nng
923 n=grnod(i)
924 DO j = 1,nrbody
925 IF ((n==npby(nnpby*(j-1)+1)).AND.(n>0)) idrby(i) = j
926 END DO
927 END DO
928 CALL spmd_r2r_iget(idrby,nng,grnod,dd_r2r,weight,ibuf,0)
929 CALL spmd_r2r_iget(itab,nng,grnod,dd_r2r,weight,ibuf2,1)
930
931C-----------------------------------------------------------------------
932
933 IF(ispmd==0) THEN
934 CALL get_mass_rby_spmd_c(idp,nglob,bufr1,bufr2,bufr3,bufr4)
935 DO i = 1, nglob
936 IF(ispmd==0) THEN
937 n = ibuf(i)
938 DO j = 1,3
939 rby_x(j,n)=bufr3(3*(i-1)+j)
940 END DO
941 DO j = 1,9
942 rby(16+j,n)=bufr4(9*(i-1)+j)
943 END DO
944 ENDIF
945 END DO
946 CALL r2r_rby(nglob,ibuf2,ibuf,bufr3,bufr1,bufr2,npby,rby,
947 . xdp,nspmd,weight)
948 ENDIF
949
950C--------------> Exchange of RBY between SPMD domains---------------------------
951
952 DO i = 1, nglob
953 IF(ispmd==0) n = ibuf(i)
954 CALL spmd_ibcast(n,n,1,1,0,2)
955 CALL spmd_rbcast(rby_x(1,n),rby_x(1,n),3,1,0,2)
956 CALL spmd_rbcast(rby(1,n),rby(1,n),nrby,1,0,2)
957 END DO
958
959C--------> Affectation of X,M and I for each SPMD domain -------
960
961 DO i = 1,nng
962 n = grnod(i)
963 DO j = 1,nrbody
964 IF ((n==npby(nnpby*(j-1)+1)).AND.(n>0)) id_rb = j
965 END DO
966 x(1,n) = rby_x(1,id_rb)
967 x(2,n) = rby_x(2,id_rb)
968 x(3,n) = rby_x(3,id_rb)
969 IF (iresp==1) THEN
970C-------Simple precision -> XDP is updated-----
971 xdp(1,n)=x(1,n)
972 xdp(2,n)=x(2,n)
973 xdp(3,n)=x(3,n)
974 ENDIF
975 ms(n) = rby(14,id_rb)
976 in(n) = min(rby(10,id_rb),rby(11,id_rb),rby(12,id_rb))
977 END DO
978
979C-----------------------------------------------------------------
980 RETURN
981 END SUBROUTINE get_mass_rby_spmd
982C
983!||====================================================================
984!|| r2r_rby ../engine/source/coupling/rad2rad/r2r_init.F
985!||--- called by ------------------------------------------------------
986!|| get_mass_rby_spmd ../engine/source/coupling/rad2rad/r2r_init.F
987!|| r2r_init ../engine/source/coupling/rad2rad/r2r_init.F
988!||--- calls -----------------------------------------------------
989!|| inepri ../engine/source/constraints/general/rbody/inepri.F
990!||====================================================================
991 SUBROUTINE r2r_rby(NNOD,ITAB,IBUF,X,MS,IN,NPBY,RBY,XDP,NPROC,
992 . WEIGHT)
993C-----------------------------------------------
994C I m p l i c i t T y p e s
995C-----------------------------------------------
996#include "implicit_f.inc"
997C-----------------------------------------------
998C C o m m o n B l o c k s
999C-----------------------------------------------
1000#include "com04_c.inc"
1001#include "param_c.inc"
1002#include "units_c.inc"
1003#include "scr05_c.inc"
1004C-----------------------------------------------
1005C D u m m y A r g u m e n t s
1006C-----------------------------------------------
1007 INTEGER NNOD,IBUF(*),NPBY(*),ITAB(*),NPROC,WEIGHT(*)
1008 my_real MS(*), IN(*), X(*), RBY(NRBY,*)
1009 DOUBLE PRECISION XDP(3,*)
1010C-----------------------------------------------
1011C L o c a l V a r i a b l e s
1012C-----------------------------------------------
1013 INTEGER I,J,K,N,ID,NOD,W,TAG(NRBODY)
1014 my_real RBYL(NRBY),XIIN
1015C
1016C******************************************************************************C
1017 TAG(:) = 0
1018
1019 do i=1,nnod
1020 rbyl = 0
1021 IF (nproc<2) THEN
1022 n = ibuf(i)
1023 DO j=1,nrbody
1024 IF (n==npby(nnpby*(j-1)+1)) id = j
1025 END DO
1026 ELSE
1027 n = i
1028 id = ibuf(i)
1029 ENDIF
1030 DO j=1,9
1031 rbyl(j)=rby(16+j,id)
1032 END DO
1033C---------Computation of principal inertias-----------------------
1034 CALL inepri(rbyl(10),rbyl)
1035C---------spherical inertia---------------------------------------
1036 IF (npby(nnpby*(id-1)+5)==1) THEN
1037 xiin = (rbyl(10)+rbyl(11)+rbyl(12))* third
1038 rbyl(10)=xiin
1039 rbyl(11)=xiin
1040 rbyl(12)=xiin
1041 ENDIF
1042C-----------------------------------------------------------------
1043 DO j=1,12
1044 rby(j,id) = rbyl(j)
1045 END DO
1046 rby(14,id) = ms(n)
1047 IF (nproc<2) in(n) = min(rbyl(10),rbyl(11),rbyl(12))
1048 tag(id)=n
1049 END DO
1050
1051C---------Printout for Rigid bodies------------------------------
1052 DO id=1,nrbody
1053 n = tag(id)
1054 IF (n/=0) THEN
1055 IF (weight(n)==1) WRITE(iout,1000)
1056 nod = itab(n)
1057 IF ((iresp==1).AND.(nproc==1)) THEN
1058C-------Simple precision + nproc=1 -> update of XDP--------------
1059 xdp(1,n)=x(3*(n-1)+1)
1060 xdp(2,n)=x(3*(n-1)+2)
1061 xdp(3,n)=x(3*(n-1)+3)
1062 ENDIF
1063 IF (weight(n)==1) THEN
1064 IF (npby(nnpby*(id-1)+5)==1) THEN
1065C-------Spherical inertia -> global matrix is not printed-----
1066 WRITE(iout,1100) id,nod,x(3*(n-1)+1),x(3*(n-1)+2),x(3*(n-1)+3),
1067 . 2*ms(n)
1068 ELSE
1069 WRITE(iout,1100) npby(nnpby*(id-1)+6),nod,x(3*(n-1)+1),
1070 . x(3*(n-1)+2),x(3*(n-1)+3),2*ms(n)
1071 WRITE(iout,1300) 2*rby(17,id),2*rby(21,id),2*rby(25,id),
1072 . 2*rby(18,id),2*rby(22,id),2*rby(19,id)
1073 ENDIF
1074 WRITE(iout,1200) 2*rby(10,id),2*rby(11,id),2*rby(12,id)
1075 ENDIF
1076 ENDIF
1077 END DO
1078
1079C-----------------------------------------------------------------
1080 RETURN
1081C
10821000 FORMAT(/40h multidomains -> rigid body assemblage )
10831100 FORMAT(5x,'RIGID BODY ID',i10
1084 . /10x,'PRIMARY NODE ',i10
1085 . /10x,'NEW X,Y,Z ',1p3g14.7
1086 . /10x,'NEW MASS ',1g14.7)
10871300 FORMAT(10x,'NEW INERTIA xx yy zz ',3g14.7
1088 . /10x,'NEW INERTIA xy yz zx ',3g14.7)
10891200 FORMAT(10x,'PRINCIPAL INERTIA',1p3g20.13,/)
1090 END SUBROUTINE r2r_rby
1091C
my_real
#define my_real
Definition cppsort.cpp:32
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
groupdef_mod
Definition groupdef_mod.F:662
message_mod
Definition message_mod.F:1249
nlocal_reg_mod
Definition nlocal_reg_mod.F:117
rad2r_mod
Definition rad2r.F:46
rad2r_mod::nllnk
integer, dimension(:), allocatable nllnk
Definition rad2r.F:53
rad2r_mod::rbylnk
integer, dimension(:), allocatable rbylnk
Definition rad2r.F:53
rad2r_mod::dbn
integer, dimension(:,:), allocatable dbn
Definition rad2r.F:58
rad2r_mod::nbdof_nl
integer, dimension(:), allocatable nbdof_nl
Definition rad2r.F:53
rad2r_mod::tcnelt
integer, dimension(:), allocatable tcnelt
Definition rad2r.F:53
rad2r_mod::socket
integer, dimension(:), allocatable socket
Definition rad2r.F:53
rad2r_mod::tcneltdb
integer, dimension(:), allocatable tcneltdb
Definition rad2r.F:53
rad2r_mod::offset
integer, dimension(:), allocatable offset
Definition rad2r.F:53
rad2r_mod::rotlnk
integer, dimension(:), allocatable rotlnk
Definition rad2r.F:53
rad2r_mod::r2r_fdr
integer r2r_fdr
Definition rad2r.F:64
rad2r_mod::tbcnel
integer, dimension(:,:), allocatable tbcnel
Definition rad2r.F:58
rad2r_mod::tag_rby
integer, dimension(:), allocatable tag_rby
Definition rad2r.F:53
rad2r_mod::nbeln
integer, dimension(:,:), allocatable nbeln
Definition rad2r.F:58
rad2r_mod::iadd_nl
integer, dimension(:), allocatable iadd_nl
Definition rad2r.F:53
rad2r_mod::nbeltn_r2r
integer, dimension(:), allocatable nbeltn_r2r
Definition rad2r.F:53
rad2r_mod::nbel
integer, dimension(:,:), allocatable nbel
Definition rad2r.F:58
rad2r_mod::r2r_fdw
integer r2r_fdw
Definition rad2r.F:64
rad2r_mod::dd_r2r_nl
integer, dimension(2) dd_r2r_nl
Definition rad2r.F:64
rad2r_mod::add_rby
integer, dimension(:), allocatable add_rby
Definition rad2r.F:53
rad2r_mod::typlnk
integer, dimension(:), allocatable typlnk
Definition rad2r.F:53
rad2r_mod::r2r_kine
double precision, dimension(:,:), allocatable r2r_kine
Definition rad2r.F:61
rad2r_mod::nbelt_r2r
integer, dimension(:), allocatable nbelt_r2r
Definition rad2r.F:53
rad2r_mod::tbcneldb
integer, dimension(:,:), allocatable tbcneldb
Definition rad2r.F:58
rad2r_mod::kinlnk
integer, dimension(:), allocatable kinlnk
Definition rad2r.F:53
rad2r_mod::dbno
integer, dimension(:), allocatable dbno
Definition rad2r.F:53
rad2r_mod::r2r_ipid
integer r2r_ipid
Definition rad2r.F:64
r2r_rby
subroutine r2r_rby(nnod, itab, ibuf, x, ms, in, npby, rby, xdp, nproc, weight)
Definition r2r_init.F:993
get_mass_spmd
subroutine get_mass_spmd(idp, nng, grnod, ms, in, dd_r2r, nglob, weight, iad_elem, fr_elem, flag_rot)
Definition r2r_init.F:753
get_mass_rby_spmd
subroutine get_mass_rby_spmd(idp, nng, grnod, ms, in, dd_r2r, nglob, weight, iad_elem, fr_elem, flag_rot, x, npby, rby, itab, iex, xdp)
Definition r2r_init.F:888
init_link_spmd
subroutine init_link_spmd(idp, nng, itab, grnod, x, dd_r2r, nglob, weight, addcnel, cnel, ixc, ofc, iex, info, typ, icodt, icodr, ibfv, dx)
Definition r2r_init.F:550
send_mass_rby_spmd
subroutine send_mass_rby_spmd(idp, nng, grnod, ms, in, dd_r2r, nglob, weight, flag_rot, npby, rby, addr)
Definition r2r_init.F:804
r2r_init
subroutine r2r_init(iexlnk, itab, igrnod, x, ms, in, dd_r2r, weight, iad_elem, fr_elem, addcnel, cnel, ixc, iparg, icodt, icodr, ibfv, dx, rby, npby, xdp, stifn, stifr, dd_r2r_elem, sdd_r2r_elem, weight_md, ilenxv, numsph_glo_r2r, flg_sphinout_r2r, ipari, nloc_dmg)
Definition r2r_init.F:70
send_mass_spmd
subroutine send_mass_spmd(idp, nng, grnod, ms, in, dd_r2r, nglob, weight, flag_rot)
Definition r2r_init.F:712
init_link_c
void init_link_c(int *igd, int *nng, int *itab, int *nodbuf, my_real_c *x, int *addcnel, int *cnel, int *ixc, int *ofc, int *info, int *typ, int *cdt, int *cdr, int *print, int *rddl, int *nlink, my_real_c *dx)
Definition rad2rad_c.c:451
opensem_c
void opensem_c(int *iroot, int *len, int *ispmd, int *nthr, int *ppid)
Definition rad2rad_c.c:246
get_name_c
void get_name_c(char *name)
Definition rad2rad_c.c:2607
get_fbuf_c
void get_fbuf_c(my_real_c *fbuf, int *len)
Definition rad2rad_c.c:995
init_link_nl_c
void init_link_nl_c(int *igd, int *nng, int *itab, int *nodbuf, my_real_c *x, int *print, my_real_c *dx, int *ndof_nl, int *nb_tot_dof, int *nlnk)
Definition rad2rad_c.c:646
get_mass_rby_c
void get_mass_rby_c(int *idp, int *nng, int *nodbuf, my_real_c *ms, my_real_c *in, my_real_c *x, int *npby, int *nrbody, my_real_c *rby, int *nnpby, int *nrby)
Definition rad2rad_c.c:1290
get_mass_c
void get_mass_c(int *idp, int *nng, int *nodbuf, my_real_c *ms, my_real_c *in)
Definition rad2rad_c.c:1253
send_mass_spmd_c
void send_mass_spmd_c(int *idp, int *nng, my_real_c *buf1, my_real_c *buf2, int *iroddl)
Definition rad2rad_c.c:1198
get_mass_rby_spmd_c
void get_mass_rby_spmd_c(int *idp, int *nng, my_real_c *buf1, my_real_c *buf2, my_real_c *buf3, my_real_c *buf4)
Definition rad2rad_c.c:1364
openshm_c
void openshm_c()
Definition rad2rad_c.c:284
init_link_spmd_c
void init_link_spmd_c(int *igd, int *nng, int *dbnod, int *nbproc, int *ibuf, int *dbibuf, int *dbnbuf, int *ddbuf, my_real_c *rbuf, int *dim, int *ibufnb, int *ibufcnel, int *nbel, int *dimel, int *ibufel, int *ibufelnbnod, int *ibufelnod, int *dimb, int *ibufcneldb, int *ibufnbeldb, int *typ, int *bcs, int *print, int *rddl, int *nl, int *nlnk, int *iex)
Definition rad2rad_c.c:853
send_mass_rby_spmd_c
void send_mass_rby_spmd_c(int *idp, int *nng, my_real_c *buf1, my_real_c *buf2, int *buf3, my_real_c *buf4, my_real_c *buf5, int *iroddl)
Definition rad2rad_c.c:1223
init_buf_spmd_c
void init_buf_spmd_c(int *igd, int *nng, int *itab, int *nodbuf, my_real_c *x, int *addcnel, int *cnel, int *ixc, int *ofc, int *tlel, int *lel, int *lelnb, int *tleln, int *leln, int *nbelem, int *tcnel, int *cnelem2, int *wgt, int *tcneldb, int *cnelemdb, int *info, int *typ, int *nglob)
Definition rad2rad_c.c:706
init_activ_c
void init_activ_c(int *activ)
Definition rad2rad_c.c:1181
send_fbuf_c
void send_fbuf_c(my_real_c *fbuf, int *len)
Definition rad2rad_c.c:958
get_mass_spmd_c
void get_mass_spmd_c(int *idp, int *nng, my_real_c *buf1, my_real_c *buf2)
Definition rad2rad_c.c:1343
send_sock_init_c
void send_sock_init_c(int *iroot, int *len, int *ispmd, int *sd, int *maxproc, int *imach)
Definition rad2rad_c.c:2202
send_ibuf_c
void send_ibuf_c(int *ibuf, int *len)
Definition rad2rad_c.c:940
get_ibuf_c
void get_ibuf_c(int *ibuf, int *len)
Definition rad2rad_c.c:1031
send_mass_rby_c
void send_mass_rby_c(int *idp, int *nng, int *nodbuf, my_real_c *ms, my_real_c *in, int *npby, int *nrbody, my_real_c *rby, int *tag, int *add_rby, int *nnpby, int *nrby)
Definition rad2rad_c.c:1121
send_mass_nl_c
void send_mass_nl_c(int *idp, int *nng, int *iadd_nl, my_real_c *ms)
Definition rad2rad_c.c:1090
connection_sock_c
void connection_sock_c(int *ispmd, int *sd, char *addr)
Definition rad2rad_c.c:2268
send_mass_c
void send_mass_c(int *idp, int *nng, int *nodbuf, my_real_c *ms, my_real_c *in)
Definition rad2rad_c.c:1048
openfifo_c
void openfifo_c(int *iroot, int *len, int *fdw, int *fdr, int *sd, int *ispmd, int *nthr, int *ppid)
Definition rad2rad_c.c:158
spmd_allglob_isum9
subroutine spmd_allglob_isum9(v, len)
Definition spmd_allglob_isum9.F:46
spmd_ibcast
subroutine spmd_ibcast(tabi, tabr, n1, n2, from, add)
Definition spmd_ibcast.F:57
spmd_r2r_iget4
subroutine spmd_r2r_iget4(itab, nng, grnod, dd_r2r, weight, ibuf, iex, dbnbuf, ddbuf, flag)
Definition spmd_r2r.F:615
spmd_r2r_rget3
subroutine spmd_r2r_rget3(x, nng, grnod, dd_r2r, weight, bufr)
Definition spmd_r2r.F:34
spmd_exch_r2r
subroutine spmd_exch_r2r(a, ar, stifn, stifr, ms, iad_elem, fr_elem, size, lenr, dd_r2r, dd_r2r_elem, flag)
Definition spmd_r2r.F:1180
spmd_r2r_rset4
subroutine spmd_r2r_rset4(m, nng, grnod, dd_r2r, weight, bufr, iad_elem, fr_elem, lrbuf)
Definition spmd_r2r.F:856
spmd_r2r_iget2
subroutine spmd_r2r_iget2(itab, nng, iex, ibuf, flag)
Definition spmd_r2r.F:512
spmd_r2r_iget
subroutine spmd_r2r_iget(itab, nng, grnod, dd_r2r, weight, ibuf, flag)
Definition spmd_r2r.F:437
spmd_r2r_sync
subroutine spmd_r2r_sync(addr)
Definition spmd_r2r.F:700
spmd_exch_r2r_rby
subroutine spmd_exch_r2r_rby(npby, rby, iad_elem, fr_elem, size, lenr, dd_r2r, dd_r2r_elem, x)
Definition spmd_r2r.F:1570
spmd_r2r_idef
subroutine spmd_r2r_idef(nng, grnod, weight, iex, tlel, tleln, tcnel, tcneldb)
Definition spmd_r2r.F:329
spmd_rbcast
subroutine spmd_rbcast(tabi, tabr, n1, n2, from, add)
Definition spmd_rbcast.F:62
inepri
subroutine inepri(xi, bm)
Definition inepri.F:34
nlocal_reg_mod::nlocal_str_
Definition nlocal_reg_mod.F:124