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