OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
imp_fri.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!|| imp_fri ../engine/source/mpi/implicit/imp_fri.F
25!||--- called by ------------------------------------------------------
26!|| imp_chkm ../engine/source/implicit/imp_solv.F
27!|| imp_intfr ../engine/source/implicit/imp_solv.F
28!||--- calls -----------------------------------------------------
29!|| imp_frkd ../engine/source/mpi/implicit/imp_fri.F
30!|| imp_frki ../engine/source/mpi/implicit/imp_fri.f
31!|| imp_frsl ../engine/source/mpi/implicit/imp_fri.F
32!|| spmd_sumf_v ../engine/source/mpi/implicit/imp_spmd.F
33!||--- uses -----------------------------------------------------
34!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
35!||====================================================================
36 SUBROUTINE imp_fri(
37 1 NUM_IMP ,NS_IMP ,NE_IMP ,IPARI ,INTBUF_TAB,
38 2 NPBY ,LPBY ,ITAB ,NRBYAC ,
39 3 IRBYAC ,NINT2 ,IINT2 ,IDDL ,IKC ,
40 4 NDOF ,INLOC ,NSREM ,NSL ,NBINTC ,
41 5 INTLIST ,X ,IBFV ,LJ ,SKEW ,
42 6 XFRAME ,ISKEW ,ICODT ,A ,UD ,
43 7 LB ,IFDIS ,NDDL ,URD ,IDDLI ,
44 8 IRBE3 ,LRBE3 ,FRBE3 ,IRBE2 ,LRBE2 )
45C-----------------------------------------------
46C M o d u l e s
47C-----------------------------------------------
48 USE intbufdef_mod
49C----6---------------------------------------------------------------7---------8
50C I m p l i c i t T y p e s
51C-----------------------------------------------
52#include "implicit_f.inc"
53C-----------------------------------------------
54C C o m m o n B l o c k s
55C-----------------------------------------------
56#include "param_c.inc"
57#include "impl1_c.inc"
58C-----------------------------------------------------------------
59C D u m m y A r g u m e n t s
60C-----------------------------------------------
61 INTEGER IPARI(NPARI,*),NUM_IMP(*),NS_IMP(*),
62 . NE_IMP(*),NSREM ,NSL,NBINTC,INTLIST(*),
63 . IRBE3(*),LRBE3(*),IRBE2(*),LRBE2(*)
64 INTEGER NPBY(NNPBY,*),LPBY(*),ITAB(*),NRBYAC,IRBYAC(*),
65 . NINT2,IINT2(*),IDDL(*),IKC(*),NDOF(*),INLOC(*),
66 . IBFV(*),LJ(*),ISKEW(*),ICODT(*),IFDIS,NDDL,IDDLI(*)
67C REAL
68 my_real
69 . x(3,*),skew(*) ,xframe(*),
70 . a(3,*),ud(3,*),lb(*),urd(3,*),frbe3(*)
71
72 TYPE(intbuf_struct_) INTBUF_TAB(*)
73C-----------------------------------------------
74C L o c a l V a r i a b l e s
75C-----------------------------------------------
76 INTEGER I,IKPAT0
77 my_real,
78 . DIMENSION(:),ALLOCATABLE :: LB0
79C-----------------------------------------------
80 CALL imp_frsl(nbintc,nsrem ,nsl )
81C-----------------------------------------------
82 IF (intp_c>0) THEN
83 ALLOCATE(lb0(nddl))
84 lb0=zero
85 ENDIF
86 IF ((nsrem+nsl)>0) THEN
87 IF (intp_c<=0) THEN
88 CALL imp_frki(
89 1 ipari ,intbuf_tab,num_imp ,ns_imp ,ne_imp ,
90 2 npby ,lpby ,itab ,nrbyac ,irbyac ,
91 3 nint2 ,iint2 ,iddl ,ikc ,ndof ,
92 4 inloc ,nsrem ,nsl ,nbintc ,intlist ,
93 5 x ,ibfv ,lj ,skew ,
94 6 xframe ,iskew ,icodt ,irbe3 ,lrbe3 ,
95 7 frbe3 ,irbe2 ,lrbe2 )
96 ELSE
97 ikpat0 = ikpat
98 ikpat = 1
99 CALL imp_frkd(
100 1 npby ,lpby ,itab ,nrbyac ,irbyac ,
101 2 ipari ,intbuf_tab,nint2 ,iint2 ,iddl ,
102 3 ikc ,ndof ,inloc ,nsrem ,nsl ,
103 4 nbintc ,intlist ,x ,ibfv ,
104 5 lj ,skew ,xframe ,iskew ,icodt ,
105 6 a ,ud ,lb0 ,ifdis ,urd ,
106 7 iddli ,irbe3 ,lrbe3 ,frbe3 ,irbe2 ,
107 8 lrbe2 )
108 ikpat = ikpat0
109 ENDIF
110 ENDIF
111 IF (intp_c>0) THEN
112 CALL spmd_sumf_v(lb0)
113 DO i=1,nddl
114 lb(i) = lb(i)+lb0(i)
115 ENDDO
116 DEALLOCATE(lb0)
117 ENDIF
118C----6---------------------------------------------------------------7---------8
119 RETURN
120 END
121!||====================================================================
122!|| imp_frfv ../engine/source/mpi/implicit/imp_fri.F
123!||--- called by ------------------------------------------------------
124!|| imp_chkm ../engine/source/implicit/imp_solv.F
125!|| imp_intfr ../engine/source/implicit/imp_solv.F
126!||--- calls -----------------------------------------------------
127!|| fr_matv ../engine/source/mpi/implicit/imp_fri.F
128!|| ini_dd0 ../engine/source/mpi/implicit/imp_fri.F
129!|| ini_ddfv ../engine/source/mpi/implicit/imp_fri.F
130!|| produt_vmhp ../engine/source/implicit/produt_v.F
131!|| spmd_sumf_v ../engine/source/mpi/implicit/imp_spmd.F
132!||--- uses -----------------------------------------------------
133!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
134!||====================================================================
135 SUBROUTINE imp_frfv(
136 1 NUM_IMP ,NS_IMP ,NE_IMP ,IPARI ,INTBUF_TAB,
137 2 IDDL ,IKC ,NDOF ,NSREM ,
138 3 NSL ,D_IMP ,DD ,DR_IMP ,DDR ,
139 4 A ,AR ,MS ,V ,X ,
140 5 LB ,NDDL ,IBFV ,SKEW ,XFRAME ,
141 6 IRBE3 ,LRBE3 ,IRBE2 ,LRBE2 ,DE ,
142 7 NDDL0 ,W_DDL )
143C-----------------------------------------------
144C M o d u l e s
145C-----------------------------------------------
146 USE intbufdef_mod
147C----6---------------------------------------------------------------7---------8
148C I m p l i c i t T y p e s
149C-----------------------------------------------
150#include "implicit_f.inc"
151C-----------------------------------------------
152C C o m m o n B l o c k s
153C-----------------------------------------------
154#include "com01_c.inc"
155#include "com04_c.inc"
156#include "param_c.inc"
157#include "impl1_c.inc"
158C-----------------------------------------------------------------
159C D u m m y A r g u m e n t s
160C-----------------------------------------------
161 INTEGER IPARI(NPARI,*),NUM_IMP(*),NS_IMP(*),
162 . NE_IMP(*),NSREM ,NSL,NDDL,IRBE3(*),LRBE3(*)
163 INTEGER IDDL(*),IKC(*),NDOF(*),IBFV(*),IRBE2(*),LRBE2(*),
164 . NDDL0 ,W_DDL(*)
165C REAL
166 my_real
167 . D_IMP(3,*) ,DD(3,*),DR_IMP(3,*) ,DDR(3,*),LB(*),
168 . A(3,*) ,AR(3,*),MS(*) ,V(3,*),X(3,*),
169 . SKEW(*),XFRAME(*),DE
170 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
171C-----------------------------------------------
172C L o c a l V a r i a b l e s
173C-----------------------------------------------
174 INTEGER I,J,K,L
175 my_real
176 . lx(nddl)
177 my_real,
178 . DIMENSION(:),ALLOCATABLE :: dd_tmp,ddr_tmp
179C-----------------------------------------------
180 IF (iline>0) THEN
181 DO i =1,nddl
182 lx(i)=zero
183 ENDDO
184 CALL fr_matv( a ,v ,d_imp ,ms ,x ,
185 1 dr_imp,ar ,ipari ,intbuf_tab ,
186 2 ndof ,num_imp,ns_imp,ne_imp,lx ,
187 3 nsrem ,nsl ,ibfv ,skew ,xframe ,
188 4 lx ,irbe3 ,lrbe3,irbe2 ,lrbe2 )
189 CALL spmd_sumf_v(lx)
190 DO i =1,nddl
191 lb(i) = lb(i)-lx(i)
192 ENDDO
193 IF ((nsrem+nsl)>0)
194 . CALL ini_dd0(iddl ,ikc ,ndof ,ipari ,intbuf_tab,
195 . d_imp,dr_imp,nsl ,irbe3,lrbe3 ,
196 . irbe2,lrbe2 )
197 ELSE
198 l=3*numnod
199 ALLOCATE(dd_tmp(l))
200 dd_tmp=zero
201 IF (iroddl/=0) THEN
202 ALLOCATE(ddr_tmp(l))
203 ddr_tmp=zero
204 END IF
205 IF ((nsrem+nsl)>0)
206 . CALL ini_ddfv(iddl ,ikc ,ndof ,ipari ,intbuf_tab,
207 . d_imp,dr_imp,dd_tmp,ddr_tmp,nsl ,
208 . irbe3,lrbe3 ,irbe2 ,lrbe2 )
209 DO i =1,nddl
210 lx(i)=zero
211 ENDDO
212 CALL fr_matv( a ,v ,dd_tmp ,ms ,x ,
213 1 ddr_tmp ,ar ,ipari ,intbuf_tab ,
214 2 ndof ,num_imp,ns_imp,ne_imp,lx ,
215 3 nsrem ,nsl ,ibfv ,skew ,xframe ,
216 4 lx ,irbe3 ,lrbe3 ,irbe2 ,lrbe2 )
217 DEALLOCATE(dd_tmp)
218 IF (iroddl/=0) DEALLOCATE(ddr_tmp)
219 CALL spmd_sumf_v(lx)
220 DO i =1,nddl
221 lb(i) = lb(i)-lx(i)
222 ENDDO
223C------calculate DE for L_search as DD,DDR will be updated
224 CALL produt_vmhp(nddl0 ,nddl ,iddl ,ndof ,ikc ,
225 . dd ,ddr ,lb ,de ,w_ddl )
226 IF ((nsrem+nsl)>0)
227 . CALL ini_dd0(iddl ,ikc ,ndof ,ipari ,intbuf_tab ,
228 . dd ,ddr ,nsl ,irbe3,lrbe3 ,
229 . irbe2 ,lrbe2)
230 ENDIF !(ILINE>0) THEN
231C----6---------------------------------------------------------------7---------8
232 RETURN
233 END
234!||====================================================================
235!|| imp_frki ../engine/source/mpi/implicit/imp_fri.F
236!||--- called by ------------------------------------------------------
237!|| imp_fri ../engine/source/mpi/implicit/imp_fri.F
238!||--- calls -----------------------------------------------------
239!|| diag_int ../engine/source/mpi/implicit/imp_fri.F
240!|| dim_kinefr ../engine/source/mpi/implicit/imp_fri.F
241!|| iddl_int ../engine/source/mpi/implicit/imp_fri.F
242!|| imp_frsn ../engine/source/mpi/implicit/imp_fri.F
243!|| ind_kinefr ../engine/source/mpi/implicit/imp_fri.F
244!|| ini_intm ../engine/source/mpi/implicit/imp_fri.F
245!|| spmd_ifc1 ../engine/source/mpi/implicit/imp_spmd.F
246!|| tag_intm ../engine/source/mpi/implicit/imp_fri.F
247!|| tag_intm11 ../engine/source/mpi/implicit/imp_fri.F
248!|| tag_ints ../engine/source/mpi/implicit/imp_fri.F
249!||--- uses -----------------------------------------------------
250!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
251!||====================================================================
252 SUBROUTINE imp_frki(
253 1 IPARI ,INTBUF_TAB,NUM_IMP ,NS_IMP ,NE_IMP ,
254 2 NPBY ,LPBY ,ITAB ,NRBYAC ,IRBYAC ,
255 3 NINT2 ,IINT2 ,IDDL ,IKC ,NDOF ,
256 4 INLOC ,NSREM ,NSL ,NBINTC ,INTLIST ,
257 5 X ,IBFV ,LJ ,SKEW ,
258 6 XFRAME ,ISKEW ,ICODT ,IRBE3 ,LRBE3 ,
259 7 FRBE3 ,IRBE2 ,LRBE2 )
260C-----------------------------------------------
261C M o d u l e s
262C-----------------------------------------------
263 USE intbufdef_mod
264C----6---------------------------------------------------------------7---------8
265C I m p l i c i t T y p e s
266C-----------------------------------------------
267#include "implicit_f.inc"
268C-----------------------------------------------
269C C o m m o n B l o c k s
270C-----------------------------------------------
271#include "com04_c.inc"
272#include "param_c.inc"
273C-----------------------------------------------------------------
274C D u m m y A r g u m e n t s
275C-----------------------------------------------
276 INTEGER IPARI(NPARI,*),NUM_IMP(*),NS_IMP(*),
277 . NE_IMP(*),NSREM ,NSL,NBINTC,INTLIST(*)
278 INTEGER NPBY(NNPBY,*),LPBY(*),ITAB(*),NRBYAC,IRBYAC(*),
279 . NINT2,IINT2(*),IDDL(*),IKC(*),NDOF(*),INLOC(*),
280 . IBFV(*),LJ(*),ISKEW(*),ICODT(*),IRBE3(*),LRBE3(*),
281 . IRBE2(*),LRBE2(*)
282C REAL
283 my_real
284 . X(3,*),SKEW(*),XFRAME(*),FRBE3(*)
285 TYPE(intbuf_struct_) INTBUF_TAB(*)
286C-----------------------------------------------
287C L o c a l V a r i a b l e s
288C-----------------------------------------------
289 INTEGER NIN,NTY,ILOCP(NUMNOD),IDDLM(NUMNOD),LNS,LNS2,N_KINE
290 INTEGER I,J,K,L,NDOFI,N,IAD,NRTS,
291 . NSN,NKC,J1,ND,N_KINE_M,LNSS ,LNSS2,LNS3,LNSS3,
292 . LRS2,LRSS2
293 my_real
294 . KSS(6,NSL)
295C------comm. table of remote secondary nodes (to origin proc) and diag_ss
296 CALL SPMD_IFC1(NSREM ,NSL ,KSS )
297 IF (NSL>0) CALL IMP_FRSN(IPARI ,INTBUF_TAB ,NBINTC,INTLIST)
298C IF ((NSREM+NSL)==0) RETURN
299 DO n =1,numnod
300 ilocp(n)=0
301 ENDDO
302C--------tag additional nodes possibly dependent----
303 n_kine=0
304C
305 CALL tag_ints(nsl ,ilocp ,n_kine)
306 n_kine_m=n_kine
307 IF (nsrem>0) THEN
308 iad=1
309 DO nin=1,ninter
310 nty =ipari(7,nin)
311 IF(nty==5) iad=iad+num_imp(nin)
312 ENDDO
313 DO nin=1,ninter
314 nsn =ipari(5,nin)
315 nty =ipari(7,nin)
316 IF(nty==3)THEN
317 ELSEIF(nty==4)THEN
318 ELSEIF(nty==5)THEN
319 ELSEIF(nty==6)THEN
320 ELSEIF(nty==7.OR.nty==10.OR.nty==24)THEN
321C
322 CALL tag_intm(num_imp(nin),ns_imp(iad),ne_imp(iad),
323 . intbuf_tab(nin)%IRECTM,intbuf_tab(nin)%NSV , ilocp ,
324 . n_kine ,nsn )
325 iad=iad+num_imp(nin)
326C
327 ELSEIF(nty==11)THEN
328 nrts =ipari(3,nin)
329 CALL tag_intm11(num_imp(nin),ns_imp(iad),ne_imp(iad),
330 . intbuf_tab(nin)%IRECTS,intbuf_tab(nin)%IRECTM, ilocp ,
331 . n_kine ,nrts )
332 iad=iad+num_imp(nin)
333C
334 ENDIF
335 ENDDO
336 ENDIF
337C-------init iml--isl ----
338 CALL ini_intm(ilocp ,n_kine_m, n_kine )
339C-------iddlm-----------------
340 nkc=0
341 DO n =1,numnod
342 i=inloc(n)
343 iddlm(i)=iddl(i)-nkc
344 DO j=1,ndof(i)
345 nd = iddl(i)+j
346 IF (ikc(nd)/=0) nkc = nkc + 1
347 ENDDO
348 ENDDO
349C-----coupling with kinematic constraints ------
350 CALL dim_kinefr(
351 1 npby ,lpby ,itab ,nrbyac ,irbyac ,
352 2 nint2 ,iint2 ,ipari ,intbuf_tab,ilocp,
353 3 lns ,lns2 ,lnss ,lnss2 ,n_kine_m ,
354 4 irbe3 ,lns3 ,lnss3 ,irbe2 ,lrbe2 ,
355 5 lrs2 ,lrss2 )
356 CALL ind_kinefr(
357 1 npby ,lpby ,itab ,nrbyac ,irbyac ,
358 2 nint2 ,iint2 ,ipari ,intbuf_tab,ilocp,
359 3 lns ,lns2 ,lnss ,lnss2 ,n_kine_m ,
360 4 ibfv ,lj ,iskew ,icodt ,irbe3 ,
361 5 lns3 ,lnss3 ,irbe2 ,lrbe2 ,lrs2 ,
362 6 lrss2 )
363 CALL iddl_int(nsl ,iddl ,ikc ,ndof ,iddlm ,
364 . ipari ,intbuf_tab ,irbe3 ,lrbe3 ,frbe3 ,
365 . x ,skew ,irbe2 ,lrbe2 )
366 IF (nsl>0)
367 . CALL diag_int(nsl ,ndof ,ipari ,intbuf_tab,
368 . kss ,x ,ibfv ,skew ,xframe ,
369 . irbe3 ,lrbe3 ,irbe2 ,lrbe2 )
370C----6---------------------------------------------------------------7---------8
371 RETURN
372 END
373C ------retrieve ISL in global num (by each proc)---
374!||====================================================================
375!|| imp_frsn ../engine/source/mpi/implicit/imp_fri.F
376!||--- called by ------------------------------------------------------
377!|| imp_frkd ../engine/source/mpi/implicit/imp_fri.F
378!|| imp_frki ../engine/source/mpi/implicit/imp_fri.F
379!||--- uses -----------------------------------------------------
380!|| imp_intm ../engine/share/modules/imp_intm.F
381!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
382!||====================================================================
383 SUBROUTINE imp_frsn(IPARI ,INTBUF_TAB ,NBINTC,INTLIST)
384C-----------------------------------------------
385C M o d u l e s
386C-----------------------------------------------
387 USE imp_intm
388 USE intbufdef_mod
389C-----------------------------------------------
390C I m p l i c i t T y p e s
391C-----------------------------------------------
392#include "implicit_f.inc"
393C-----------------------------------------------
394C C o m m o n B l o c k s
395C-----------------------------------------------
396#include "param_c.inc"
397#include "com01_c.inc"
398C-----------------------------------------------
399C D u m m y A r g u m e n t s
400C-----------------------------------------------
401 INTEGER IPARI(NPARI,*), NBINTC,INTLIST(*)
402 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
403C-----------------------------------------------
404C L o c a l V a r i a b l e s
405C-----------------------------------------------
406 INTEGER I,J,K,L,N,NN,IAD,NSN,NIN,NUM,NTY,II,NB
407 INTEGER N0,N1,N2
408C-----------------------------------------------
409C S o u r c e L i n e s
410C-----------------------------------------------
411C
412 l = 0
413C -----sort by proc---independent interface structure------
414 DO i = 1, nspmd
415 IF(iad_sl(i+1)>iad_sl(i))THEN
416 DO ii = 1, nbintc
417 nin = intlist(ii)
418 nb = inbsl(ii,i)
419 IF(nb>0)THEN
420 nty = ipari(7,nin)
421 IF(nty==7.OR.nty==10.OR.nty==24) THEN
422 DO j = 1, nb
423 l = l + 1
424 n0 = isl(l)
425 n = intbuf_tab(nin)%NSV(n0)
426 isl(l) = n
427 ENDDO
428C
429 ELSEIF(nty==11) THEN
430 DO j = 1, nb/2
431 l = l + 1
432 n0 = isl(l)
433 n1 = intbuf_tab(nin)%IRECTS(2*(n0-1)+1)
434 n2 = intbuf_tab(nin)%IRECTS(2*(n0-1)+2)
435 isl(l) = n1
436 l = l + 1
437 isl(l) = n2
438 ENDDO
439C
440 END IF
441 END IF
442 ENDDO
443 ENDIF
444 ENDDO
445C
446 RETURN
447 END
448!||====================================================================
449!|| imp_frii ../engine/source/mpi/implicit/imp_fri.F
450!||--- called by ------------------------------------------------------
451!|| imp_sol_init ../engine/source/implicit/imp_sol_init.F
452!||--- uses -----------------------------------------------------
453!|| imp_intm ../engine/share/modules/imp_intm.F
454!||====================================================================
455 SUBROUTINE imp_frii(NINTER)
456C-----------------------------------------------
457C M o d u l e s
458C-----------------------------------------------
459 USE imp_intm
460C-----------------------------------------------
461C I m p l i c i t T y p e s
462C-----------------------------------------------
463#include "implicit_f.inc"
464C-----------------------------------------------
465C C o m m o n B l o c k s
466C-----------------------------------------------
467#include "impl1_c.inc"
468C-----------------------------------------------
469C D u m m y A r g u m e n t s
470C-----------------------------------------------
471 INTEGER NINTER
472C-----------------------------------------------
473C L o c a l V a r i a b l e s
474C-----------------------------------------------
475 INTEGER I
476C-----------------------------------------------
477C S o u r c e L i n e s
478C-----------------------------------------------
479C
480 ALLOCATE(ind_int(ninter))
481 DO i=1,ninter
482 NULLIFY(ind_int(i)%p)
483 ENDDO
484 ALLOCATE(shf_int(ninter))
485C
486 intp_d = max(0,intp_c)
487 nddl_si = 0
488 nddl_sl = 0
489 nz_si = 0
490 nz_sl = 0
491C
492 RETURN
493 END
494!||====================================================================
495!|| imp_fr7i ../engine/source/mpi/implicit/imp_fri.F
496!||--- called by ------------------------------------------------------
497!|| imp_chkm ../engine/source/implicit/imp_solv.F
498!|| imp_solv ../engine/source/implicit/imp_solv.F
499!||--- uses -----------------------------------------------------
500!|| imp_intm ../engine/share/modules/imp_intm.F
501!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
502!|| tri7box ../engine/share/modules/tri7box.F
503!||====================================================================
504 SUBROUTINE imp_fr7i(IPARI ,INTBUF_TAB,NUM_IMP ,NS_IMP ,NSREM ,
505 1 NBINTC,INTLIST)
506C-----------------------------------------------
507C M o d u l e s
508C-----------------------------------------------
509 USE tri7box
510 USE imp_intm
511 USE intbufdef_mod
512C-----------------------------------------------
513C I m p l i c i t T y p e s
514C-----------------------------------------------
515#include "implicit_f.inc"
516C-----------------------------------------------
517C C o m m o n B l o c k s
518C-----------------------------------------------
519#include "param_c.inc"
520#include "com01_c.inc"
521#include "com04_c.inc"
522#include "task_c.inc"
523C-----------------------------------------------
524C D u m m y A r g u m e n t s
525C-----------------------------------------------
526 INTEGER NUM_IMP(*),NS_IMP(*),IPARI(NPARI,*),
527 . nsrem,nbintc,intlist(*)
528 TYPE(intbuf_struct_) INTBUF_TAB(*)
529C-----------------------------------------------
530C L o c a l V a r i a b l e s
531C-----------------------------------------------
532 INTEGER I,J,K,L,N,NN,IAD,NSN,NIN,NUM,NTY,II,NB
533 INTEGER IERROR1,IERROR2,NRTS,NSREM11,NCONT,
534 . ierror3,ierror4,ierror5,ierror6,ierror7
535 INTEGER DEBUT(NINTER),DEBUTI(NINTER),L1,
536 . IERROR8,IERROR9,IDEB,IDEBI,LOC_PROC
537C-----------------------------------------------
538C S o u r c e L i n e s
539C-----------------------------------------------
540 LOC_PROC = ispmd + 1
541C----init
542 DO ii = 1, nbintc
543 nin = intlist(ii)
544 debuti(nin) = 0
545 ENDDO
546 DO i = 1, nspmd
547 IF(i/=loc_proc)THEN
548 DO ii = 1, nbintc
549 nin = intlist(ii)
550 nb = nsnfi(nin)%P(i)
551 nty = ipari(7,nin)
552 IF(nty==7.OR.nty==10.OR.nty==11.OR.nty==24) THEN
553 IF(nb>0) THEN
554 debuti(nin) = debuti(nin) + nb
555 END IF
556 END IF
557 ENDDO
558 ENDIF
559 ENDDO
560C
561C
562 nsrem11 = 0
563 iad=0
564 l = 0
565 DO nin=1,ninter
566 nty =ipari(7,nin)
567 IF(nty==5) iad=iad+num_imp(nin)
568 ENDDO
569 DO nin=1,ninter
570 num=0
571 nty =ipari(7,nin)
572 nsn =ipari(5,nin)
573 shf_int(nin) = l
574 IF(nty==7.OR.nty==10.OR.nty==24) THEN
575 DO i=1,num_imp(nin)
576 IF (ns_imp(i+iad)>nsn) THEN
577 nn=ns_imp(i+iad)-nsn
578C -------tag impact nodes-------
579 nsvfi(nin)%P(nn)=-abs(nsvfi(nin)%P(nn))
580 num=num+1
581 ENDIF
582 ENDDO
583 iad=iad+num_imp(nin)
584 ELSEIF(nty==11)THEN
585C
586 nrts =ipari(3,nin)
587 DO i=1,num_imp(nin)
588 IF (ns_imp(i+iad)>nrts) THEN
589 nn=ns_imp(i+iad)-nrts
590C -------tag impact nodes-------
591 nsvfi(nin)%P(nn)=-abs(nsvfi(nin)%P(nn))
592 num=num+1
593 nsrem11 = nsrem11 + 1
594 ENDIF
595 ENDDO
596 iad=iad+num_imp(nin)
597C
598 ELSE
599 ENDIF
600 l = l + num
601 IF(ASSOCIATED(ind_int(nin)%P)) DEALLOCATE(ind_int(nin)%P)
602 l1=debuti(nin)
603 IF (l1>0) ALLOCATE(ind_int(nin)%P(l1),stat=ierror1)
604 ENDDO
605C---------
606C
607C Allocation of boundary interface arrays for implicit
608C
609C
610 ncont = nsrem-nsrem11
611 IF (intp_d==0) THEN
612 IF(ALLOCATED(stifs)) DEALLOCATE(stifs)
613 ALLOCATE(stifs(ncont),stat=ierror3)
614 IF(ALLOCATED(h_e)) DEALLOCATE(h_e)
615 ALLOCATE(h_e(4,ncont),stat=ierror4)
616 IF(ALLOCATED(n_e)) DEALLOCATE(n_e)
617 ALLOCATE(n_e(3,ncont),stat=ierror5)
618C
619 ENDIF
620C
621 IF(ALLOCATED(fr_srem)) DEALLOCATE(fr_srem)
622 ALLOCATE(fr_srem(nsrem),stat=ierror2)
623 IF(ALLOCATED(dfi)) DEALLOCATE(dfi)
624 ALLOCATE(dfi(3,nsrem),stat=ierror6)
625 IF(ALLOCATED(ffi)) DEALLOCATE(ffi)
626 ALLOCATE(ffi(3,nsrem),stat=ierror7)
627C
628 IF(ALLOCATED(iad_srem)) DEALLOCATE(iad_srem)
629 ALLOCATE(iad_srem(nspmd+1),stat=ierror8)
630 IF(ALLOCATED(inbsl)) DEALLOCATE(inbsl)
631 ALLOCATE(inbsl(nbintc,nspmd),stat=ierror9)
632C -----sort by proc---independent interface structure------
633 DO ii = 1, nbintc
634 nin = intlist(ii)
635 debut(nin) = 0
636 debuti(nin) = 0
637 ENDDO
638 l = 1
639C
640 iad_srem(1) = l
641 DO i = 1, nspmd
642 IF(i/=loc_proc)THEN
643 DO ii = 1, nbintc
644 nin = intlist(ii)
645 ideb = debut(nin)
646 idebi = debuti(nin)
647 nb = nsnfi(nin)%P(i)
648 nty = ipari(7,nin)
649 nsn = ipari(5,nin)
650 l1 = l
651 IF(nty==7.OR.nty==10.OR.nty==11.OR.nty==24) THEN
652 IF(nb>0) THEN
653 IF(nty==7.OR.nty==10.OR.nty==24) THEN
654 DO n = 1, nb
655 IF(nsvfi(nin)%P(ideb+n)<0)THEN
656 nsvfi(nin)%P(ideb+n)=-nsvfi(nin)%P(ideb+n)
657 fr_srem(l) = nsvfi(nin)%P(ideb+n)
658 ind_int(nin)%P(idebi+n)=l
659 l = l + 1
660 ENDIF
661 ENDDO
662 debuti(nin) = debuti(nin) + nb
663C
664 ELSEIF(nty==11) THEN
665 DO n = 1, nb
666 IF(nsvfi(nin)%P(ideb+n)<0)THEN
667 nsvfi(nin)%P(ideb+n)=-nsvfi(nin)%P(ideb+n)
668 fr_srem(l) = nsvfi(nin)%P(ideb+n)
669 ind_int(nin)%P(idebi+n)=l
670 l = l + 1
671 fr_srem(l) = 0
672 l = l + 1
673 ENDIF
674 ENDDO
675 debuti(nin) = debuti(nin) + nb
676C
677 ENDIF
678 debut(nin) = debut(nin) + nb
679 END IF
680 END IF
681 inbsl(ii,i)= l - l1
682 ENDDO
683 ENDIF
684 iad_srem(i+1)=l
685 ENDDO
686 IF(iad_srem(nspmd+1)>1)nsrem=iad_srem(nspmd+1)-1
687C
688 RETURN
689 END
690!||====================================================================
691!|| imp_frsl ../engine/source/mpi/implicit/imp_fri.F
692!||--- called by ------------------------------------------------------
693!|| imp_fri ../engine/source/mpi/implicit/imp_fri.F
694!||--- calls -----------------------------------------------------
695!|| spmd_inis ../engine/source/mpi/implicit/imp_spmd.F
696!|| spmd_inisl ../engine/source/mpi/implicit/imp_spmd.F
697!||--- uses -----------------------------------------------------
698!|| imp_intm ../engine/share/modules/imp_intm.F
699!||====================================================================
700 SUBROUTINE imp_frsl(NBINTC,NSREM ,NSL )
701C-----------------------------------------------
702C M o d u l e s
703C-----------------------------------------------
704 USE imp_intm
705C-----------------------------------------------
706C I m p l i c i t T y p e s
707C-----------------------------------------------
708#include "implicit_f.inc"
709C-----------------------------------------------
710C C o m m o n B l o c k s
711C-----------------------------------------------
712#include "com01_c.inc"
713C-----------------------------------------------
714C D u m m y A r g u m e n t s
715C-----------------------------------------------
716 INTEGER NBINTC,NSL,NSREM
717C-----------------------------------------------
718C L o c a l V a r i a b l e s
719C-----------------------------------------------
720 INTEGER I,IERROR1,IERROR2,IERROR3,IERROR4,IERROR5,
721 . II,IAD
722C-----------------------------------------------
723C S o u r c e L i n e s
724C-----------------------------------------------
725C
726 IF(ALLOCATED(iad_sl)) DEALLOCATE(iad_sl)
727 ALLOCATE(iad_sl(nspmd+1),stat=ierror1)
728 IF (nsrem==0) THEN
729 IF(ALLOCATED(iad_srem)) DEALLOCATE(iad_srem)
730 ALLOCATE(iad_srem(nspmd+1),stat=ierror2)
731 DO i = 1, nspmd+1
732 iad_srem(i)=1
733 ENDDO
734 ENDIF
735C
736 CALL spmd_inis(iad_srem,iad_sl)
737 nsl=iad_sl(nspmd+1)-1
738 IF (nsrem==0) THEN
739 IF(ALLOCATED(inbsl)) DEALLOCATE(inbsl)
740 ALLOCATE(inbsl(nbintc,nspmd),stat=ierror5)
741 DO i = 1, nspmd
742 DO ii = 1, nbintc
743 inbsl(ii,i)=0
744 ENDDO
745 ENDDO
746 ENDIF
747 CALL spmd_inisl(nbintc,inbsl)
748 IF (nsl>0) THEN
749 IF(ALLOCATED(isl)) DEALLOCATE(isl)
750 ALLOCATE(isl(nsl),stat=ierror3)
751C
752 IF (intp_d==0) THEN
753 IF(ALLOCATED(diag_s)) DEALLOCATE(diag_s)
754 ALLOCATE(diag_s(3,nsl),stat=ierror4)
755 IF(ALLOCATED(islm)) DEALLOCATE(islm)
756 ALLOCATE(islm(nsl),stat=ierror5)
757C
758 ENDIF
759 ENDIF
760
761C
762 RETURN
763 END
764C --------- ----
765!||====================================================================
766!|| tag_intm ../engine/source/mpi/implicit/imp_fri.F
767!||--- called by ------------------------------------------------------
768!|| imp_frki ../engine/source/mpi/implicit/imp_fri.F
769!||====================================================================
770 SUBROUTINE tag_intm(
771 1 JLT ,NS_IMP ,NE_IMP ,IRECT ,NSV ,
772 2 ILOC ,N_IMPN ,NSN )
773C----6---------------------------------------------------------------7---------8
774C I m p l i c i t T y p e s
775C-----------------------------------------------
776#include "implicit_f.inc"
777C-----------------------------------------------
778C C o m m o n B l o c k s
779C-----------------------------------------------
780C-----------------------------------------------------------------
781C D u m m y A r g u m e n t s
782C-----------------------------------------------
783 INTEGER JLT,NS_IMP(*),NE_IMP(*),IRECT(4,*),NSV(*),
784 . iloc(*),n_impn,nsn
785C REAL
786C-----------------------------------------------
787C L o c a l V a r i a b l e s
788C-----------------------------------------------
789 INTEGER I,J,N,N1,N2,NE,IG
790C-----------------------------------------------
791 DO I = 1, jlt
792C--------second node-----
793 ig = ns_imp(i)
794 IF (ig>nsn) THEN
795 ne=ne_imp(i)
796 DO j=1,3
797 n=irect(j,ne)
798 IF (iloc(n)==0) THEN
799 n_impn=n_impn+1
800 iloc(n)=n_impn
801 ENDIF
802 ENDDO
803 IF (irect(3,ne)/=irect(4,ne)) THEN
804 n=irect(4,ne)
805 IF (iloc(n)==0) THEN
806 n_impn=n_impn+1
807 iloc(n)=n_impn
808 ENDIF
809 ENDIF
810 ENDIF
811 ENDDO
812C----6---------------------------------------------------------------7---------8
813 RETURN
814 END
815C --------- ----
816!||====================================================================
817!|| tag_ints ../engine/source/mpi/implicit/imp_fri.F
818!||--- called by ------------------------------------------------------
819!|| imp_frki ../engine/source/mpi/implicit/imp_fri.F
820!|| kin_ksl ../engine/source/mpi/implicit/imp_fri.F
821!||--- uses -----------------------------------------------------
822!|| imp_intm ../engine/share/modules/imp_intm.F
823!||====================================================================
824 SUBROUTINE tag_ints(NSL ,ILOC ,N_IMPN )
825C-----------------------------------------------
826C M o d u l e s
827C-----------------------------------------------
828 USE imp_intm
829C----6---------------------------------------------------------------7---------8
830C I m p l i c i t T y p e s
831C-----------------------------------------------
832#include "implicit_f.inc"
833C-----------------------------------------------------------------
834C D u m m y A r g u m e n t s
835C-----------------------------------------------
836 INTEGER NSL,ILOC(*),N_IMPN
837C REAL
838C-----------------------------------------------
839C L o c a l V a r i a b l e s
840C-----------------------------------------------
841 INTEGER I,J,N,N1,N2,NE,IG
842C-----------------------------------------------
843 IF (INTP_D>0) THEN
844 DO I = 1, nsl
845C--------second node--------------
846 n = isl(i)
847 IF (iloc(n)==0) iloc(n)=i
848 ENDDO
849 ELSE
850
851 DO i = 1, nsl
852C--------second node-----
853 n = isl(i)
854 IF (iloc(n)==0) THEN
855 n_impn=n_impn+1
856 iloc(n)=n_impn
857C
858 islm(i) = n
859 ELSE
860 islm(i) = 0
861C
862 ENDIF
863 ENDDO
864C
865 ENDIF
866C----6---------------------------------------------------------------7---------8
867 RETURN
868 END
869!||====================================================================
870!|| ini_ddfv ../engine/source/mpi/implicit/imp_fri.F
871!||--- called by ------------------------------------------------------
872!|| imp_frfv ../engine/source/mpi/implicit/imp_fri.F
873!||--- uses -----------------------------------------------------
874!|| imp_intm ../engine/share/modules/imp_intm.F
875!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
876!||====================================================================
877 SUBROUTINE ini_ddfv(IDDL ,IKC ,NDOF ,IPARI ,INTBUF_TAB ,
878 . D ,DR ,DD ,DDR ,NSL ,
879 . IRBE3,LRBE3,IRBE2 ,LRBE2 )
880C-----------------------------------------------
881C M o d u l e s
882C-----------------------------------------------
883 USE intbufdef_mod
884C-----------------------------------------------
885C M o d u l e s
886C-----------------------------------------------
887 USE imp_intm
888C----6---------------------------------------------------------------7---------8
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 "param_c.inc"
896C-----------------------------------------------------------------
897C D u m m y A r g u m e n t s
898C-----------------------------------------------
899 INTEGER IDDL(*),IKC(*),NDOF(*),NSL
900 INTEGER IPARI(NPARI,*),IRBE3(NRBE3L,*),LRBE3(*) ,
901 . IRBE2(NRBE2L,*),LRBE2(*)
902C REAL
903 my_real
904 . d(3,*),dr(3,*),dd(3,*),ddr(3,*)
905 TYPE(intbuf_struct_) INTBUF_TAB(*)
906C-----------------------------------------------
907C L o c a l V a r i a b l e s
908C-----------------------------------------------
909 INTEGER I,ND,N,J,IAD
910 INTEGER M,NSN,JI,L,NNOD,NJ,NL,NI
911C-----------------------------------------------
912 DO I = 1, nsl
913C--------local second node-----
914 n = isl(i)
915 DO j = 1, min(3,ndof(n))
916 nd = iddl(n)+j
917 IF ((ikc(nd)>=2.AND.ikc(nd)<=4).OR.ikc(nd)==9) THEN
918 dd(j,n)=d(j,n)
919 ENDIF
920 ENDDO
921 DO j = 3, ndof(n)
922 nd = iddl(n)+j
923 IF ((ikc(nd)>=2.AND.ikc(nd)<=4).OR.ikc(nd)==9) THEN
924 ddr(j-3,n)=dr(j-3,n)
925 ENDIF
926 ENDDO
927 ENDDO
928C
929 DO i = 1, nml
930C--------local main node-----
931 n = iml(i)
932 DO j = 1, min(3,ndof(n))
933 nd = iddl(n)+j
934 IF ((ikc(nd)>=2.AND.ikc(nd)<=4).OR.ikc(nd)==9) THEN
935 dd(j,n)=d(j,n)
936 ENDIF
937 ENDDO
938 DO j = 3, ndof(n)
939 nd = iddl(n)+j
940 IF ((ikc(nd)>=2.AND.ikc(nd)<=4).OR.ikc(nd)==9) THEN
941 ddr(j-3,n)=dr(j-3,n)
942 ENDIF
943 ENDDO
944 ENDDO
945C------Rigid bodies-----
946 DO i=1,nrb_fr
947 m=ifrsr(1,i)
948 DO j=1,min(3,ndof(m))
949 nd = iddl(m)+j
950 IF ((ikc(nd)>=2.AND.ikc(nd)<=4).OR.ikc(nd)==9) THEN
951 dd(j,m)=d(j,m)
952 ENDIF
953 ENDDO
954 DO j=3,ndof(m)
955 nd = iddl(m)+j
956 IF ((ikc(nd)>=2.AND.ikc(nd)<=4).OR.ikc(nd)==9) THEN
957 ddr(j-3,m)=dr(j-3,m)
958 ENDIF
959 ENDDO
960 ENDDO
961C------int2-------
962 DO i=1,ni2_fr
963 n=ifrs2(1,i)
964 ni=ifrs2(2,i)
965 ji=ipari(1,n)
966 nsn=ipari(5,n)
967 l=intbuf_tab(n)%IRTLM(ni)
968 nl=4*(l-1)
969 IF ((ikc(nd)>=2.AND.ikc(nd)<=4).OR.ikc(nd)==9) THEN
970 nnod=3
971 ELSE
972 nnod=4
973 ENDIF
974C-------if main node is also dependent-----
975 DO m=1,nnod
976 nj=intbuf_tab(n)%IRECTM(nl+m)
977 DO j = 1 , min(3,ndof(nj))
978 nd = iddl(nj) + j
979 IF ((ikc(nd)>=2.AND.ikc(nd)<=4).OR.ikc(nd)==9) THEN
980 dd(j,nj)=d(j,nj)
981 ENDIF
982 ENDDO
983 DO j = 3 , ndof(nj)
984 nd = iddl(nj) + j
985 IF ((ikc(nd)>=2.AND.ikc(nd)<=4).OR.ikc(nd)==9) THEN
986 ddr(j-3,nj)=dr(j-3,nj)
987 ENDIF
988 ENDDO
989 ENDDO
990 ENDDO
991C------RBE3-------
992 DO i=1,nrbe3_fr
993 n=ifrs3(i)
994 nnod=irbe3(5,n)
995 iad=irbe3(1,n)
996C-------if main node is also dependent-----
997 DO m=1,nnod
998 nj=lrbe3(iad+m)
999 DO j = 1 , min(3,ndof(nj))
1000 nd = iddl(nj) + j
1001 IF ((ikc(nd)>=2.AND.ikc(nd)<=4).OR.ikc(nd)==9) THEN
1002 dd(j,nj)=d(j,nj)
1003 ENDIF
1004 ENDDO
1005 DO j = 3 , ndof(nj)
1006 nd = iddl(nj) + j
1007 IF ((ikc(nd)>=2.AND.ikc(nd)<=4).OR.ikc(nd)==9) THEN
1008 ddr(j-3,nj)=dr(j-3,nj)
1009 ENDIF
1010 ENDDO
1011 ENDDO
1012 ENDDO
1013C------RBE2-------
1014 DO i=1,nrbe2_fr
1015 n=ifrs4(1,i)
1016 m=irbe2(3,n)
1017 DO j=1,min(3,ndof(m))
1018 nd = iddl(m)+j
1019 IF ((ikc(nd)>=2.AND.ikc(nd)<=4).OR.ikc(nd)==9) THEN
1020 dd(j,m)=d(j,m)
1021 ENDIF
1022 ENDDO
1023 DO j=3,ndof(m)
1024 nd = iddl(m)+j
1025 IF ((ikc(nd)>=2.AND.ikc(nd)<=4).OR.ikc(nd)==9) THEN
1026 ddr(j-3,m)=dr(j-3,m)
1027 ENDIF
1028 ENDDO
1029 ENDDO
1030C----6---------------------------------------------------------------7---------8
1031 RETURN
1032 END
1033!||====================================================================
1034!|| ini_dd0 ../engine/source/mpi/implicit/imp_fri.F
1035!||--- called by ------------------------------------------------------
1036!|| imp_frfv ../engine/source/mpi/implicit/imp_fri.F
1037!||--- uses -----------------------------------------------------
1038!|| imp_intm ../engine/share/modules/imp_intm.f
1039!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
1040!||====================================================================
1041 SUBROUTINE ini_dd0(IDDL ,IKC ,NDOF ,IPARI ,INTBUF_TAB ,
1042 . DD ,DDR ,NSL ,IRBE3 ,LRBE3 ,
1043 . IRBE2,LRBE2 )
1044C-----------------------------------------------
1045C M o d u l e s
1046C-----------------------------------------------
1047 USE imp_intm
1048 USE intbufdef_mod
1049C----6---------------------------------------------------------------7---------8
1050C I m p l i c i t T y p e s
1051C-----------------------------------------------
1052#include "implicit_f.inc"
1053C-----------------------------------------------
1054C C o m m o n B l o c k s
1055C-----------------------------------------------
1056#include "param_c.inc"
1057C-----------------------------------------------------------------
1058C D u m m y A r g u m e n t s
1059C-----------------------------------------------
1060 INTEGER IDDL(*),IKC(*),NDOF(*),NSL
1061 INTEGER IPARI(NPARI,*),IRBE3(NRBE3L,*),LRBE3(*),
1062 . IRBE2(NRBE2L,*),LRBE2(*)
1063C REAL
1064 my_real
1065 . DD(3,*),DDR(3,*)
1066 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
1067C-----------------------------------------------
1068C L o c a l V a r i a b l e s
1069C-----------------------------------------------
1070 INTEGER I,ND,N,J,IAD,JI
1071 INTEGER M,NSN,L,NNOD,NJ,NL,NI
1072C-----------------------------------------------
1073 DO I = 1, nsl
1074C--------local second node-----
1075 n = isl(i)
1076 DO j = 1, min(3,ndof(n))
1077 nd = iddl(n)+j
1078 IF ((ikc(nd)>=2.AND.ikc(nd)<=4).OR.ikc(nd)==9) THEN
1079 dd(j,n)=zero
1080 ENDIF
1081 ENDDO
1082 DO j = 3, ndof(n)
1083 nd = iddl(n)+j
1084 IF ((ikc(nd)>=2.AND.ikc(nd)<=4).OR.ikc(nd)==9) THEN
1085 ddr(j-3,n)=zero
1086 ENDIF
1087 ENDDO
1088 ENDDO
1089C
1090 DO i = 1, nml
1091C--------local main node-----
1092 n = iml(i)
1093 DO j = 1, min(3,ndof(n))
1094 nd = iddl(n)+j
1095 IF ((ikc(nd)>=2.AND.ikc(nd)<=4).OR.ikc(nd)==9) THEN
1096 dd(j,n)=zero
1097 ENDIF
1098 ENDDO
1099 DO j = 3, ndof(n)
1100 nd = iddl(n)+j
1101 IF ((ikc(nd)>=2.AND.ikc(nd)<=4).OR.ikc(nd)==9) THEN
1102 ddr(j-3,n)=zero
1103 ENDIF
1104 ENDDO
1105 ENDDO
1106C------Rigid bodies-------
1107 DO i=1,nrb_fr
1108 m=ifrsr(1,i)
1109 DO j=1,min(3,ndof(m))
1110 nd = iddl(m)+j
1111 IF ((ikc(nd)>=2.AND.ikc(nd)<=4).OR.ikc(nd)==9) THEN
1112 dd(j,m)=zero
1113 ENDIF
1114 ENDDO
1115 DO j = 3, ndof(m)
1116 nd = iddl(m)+j
1117 IF ((ikc(nd)>=2.AND.ikc(nd)<=4).OR.ikc(nd)==9) THEN
1118 ddr(j-3,m)=zero
1119 ENDIF
1120 ENDDO
1121 ENDDO
1122C------int2-------
1123 DO i=1,ni2_fr
1124 n=ifrs2(1,i)
1125 ni=ifrs2(2,i)
1126 ji=ipari(1,n)
1127 nsn=ipari(5,n)
1128 l=intbuf_tab(n)%IRTLM(ni)
1129 nl=4*(l-1)
1130 IF (intbuf_tab(n)%IRECTM(nl+3)==intbuf_tab(n)%IRECTM(nl+4)) THEN
1131 nnod=3
1132 ELSE
1133 nnod=4
1134 ENDIF
1135C-------if main node is also dependent-----
1136 DO m=1,nnod
1137 nj=intbuf_tab(n)%IRECTM(nl+m)
1138 DO j = 1 , min(3,ndof(nj))
1139 nd = iddl(nj) + j
1140 IF ((ikc(nd)>=2.AND.ikc(nd)<=4).OR.ikc(nd)==9) THEN
1141 dd(j,nj)=zero
1142 ENDIF
1143 ENDDO
1144 DO j = 3 , ndof(nj)
1145 nd = iddl(nj) + j
1146 IF ((ikc(nd)>=2.AND.ikc(nd)<=4).OR.ikc(nd)==9) THEN
1147 ddr(j-3,nj)=zero
1148 ENDIF
1149 ENDDO
1150 ENDDO
1151 ENDDO
1152C------RBE3-------
1153 DO i=1,nrbe3_fr
1154 n=ifrs3(i)
1155 nnod=irbe3(5,n)
1156 iad=irbe3(1,n)
1157C-------if main node is also dependent-----
1158 DO m=1,nnod
1159 nj=lrbe3(iad+m)
1160 DO j = 1 , min(3,ndof(nj))
1161 nd = iddl(nj) + j
1162 IF ((ikc(nd)>=2.AND.ikc(nd)<=4).OR.ikc(nd)==9) THEN
1163 dd(j,nj)=zero
1164 ENDIF
1165 ENDDO
1166 DO j = 3 , ndof(nj)
1167 nd = iddl(nj) + j
1168 IF ((ikc(nd)>=2.AND.ikc(nd)<=4).OR.ikc(nd)==9) THEN
1169 ddr(j-3,nj)=zero
1170 ENDIF
1171 ENDDO
1172 ENDDO
1173 ENDDO
1174C------RBE2-------
1175 DO i=1,nrbe2_fr
1176 n=ifrs4(1,i)
1177 m=irbe2(3,n)
1178 DO j=1,min(3,ndof(m))
1179 nd = iddl(m)+j
1180 IF ((ikc(nd)>=2.AND.ikc(nd)<=4).OR.ikc(nd)==9) THEN
1181 dd(j,m)=zero
1182 ENDIF
1183 ENDDO
1184 DO j = 3, ndof(m)
1185 nd = iddl(m)+j
1186 IF ((ikc(nd)>=2.AND.ikc(nd)<=4).OR.ikc(nd)==9) THEN
1187 ddr(j-3,m)=zero
1188 ENDIF
1189 ENDDO
1190 ENDDO
1191C----6---------------------------------------------------------------7---------8
1192 RETURN
1193 END
1194C --------- ----
1195!||====================================================================
1196!|| ini_intm ../engine/source/mpi/implicit/imp_fri.F
1197!||--- called by ------------------------------------------------------
1198!|| imp_frki ../engine/source/mpi/implicit/imp_fri.F
1199!||--- uses -----------------------------------------------------
1200!|| imp_intm ../engine/share/modules/imp_intm.F
1201!||====================================================================
1202 SUBROUTINE ini_intm(ILOC ,N_IMPS,N_IMPN )
1203C-----------------------------------------------
1204C M o d u l e s
1205C-----------------------------------------------
1206 USE imp_intm
1207C----6---------------------------------------------------------------7---------8
1208C I m p l i c i t T y p e s
1209C-----------------------------------------------
1210#include "implicit_f.inc"
1211C-----------------------------------------------
1212C C o m m o n B l o c k s
1213C-----------------------------------------------
1214#include "com04_c.inc"
1215C-----------------------------------------------------------------
1216C D u m m y A r g u m e n t s
1217C-----------------------------------------------
1218 INTEGER ILOC(*),N_IMPN,N_IMPS
1219C REAL
1220C-----------------------------------------------
1221C L o c a l V a r i a b l e s
1222C-----------------------------------------------
1223 INTEGER I,J,N,IERROR1
1224C-----------------------------------------------
1225C
1226 NML=n_impn-n_imps
1227 IF (nml>0) THEN
1228 IF(ALLOCATED(iml)) DEALLOCATE(iml)
1229 ALLOCATE(iml(nml),stat=ierror1)
1230 DO n = 1, numnod
1231 IF (iloc(n)>n_imps) THEN
1232 i=iloc(n)-n_imps
1233 iml(i)=n
1234 ENDIF
1235 ENDDO
1236 ENDIF
1237C----6---------------------------------------------------------------7---------8
1238 RETURN
1239 END
1240!||====================================================================
1241!|| dim_kinefr ../engine/source/mpi/implicit/imp_fri.F
1242!||--- called by ------------------------------------------------------
1243!|| imp_frki ../engine/source/mpi/implicit/imp_fri.F
1244!||--- uses -----------------------------------------------------
1245!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
1246!||====================================================================
1247 SUBROUTINE dim_kinefr(
1248 1 NPBY ,LPBY ,ITAB ,NRBYAC ,IRBYAC ,
1249 2 NINT2 ,IINT2 ,IPARI ,INTBUF_TAB,INLOC ,
1250 3 LNS ,LNS2 ,LNSS ,LNSS2 ,NK_M ,
1251 4 IRBE3 ,LNS3 ,LNSS3 ,IRBE2 ,LRBE2 ,
1252 5 LNR2 ,LNRS2 )
1253C-----------------------------------------------
1254C M o d u l e s
1255C-----------------------------------------------
1256 USE intbufdef_mod
1257C----6---------------------------------------------------------------7---------8
1258C I m p l i c i t T y p e s
1259C-----------------------------------------------
1260#include "implicit_f.inc"
1261C-----------------------------------------------
1262C C o m m o n B l o c k s
1263C-----------------------------------------------
1264#include "com04_c.inc"
1265#include "param_c.inc"
1266C-----------------------------------------------------------------
1267C D u m m y A r g u m e n t s
1268C-----------------------------------------------
1269C INTEGER NNMAX,NKMAX
1270 INTEGER NPBY(NNPBY,*),LPBY(*),ITAB(*),NRBYAC,IRBYAC(*),
1271 . NINT2,IINT2(*),IPARI(NPARI,*)
1272 integer
1273 . inloc(*),lns ,lns2,lnss ,lnss2,nk_m,
1274 . irbe3(nrbe3l,*),lns3 ,lnss3 ,irbe2(nrbe2l,*),lrbe2(*),
1275 . lnr2 ,lnrs2
1276C REAL
1277 TYPE(intbuf_struct_) INTBUF_TAB(*)
1278C-----------------------------------------------
1279C L o c a l V a r i a b l e s
1280C-----------------------------------------------
1281 integer
1282 . i,j,k,n,l,nl,nj,ni,j1,m,nsn,n1,n2,nk,id,
1283 . ji,kfi,ns,iad
1284C----------------------------
1285 lns2=0
1286 lnss2=0
1287 DO j=1,nint2
1288 n=iint2(j)
1289 nsn = ipari(5,n)
1290 ji=ipari(1,n)
1291 DO i=1,nsn
1292 ni=intbuf_tab(n)%NSV(i)
1293 IF (inloc(ni)>0) THEN
1294 lns2=lns2+1
1295 IF (inloc(ni)<=nk_m) lnss2=lnss2+1
1296 ENDIF
1297 ENDDO
1298 ENDDO
1299C--------RBE3--------------------
1300 lns3=0
1301 lnss3=0
1302 DO n=1,nrbe3
1303 ni = irbe3(3,n)
1304 IF (ni==0) cycle
1305 IF (inloc(ni)>0) THEN
1306 lns3=lns3+1
1307 IF (inloc(ni)<=nk_m) lnss3=lnss3+1
1308 ENDIF
1309 ENDDO
1310CC-----active rigid body main nodes------
1311 lns=0
1312 lnss=0
1313 DO j=1,nrbyac
1314 n=irbyac(j)
1315 k=irbyac(j+nrbykin)
1316 m =npby(1,n)
1317 nsn =npby(2,n)
1318 DO i=1,nsn
1319 id = i+k
1320 ni=lpby(id)
1321 IF (inloc(ni)>0) THEN
1322 lns=lns+1
1323 IF (inloc(ni)<=nk_m) lnss=lnss+1
1324 IF (inloc(m)==0) inloc(m) = 1
1325 ENDIF
1326 ENDDO
1327 ENDDO
1328C--------RBE2--------------------
1329 lnr2=0
1330 lnrs2=0
1331 DO n=1,nrbe2
1332 iad = irbe2(1,n)
1333 m = irbe2(3,n)
1334 nsn =irbe2(5,n)
1335 DO i=1,nsn
1336 id = iad+i
1337 ni=lrbe2(id)
1338 IF (inloc(ni)>0) THEN
1339 lnr2=lnr2+1
1340 IF (inloc(ni)<=nk_m) lnrs2=lnrs2+1
1341 IF (inloc(m)==0) inloc(m) = 2
1342 ENDIF
1343 ENDDO
1344 ENDDO
1345C----6---------------------------------------------------------------7---------8
1346 RETURN
1347 END
1348!||====================================================================
1349!|| ind_kinefr ../engine/source/mpi/implicit/imp_fri.F
1350!||--- called by ------------------------------------------------------
1351!|| imp_frki ../engine/source/mpi/implicit/imp_fri.F
1352!||--- uses -----------------------------------------------------
1353!|| imp_aspc ../engine/share/modules/impbufdef_mod.F
1354!|| imp_intm ../engine/share/modules/imp_intm.F
1355!|| imp_rwl ../engine/share/modules/impbufdef_mod.F
1356!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
1357!||====================================================================
1358 SUBROUTINE ind_kinefr(
1359 1 NPBY ,LPBY ,ITAB ,NRBYAC ,IRBYAC ,
1360 2 NINT2 ,IINT2 ,IPARI ,INTBUF_TAB,INLOC ,
1361 3 NSS ,NSS2 ,NSS_S ,NSS2_S ,KN_M ,
1362 4 IBFV ,LJ ,ISKEW ,ICODT ,IRBE3 ,
1363 5 NSS3 ,NSS3_S ,IRBE2 ,LRBE2 ,NSR2 ,
1364 6 NRS2_S )
1365C-----------------------------------------------
1366C M o d u l e s
1367C-----------------------------------------------
1368 USE imp_intm
1369 USE imp_rwl
1370 USE imp_aspc
1371 USE intbufdef_mod
1372C----6---------------------------------------------------------------7---------8
1373C I m p l i c i t T y p e s
1374C-----------------------------------------------
1375#include "implicit_f.inc"
1376C-----------------------------------------------
1377C C o m m o n B l o c k s
1378C-----------------------------------------------
1379#include "com04_c.inc"
1380#include "param_c.inc"
1381C-----------------------------------------------------------------
1382C D u m m y A r g u m e n t s
1383C-----------------------------------------------
1384C INTEGER NNMAX,NKMAX
1385 INTEGER NPBY(NNPBY,*),LPBY(*),ITAB(*),NRBYAC,IRBYAC(*),
1386 . nint2,iint2(*),ipari(npari,*),iskew(*),icodt(*)
1387 integer
1388 . inloc(*),nss,nss2,nss_s ,nss2_s,kn_m,ibfv(nifv,*),lj(*),
1389 . irbe3(nrbe3l,*),nss3 ,nss3_s ,irbe2(nrbe2l,*),lrbe2(*),
1390 . nsr2 ,nrs2_s
1391C REAL
1392 TYPE(intbuf_struct_) INTBUF_TAB(*)
1393C-----------------------------------------------
1394C L o c a l V a r i a b l e s
1395C-----------------------------------------------
1396 INTEGER
1397 . I,J,K,N,L,NL,NJ,NI,J1,M,NSN,N1,N2,NK,ID,IAD,JI,
1398 . ierror1,ierror2,ierror3,ierror4,ierror5,ierror6,ierror7
1399c----------------------
1400 ni2_fr=0
1401 ni2_frs=0
1402 IF (nss2>0) THEN
1403 IF(ALLOCATED(ifrs2)) DEALLOCATE(ifrs2)
1404 ALLOCATE(ifrs2(2,nss2),stat=ierror1)
1405 IF (nss2_s>0) THEN
1406 IF(ALLOCATED(ifrs2_s)) DEALLOCATE(ifrs2_s)
1407 ALLOCATE(ifrs2_s(nss2_s),stat=ierror3)
1408 ENDIF
1409 DO j=1,nint2
1410 n=iint2(j)
1411 nsn = ipari(5,n)
1412 ji=ipari(1,n)
1413 DO i=1,nsn
1414 ni=intbuf_tab(n)%NSV(i)
1415 IF (inloc(ni)>0) THEN
1416 ni2_fr=ni2_fr+1
1417 ifrs2(1,ni2_fr)=n
1418 ifrs2(2,ni2_fr)=i
1419 IF (inloc(ni)<=kn_m)THEN
1420 ni2_frs=ni2_frs+1
1421 ifrs2_s(ni2_frs)=ni2_fr
1422 ENDIF
1423 ENDIF
1424 ENDDO
1425 ENDDO
1426 IF (ni2_fr/=nss2.OR.ni2_frs/=nss2_s)
1427 . WRITE(*,*)'pb cal NI2_FR'
1428 ENDIF
1429c-------RBE3---------------
1430 nrbe3_fr=0
1431 nrbe3_frs=0
1432 IF (nss3>0) THEN
1433 IF(ALLOCATED(ifrs3)) DEALLOCATE(ifrs3)
1434 ALLOCATE(ifrs3(nss3),stat=ierror1)
1435 IF (nss3_s>0) THEN
1436 IF(ALLOCATED(ifrs3_s)) DEALLOCATE(ifrs3_s)
1437 ALLOCATE(ifrs3_s(nss3_s),stat=ierror3)
1438 ENDIF
1439 DO n=1,nrbe3
1440 ni=irbe3(3,n)
1441 IF (ni==0) cycle
1442 IF (inloc(ni)>0) THEN
1443 nrbe3_fr=nrbe3_fr+1
1444 ifrs3(nrbe3_fr)=n
1445 IF (inloc(ni)<=kn_m)THEN
1446 nrbe3_frs=nrbe3_frs+1
1447 ifrs3_s(nrbe3_frs)=nrbe3_fr
1448 ENDIF
1449 ENDIF
1450 ENDDO
1451 IF (nrbe3_fr/=nss3.OR.nrbe3_frs/=nss3_s)
1452 . WRITE(*,*)'pb cal NRBE3_FR'
1453 ENDIF
1454C-----active rigid body main nodes------
1455 nrb_fr=0
1456 nrb_frs=0
1457 IF (nss>0) THEN
1458 IF(ALLOCATED(ifrsr)) DEALLOCATE(ifrsr)
1459 ALLOCATE(ifrsr(2,nss),stat=ierror2)
1460 IF (nss_s>0) THEN
1461 IF(ALLOCATED(ifrsr_s)) DEALLOCATE(ifrsr_s)
1462 ALLOCATE(ifrsr_s(nss_s),stat=ierror4)
1463 ENDIF
1464 DO j=1,nrbyac
1465 n=irbyac(j)
1466 k=irbyac(j+nrbykin)
1467 m =npby(1,n)
1468 IF (inloc(m)>0) THEN
1469 nsn =npby(2,n)
1470 DO i=1,nsn
1471 id = i+k
1472 ni=lpby(id)
1473 IF (inloc(ni)>0) THEN
1474 nrb_fr=nrb_fr+1
1475 ifrsr(1,nrb_fr)=m
1476 ifrsr(2,nrb_fr)=ni
1477 IF (inloc(ni)<=kn_m) THEN
1478 nrb_frs=nrb_frs+1
1479 ifrsr_s(nrb_frs)=nrb_fr
1480 ENDIF
1481 ENDIF
1482 ENDDO
1483 ENDIF
1484 ENDDO
1485 ENDIF
1486C
1487 nbc_fr = 0
1488 DO n=1,numnod
1489 IF (iskew(n)>1.AND.icodt(n)/=7) THEN
1490 IF (inloc(n)>0.AND.inloc(n)<=kn_m)nbc_fr = nbc_fr + 1
1491 ENDIF
1492 ENDDO
1493 IF (nbc_fr>0) THEN
1494 IF(ALLOCATED(ibc_fr)) DEALLOCATE(ibc_fr)
1495 ALLOCATE(ibc_fr(3,nbc_fr),stat=ierror5)
1496 nbc_fr = 0
1497 DO n=1,numnod
1498 IF (iskew(n)>1.AND.icodt(n)/=7) THEN
1499 IF (inloc(n)>0.AND.inloc(n)<=kn_m) THEN
1500 nbc_fr = nbc_fr + 1
1501 ibc_fr(1,nbc_fr) = n
1502 ibc_fr(2,nbc_fr) = iskew(n)
1503 ibc_fr(3,nbc_fr) = icodt(n)
1504 ENDIF
1505 ENDIF
1506 ENDDO
1507 ENDIF
1508C-------AUTOSPC
1509 nspc_fr = 0
1510 DO i=1,nspcl
1511 n = in_spc(i)
1512 IF (inloc(n)>0.AND.inloc(n)<=kn_m.AND.ic_spc(i)<=3)
1513 . nspc_fr = nspc_fr + 1
1514 ENDDO
1515 IF (nspc_fr>0) THEN
1516 IF(ALLOCATED(ispc_fr)) DEALLOCATE(ispc_fr)
1517 ALLOCATE(ispc_fr(nspc_fr),stat=ierror5)
1518 nspc_fr = 0
1519 DO i=1,nspcl
1520 n = in_spc(i)
1521 IF (inloc(n)>0.AND.inloc(n)<=kn_m.AND.ic_spc(i)<=3) THEN
1522 nspc_fr = nspc_fr + 1
1523 ispc_fr(nspc_fr)=i
1524 ENDIF
1525 ENDDO
1526 ENDIF
1527C---
1528 nfx_fr = 0
1529 DO j=1,nfxvel
1530 IF (lj(j)>0.AND.lj(j)<=3) THEN
1531 n=iabs(ibfv(1,j))
1532 IF (inloc(n)>0.AND.inloc(n)<=kn_m)nfx_fr = nfx_fr + 1
1533 ENDIF
1534 ENDDO
1535 IF (nfx_fr>0) THEN
1536 IF(ALLOCATED(ifx_fr)) DEALLOCATE(ifx_fr)
1537 ALLOCATE(ifx_fr(2,nfx_fr),stat=ierror6)
1538 nfx_fr = 0
1539 DO j=1,nfxvel
1540 IF (lj(j)>0.AND.lj(j)<=3) THEN
1541 n=iabs(ibfv(1,j))
1542 IF (inloc(n)>0.AND.inloc(n)<=kn_m) THEN
1543 nfx_fr = nfx_fr + 1
1544 ifx_fr(1,nfx_fr) = j
1545 ifx_fr(2,nfx_fr) = lj(j)
1546 ENDIF
1547 ENDIF
1548 ENDDO
1549 ENDIF
1550C
1551 nrw_fr = 0
1552 DO j=1,n_rwl
1553 n=in_rwl(j)
1554 IF (inloc(n)>0) nrw_fr = nrw_fr + 1
1555 ENDDO
1556 IF (nrw_fr>0) THEN
1557 IF(ALLOCATED(irw_fr)) DEALLOCATE(irw_fr)
1558 ALLOCATE(irw_fr(nrw_fr),stat=ierror7)
1559 nrw_fr = 0
1560 DO j=1,n_rwl
1561 n=in_rwl(j)
1562 IF (inloc(n)>0) THEN
1563 nrw_fr = nrw_fr + 1
1564 irw_fr(nrw_fr) = j
1565 ENDIF
1566 ENDDO
1567 ENDIF
1568C
1569C-----RBE2------
1570 nrbe2_fr=0
1571 nrbe2_frs=0
1572 IF (nsr2>0) THEN
1573 IF(ALLOCATED(ifrs4)) DEALLOCATE(ifrs4)
1574 ALLOCATE(ifrs4(2,nsr2),stat=ierror2)
1575 IF (nrs2_s>0) THEN
1576 IF(ALLOCATED(ifrs4_s)) DEALLOCATE(ifrs4_s)
1577 ALLOCATE(ifrs4_s(nrs2_s),stat=ierror4)
1578 ENDIF
1579 DO n=1,nrbe2
1580 m =irbe2(3,n)
1581 IF (inloc(m)>0) THEN
1582 iad = irbe2(1,n)
1583 nsn =irbe2(5,n)
1584 DO i=1,nsn
1585 id = iad+i
1586 ni=lrbe2(id)
1587 IF (inloc(ni)>0) THEN
1588 nrbe2_fr=nrbe2_fr+1
1589 ifrs4(1,nrbe2_fr)=n
1590 ifrs4(2,nrbe2_fr)=ni
1591 IF (inloc(ni)<=kn_m) THEN
1592 nrbe2_frs=nrbe2_frs+1
1593 ifrs4_s(nrbe2_frs)=nrbe2_fr
1594 ENDIF
1595 ENDIF
1596 ENDDO
1597 ENDIF
1598 ENDDO
1599 ENDIF
1600C----6---------------------------------------------------------------7---------8
1601 RETURN
1602 END
1603!||====================================================================
1604!|| iddl_int ../engine/source/mpi/implicit/imp_fri.F
1605!||--- called by ------------------------------------------------------
1606!|| imp_frki ../engine/source/mpi/implicit/imp_fri.F
1607!||--- calls -----------------------------------------------------
1608!|| rbe3cl ../engine/source/constraints/general/rbe3/rbe3f.F
1609!||--- uses -----------------------------------------------------
1610!|| imp_intm ../engine/share/modules/imp_intm.F
1611!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
1612!||====================================================================
1613 SUBROUTINE iddl_int(NSL ,IDDL ,IKC ,NDOF ,IDDLM ,
1614 . IPARI ,INTBUF_TAB,IRBE3 ,LRBE3 ,FRBE3 ,
1615 . X ,SKEW ,IRBE2 ,LRBE2 )
1616C-----------------------------------------------
1617C M o d u l e s
1618C-----------------------------------------------
1619 USE imp_intm
1620 USE intbufdef_mod
1621C-----------------------------------------------
1622C I m p l i c i t T y p e s
1623C-----------------------------------------------
1624#include "implicit_f.inc"
1625C-----------------------------------------------
1626C C o m m o n B l o c k s
1627C-----------------------------------------------
1628#include "param_c.inc"
1629#include "tabsiz_c.inc"
1630C-----------------------------------------------
1631C D u m m y A r g u m e n t s
1632C-----------------------------------------------
1633 INTEGER NSL,IDDL(*) ,IKC(*) ,NDOF(*) ,IDDLM(*)
1634 INTEGER IPARI(NPARI,*),IRBE3(NRBE3L,*),LRBE3(*),
1635 . irbe2(nrbe2l,*),lrbe2(*)
1636 my_real
1637 . frbe3(*),x(*),skew(*)
1638 TYPE(intbuf_struct_) INTBUF_TAB(*)
1639C-----------------------------------------------
1640C L o c a l V a r i a b l e s
1641C-----------------------------------------------
1642 INTEGER I,ID,N,J,NDD,I1,IAD,NMT,IROTG,IADS
1643 INTEGER M,NSN,L,NNOD,NJ,NL,NI,JI
1644 INTEGER IERROR1,IERROR2,IERROR3,IERROR4,IERROR5
1645C-----------------------------------------------
1646C S o u r c e L i n e s
1647C-----------------------------------------------
1648C
1649 IF (NML>0) THEN
1650 IF(ALLOCATED(IDDML)) DEALLOCATE(IDDML)
1651 ALLOCATE(IDDML(3,NML),STAT=ierror1)
1652C--------initialization for ndof=0---
1653 iddml = -7
1654 DO i = 1, nml
1655 n = iml(i)
1656 ndd = 0
1657 DO j = 1 , min(3,ndof(n))
1658 id = iddl(n) + j
1659 IF (ikc(id)<1) THEN
1660 ndd = ndd + 1
1661 iddml(j,i) = iddlm(n) + ndd
1662 ELSE
1663 iddml(j,i) = -ikc(id)
1664 ENDIF
1665 ENDDO
1666 ENDDO
1667 ENDIF
1668C
1669 IF (nsl>0) THEN
1670 IF(ALLOCATED(iddsl)) DEALLOCATE(iddsl)
1671 ALLOCATE(iddsl(3,nsl),stat=ierror2)
1672 iddsl = -7
1673 DO i = 1, nsl
1674 n = isl(i)
1675 ndd = 0
1676 DO j = 1 , min(3,ndof(n))
1677 id = iddl(n) + j
1678 IF (ikc(id)<1) THEN
1679 ndd = ndd + 1
1680 iddsl(j,i) = iddlm(n) + ndd
1681 ELSE
1682 iddsl(j,i) = -ikc(id)
1683 ENDIF
1684 ENDDO
1685 ENDDO
1686 ENDIF
1687C
1688 IF (nrb_fr>0) THEN
1689 IF(ALLOCATED(iddmr)) DEALLOCATE(iddmr)
1690 ALLOCATE(iddmr(6,nrb_fr),stat=ierror3)
1691 DO i = 1, nrb_fr
1692 n = ifrsr(1,i)
1693 ndd = 0
1694 DO j = 1 , ndof(n)
1695 id = iddl(n) + j
1696 IF (ikc(id)<1) THEN
1697 ndd = ndd + 1
1698 iddmr(j,i) = iddlm(n) + ndd
1699 ELSE
1700 iddmr(j,i) = -ikc(id)
1701 ENDIF
1702 ENDDO
1703 ENDDO
1704 ENDIF
1705C
1706 IF (ni2_fr>0) THEN
1707 IF(ALLOCATED(iddmi2)) DEALLOCATE(iddmi2)
1708 ALLOCATE(iddmi2(6,4,ni2_fr),stat=ierror4)
1709 DO i=1,ni2_fr
1710 n=ifrs2(1,i)
1711 ni=ifrs2(2,i)
1712 ji=ipari(1,n)
1713 nsn=ipari(5,n)
1714 l=intbuf_tab(n)%IRTLM(ni)
1715 nl=4*(l-1)
1716 IF (intbuf_tab(n)%IRECTM(nl+3)==intbuf_tab(n)%IRECTM(nl+4)) THEN
1717 nnod=3
1718 ELSE
1719 nnod=4
1720 ENDIF
1721C-------if main node is also dependent-----
1722 DO m=1,nnod
1723 nj=intbuf_tab(n)%IRECTM(nl+m)
1724 ndd = 0
1725 DO j = 1 , ndof(nj)
1726 id = iddl(nj) + j
1727 IF (ikc(id)<1) THEN
1728 ndd = ndd + 1
1729 iddmi2(j,m,i) = iddlm(nj) + ndd
1730 ELSE
1731 iddmi2(j,m,i) = -ikc(id)
1732 ENDIF
1733 ENDDO
1734 ENDDO
1735 ENDDO
1736 ENDIF
1737C-------RBE3-----------
1738 IF (nrbe3_fr>0) THEN
1739 IF(ALLOCATED(iddmi3)) DEALLOCATE(iddmi3)
1740 ndd = 0
1741 DO i=1,nrbe3_fr
1742 n=ifrs3(i)
1743 ndd = max(ndd ,irbe3(5,n))
1744 ENDDO
1745 ALLOCATE(iddmi3(6,ndd,nrbe3_fr),stat=ierror5)
1746 irotg=0
1747 nmt = 0
1748 DO i=1,nrbe3_fr
1749 n=ifrs3(i)
1750 ni=irbe3(3,n)
1751 nnod=irbe3(5,n)
1752 iad=irbe3(1,n)
1753 irotg =max(irotg,irbe3(6,n))
1754C-------
1755 DO m=1,nnod
1756 nj=lrbe3(iad+m)
1757 ndd = 0
1758 DO j = 1 , ndof(nj)
1759 id = iddl(nj) + j
1760 IF (ikc(id)<1) THEN
1761 ndd = ndd + 1
1762 iddmi3(j,m,i) = iddlm(nj) + ndd
1763 ELSE
1764 iddmi3(j,m,i) = -ikc(id)
1765 ENDIF
1766 ENDDO
1767 ENDDO
1768 nmt = nmt + nnod
1769 ENDDO
1770 IF(ALLOCATED(frcdi)) DEALLOCATE(frcdi)
1771 ALLOCATE(frcdi(18*nmt))
1772 IF (irotg>0) THEN
1773 IF(ALLOCATED(mrcdi)) DEALLOCATE(mrcdi)
1774 ALLOCATE(mrcdi(18*nmt))
1775 ENDIF
1776C------- init FRCDI,MRCDI
1777 nmt = slrbe3/2
1778 iads =1
1779 DO i=1,nrbe3_fr
1780 n=ifrs3(i)
1781 ni=irbe3(3,n)
1782 nnod=irbe3(5,n)
1783 iad=irbe3(1,n)
1784 irotg =irbe3(6,n)
1785 CALL rbe3cl(lrbe3(iad+1),lrbe3(nmt+iad+1),ni ,x ,
1786 . frbe3(6*iad+1),skew ,nnod ,irotg ,frcdi(iads),
1787 . mrcdi(iads) ,irbe3(2,n))
1788C-------
1789 iads = iads + nnod
1790 ENDDO
1791 ENDIF
1792C-----------Rbe2-------------------
1793 IF (nrbe2_fr>0) THEN
1794 IF(ALLOCATED(iddmr2)) DEALLOCATE(iddmr2)
1795 ALLOCATE(iddmr2(6,nrbe2_fr),stat=ierror3)
1796 DO i = 1, nrbe2_fr
1797 n = ifrs4(1,i)
1798 m = irbe2(3,n)
1799 ndd = 0
1800 DO j = 1 , ndof(m)
1801 id = iddl(m) + j
1802 IF (ikc(id)<1) THEN
1803 ndd = ndd + 1
1804 iddmr2(j,i) = iddlm(m) + ndd
1805 ELSE
1806 iddmr2(j,i) = -ikc(id)
1807 ENDIF
1808 ENDDO
1809 ENDDO
1810 ENDIF
1811C
1812 RETURN
1813 END
1814!||====================================================================
1815!|| diag_int ../engine/source/mpi/implicit/imp_fri.F
1816!||--- called by ------------------------------------------------------
1817!|| imp_frki ../engine/source/mpi/implicit/imp_fri.F
1818!||--- calls -----------------------------------------------------
1819!|| bcl_impkd ../engine/source/constraints/general/bcs/bc_imp0.F
1820!|| fv_updkd ../engine/source/constraints/general/impvel/fv_imp0.F
1821!|| fv_updkd2 ../engine/source/constraints/general/bcs/bc_imp0.F
1822!|| i2_frup0 ../engine/source/interfaces/interf/i2_imp1.f
1823!|| i2_frup1 ../engine/source/interfaces/interf/i2_imp1.F
1824!|| l_dir ../engine/source/constraints/general/bcs/bc_imp0.F
1825!|| prerbe2fr ../engine/source/constraints/general/rbe2/rbe2f.F
1826!|| prerbe3fr ../engine/source/constraints/general/rbe3/rbe3f.F
1827!|| rbe2_impkd ../engine/source/constraints/general/rbe2/rbe2_imp0.F
1828!|| rbe3_frupd ../engine/source/constraints/general/rbe3/rbe3_imp0.F
1829!|| updfr_rb ../engine/source/constraints/general/rbody/rby_imp0.F
1830!||--- uses -----------------------------------------------------
1831!|| imp_aspc ../engine/share/modules/impbufdef_mod.F
1832!|| imp_intm ../engine/share/modules/imp_intm.F
1833!|| imp_rwl ../engine/share/modules/impbufdef_mod.F
1834!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
1835!||====================================================================
1836 SUBROUTINE diag_int(NSL ,NDOF ,IPARI ,INTBUF_TAB,
1837 . KSS ,X ,IBFV ,SKEW ,XFRAME,
1838 . IRBE3 ,LRBE3 ,IRBE2 ,LRBE2 )
1839C-----------------------------------------------
1840C M o d u l e s
1841C-----------------------------------------------
1842 USE imp_intm
1843 USE imp_rwl
1844 USE imp_aspc
1845 USE intbufdef_mod
1846C-----------------------------------------------
1847C I m p l i c i t T y p e s
1848C-----------------------------------------------
1849#include "implicit_f.inc"
1850C-----------------------------------------------
1851C C o m m o n B l o c k s
1852C-----------------------------------------------
1853#include "param_c.inc"
1854C-----------------------------------------------
1855C D u m m y A r g u m e n t s
1856C-----------------------------------------------
1857 INTEGER NSL , NDOF(*) ,IBFV(NIFV,*)
1858 INTEGER IPARI(NPARI,*),IRBE3(NRBE3L,*),LRBE3(*),
1859 . IRBE2(NRBE2L,*),LRBE2(*)
1860 my_real
1861 . KSS(6,*),X(3,*),SKEW(LSKEW,*),XFRAME(NXFRAME,*)
1862 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
1863C-----------------------------------------------
1864C L o c a l V a r i a b l e s
1865C-----------------------------------------------
1866 INTEGER I,ID,N,J,NDD,I1,IS,NS,ILEV,JT(3),JR(3)
1867 INTEGER M,NSN,JI,L,NNOD,NJ,NL,NI,IROT,IRAD
1868 INTEGER IERROR1,IERROR2,J1,ISK,IFM,K1,K2,K3,ICT,NN,IAD,IADS,K
1869 my_real
1870 . XS,YS,ZS,KII(3,3),KJJ(6),EJ(3),S,KDD(6,6),KMM(6)
1871C-----------------------------------------------
1872C S o u r c e L i n e s
1873C-----------------------------------------------
1874C
1875 IF (NRB_FRS>0) THEN
1876 IF(ALLOCATED(DIAG_MR)) DEALLOCATE(DIAG_MR)
1877 ALLOCATE(DIAG_MR(6,NRB_FRS),STAT=ierror1)
1878 DO i1 = 1, nrb_frs
1879 DO j = 1, 6
1880 diag_mr(j,i1)=zero
1881 ENDDO
1882 ENDDO
1883 ENDIF
1884 IF (ni2_frs>0) THEN
1885 IF(ALLOCATED(diag_m2)) DEALLOCATE(diag_m2)
1886 ALLOCATE(diag_m2(6,4,ni2_frs),stat=ierror2)
1887 DO i1=1,ni2_frs
1888 DO j = 1, 6
1889 DO m = 1, 4
1890 diag_m2(j,m,i1)=zero
1891 ENDDO
1892 ENDDO
1893 ENDDO
1894 ENDIF
1895 IF (nrbe3_frs>0) THEN
1896C------RBE3---
1897 iads=0
1898 DO i1=1,nrbe3_frs
1899 i = ifrs3_s(i1)
1900 n=ifrs3(i)
1901 iads=max(iads,irbe3(5,n))
1902 ENDDO
1903 IF(ALLOCATED(diag_m3)) DEALLOCATE(diag_m3)
1904 ALLOCATE(diag_m3(6,iads,nrbe3_frs),stat=ierror1)
1905 diag_m3=zero
1906 ENDIF
1907C-------------RBE2----------------------
1908 IF (nrbe2_frs>0) THEN
1909 IF(ALLOCATED(diag_mr2)) DEALLOCATE(diag_mr2)
1910 ALLOCATE(diag_mr2(6,nrbe2_frs),stat=ierror1)
1911 diag_mr2=zero
1912 ENDIF
1913C--------local secondary node-, first independent----
1914 DO i = 1, nsl
1915 n = isl(i)
1916 DO j = 1, min(3,ndof(n))
1917 id = iddsl(j,i)
1918 IF (id>0) diag_s(j,i)=kss(j,i)
1919 ENDDO
1920 ENDDO
1921C
1922 DO i1=1,ni2_frs
1923 i = ifrs2_s(i1)
1924 n=ifrs2(1,i)
1925 ni=ifrs2(2,i)
1926 ji=ipari(1,n)
1927 nsn=ipari(5,n)
1928 ns=intbuf_tab(n)%NSV(ni)
1929 DO is = 1, nsl
1930 IF (isl(is)==ns) THEN
1931 ilev =ipari(20,n)
1932 IF (ilev==1) THEN
1933 CALL i2_frup1(x ,intbuf_tab(n)%IRECTM,intbuf_tab(n)%DPARA ,intbuf_tab(n)%NSV ,
1934 1 intbuf_tab(n)%IRTLM ,ns ,kss(1,is),diag_m2(1,1,i1))
1935 ELSE
1936 CALL i2_frup0(x ,intbuf_tab(n)%IRECTM,intbuf_tab(n)%CSTS ,intbuf_tab(n)%NSV ,
1937 1 intbuf_tab(n)%IRTLM,ns,ndof,kss(1,is),diag_m2(1,1,i1))
1938 ENDIF
1939 ENDIF
1940 ENDDO
1941 ENDDO
1942C------------RBE2--------------
1943 DO i1 = 1, nrbe2_frs
1944 i = ifrs4_s(i1)
1945 n = ifrs4(1,i)
1946 m = irbe2(3,n)
1947 ns = ifrs4(2,i)
1948 ict = irbe2(4,n)
1949 isk = irbe2(7,n)
1950 irad =irbe2(11,n)
1951C--------remove ICR---
1952 ict =(ict/512)*512
1953 CALL prerbe2fr(ict ,jt ,jr )
1954 DO k=1,6
1955 DO j=1,6
1956 kdd(k,j) = zero
1957 ENDDO
1958 kmm(k)= zero
1959 ENDDO
1960 DO is = 1, nsl
1961 IF (isl(is)==ns) THEN
1962 DO j=1,3
1963 kdd(j,j) = kss(j,is)
1964 ENDDO
1965 kdd(1,2)=kss(4,is)
1966 kdd(1,3)=kss(5,is)
1967 kdd(2,3)=kss(6,is)
1968 kdd(2,1)=kdd(1,2)
1969 kdd(3,1)=kdd(1,3)
1970 kdd(3,2)=kdd(2,3)
1971 CALL rbe2_impkd(m ,ns ,x ,isk ,jt ,
1972 2 jr ,ndof ,skew(1,isk),kdd ,kmm ,
1973 3 diag_s(1,is),irad )
1974 DO j = 1 , ndof(m)
1975 diag_mr2(j,i1) = diag_mr2(j,i1) + kmm(j)
1976 END DO
1977 END IF
1978 END DO
1979 END DO
1980C------RBE3---
1981 iads=1
1982 DO i1=1,nrbe3_frs
1983 i = ifrs3_s(i1)
1984 n=ifrs3(i)
1985 ni=irbe3(3,n)
1986 nnod=irbe3(5,n)
1987 irot=irbe3(6,n)
1988 iad=irbe3(1,n)
1989 DO is = 1, nsl
1990 IF (isl(is)==ni) THEN
1991C-------
1992 CALL prerbe3fr(irbe3 ,n ,jt ,jr )
1993 CALL rbe3_frupd(nnod ,lrbe3(iad+1) ,frcdi(iads),
1994 1 mrcdi(iads),ndof ,jt ,irot ,
1995 2 kss(1,is),diag_m3(1,1,i1))
1996 ENDIF
1997 ENDDO
1998 iads=iads+nnod
1999 ENDDO
2000C------RBODY---
2001 DO i1 = 1, nrb_frs
2002 i = ifrsr_s(i1)
2003 m = ifrsr(1,i)
2004 n = ifrsr(2,i)
2005 DO is = 1, nsl
2006 IF (isl(is)==n) THEN
2007 xs=x(1,n)-x(1,m)
2008 ys=x(2,n)-x(2,m)
2009 zs=x(3,n)-x(3,m)
2010 CALL updfr_rb(xs,ys,zs,kss(1,is),diag_mr(1,i1))
2011 ENDIF
2012 ENDDO
2013 ENDDO
2014 DO i1 = 1,nbc_fr
2015 n = ibc_fr(1,i1)
2016 isk= ibc_fr(2,i1)
2017 ict= ibc_fr(3,i1)
2018 DO is = 1, nsl
2019 IF (isl(is)==n) THEN
2020 kii(1,1)=kss(1,is)
2021 kii(2,2)=kss(2,is)
2022 kii(3,3)=kss(3,is)
2023 kii(1,2)=kss(4,is)
2024 kii(1,3)=kss(5,is)
2025 kii(2,3)=kss(6,is)
2026 kii(2,1)=kii(1,2)
2027 kii(3,1)=kii(1,3)
2028 kii(3,2)=kii(2,3)
2029 CALL bcl_impkd(ict ,isk ,skew ,kii ,diag_s(1,is))
2030 ENDIF
2031 ENDDO
2032 ENDDO
2033C-------AUTOSPC
2034 DO i1=1,nspc_fr
2035 n = ispc_fr(i1)
2036 i = in_spc(n)
2037 iad = 6*(n-1)+1
2038 nn = ic_spc(n)
2039 DO is = 1, nsl
2040 IF (isl(is)==i) THEN
2041 kii(1,1)=kss(1,is)
2042 kii(2,2)=kss(2,is)
2043 kii(3,3)=kss(3,is)
2044 kii(1,2)=kss(4,is)
2045 kii(1,3)=kss(5,is)
2046 kii(2,3)=kss(6,is)
2047 kii(2,1)=kii(1,2)
2048 kii(3,1)=kii(1,3)
2049 kii(3,2)=kii(2,3)
2050 IF (nn==1) THEN
2051 ej(1)=skew_spc(iad)
2052 ej(2)=skew_spc(iad+1)
2053 ej(3)=skew_spc(iad+2)
2054 CALL l_dir(ej,j)
2055 CALL fv_updkd(ej ,j ,kii ,diag_s(1,is))
2056 ELSEIF (nn==2) THEN
2057 CALL fv_updkd2(skew_spc(iad),skew_spc(iad+3),kii,
2058 . diag_s(1,is))
2059 END IF
2060 ENDIF
2061 ENDDO
2062 ENDDO
2063 DO i1 = 1,nfx_fr
2064 n = ifx_fr(1,i1)
2065 j1= ifx_fr(2,i1)
2066 i=iabs(ibfv(1,n))
2067 isk=ibfv(2,n)/10
2068 ifm = ibfv(9,n)
2069 j=ibfv(2,n)
2070 IF (ifm<=1) j=j-10*isk
2071 k1=3*j-2
2072 k2=3*j-1
2073 k3=3*j
2074 IF (isk>1) THEN
2075 ej(1)=skew(k1,isk)
2076 ej(2)=skew(k2,isk)
2077 ej(3)=skew(k3,isk)
2078 ELSE
2079 ej(1)=xframe(k1,ifm)
2080 ej(2)=xframe(k2,ifm)
2081 ej(3)=xframe(k3,ifm)
2082 ENDIF
2083 DO is = 1, nsl
2084 IF (isl(is)==i) THEN
2085 kii(1,1)=kss(1,is)
2086 kii(2,2)=kss(2,is)
2087 kii(3,3)=kss(3,is)
2088 kii(1,2)=kss(4,is)
2089 kii(1,3)=kss(5,is)
2090 kii(2,3)=kss(6,is)
2091 kii(2,1)=kii(1,2)
2092 kii(3,1)=kii(1,3)
2093 kii(3,2)=kii(2,3)
2094 s = one/ej(j1)
2095 DO nn =1,3
2096 ej(nn) = ej(nn)*s
2097 ENDDO
2098 CALL fv_updkd(ej ,j1 ,kii ,diag_s(1,is))
2099 ENDIF
2100 ENDDO
2101 ENDDO
2102 DO i1 = 1,nrw_fr
2103 i = irw_fr(i1)
2104 n = in_rwl(i)
2105 DO is = 1, nsl
2106 IF (isl(is)==n) THEN
2107 kii(1,1)=kss(1,is)
2108 kii(2,2)=kss(2,is)
2109 kii(3,3)=kss(3,is)
2110 kii(1,2)=kss(4,is)
2111 kii(1,3)=kss(5,is)
2112 kii(2,3)=kss(6,is)
2113 kii(2,1)=kii(1,2)
2114 kii(3,1)=kii(1,3)
2115 kii(3,2)=kii(2,3)
2116 ej(1)=nor_rwl(1,i)
2117 ej(2)=nor_rwl(2,i)
2118 ej(3)=nor_rwl(3,i)
2119 CALL l_dir(ej,j1)
2120 CALL fv_updkd(ej ,j1 ,kii ,diag_s(1,is))
2121 ENDIF
2122 ENDDO
2123 ENDDO
2124C
2125 RETURN
2126 END
2127!||====================================================================
2128!|| intabfr ../engine/source/mpi/implicit/imp_fri.F
2129!||--- called by ------------------------------------------------------
2130!|| get_iad ../engine/source/mpi/implicit/imp_fri.F
2131!|| imp_fvkm ../engine/source/mpi/implicit/imp_fri.F
2132!|| imp_fvkss ../engine/source/mpi/implicit/imp_fri.F
2133!|| ini_frud ../engine/source/mpi/implicit/imp_fri.F
2134!|| upd_kml ../engine/source/mpi/implicit/imp_fri.F
2135!|| upd_ksl ../engine/source/mpi/implicit/imp_fri.f
2136!||--- calls -----------------------------------------------------
2137!|| intab ../engine/source/implicit/ind_glob_k.F
2138!||====================================================================
2139 SUBROUTINE intabfr(NIC,IC,N,INTAB)
2140C----6---------------------------------------------------------------7---------8
2141C I m p l i c i t T y p e s
2142C-----------------------------------------------
2143#include "implicit_f.inc"
2144C-----------------------------------------------------------------
2145C D u m m y A r g u m e n t s
2146C-----------------------------------------------
2147 INTEGER N ,NIC,IC(*),INTAB
2148C-----------------------------------------------
2149C L o c a l V a r i a b l e s
2150C-----------------------------------------------
2151 INTEGER I
2152C---- 6 ----- IC is already in an increasing order ----------------------------------- 7 -------- 8
2153 intab=0
2154 DO i =1,nic
2155 IF (n==ic(i)) THEN
2156 intab=i
2157 RETURN
2158 ENDIF
2159 ENDDO
2160C
2161 RETURN
2162 END
2163C --------- ----
2164!||====================================================================
2165!|| imp_diags ../engine/source/mpi/implicit/imp_fri.F
2166!||--- called by ------------------------------------------------------
2167!|| lin_solvh1 ../engine/source/implicit/lin_solv.F
2168!|| lin_solvih2 ../engine/source/implicit/lin_solv.F
2169!||--- uses -----------------------------------------------------
2170!|| imp_intm ../engine/share/modules/imp_intm.F
2171!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
2172!||====================================================================
2173 SUBROUTINE imp_diags(DIAG_K,NDOF,NSL,IPARI,INTBUF_TAB,IRBE3,LRBE3,
2174 . IRBE2 )
2175C-----------------------------------------------
2176C M o d u l e s
2177C-----------------------------------------------
2178 USE imp_intm
2179 USE intbufdef_mod
2180C----6---------------------------------------------------------------7---------8
2181C I m p l i c i t T y p e s
2182C-----------------------------------------------
2183#include "implicit_f.inc"
2184C-----------------------------------------------
2185C C o m m o n B l o c k s
2186C-----------------------------------------------
2187#include "param_c.inc"
2188C-----------------------------------------------------------------
2189C D u m m y A r g u m e n t s
2190C-----------------------------------------------
2191 INTEGER NDOF(*),NSL
2192 INTEGER IPARI(NPARI,*),IRBE3(NRBE3L,*),LRBE3(*),
2193 . IRBE2(NRBE2L,*)
2194C REAL
2195 my_real
2196 . diag_k(*)
2197 TYPE(intbuf_struct_) INTBUF_TAB(*)
2198C-----------------------------------------------
2199C L o c a l V a r i a b l e s
2200C-----------------------------------------------
2201 INTEGER I,J,N,ID,I1,IAD
2202 INTEGER M,NSN,L,NNOD,NJ,NL,NI,JI
2203C-----------------------------------------------
2204 IF (intp_d>0) THEN
2205 DO i = 1, nddl_sl
2206 id = iddl_sl(i)
2207 diag_k(id)=diag_k(id)+diag_sl(i)
2208 ENDDO
2209 ELSE
2210 DO i = 1, nsl
2211C--------local secondary node-----
2212 n = isl(i)
2213 DO j = 1, min(3,ndof(n))
2214 id = iddsl(j,i)
2215 IF (id>0) diag_k(id)=diag_k(id)+diag_s(j,i)
2216 ENDDO
2217 ENDDO
2218C--------if there are independent nodes-----
2219 DO i1=1,ni2_frs
2220 i=ifrs2_s(i1)
2221 n=ifrs2(1,i)
2222 ni=ifrs2(2,i)
2223 ji=ipari(1,n)
2224 nsn=ipari(5,n)
2225 l=intbuf_tab(n)%IRTLM(ni)
2226 nl=4*(l-1)
2227 IF (intbuf_tab(n)%IRECTM(nl+3)==intbuf_tab(n)%IRECTM(nl+4)) THEN
2228 nnod=3
2229 ELSE
2230 nnod=4
2231 ENDIF
2232 DO m=1,nnod
2233 nj=intbuf_tab(n)%IRECTM(nl+m)
2234 DO j = 1 , ndof(nj)
2235 id = iddmi2(j,m,i)
2236 IF (id>0) diag_k(id)=diag_k(id)+diag_m2(j,m,i1)
2237 ENDDO
2238 ENDDO
2239 ENDDO
2240C--------RBE3-----
2241 DO i1=1,nrbe3_frs
2242 i=ifrs3_s(i1)
2243 n=ifrs3(i)
2244 iad=irbe3(1,n)
2245 nnod=irbe3(5,n)
2246 DO m=1,nnod
2247 nj=lrbe3(iad+m)
2248 DO j = 1 , ndof(nj)
2249 id = iddmi3(j,m,i)
2250 IF (id>0) diag_k(id)=diag_k(id)+diag_m3(j,m,i1)
2251 ENDDO
2252 ENDDO
2253 ENDDO
2254 DO i1 = 1, nrb_frs
2255 i=ifrsr_s(i1)
2256 n = ifrsr(1,i)
2257 DO j = 1 , ndof(n)
2258 id = iddmr(j,i)
2259 IF (id>0) diag_k(id)=diag_k(id)+diag_mr(j,i1)
2260 ENDDO
2261 ENDDO
2262C--------RBE2-----
2263 DO i1 = 1, nrbe2_frs
2264 i=ifrs4_s(i1)
2265 n = ifrs4(1,i)
2266 m = irbe2(3,n)
2267 DO j = 1 , ndof(m)
2268 id = iddmr2(j,i)
2269 IF (id>0) diag_k(id)=diag_k(id)+diag_mr2(j,i1)
2270 ENDDO
2271 ENDDO
2272C
2273 ENDIF
2274C----6---------------------------------------------------------------7---------8
2275 RETURN
2276 END
2277C --------- ----
2278!||====================================================================
2279!|| imp_diagsn ../engine/source/mpi/implicit/imp_fri.F
2280!||--- called by ------------------------------------------------------
2281!|| lin_solvh1 ../engine/source/implicit/lin_solv.F
2282!|| lin_solvih2 ../engine/source/implicit/lin_solv.F
2283!||--- uses -----------------------------------------------------
2284!|| imp_intm ../engine/share/modules/imp_intm.F
2285!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
2286!||====================================================================
2287 SUBROUTINE imp_diagsn(DIAG_K,NDOF,NSL,IPARI,INTBUF_TAB,IRBE3,LRBE3,
2288 . IRBE2 )
2289C-----------------------------------------------
2290C M o d u l e s
2291C-----------------------------------------------
2292 USE imp_intm
2293 USE intbufdef_mod
2294C----6---------------------------------------------------------------7---------8
2295C I m p l i c i t T y p e s
2296C-----------------------------------------------
2297#include "implicit_f.inc"
2298C-----------------------------------------------
2299C C o m m o n B l o c k s
2300C-----------------------------------------------
2301#include "param_c.inc"
2302C-----------------------------------------------------------------
2303C D u m m y A r g u m e n t s
2304C-----------------------------------------------
2305 INTEGER NDOF(*),NSL
2306 INTEGER IPARI(NPARI,*),IRBE3(NRBE3L,*),LRBE3(*),
2307 . irbe2(nrbe2l,*)
2308C REAL
2309 my_real
2310 . diag_k(*)
2311 TYPE(intbuf_struct_) INTBUF_TAB(*)
2312C-----------------------------------------------
2313C L o c a l V a r i a b l e s
2314C-----------------------------------------------
2315 INTEGER I,J,N,ID,I1,IAD
2316 INTEGER M,NSN,L,NNOD,NJ,NL,NI,JI
2317C-----------------------------------------------
2318 IF (intp_d>0) THEN
2319 DO i = 1, nddl_sl
2320 id = iddl_sl(i)
2321 diag_k(id)=diag_k(id)-diag_sl(i)
2322 ENDDO
2323 ELSE
2324 DO i = 1, nsl
2325C--------local secondary node-----
2326 n = isl(i)
2327 DO j = 1, min(3,ndof(n))
2328 id = iddsl(j,i)
2329 IF (id>0) diag_k(id)=diag_k(id)-diag_s(j,i)
2330 ENDDO
2331 ENDDO
2332C--------if there are independent nodes-----
2333 DO i1=1,ni2_frs
2334 i=ifrs2_s(i1)
2335 n=ifrs2(1,i)
2336 ni=ifrs2(2,i)
2337 ji=ipari(1,n)
2338 nsn=ipari(5,n)
2339 l=intbuf_tab(n)%IRTLM(ni)
2340 nl=4*(l-1)
2341 IF (intbuf_tab(n)%IRECTM(nl+3)==intbuf_tab(n)%IRECTM(nl+4)) THEN
2342 nnod=3
2343 ELSE
2344 nnod=4
2345 ENDIF
2346 DO m=1,nnod
2347 nj=intbuf_tab(n)%IRECTM(nl+m)
2348 DO j = 1 , ndof(nj)
2349 id = iddmi2(j,m,i)
2350 IF (id>0) diag_k(id)=diag_k(id)-diag_m2(j,m,i1)
2351 ENDDO
2352 ENDDO
2353 ENDDO
2354C--------RBE3-----
2355 DO i1=1,nrbe3_frs
2356 i=ifrs3_s(i1)
2357 n=ifrs3(i)
2358 iad=irbe3(1,n)
2359 nnod=irbe3(5,n)
2360 DO m=1,nnod
2361 nj=lrbe3(iad+m)
2362 DO j = 1 , ndof(nj)
2363 id = iddmi3(j,m,i)
2364 IF (id>0) diag_k(id)=diag_k(id)-diag_m3(j,m,i1)
2365 ENDDO
2366 ENDDO
2367 ENDDO
2368 DO i1 = 1, nrb_frs
2369 i=ifrsr_s(i1)
2370 n = ifrsr(1,i)
2371 DO j = 1 , ndof(n)
2372 id = iddmr(j,i)
2373 IF (id>0) diag_k(id)=diag_k(id)-diag_mr(j,i1)
2374 ENDDO
2375 ENDDO
2376C--------RBE2-----
2377 DO i1 = 1, nrbe2_frs
2378 i=ifrs4_s(i1)
2379 n = ifrs4(1,i)
2380 m = irbe2(3,n)
2381 DO j = 1 , ndof(m)
2382 id = iddmr2(j,i)
2383 IF (id>0) diag_k(id)=diag_k(id)-diag_mr2(j,i1)
2384 ENDDO
2385 ENDDO
2386C
2387 ENDIF
2388C----6---------------------------------------------------------------7---------8
2389 RETURN
2390 END
2391!||====================================================================
2392!|| fr_matv ../engine/source/mpi/implicit/imp_fri.F
2393!||--- called by ------------------------------------------------------
2394!|| imp_frfv ../engine/source/mpi/implicit/imp_fri.F
2395!|| mav_lth ../engine/source/implicit/produt_v.F
2396!|| mav_lth0 ../engine/source/implicit/produt_v.F
2397!|| mav_ltp ../engine/source/implicit/produt_v.F
2398!||--- calls -----------------------------------------------------
2399!|| fr_a2b ../engine/source/mpi/implicit/imp_fri.F
2400!|| fr_a2bd ../engine/source/mpi/implicit/imp_fri.F
2401!|| fr_u2d ../engine/source/mpi/implicit/imp_fri.F
2402!|| fr_u2dd ../engine/source/mpi/implicit/imp_fri.F
2403!|| i7mainfr ../engine/source/interfaces/int07/i7ke3.F
2404!|| mav_ltfr ../engine/source/mpi/implicit/imp_fri.F
2405!|| spmd_ifcd ../engine/source/mpi/implicit/imp_spmd.F
2406!|| spmd_ifcf ../engine/source/mpi/implicit/imp_spmd.F
2407!|| spmd_ifrf ../engine/source/mpi/implicit/imp_spmd.F
2408!|| spmd_ifru ../engine/source/mpi/implicit/imp_spmd.F
2409!|| upd_fr ../engine/source/mpi/implicit/imp_fri.F
2410!||--- uses -----------------------------------------------------
2411!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
2412!||====================================================================
2413 SUBROUTINE fr_matv( A ,V ,D ,MS ,X ,
2414 1 DR ,AR ,IPARI ,INTBUF_TAB ,
2415 2 NDOF ,NUM_IMP,NS_IMP,NE_IMP,LX ,
2416 3 NSREM ,NSL ,IBFV ,SKEW ,XFRAME ,
2417 4 F ,IRBE3 ,LRBE3 ,IRBE2 ,LRBE2 )
2418C-----------------------------------------------
2419C M o d u l e s
2420C-----------------------------------------------
2421 USE intbufdef_mod
2422C-----------------------------------------------
2423C I m p l i c i t T y p e s
2424C-----------------------------------------------
2425#include "implicit_f.inc"
2426C-----------------------------------------------
2427C C o m m o n B l o c k s
2428C-----------------------------------------------
2429#include "param_c.inc"
2430#include "impl1_c.inc"
2431C-----------------------------------------------
2432C D u m m y A r g u m e n t s
2433C-----------------------------------------------
2434 INTEGER IPARI(NPARI,*), NDOF(*),IBFV(*) ,
2435 . num_imp(*),ns_imp(*),ne_imp(*),nsrem,nsl,
2436 . irbe3(*) ,lrbe3(*),irbe2(*),lrbe2(*)
2437 my_real
2438 . a(3,*),ar(3,*),v(3,*),d(3,*),dr(3,*),x(3,*) ,
2439 . ms(*),skew(*) ,xframe(*)
2440 my_real
2441 . lx(*),f(*)
2442 TYPE(intbuf_struct_) INTBUF_TAB(*)
2443C-----------------------------------------------
2444C L o c a l V a r i a b l e s
2445C-----------------------------------------------
2446 INTEGER I,IDF
2447C-----------------------------------------------
2448 IF ((NSREM+NSL)==0) return
2449C
2450 IF (intp_c>0) THEN
2451C-----send U(NDDL_SL) and receive U(NDDL_SI)-----
2452 CALL spmd_ifru(lx )
2453 CALL mav_ltfr(lx ,f )
2454C-----send F (NDDL_SI) and receive F (NDDL_SL)-----
2455 CALL spmd_ifrf(f )
2456 ELSE
2457C
2458C-----initialize D,A independent nodes first-----
2459 CALL fr_u2d(ndof ,lx ,d ,a ,nsrem, nsl )
2460C-----kinematic nodes -----
2461 CALL fr_u2dd(d ,dr ,x ,ipari ,intbuf_tab,
2462 1 ndof ,a ,ar ,lx ,
2463 2 ibfv ,skew ,xframe,irbe3,lrbe3 ,
2464 3 irbe2,lrbe2 )
2465C-----send D (NSL) and receive DFI (NSREM)-----
2466 CALL spmd_ifcd(d ,nsl, nsrem)
2467C-----compute contact force ->A ,FFI-----
2468 IF (nsrem>0)
2469 . CALL i7mainfr(a ,v ,d ,x ,ms ,
2470 1 ipari ,intbuf_tab ,num_imp,ns_imp,
2471 2 ne_imp)
2472C-----send FFI (NSREM) and receive A (NSL)-----
2473 CALL spmd_ifcf(a, nsrem ,nsl)
2474C-----Compute A with dependent nodes---------
2475 CALL upd_fr(a ,ar ,x ,ipari ,intbuf_tab,
2476 1 ndof ,ibfv ,skew ,xframe ,
2477 2 irbe3 ,lrbe3 ,irbe2 ,lrbe2 )
2478C
2479 CALL fr_a2b(ndof ,f ,a ,nsl )
2480 CALL fr_a2bd(ndof ,ipari ,intbuf_tab,f ,a ,
2481 . ar ,irbe3 ,lrbe3 ,irbe2 ,lrbe2 )
2482 END IF !(INTP_C>0) THEN
2483C
2484 RETURN
2485 END
2486!||====================================================================
2487!|| fr_matv_gpu ../engine/source/mpi/implicit/imp_fri.F
2488!||--- calls -----------------------------------------------------
2489!|| mav_ltfr_gpu ../engine/source/mpi/implicit/imp_fri.F
2490!|| spmd_ifrf_gpu ../engine/source/mpi/implicit/imp_spmd.F
2491!|| spmd_ifru_gpu ../engine/source/mpi/implicit/imp_spmd.F
2492!||====================================================================
2493 SUBROUTINE fr_matv_gpu(NSREM, NSL, LX ,F ,NINDEX)
2494C-----------------------------------------------
2495C I m p l i c i t T y p e s
2496C-----------------------------------------------
2497#include "implicit_f.inc"
2498C-----------------------------------------------
2499C C o m m o n B l o c k s
2500C-----------------------------------------------
2501#include "impl1_c.inc"
2502C-----------------------------------------------
2503C D u m m y A r g u m e n t s
2504C-----------------------------------------------
2505 INTEGER NSREM, NSL, NINDEX(*)
2506 my_real
2507 . lx(*), f(*)
2508C-----------------------------------------------
2509C L o c a l V a r i a b l e s
2510C-----------------------------------------------
2511 INTEGER I
2512C-----------------------------------------------
2513 IF ((NSREM+NSL)==0) return
2514C
2515 IF (intp_c>0) THEN
2516C-----send U(NDDL_SL) and receive U(NDDL_SI)-----
2517 CALL spmd_ifru_gpu(lx,nindex)
2518 CALL mav_ltfr_gpu(lx ,f, nindex)
2519C-----send F (NDDL_SI) and receive F (NDDL_SL)-----
2520 CALL spmd_ifrf_gpu(f,nindex)
2521 ELSE
2522 print*,'**ERROR OPTION NOT COMPATIBLE WITH GPU'
2523 stop 1234
2524 END IF
2525C
2526 RETURN
2527 END
2528!||====================================================================
2529!|| fr_u2d ../engine/source/mpi/implicit/imp_fri.F
2530!||--- called by ------------------------------------------------------
2531!|| fr_matv ../engine/source/mpi/implicit/imp_fri.F
2532!||--- uses -----------------------------------------------------
2533!|| imp_intm ../engine/share/modules/imp_intm.F
2534!||====================================================================
2535 SUBROUTINE fr_u2d(NDOF ,LX ,D ,A ,NSREM ,NSL )
2536C-----------------------------------------------
2537C M o d u l e s
2538C-----------------------------------------------
2539 USE imp_intm
2540C-----------------------------------------------
2541C I m p l i c i t T y p e s
2542C-----------------------------------------------
2543#include "implicit_f.inc"
2544C-----------------------------------------------
2545C D u m m y A r g u m e n t s
2546C-----------------------------------------------
2547 INTEGER NDOF(*),NSL,NSREM
2548 my_real
2549 . D(3,*),A(3,*),LX(*)
2550C----------------------------------------------
2551C L o c a l V a r i a b l e s
2552C-----------------------------------------------
2553 INTEGER I,J,K,ID,ND,M,N
2554C----independent nodes first-----
2555 DO i = 1,nsrem
2556 ffi(1,i)=zero
2557 ffi(2,i)=zero
2558 ffi(3,i)=zero
2559 ENDDO
2560 DO i = 1,nsl
2561 n=isl(i)
2562 DO j=1,min(3,ndof(n))
2563 nd = iddsl(j,i)
2564 IF (nd>0) d(j,n)=lx(nd)
2565C--------for communication with FFI----
2566 a(j,n)=zero
2567 ENDDO
2568 ENDDO
2569 DO i = 1,nml
2570 n=iml(i)
2571 DO j=1,min(3,ndof(n))
2572 nd = iddml(j,i)
2573 IF (nd>0) d(j,n)=lx(nd)
2574 a(j,n)=zero
2575 ENDDO
2576 ENDDO
2577C
2578 RETURN
2579 END
2580!||====================================================================
2581!|| fr_u2dd ../engine/source/mpi/implicit/imp_fri.F
2582!||--- called by ------------------------------------------------------
2583!|| fr_matv ../engine/source/mpi/implicit/imp_fri.f
2584!||--- calls -----------------------------------------------------
2585!|| bc_upd2d ../engine/source/constraints/general/bcs/bc_imp0.F
2586!|| bc_updd ../engine/source/constraints/general/bcs/bc_imp0.F
2587!|| bcl_impd ../engine/source/constraints/general/bcs/bc_imp0.F
2588!|| fv_impd ../engine/source/constraints/general/impvel/fv_imp0.f
2589!|| i2_frrd0 ../engine/source/interfaces/interf/i2_imp2.F
2590!|| i2_frrd1 ../engine/source/interfaces/interf/i2_imp2.F
2591!|| l_dir ../engine/source/constraints/general/bcs/bc_imp0.F
2592!|| prerbe2fr ../engine/source/constraints/general/rbe2/rbe2f.F
2593!|| prerbe3fr ../engine/source/constraints/general/rbe3/rbe3f.F
2594!|| rbe2_frd ../engine/source/constraints/general/rbe2/rbe2v.F
2595!|| rbe3_frd ../engine/source/constraints/general/rbe3/rbe3v.F
2596!|| rby_imp3 ../engine/source/constraints/general/rbody/rby_impd.F
2597!||--- uses -----------------------------------------------------
2598!|| imp_aspc ../engine/share/modules/impbufdef_mod.F
2599!|| imp_intm ../engine/share/modules/imp_intm.F
2600!|| imp_rwl ../engine/share/modules/impbufdef_mod.F
2601!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
2602!||====================================================================
2603 SUBROUTINE fr_u2dd( D ,DR ,X ,IPARI ,INTBUF_TAB,
2604 . NDOF ,A ,AR ,LX ,
2605 . IBFV ,SKEW ,XFRAME,IRBE3 ,LRBE3 ,
2606 . IRBE2 ,LRBE2 )
2607C-----------------------------------------------
2608C M o d u l e s
2609C-----------------------------------------------
2610 USE imp_intm
2611 USE imp_rwl
2612 USE imp_aspc
2613 USE intbufdef_mod
2614C-----------------------------------------------
2615C I m p l i c i t T y p e s
2616C-----------------------------------------------
2617#include "implicit_f.inc"
2618C-----------------------------------------------
2619C C o m m o n B l o c k s
2620C-----------------------------------------------
2621#include "com04_c.inc"
2622#include "param_c.inc"
2623C-----------------------------------------------
2624C D u m m y A r g u m e n t s
2625C-----------------------------------------------
2626 INTEGER IRBE3(NRBE3L,*),LRBE3(*),IRBE2(NRBE2L,*),LRBE2(*),
2627 . ipari(npari,*), ndof(*),ibfv(nifv,*)
2628 my_real
2629 . d(3,*),dr(3,*),a(3,*),ar(3,*),x(3,*) ,lx(*),
2630 . skew(lskew,*) ,xframe(*)
2631 TYPE(intbuf_struct_) INTBUF_TAB(*)
2632C-----------------------------------------------
2633C L o c a l V a r i a b l e s
2634C-----------------------------------------------
2635 INTEGER I,J,N,M,NS,NI,NSN,ILEV,IADS,IROT,IAD,JI,
2636 . L,NNOD,NJ,ND,NL,ISK,IFM,LJFR(NFXVEL),
2637 . JT(3),JR(3),IRAD,NN,IC
2638 my_real
2639 . EJ(3)
2640 DO L=nbc_fr,1,-1
2641 i = ibc_fr(1,l)
2642 isk =ibc_fr(2,l)
2643 ifm =ibc_fr(3,l)
2644 CALL bcl_impd(ifm ,isk ,skew ,i ,d )
2645 a(1,i)=zero
2646 a(2,i)=zero
2647 a(3,i)=zero
2648 ENDDO
2649 DO l=nspc_fr,1,-1
2650 n = ispc_fr(l)
2651 i = in_spc(n)
2652 iad = 6*(n-1)+1
2653 nn = ic_spc(n)
2654 IF (nn==1) THEN
2655 ej(1)=skew_spc(iad)
2656 ej(2)=skew_spc(iad+1)
2657 ej(3)=skew_spc(iad+2)
2658 CALL l_dir(ej,j)
2659 d(j,i) = zero
2660 CALL bc_updd(i ,ej ,j ,d )
2661 ELSEIF (nn==2) THEN
2662 CALL bc_upd2d(i ,skew_spc(iad),skew_spc(iad+3),d )
2663 END IF
2664 a(1,i)=zero
2665 a(2,i)=zero
2666 a(3,i)=zero
2667 ENDDO
2668C
2669 IF (nfx_fr>0) THEN
2670 DO n=1,nfxvel
2671 ljfr(n)=0
2672 ENDDO
2673 DO l=1,nfx_fr
2674 i = ifx_fr(1,l)
2675 ljfr(i) = ifx_fr(2,l)
2676 ENDDO
2677 CALL fv_impd(ibfv ,ljfr ,skew ,xframe,d ,
2678 1 dr )
2679 DO l=nfx_fr,1,-1
2680 j = ifx_fr(2,l)
2681 a(j,n)=zero
2682 ENDDO
2683 ENDIF
2684C
2685 DO l = 1,nrw_fr
2686 i = irw_fr(l)
2687 n=in_rwl(i)
2688 ej(1)=nor_rwl(1,i)
2689 ej(2)=nor_rwl(2,i)
2690 ej(3)=nor_rwl(3,i)
2691 CALL l_dir(ej,j)
2692 CALL bc_updd(n ,ej ,j ,d )
2693 a(j,n)=zero
2694 ENDDO
2695C
2696C------Rigid bodies-------
2697 DO i=nrb_fr,1,-1
2698 m=ifrsr(1,i)
2699 DO j = 1 , ndof(m)
2700 nd = iddmr(j,i)
2701 IF (j<=3.AND.nd>0) THEN
2702 d(j,m)=lx(nd)
2703 ELSEIF (nd>0) THEN
2704 dr(j-3,m)=lx(nd)
2705 ENDIF
2706 ENDDO
2707 ns=ifrsr(2,i)
2708 CALL rby_imp3(x ,m ,ns ,d ,dr ,
2709 . a ,ar )
2710 ENDDO
2711C--------RBE3-----
2712 iads=1
2713 DO i=1,nrbe3_fr
2714 n=ifrs3(i)
2715 iad=irbe3(1,n)
2716 ns=irbe3(3,n)
2717 nnod=irbe3(5,n)
2718 irot=irbe3(6,n)
2719 DO m=1,nnod
2720 nj=lrbe3(iad+m)
2721 DO j=1,ndof(nj)
2722 nd = iddmi3(j,m,i)
2723 IF (j<=3.AND.nd>0) THEN
2724 d(j,nj)=lx(nd)
2725 a(j,nj)=zero
2726 ELSEIF(nd>0) THEN
2727 dr(j-3,nj)=lx(nd)
2728 ar(j-3,nj)=zero
2729 ENDIF
2730 ENDDO
2731 ENDDO
2732 CALL prerbe3fr(irbe3 ,n ,jt ,jr )
2733 CALL rbe3_frd(nnod ,lrbe3(iad+1),ns ,d ,dr ,
2734 1 frcdi(iads),mrcdi(iads),jt ,jr ,irot )
2735 iads=iads+nnod
2736 ENDDO
2737C------Rbe2------
2738 DO i=nrbe2_fr,1,-1
2739 n=ifrs4(1,i)
2740 m=irbe2(3,n)
2741 DO j = 1 , ndof(m)
2742 nd = iddmr2(j,i)
2743 IF (j<=3.AND.nd>0) THEN
2744 d(j,m)=lx(nd)
2745 a(j,m)=zero
2746 ELSEIF (nd>0) THEN
2747 dr(j-3,m)=lx(nd)
2748 ar(j-3,m)=zero
2749 ENDIF
2750 ENDDO
2751 ns=ifrs4(2,i)
2752 isk = irbe2(7,n)
2753 irad =irbe2(11,n)
2754 ic = irbe2(4,n)
2755C--------remove ICR---
2756 ic =(ic/512)*512
2757 CALL prerbe2fr(ic ,jt ,jr )
2758 CALL rbe2_frd(ns ,m ,x ,d ,dr ,
2759 1 jt ,jr ,skew(1,isk),isk ,irad )
2760 a(1,ns)=zero
2761 a(2,ns)=zero
2762 a(3,ns)=zero
2763 ENDDO
2764C------int2-------
2765 DO i=ni2_fr,1,-1
2766 n=ifrs2(1,i)
2767 ni=ifrs2(2,i)
2768 ji=ipari(1,n)
2769 nsn=ipari(5,n)
2770 l=intbuf_tab(n)%IRTLM(ni)
2771 nl=4*(l-1)
2772 IF (intbuf_tab(n)%IRECTM(nl+3)==intbuf_tab(n)%IRECTM(nl+4)) THEN
2773 nnod=3
2774 ELSE
2775 nnod=4
2776 ENDIF
2777C-------if main node is also dependent-----
2778 DO m=1,nnod
2779 nj=intbuf_tab(n)%IRECTM(nl+m)
2780 DO j=1,ndof(nj)
2781 nd = iddmi2(j,m,i)
2782 IF (j<=3.AND.nd>0) THEN
2783 d(j,nj)=lx(nd)
2784 a(j,nj)=zero
2785 ELSEIF(nd>0) THEN
2786 dr(j-3,nj)=lx(nd)
2787 ar(j-3,nj)=zero
2788 ENDIF
2789 ENDDO
2790 ENDDO
2791 ilev =ipari(20,n)
2792 IF (ilev==1) THEN
2793 CALL i2_frrd1(x ,intbuf_tab(n)%IRECTM,intbuf_tab(n)%DPARA ,intbuf_tab(n)%NSV ,
2794 1 intbuf_tab(n)%IRTLM ,d ,ni )
2795 ELSE
2796 CALL i2_frrd0(x ,intbuf_tab(n)%IRECTM,intbuf_tab(n)%CSTS ,intbuf_tab(n)%NSV ,
2797 1 intbuf_tab(n)%IRTLM ,d ,dr ,ni ,ndof )
2798 ENDIF
2799 ENDDO
2800C
2801 RETURN
2802 END
2803!||====================================================================
2804!|| upd_fr ../engine/source/mpi/implicit/imp_fri.F
2805!||--- called by ------------------------------------------------------
2806!|| fr_matv ../engine/source/mpi/implicit/imp_fri.F
2807!||--- calls -----------------------------------------------------
2808!|| bc_fi ../engine/source/constraints/general/bcs/bc_imp0.F
2809!|| bc_fi2 ../engine/source/constraints/general/bcs/bc_imp0.F
2810!|| bc_updf ../engine/source/constraints/general/bcs/bc_imp0.F
2811!|| fv_updf ../engine/source/constraints/general/impvel/fv_imp0.F
2812!|| i2_frfm0 ../engine/source/interfaces/interf/i2_imp1.F
2813!|| i2_frfm1 ../engine/source/interfaces/interf/i2_imp1.F
2814!|| kin_updf ../engine/source/constraints/general/impvel/fv_imp0.F
2815!|| l_dir ../engine/source/constraints/general/bcs/bc_imp0.F
2816!|| prerbe2fr ../engine/source/constraints/general/rbe2/rbe2f.F
2817!|| prerbe3fr ../engine/source/constraints/general/rbe3/rbe3f.F
2818!|| rbe2frf ../engine/source/constraints/general/rbe2/rbe2f.F
2819!|| rbe3frf ../engine/source/constraints/general/rbe3/rbe3f.F
2820!|| rby_impf ../engine/source/constraints/general/rbody/rby_imp0.F
2821!||--- uses -----------------------------------------------------
2822!|| imp_aspc ../engine/share/modules/impbufdef_mod.F
2823!|| imp_intm ../engine/share/modules/imp_intm.F
2824!|| imp_rwl ../engine/share/modules/impbufdef_mod.F
2825!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
2826!||====================================================================
2827 SUBROUTINE upd_fr( A ,AR ,X ,IPARI ,INTBUF_TAB,
2828 1 NDOF ,IBFV ,SKEW ,XFRAME ,
2829 2 IRBE3 ,LRBE3 ,IRBE2 ,LRBE2 )
2830C-----------------------------------------------
2831C M o d u l e s
2832C-----------------------------------------------
2833 USE imp_intm
2834 USE imp_rwl
2835 USE imp_aspc
2836 USE intbufdef_mod
2837C-----------------------------------------------
2838C I m p l i c i t T y p e s
2839C-----------------------------------------------
2840#include "implicit_f.inc"
2841C-----------------------------------------------
2842C C o m m o n B l o c k s
2843C-----------------------------------------------
2844#include "param_c.inc"
2845C-----------------------------------------------
2846C D u m m y A r g u m e n t s
2847C-----------------------------------------------
2848 INTEGER IRBE3(NRBE3L,*),LRBE3(*),IRBE2(NRBE2L,*),LRBE2(*),
2849 . IPARI(NPARI,*), NDOF(*),IBFV(NIFV,*)
2850 my_real
2851 . a(3,*),ar(3,*),x(3,*) ,skew(lskew,*),xframe(nxframe,*)
2852 TYPE(intbuf_struct_) INTBUF_TAB(*)
2853C-----------------------------------------------
2854C L o c a l V a r i a b l e s
2855C-----------------------------------------------
2856 INTEGER I,J,N,M,NS,NI,NSN,ILEV,I1,IADS,IROT,IAD,NNOD,ISK,IRAD,
2857 . ji,jt(3),jr(3),nn,ic
2858 my_real
2859 . ej(3)
2860C------int2-------
2861 DO i=1,ni2_fr
2862 n=ifrs2(1,i)
2863 ji=ipari(1,n)
2864 nsn=ipari(5,n)
2865 ni=ifrs2(2,i)
2866 ilev =ipari(20,n)
2867 IF (ilev==1) THEN
2868 CALL i2_frfm1(x ,intbuf_tab(n)%IRECTM,intbuf_tab(n)%DPARA ,intbuf_tab(n)%NSV ,
2869 1 intbuf_tab(n)%IRTLM ,a ,ni )
2870 ELSE
2871 CALL i2_frfm0(x ,intbuf_tab(n)%IRECTM,intbuf_tab(n)%CSTS ,intbuf_tab(n)%NSV ,
2872 1 intbuf_tab(n)%IRTLM ,a ,ar ,ni ,ndof )
2873 ENDIF
2874 ENDDO
2875C------RBE2-------
2876 DO i=1,nrbe2_fr
2877 n=ifrs4(1,i)
2878 m=irbe2(3,n)
2879 ns=ifrs4(2,i)
2880 isk = irbe2(7,n)
2881 irad =irbe2(11,n)
2882 ic = irbe2(4,n)
2883C--------remove ICR---
2884 ic =(ic/512)*512
2885 CALL prerbe2fr(ic ,jt ,jr )
2886 CALL rbe2frf(ns ,m ,a ,ar ,jt ,
2887 1 jr ,x ,isk ,skew(1,isk),irad )
2888 ENDDO
2889C--------RBE3-----
2890 iads=1
2891 DO i=1,nrbe3_fr
2892 n=ifrs3(i)
2893 iad=irbe3(1,n)
2894 ns=irbe3(3,n)
2895 nnod=irbe3(5,n)
2896 irot=irbe3(6,n)
2897 CALL prerbe3fr(irbe3 ,n ,jt ,jr )
2898 CALL rbe3frf(nnod ,lrbe3(iad+1),ns ,a ,ar ,
2899 1 frcdi(iads),mrcdi(iads),jt ,jr ,irot )
2900 iads=iads+nnod
2901 ENDDO
2902C------Rigid bodies-------
2903 DO i=1,nrb_fr
2904 m=ifrsr(1,i)
2905 ns=ifrsr(2,i)
2906 CALL rby_impf(x ,m ,ns ,ndof ,a ,
2907 . ar )
2908 ENDDO
2909 IF (nbc_fr>0) THEN
2910 CALL bc_updf(nbc_fr ,ibc_fr ,skew ,a )
2911 ENDIF
2912 DO i1=1,nspc_fr
2913 n = ispc_fr(i1)
2914 i = in_spc(n)
2915 iad = 6*(n-1)+1
2916 nn = ic_spc(n)
2917 IF (nn==1) THEN
2918 ej(1)=skew_spc(iad)
2919 ej(2)=skew_spc(iad+1)
2920 ej(3)=skew_spc(iad+2)
2921 CALL l_dir(ej,j)
2922 CALL bc_fi(i ,skew_spc(iad),j ,a )
2923 ELSEIF (nn==2) THEN
2924 CALL bc_fi2(i ,skew_spc(iad),skew_spc(iad+3),a )
2925 END IF
2926 ENDDO
2927C
2928 IF (nfx_fr>0) THEN
2929 CALL fv_updf(nfx_fr ,ifx_fr ,ibfv ,skew ,xframe,
2930 1 a )
2931 ENDIF
2932 DO i1 = 1,nrw_fr
2933 i = irw_fr(i1)
2934 n = in_rwl(i)
2935 ej(1)=nor_rwl(1,i)
2936 ej(2)=nor_rwl(2,i)
2937 ej(3)=nor_rwl(3,i)
2938 CALL l_dir(ej,j)
2939 CALL kin_updf(n ,ej ,j ,a )
2940 ENDDO
2941C
2942 RETURN
2943 END
2944!||====================================================================
2945!|| fr_a2b ../engine/source/mpi/implicit/imp_fri.F
2946!||--- called by ------------------------------------------------------
2947!|| fr_matv ../engine/source/mpi/implicit/imp_fri.F
2948!||--- uses -----------------------------------------------------
2949!|| imp_intm ../engine/share/modules/imp_intm.F
2950!||====================================================================
2951 SUBROUTINE fr_a2b(NDOF ,LB ,A ,NSL )
2952C-----------------------------------------------
2953C M o d u l e s
2954C-----------------------------------------------
2955 USE imp_intm
2956C-----------------------------------------------
2957C I m p l i c i t T y p e s
2958C-----------------------------------------------
2959#include "implicit_f.inc"
2960C-----------------------------------------------
2961C D u m m y A r g u m e n t s
2962C-----------------------------------------------
2963 INTEGER NDOF(*),NSL
2964 my_real
2965 . a(3,*),lb(*)
2966C----------------------------------------------
2967C L o c a l V a r i a b l e s
2968C-----------------------------------------------
2969 INTEGER I,J,K,ID,ND,M,N
2970C---------
2971 DO i = 1,nsl
2972 n=islm(i)
2973 IF (n>0) THEN
2974 DO j=1,min(3,ndof(n))
2975 nd = iddsl(j,i)
2976 IF (nd>0) lb(nd)=lb(nd)+a(j,n)
2977 ENDDO
2978 ENDIF
2979 ENDDO
2980 DO i = 1,nml
2981 n=iml(i)
2982 DO j=1,min(3,ndof(n))
2983 nd = iddml(j,i)
2984 IF (nd>0) lb(nd)=lb(nd)+a(j,n)
2985 ENDDO
2986 ENDDO
2987C
2988 RETURN
2989 END
2990!||====================================================================
2991!|| fr_a2bd ../engine/source/mpi/implicit/imp_fri.F
2992!||--- called by ------------------------------------------------------
2993!|| fr_matv ../engine/source/mpi/implicit/imp_fri.F
2994!||--- uses -----------------------------------------------------
2995!|| imp_intm ../engine/share/modules/imp_intm.F
2996!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
2997!||====================================================================
2998 SUBROUTINE fr_a2bd(NDOF ,IPARI ,INTBUF_TAB ,LB ,A ,
2999 . AR ,IRBE3 ,LRBE3 ,IRBE2 ,LRBE2 )
3000C-----------------------------------------------
3001C M o d u l e s
3002C-----------------------------------------------
3003 USE imp_intm
3004 USE intbufdef_mod
3005C-----------------------------------------------
3006C I m p l i c i t T y p e s
3007C-----------------------------------------------
3008#include "implicit_f.inc"
3009C-----------------------------------------------
3010C C o m m o n B l o c k s
3011C-----------------------------------------------
3012#include "param_c.inc"
3013C-----------------------------------------------
3014C D u m m y A r g u m e n t s
3015C-----------------------------------------------
3016 INTEGER NDOF(*),IPARI(NPARI,*),
3017 . IRBE3(NRBE3L,*),LRBE3(*) ,IRBE2(NRBE2L,*),LRBE2(*)
3018 my_real
3019 . a(3,*),ar(3,*),lb(*)
3020 TYPE(intbuf_struct_) INTBUF_TAB(*)
3021C----------------------------------------------
3022C L o c a l V a r i a b l e s
3023C-----------------------------------------------
3024 INTEGER I,J,N,M,NS,NI,NSN,
3025 . l,nnod,nj,nd,nl,iad,ji
3026C------------------------------------
3027C------Rigid bodies-------
3028 DO i=1,nrb_fr
3029 m=ifrsr(1,i)
3030 DO j=1,ndof(m)
3031 nd = iddmr(j,i)
3032 IF (j<=3.AND.nd>0) THEN
3033 lb(nd)=lb(nd)+a(j,m)
3034 a(j,m)=zero
3035 ELSEIF(nd>0) THEN
3036 lb(nd)=lb(nd)+ar(j-3,m)
3037 ar(j-3,m)=zero
3038 ENDIF
3039 ENDDO
3040 ENDDO
3041C------int2-------
3042 DO i=1,ni2_fr
3043 n=ifrs2(1,i)
3044 ni=ifrs2(2,i)
3045 ji=ipari(1,n)
3046 nsn=ipari(5,n)
3047 l=intbuf_tab(n)%IRTLM(ni)
3048 nl=4*(l-1)
3049 IF (intbuf_tab(n)%IRECTM(nl+3)==intbuf_tab(n)%IRECTM(nl+4)) THEN
3050 nnod=3
3051 ELSE
3052 nnod=4
3053 ENDIF
3054C-------if main node is also dependent-----
3055 DO m=1,nnod
3056 nj=intbuf_tab(n)%IRECTM(nl+m)
3057 DO j=1,ndof(nj)
3058 nd = iddmi2(j,m,i)
3059 IF (j<=3.AND.nd>0) THEN
3060 lb(nd)=lb(nd)+a(j,nj)
3061 a(j,nj)=zero
3062 ELSEIF(nd>0) THEN
3063 lb(nd)=lb(nd)+ar(j-3,nj)
3064 ar(j-3,nj)=zero
3065 ENDIF
3066 ENDDO
3067 ENDDO
3068 ENDDO
3069C--------RBE3-----
3070 DO i=1,nrbe3_fr
3071 n=ifrs3(i)
3072 iad=irbe3(1,n)
3073 nnod=irbe3(5,n)
3074 DO m=1,nnod
3075 nj=lrbe3(iad+m)
3076 DO j=1,ndof(nj)
3077 nd = iddmi3(j,m,i)
3078 IF (j<=3.AND.nd>0) THEN
3079 lb(nd)=lb(nd)+a(j,nj)
3080 a(j,nj)=zero
3081 ELSEIF(nd>0) THEN
3082 lb(nd)=lb(nd)+ar(j-3,nj)
3083 ar(j-3,nj)=zero
3084 ENDIF
3085 ENDDO
3086 ENDDO
3087 ENDDO
3088C------RBE2-------
3089 DO i=1,nrbe2_fr
3090 n=ifrs4(1,i)
3091 m=irbe2(3,n)
3092 DO j=1,ndof(m)
3093 nd = iddmr2(j,i)
3094 IF (j<=3.AND.nd>0) THEN
3095 lb(nd)=lb(nd)+a(j,m)
3096 a(j,m)=zero
3097 ELSEIF(nd>0) THEN
3098 lb(nd)=lb(nd)+ar(j-3,m)
3099 ar(j-3,m)=zero
3100 ENDIF
3101 ENDDO
3102 ENDDO
3103C
3104 RETURN
3105 END
3106!||====================================================================
3107!|| dim_nrmax ../engine/source/mpi/implicit/imp_fri.F
3108!||--- called by ------------------------------------------------------
3109!|| dim_glob_k ../engine/source/implicit/ind_glob_k.F
3110!||--- uses -----------------------------------------------------
3111!|| imp_frk ../engine/share/modules/impbufdef_mod.F
3112!||====================================================================
3113 SUBROUTINE dim_nrmax(NROW ,FR_ELEM ,IAD_ELEM,NNMAX )
3114C-----------------------------------------------
3115C M o d u l e s
3116C-----------------------------------------------
3117 USE imp_frk
3118C-----------------------------------------------
3119C I m p l i c i t T y p e s
3120C-----------------------------------------------
3121#include "implicit_f.inc"
3122C-----------------------------------------------
3123C C o m m o n B l o c k s
3124C-----------------------------------------------
3125#include "com01_c.inc"
3126C-----------------------------------------------
3127C D u m m y A r g u m e n t s
3128C-----------------------------------------------
3129 INTEGER NROW(*),IAD_ELEM(2,*),FR_ELEM(*),NNMAX
3130C----------------------------------------------
3131C L o c a l V a r i a b l e s
3132C-----------------------------------------------
3133 INTEGER I,J,N,NR
3134C------------------------------------
3135 IF (n_frnn==0) RETURN
3136C
3137 DO i =1,nspmd
3138 DO j=iad_elem(1,i),iad_elem(1,i+1)-1
3139 nr=iad_rl(j+1)-iad_rl(j)
3140 IF (nr>0)THEN
3141 n = fr_elem(j)
3142 nrow(n)=nrow(n)+nr
3143 nnmax = max(nnmax,nrow(n))
3144 ENDIF
3145 ENDDO
3146 ENDDO
3147C
3148 RETURN
3149 END
3150!||====================================================================
3151!|| kin_nrmax0 ../engine/source/mpi/implicit/imp_fri.F
3152!||--- called by ------------------------------------------------------
3153!|| dim_kinmax ../engine/source/implicit/ind_glob_k.F
3154!||--- calls -----------------------------------------------------
3155!|| reorder_a ../engine/source/implicit/ind_glob_k.F
3156!||--- uses -----------------------------------------------------
3157!|| imp_frk ../engine/share/modules/impbufdef_mod.F
3158!||====================================================================
3159 SUBROUTINE kin_nrmax0(
3160 1 NNMAX ,NKMAX ,NROWK ,ICOK ,ICOKM ,
3161 2 ILOC ,INK ,FR_ELEM ,IAD_ELEM )
3162C-----------------------------------------------
3163C M o d u l e s
3164C-----------------------------------------------
3165 USE imp_frk
3166C-----------------------------------------------
3167C I m p l i c i t T y p e s
3168C-----------------------------------------------
3169#include "implicit_f.inc"
3170C-----------------------------------------------
3171C C o m m o n B l o c k s
3172C-----------------------------------------------
3173#include "com01_c.inc"
3174C-----------------------------------------------
3175C D u m m y A r g u m e n t s
3176C-----------------------------------------------
3177 INTEGER NNMAX,NKMAX,NROWK(*),ILOC(*),INK
3178 INTEGER ICOK(NNMAX,*),ICOKM(NKMAX,*),IAD_ELEM(2,*),FR_ELEM(*)
3179C----------------------------------------------
3180C L o c a l V a r i a b l e s
3181C-----------------------------------------------
3182 INTEGER I,J,N,NL,NR,K,NN
3183C------------------------------------
3184 IF (N_FRNN==0) return
3185C
3186 DO i =1,nspmd
3187 DO j=iad_elem(1,i),iad_elem(1,i+1)-1
3188 n = fr_elem(j)
3189 nn = iloc(n)
3190 IF (nn>ink)THEN
3191 DO k=iad_rl(j),iad_rl(j+1)-1
3192 nl = fr_icol(k)+iad_elem(1,i)-1
3193 CALL reorder_a(nrowk(nn),icok(1,nn),fr_elem(nl))
3194 ENDDO
3195 ELSEIF (nn>0)THEN
3196 DO k=iad_rl(j),iad_rl(j+1)-1
3197 nl = fr_icol(k)+iad_elem(1,i)-1
3198 CALL reorder_a(nrowk(nn),icokm(1,nn),fr_elem(nl))
3199 ENDDO
3200 ENDIF
3201 ENDDO
3202 ENDDO
3203C
3204 RETURN
3205 END
3206!||====================================================================
3207!|| kin_nrmax ../engine/source/mpi/implicit/imp_fri.F
3208!||--- called by ------------------------------------------------------
3209!|| dim_kinmax ../engine/source/implicit/ind_glob_k.F
3210!|| ind_glob_k ../engine/source/implicit/ind_glob_k.F
3211!||--- calls -----------------------------------------------------
3212!|| reorder_a ../engine/source/implicit/ind_glob_k.F
3213!||--- uses -----------------------------------------------------
3214!|| imp_frk ../engine/share/modules/impbufdef_mod.F
3215!||====================================================================
3216 SUBROUTINE kin_nrmax(
3217 1 NNMAX ,NKMAX ,NROWK ,ICOK ,ICOKM ,
3218 2 ILOC ,INK ,FR_ELEM ,IAD_ELEM )
3219C-----------------------------------------------
3220C M o d u l e s
3221C-----------------------------------------------
3222 USE imp_frk
3223C-----------------------------------------------
3224C I m p l i c i t T y p e s
3225C-----------------------------------------------
3226#include "implicit_f.inc"
3227C-----------------------------------------------
3228C C o m m o n B l o c k s
3229C-----------------------------------------------
3230#include "com01_c.inc"
3231C-----------------------------------------------
3232C D u m m y A r g u m e n t s
3233C-----------------------------------------------
3234 INTEGER NNMAX,NKMAX,NROWK(*),ILOC(*),INK
3235 INTEGER ICOK(NNMAX,*),ICOKM(NKMAX,*),IAD_ELEM(2,*),FR_ELEM(*)
3236C----------------------------------------------
3237C L o c a l V a r i a b l e s
3238C-----------------------------------------------
3239 INTEGER I,J,N,NL,NR,K,NK,NN
3240C------------------------------------
3241 IF (N_FRNN==0) return
3242C
3243 DO i =1,nspmd
3244 DO j=iad_elem(1,i),iad_elem(1,i+1)-1
3245 n = fr_elem(j)
3246 nn = iloc(n)
3247 IF (nn>ink)THEN
3248 nk=nn-ink
3249 DO k=iad_rl(j),iad_rl(j+1)-1
3250 nl = fr_icol(k)+iad_elem(1,i)-1
3251 CALL reorder_a(nrowk(nn),icokm(1,nk),fr_elem(nl))
3252 ENDDO
3253 ELSEIF (nn>0)THEN
3254 DO k=iad_rl(j),iad_rl(j+1)-1
3255 nl = fr_icol(k)+iad_elem(1,i)-1
3256 CALL reorder_a(nrowk(nn),icok(1,nn),fr_elem(nl))
3257 ENDDO
3258 ENDIF
3259 ENDDO
3260 ENDDO
3261C
3262 RETURN
3263 END
3264!||====================================================================
3265!|| ind_nrmax ../engine/source/mpi/implicit/imp_fri.F
3266!||--- called by ------------------------------------------------------
3267!|| ind_nrfr ../engine/source/mpi/implicit/imp_fri.F
3268!||--- calls -----------------------------------------------------
3269!|| reorder_a ../engine/source/implicit/ind_glob_k.F
3270!||====================================================================
3271 SUBROUTINE ind_nrmax(
3272 1 NFT ,NEL ,NPN ,NPPS ,NNMAX ,
3273 2 NROW ,ICOL ,IAD_RL ,FR_ICOL ,N_FRNN )
3274C-----------------------------------------------
3275C I m p l i c i t T y p e s
3276C-----------------------------------------------
3277#include "implicit_f.inc"
3278C-----------------------------------------------
3279C C o m m o n B l o c k s
3280C-----------------------------------------------
3281#include "com04_c.inc"
3282C-----------------------------------------------
3283C D u m m y A r g u m e n t s
3284C-----------------------------------------------
3285 INTEGER NNMAX,IAD_RL(*),FR_ICOL(*),N_FRNN
3286 INTEGER NFT,NEL,NPN,NPPS,NROW(*),ICOL(NNMAX,*)
3287C----------------------------------------------
3288C L o c a l V a r i a b l e s
3289C-----------------------------------------------
3290 INTEGER I,J,N,M,JLT,JLT1,NK,NFT1,ISH,L,NPP
3291C------------------------------------
3292 IF (N_FRNN==0) return
3293 jlt=nel+nft
3294 npp=numnod-npps
3295 IF (npn>nft) THEN
3296 jlt1 = min( nel, npn - nft )
3297 DO nk=1,jlt1
3298 j=nk+nft
3299 DO i=iad_rl(j),iad_rl(j+1)-1
3300 CALL reorder_a(nrow(nk),icol(1,nk),fr_icol(i))
3301 ENDDO
3302 ENDDO
3303 ENDIF
3304 IF (npp<jlt) THEN
3305 nft1 = max(nft,npp)+1
3306 ish= npp-npn
3307 DO n=nft1,jlt
3308 nk=n-nft
3309 j=n-ish
3310 DO i=iad_rl(j),iad_rl(j+1)-1
3311 CALL reorder_a(nrow(nk),icol(1,nk),fr_icol(i))
3312 ENDDO
3313 ENDDO
3314 ENDIF
3315C
3316 RETURN
3317 END
3318
3319!||====================================================================
3320!|| dim_fr_k ../engine/source/mpi/implicit/imp_fri.F
3321!||--- called by ------------------------------------------------------
3322!|| dim_glob_k ../engine/source/implicit/ind_glob_k.F
3323!||--- calls -----------------------------------------------------
3324!|| dim_elemsp ../engine/source/implicit/ind_glob_k.F
3325!|| intab ../engine/source/implicit/ind_glob_k.F
3326!|| reorder_a ../engine/source/implicit/ind_glob_k.F
3327!|| spmd_icol ../engine/source/mpi/implicit/imp_spmd.f
3328!|| spmd_nrow ../engine/source/mpi/implicit/imp_spmd.F
3329!||--- uses -----------------------------------------------------
3330!|| elbufdef_mod ../common_source/modules/mat_elem/elbufdef_mod.f90
3331!|| element_mod ../common_source/modules/elements/element_mod.F90
3332!|| imp_frk ../engine/share/modules/impbufdef_mod.F
3333!||====================================================================
3334 SUBROUTINE dim_fr_k(
3335 1 ELBUF ,IPARG ,IXS ,IXQ ,IXC ,
3336 2 IXT ,IXP ,IXR ,IXTG ,IXTG1 ,
3337 3 IXS10 ,IXS20 ,IXS16 ,NDOF ,
3338 4 NNMAX ,INLOC ,FR_ELEM ,IAD_ELEM ,N_FR ,
3339 5 IGEO ,FR_I2M ,IAD_I2M ,ELBUF_TAB )
3340C-----------------------------------------------
3341C M o d u l e s
3342C-----------------------------------------------
3343 USE imp_frk
3344 USE elbufdef_mod
3345 use element_mod , only : nixs,nixq,nixc,nixt,nixp,nixr,nixtg
3346C-----------------------------------------------
3347C I m p l i c i t T y p e s
3348C-----------------------------------------------
3349#include "implicit_f.inc"
3350C-----------------------------------------------
3351C C o m m o n B l o c k s
3352C-----------------------------------------------
3353#include "com01_c.inc"
3354#include "com04_c.inc"
3355#include "param_c.inc"
3356C-----------------------------------------------
3357C D u m m y A r g u m e n t s
3358C-----------------------------------------------
3359 INTEGER IPARG(NPARG,*),NNMAX,N_FR ,NDOF(*),IGEO(*),
3360 . fr_i2m(*),iad_i2m(*)
3361 integer
3362 . ixs(nixs,*),ixq(nixq,*),ixc(nixc,*), ixt(nixt,*),ixp(nixp,*),
3363 . ixr(nixr,*), ixtg(nixtg,*),ixs10(6,*),ixs20(12,*),
3364 . ixs16(8,*),ixtg1(4,*),inloc(*),fr_elem(*),iad_elem(2,*)
3365C REAL
3366 my_real
3367 . elbuf(*)
3368 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP) :: ELBUF_TAB
3369C-----------------------------------------------
3370C External function
3371C-----------------------------------------------
3372 LOGICAL INTAB
3373 EXTERNAL intab
3374C-----------------------------------------------
3375C L o c a l V a r i a b l e s
3376C-----------------------------------------------
3377 INTEGER I,J,N,NK,ICOL(NNMAX,N_FR),NROW(N_FR),IP,JLT,NFT,
3378 . fr_nrow(n_fr),l,iad_s(nspmd+1),iad_r(nspmd+1),nf1,
3379 . ierror1,ierror2,ierror3,ls,lr,ssize,rsize,j0,nn,nr,nl,nrn
3380C ---- creer NROW,ICOL aux front.---------
3381 IF (n_fr <=0 .OR. nnmax <=0 ) THEN
3382 nddlfr=0
3383 nddlfrb=0
3384 ndfrmax=0
3385 n_frnn=0
3386c RETURN
3387 ENDIF
3388 DO n =1,numnod
3389 inloc(n)=0
3390 ENDDO
3391 DO n =1,n_fr
3392 nrow(n)=0
3393 ENDDO
3394 DO ip =1,nspmd
3395 jlt=iad_elem(1,ip+1)-iad_elem(1,ip)
3396 nft=iad_elem(1,ip)-1
3397 nf1=min(n_fr,nft+1)
3398 DO j=1,jlt
3399 nk=j+nft
3400 n=fr_elem(nk)
3401 inloc(n) = j
3402 ENDDO
3403 CALL dim_elemsp(
3404 1 elbuf ,iparg ,ixs ,ixq ,ixc ,
3405 2 ixt ,ixp ,ixr ,ixtg ,ixtg1 ,
3406 3 ixs10 ,ixs20 ,ixs16 ,nrow(nf1),
3407 4 inloc ,nnmax ,icol(1,nf1),igeo ,elbuf_tab )
3408 DO j=1,jlt
3409 nk=j+nft
3410 n=fr_elem(nk)
3411 inloc(n) = 0
3412 ENDDO
3413 ENDDO
3414 CALL spmd_nrow(nrow,fr_nrow,iad_elem,n_fr)
3415C------ prepare comm .-----
3416 ls=1
3417 lr=1
3418 iad_s(1)=ls
3419 iad_r(1)=lr
3420 DO ip =1,nspmd
3421 DO nk=iad_elem(1,ip),iad_elem(1,ip+1)-1
3422 ls=ls+nrow(nk)
3423 lr=lr+fr_nrow(nk)
3424 ENDDO
3425 iad_s(ip+1)=ls
3426 iad_r(ip+1)=lr
3427 ENDDO
3428 IF ((ls+lr)>2) THEN
3429 ssize=iad_s(nspmd+1)-1
3430 rsize=iad_r(nspmd+1)-1
3431C
3432 CALL spmd_icol(
3433 1 iad_s ,iad_r ,nnmax ,icol ,nrow ,
3434 2 fr_nrow ,iad_elem ,fr_elem ,ssize ,rsize )
3435 ENDIF
3436C
3437 DO ip =1,nspmd
3438 nr=iad_i2m(ip+1)-iad_i2m(ip)
3439 IF (nr>0) THEN
3440 jlt=iad_elem(1,ip+1)-iad_elem(1,ip)
3441 nft=iad_elem(1,ip)-1
3442 DO j=1,jlt
3443 nk=j+nft
3444 n=fr_elem(nk)
3445 inloc(n) = j
3446 ENDDO
3447 DO nk=iad_elem(1,ip),iad_elem(1,ip+1)-1
3448 n=fr_elem(nk)
3449 IF (intab(nr,fr_i2m(iad_i2m(ip)),n)) THEN
3450 DO l=iad_i2m(ip),iad_i2m(ip+1)-1
3451 nn=fr_i2m(l)
3452 nl=inloc(nn)
3453 IF (nl>0.AND.nn/=n) THEN
3454 nrn = max(nrow(nk),fr_nrow(nk))
3455 CALL reorder_a(nrn,icol(1,nk),nl)
3456 IF (nrn>max(nrow(nk),fr_nrow(nk))) fr_nrow(nk)=nrn
3457 ENDIF
3458 ENDDO
3459 ENDIF
3460 ENDDO
3461C
3462 DO j=1,jlt
3463 nk=j+nft
3464 n=fr_elem(nk)
3465 inloc(n) = 0
3466 ENDDO
3467 ENDIF !IF (NR>0)
3468 ENDDO !IP =1,NSPMD
3469 nrmax = 0
3470 IF(ALLOCATED(iad_rl)) DEALLOCATE(iad_rl)
3471 ALLOCATE(iad_rl(n_fr+1),stat=ierror3)
3472 lr=1
3473 iad_rl(1)=lr
3474 DO ip =1,nspmd
3475 DO nk=iad_elem(1,ip),iad_elem(1,ip+1)-1
3476 IF (nrow(nk)<fr_nrow(nk)) THEN
3477 nr=fr_nrow(nk)-nrow(nk)
3478 lr=lr+nr
3479 nrmax = max(nrmax,nr)
3480 ENDIF
3481 iad_rl(nk+1)=lr
3482 ENDDO
3483 ENDDO
3484 n_frnn=lr-1
3485C------- First it is local ------------
3486 IF (n_frnn>0) THEN
3487 IF(ALLOCATED(fr_icol)) DEALLOCATE(fr_icol)
3488 ALLOCATE(fr_icol(lr),stat=ierror2)
3489 DO ip =1,nspmd
3490 DO nk=iad_elem(1,ip),iad_elem(1,ip+1)-1
3491 j0=nrow(nk)-iad_rl(nk)+1
3492 DO l=iad_rl(nk),iad_rl(nk+1)-1
3493 j=l+j0
3494 fr_icol(l)=icol(j,nk)
3495 ENDDO
3496 ENDDO
3497 ENDDO
3498 ENDIF
3499C------definit IFRLOC (global)for ind_glob_k---
3500 IF(ALLOCATED(ifrloc)) DEALLOCATE(ifrloc)
3501 ALLOCATE(ifrloc(n_fr),stat=ierror1)
3502 nn=0
3503 DO n =1,numnod
3504 inloc(n)=0
3505 ENDDO
3506 DO ip =1,nspmd
3507 DO nk=iad_elem(1,ip),iad_elem(1,ip+1)-1
3508 n=fr_elem(nk)
3509 IF (inloc(n)==0) THEN
3510 nn = nn +1
3511 inloc(n)=nn
3512 ifrloc(nk)=nn
3513 icol(1,nn)=nk
3514 ELSE
3515 ifrloc(nk)=-icol(1,inloc(n))
3516 IF (nrow(nk)<fr_nrow(nk))nrmax=nrmax+fr_nrow(nk)-nrow(nk)
3517 ENDIF
3518 ENDDO
3519 ENDDO
3520C
3521 RETURN
3522 END
3523!||====================================================================
3524!|| ind_fr_k ../engine/source/mpi/implicit/imp_fri.F
3525!||--- called by ------------------------------------------------------
3526!|| ind_glob_k ../engine/source/implicit/ind_glob_k.F
3527!||--- calls -----------------------------------------------------
3528!|| dim_elemsp ../engine/source/implicit/ind_glob_k.F
3529!|| ind_fr_k0 ../engine/source/mpi/implicit/imp_fri.F
3530!|| reorder_a ../engine/source/implicit/ind_glob_k.F
3531!||--- uses -----------------------------------------------------
3532!|| elbufdef_mod ../common_source/modules/mat_elem/elbufdef_mod.F90
3533!|| element_mod ../common_source/modules/elements/element_mod.F90
3534!|| imp_frk ../engine/share/modules/impbufdef_mod.F
3535!||====================================================================
3536 SUBROUTINE ind_fr_k(
3537 1 ELBUF ,IPARG ,IXS ,IXQ ,IXC ,
3538 2 IXT ,IXP ,IXR ,IXTG ,IXTG1 ,
3539 3 IXS10 ,IXS20 ,IXS16 ,NDOF ,
3540 4 NNMAX ,INLOC ,FR_ELEM ,IAD_ELEM ,N_FR ,
3541 5 IGEO ,ELBUF_TAB )
3542C-----------------------------------------------
3543C M o d u l e s
3544C-----------------------------------------------
3545 USE imp_frk
3546 USE elbufdef_mod
3547 use element_mod , only : nixs,nixq,nixc,nixt,nixp,nixr,nixtg
3548C-----------------------------------------------
3549C I m p l i c i t T y p e s
3550C-----------------------------------------------
3551#include "implicit_f.inc"
3552C-----------------------------------------------
3553C C o m m o n B l o c k s
3554C-----------------------------------------------
3555#include "com01_c.inc"
3556#include "com04_c.inc"
3557#include "param_c.inc"
3558C-----------------------------------------------
3559C D u m m y A r g u m e n t s
3560C-----------------------------------------------
3561 INTEGER IPARG(NPARG,*),NNMAX,N_FR ,NDOF(*),IGEO(*)
3562 integer
3563 . ixs(nixs,*),ixq(nixq,*),ixc(nixc,*), ixt(nixt,*),ixp(nixp,*),
3564 . ixr(nixr,*), ixtg(nixtg,*),ixs10(6,*),ixs20(12,*),
3565 . ixs16(8,*),ixtg1(4,*),inloc(*),fr_elem(*),iad_elem(2,*)
3566C REAL
3567 my_real
3568 . elbuf(*)
3569 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP) :: ELBUF_TAB
3570C-----------------------------------------------
3571C L o c a l V a r i a b l e s
3572C-----------------------------------------------
3573 INTEGER I,J,N,NK,ICOL(NNMAX,N_FR),NROW(N_FR),IP,JLT,NFT,
3574 . ierror1,ierror2,ierror3,ls,lr,ssize,rsize,j0,l,nf1
3575C ---- creer NROW,ICOL aux front.---------
3576 IF (n_fr>0) THEN
3577 DO n =1,numnod
3578 inloc(n)=0
3579 ENDDO
3580 DO n =1,n_fr
3581 nrow(n)=0
3582 ENDDO
3583 DO ip =1,nspmd
3584 jlt=iad_elem(1,ip+1)-iad_elem(1,ip)
3585 nft=iad_elem(1,ip)-1
3586 nf1=min(n_fr,nft+1)
3587 DO j=1,jlt
3588 nk=j+nft
3589 n=fr_elem(nk)
3590 inloc(n) = j
3591 ENDDO
3592 CALL dim_elemsp(
3593 1 elbuf ,iparg ,ixs ,ixq ,ixc ,
3594 2 ixt ,ixp ,ixr ,ixtg ,ixtg1 ,
3595 3 ixs10 ,ixs20 ,ixs16 ,nrow(nf1),
3596 4 inloc ,nnmax ,icol(1,nf1),igeo ,elbuf_tab )
3597 DO j=1,jlt
3598 nk=j+nft
3599 n=fr_elem(nk)
3600 inloc(n) = 0
3601 ENDDO
3602 ENDDO
3603C--------recupere fr_nrow --
3604 IF (n_frnn>0) THEN
3605 DO ip =1,nspmd
3606 DO nk=iad_elem(1,ip),iad_elem(1,ip+1)-1
3607 DO l=iad_rl(nk),iad_rl(nk+1)-1
3608 CALL reorder_a(nrow(nk),icol(1,nk),fr_icol(l))
3609 ENDDO
3610 ENDDO
3611 ENDDO
3612 ENDIF
3613 ENDIF ! (N_FR>0)
3614C------ind_ [k] of FR.------
3615 CALL ind_fr_k0(
3616 1 ndof ,nrow ,nnmax ,icol ,fr_elem ,
3617 2 iad_elem ,n_fr )
3618C
3619 RETURN
3620 END
3621!||====================================================================
3622!|| ind_nrfr ../engine/source/mpi/implicit/imp_fri.F
3623!||--- called by ------------------------------------------------------
3624!|| ind_glob_k ../engine/source/implicit/ind_glob_k.F
3625!||--- calls -----------------------------------------------------
3626!|| ind_nrmax ../engine/source/mpi/implicit/imp_fri.F
3627!|| reorder_a ../engine/source/implicit/ind_glob_k.F
3628!||--- uses -----------------------------------------------------
3629!|| imp_frk ../engine/share/modules/impbufdef_mod.F
3630!||====================================================================
3631 SUBROUTINE ind_nrfr(
3632 1 NFT ,NEL ,NPN ,NPP ,NNMAX ,
3633 2 NROW ,ICOL ,FR_ELEM ,IAD_ELEM ,N_FR ,
3634 3 ICOK )
3635C-----------------------------------------------
3636C M o d u l e s
3637C-----------------------------------------------
3638 USE imp_frk
3639C-----------------------------------------------
3640C I m p l i c i t T y p e s
3641C-----------------------------------------------
3642#include "implicit_f.inc"
3643C-----------------------------------------------
3644C C o m m o n B l o c k s
3645C-----------------------------------------------
3646#include "com01_c.inc"
3647C-----------------------------------------------
3648C D u m m y A r g u m e n t s
3649C-----------------------------------------------
3650 INTEGER NNMAX,NFT,NEL,NPN,NPP,NROW(*),ICOL(NNMAX,*)
3651 integer
3652 . fr_elem(*),iad_elem(2,*),n_fr,icok(nrmax,n_fr)
3653C REAL
3654C-----------------------------------------------
3655C L o c a l V a r i a b l e s
3656C-----------------------------------------------
3657 INTEGER I,J,N,NK,NROWK(N_FR),IP,
3658 . l,iad_r(n_fr+1),fr_icol1(n_frnn+1),lr,j0,nn,n_frn
3659C------- Recipation fr_nrow and goes through global (by rap)-
3660 IF (nnmax <=0 ) RETURN
3661 DO ip =1,nspmd
3662 DO nk=iad_elem(1,ip),iad_elem(1,ip+1)-1
3663 nrowk(nk)=iad_rl(nk+1)-iad_rl(nk)
3664 j0 = iad_elem(1,ip)-1
3665 DO l=iad_rl(nk),iad_rl(nk+1)-1
3666 j=l-iad_rl(nk)+1
3667 n= fr_icol(l)+j0
3668 icok(j,nk)=fr_elem(n)
3669 ENDDO
3670 ENDDO
3671 ENDDO
3672C----accumulate in case nodes belong to multiple interfaces--
3673 DO ip =1,nspmd
3674 DO nk=iad_elem(1,ip),iad_elem(1,ip+1)-1
3675 n = -ifrloc(nk)
3676 IF (n>0) THEN
3677 DO j=1,nrowk(nk)
3678 CALL reorder_a(nrowk(n),icok(1,n),icok(j,nk))
3679 ENDDO
3680 ENDIF
3681 ENDDO
3682 ENDDO
3683C------dim de IAD_R->NN+1--
3684 lr=1
3685 iad_r(1)=lr
3686 DO ip =1,nspmd
3687 DO nk=iad_elem(1,ip),iad_elem(1,ip+1)-1
3688 n = ifrloc(nk)
3689 IF (n>0) THEN
3690 lr=lr+nrowk(nk)
3691 iad_r(n+1)=lr
3692 ENDIF
3693 ENDDO
3694 ENDDO
3695 n_frn=lr-1
3696 if (n_frn>n_frnn) print *,'PROBLEM IN IND_NRFR'
3697 IF (n_frn>0) THEN
3698 DO ip =1,nspmd
3699 DO nk=iad_elem(1,ip),iad_elem(1,ip+1)-1
3700 n = ifrloc(nk)
3701 IF (n>0) THEN
3702 DO j=1,nrowk(nk)
3703 l=iad_r(n)+j-1
3704 fr_icol1(l)=icok(j,nk)
3705 ENDDO
3706 ENDIF
3707 ENDDO
3708 ENDDO
3709 ENDIF
3710C
3711 CALL ind_nrmax(
3712 1 nft ,nel ,npn ,npp ,nnmax ,
3713 2 nrow ,icol ,iad_r ,fr_icol1 ,n_frnn )
3714
3715C
3716 RETURN
3717 END
3718!||====================================================================
3719!|| ind_fr_k0 ../engine/source/mpi/implicit/imp_fri.F
3720!||--- called by ------------------------------------------------------
3721!|| ind_fr_k ../engine/source/mpi/implicit/imp_fri.F
3722!||--- calls -----------------------------------------------------
3723!|| reorder_l ../engine/source/implicit/ind_glob_k.F
3724!|| spmd_sum_s ../engine/source/mpi/implicit/imp_spmd.f
3725!||--- uses -----------------------------------------------------
3726!|| imp_frk ../engine/share/modules/impbufdef_mod.F
3727!||====================================================================
3728 SUBROUTINE ind_fr_k0(
3729 1 NDOF ,NROW ,NNMAX ,ICOL ,FR_ELEM ,
3730 2 IAD_ELEM ,N_FR )
3731C-----------------------------------------------
3732C M o d u l e s
3733C-----------------------------------------------
3734 USE imp_frk
3735C-----------------------------------------------
3736C I m p l i c i t T y p e s
3737C-----------------------------------------------
3738#include "implicit_f.inc"
3739C-----------------------------------------------
3740C C o m m o n B l o c k s
3741C-----------------------------------------------
3742#include "com01_c.inc"
3743#include "impl1_c.inc"
3744C-----------------------------------------------
3745C D u m m y A r g u m e n t s
3746C-----------------------------------------------
3747 INTEGER NNMAX,N_FR ,NDOF(*),NROW(*)
3748 integer
3749 . fr_elem(*),iad_elem(2,*),icol(nnmax,*)
3750C REAL
3751C-----------------------------------------------
3752C L o c a l V a r i a b l e s
3753C-----------------------------------------------
3754 INTEGER I,J,N,NK,IP,L,NDDL0,NZZK0,NN,IAD,NB,
3755 . nnz(nspmd),ndofj,k,nddl,nzzk,nj,nk0,njn,nl,nzz,
3756 . ierror0,ierror1,ierror2,ierror3,ierror4,ierror5
3757 INTEGER, DIMENSION(:),ALLOCATABLE :: ITAG
3758 my_real
3759 . s1,stmp
3760C------ Sun [K] for each fr .-----
3761 IF (iroddl==0) THEN
3762 ndofj=3
3763 ELSE
3764 ndofj=6
3765 ENDIF
3766 nddlfr=0
3767 nddlfrb=0
3768 ndfrmax=0
3769 nzzk=0
3770 IF(ALLOCATED(nd_fr)) DEALLOCATE(nd_fr)
3771 ALLOCATE(nd_fr(nspmd),stat=ierror0)
3772 DO ip =1,nspmd
3773 nd_fr(ip)=0
3774 nnz(ip)=0
3775 DO nk=iad_elem(1,ip),iad_elem(1,ip+1)-1
3776 n=fr_elem(nk)
3777 nd_fr(ip)=nd_fr(ip)+ndof(n)
3778 DO k=1,ndof(n)
3779C-------termes knn-------
3780 DO j=1,ndof(n)
3781 IF (j/=k) nnz(ip) = nnz(ip)+1
3782 ENDDO
3783C-------termes kn,nj-------
3784 DO j=1,nrow(nk)
3785 DO l=1,ndofj
3786 nnz(ip) = nnz(ip)+1
3787 ENDDO
3788 ENDDO
3789 ENDDO
3790 ENDDO
3791 nddlfr = nddlfr + nd_fr(ip)
3792 ndfrmax=max(ndfrmax,nd_fr(ip))
3793 nzzk = nzzk + nnz(ip)
3794 ENDDO
3795 nzzk = nzzk/2+1
3796 stmp = zero
3797 IF (nddlfr>0) THEN
3798 ALLOCATE(itag(n_fr))
3799 itag = 2
3800 DO nk=1,n_fr
3801 nb=-ifrloc(nk)
3802 IF (nb>0) itag(nb) = itag(nb) + 1
3803 ENDDO
3804 DO nk=1,n_fr
3805 nb=-ifrloc(nk)
3806 IF (nb<0) nb = nk
3807 s1 = one/itag(nb)
3808 stmp = stmp + s1*ndof(fr_elem(nb))
3809 ENDDO
3810 DEALLOCATE(itag)
3811 ENDIF
3812 CALL spmd_sum_s(stmp)
3813 nddlfrb = int(stmp)
3814 IF (nddlfr==0) RETURN
3815C
3816 nddl = nddlfr + nspmd
3817 IF(ALLOCATED(iadfr)) DEALLOCATE(iadfr)
3818 ALLOCATE(iadfr(nddl),stat=ierror1)
3819 IF(ALLOCATED(jdifr)) DEALLOCATE(jdifr)
3820 ALLOCATE(jdifr(nzzk),stat=ierror2)
3821 IF(ALLOCATED(iddlfr)) DEALLOCATE(iddlfr)
3822 ALLOCATE(iddlfr(n_fr),stat=ierror3)
3823 IF(ALLOCATED(ifr2k)) DEALLOCATE(ifr2k)
3824 ALLOCATE(ifr2k(nddlfr),stat=ierror4)
3825 IF (iprec>2.OR.iautspc>0) THEN
3826 IF(ALLOCATED(jfr2k)) DEALLOCATE(jfr2k)
3827 ALLOCATE(jfr2k(nzzk),stat=ierror5)
3828 ENDIF
3829 DO ip =1,nspmd
3830 nddl0=0
3831 DO nk=iad_elem(1,ip),iad_elem(1,ip+1)-1
3832 n=fr_elem(nk)
3833 iddlfr(nk) = nddl0
3834 nddl0=nddl0+ndof(n)
3835 ENDDO
3836 ENDDO
3837C------ Ind_ [K] for each fr .-----
3838 nddl0 = nddl
3839 nzzk0 = nzzk
3840 nzzk=0
3841 iad=0
3842 DO ip =1,nspmd
3843 nk0=iad_elem(1,ip)-1
3844 nzz = 0
3845 nddl=1
3846 iadfr(nddl+iad)=1
3847 DO nk=iad_elem(1,ip),iad_elem(1,ip+1)-1
3848 n=fr_elem(nk)
3849 CALL reorder_l(nrow(nk),icol(1,nk),nk-nk0,
3850 . iddlfr(iad_elem(1,ip)))
3851 IF (ndof(n)>0) THEN
3852 DO k=1,ndof(n)
3853C-------termes knj,n-------
3854 DO j=1,nrow(nk)
3855 nj = icol(j,nk)+nk0
3856 nn=fr_elem(nj)
3857 DO l=1,ndof(nn)
3858 nzz = nzz+1
3859 jdifr(nzz+nzzk) = iddlfr(nj)+l
3860 ENDDO
3861 ENDDO
3862 DO j=1,k-1
3863 nzz = nzz+1
3864 jdifr(nzz+nzzk) = iddlfr(nk)+j
3865 ENDDO
3866 nddl = nddl +1
3867 iadfr(nddl+iad) = nzz+1
3868 ENDDO
3869 ENDIF
3870 ENDDO
3871 nzzk = nzzk +nzz
3872 iad = iad + nddl
3873 ENDDO
3874 IF (nzzk>nzzk0.OR.iad/=nddl0)
3875 . WRITE(*,*)'--MEMERY PROBLEM 3--:',nzzk,nzzk0,iad,nddl0
3876 nzkfr = nzzk
3877C
3878 RETURN
3879 END
3880!||====================================================================
3881!|| ini_fr_k ../engine/source/mpi/implicit/imp_fri.F
3882!||--- called by ------------------------------------------------------
3883!|| ind_glob_k ../engine/source/implicit/ind_glob_k.F
3884!||--- calls -----------------------------------------------------
3885!|| dim_elemsp ../engine/source/implicit/ind_glob_k.F
3886!|| intab ../engine/source/implicit/ind_glob_k.F
3887!|| reorder_a ../engine/source/implicit/ind_glob_k.F
3888!|| spmd_icol ../engine/source/mpi/implicit/imp_spmd.F
3889!|| spmd_nrow ../engine/source/mpi/implicit/imp_spmd.F
3890!||--- uses -----------------------------------------------------
3891!|| elbufdef_mod ../common_source/modules/mat_elem/elbufdef_mod.F90
3892!|| element_mod ../common_source/modules/elements/element_mod.F90
3893!|| imp_frk ../engine/share/modules/impbufdef_mod.F
3894!||====================================================================
3895 SUBROUTINE ini_fr_k(
3896 1 ELBUF ,IPARG ,IXS ,IXQ ,IXC ,
3897 2 IXT ,IXP ,IXR ,IXTG ,IXTG1 ,
3898 3 IXS10 ,IXS20 ,IXS16 ,NDOF ,
3899 4 NNMAX ,INLOC ,FR_ELEM ,IAD_ELEM ,N_FR ,
3900 5 IGEO ,FR_I2M ,IAD_I2M ,ELBUF_TAB ,NNRMAX )
3901C-----------------------------------------------
3902C M o d u l e s
3903C-----------------------------------------------
3904 USE imp_frk
3905 USE elbufdef_mod
3906 use element_mod , only : nixs,nixq,nixc,nixt,nixp,nixr,nixtg
3907C-----------------------------------------------
3908C I m p l i c i t T y p e s
3909C-----------------------------------------------
3910#include "implicit_f.inc"
3911C-----------------------------------------------
3912C C o m m o n B l o c k s
3913C-----------------------------------------------
3914#include "com01_c.inc"
3915#include "com04_c.inc"
3916#include "param_c.inc"
3917C-----------------------------------------------
3918C D u m m y A r g u m e n t s
3919C-----------------------------------------------
3920 INTEGER IPARG(NPARG,*),NNMAX,N_FR ,NDOF(*),IGEO(*),
3921 . fr_i2m(*),iad_i2m(*),nnrmax
3922 integer
3923 . ixs(nixs,*),ixq(nixq,*),ixc(nixc,*), ixt(nixt,*),ixp(nixp,*),
3924 . ixr(nixr,*), ixtg(nixtg,*),ixs10(6,*),ixs20(12,*),
3925 . ixs16(8,*),ixtg1(4,*),inloc(*),fr_elem(*),iad_elem(2,*)
3926C REAL
3927 my_real
3928 . elbuf(*)
3929 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP) :: ELBUF_TAB
3930C-----------------------------------------------
3931C External function
3932C-----------------------------------------------
3933 LOGICAL INTAB
3934 EXTERNAL intab
3935C-----------------------------------------------
3936C L o c a l V a r i a b l e s
3937C-----------------------------------------------
3938 INTEGER I,J,N,NK,ICOL(NNMAX,N_FR),NROW(N_FR),IP,JLT,NFT,
3939 . fr_nrow(n_fr),l,iad_s(nspmd+1),iad_r(nspmd+1),
3940 . ierror1,ierror2,ierror3,ls,lr,ssize,rsize,j0,nn,nr,nl,nrn,
3941 . nr2,nf1
3942C ---- PB suite with Elem Delete .--------
3943C IF (N_FR <=0 .OR. NNMAX <=0) RETURN
3944 DO n =1,numnod
3945 inloc(n)=0
3946 ENDDO
3947 DO n =1,n_fr
3948 nrow(n)=0
3949 ENDDO
3950 DO ip =1,nspmd
3951 jlt=iad_elem(1,ip+1)-iad_elem(1,ip)
3952 nft=iad_elem(1,ip)-1
3953 nf1=min(n_fr,nft+1)
3954 DO j=1,jlt
3955 nk=j+nft
3956 n=fr_elem(nk)
3957 inloc(n) = j
3958 ENDDO
3959 CALL dim_elemsp(
3960 1 elbuf ,iparg ,ixs ,ixq ,ixc ,
3961 2 ixt ,ixp ,ixr ,ixtg ,ixtg1 ,
3962 3 ixs10 ,ixs20 ,ixs16 ,nrow(nf1),
3963 4 inloc ,nnmax ,icol(1,nf1),igeo ,elbuf_tab )
3964 DO j=1,jlt
3965 nk=j+nft
3966 n=fr_elem(nk)
3967 inloc(n) = 0
3968 ENDDO
3969 ENDDO
3970 CALL spmd_nrow(nrow,fr_nrow,iad_elem,n_fr)
3971C------ prepare comm .-----
3972 ls=1
3973 lr=1
3974 iad_s(1)=ls
3975 iad_r(1)=lr
3976 DO ip =1,nspmd
3977 DO nk=iad_elem(1,ip),iad_elem(1,ip+1)-1
3978 ls=ls+nrow(nk)
3979 lr=lr+fr_nrow(nk)
3980 ENDDO
3981 iad_s(ip+1)=ls
3982 iad_r(ip+1)=lr
3983 ENDDO
3984 IF ((ls+lr)>2) THEN
3985 ssize=iad_s(nspmd+1)-1
3986 rsize=iad_r(nspmd+1)-1
3987C
3988 CALL spmd_icol(
3989 1 iad_s ,iad_r ,nnmax ,icol ,nrow ,
3990 2 fr_nrow ,iad_elem ,fr_elem ,ssize ,rsize )
3991 ENDIF
3992C
3993 nr2=iad_i2m(nspmd+1)-iad_i2m(1)
3994 IF (nr2>0) THEN
3995 DO ip =1,nspmd
3996 nr=iad_i2m(ip+1)-iad_i2m(ip)
3997 IF (nr>0) THEN
3998 jlt=iad_elem(1,ip+1)-iad_elem(1,ip)
3999 nft=iad_elem(1,ip)-1
4000 DO j=1,jlt
4001 nk=j+nft
4002 n=fr_elem(nk)
4003 inloc(n) = j
4004 ENDDO
4005 DO nk=iad_elem(1,ip),iad_elem(1,ip+1)-1
4006 n=fr_elem(nk)
4007 IF (intab(nr,fr_i2m(iad_i2m(ip)),n)) THEN
4008 DO l=iad_i2m(ip),iad_i2m(ip+1)-1
4009 nn=fr_i2m(l)
4010 nl=inloc(nn)
4011 IF (nl>0.AND.nn/=n) THEN
4012 nrn = max(nrow(nk),fr_nrow(nk))
4013 CALL reorder_a(nrn,icol(1,nk),nl)
4014 IF (nrn>max(nrow(nk),fr_nrow(nk))) fr_nrow(nk)=nrn
4015 ENDIF
4016 ENDDO
4017 ENDIF
4018 ENDDO
4019C
4020 DO j=1,jlt
4021 nk=j+nft
4022 n=fr_elem(nk)
4023 inloc(n) = 0
4024 ENDDO
4025 ENDIF
4026 ENDDO
4027 END IF !(NR2>0) THEN
4028C
4029 IF(ALLOCATED(iad_rl)) DEALLOCATE(iad_rl)
4030 ALLOCATE(iad_rl(n_fr+1),stat=ierror3)
4031 lr=1
4032 iad_rl(1)=lr
4033 nrmax = 0
4034 DO ip =1,nspmd
4035 DO nk=iad_elem(1,ip),iad_elem(1,ip+1)-1
4036 IF (nrow(nk)<fr_nrow(nk)) THEN
4037 nr=fr_nrow(nk)-nrow(nk)
4038 lr=lr+nr
4039 nrmax = max(nrmax,nr)
4040 n=fr_elem(nk)
4041 IF (inloc(n)==0) THEN
4042 inloc(n)=1
4043 ELSE
4044 nrmax=nrmax+nr
4045 ENDIF
4046 ENDIF
4047 iad_rl(nk+1)=lr
4048 ENDDO
4049 ENDDO
4050 nnrmax = nrmax
4051C
4052 DO ip =1,nspmd
4053 DO nk=iad_elem(1,ip),iad_elem(1,ip+1)-1
4054 IF (nrow(nk)<fr_nrow(nk)) THEN
4055 n=fr_elem(nk)
4056 inloc(n) = 0
4057 ENDIF
4058 ENDDO
4059 ENDDO
4060C
4061 n_frnn=lr-1
4062C------- First it is local ------------
4063 IF (n_frnn>0) THEN
4064 IF(ALLOCATED(fr_icol)) DEALLOCATE(fr_icol)
4065 ALLOCATE(fr_icol(lr),stat=ierror2)
4066 DO ip =1,nspmd
4067 DO nk=iad_elem(1,ip),iad_elem(1,ip+1)-1
4068 j0=nrow(nk)-iad_rl(nk)+1
4069 DO l=iad_rl(nk),iad_rl(nk+1)-1
4070 j=l+j0
4071 fr_icol(l)=icol(j,nk)
4072 ENDDO
4073 ENDDO
4074 ENDDO
4075 ENDIF
4076C
4077 RETURN
4078 END
4079!||====================================================================
4080!|| upd_fr_k ../engine/source/mpi/implicit/imp_fri.F
4081!||--- called by ------------------------------------------------------
4082!|| imp_buck ../engine/source/implicit/imp_buck.F
4083!|| imp_chkm ../engine/source/implicit/imp_solv.F
4084!|| imp_k_eig ../engine/stub/imp_k_eig.F
4085!|| imp_solv ../engine/source/implicit/imp_solv.F
4086!||--- calls -----------------------------------------------------
4087!|| condens_ind ../engine/source/implicit/upd_glob_k.F
4088!|| intab0 ../engine/source/implicit/imp_fsa_inv.F
4089!|| spmd_max_iv ../engine/source/mpi/implicit/imp_spmd.F
4090!|| spmd_sum_s ../engine/source/mpi/implicit/imp_spmd.F
4091!||--- uses -----------------------------------------------------
4092!|| imp_frk ../engine/share/modules/impbufdef_mod.F
4093!||====================================================================
4094 SUBROUTINE upd_fr_k(
4095 1 IADK ,JDIK ,NDOF ,IKC ,IDDL ,
4096 2 INLOC ,FR_ELEM ,IAD_ELEM ,NDDL )
4097C-----------------------------------------------
4098C M o d u l e s
4099C-----------------------------------------------
4100 USE imp_frk
4101C-----------------------------------------------
4102C I m p l i c i t T y p e s
4103C-----------------------------------------------
4104#include "implicit_f.inc"
4105C-----------------------------------------------
4106C C o m m o n B l o c k s
4107C-----------------------------------------------
4108#include "com01_c.inc"
4109#include "com04_c.inc"
4110#include "impl1_c.inc"
4111#include "task_c.inc"
4112C-----------------------------------------------
4113C D u m m y A r g u m e n t s
4114C-----------------------------------------------
4115 INTEGER IADK(*) ,JDIK(*),IDDL(*),INLOC(*),NDOF(*)
4116 integer
4117 . ikc(*), fr_elem(*),iad_elem(2,*),nddl
4118C REAL
4119C-----------------------------------------------
4120C External function
4121C-----------------------------------------------
4122 INTEGER INTAB0
4123 EXTERNAL intab0
4124C-----------------------------------------------
4125C L o c a l V a r i a b l e s
4126C-----------------------------------------------
4127 INTEGER I,J,N,NK,IP,L,IFIX,II,IAD2,IJ,IND,N_FR,NB,
4128 . k,nd,nzzk,nj,nzz,iad,jad,id,jd,idk,nc,idf,ikcfr(nddlfr)
4129 INTEGER IIC(NDFRMAX),IDDLM(NUMNOD),NDN(NSPMD),NZN(NSPMD)
4130 INTEGER, DIMENSION(:),ALLOCATABLE :: ITAG
4131 my_real
4132 . s1,stmp
4133C
4134 ddlp0=0
4135 ddlp1=nddl
4136C
4137 stmp = zero
4138 IF (nddlfr>0) THEN
4139 n_fr = iad_elem(1,nspmd+1)-iad_elem(1,1)
4140 ALLOCATE(itag(n_fr))
4141 itag = 2
4142 DO nk=1,n_fr
4143 nb=-ifrloc(nk)
4144 IF (nb>0) itag(nb) = itag(nb) + 1
4145 ENDDO
4146 ENDIF
4147C
4148 IF (nddlfr>0) THEN
4149C-------if not the same IKC (e.g. RBE3 Ns)
4150c IKCFR (before condensation) for comm IKC
4151 iad2 = 0
4152 DO ip =1,nspmd
4153 DO nk=iad_elem(1,ip),iad_elem(1,ip+1)-1
4154 n=fr_elem(nk)
4155 id=iddlfr(nk)+iad2
4156 idk=iddl(n)
4157 DO j=1,ndof(n)
4158 ikcfr(id+j)=ikc(idk+j)
4159 ENDDO
4160 ENDDO
4161 iad2 = iad2 + nd_fr(ip)
4162 ENDDO
4163 CALL spmd_max_iv(ikcfr)
4164 iad2 = 0
4165 iad = 0
4166 jad = 0
4167 ii = 0
4168 ij = 0
4169 DO ip =1,nspmd
4170 ifix = 0
4171 DO nk=iad_elem(1,ip),iad_elem(1,ip+1)-1
4172 n=fr_elem(nk)
4173 id=iddlfr(nk)
4174 idk=iddl(n)
4175 ind = ifix
4176 DO j=1,ndof(n)
4177 iic(id+j)=ikcfr(id+iad2+j)
4178 IF (iic(id+j)/=0) ifix=ifix+1
4179 ENDDO
4180C
4181 nb=-ifrloc(nk)
4182 IF (nb<0) nb = nk
4183 s1 = one/itag(nb)
4184 stmp = stmp + s1*(ifix-ind)
4185C
4186 ENDDO
4187C -----update---condense-IKC>=1------------------------------------
4188 nd = nd_fr(ip)
4189 nzz=iadfr(iad+nd_fr(ip)+1)-iadfr(iad+1)
4190 iad2 = iad2 + nd_fr(ip)
4191 IF (ifix>0) THEN
4192 nzzk=nzz
4193 CALL condens_ind(nd_fr(ip),nzzk,iadfr(iad+1),jdifr(jad+1),iic)
4194 ii = ii + ifix
4195 ij = ij + nzz-nzzk
4196 ENDIF
4197 iad = iad + nd + 1
4198 jad = jad + nzz
4199 ndn(ip)=ii
4200 nzn(ip)=ij
4201 ENDDO
4202 DEALLOCATE(itag)
4203 ENDIF ! (NDDLFR>0)
4204 CALL spmd_sum_s(stmp)
4205 nddlfrb1 = nddlfrb-int(stmp)
4206 IF (nddlfr<=0) RETURN
4207C-------if there is condensation-------
4208 IF (ndn(nspmd)>0) THEN
4209 iad = nd_fr(1) + 1
4210 DO ip =2,nspmd
4211 ii = ndn(ip-1)
4212 IF (ii>0) THEN
4213 ii = ii+iad
4214 DO i=1,nd_fr(ip)+1
4215 iadfr(iad+i)=iadfr(ii+i)
4216 ENDDO
4217 ENDIF
4218 iad = iad + nd_fr(ip) + 1
4219 ENDDO
4220 iad = nd_fr(1) + 1
4221 jad = iadfr(iad)-iadfr(1)
4222 DO ip =2,nspmd
4223 ij = nzn(ip-1)
4224 IF (ij>0) THEN
4225 ij = ij+jad
4226 DO j=iadfr(iad+1),iadfr(iad+1+nd_fr(ip))-1
4227 jdifr(j+jad)= jdifr(j+ij)
4228 ENDDO
4229 ENDIF
4230 nzzk=iadfr(iad+nd_fr(ip)+1)-iadfr(iad+1)
4231 iad = iad + nd_fr(ip) + 1
4232 jad = jad + nzzk
4233 ENDDO
4234 ENDIF
4235C
4236 ifix=0
4237 DO n = 1,numnod
4238 i=inloc(n)
4239 iddlm(i)=iddl(i)-ifix
4240 DO j=1,ndof(i)
4241 nd = iddl(i)+j
4242 IF (ikc(nd)/=0) ifix=ifix+1
4243 ENDDO
4244 ENDDO
4245C
4246C-------FR2K-------
4247 iad2 = 0
4248 DO ip =1,nspmd
4249 ifix=0
4250 DO nk=iad_elem(1,ip),iad_elem(1,ip+1)-1
4251 n=fr_elem(nk)
4252 id=iddlfr(nk)+iad2-ifix
4253 idk=iddl(n)
4254 ind=0
4255 DO j=1,ndof(n)
4256 IF (ikc(idk+j)<1) THEN
4257 ind=ind+1
4258 ifr2k(id+ind)=iddlm(n)+ind
4259 ELSE
4260 ifix=ifix+1
4261 ENDIF
4262 ENDDO
4263 ENDDO
4264 iad2 = iad2 + nd_fr(ip)
4265 ENDDO
4266 len_v = iad2
4267C
4268 len_k = 0
4269 IF (iprec>2) THEN
4270 iad = 0
4271 iad2 = 0
4272 jad = 0
4273 DO ip =1,nspmd
4274 DO i=1,nd_fr(ip)
4275 id = i+iad
4276 ii = ifr2k(i+iad2)
4277 DO j=iadfr(id),iadfr(id+1)-1
4278 jd = j + jad
4279 k=jdifr(jd)
4280 ij = ifr2k(k+iad2)
4281 IF (ii>ij) THEN
4282 nc = iadk(ii+1)-iadk(ii)
4283 n=intab0(nc,jdik(iadk(ii)),ij)
4284 IF (n>0) THEN
4285 jfr2k(jd)=n+iadk(ii)-1
4286 ELSE
4287 write(*,*)'index error in UPD_FR_K I>J',ij,ip,nc
4288c write(*,*)'i,j,ik,iad=',i,k,ii,iad
4289 ENDIF
4290 ELSE
4291 nc = iadk(ij+1)-iadk(ij)
4292 n=intab0(nc,jdik(iadk(ij)),ii)
4293 IF (n>0) THEN
4294 jfr2k(jd)=n+iadk(ij)-1
4295 ELSE
4296 write(*,*)'index error in UPD_FR_K J>I',ii,ip,nc
4297c write(*,*)'i,j,ik,iad=',i,k,ij,iad
4298 ENDIF
4299 ENDIF
4300 ENDDO
4301 ENDDO
4302 nzzk=iadfr(iad+nd_fr(ip)+1)-iadfr(iad+1)
4303 iad = iad + nd_fr(ip) +1
4304 iad2 = iad2 + nd_fr(ip)
4305 jad = jad + nzzk
4306 ENDDO
4307 len_k = iad2+jad
4308 iad2 = 0
4309 DO ip =1,ispmd
4310 DO j =1,nd_fr(ip)
4311 ddlp0 = max(ddlp0,ifr2k(iad2+j))
4312 ENDDO
4313 iad2=iad2+nd_fr(ip)
4314 ENDDO
4315C
4316 DO ip =ispmd+2,nspmd
4317 ifix=0
4318 DO nk=iad_elem(1,ip),iad_elem(1,ip+1)-1
4319 n=fr_elem(nk)
4320 id=iddlfr(nk)+iad2-ifix
4321 idk=iddl(n)
4322 DO j=1,ndof(n)
4323 IF (ikc(idk+j)>0) ifix=ifix+1
4324 ENDDO
4325 IF(ifrloc(nk)>0) THEN
4326 ind=0
4327 DO j=1,ndof(n)
4328 IF (ikc(idk+j)<1) THEN
4329 ind=ind+1
4330 ddlp1=ifr2k(id+ind)-1
4331 GOTO 100
4332 ENDIF
4333 ENDDO
4334 ENDIF
4335 ENDDO
4336 iad2 = iad2 + nd_fr(ip)
4337 ENDDO
4338 ENDIF
4339c write(*,*)'LEN_V,LEN_K,ISPMD=',LEN_V,LEN_K,ISPMD
4340c write(*,*)'ND_FR=',(ND_FR(J),J=1,NSPMD),ISPMD
4341 100 CONTINUE
4342C
4343 RETURN
4344 END
4345!||====================================================================
4346!|| fr_dlft ../engine/source/mpi/implicit/imp_fri.F
4347!||--- called by ------------------------------------------------------
4348!|| imp_checm0 ../engine/source/implicit/imp_solv.F
4349!|| lin_solvh1 ../engine/source/implicit/lin_solv.F
4350!|| lin_solvih2 ../engine/source/implicit/lin_solv.F
4351!||--- uses -----------------------------------------------------
4352!|| imp_frk ../engine/share/modules/impbufdef_mod.F
4353!||====================================================================
4354 SUBROUTINE fr_dlft(NDDL,IDLFT0,IDLFT1)
4355C-----------------------------------------------
4356C M o d u l e s
4357C-----------------------------------------------
4358 USE imp_frk
4359C-----------------------------------------------
4360C I m p l i c i t T y p e s
4361C-----------------------------------------------
4362#include "implicit_f.inc"
4363C-----------------------------------------------
4364C D u m m y A r g u m e n t s
4365C-----------------------------------------------
4366 INTEGER IDLFT0,IDLFT1,NDDL
4367C REAL
4368C-----------------------------------------------
4369C L o c a l V a r i a b l e s
4370C-----------------------------------------------
4371 INTEGER L,IP,J
4372C
4373C
4374 idlft0 = ddlp0
4375 idlft1 = ddlp1
4376C
4377 RETURN
4378 END
4379CCgw| DIM_GLOB_K /implicit/ind_glob_k.F
4380!||====================================================================
4381!|| set_ikin2g ../engine/source/mpi/implicit/imp_fri.F
4382!||--- called by ------------------------------------------------------
4383!|| dim_glob_k ../engine/source/implicit/ind_glob_k.F
4384!||--- uses -----------------------------------------------------
4385!|| imp_frk ../engine/share/modules/impbufdef_mod.F
4386!||====================================================================
4387 SUBROUTINE set_ikin2g(NKINE,INLOC)
4388C-----------------------------------------------
4389C M o d u l e s
4390C-----------------------------------------------
4391 USE imp_frk
4392C-----------------------------------------------
4393C I m p l i c i t T y p e s
4394C-----------------------------------------------
4395#include "implicit_f.inc"
4396C-----------------------------------------------
4397C C o m m o n B l o c k s
4398C-----------------------------------------------
4399#include "com04_c.inc"
4400C-----------------------------------------------
4401C D u m m y A r g u m e n t s
4402C-----------------------------------------------
4403 INTEGER NKINE,INLOC(*)
4404C REAL
4405C-----------------------------------------------
4406C L o c a l V a r i a b l e s
4407C-----------------------------------------------
4408 INTEGER I,N,IERROR1
4409C
4410 IF (nkine<=0) RETURN
4411 IF(ALLOCATED(ikin2g)) DEALLOCATE(ikin2g)
4412 ALLOCATE(ikin2g(nkine),stat=ierror1)
4413 DO i =1,numnod
4414 n=inloc(i)
4415 IF (n>0) ikin2g(n)=i
4416 ENDDO
4417C
4418 RETURN
4419 END
4420CCgw| IND_GLOB_K /implicit/ind_glob_k.F
4421!||====================================================================
4422!|| get_ikin2g ../engine/source/mpi/implicit/imp_fri.F
4423!||--- called by ------------------------------------------------------
4424!|| ind_glob_k ../engine/source/implicit/ind_glob_k.F
4425!||--- uses -----------------------------------------------------
4426!|| imp_frk ../engine/share/modules/impbufdef_mod.F
4427!||====================================================================
4428 SUBROUTINE get_ikin2g(NKINE,INK,ILOC)
4429C-----------------------------------------------
4430C M o d u l e s
4431C-----------------------------------------------
4432 USE imp_frk
4433C-----------------------------------------------
4434C I m p l i c i t T y p e s
4435C-----------------------------------------------
4436#include "implicit_f.inc"
4437C-----------------------------------------------
4438C D u m m y A r g u m e n t s
4439C-----------------------------------------------
4440 INTEGER NKINE,ILOC(*),INK
4441C REAL
4442C-----------------------------------------------
4443C L o c a l V a r i a b l e s
4444C-----------------------------------------------
4445 INTEGER I,N,NRB
4446C
4447 NRB=nkine-ink
4448 DO n =1,nrb
4449 i=ikin2g(n)
4450 iloc(i)=n+ink
4451 ENDDO
4452 DO n =nrb+1,nkine
4453 i=ikin2g(n)
4454 iloc(i)=n-nrb
4455 ENDDO
4456C
4457 RETURN
4458 END
4459CCgw| IND_GLOB_K /implicit/ind_glob_k.F
4460!||====================================================================
4461!|| zero_ikin2g ../engine/source/mpi/implicit/imp_fri.F
4462!||--- called by ------------------------------------------------------
4463!|| ind_glob_k ../engine/source/implicit/ind_glob_k.F
4464!||--- uses -----------------------------------------------------
4465!|| imp_frk ../engine/share/modules/impbufdef_mod.F
4466!||====================================================================
4467 SUBROUTINE zero_ikin2g(NKINE,ILOC)
4468C-----------------------------------------------
4469C M o d u l e s
4470C-----------------------------------------------
4471 USE imp_frk
4472C-----------------------------------------------
4473C I m p l i c i t T y p e s
4474C-----------------------------------------------
4475#include "implicit_f.inc"
4476C-----------------------------------------------
4477C D u m m y A r g u m e n t s
4478C-----------------------------------------------
4479 INTEGER NKINE,ILOC(*),INK
4480C REAL
4481C-----------------------------------------------
4482C L o c a l V a r i a b l e s
4483C-----------------------------------------------
4484 INTEGER I,N
4485C
4486 DO N =1,nkine
4487 i=ikin2g(n)
4488 iloc(i)=0
4489 ENDDO
4490C
4491 RETURN
4492 END
4493!||====================================================================
4494!|| ind_kine_kp ../engine/source/mpi/implicit/imp_fri.F
4495!||--- called by ------------------------------------------------------
4496!|| ind_glob_k ../engine/source/implicit/ind_glob_k.F
4497!||--- calls -----------------------------------------------------
4498!|| reorder_j ../engine/source/implicit/ind_glob_k.F
4499!|| reorder_l ../engine/source/implicit/ind_glob_k.F
4500!||--- uses -----------------------------------------------------
4501!|| imp_frk ../engine/share/modules/impbufdef_mod.F
4502!||====================================================================
4503 SUBROUTINE ind_kine_kp(
4504 1 NROWK ,ICOK ,ICOKM ,NNMAX ,NKMAX ,
4505 2 NKINE ,INK ,IKPAT ,IDDL )
4506C-----------------------------------------------
4507C M o d u l e s
4508C-----------------------------------------------
4509 USE imp_frk
4510C----6---------------------------------------------------------------7---------8
4511C I m p l i c i t T y p e s
4512C-----------------------------------------------
4513#include "implicit_f.inc"
4514C-----------------------------------------------
4515C C o m m o n B l o c k s
4516C-----------------------------------------------
4517C-----------------------------------------------------------------
4518C D u m m y A r g u m e n t s
4519C-----------------------------------------------
4520 INTEGER NNMAX,NKMAX,NROWK(*),NKINE,INK,IKPAT
4521 INTEGER ICOK(NNMAX,*),ICOKM(NKMAX,*),IDDL(*)
4522C REAL
4523C-----------------------------------------------
4524C L o c a l V a r i a b l e s
4525C-----------------------------------------------
4526 INTEGER I,J,N,K,NL,NK,NJ,NRB
4527c----------------------
4528 NRB=nkine-ink
4529 IF (ikpat==0) THEN
4530 DO nk =1,nrb
4531 j=ikin2g(nk)
4532 CALL reorder_j(nrowk(nk+ink),icokm(1,nk),j,iddl)
4533 ENDDO
4534 DO nk =nrb+1,nkine
4535 j=ikin2g(nk)
4536 nj=nk-nrb
4537 CALL reorder_j(nrowk(nj),icok(1,nj),j,iddl)
4538 ENDDO
4539 ELSE
4540 DO nk =1,nrb
4541 j=ikin2g(nk)
4542 CALL reorder_l(nrowk(nk+ink),icokm(1,nk),j,iddl)
4543 ENDDO
4544 DO nk =nrb+1,nkine
4545 j=ikin2g(nk)
4546 nj=nk-nrb
4547 CALL reorder_l(nrowk(nj),icok(1,nj),j,iddl)
4548 ENDDO
4549 ENDIF
4550C----6---------------------------------------------------------------7---------8
4551 RETURN
4552 END
4553!||====================================================================
4554!|| tag_intm11 ../engine/source/mpi/implicit/imp_fri.F
4555!||--- called by ------------------------------------------------------
4556!|| imp_frki ../engine/source/mpi/implicit/imp_fri.F
4557!||====================================================================
4558 SUBROUTINE tag_intm11(
4559 1 JLT ,NS_IMP ,NE_IMP ,IRECTS ,IRECTM ,
4560 2 ILOC ,N_IMPN ,NSN )
4561C----6---------------------------------------------------------------7---------8
4562C I m p l i c i t T y p e s
4563C-----------------------------------------------
4564#include "implicit_f.inc"
4565C-----------------------------------------------------------------
4566C D u m m y A r g u m e n t s
4567C-----------------------------------------------
4568 INTEGER JLT,NS_IMP(*),NE_IMP(*),IRECTS(2,*),IRECTM(2,*),
4569 . ILOC(*),N_IMPN,NSN
4570C REAL
4571C-----------------------------------------------
4572C L o c a l V a r i a b l e s
4573C-----------------------------------------------
4574 INTEGER I,J,N,N1,N2,NE,IG,M1,M2
4575C-----------------------------------------------
4576 DO i = 1, jlt
4577C--------second node-----
4578 ig = ns_imp(i)
4579 IF (ig>nsn) THEN
4580 ne=ne_imp(i)
4581 m1=irectm(1,ne)
4582 m2=irectm(2,ne)
4583 IF (iloc(m1)==0) THEN
4584 n_impn=n_impn+1
4585 iloc(m1)=n_impn
4586 ENDIF
4587 IF (iloc(m2)==0) THEN
4588 n_impn=n_impn+1
4589 iloc(m2)=n_impn
4590 ENDIF
4591 ENDIF
4592 ENDDO
4593C----6---------------------------------------------------------------7---------8
4594 RETURN
4595 END
4596!||====================================================================
4597!|| mav_ltfr ../engine/source/mpi/implicit/imp_fri.F
4598!||--- called by ------------------------------------------------------
4599!|| fr_matv ../engine/source/mpi/implicit/imp_fri.F
4600!||--- uses -----------------------------------------------------
4601!|| imp_intm ../engine/share/modules/imp_intm.f
4602!||====================================================================
4603 SUBROUTINE mav_ltfr(V ,W )
4604C-----------------------------------------------
4605C M o d u l e s
4606C-----------------------------------------------
4607 USE imp_intm
4608C-----------------------------------------------
4609C I m p l i c i t T y p e s
4610C-----------------------------------------------
4611#include "implicit_f.inc"
4612C-----------------------------------------------
4613C D u m m y A r g u m e n t s
4614C-----------------------------------------------
4615C REAL
4616 my_real
4617 . w(*), v(*)
4618C-----------------------------------------------
4619C L o c a l V a r i a b l e s
4620C-----------------------------------------------
4621 INTEGER I,J,K,ID
4622 my_real
4623 . l_k
4624C-----------------------------
4625 DO i=1,nddl_si
4626 fsi(i) = zero
4627 ENDDO
4628 DO i=1,nddl_si
4629 DO j =iad_si(i),iad_si(i+1)-1
4630 k =jdi_si(j)
4631 l_k = lt_si(j)
4632 fsi(i) = fsi(i) + l_k*v(k)
4633 w(k) = w(k) + l_k*usi(i)
4634 ENDDO
4635 ENDDO
4636C
4637 DO i=1,nddl_sl
4638 id = iddl_sl(i)
4639 w(id) = w(id) + diag_sl(i)*v(id)
4640 DO j =iad_ss(i),iad_ss(i+1)-1
4641 k =jdi_sl(j)
4642 l_k = lt_sl(j)
4643 w(id) = w(id) + l_k*v(k)
4644 w(k) = w(k) + l_k*v(id)
4645 ENDDO
4646 ENDDO
4647C--------------------------------------------
4648 RETURN
4649 END
4650!||====================================================================
4651!|| mav_ltfr_gpu ../engine/source/mpi/implicit/imp_fri.F
4652!||--- called by ------------------------------------------------------
4653!|| fr_matv_gpu ../engine/source/mpi/implicit/imp_fri.F
4654!||--- uses -----------------------------------------------------
4655!|| imp_intm ../engine/share/modules/imp_intm.F
4656!||====================================================================
4657 SUBROUTINE mav_ltfr_gpu(V ,W ,NINDEX)
4658C-----------------------------------------------
4659C M o d u l e s
4660C-----------------------------------------------
4661 USE imp_intm
4662C-----------------------------------------------
4663C I m p l i c i t T y p e s
4664C-----------------------------------------------
4665#include "implicit_f.inc"
4666C-----------------------------------------------
4667C D u m m y A r g u m e n t s
4668C-----------------------------------------------
4669 INTEGER NINDEX(*)
4670C REAL
4671 my_real
4672 . w(*), v(*)
4673C-----------------------------------------------
4674C L o c a l V a r i a b l e s
4675C-----------------------------------------------
4676 INTEGER I,J,K,ID,KK,II
4677 my_real
4678 . l_k
4679C-----------------------------
4680 DO i=1,nddl_si
4681 fsi(i) = zero
4682 ENDDO
4683 DO i=1,nddl_si
4684 DO j =iad_si(i),iad_si(i+1)-1
4685 k =jdi_si(j)
4686 kk=nindex(k)
4687 l_k = lt_si(j)
4688 fsi(i) = fsi(i) + l_k*v(kk)
4689 w(kk) = w(kk) + l_k*usi(i)
4690 ENDDO
4691 ENDDO
4692C
4693 DO i=1,nddl_sl
4694 id = iddl_sl(i)
4695 ii = nindex(id)
4696 w(ii) = w(ii) + diag_sl(i)*v(ii)
4697 DO j =iad_ss(i),iad_ss(i+1)-1
4698 k =jdi_sl(j)
4699 kk=nindex(k)
4700 l_k = lt_sl(j)
4701 w(ii) = w(ii) + l_k*v(kk)
4702 w(kk) = w(kk) + l_k*v(ii)
4703 ENDDO
4704 ENDDO
4705C--------------------------------------------
4706 RETURN
4707 END
4708!||====================================================================
4709!|| ind_frkd ../engine/source/mpi/implicit/imp_fri.F
4710!||--- called by ------------------------------------------------------
4711!|| imp_solv ../engine/source/implicit/imp_solv.F
4712!||--- calls -----------------------------------------------------
4713!|| reorder_fr ../engine/source/mpi/implicit/imp_fri.f
4714!|| rowfr_dim ../engine/source/mpi/implicit/imp_fri.F
4715!|| rowfr_dim11 ../engine/source/mpi/implicit/imp_fri.F
4716!|| rowfr_dim24 ../engine/source/mpi/implicit/imp_fri.f
4717!|| rowfr_ind ../engine/source/mpi/implicit/imp_fri.f
4718!|| rowfr_ind11 ../engine/source/mpi/implicit/imp_fri.F
4719!|| rowfr_ind24 ../engine/source/mpi/implicit/imp_fri.F
4720!|| set_ind_fr ../engine/source/mpi/implicit/imp_fri.F
4721!||--- uses -----------------------------------------------------
4722!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
4723!||====================================================================
4724 SUBROUTINE ind_frkd(
4725 1 IPARI ,INTBUF_TAB,NUM_IMP ,NS_IMP ,NE_IMP ,
4726 2 IDDL ,IKC ,NDOF ,NSREM ,IND_IMP )
4727C-----------------------------------------------
4728C M o d u l e s
4729C-----------------------------------------------
4730 USE intbufdef_mod
4731C----6---------------------------------------------------------------7---------8
4732C I m p l i c i t T y p e s
4733C-----------------------------------------------
4734#include "implicit_f.inc"
4735C-----------------------------------------------
4736C C o m m o n B l o c k s
4737C-----------------------------------------------
4738#include "com04_c.inc"
4739#include "param_c.inc"
4740C-----------------------------------------------------------------
4741C D u m m y A r g u m e n t s
4742C-----------------------------------------------
4743 INTEGER IPARI(NPARI,*),NUM_IMP(*),NS_IMP(*),
4744 . NE_IMP(*),NSREM,IND_IMP(*)
4745 INTEGER IDDL(*),IKC(*),NDOF(*)
4746C REAL
4747 TYPE(intbuf_struct_) INTBUF_TAB(*)
4748C-----------------------------------------------
4749C L o c a l V a r i a b l e s
4750C-----------------------------------------------
4751 INTEGER NIN,NTY,NROW(NSREM)
4752 INTEGER I,J,K,L,NDOFI,N,IAD,INSV11,NRTS,
4753 . INSV,NSN,NKC,J1,ND,IER1,NNMAX
4754 INTEGER, DIMENSION(:,:), ALLOCATABLE :: ICOL
4755C------------------------------------------------------------
4756C--------dim Nrow----
4757 DO N =1,nsrem
4758 nrow(n)=0
4759 ENDDO
4760C
4761 iad=1
4762 DO nin=1,ninter
4763 nty =ipari(7,nin)
4764 IF(nty==5) iad=iad+num_imp(nin)
4765 ENDDO
4766 DO nin=1,ninter
4767 nsn =ipari(5,nin)
4768 nty =ipari(7,nin)
4769 IF(nty==3)THEN
4770 ELSEIF(nty==4)THEN
4771 ELSEIF(nty==5)THEN
4772 ELSEIF(nty==6)THEN
4773 ELSEIF(nty==7.OR.nty==10)THEN
4774C
4775 CALL rowfr_dim(num_imp(nin),ns_imp(iad),ne_imp(iad),
4776 . intbuf_tab(nin)%IRECTM,nrow ,nsn ,nin )
4777 iad=iad+num_imp(nin)
4778 ELSEIF(nty==24)THEN
4779C
4780 CALL rowfr_dim24(num_imp(nin),ns_imp(iad),ne_imp(iad),
4781 . intbuf_tab(nin)%IRECTM,nrow ,nsn ,nin ,
4782 . ind_imp ,intbuf_tab(nin)%NVOISIN)
4783 iad=iad+num_imp(nin)
4784 ELSEIF(nty==11)THEN
4785 nrts =ipari(3,nin)
4786 CALL rowfr_dim11(num_imp(nin),ns_imp(iad),ne_imp(iad),
4787 . intbuf_tab(nin)%IRECTM, nrow ,nrts ,nin )
4788 iad=iad+num_imp(nin)
4789 ENDIF
4790 ENDDO
4791C
4792 nnmax=0
4793 DO n =1,nsrem
4794 nnmax=max(nnmax,nrow(n))
4795 nrow(n)=0
4796 ENDDO
4797 ALLOCATE(icol(nnmax,nsrem),stat=ier1)
4798C--------ind Nrow----
4799 iad=1
4800 DO nin=1,ninter
4801 nty =ipari(7,nin)
4802 IF(nty==5) iad=iad+num_imp(nin)
4803 ENDDO
4804 DO nin=1,ninter
4805 nsn =ipari(5,nin)
4806 nty =ipari(7,nin)
4807 IF(nty==3)THEN
4808 ELSEIF(nty==4)THEN
4809 ELSEIF(nty==5)THEN
4810 ELSEIF(nty==6)THEN
4811 ELSEIF(nty==7.OR.nty==10)THEN
4812C
4813 CALL rowfr_ind(num_imp(nin),ns_imp(iad),ne_imp(iad),
4814 . intbuf_tab(nin)%IRECTM,nrow ,icol ,nnmax ,
4815 . nsn ,nin )
4816 iad=iad+num_imp(nin)
4817 ELSEIF(nty==24)THEN
4818C
4819 CALL rowfr_ind24(num_imp(nin),ns_imp(iad),ne_imp(iad),
4820 . intbuf_tab(nin)%IRECTM,nrow ,icol ,nnmax ,
4821 . nsn ,nin ,ind_imp ,intbuf_tab(nin)%NVOISIN)
4822 iad=iad+num_imp(nin)
4823 ELSEIF(nty==11)THEN
4824 nrts =ipari(3,nin)
4825 CALL rowfr_ind11(num_imp(nin),ns_imp(iad),ne_imp(iad),
4826 . intbuf_tab(nin)%IRECTM, nrow ,icol ,nnmax ,
4827 . nrts ,nin )
4828 iad=iad+num_imp(nin)
4829 ENDIF
4830 ENDDO
4831C
4832 DO n =1,nsrem
4833 CALL reorder_fr(nrow(n),icol(1,n),iddl)
4834 ENDDO
4835 CALL set_ind_fr(
4836 1 nsrem ,iddl ,ndof ,nrow ,icol ,
4837 2 nnmax )
4838C
4839 DEALLOCATE(icol)
4840C----6---------------------------------------------------------------7---------8
4841 RETURN
4842 END
4843!||====================================================================
4844!|| rowfr_dim ../engine/source/mpi/implicit/imp_fri.F
4845!||--- called by ------------------------------------------------------
4846!|| ind_frkd ../engine/source/mpi/implicit/imp_fri.F
4847!||--- uses -----------------------------------------------------
4848!|| imp_intm ../engine/share/modules/imp_intm.F
4849!||====================================================================
4850 SUBROUTINE rowfr_dim(
4851 1 JLT ,NS_IMP ,NE_IMP ,IRECT ,NROW ,
4852 2 NSN ,NIN )
4853C-----------------------------------------------
4854C M o d u l e s
4855C-----------------------------------------------
4856 USE imp_intm
4857C----6---------------------------------------------------------------7---------8
4858C I m p l i c i t T y p e s
4859C-----------------------------------------------
4860#include "implicit_f.inc"
4861C-----------------------------------------------------------------
4862C D u m m y A r g u m e n t s
4863C-----------------------------------------------
4864 INTEGER JLT,NS_IMP(*),NE_IMP(*),IRECT(4,*),NROW(*),NSN,NIN
4865C REAL
4866C-----------------------------------------------
4867C L o c a l V a r i a b l e s
4868C-----------------------------------------------
4869 INTEGER I,NE,IG,NS
4870C-----------------------------------------------
4871 DO i = 1, jlt
4872 ig = ns_imp(i)-nsn
4873 IF (ig>0) THEN
4874 ns=ind_int(nin)%P(ig)
4875 ne=ne_imp(i)
4876 IF (irect(3,ne)==irect(4,ne)) THEN
4877 nrow(ns)=nrow(ns)+3
4878 ELSE
4879 nrow(ns)=nrow(ns)+4
4880 ENDIF
4881 ENDIF
4882 ENDDO
4883C----6---------------------------------------------------------------7---------8
4884 RETURN
4885 END
4886!||====================================================================
4887!|| rowfr_dim11 ../engine/source/mpi/implicit/imp_fri.F
4888!||--- called by ------------------------------------------------------
4889!|| ind_frkd ../engine/source/mpi/implicit/imp_fri.F
4890!||--- uses -----------------------------------------------------
4891!|| imp_intm ../engine/share/modules/imp_intm.F
4892!||====================================================================
4893 SUBROUTINE rowfr_dim11(
4894 1 JLT ,NS_IMP ,NE_IMP ,IRECTM ,NROW ,
4895 2 NSN ,NIN )
4896C-----------------------------------------------
4897C M o d u l e s
4898C-----------------------------------------------
4899 USE imp_intm
4900C----6---------------------------------------------------------------7---------8
4901C I m p l i c i t T y p e s
4902C-----------------------------------------------
4903#include "implicit_f.inc"
4904C-----------------------------------------------------------------
4905C D u m m y A r g u m e n t s
4906C-----------------------------------------------
4907 INTEGER JLT,NS_IMP(*),NE_IMP(*),IRECTM(2,*),NROW(*),NSN,NIN
4908C REAL
4909C-----------------------------------------------
4910C L o c a l V a r i a b l e s
4911C-----------------------------------------------
4912 INTEGER I,NE,IG,NS1,NS2
4913C-----------------------------------------------
4914 DO i = 1, jlt
4915 ig = ns_imp(i)-nsn
4916 IF (ig>0) THEN
4917 ns1=ind_int(nin)%P(ig)
4918 ns2=ns1+1
4919 ne=ne_imp(i)
4920 nrow(ns1)=nrow(ns1)+2
4921 nrow(ns2)=nrow(ns2)+2
4922 ENDIF
4923 ENDDO
4924C----6---------------------------------------------------------------7---------8
4925 RETURN
4926 END
4927!||====================================================================
4928!|| rowfr_ind ../engine/source/mpi/implicit/imp_fri.F
4929!||--- called by ------------------------------------------------------
4930!|| ind_frkd ../engine/source/mpi/implicit/imp_fri.F
4931!||--- calls -----------------------------------------------------
4932!|| reorder_a ../engine/source/implicit/ind_glob_k.F
4933!||--- uses -----------------------------------------------------
4934!|| imp_intm ../engine/share/modules/imp_intm.F
4935!||====================================================================
4936 SUBROUTINE rowfr_ind(
4937 1 JLT ,NS_IMP ,NE_IMP ,IRECT ,NROW ,
4938 2 ICOL ,NNMAX ,NSN ,NIN )
4939C-----------------------------------------------
4940C M o d u l e s
4941C-----------------------------------------------
4942 USE imp_intm
4943C----6---------------------------------------------------------------7---------8
4944C I m p l i c i t T y p e s
4945C-----------------------------------------------
4946#include "implicit_f.inc"
4947C-----------------------------------------------------------------
4948C D u m m y A r g u m e n t s
4949C-----------------------------------------------
4950 INTEGER NNMAX
4951 INTEGER JLT,NS_IMP(*),NE_IMP(*),IRECT(4,*),NROW(*),
4952 . icol(nnmax,*),nsn,nin
4953C REAL
4954C-----------------------------------------------
4955C L o c a l V a r i a b l e s
4956C-----------------------------------------------
4957 INTEGER I,J,NE,IG,NS,NM
4958C-----------------------------------------------
4959 DO I = 1, jlt
4960 ig = ns_imp(i)-nsn
4961 IF (ig>0) THEN
4962 ns=ind_int(nin)%P(ig)
4963 ne=ne_imp(i)
4964 DO j = 1,4
4965 nm = irect(j,ne)
4966 CALL reorder_a(nrow(ns),icol(1,ns),nm)
4967 ENDDO
4968 ENDIF
4969 ENDDO
4970C----6---------------------------------------------------------------7---------8
4971 RETURN
4972 END
4973!||====================================================================
4974!|| rowfr_ind11 ../engine/source/mpi/implicit/imp_fri.F
4975!||--- called by ------------------------------------------------------
4976!|| ind_frkd ../engine/source/mpi/implicit/imp_fri.F
4977!||--- calls -----------------------------------------------------
4978!|| reorder_a ../engine/source/implicit/ind_glob_k.F
4979!||--- uses -----------------------------------------------------
4980!|| imp_intm ../engine/share/modules/imp_intm.F
4981!||====================================================================
4982 SUBROUTINE rowfr_ind11(
4983 1 JLT ,NS_IMP ,NE_IMP ,IRECTM ,NROW ,
4984 2 ICOL ,NNMAX ,NSN ,NIN )
4985C-----------------------------------------------
4986C M o d u l e s
4987C-----------------------------------------------
4988 USE imp_intm
4989C----6---------------------------------------------------------------7---------8
4990C I m p l i c i t T y p e s
4991C-----------------------------------------------
4992#include "implicit_f.inc"
4993C-----------------------------------------------------------------
4994C D u m m y A r g u m e n t s
4995C-----------------------------------------------
4996 INTEGER NNMAX
4997 INTEGER JLT,NS_IMP(*),NE_IMP(*),IRECTM(2,*),NROW(*),
4998 . ICOL(NNMAX,*),NSN,NIN
4999C REAL
5000C-----------------------------------------------
5001C L o c a l V a r i a b l e s
5002C-----------------------------------------------
5003 INTEGER I,NE,IG,NS1,NS2,NM1,NM2
5004C-----------------------------------------------
5005 DO i = 1, jlt
5006 ig = ns_imp(i)-nsn
5007 IF (ig>0) THEN
5008 ns1=ind_int(nin)%P(ig)
5009 ns2=ns1+1
5010 ne=ne_imp(i)
5011 nm1=irectm(1,ne)
5012 nm2=irectm(2,ne)
5013 CALL reorder_a(nrow(ns1),icol(1,ns1),nm1)
5014 CALL reorder_a(nrow(ns1),icol(1,ns1),nm2)
5015 CALL reorder_a(nrow(ns2),icol(1,ns2),nm1)
5016 CALL reorder_a(nrow(ns2),icol(1,ns2),nm2)
5017 ENDIF
5018 ENDDO
5019C----6---------------------------------------------------------------7---------8
5020 RETURN
5021 END
5022!||====================================================================
5023!|| rowfr_dim24 ../engine/source/mpi/implicit/imp_fri.F
5024!||--- called by ------------------------------------------------------
5025!|| ind_frkd ../engine/source/mpi/implicit/imp_fri.F
5026!||--- calls -----------------------------------------------------
5027!|| i24msegv ../engine/source/implicit/ind_glob_k.F
5028!||--- uses -----------------------------------------------------
5029!|| imp_intm ../engine/share/modules/imp_intm.F
5030!||====================================================================
5031 SUBROUTINE rowfr_dim24(
5032 1 JLT ,NS_IMP ,NE_IMP ,IRECT ,NROW ,
5033 2 NSN ,NIN ,SUBTRIA ,NVOISIN )
5034C-----------------------------------------------
5035C M o d u l e s
5036C-----------------------------------------------
5037 USE imp_intm
5038C----6---------------------------------------------------------------7---------8
5039C I m p l i c i t T y p e s
5040C-----------------------------------------------
5041#include "implicit_f.inc"
5042C-----------------------------------------------------------------
5043C D u m m y A r g u m e n t s
5044C-----------------------------------------------
5045 INTEGER JLT,NS_IMP(*),NE_IMP(*),IRECT(4,*),NROW(*),NSN,NIN,
5046 + SUBTRIA(*),NVOISIN(8,*)
5047C REAL
5048C-----------------------------------------------
5049C L o c a l V a r i a b l e s
5050C-----------------------------------------------
5051 INTEGER I,NE,IG,NS,IRTLM(4),NEI
5052C-----------------------------------------------
5053 DO I = 1, jlt
5054 ig = ns_imp(i)-nsn
5055 IF (ig>0) THEN
5056 ns=ind_int(nin)%P(ig)
5057 ne=ne_imp(i)
5058 IF (ne<0) THEN
5059 nei=-ne
5060 CALL i24msegv(ne,irtlm ,subtria(i),irect(1,nei),nvoisin(1,nei))
5061 ELSE
5062 irtlm(1:4) = irect(1:4,ne)
5063 END IF
5064 IF (irtlm(3)==irtlm(4)) THEN
5065 nrow(ns)=nrow(ns)+3
5066 ELSE
5067 nrow(ns)=nrow(ns)+4
5068 ENDIF
5069 ENDIF
5070 ENDDO
5071C----6---------------------------------------------------------------7---------8
5072 RETURN
5073 END
5074!||====================================================================
5075!|| rowfr_ind24 ../engine/source/mpi/implicit/imp_fri.f
5076!||--- called by ------------------------------------------------------
5077!|| ind_frkd ../engine/source/mpi/implicit/imp_fri.F
5078!||--- calls -----------------------------------------------------
5079!|| i24msegv ../engine/source/implicit/ind_glob_k.F
5080!|| reorder_a ../engine/source/implicit/ind_glob_k.F
5081!||--- uses -----------------------------------------------------
5082!|| imp_intm ../engine/share/modules/imp_intm.F
5083!||====================================================================
5084 SUBROUTINE rowfr_ind24(
5085 1 JLT ,NS_IMP ,NE_IMP ,IRECT ,NROW ,
5086 2 ICOL ,NNMAX ,NSN ,NIN ,SUBTRIA ,
5087 3 NVOISIN )
5088C-----------------------------------------------
5089C M o d u l e s
5090C-----------------------------------------------
5091 USE imp_intm
5092C----6---------------------------------------------------------------7---------8
5093C I m p l i c i t T y p e s
5094C-----------------------------------------------
5095#include "implicit_f.inc"
5096C-----------------------------------------------------------------
5097C D u m m y A r g u m e n t s
5098C-----------------------------------------------
5099 INTEGER NNMAX
5100 INTEGER JLT,NS_IMP(*),NE_IMP(*),IRECT(4,*),NROW(*),
5101 . ICOL(NNMAX,*),NSN,NIN,SUBTRIA(*),NVOISIN(8,*)
5102C REAL
5103C-----------------------------------------------
5104C L o c a l V a r i a b l e s
5105C-----------------------------------------------
5106 INTEGER I,J,NE,IG,NS,NM,IRTLM(4),NEI
5107C-----------------------------------------------
5108 DO i = 1, jlt
5109 ig = ns_imp(i)-nsn
5110 IF (ig>0) THEN
5111 ns=ind_int(nin)%P(ig)
5112 ne=ne_imp(i)
5113 IF (ne<0) THEN
5114 nei=-ne
5115 CALL i24msegv(ne,irtlm ,subtria(i),irect(1,nei),nvoisin(1,nei))
5116 ELSE
5117 irtlm(1:4) = irect(1:4,ne)
5118 END IF
5119 DO j = 1,4
5120 nm = irtlm(j)
5121 CALL reorder_a(nrow(ns),icol(1,ns),nm)
5122 ENDDO
5123 ENDIF
5124 ENDDO
5125C----6---------------------------------------------------------------7---------8
5126 RETURN
5127 END
5128!||====================================================================
5129!|| set_ind_fr ../engine/source/mpi/implicit/imp_fri.F
5130!||--- called by ------------------------------------------------------
5131!|| ind_frkd ../engine/source/mpi/implicit/imp_fri.F
5132!||--- calls -----------------------------------------------------
5133!|| zero1 ../engine/source/system/zero.F
5134!||--- uses -----------------------------------------------------
5135!|| imp_intm ../engine/share/modules/imp_intm.F
5136!||====================================================================
5137 SUBROUTINE set_ind_fr(
5138 1 NSREM ,IDDL ,NDOF ,NROW ,ICOL ,
5139 2 NNMAX )
5140C-----------------------------------------------
5141C M o d u l e s
5142C-----------------------------------------------
5143 USE imp_intm
5144C----6---------------------------------------------------------------7---------8
5145C I m p l i c i t T y p e s
5146C-----------------------------------------------
5147#include "implicit_f.inc"
5148C-----------------------------------------------------------------
5149C D u m m y A r g u m e n t s
5150C-----------------------------------------------
5151 INTEGER NNMAX
5152 INTEGER
5153 . NSREM,IDDL(*),NDOF(*),NROW(*) ,ICOL(NNMAX,*)
5154C-----------------------------------------------
5155C L o c a l V a r i a b l e s
5156C-----------------------------------------------
5157 INTEGER I,J,K,L,N,NL,NJ,NDOFI,NZ
5158 INTEGER IER1,IER2,IER3,IER4,IER5,IER6
5159c----------
5160 ndofi = 3
5161 IF(ALLOCATED(iddl_si)) DEALLOCATE(iddl_si)
5162 ALLOCATE(iddl_si(nsrem),stat=ier1)
5163 nddl_si =0
5164 DO n=1,nsrem
5165 iddl_si(n)=nddl_si
5166 nddl_si = nddl_si + ndofi
5167 ENDDO
5168 nz = 0
5169 DO n=1,nsrem
5170 DO k=1,ndofi
5171C-------termes kn,nj-------
5172 DO j=1,nrow(n)
5173 DO l=1,ndofi
5174 nz = nz+1
5175 ENDDO
5176 ENDDO
5177 ENDDO
5178 ENDDO
5179C
5180 IF(ALLOCATED(iad_si)) DEALLOCATE(iad_si)
5181 ALLOCATE(iad_si(nddl_si+1),stat=ier2)
5182 IF(ALLOCATED(jdi_si)) DEALLOCATE(jdi_si)
5183 ALLOCATE(jdi_si(nz),stat=ier3)
5184 IF(ALLOCATED(lt_si)) DEALLOCATE(lt_si)
5185 ALLOCATE(lt_si(nz),stat=ier4)
5186 CALL zero1(lt_si,nz)
5187C
5188 nl = 1
5189 nz = 0
5190 iad_si(nl) = nz+1
5191 DO n=1,nsrem
5192 DO k=1,ndofi
5193C-------termes knj,n-------
5194 DO j=1,nrow(n)
5195 nj = icol(j,n)
5196 DO l=1,ndofi
5197 nz = nz+1
5198 jdi_si(nz) = iddl(nj)+l
5199 ENDDO
5200 ENDDO
5201 nl = nl +1
5202 iad_si(nl) = nz+1
5203 ENDDO
5204 ENDDO
5205 nz_si = nz
5206C------- Save Icol in compress -------
5207 nz = 0
5208 DO n=1,nsrem
5209 nz = nz+nrow(n)
5210 ENDDO
5211 IF(ALLOCATED(iad_sinr)) DEALLOCATE(iad_sinr)
5212 ALLOCATE(iad_sinr(nsrem+1),stat=ier5)
5213 IF(ALLOCATED(jdi_sinr)) DEALLOCATE(jdi_sinr)
5214 ALLOCATE(jdi_sinr(nz),stat=ier6)
5215 nz = 0
5216 iad_sinr(1) = nz+1
5217 DO n=1,nsrem
5218 DO j=1,nrow(n)
5219 nj = icol(j,n)
5220 nz = nz+1
5221 jdi_sinr(nz) = nj
5222 ENDDO
5223 iad_sinr(n+1) = nz+1
5224 ENDDO
5225C
5226 RETURN
5227 END
5228!||====================================================================
5229!|| reorder_fr ../engine/source/mpi/implicit/imp_fri.F
5230!||--- called by ------------------------------------------------------
5231!|| ind_frkd ../engine/source/mpi/implicit/imp_fri.F
5232!||====================================================================
5233 SUBROUTINE reorder_fr(N,IC,IDDL)
5234C----6---------------------------------------------------------------7---------8
5235C I m p l i c i t T y p e s
5236C-----------------------------------------------
5237#include "implicit_f.inc"
5238C-----------------------------------------------------------------
5239C D u m m y A r g u m e n t s
5240C-----------------------------------------------
5241 INTEGER N ,IC(*),IDDL(*)
5242C-----------------------------------------------
5243C L o c a l V a r i a b l e s
5244C-----------------------------------------------
5245 INTEGER I,J,II,IT,IIC,IMIN
5246C
5247C---- In an increasing iddl order -----
5248 DO i =1,n
5249 imin=iddl(ic(i))
5250 ii=i
5251 DO j =i+1,n
5252 iic = iddl(ic(j))
5253 IF (iic<imin) THEN
5254 imin=iic
5255 ii=j
5256 ENDIF
5257 ENDDO
5258 IF (ii/=i) THEN
5259 it=ic(i)
5260 ic(i)=ic(ii)
5261 ic(ii)=it
5262 ENDIF
5263 ENDDO
5264C----6---------------------------------------------------------------7---------8
5265 RETURN
5266 END
5267!||====================================================================
5268!|| jdifrtok ../engine/source/mpi/implicit/imp_fri.F
5269!||--- uses -----------------------------------------------------
5270!|| imp_intm ../engine/share/modules/imp_intm.F
5271!||====================================================================
5272 SUBROUTINE jdifrtok(ITOK )
5273C-----------------------------------------------
5274C M o d u l e s
5275C-----------------------------------------------
5276 USE imp_intm
5277C----6---------------------------------------------------------------7---------8
5278C I m p l i c i t T y p e s
5279C-----------------------------------------------
5280#include "implicit_f.inc"
5281C-----------------------------------------------------------------
5282C D u m m y A r g u m e n t s
5283C-----------------------------------------------
5284 INTEGER ITOK(*)
5285C-----------------------------------------------
5286C L o c a l V a r i a b l e s
5287C-----------------------------------------------
5288 INTEGER I,J,NJ
5289C
5290C-----pass IDDLI to IDDLJ croisante-----
5291 DO i =1,nddl_si
5292 DO j =iad_si(i),iad_si(i+1)-1
5293 nj = jdi_si(j)
5294 jdi_si(j) = itok(nj)
5295 ENDDO
5296 ENDDO
5297C----6---------------------------------------------------------------7---------8
5298 RETURN
5299 END
5300!||====================================================================
5301!|| imp_frkd ../engine/source/mpi/implicit/imp_fri.F
5302!||--- called by ------------------------------------------------------
5303!|| imp_fri ../engine/source/mpi/implicit/imp_fri.F
5304!||--- calls -----------------------------------------------------
5305!|| cp_iadd ../engine/source/mpi/implicit/imp_fri.F
5306!|| dim_frkm ../engine/source/mpi/implicit/imp_fri.F
5307!|| dim_frkm1 ../engine/source/mpi/implicit/imp_fri.F
5308!|| dim_fvn ../engine/source/mpi/implicit/imp_fri.F
5309!|| imp_frkm ../engine/source/mpi/implicit/imp_fri.F
5310!|| imp_frks ../engine/source/mpi/implicit/imp_fri.F
5311!|| imp_frsn ../engine/source/mpi/implicit/imp_fri.F
5312!|| imp_fvkm ../engine/source/mpi/implicit/imp_fri.F
5313!|| imp_fvksl ../engine/source/mpi/implicit/imp_fri.F
5314!|| imp_fvkss ../engine/source/mpi/implicit/imp_fri.F
5315!|| ind_fvn ../engine/source/mpi/implicit/imp_fri.F
5316!|| ind_sld ../engine/source/mpi/implicit/imp_fri.F
5317!|| ini_frfd ../engine/source/mpi/implicit/imp_fri.F
5318!|| ini_frkc ../engine/source/mpi/implicit/imp_fri.F
5319!|| ini_frud ../engine/source/mpi/implicit/imp_fri.f
5320!|| ini_ksi ../engine/source/mpi/implicit/imp_fri.F
5321!|| kin_kml ../engine/source/mpi/implicit/imp_fri.F
5322!|| kin_ksl ../engine/source/mpi/implicit/imp_fri.F
5323!|| scom_frk ../engine/source/mpi/implicit/imp_fri.F
5324!|| scom_frk1 ../engine/source/mpi/implicit/imp_fri.F
5325!|| scom_frud ../engine/source/mpi/implicit/imp_fri.F
5326!|| spmd_ifc1 ../engine/source/mpi/implicit/imp_spmd.F
5327!|| spmd_ifrf ../engine/source/mpi/implicit/imp_spmd.F
5328!|| tag_intml ../engine/source/mpi/implicit/imp_fri.F
5329!|| tra_frkm ../engine/source/mpi/implicit/imp_fri.F
5330!|| upd_kml ../engine/source/mpi/implicit/imp_fri.F
5331!|| upd_ksl ../engine/source/mpi/implicit/imp_fri.F
5332!||--- uses -----------------------------------------------------
5333!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
5334!||====================================================================
5335 SUBROUTINE imp_frkd(
5336 1 NPBY ,LPBY ,ITAB ,NRBYAC ,IRBYAC ,
5337 2 IPARI ,INTBUF_TAB,NINT2 ,IINT2 ,IDDL ,
5338 3 IKC ,NDOF ,INLOC ,NSREM ,NSL ,
5339 4 NBINTC ,INTLIST ,X ,IBFV ,
5340 5 LJ ,SKEW ,XFRAME ,ISKEW ,ICODT ,
5341 6 A ,UD ,LB ,IFDIS ,URD ,
5342 7 IDDLI ,IRBE3 ,LRBE3 ,FRBE3 ,IRBE2 ,
5343 8 LRBE2 )
5344C-----------------------------------------------
5345C M o d u l e s
5346C-----------------------------------------------
5347 USE intbufdef_mod
5348C----6---------------------------------------------------------------7---------8
5349C I m p l i c i t T y p e s
5350C-----------------------------------------------
5351#include "implicit_f.inc"
5352C-----------------------------------------------
5353C C o m m o n B l o c k s
5354C-----------------------------------------------
5355#include "com01_c.inc"
5356#include "com04_c.inc"
5357#include "param_c.inc"
5358C-----------------------------------------------------------------
5359C D u m m y A r g u m e n t s
5360C-----------------------------------------------
5361 INTEGER IPARI(NPARI,*),NSREM ,NSL,NBINTC,INTLIST(*)
5362 INTEGER NPBY(NNPBY,*),LPBY(*),ITAB(*),NRBYAC,IRBYAC(*),
5363 . nint2,iint2(*),iddl(*),ikc(*),ndof(*),inloc(*),
5364 . ibfv(*),lj(*),iskew(*),icodt(*),ifdis,iddli(*),
5365 . irbe3(*),lrbe3(*),irbe2(*),lrbe2(*)
5366C REAL
5367 my_real
5368 . x(3,*),ud(3,*),a(3,*),skew(*),xframe(*),
5369 . lb(*),urd(3,*),frbe3(*)
5370 TYPE(intbuf_struct_) INTBUF_TAB(*)
5371C-----------------------------------------------
5372C L o c a l V a r i a b l e s
5373C-----------------------------------------------
5374 INTEGER LSI,LSL,IDDLM(NUMNOD),ILOCP(NUMNOD)
5375 INTEGER I,J,K,L,N,NKC,J1,ND,LSG,
5376 . nf_sl(nsl),nf_si(nsrem),n_kine,
5377 . iad_sld(nspmd+1),iad_mld(nspmd+1),
5378 . isi ,isl,nfv,lvsi,lvsl,lfsi,lfsl,nz,
5379 . ier1,ier2,ier3,ier4,ier5,ier6,ier7,lsi0
5380 my_real
5381 . kss(6,nsl)
5382 INTEGER, DIMENSION(:),ALLOCATABLE :: IAD_M,IKCSI,IKCSL,
5383 . IFVSI,IFVSL
5384 my_real, DIMENSION(:),ALLOCATABLE :: KSI_FR,KSL_FR,
5385 . udsi,udsl,fdsi
5386C------------------------------------------------------------
5387C---IKCSI(NSREM),IKCSL(NSL): initialised by NDD=sum(IKC(id+1,3)) or 21 for NDOF=0
5388C---they are updated just after by DIM_FRKM :nb of [K}3x3-> is sent in SL
5389 CALL spmd_ifc1(nsrem ,nsl ,kss)
5390C-------iddlm-----------------
5391 nkc=0
5392 isi =0
5393 lfsi = 0
5394 DO n =1,numnod
5395 i=inloc(n)
5396 iddlm(i)=iddl(i)-nkc
5397 DO j=1,ndof(i)
5398 nd = iddl(i)+j
5399 IF (ikc(nd)/=0) nkc = nkc + 1
5400 ENDDO
5401 ENDDO
5402 IF (nsl>0) THEN
5403 CALL imp_frsn(ipari ,intbuf_tab ,nbintc,intlist)
5404 ALLOCATE(iad_m(nsl+1))
5405 ENDIF
5406 DO i=1,nsrem
5407 nf_si(i) = 0
5408 ENDDO
5409C------if there is des neouds kin---IKC_SL(NSL)>0->IKC_SI----
5410 CALL ini_frkc(nsrem ,nsl ,ikc ,ndof ,iddl)
5411C------com. [Ksm] seconds remotes dependant--s.KSI;r.KSL-IKC_SI,SL->nb [Ksm]--
5412 CALL dim_frkm(nsrem ,nsl ,lsi ,lsl )
5413 lsi0 = lsi
5414 lsg = lsi+lsl
5415C due to if (NSREM+NSL>0) outside CALL SPMD_MAX_I(LSG)
5416 IF (lsg >= 0) THEN
5417 IF (ifdis>0) nfv = 0
5418 IF (lsi>0) THEN
5419 ALLOCATE(ksi_fr(9*lsi),stat=ier1)
5420 CALL ini_ksi(nsrem ,ksi_fr ,iddli )
5421 ENDIF
5422 IF (lsl>0) ALLOCATE(ksl_fr(9*lsl),stat=ier2)
5423 CALL scom_frk(ksi_fr,ksl_fr,lsi ,lsl)
5424C--------condense KSL_FR------
5425 IF (lsl>0) THEN
5426 CALL kin_ksl(
5427 1 ipari ,intbuf_tab,nint2 ,iint2 ,
5428 2 npby ,lpby ,itab ,nrbyac ,irbyac ,
5429 3 x ,ibfv ,lj ,skew ,xframe ,
5430 4 iskew ,icodt ,ndof ,ilocp ,nsl ,
5431 5 iad_m ,irbe3 ,lrbe3 ,irbe2 ,lrbe2 )
5432 lsi = iad_m(nsl+1) -iad_m(1)
5433 CALL ind_sld(nsl ,ndof ,kss )
5434C------- Use tempo ksi_fr for k_sl modifies- (handshakes) -----------------------------------------------------------
5435 IF(ALLOCATED(ksi_fr)) DEALLOCATE(ksi_fr)
5436 ALLOCATE(ksi_fr(9*lsi),stat=ier3)
5437 CALL upd_ksl(
5438 1 ipari ,intbuf_tab,nint2 ,iint2 ,
5439 2 npby ,lpby ,itab ,nrbyac ,irbyac ,
5440 3 x ,ibfv ,lj ,skew ,xframe ,
5441 4 iskew ,icodt ,ilocp ,nsl ,iad_m ,
5442 5 iddl ,ikc ,ndof ,iddlm ,ud ,
5443 6 a ,lb ,kss ,ksl_fr ,ksi_fr ,
5444 7 irbe3 ,lrbe3 ,frbe3 ,irbe2 ,lrbe2 )
5445C-------if there is imposed Ud(local second), must return UDSL->UDSI---------
5446C-------NFV: nb of /IMPVEL node in SL, use ISLM(NFV) to save node num.
5447 IF (ifdis>0) THEN
5448 CALL dim_fvn(
5449 1 ndof ,iddl ,ikc ,ilocp ,nfv )
5450 IF (nfv > 0) THEN
5451 CALL ind_fvn(
5452 1 ndof ,iddl ,ikc ,ilocp ,nfv )
5453 ALLOCATE(udsl(3*nfv))
5454C------ Change the due to the kSS and ini USLD --- Put kSS in K_SL --------------------
5455 CALL imp_fvkss(
5456 1 kss ,iddl ,iddlm ,ikc ,nsl ,
5457 2 ud ,lb ,nfv ,udsl ,ilocp ,
5458 3 ndof )
5459 ENDIF
5460 ENDIF ! IF (IFDIS>0)
5461 ENDIF ! IF (LSL>0)
5462C------- Dim for re-copy ksi_fr (k_sl modifies) a k_sl (only remains ikc = 0 -----------------------
5463 CALL dim_frkm1(nsrem,nsl ,iddl ,ikc ,ndof ,
5464 . nf_si,nf_sl,lsi ,lsl ,isi ,isl )
5465C
5466 IF (lsl>0) THEN
5467 IF(ALLOCATED(ksl_fr)) DEALLOCATE(ksl_fr)
5468 ALLOCATE(ksl_fr(9*lsl),ikcsl(3*isl),stat=ier5)
5469 IF (isl>0) ikcsl=1
5470 CALL tra_frkm(nsl ,iddl ,ikc ,ndof ,iad_m ,
5471 . ksi_fr,ksl_fr,ikcsl)
5472 IF(ALLOCATED(ksi_fr)) DEALLOCATE(ksi_fr)
5473 IF (ifdis>0) ALLOCATE(ifvsl(isl))
5474 ENDIF
5475 IF (lsi>0) THEN
5476 IF(ALLOCATED(ksi_fr)) DEALLOCATE(ksi_fr)
5477 ALLOCATE(ksi_fr(9*lsi),ikcsi(3*isi),stat=ier6)
5478 IF (ifdis>0) ALLOCATE(ifvsi(isi))
5479 ENDIF
5480C-------s: KSL_FR, r:KSI_FR :[Ksm] condense-----
5481 lsg = lsi+lsl
5482C CALL SPMD_MAX_I(LSG)
5483 IF (lsg >= 0)
5484 . CALL scom_frk1(ksl_fr,ksi_fr,nf_sl,nf_si,ikcsl,ikcsi)
5485 IF(ALLOCATED(ksl_fr)) DEALLOCATE(ksl_fr)
5486 IF (ifdis>0) THEN
5487C------- Ini lvsi for receiving UD (LVSI) ------
5488 CALL ini_frud(nsrem ,nsl ,nfv ,ifvsi ,ifvsl ,
5489 . nf_si ,nf_sl ,lvsi )
5490 IF (lvsi>0) ALLOCATE(udsi(3*lvsi))
5491 CALL scom_frud(udsl,udsi,nf_sl,nf_si,ifvsl,ifvsi)
5492C------ Modifies lb (Mi) from to [ksm]^t ', ud (si) ------
5493 IF (lvsi>0) CALL imp_fvksl(
5494 1 iddl ,iddlm ,ikc ,ifvsi ,nf_si ,
5495 2 ksi_fr ,lb ,nsrem ,udsi )
5496 IF(ALLOCATED(udsi).AND.lvsi>0) DEALLOCATE(udsi)
5497 ENDIF
5498 IF(ALLOCATED(udsl).AND.nfv>0) DEALLOCATE(udsl)
5499 IF(ALLOCATED(ifvsi).AND.isi>0) DEALLOCATE(ifvsi)
5500 IF(ALLOCATED(ifvsl).AND.isl>0) DEALLOCATE(ifvsl)
5501 IF(ALLOCATED(ikcsl).AND.isl>0) DEALLOCATE(ikcsl)
5502C
5503 ENDIF ! (LSG>0)
5504 IF (nsl>0) THEN
5505 DEALLOCATE(iad_m)
5506 CALL imp_frks(nsl ,iddl ,ikc ,ndof ,iddlm,kss ,iad_sld )
5507 ENDIF
5508C
5509 IF (ifdis>0) nfv = 0
5510 IF (nsrem>0) THEN
5511 DO n =1,numnod
5512 ilocp(n)=0
5513 ENDDO
5514C--------N_KINE: NML---LSI number of kinematic nodes-
5515 n_kine=0
5516 CALL tag_intml(nsrem ,ilocp ,n_kine ,iddl ,ikc ,ndof ,lsi)
5517 IF (lsi>0) THEN
5518 ALLOCATE(iad_m(n_kine+1))
5519 CALL kin_kml(
5520 1 ipari ,intbuf_tab,nint2 ,iint2 ,
5521 2 npby ,lpby ,itab ,nrbyac ,irbyac ,
5522 3 x ,ibfv ,lj ,skew ,xframe ,
5523 4 iskew ,icodt ,ndof ,ilocp ,nsrem ,
5524 5 iddl ,ikc ,iad_m ,n_kine ,irbe3 ,
5525 6 lrbe3 ,irbe2 ,lrbe2 )
5526C------- Use tempo ksl_fr for kml_fr modifies -------------------------------------------------
5527 lsl = iad_m(n_kine+1) -iad_m(1)
5528 ALLOCATE(ksl_fr(9*lsl),stat=ier7)
5529 CALL upd_kml(
5530 1 ipari ,intbuf_tab,nint2 ,iint2 ,
5531 2 npby ,lpby ,itab ,nrbyac ,irbyac ,
5532 3 x ,ibfv ,lj ,skew ,xframe ,
5533 4 iskew ,icodt ,ilocp ,n_kine ,iad_m ,
5534 5 iddl ,ikc ,ndof ,iddlm ,ud ,
5535 6 a ,ksl_fr ,ksi_fr ,nsrem ,nf_si ,
5536 7 iddli ,irbe3 ,lrbe3 ,frbe3 ,irbe2 ,
5537 8 lrbe2 )
5538 IF (ifdis>0) THEN
5539 CALL dim_fvn(
5540 1 ndof ,iddl ,ikc ,ilocp ,nfv )
5541 IF (nfv > 0) THEN
5542 CALL ind_fvn(
5543 1 ndof ,iddl ,ikc ,ilocp ,nfv )
5544 DO i=1,nsrem
5545 DO j =1, max(1,nf_si(i))
5546 lfsi = lfsi + 1
5547 ENDDO
5548 ENDDO
5549 ALLOCATE(fdsi(3*lfsi))
5550C------- Modifies FDSI from AU [KSM], UD (Mi) -----
5551 CALL imp_fvkm(
5552 1 ksi_fr ,ksl_fr ,iddl ,ndof ,ikc ,
5553 2 ilocp ,iad_m ,nsrem ,n_kine ,ud ,
5554 3 fdsi ,nf_si ,nfv ,lfsi ,iddli )
5555 ENDIF
5556 ENDIF
5557 ENDIF
5558 lsi = lsi + isi + lsi0
5559C-------updates [Ksm] and stores in LT_SI----
5560 CALL imp_frkm(
5561 1 nsrem ,lsi ,ikcsi ,ikc ,ndof ,
5562 2 iddl ,iddlm ,ilocp ,iad_m ,ksi_fr ,
5563 3 ksl_fr ,nf_si ,iad_mld ,iddli )
5564 ENDIF
5565 IF(ALLOCATED(iad_m)) DEALLOCATE(iad_m)
5566 IF(ALLOCATED(ksi_fr)) DEALLOCATE(ksi_fr)
5567 IF(ALLOCATED(ksl_fr)) DEALLOCATE(ksl_fr)
5568 IF (ifdis>0) CALL ini_frfd(nsrem ,nfv ,ikcsi,nf_si ,fdsi )
5569 CALL cp_iadd(nsl ,nsrem,iad_sld ,iad_mld)
5570 IF (ifdis>0) CALL spmd_ifrf(lb )
5571C ----- IAD_SL, IAD_SREM in DDL -----
5572 IF(ALLOCATED(ikcsi).AND.isi>0) DEALLOCATE(ikcsi)
5573 IF(ALLOCATED(fdsi).AND.lfsi>0) DEALLOCATE(fdsi)
5574C----6---------------------------------------------------------------7---------8
5575 RETURN
5576 END
5577!||====================================================================
5578!|| ini_frkc ../engine/source/mpi/implicit/imp_fri.F
5579!||--- called by ------------------------------------------------------
5580!|| imp_frkd ../engine/source/mpi/implicit/imp_fri.F
5581!||--- calls -----------------------------------------------------
5582!|| spmd_isr ../engine/source/mpi/implicit/imp_spmd.F
5583!||--- uses -----------------------------------------------------
5584!|| imp_intm ../engine/share/modules/imp_intm.F
5585!||====================================================================
5586 SUBROUTINE ini_frkc(NSREM ,NSL ,IKC ,NDOF ,IDDL )
5587C-----------------------------------------------
5588C M o d u l e s
5589C-----------------------------------------------
5590 USE imp_intm
5591C-----------------------------------------------
5592C I m p l i c i t T y p e s
5593C-----------------------------------------------
5594#include "implicit_f.inc"
5595C-----------------------------------------------
5596C D u m m y A r g u m e n t s
5597C-----------------------------------------------
5598 INTEGER NSREM ,NSL ,IKC(*) ,NDOF(*) ,IDDL(*)
5599C REAL
5600C-----------------------------------------------
5601C L o c a l V a r i a b l e s
5602C-----------------------------------------------
5603 INTEGER I,J,N,ID,NDD,IERROR1,IERROR2
5604C--------------------------------------------
5605 IF(ALLOCATED(ikc_sl)) DEALLOCATE(ikc_sl)
5606 ALLOCATE(ikc_sl(nsl),stat=ierror1)
5607 IF(ALLOCATED(ikc_si)) DEALLOCATE(ikc_si)
5608 ALLOCATE(ikc_si(nsrem),stat=ierror2)
5609 DO i = 1, nsl
5610 n = isl(i)
5611 id = iddl(n)
5612 ndd = 0
5613 DO j = 1 , min(3,ndof(n))
5614 ndd = ndd + ikc(id+j)
5615 ENDDO
5616 IF (ndof(n)==0) ndd = 21
5617 ikc_sl(i) = ndd
5618 ENDDO
5619C
5620 CALL spmd_isr(iad_sl,iad_srem,ikc_sl,ikc_si,nsl ,nsrem )
5621C
5622 IF (nsrem==0) nddl_si=0
5623 nddl_sl=0
5624C
5625 RETURN
5626 END
5627!||====================================================================
5628!|| dim_frkm ../engine/source/mpi/implicit/imp_fri.F
5629!||--- called by ------------------------------------------------------
5630!|| imp_frkd ../engine/source/mpi/implicit/imp_fri.F
5631!||--- calls -----------------------------------------------------
5632!|| spmd_isr ../engine/source/mpi/implicit/imp_spmd.F
5633!||--- uses -----------------------------------------------------
5634!|| imp_intm ../engine/share/modules/imp_intm.F
5635!||====================================================================
5636 SUBROUTINE dim_frkm(NSREM ,NSL ,SSIZE,RSIZE)
5637C-----------------------------------------------
5638C M o d u l e s
5639C-----------------------------------------------
5640 USE imp_intm
5641C-----------------------------------------------
5642C I m p l i c i t T y p e s
5643C-----------------------------------------------
5644#include "implicit_f.inc"
5645C-----------------------------------------------
5646C D u m m y A r g u m e n t s
5647C-----------------------------------------------
5648 INTEGER NSREM ,NSL ,SSIZE,RSIZE
5649C REAL
5650C-----------------------------------------------
5651C L o c a l V a r i a b l e s
5652C-----------------------------------------------
5653 INTEGER I,J,ID
5654C--------------------------------------------
5655C ----- Returns KSL, KSM and receives KSS, KSLM A CONDENSER
5656 ssize = 0
5657 DO i = 1, nsrem
5658 IF (ikc_si(i)>0) THEN
5659C -----number of [K}3x3--------
5660 ikc_si(i) = iad_sinr(i+1)-iad_sinr(i)
5661 ssize = ssize + ikc_si(i)
5662 ENDIF
5663 ENDDO
5664 CALL spmd_isr(iad_srem,iad_sl,ikc_si,ikc_sl,nsrem,nsl )
5665C
5666 rsize = 0
5667 DO i = 1, nsl
5668 IF (ikc_sl(i)>0) rsize = rsize + ikc_sl(i)
5669 ENDDO
5670C
5671 RETURN
5672 END
5673!||====================================================================
5674!|| ini_ksi ../engine/source/mpi/implicit/imp_fri.F
5675!||--- called by ------------------------------------------------------
5676!|| imp_frkd ../engine/source/mpi/implicit/imp_fri.F
5677!||--- calls -----------------------------------------------------
5678!|| getfr_kij ../engine/source/mpi/implicit/imp_fri.F
5679!||--- uses -----------------------------------------------------
5680!|| imp_intm ../engine/share/modules/imp_intm.F
5681!||====================================================================
5682 SUBROUTINE ini_ksi(NSREM ,KSI ,IDDL )
5683C-----------------------------------------------
5684C M o d u l e s
5685C-----------------------------------------------
5686 USE imp_intm
5687C-----------------------------------------------
5688C I m p l i c i t T y p e s
5689C-----------------------------------------------
5690#include "implicit_f.inc"
5691C-----------------------------------------------
5692C D u m m y A r g u m e n t s
5693C-----------------------------------------------
5694 INTEGER NSREM ,IDDL(*)
5695C REAL
5696 my_real
5697 . KSI(9,*)
5698C-----------------------------------------------
5699C L o c a l V a r i a b l e s
5700C-----------------------------------------------
5701 INTEGER I,J,ID,JD,NM,ND,IAD
5702C--------------------------------------------
5703 nd = 3
5704 iad = 0
5705 DO i = 1, nsrem
5706 IF (ikc_si(i)>0) THEN
5707 id = iddl_si(i)
5708 DO j = iad_sinr(i), iad_sinr(i+1)-1
5709 nm = jdi_sinr(j)
5710 jd = iddl(nm)
5711 iad = iad + 1
5712 CALL getfr_kij( id ,jd ,iad_si ,jdi_si,lt_si ,
5713 1 ksi(1,iad),nd ,nd )
5714 ENDDO
5715 ENDIF
5716 ENDDO
5717C
5718 RETURN
5719 END
5720!||====================================================================
5721!|| upd_ksl ../engine/source/mpi/implicit/imp_fri.F
5722!||--- called by ------------------------------------------------------
5723!|| imp_frkd ../engine/source/mpi/implicit/imp_fri.F
5724!||--- calls -----------------------------------------------------
5725!|| bc_updfr ../engine/source/constraints/general/bcs/bc_imp0.F
5726!|| bc_updfr2 ../engine/source/constraints/general/bcs/bc_imp0.F
5727!|| bcl_frk ../engine/source/constraints/general/bcs/bc_imp0.F
5728!|| cp_real ../engine/source/implicit/produt_v.F
5729!|| fv_updfr ../engine/source/constraints/general/impvel/fv_imp0.F
5730!|| fvl_frk ../engine/source/constraints/general/impvel/fv_imp0.F
5731!|| get_iad ../engine/source/mpi/implicit/imp_fri.F
5732!|| i2_frk0 ../engine/source/interfaces/interf/i2_imp1.F
5733!|| i2_frk1 ../engine/source/interfaces/interf/i2_imp1.F
5734!|| intabfr ../engine/source/mpi/implicit/imp_fri.F
5735!|| l_dir ../engine/source/constraints/general/bcs/bc_imp0.F
5736!|| prerbe2fr ../engine/source/constraints/general/rbe2/rbe2f.F
5737!|| prerbe3fr ../engine/source/constraints/general/rbe3/rbe3f.F
5738!|| rbe2_frk ../engine/source/constraints/general/rbe2/rbe2_imp0.F
5739!|| rbe3_fr0 ../engine/source/constraints/general/rbe3/rbe3_imp0.F
5740!|| rby_frk ../engine/source/constraints/general/rbody/rby_imp0.F
5741!||--- uses -----------------------------------------------------
5742!|| imp_aspc ../engine/share/modules/impbufdef_mod.F
5743!|| imp_intm ../engine/share/modules/imp_intm.F
5744!|| imp_rwl ../engine/share/modules/impbufdef_mod.F
5745!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
5746!||====================================================================
5747 SUBROUTINE upd_ksl(
5748 1 IPARI ,INTBUF_TAB,NINT2 ,IINT2 ,
5749 2 NPBY ,LPBY ,ITAB ,NRBYAC ,IRBYAC ,
5750 3 X ,IBFV ,LJ ,SKEW ,XFRAME ,
5751 4 ISKEW ,ICODT ,INLOC ,NSL ,IAD_M ,
5752 5 IDDL ,IKC ,NDOF ,IDDLM ,UD ,
5753 6 A ,B ,KSS ,KSL_FR ,KSI_FR ,
5754 7 IRBE3 ,LRBE3 ,FRBE3 ,IRBE2 ,LRBE2 )
5755C-----------------------------------------------
5756C M o d u l e s
5757C-----------------------------------------------
5758 USE imp_intm
5759 USE imp_rwl
5760 USE imp_aspc
5761 USE intbufdef_mod
5762C-----------------------------------------------
5763C I m p l i c i t T y p e s
5764C-----------------------------------------------
5765#include "implicit_f.inc"
5766C-----------------------------------------------
5767C C o m m o n B l o c k s
5768C-----------------------------------------------
5769#include "param_c.inc"
5770#include "tabsiz_c.inc"
5771C-----------------------------------------------
5772C D u m m y A r g u m e n t s
5773C-----------------------------------------------
5774 INTEGER IBFV(NIFV,*),IPARI(NPARI,*),NSL,IAD_M(*)
5775 INTEGER NPBY(NNPBY,*),LPBY(*),ITAB(*),NRBYAC,IRBYAC(*),
5776 . nint2,iint2(*),iddl(*),ikc(*),ndof(*),inloc(*),
5777 . lj(*),iskew(*),icodt(*),iddlm(*),irbe3(nrbe3l,*),
5778 . lrbe3(*),irbe2(nrbe2l,*),lrbe2(*)
5779C REAL
5780 my_real
5781 . x(3,*),skew(lskew,*),xframe(*),frbe3(*)
5782 my_real
5783 . ud(3,*),a(3,*),b(*) ,kss(6,*),ksl_fr(9,*) ,ksi_fr(9,*)
5784 TYPE(intbuf_struct_) INTBUF_TAB(*)
5785C-----------------------------------------------
5786C L o c a l V a r i a b l e s
5787C-----------------------------------------------
5788 INTEGER I,J,N,K,M,NS,NI,NSN,ILEV,IAD_M1(NSL+1),IS,
5789 . ji,l,nnod,nj,nd,nl,isk,ifm,j1,nm,id,iad0,iad,iads,
5790 . i1,ict,ifss,ifsm,idm(4),nr,jt(3),jr(3),irot,
5791 . idlm(slrbe3/2),iadr,nn,irad,ic,eid
5792 my_real
5793 . ej(3),ksm(9),knm(9,4),krm(9,4)
5794C----4 no more sufficient for RBE3: alloc dynamic only for IFSM=1
5795 my_real,
5796 . DIMENSION(:),ALLOCATABLE :: knm3,krm3
5797C----------Kss d'abord------------------------------
5798 ifss =1
5799 ifsm=0
5800 iad_m1(1) = 1
5801 DO n=1,nsl
5802 nl =0
5803 IF (ikc_sl(n)>0) THEN
5804 nr = iad_slnr(n+1)-iad_slnr(n)
5805 nl = max(1,nr)
5806 ENDIF
5807 iad_m1(n+1) = iad_m1(n)+nl
5808 ENDDO
5809C------int2----------------------------------
5810 DO i=ni2_fr,1,-1
5811 n=ifrs2(1,i)
5812 ni=ifrs2(2,i)
5813 ji=ipari(1,n)
5814 nsn=ipari(5,n)
5815 l=intbuf_tab(n)%IRTLM(ni)
5816 nl=4*(l-1)
5817 IF (intbuf_tab(n)%IRECTM(nl+3)==intbuf_tab(n)%IRECTM(nl+4)) THEN
5818 nnod=3
5819 ELSE
5820 nnod=4
5821 ENDIF
5822 ilev =ipari(20,n)
5823C
5824 DO is = 1,nsl
5825 IF (isl(is)==ns) THEN
5826 nr = iad_slnr(is+1)-iad_slnr(is)
5827 DO k =1,nnod
5828 nj=intbuf_tab(n)%IRECTM(nl+k)
5829 CALL intabfr(nr,jdi_slnr(iad_slnr(is)),nj,j)
5830 IF (j>0) THEN
5831 idm(k) = iddl_sl(iad_m1(is)+j-1)
5832 ELSE
5833 ENDIF
5834 ENDDO
5835 IF (ilev==1) THEN
5836 CALL i2_frk1(intbuf_tab(n)%IRECTM,intbuf_tab(n)%DPARA,x ,itab ,
5837 . intbuf_tab(n)%NSV,
5838 1 intbuf_tab(n)%IRTLM,ikc ,ndof ,iddl ,iddlm,
5839 2 iad_ss ,jdi_sl ,diag_sl,lt_sl ,b ,a ,
5840 3 kss(1,is),ksm ,knm ,krm ,ni ,
5841 4 idm ,ifss ,ifsm )
5842 ELSE
5843 CALL i2_frk0(intbuf_tab(n)%IRECTM,intbuf_tab(n)%CSTS,x ,itab ,
5844 . intbuf_tab(n)%NSV,
5845 1 intbuf_tab(n)%IRTLM,ikc ,ndof ,iddl ,iddlm,
5846 2 iad_ss ,jdi_sl ,diag_sl,lt_sl ,b ,a ,
5847 3 kss(1,is),ksm ,knm ,krm ,ni ,
5848 4 idm ,ifss ,ifsm )
5849 ENDIF
5850 ENDIF
5851 ENDDO
5852 ENDDO
5853C------RBE2-------
5854 DO i=nrbe2_fr,1,-1
5855 n=ifrs4(1,i)
5856 m=irbe2(3,n)
5857 ns=ifrs4(2,i)
5858 isk = irbe2(7,n)
5859 irad =irbe2(11,n)
5860 ic = irbe2(4,n)
5861C--------remove ICR---
5862 ic =(ic/512)*512
5863 DO is = 1,nsl
5864 IF (isl(is)==ns) THEN
5865 nr = iad_slnr(is+1)-iad_slnr(is)
5866 CALL intabfr(nr,jdi_slnr(iad_slnr(is)),m ,j)
5867 IF (j>0) THEN
5868 idm(1) = iddl_sl(iad_m1(is)+j-1)
5869 ELSE
5870 ENDIF
5871 CALL prerbe2fr(ic ,jt ,jr )
5872 CALL rbe2_frk(ns ,m ,x ,isk ,skew(1,isk) ,
5873 1 irad ,ndof ,iddl ,jt ,jr ,
5874 2 iad_ss,jdi_sl,diag_sl,lt_sl ,b ,
5875 3 a ,kss(1,is),ksm ,knm ,krm ,
5876 4 idm(1),ifss,ifsm )
5877 ENDIF
5878 ENDDO
5879 ENDDO
5880C------RBE3----------------------------------
5881 DO i=1,nrbe3_fr
5882 n=ifrs3(i)
5883 iad=irbe3(1,n)
5884 ns=irbe3(3,n)
5885 nnod=irbe3(5,n)
5886 irot =irbe3(6,n)
5887 eid=irbe3(2,n)
5888 iads = slrbe3/2+iad
5889C
5890 CALL prerbe3fr(irbe3 ,n ,jt ,jr )
5891 DO is = 1,nsl
5892 IF (isl(is)==ns) THEN
5893 nr = iad_slnr(is+1)-iad_slnr(is)
5894 DO k =1,nnod
5895 nj = lrbe3(iad+k)
5896 CALL intabfr(nr,jdi_slnr(iad_slnr(is)),nj,j)
5897 IF (j>0) THEN
5898 idlm(k) = iddl_sl(iad_m1(is)+j-1)
5899 ELSE
5900 ENDIF
5901 ENDDO
5902 CALL rbe3_fr0(ns ,nnod ,lrbe3(iad+1) ,x ,irot ,
5903 2 jt ,jr ,frbe3(6*iad+1) ,skew ,ikc ,
5904 3 ndof ,iad_ss ,jdi_sl ,diag_sl,lt_sl ,
5905 2 kss(1,is),ksm ,knm ,krm ,idlm ,
5906 3 ifss ,ifsm ,itab ,lrbe3(iads+1),eid)
5907 ENDIF
5908 ENDDO
5909 ENDDO
5910C------Rigid bodies-------
5911 DO i=nrb_fr,1,-1
5912 m=ifrsr(1,i)
5913 ns=ifrsr(2,i)
5914 DO is = 1,nsl
5915 IF (isl(is)==ns) THEN
5916 nr = iad_slnr(is+1)-iad_slnr(is)
5917 CALL intabfr(nr,jdi_slnr(iad_slnr(is)),m ,j)
5918 IF (j>0) THEN
5919 idm(1) = iddl_sl(iad_m1(is)+j-1)
5920 ELSE
5921 ENDIF
5922 CALL rby_frk(ns ,m ,x ,itab ,ikc ,
5923 1 ndof ,iddl ,iddlm,iad_ss,jdi_sl,
5924 2 diag_sl,lt_sl ,b ,a ,kss(1,is),
5925 3 ksm ,knm ,krm ,idm(1),ifss,ifsm )
5926 ENDIF
5927 ENDDO
5928 ENDDO
5929C
5930 DO i1 = 1,nbc_fr
5931 n = ibc_fr(1,i1)
5932 isk= ibc_fr(2,i1)
5933 ict= ibc_fr(3,i1)
5934 DO is = 1,nsl
5935 IF (isl(is)==n) THEN
5936 nr = iad_slnr(is+1)-iad_slnr(is)
5937 IF (nr>0) THEN
5938 CALL intabfr(nr,jdi_slnr(iad_slnr(is)),n ,j)
5939 idm(1) = iddl_sl(iad_m1(is)+j-1)
5940 ELSE
5941 idm(1) = iddl_sl(iad_m1(is))
5942 ENDIF
5943 CALL bcl_frk(n ,iddl ,iddlm ,ict ,isk ,
5944 1 skew ,ikc ,iad_ss,jdi_sl,diag_sl,
5945 2 lt_sl ,b ,a ,kss(1,is),ksm ,
5946 3 idm(1) ,ifss ,ifsm )
5947 ENDIF
5948 ENDDO
5949 ENDDO
5950C
5951 DO i1 = 1,nspc_fr
5952 n = ispc_fr(i1)
5953 i = in_spc(n)
5954 iad = 6*(n-1)+1
5955 nn = ic_spc(n)
5956 DO is = 1,nsl
5957 IF (isl(is)==i) THEN
5958 nr = iad_slnr(is+1)-iad_slnr(is)
5959 IF (nr>0) THEN
5960 CALL intabfr(nr,jdi_slnr(iad_slnr(is)),i ,j)
5961 idm(1) = iddl_sl(iad_m1(is)+j-1)
5962 ELSE
5963 idm(1) = iddl_sl(iad_m1(is))
5964 ENDIF
5965 IF (nn==1) THEN
5966 ej(1)=skew_spc(iad)
5967 ej(2)=skew_spc(iad+1)
5968 ej(3)=skew_spc(iad+2)
5969 CALL l_dir(ej,j)
5970 CALL bc_updfr(i ,iddl ,ej ,j ,iddlm ,
5971 1 ikc ,iad_ss,jdi_sl,diag_sl,lt_sl ,
5972 2 b ,a ,kss(1,is),ksm ,idm(1),
5973 3 ifss ,ifsm )
5974 ELSE
5975 CALL bc_updfr2(i ,iddl ,skew_spc(iad),skew_spc(iad+3),
5976 1 iddlm ,ikc ,iad_ss,jdi_sl,diag_sl,lt_sl ,
5977 2 b ,a ,kss(1,is),ksm ,idm(1),
5978 3 ifss ,ifsm )
5979 END IF
5980 ENDIF
5981 ENDDO
5982 ENDDO
5983C
5984 IF (nfx_fr>0) THEN
5985 DO l=1,nfx_fr
5986 i = ifx_fr(1,l)
5987 j1 = ifx_fr(2,l)
5988 n=iabs(ibfv(1,i))
5989 DO is = 1,nsl
5990 IF (isl(is)==n) THEN
5991 nr = iad_slnr(is+1)-iad_slnr(is)
5992 IF (nr>0) THEN
5993 CALL intabfr(nr,jdi_slnr(iad_slnr(is)),n ,j)
5994 idm(1) = iddl_sl(iad_m1(is)+j-1)
5995 ELSE
5996 idm(1) = iddl_sl(iad_m1(is))
5997 ENDIF
5998 CALL fvl_frk(j1 ,i ,ibfv ,skew ,xframe,
5999 1 iddl ,iddlm ,ikc ,iad_ss ,jdi_sl,
6000 2 diag_sl ,lt_sl ,ud ,b ,a ,
6001 3 kss(1,is),ksm ,idm(1) ,ifss ,ifsm )
6002 ENDIF
6003 ENDDO
6004 ENDDO
6005 ENDIF
6006C
6007 DO l = 1,nrw_fr
6008 i = irw_fr(l)
6009 n=in_rwl(i)
6010 ej(1)=nor_rwl(1,i)
6011 ej(2)=nor_rwl(2,i)
6012 ej(3)=nor_rwl(3,i)
6013 CALL l_dir(ej,j1)
6014 DO is = 1,nsl
6015 IF (isl(is)==n) THEN
6016 nr = iad_slnr(is+1)-iad_slnr(is)
6017 IF (nr>0) THEN
6018 CALL intabfr(nr,jdi_slnr(iad_slnr(is)),n ,j)
6019 idm(1) = iddl_sl(iad_m1(is)+j-1)
6020 ELSE
6021 idm(1) = iddl_sl(iad_m1(is))
6022 ENDIF
6023 CALL fv_updfr(n ,ej ,j1 ,iddl ,iddlm ,
6024 1 ikc ,iad_ss,jdi_sl,diag_sl,lt_sl ,
6025 2 ud ,b ,a ,kss(1,is),ksm ,
6026 3 idm(1) ,ifss ,ifsm)
6027 ENDIF
6028 ENDDO
6029 ENDDO
6030C----------Ksm ------------------------------
6031 ifss = 0
6032 ifsm = 1
6033 iad_m1(1) = 0
6034 DO n=1,nsl
6035 iad_m1(n+1) = iad_m1(n)+ikc_sl(n)
6036 ENDDO
6037C------copy KSL_FR to KSI_FR-(for kin without modification-----
6038 DO i = 1,nsl
6039 ns = isl(i)
6040 DO j = 1,ikc_sl(i)
6041 iad = iad_m1(i)+j
6042 CALL cp_real(9,ksl_fr(1,iad),ksm)
6043 CALL get_iad(iad_m ,iad_slnr,jdi_slnr,ns ,i ,
6044 1 j ,ikc_sl(i),ndof ,iad )
6045 IF (iad>0) CALL cp_real(9,ksm,ksi_fr(1,iad))
6046 ENDDO
6047 ENDDO
6048C
6049 DO i=ni2_fr,1,-1
6050 n=ifrs2(1,i)
6051 ni=ifrs2(2,i)
6052 ji=ipari(1,n)
6053 nsn=ipari(5,n)
6054 l=intbuf_tab(n)%IRTLM(ni)
6055 nl=4*(l-1)
6056 IF (intbuf_tab(n)%IRECTM(nl+3)==intbuf_tab(n)%IRECTM(nl+4)) THEN
6057 nnod=3
6058 ELSE
6059 nnod=4
6060 ENDIF
6061 ilev =ipari(20,n)
6062C
6063 DO is = 1,nsl
6064 IF (isl(is)==ns) THEN
6065 DO j = 1,ikc_sl(is)
6066C----------------int2 herarch-------
6067 IF (inloc(ns)>nsl) THEN
6068 CALL get_iad(iad_m ,iad_slnr,jdi_slnr,ns ,is ,
6069 1 j ,ikc_sl(is),ndof ,iad )
6070 CALL cp_real(9,ksi_fr(1,iad),ksm)
6071 ELSE
6072 iad = iad_m1(is)+j
6073 CALL cp_real(9,ksl_fr(1,iad),ksm)
6074 ENDIF
6075 IF (ilev==1) THEN
6076 CALL i2_frk1(intbuf_tab(n)%IRECTM,intbuf_tab(n)%DPARA,x ,itab ,
6077 . intbuf_tab(n)%NSV,
6078 1 intbuf_tab(n)%IRTLM,ikc ,ndof ,iddl ,iddlm,
6079 2 iad_ss ,jdi_sl ,diag_sl,lt_sl ,b ,a ,
6080 3 kss(1,is),ksm ,knm ,krm ,ni ,
6081 4 idm ,ifss ,ifsm )
6082 ELSE
6083 CALL i2_frk0(intbuf_tab(n)%IRECTM,intbuf_tab(n)%CSTS,x ,itab ,
6084 . intbuf_tab(n)%NSV,
6085 1 intbuf_tab(n)%IRTLM,ikc ,ndof ,iddl ,iddlm,
6086 2 iad_ss ,jdi_sl ,diag_sl,lt_sl ,b ,a ,
6087 3 kss(1,is),ksm ,knm ,krm ,ni ,
6088 4 idm ,ifss ,ifsm )
6089 ENDIF
6090 DO k =1,nnod
6091 nj=intbuf_tab(n)%IRECTM(nl+k)
6092 CALL get_iad(iad_m ,iad_slnr,jdi_slnr,nj ,is ,
6093 1 j ,ikc_sl(is),ndof ,iad )
6094 CALL cp_real(9,knm(1,k),ksi_fr(1,iad))
6095 IF (ndof(nj)==6)CALL cp_real(9,krm(1,k),ksi_fr(1,iad+1))
6096 ENDDO
6097 ENDDO
6098 ENDIF
6099 ENDDO
6100 ENDDO
6101C------RBE2-------
6102 DO i=nrbe2_fr,1,-1
6103 n=ifrs4(1,i)
6104 m=irbe2(3,n)
6105 ns=ifrs4(2,i)
6106 isk = irbe2(7,n)
6107 irad =irbe2(11,n)
6108 ic =irbe2(4,n)
6109C--------remove ICR---
6110 ic =(ic/512)*512
6111 DO is = 1,nsl
6112 IF (isl(is)==ns) THEN
6113 DO j = 1,ikc_sl(is)
6114C----------------ns main int2 -------
6115 IF (inloc(ns)>nsl) THEN
6116 CALL get_iad(iad_m ,iad_slnr,jdi_slnr,ns ,is ,
6117 1 j ,ikc_sl(is),ndof ,iad )
6118 CALL cp_real(9,ksi_fr(1,iad),ksm)
6119 ELSE
6120 iad = iad_m1(is)+j
6121 CALL cp_real(9,ksl_fr(1,iad),ksm)
6122 ENDIF
6123 CALL prerbe2fr(ic ,jt ,jr )
6124 CALL rbe2_frk(ns ,m ,x ,isk ,skew(1,isk) ,
6125 1 irad ,ndof ,iddl ,jt ,jr ,
6126 2 iad_ss,jdi_sl,diag_sl,lt_sl ,b ,
6127 3 a ,kss(1,is),ksm ,knm ,krm ,
6128 4 idm(1),ifss,ifsm )
6129 CALL get_iad(iad_m ,iad_slnr,jdi_slnr,m ,is ,
6130 1 j ,ikc_sl(is),ndof ,iad )
6131 CALL cp_real(9,knm,ksi_fr(1,iad))
6132 CALL cp_real(9,krm,ksi_fr(1,iad+1))
6133 ENDDO
6134 ENDIF
6135 ENDDO
6136 ENDDO
6137C ------RBE3
6138 DO i=1,nrbe3_fr
6139 n=ifrs3(i)
6140 iadr=irbe3(1,n)
6141 ns=irbe3(3,n)
6142 nnod=irbe3(5,n)
6143 irot =irbe3(6,n)
6144 eid=irbe3(2,n)
6145 iads = slrbe3/2+iadr
6146 CALL prerbe3fr(irbe3 ,n ,jt ,jr )
6147 ALLOCATE(knm3(9*nnod))
6148 IF (irot>0) ALLOCATE(krm3(9*nnod))
6149C
6150 DO is = 1,nsl
6151 IF (isl(is)==ns) THEN
6152 DO j = 1,ikc_sl(is)
6153C----------------int2 herarch-------
6154 IF (inloc(ns)>nsl) THEN
6155 CALL get_iad(iad_m ,iad_slnr,jdi_slnr,ns ,is ,
6156 1 j ,ikc_sl(is),ndof ,iad )
6157 CALL cp_real(9,ksi_fr(1,iad),ksm)
6158 ELSE
6159 iad = iad_m1(is)+j
6160 CALL cp_real(9,ksl_fr(1,iad),ksm)
6161 ENDIF
6162 CALL rbe3_fr0(ns ,nnod ,lrbe3(iadr+1) ,x ,irot ,
6163 2 jt ,jr ,frbe3(6*iadr+1) ,skew ,ikc ,
6164 3 ndof ,iad_ss ,jdi_sl ,diag_sl,lt_sl ,
6165 2 kss(1,is),ksm ,knm3 ,krm3 ,idlm ,
6166 3 ifss ,ifsm ,itab ,lrbe3(iads+1),eid)
6167 DO k =1,nnod
6168 nj = lrbe3(iadr+k)
6169 CALL get_iad(iad_m ,iad_slnr,jdi_slnr,nj ,is ,
6170 1 j ,ikc_sl(is),ndof ,iad )
6171 id = 9*(k-1) +1
6172 CALL cp_real(9,knm3(id),ksi_fr(1,iad))
6173 IF (irot>0.AND.ndof(nj)==6)
6174 + CALL cp_real(9,krm3(id),ksi_fr(1,iad+1))
6175 ENDDO
6176 ENDDO
6177 ENDIF
6178 ENDDO
6179 DEALLOCATE(knm3)
6180 IF (irot>0) DEALLOCATE(krm3)
6181 ENDDO
6182C------Rigid bodies-------
6183 DO i=nrb_fr,1,-1
6184 m=ifrsr(1,i)
6185 ns=ifrsr(2,i)
6186 DO is = 1,nsl
6187 IF (isl(is)==ns) THEN
6188 DO j = 1,ikc_sl(is)
6189C----------------ns main int2 -------
6190 IF (inloc(ns)>nsl) THEN
6191 CALL get_iad(iad_m ,iad_slnr,jdi_slnr,ns ,is ,
6192 1 j ,ikc_sl(is),ndof ,iad )
6193 CALL cp_real(9,ksi_fr(1,iad),ksm)
6194 ELSE
6195 iad = iad_m1(is)+j
6196 CALL cp_real(9,ksl_fr(1,iad),ksm)
6197 ENDIF
6198 CALL rby_frk(ns ,m ,x ,itab ,ikc ,
6199 1 ndof ,iddl ,iddlm,iad_ss,jdi_sl,
6200 2 diag_sl,lt_sl ,b ,a ,kss(1,is),
6201 3 ksm ,knm ,krm ,idm(1),ifss,ifsm )
6202 CALL get_iad(iad_m ,iad_slnr,jdi_slnr,m ,is ,
6203 1 j ,ikc_sl(is),ndof ,iad )
6204 CALL cp_real(9,knm,ksi_fr(1,iad))
6205 CALL cp_real(9,krm,ksi_fr(1,iad+1))
6206 ENDDO
6207 ENDIF
6208 ENDDO
6209 ENDDO
6210C
6211 DO i1 = 1,nbc_fr
6212 n = ibc_fr(1,i1)
6213 isk= ibc_fr(2,i1)
6214 ict= ibc_fr(3,i1)
6215 DO is = 1,nsl
6216 IF (isl(is)==n) THEN
6217 DO j = 1,ikc_sl(is)
6218 IF (inloc(n)>nsl) THEN
6219 CALL get_iad(iad_m ,iad_slnr,jdi_slnr,n ,is ,
6220 1 j ,ikc_sl(is),ndof ,iad )
6221 CALL cp_real(9,ksi_fr(1,iad),ksm)
6222 ELSE
6223 iad = iad_m1(is)+j
6224 CALL cp_real(9,ksl_fr(1,iad),ksm)
6225 ENDIF
6226 CALL bcl_frk(n ,iddl ,iddlm ,ict ,isk ,
6227 1 skew ,ikc ,iad_ss,jdi_sl,diag_sl,
6228 2 lt_sl ,b ,a ,kss(1,is),ksm ,
6229 3 idm(1) ,ifss ,ifsm )
6230 IF (inloc(n)<=nsl) THEN
6231 CALL get_iad(iad_m ,iad_slnr,jdi_slnr,n ,is ,
6232 1 j ,ikc_sl(is),ndof ,iad )
6233 ENDIF
6234 CALL cp_real(9,ksm,ksi_fr(1,iad))
6235 ENDDO
6236 ENDIF
6237 ENDDO
6238 ENDDO
6239C
6240 DO i1 = 1,nspc_fr
6241 n = ispc_fr(i1)
6242 i = in_spc(n)
6243 iadr = 6*(n-1)+1
6244 nn = ic_spc(n)
6245 DO is = 1,nsl
6246 IF (isl(is)==i) THEN
6247 DO j = 1,ikc_sl(is)
6248 IF (inloc(i)>nsl) THEN
6249 CALL get_iad(iad_m ,iad_slnr,jdi_slnr,i ,is ,
6250 1 j ,ikc_sl(is),ndof ,iad )
6251 CALL cp_real(9,ksi_fr(1,iad),ksm)
6252 ELSE
6253 iad = iad_m1(is)+j
6254 CALL cp_real(9,ksl_fr(1,iad),ksm)
6255 ENDIF
6256 IF (nn==1) THEN
6257 ej(1)=skew_spc(iadr)
6258 ej(2)=skew_spc(iadr+1)
6259 ej(3)=skew_spc(iadr+2)
6260 CALL l_dir(ej,ji)
6261 CALL bc_updfr(i ,iddl ,ej ,ji ,iddlm ,
6262 1 ikc ,iad_ss,jdi_sl,diag_sl,lt_sl ,
6263 2 b ,a ,kss(1,is),ksm ,idm(1),
6264 3 ifss ,ifsm )
6265 ELSE
6266 CALL bc_updfr2(i ,iddl ,skew_spc(iadr),skew_spc(iadr+3),
6267 1 iddlm ,ikc ,iad_ss,jdi_sl,diag_sl,lt_sl ,
6268 2 b ,a ,kss(1,is),ksm ,idm(1),
6269 3 ifss ,ifsm )
6270 END IF
6271 IF (inloc(i)<=nsl) THEN
6272 CALL get_iad(iad_m ,iad_slnr,jdi_slnr,i ,is ,
6273 1 j ,ikc_sl(is),ndof ,iad )
6274 ENDIF
6275 CALL cp_real(9,ksm,ksi_fr(1,iad))
6276 ENDDO
6277 ENDIF
6278 ENDDO
6279 ENDDO
6280C
6281 IF (nfx_fr>0) THEN
6282 DO l=1,nfx_fr
6283 i = ifx_fr(1,l)
6284 j1 = ifx_fr(2,l)
6285 n=iabs(ibfv(1,i))
6286 DO is = 1,nsl
6287 IF (isl(is)==n) THEN
6288 DO j = 1,ikc_sl(is)
6289 IF (inloc(n)>nsl) THEN
6290 CALL get_iad(iad_m ,iad_slnr,jdi_slnr,n ,is ,
6291 1 j ,ikc_sl(is),ndof ,iad )
6292 CALL cp_real(9,ksi_fr(1,iad),ksm)
6293 ELSE
6294 iad = iad_m1(is)+j
6295 CALL cp_real(9,ksl_fr(1,iad),ksm)
6296 ENDIF
6297 CALL fvl_frk(j1 ,i ,ibfv ,skew ,xframe,
6298 1 iddl ,iddlm ,ikc ,iad_ss ,jdi_sl,
6299 2 diag_sl ,lt_sl ,ud ,b ,a ,
6300 3 kss(1,is),ksm ,idm ,ifss ,ifsm )
6301 IF (inloc(n)<=nsl) THEN
6302 CALL get_iad(iad_m ,iad_slnr,jdi_slnr,n ,is ,
6303 1 j ,ikc_sl(is),ndof ,iad )
6304 ENDIF
6305 CALL cp_real(9,ksm,ksi_fr(1,iad))
6306 ENDDO
6307 ENDIF
6308 ENDDO
6309 ENDDO
6310 ENDIF
6311C
6312 DO l = 1,nrw_fr
6313 i = irw_fr(l)
6314 n=in_rwl(i)
6315 ej(1)=nor_rwl(1,i)
6316 ej(2)=nor_rwl(2,i)
6317 ej(3)=nor_rwl(3,i)
6318 CALL l_dir(ej,j1)
6319 DO is = 1,nsl
6320 IF (isl(is)==n) THEN
6321 DO j = 1,ikc_sl(is)
6322 IF (inloc(n)>nsl) THEN
6323 CALL get_iad(iad_m ,iad_slnr,jdi_slnr,n ,is ,
6324 1 j ,ikc_sl(is),ndof ,iad )
6325 CALL cp_real(9,ksi_fr(1,iad),ksm)
6326 ELSE
6327 iad = iad_m1(is)+j
6328 CALL cp_real(9,ksl_fr(1,iad),ksm)
6329 ENDIF
6330 CALL fv_updfr(n ,ej ,j1 ,iddl ,iddlm ,
6331 1 ikc ,iad_ss,jdi_sl,diag_sl,lt_sl ,
6332 2 ud ,b ,a ,kss(1,is),ksm ,
6333 3 idm(1) ,ifss ,ifsm)
6334 IF (inloc(n)<=nsl) THEN
6335 CALL get_iad(iad_m ,iad_slnr,jdi_slnr,n ,is ,
6336 1 j ,ikc_sl(is),ndof ,iad )
6337 ENDIF
6338 CALL cp_real(9,ksm,ksi_fr(1,iad))
6339 ENDDO
6340 ENDIF
6341 ENDDO
6342 ENDDO
6343C--------------------------------------------
6344C
6345 RETURN
6346 END
6347!||====================================================================
6348!|| assem_ksl ../engine/source/mpi/implicit/imp_fri.F
6349!||--- calls -----------------------------------------------------
6350!|| assem_kii ../engine/source/implicit/imp_glob_k.F
6351!||--- uses -----------------------------------------------------
6352!|| imp_intm ../engine/share/modules/imp_intm.F
6353!||====================================================================
6354 SUBROUTINE assem_ksl(IDDL ,K_DIAG ,K_LT ,IADK ,
6355 1 JDIK ,KSS ,NSL )
6356C-----------------------------------------------
6357C M o d u l e s
6358C-----------------------------------------------
6359 USE imp_intm
6360C-----------------------------------------------
6361C I m p l i c i t T y p e s
6362C-----------------------------------------------
6363#include "implicit_f.inc"
6364C-----------------------------------------------
6365C G l o b a l P a r a m e t e r s
6366C-----------------------------------------------
6367#include "mvsiz_p.inc"
6368#include "param_c.inc"
6369C-----------------------------------------------
6370C D u m m y A r g u m e n t s
6371C-----------------------------------------------
6372 integer
6373 . iddl(*) ,iadk(*) ,jdik(*),nsl
6374 my_real
6375 . k_diag(*) ,k_lt(*) ,kss(6,*)
6376C-----------------------------------------------
6377C L o c a l V a r i a b l e s
6378C-----------------------------------------------
6379 INTEGER I, JLT , NFT ,ND ,J,N0,JLT_NEW,IS
6380 my_real
6381 . k11(3,3,mvsiz),off(mvsiz)
6382C------------------------------------
6383 nd = 3
6384 DO nft = 0 , nsl - 1 , nvsiz
6385 jlt = min( nvsiz, nsl - nft )
6386 jlt_new = 0
6387 DO i = 1 , jlt
6388 is = nft+i
6389 IF (ikc_si(is)==0) THEN
6390 jlt_new = jlt_new + 1
6391 DO j = 1 , 3
6392 k11(j,j,jlt_new) = kss(j,is)
6393 ENDDO
6394 k11(1,2,jlt_new) = kss(4,is)
6395 k11(1,3,jlt_new) = kss(5,is)
6396 k11(2,3,jlt_new) = kss(6,is)
6397 off(jlt_new) = one
6398 ENDIF
6399 ENDDO
6400 jlt = jlt_new
6401 CALL assem_kii(isl(nft+1),jlt,iddl,iadk,k_diag,k_lt,k11,nd,off)
6402 ENDDO
6403C----6---------------------------------------------------------------7---------8
6404 RETURN
6405 END
6406!||====================================================================
6407!|| assfr_kij ../engine/source/mpi/implicit/imp_fri.F
6408!||--- called by ------------------------------------------------------
6409!|| ass_spmd ../engine/source/implicit/assem_int.F
6410!|| ass_spmd11 ../engine/source/implicit/assem_int.F
6411!||====================================================================
6412 SUBROUTINE assfr_kij( ID ,JD ,IADK ,JDIK,K_LT ,
6413 1 KIJ ,ND )
6414C----6---------------------------------------------------------------7---------8
6415C I m p l i c i t T y p e s
6416C-----------------------------------------------
6417#include "implicit_f.inc"
6418C-----------------------------------------------------------------
6419C D u m m y A r g u m e n t s
6420C-----------------------------------------------
6421 INTEGER ND
6422 INTEGER ID,JD,IADK(*),JDIK(*)
6423C REAL
6424 my_real
6425 . k_lt(*) ,kij(nd,nd)
6426C-----------------------------------------------
6427C L o c a l V a r i a b l e s
6428C-----------------------------------------------
6429 INTEGER I,J,K,JDL,L,JJ
6430C----6---------------------------------------------------------------7---------8
6431 DO k=1,nd
6432 jdl= -1
6433 DO jj = iadk(id+k),iadk(id+1+k)-1
6434C-------- Find l'Address in LT -----
6435 IF (jdik(jj)==(jd+1)) THEN
6436 jdl = jj-1
6437 GOTO 300
6438 ENDIF
6439 ENDDO
6440 300 CONTINUE
6441 IF (jdl>=0) THEN
6442 DO l=1,nd
6443 k_lt(jdl+l) = k_lt(jdl+l) + kij(k,l)
6444 ENDDO
6445 ELSE
6446 ENDIF
6447 ENDDO
6448C
6449C----6---------------------------------------------------------------7---------8
6450 RETURN
6451 END
6452!||====================================================================
6453!|| getfr_kij ../engine/source/mpi/implicit/imp_fri.F
6454!||--- called by ------------------------------------------------------
6455!|| imp_frkm ../engine/source/mpi/implicit/imp_fri.F
6456!|| imp_fvkm ../engine/source/mpi/implicit/imp_fri.F
6457!|| ini_ksi ../engine/source/mpi/implicit/imp_fri.F
6458!|| upd_kml ../engine/source/mpi/implicit/imp_fri.F
6459!||====================================================================
6460 SUBROUTINE getfr_kij( ID ,JD ,IADK ,JDIK,K_LT ,
6461 1 KIJ ,NK ,NL )
6462C----6---------------------------------------------------------------7---------8
6463C I m p l i c i t T y p e s
6464C-----------------------------------------------
6465#include "implicit_f.inc"
6466C-----------------------------------------------------------------
6467C D u m m y A r g u m e n t s
6468C-----------------------------------------------
6469 INTEGER NK ,NL
6470 INTEGER ID,JD,IADK(*),JDIK(*)
6471C REAL
6472 my_real
6473 . K_LT(*) ,KIJ(NK,NL)
6474C-----------------------------------------------
6475C L o c a l V a r i a b l e s
6476C-----------------------------------------------
6477 INTEGER I,J,K,JDL,L,JJ
6478C----6---------------------------------------------------------------7---------8
6479 DO K=1,nk
6480 jdl=-1
6481 DO jj = iadk(id+k),iadk(id+1+k)-1
6482C-------- Find l'Address in LT -----
6483 IF (jdik(jj)==(jd+1)) THEN
6484 jdl = jj-1
6485 GOTO 300
6486 ENDIF
6487 ENDDO
6488 300 CONTINUE
6489 IF (jdl>=0) THEN
6490 DO l=1,nl
6491 kij(k,l) = k_lt(jdl+l)
6492 ENDDO
6493 ELSE
6494 ENDIF
6495 ENDDO
6496C
6497C----6---------------------------------------------------------------7---------8
6498 RETURN
6499 END
6500!||====================================================================
6501!|| putfr_kij ../engine/source/mpi/implicit/imp_fri.F
6502!||====================================================================
6503 SUBROUTINE putfr_kij( ID ,JD ,IADK ,JDIK,K_LT ,
6504 1 KIJ ,NK ,NL )
6505C----6---------------------------------------------------------------7---------8
6506C I m p l i c i t T y p e s
6507C-----------------------------------------------
6508#include "implicit_f.inc"
6509C-----------------------------------------------------------------
6510C D u m m y A r g u m e n t s
6511C-----------------------------------------------
6512 INTEGER NK ,NL
6513 INTEGER ID,JD,IADK(*),JDIK(*)
6514C REAL
6515 my_real
6516 . k_lt(*) ,kij(nk,nl)
6517C-----------------------------------------------
6518C L o c a l V a r i a b l e s
6519C-----------------------------------------------
6520 INTEGER I,J,K,JDL,L,JJ
6521C----6---------------------------------------------------------------7---------8
6522 DO k=1,nk
6523 jdl=0
6524 DO jj = iadk(id+k),iadk(id+1+k)-1
6525C-------- Find l'Address in LT -----
6526 IF (jdik(jj)==(jd+1)) THEN
6527 jdl = jj-1
6528 GOTO 300
6529 ENDIF
6530 ENDDO
6531 300 CONTINUE
6532 DO l=1,nl
6533 k_lt(jdl+l) = kij(k,l)
6534 ENDDO
6535 ENDDO
6536C
6537C----6---------------------------------------------------------------7---------8
6538 RETURN
6539 END
6540!||====================================================================
6541!|| kin_ksl ../engine/source/mpi/implicit/imp_fri.F
6542!||--- called by ------------------------------------------------------
6543!|| imp_frkd ../engine/source/mpi/implicit/imp_fri.F
6544!||--- calls -----------------------------------------------------
6545!|| dim_kinfrk ../engine/source/mpi/implicit/imp_fri.F
6546!|| doub_nrs ../engine/source/mpi/implicit/imp_fri.F
6547!|| ind_kinfrk ../engine/source/mpi/implicit/imp_fri.F
6548!|| ini_slnr ../engine/source/mpi/implicit/imp_fri.F
6549!|| tag_ints ../engine/source/mpi/implicit/imp_fri.F
6550!||--- uses -----------------------------------------------------
6551!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
6552!||====================================================================
6553 SUBROUTINE kin_ksl(
6554 1 IPARI ,INTBUF_TAB,NINT2 ,IINT2 ,
6555 2 NPBY ,LPBY ,ITAB ,NRBYAC ,IRBYAC ,
6556 3 X ,IBFV ,LJ ,SKEW ,XFRAME ,
6557 4 ISKEW ,ICODT ,NDOF ,ILOCP ,NSL ,
6558 5 IAD_M ,IRBE3 ,LRBE3 ,IRBE2 ,LRBE2 )
6559C-----------------------------------------------
6560C M o d u l e s
6561C-----------------------------------------------
6562 USE intbufdef_mod
6563C----6---------------------------------------------------------------7---------8
6564C I m p l i c i t T y p e s
6565C-----------------------------------------------
6566#include "implicit_f.inc"
6567C-----------------------------------------------
6568C C o m m o n B l o c k s
6569C-----------------------------------------------
6570#include "com04_c.inc"
6571#include "param_c.inc"
6572C-----------------------------------------------------------------
6573C D u m m y A r g u m e n t s
6574C-----------------------------------------------
6575 INTEGER IPARI(NPARI,*),NSL
6576 INTEGER NPBY(NNPBY,*),LPBY(*),ITAB(*),NRBYAC,IRBYAC(*),
6577 . NINT2,IINT2(*),ILOCP(*),NDOF(*) ,
6578 . IBFV(*),LJ(*),ISKEW(*),ICODT(*),IAD_M(*),
6579 . irbe3(*),lrbe3(*),irbe2(*),lrbe2(*)
6580C REAL
6581 my_real
6582 . x(3,*),skew(*),xframe(*)
6583 TYPE(intbuf_struct_) INTBUF_TAB(*)
6584C-----------------------------------------------
6585C L o c a l V a r i a b l e s
6586C-----------------------------------------------
6587 INTEGER LNS,LNS2,NNMAX,NZ,LNS3,LNS4
6588 INTEGER I,J,K,L,N_KINE,IA2(NINT2),IA(NRBYAC),NRS(NSL)
6589 INTEGER, DIMENSION(:,:), ALLOCATABLE :: ICOL
6590C------------------------------------------------------------
6591 DO I =1,numnod
6592 ilocp(i)=0
6593 ENDDO
6594C--------N_KINE: nm, sl (no double)----
6595 n_kine=0
6596 CALL tag_ints(nsl ,ilocp ,n_kine)
6597C
6598 DO i=1,nsl
6599 nrs(i) = 0
6600 ENDDO
6601 CALL dim_kinfrk(
6602 1 npby ,lpby ,itab ,nrbyac ,irbyac ,
6603 2 nint2 ,iint2 ,ipari ,intbuf_tab,ilocp ,
6604 3 ia ,ia2 ,nrs ,lns ,lns2 ,
6605 4 nsl ,irbe3 ,lrbe3 ,lns3 ,irbe2 ,
6606 5 lrbe2 ,lns4 )
6607C
6608 nnmax=0
6609 DO i=1,nsl
6610 nnmax=max(nnmax,nrs(i))
6611 nrs(i)=0
6612 ENDDO
6613 ALLOCATE(icol(nnmax,nsl))
6614 CALL ind_kinfrk(
6615 1 npby ,lpby ,itab ,nrbyac ,irbyac ,
6616 2 nint2 ,iint2 ,ipari ,intbuf_tab,ilocp ,
6617 3 ia ,ia2 ,lns ,lns2 ,nsl ,
6618 4 ibfv ,lj ,iskew ,icodt ,nrs ,
6619 5 icol ,nnmax ,irbe3 ,lrbe3 ,lns3 ,
6620 6 irbe2 ,lrbe2 ,lns4 )
6621C
6622 CALL doub_nrs(nsl ,nnmax ,nrs ,icol ,ilocp )
6623 nz = 0
6624 DO i=1,nsl
6625 DO j=1,nrs(i)
6626 nz = nz+1
6627 ENDDO
6628 ENDDO
6629 CALL ini_slnr(nsl ,nnmax ,nrs ,icol ,nz ,
6630 . ndof ,iad_m )
6631 DEALLOCATE(icol)
6632C----6---------------------------------------------------------------7---------8
6633 RETURN
6634 END
6635!||====================================================================
6636!|| doub_nrs ../engine/source/mpi/implicit/imp_fri.F
6637!||--- called by ------------------------------------------------------
6638!|| kin_ksl ../engine/source/mpi/implicit/imp_fri.F
6639!||--- calls -----------------------------------------------------
6640!|| cp_int ../engine/source/implicit/produt_v.F
6641!||--- uses -----------------------------------------------------
6642!|| imp_intm ../engine/share/modules/imp_intm.F
6643!||====================================================================
6644 SUBROUTINE doub_nrs(NSL ,NNMAX ,NRS ,ICOL ,ILOCP )
6645C-----------------------------------------------
6646C M o d u l e s
6647C-----------------------------------------------
6648 USE imp_intm
6649C----6---------------------------------------------------------------7---------8
6650C I m p l i c i t T y p e s
6651C-----------------------------------------------
6652#include "implicit_f.inc"
6653C-----------------------------------------------------------------
6654C D u m m y A r g u m e n t s
6655C-----------------------------------------------
6656 INTEGER NSL,NNMAX ,NRS(*),ILOCP(*)
6657 INTEGER ICOL(NNMAX,*)
6658C REAL
6659C-----------------------------------------------
6660C L o c a l V a r i a b l e s
6661C-----------------------------------------------
6662 integer
6663 . i,j,k,n,nj
6664C----------------------------
6665C--- Double part-Diff.srem since [K] Rem is Dja Built
6666 DO i=1,nsl
6667 n = isl(i)
6668 k = ilocp(n)
6669 IF (nrs(i)<nrs(k)) THEN
6670 CALL cp_int(nrs(k),icol(1,k),icol(1,i))
6671 nrs(i) = nrs(k)
6672 ENDIF
6673 ENDDO
6674C----6---------------------------------------------------------------7---------8
6675 RETURN
6676 END
6677!||====================================================================
6678!|| ini_slnr ../engine/source/mpi/implicit/imp_fri.F
6679!||--- called by ------------------------------------------------------
6680!|| kin_kml ../engine/source/mpi/implicit/imp_fri.F
6681!|| kin_ksl ../engine/source/mpi/implicit/imp_fri.F
6682!||--- uses -----------------------------------------------------
6683!|| imp_intm ../engine/share/modules/imp_intm.F
6684!||====================================================================
6685 SUBROUTINE ini_slnr(NSL ,NNMAX ,NRS ,ICOL ,NZ ,
6686 . NDOF ,IAD_M )
6687C-----------------------------------------------
6688C M o d u l e s
6689C-----------------------------------------------
6690 USE imp_intm
6691C----6---------------------------------------------------------------7---------8
6692C I m p l i c i t T y p e s
6693C-----------------------------------------------
6694#include "implicit_f.inc"
6695C-----------------------------------------------------------------
6696C D u m m y A r g u m e n t s
6697C-----------------------------------------------
6698 INTEGER NSL,NZ,NNMAX ,NRS(*),NDOF(*),IAD_M(*)
6699 INTEGER ICOL(NNMAX,*)
6700C REAL
6701C-----------------------------------------------
6702C L o c a l V a r i a b l e s
6703C-----------------------------------------------
6704 INTEGER
6705 . i,j,k,n,nj
6706C----------------------------
6707 IF(ALLOCATED(iad_slnr)) DEALLOCATE(iad_slnr)
6708 ALLOCATE(iad_slnr(nsl+1))
6709 IF(ALLOCATED(jdi_slnr)) DEALLOCATE(jdi_slnr)
6710 ALLOCATE(jdi_slnr(nz))
6711 nz = 0
6712 iad_slnr(1) = nz+1
6713 DO n=1,nsl
6714 DO j=1,nrs(n)
6715 nj = icol(j,n)
6716 nz = nz+1
6717 jdi_slnr(nz) = nj
6718 ENDDO
6719 iad_slnr(n+1) = nz+1
6720 ENDDO
6721 nz = 0
6722 iad_m(1) = nz+1
6723 DO n=1,nsl
6724 IF (ikc_sl(n)>0) THEN
6725C I = ISL(N)
6726 DO j=1,max(1,nrs(n))
6727 nz = nz+ikc_sl(n)
6728 IF (nrs(n)>0) THEN
6729 nj = icol(j,n)
6730C----------IKC_SL=NREMS when it's called by KIN_KML
6731 IF (ndof(nj)==6) nz = nz+ikc_sl(n)
6732 ENDIF
6733 ENDDO
6734 ENDIF
6735 iad_m(n+1) = nz+1
6736 ENDDO
6737C----6---------------------------------------------------------------7---------8
6738 RETURN
6739 END
6740!||====================================================================
6741!|| dim_kinfrk ../engine/source/mpi/implicit/imp_fri.F
6742!||--- called by ------------------------------------------------------
6743!|| kin_kml ../engine/source/mpi/implicit/imp_fri.F
6744!|| kin_ksl ../engine/source/mpi/implicit/imp_fri.F
6745!||--- uses -----------------------------------------------------
6746!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
6747!||====================================================================
6748 SUBROUTINE dim_kinfrk(
6749 1 NPBY ,LPBY ,ITAB ,NRBYAC ,IRBYAC ,
6750 2 NINT2 ,IINT2 ,IPARI ,INTBUF_TAB,INLOC ,
6751 3 IA ,IA2 ,NRS ,LNS ,LNS2 ,
6752 4 N_KINE ,IRBE3 ,LRBE3 ,LNS3 ,IRBE2 ,
6753 5 LRBE2 ,LNS4 )
6754C-----------------------------------------------
6755C M o d u l e s
6756C-----------------------------------------------
6757 USE intbufdef_mod
6758C----6---------------------------------------------------------------7---------8
6759C I m p l i c i t T y p e s
6760C-----------------------------------------------
6761#include "implicit_f.inc"
6762C-----------------------------------------------
6763C C o m m o n B l o c k s
6764C-----------------------------------------------
6765#include "com04_c.inc"
6766#include "param_c.inc"
6767C-----------------------------------------------------------------
6768C D u m m y A r g u m e n t s
6769C-----------------------------------------------
6770C INTEGER NNMAX,NKMAX
6771 INTEGER NPBY(NNPBY,*),LPBY(*),ITAB(*),NRBYAC,IRBYAC(*),
6772 . NINT2,IINT2(*),IPARI(NPARI,*),
6773 . IRBE3(NRBE3L,*),LRBE3(*) ,LNS3 ,
6774 . IRBE2(NRBE2L,*),LRBE2(*) ,LNS4
6775 INTEGER
6776 . INLOC(*),NRS(*),LNS ,LNS2,N_KINE,IA(*),IA2(*)
6777C REAL
6778 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
6779C-----------------------------------------------
6780C L o c a l V a r i a b l e s
6781C-----------------------------------------------
6782 integer
6783 . i,j,k,n,l,nl,nj,ni,j1,m,nsn,n1,n2,nk,id,
6784 . ji,ns,nnod,iad
6785C----------------------------
6786 lns2=0
6787C--------int2---------
6788 DO j=1,nint2
6789 n=iint2(j)
6790 ia2(j)=0
6791 nsn = ipari(5,n)
6792 ji=ipari(1,n)
6793 DO i=1,nsn
6794 ni=intbuf_tab(n)%NSV(i)
6795 IF (inloc(ni)>0) THEN
6796 l=intbuf_tab(n)%IRTLM(ni)
6797 nl=4*(l-1)
6798 IF (intbuf_tab(n)%IRECTM(nl+3)==intbuf_tab(n)%IRECTM(nl+4)) THEN
6799 nnod=3
6800 ELSE
6801 nnod=4
6802 ENDIF
6803 nk = inloc(ni)
6804 IF (nk>n_kine ) nk = nk - n_kine
6805 nrs(nk) = nrs(nk)+nnod
6806 ia2(j) = n
6807 lns2 = lns2+1
6808C------- if Mi is also dependent ------
6809 DO k =1,nnod
6810 nj=intbuf_tab(n)%IRECTM(nl+k)
6811 IF (inloc(nj)==0) inloc(nj) = n_kine + inloc(ni)
6812 ENDDO
6813 ENDIF
6814 ENDDO
6815 ENDDO
6816C
6817 lns3=0
6818C--------RBE3---------
6819 DO i=1,nrbe3
6820 iad=irbe3(1,i)
6821 ni=irbe3(3,i)
6822 nnod=irbe3(5,i)
6823 IF (ni==0) cycle
6824 IF (inloc(ni)>0) THEN
6825 nk = inloc(ni)
6826 IF (nk>n_kine ) nk = nk - n_kine
6827 nrs(nk) = nrs(nk)+nnod
6828 lns3 = lns3+1
6829C------- if Mi is also dependent ------
6830 DO k =1,nnod
6831 nj = lrbe3(iad+k)
6832 IF (inloc(nj)==0) inloc(nj) = n_kine + inloc(ni)
6833 ENDDO
6834 ENDIF
6835 ENDDO
6836C
6837 lns=0
6838C-----active rigid body main nodes------
6839 DO j=1,nrbyac
6840 ia(j)=0
6841 n=irbyac(j)
6842 k=irbyac(j+nrbykin)
6843 m =npby(1,n)
6844 nsn =npby(2,n)
6845 DO i=1,nsn
6846 id = i+k
6847 ni=lpby(id)
6848 nk = inloc(ni)
6849 IF (nk>n_kine) nk = inloc(ni)-n_kine
6850 IF (nk>0) THEN
6851 nrs(nk) = nrs(nk)+1
6852 ia(j)=n
6853 lns = lns+1
6854 IF (inloc(m)==0) inloc(m) = n_kine + inloc(ni)
6855 ENDIF
6856 ENDDO
6857 ENDDO
6858C-----RBE2------
6859 lns4=0
6860 DO j=1,nrbe2
6861 iad=irbe2(1,j)
6862 m =irbe2(3,j)
6863 nsn =irbe2(5,j)
6864 DO i=1,nsn
6865 id = i+iad
6866 ni=lrbe2(id)
6867 nk = inloc(ni)
6868 IF (nk>n_kine) nk = inloc(ni)-n_kine
6869 IF (nk>0) THEN
6870 nrs(nk) = nrs(nk)+1
6871 lns4 = lns4+1
6872 IF (inloc(m)==0) inloc(m) = n_kine + inloc(ni)
6873 ENDIF
6874 ENDDO
6875 ENDDO
6876C----6---------------------------------------------------------------7---------8
6877 RETURN
6878 END
6879!||====================================================================
6880!|| ind_kinfrk ../engine/source/mpi/implicit/imp_fri.F
6881!||--- called by ------------------------------------------------------
6882!|| kin_kml ../engine/source/mpi/implicit/imp_fri.F
6883!|| kin_ksl ../engine/source/mpi/implicit/imp_fri.f
6884!||--- calls -----------------------------------------------------
6885!|| reorder_a ../engine/source/implicit/ind_glob_k.F
6886!||--- uses -----------------------------------------------------
6887!|| imp_aspc ../engine/share/modules/impbufdef_mod.F
6888!|| imp_intm ../engine/share/modules/imp_intm.F
6889!|| imp_rwl ../engine/share/modules/impbufdef_mod.F
6890!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
6891!||====================================================================
6892 SUBROUTINE ind_kinfrk(
6893 1 NPBY ,LPBY ,ITAB ,NRBYAC ,IRBYAC ,
6894 2 NINT2 ,IINT2 ,IPARI ,INTBUF_TAB,INLOC ,
6895 3 IA ,IA2 ,NSS ,NSS2 ,N_KINE ,
6896 4 IBFV ,LJ ,ISKEW ,ICODT ,NRS ,
6897 5 ICOL ,NNMAX ,IRBE3 ,LRBE3 ,LNS3 ,
6898 6 IRBE2 ,LRBE2 ,LNS4 )
6899C-----------------------------------------------
6900C M o d u l e s
6901C-----------------------------------------------
6902 USE imp_intm
6903 USE imp_rwl
6904 USE imp_aspc
6905 USE intbufdef_mod
6906C----6---------------------------------------------------------------7---------8
6907C I m p l i c i t T y p e s
6908C-----------------------------------------------
6909#include "implicit_f.inc"
6910C-----------------------------------------------
6911C C o m m o n B l o c k s
6912C-----------------------------------------------
6913#include "com04_c.inc"
6914#include "param_c.inc"
6915C-----------------------------------------------------------------
6916C D u m m y A r g u m e n t s
6917C-----------------------------------------------
6918 INTEGER NNMAX
6919 INTEGER NPBY(NNPBY,*),LPBY(*),ITAB(*),NRBYAC,IRBYAC(*),
6920 . NINT2,IINT2(*),IPARI(NPARI,*),ISKEW(*),ICODT(*)
6921 INTEGER
6922 . INLOC(*),NSS,NSS2,N_KINE,IBFV(NIFV,*),LJ(*),ICOL(NNMAX,*),
6923 . ia(*),ia2(*),nrs(*),irbe3(nrbe3l,*),lrbe3(*),lns3 ,
6924 . irbe2(nrbe2l,*),lrbe2(*),lns4
6925C REAL
6926 TYPE(intbuf_struct_) INTBUF_TAB(*)
6927C-----------------------------------------------
6928C L o c a l V a r i a b l e s
6929C-----------------------------------------------
6930 integer
6931 . i,j,k,n,l,nl,nj,ni,j1,m,nsn,n1,n2,nk,id,
6932 . ji,iad,nnod,
6933 . ierror1,ierror2,ierror3,ierror4,ierror5,ierror6,ierror7
6934c----------------------
6935 ni2_fr=0
6936 ni2_frs=0
6937 IF (nss2>0) THEN
6938 IF(ALLOCATED(ifrs2)) DEALLOCATE(ifrs2)
6939 ALLOCATE(ifrs2(2,nss2),stat=ierror1)
6940 DO j=1,nint2
6941 n=ia2(j)
6942 IF (n>0) THEN
6943 nsn = ipari(5,n)
6944 ji=ipari(1,n)
6945 DO i=1,nsn
6946 ni=intbuf_tab(n)%NSV(i)
6947 nk = inloc(ni)
6948 IF (nk>n_kine) nk =nk-n_kine
6949 IF (nk>0) THEN
6950 l=intbuf_tab(n)%IRTLM(ni)
6951 nl=4*(l-1)
6952 DO k =1,4
6953 nj=intbuf_tab(n)%IRECTM(nl+k)
6954 CALL reorder_a(nrs(nk),icol(1,nk),nj)
6955 ENDDO
6956 ni2_fr=ni2_fr+1
6957 ifrs2(1,ni2_fr)=n
6958 ifrs2(2,ni2_fr)=i
6959 ENDIF
6960 ENDDO
6961 ENDIF
6962 ENDDO
6963 ENDIF
6964C-----RBE2------
6965 nrbe2_fr=0
6966 nrbe2_frs=0
6967 IF (lns4>0) THEN
6968 IF(ALLOCATED(ifrs4)) DEALLOCATE(ifrsr)
6969 ALLOCATE(ifrs4(2,lns4),stat=ierror2)
6970 DO n=1,nrbe2
6971 iad=irbe2(1,n)
6972 m =irbe2(3,n)
6973 IF (inloc(m)>0) THEN
6974 nsn =irbe2(5,n)
6975 DO i=1,nsn
6976 id = i+iad
6977 ni=lrbe2(id)
6978 nk = inloc(ni)
6979 IF (nk>n_kine) nk = inloc(ni)-n_kine
6980 IF (nk>0) THEN
6981 CALL reorder_a(nrs(nk),icol(1,nk),m)
6982 nrbe2_fr=nrbe2_fr+1
6983 ifrs4(1,nrbe2_fr)=n
6984 ifrs4(2,nrbe2_fr)=ni
6985 ENDIF
6986 ENDDO
6987 ENDIF
6988 ENDDO
6989 ENDIF
6990c--------RBE3--------------
6991 nrbe3_fr=0
6992 nrbe3_frs=0
6993 IF (lns3>0) THEN
6994 IF(ALLOCATED(ifrs3)) DEALLOCATE(ifrs3)
6995 ALLOCATE(ifrs3(lns3),stat=ierror1)
6996 DO n=1,nrbe3
6997 iad=irbe3(1,n)
6998 ni=irbe3(3,n)
6999 nnod=irbe3(5,n)
7000 IF (ni==0) cycle
7001 IF (inloc(ni)>0) THEN
7002 nk = inloc(ni)
7003 IF (nk>n_kine) nk =nk-n_kine
7004 DO k =1,nnod
7005 nj = lrbe3(iad+k)
7006 CALL reorder_a(nrs(nk),icol(1,nk),nj)
7007 ENDDO
7008 nrbe3_fr=nrbe3_fr+1
7009 ifrs3(nrbe3_fr)=n
7010 ENDIF
7011 ENDDO
7012 ENDIF
7013C-----active rigid body main nodes------
7014 nrb_fr=0
7015 nrb_frs=0
7016 IF (nss>0) THEN
7017 IF(ALLOCATED(ifrsr)) DEALLOCATE(ifrsr)
7018 ALLOCATE(ifrsr(2,nss),stat=ierror2)
7019 DO j=1,nrbyac
7020 n=ia(j)
7021 IF (n>0) THEN
7022 k=irbyac(j+nrbykin)
7023 m =npby(1,n)
7024 IF (inloc(m)>0) THEN
7025 nsn =npby(2,n)
7026 DO i=1,nsn
7027 id = i+k
7028 ni=lpby(id)
7029 nk = inloc(ni)
7030 IF (nk>n_kine) nk = inloc(ni)-n_kine
7031 IF (nk>0) THEN
7032 CALL reorder_a(nrs(nk),icol(1,nk),m)
7033 nrb_fr=nrb_fr+1
7034 ifrsr(1,nrb_fr)=m
7035 ifrsr(2,nrb_fr)=ni
7036 ENDIF
7037 ENDDO
7038 ENDIF
7039 ENDIF
7040 ENDDO
7041 ENDIF
7042C+++ BC. LOCAL
7043 nbc_fr = 0
7044 DO n=1,numnod
7045 IF (iskew(n)>1.AND.icodt(n)/=7) THEN
7046 IF (inloc(n)>0)nbc_fr = nbc_fr + 1
7047 ENDIF
7048 ENDDO
7049 IF (nbc_fr>0) THEN
7050 IF(ALLOCATED(ibc_fr)) DEALLOCATE(ibc_fr)
7051 ALLOCATE(ibc_fr(3,nbc_fr),stat=ierror5)
7052 nbc_fr = 0
7053 DO n=1,numnod
7054 IF (iskew(n)>1.AND.icodt(n)/=7) THEN
7055 IF (inloc(n)>0) THEN
7056 nbc_fr = nbc_fr + 1
7057 ibc_fr(1,nbc_fr) = n
7058 ibc_fr(2,nbc_fr) = iskew(n)
7059 ibc_fr(3,nbc_fr) = icodt(n)
7060 ENDIF
7061 ENDIF
7062 ENDDO
7063 ENDIF
7064C+++ AUTOSPC
7065 nspc_fr = 0
7066 DO n=1,nspcl
7067 i = in_spc(n)
7068 IF (inloc(n)>0.AND.ic_spc(n)<=3)nspc_fr = nspc_fr + 1
7069 ENDDO
7070 IF (nspc_fr>0) THEN
7071 IF(ALLOCATED(ispc_fr)) DEALLOCATE(ispc_fr)
7072 ALLOCATE(ispc_fr(nspc_fr),stat=ierror5)
7073 nspc_fr = 0
7074 DO n=1,nspcl
7075 i = in_spc(n)
7076 IF (inloc(n)>0.AND.ic_spc(n)<=3) THEN
7077 nspc_fr = nspc_fr + 1
7078 ispc_fr(nspc_fr)= n
7079 ENDIF
7080 ENDDO
7081 ENDIF
7082C +++ FV---local
7083 nfx_fr = 0
7084 DO j=1,nfxvel
7085 IF (lj(j)>0.AND.lj(j)<=3) THEN
7086 n=iabs(ibfv(1,j))
7087 IF (inloc(n)>0)nfx_fr = nfx_fr + 1
7088 ENDIF
7089 ENDDO
7090 IF (nfx_fr>0) THEN
7091 IF(ALLOCATED(ifx_fr)) DEALLOCATE(ifx_fr)
7092 ALLOCATE(ifx_fr(2,nfx_fr),stat=ierror6)
7093 nfx_fr = 0
7094 DO j=1,nfxvel
7095 IF (lj(j)>0.AND.lj(j)<=3) THEN
7096 n=iabs(ibfv(1,j))
7097 IF (inloc(n)>0) THEN
7098 nfx_fr = nfx_fr + 1
7099 ifx_fr(1,nfx_fr) = j
7100 ifx_fr(2,nfx_fr) = lj(j)
7101 ENDIF
7102 ENDIF
7103 ENDDO
7104 ENDIF
7105C ---
7106C +++ sliding rigid wall---
7107 nrw_fr = 0
7108 DO j=1,n_rwl
7109 n=in_rwl(j)
7110 IF (inloc(n)>0) nrw_fr = nrw_fr + 1
7111 ENDDO
7112 IF (nrw_fr>0) THEN
7113 IF(ALLOCATED(irw_fr)) DEALLOCATE(irw_fr)
7114 ALLOCATE(irw_fr(nrw_fr),stat=ierror7)
7115 nrw_fr = 0
7116 DO j=1,n_rwl
7117 n=in_rwl(j)
7118 IF (inloc(n)>0) THEN
7119 nrw_fr = nrw_fr + 1
7120 irw_fr(nrw_fr) = j
7121 ENDIF
7122 ENDDO
7123 ENDIF
7124C ---
7125C----6---------------------------------------------------------------7---------8
7126 RETURN
7127 END
7128!||====================================================================
7129!|| get_iad ../engine/source/mpi/implicit/imp_fri.F
7130!||--- called by ------------------------------------------------------
7131!|| imp_fvkm ../engine/source/mpi/implicit/imp_fri.F
7132!|| upd_kml ../engine/source/mpi/implicit/imp_fri.F
7133!|| upd_ksl ../engine/source/mpi/implicit/imp_fri.F
7134!||--- calls -----------------------------------------------------
7135!|| intabfr ../engine/source/mpi/implicit/imp_fri.F
7136!||====================================================================
7137 SUBROUTINE get_iad(IAD_M ,IAD_S ,JDI_S ,NM ,IS ,
7138 1 J ,NRJ ,NDOF ,IAD )
7139C----6---------------------------------------------------------------7---------8
7140C I m p l i c i t T y p e s
7141C-----------------------------------------------
7142#include "implicit_f.inc"
7143C-----------------------------------------------------------------
7144C D u m m y A r g u m e n t s
7145C-----------------------------------------------
7146 INTEGER IAD_M(*),IAD_S(*),JDI_S(*),NM ,NS,J,IAD,NRJ ,NDOF(*)
7147C REAL
7148C-----------------------------------------------
7149C L o c a l V a r i a b l e s
7150C-----------------------------------------------
7151 INTEGER I,K,NR,L,IS,NK,NZ,NJ,I0,ID
7152C----6---------------------------------------------------------------7---------8
7153 nr =iad_s(is+1)-iad_s(is)
7154 l = iad_m(is)
7155 nk =(iad_m(is+1)-iad_m(is))/nrj
7156 iad = l+(j-1)*nk
7157 IF (nm>0.AND.nr>0) THEN
7158 i0=iad_s(is)
7159 CALL intabfr(nr,jdi_s(i0),nm,id)
7160 IF (id>0) THEN
7161 nz = 0
7162 DO i = 1,id-1
7163 nj = jdi_s(i0+i-1)
7164 IF (ndof(nj)==6) THEN
7165 nz = nz + 2
7166 ELSE
7167 nz = nz +1
7168 ENDIF
7169 ENDDO
7170 iad = iad + nz
7171 ELSE
7172 iad = 0
7173 ENDIF
7174 ENDIF
7175C
7176C----6---------------------------------------------------------------7---------8
7177 RETURN
7178 END
7179!||====================================================================
7180!|| ikincf ../engine/source/mpi/implicit/imp_fri.F
7181!||--- called by ------------------------------------------------------
7182!|| dim_frkm1 ../engine/source/mpi/implicit/imp_fri.F
7183!|| tra_frkm ../engine/source/mpi/implicit/imp_fri.F
7184!||====================================================================
7185 LOGICAL FUNCTION ikincf(I)
7186C----6---------------------------------------------------------------7---------8
7187C I m p l i c i t T y p e s
7188C-----------------------------------------------
7189#include "implicit_f.inc"
7190C-----------------------------------------------------------------
7191C D u m m y A r g u m e n t s
7192C-----------------------------------------------
7193 INTEGER i
7194C-----------------------------------------------
7195C L o c a l V a r i a b l e s
7196C-----------------------------------------------
7197C----6---------------------------------------------------------------7---------8
7198 IF (i==0.OR.(i>=2.AND.i<=4).OR.i==9) THEN
7199 ikincf =.true.
7200 ELSE
7201 ikincf =.false.
7202 ENDIF
7203C
7204 RETURN
7205 END
7206!||====================================================================
7207!|| dim_frkm1 ../engine/source/mpi/implicit/imp_fri.F
7208!||--- called by ------------------------------------------------------
7209!|| imp_frkd ../engine/source/mpi/implicit/imp_fri.F
7210!||--- calls -----------------------------------------------------
7211!|| ikincf ../engine/source/mpi/implicit/imp_fri.F
7212!|| spmd_isr ../engine/source/mpi/implicit/imp_spmd.F
7213!||--- uses -----------------------------------------------------
7214!|| imp_intm ../engine/share/modules/imp_intm.F
7215!||====================================================================
7216 SUBROUTINE dim_frkm1(NSREM,NSL ,IDDL ,IKC ,NDOF ,
7217 . NF_SI,NF_SL,LSI ,LSL ,MSI,MSL)
7218C-----------------------------------------------
7219C M o d u l e s
7220C-----------------------------------------------
7221 USE imp_intm
7222C-----------------------------------------------
7223C I m p l i c i t T y p e s
7224C-----------------------------------------------
7225#include "implicit_f.inc"
7226C-----------------------------------------------
7227C D u m m y A r g u m e n t s
7228C-----------------------------------------------
7229 INTEGER NSREM ,NSL ,LSI,LSL ,NF_SL(*),NF_SI(*),
7230 . iddl(*) ,ikc(*) ,ndof(*) ,msi,msl
7231C REAL
7232C-----------------------------------------------
7233C External function
7234C-----------------------------------------------
7235 LOGICAL IKINCF
7236 EXTERNAL ikincf
7237C-----------------------------------------------
7238C L o c a l V a r i a b l e s
7239C-----------------------------------------------
7240 INTEGER I,J,N,ID,NFAC,NJ
7241C----------NF_SL : new nm times of [K]3x3- of dependant---------------------------
7242 DO i = 1, nsl
7243 IF (ikc_sl(i)>0) THEN
7244 n = isl(i)
7245 id = iddl(n)
7246 IF (ndof(n)==0.OR.(ikc(id+1)/=0.AND.ikc(id+2)/=0
7247 . .AND.ikc(id+3)/=0)) THEN
7248 nfac=0
7249 DO j=iad_slnr(i),iad_slnr(i+1)-1
7250 nj = jdi_slnr(j)
7251 id = iddl(nj)
7252 IF (ikincf(ikc(id+1)).OR.ikincf(ikc(id+2)).OR.
7253 . ikincf(ikc(id+3)))
7254 . nfac = nfac +1
7255 IF (ndof(nj)==6) THEN
7256 IF (ikincf(ikc(id+4)).OR.ikincf(ikc(id+5)).OR.
7257 . ikincf(ikc(id+6)))
7258 . nfac = nfac +1
7259 ENDIF
7260 ENDDO
7261Ctmp special case of d_imp in all directions
7262 IF (ndof(n)>0.AND.iad_slnr(i)==iad_slnr(i+1))nfac = 1
7263 ELSE
7264 nfac = 1
7265 ENDIF
7266 nf_sl(i) = nfac
7267 ELSE
7268 nf_sl(i) = 0
7269 ENDIF
7270 ENDDO
7271C
7272 CALL spmd_isr(iad_sl,iad_srem,nf_sl,nf_si,nsl ,nsrem )
7273C -----new nb. [k] modifie SL,SI---for com---ISL for IKC(3,M)
7274 msl = 0
7275 lsl = 0
7276 DO i = 1, nsl
7277 IF (ikc_sl(i)>0) THEN
7278 msl = msl + nf_sl(i)
7279 lsl = lsl + ikc_sl(i)*nf_sl(i)
7280 ENDIF
7281 ENDDO
7282c
7283 msi = 0
7284 lsi = 0
7285 DO i = 1, nsrem
7286 IF (ikc_si(i)>0) THEN
7287 msi = msi + nf_si(i)
7288 lsi = lsi + ikc_si(i)*nf_si(i)
7289 ENDIF
7290 ENDDO
7291C
7292 RETURN
7293 END
7294!||====================================================================
7295!|| tra_frkm ../engine/source/mpi/implicit/imp_fri.F
7296!||--- called by ------------------------------------------------------
7297!|| imp_frkd ../engine/source/mpi/implicit/imp_fri.F
7298!||--- calls -----------------------------------------------------
7299!|| cp_real ../engine/source/implicit/produt_v.F
7300!|| ikincf ../engine/source/mpi/implicit/imp_fri.F
7301!||--- uses -----------------------------------------------------
7302!|| imp_intm ../engine/share/modules/imp_intm.F
7303!||====================================================================
7304 SUBROUTINE tra_frkm(NSL ,IDDL ,IKC ,NDOF ,IAD_M,
7305 . KSI ,KSL ,IKCSL )
7306C-----------------------------------------------
7307C M o d u l e s
7308C-----------------------------------------------
7309 USE imp_intm
7310C-----------------------------------------------
7311C I m p l i c i t T y p e s
7312C-----------------------------------------------
7313#include "implicit_f.inc"
7314C-----------------------------------------------
7315C D u m m y A r g u m e n t s
7316C-----------------------------------------------
7317 INTEGER NSL,IDDL(*),IKC(*),NDOF(*),IAD_M(*),IKCSL(3,*)
7318C REAL
7319 my_real
7320 . ksi(9,*),ksl(9,*)
7321C-----------------------------------------------
7322C External function
7323C-----------------------------------------------
7324 LOGICAL IKINCF
7325 EXTERNAL IKINCF
7326C-----------------------------------------------
7327C L o c a l V a r i a b l e s
7328C-----------------------------------------------
7329 INTEGER I,J,K,N,ID,IADI,IADL,SIZE,NJ,NB,IDM,NKC
7330 LOGICAL NODOF
7331C-------------------------------------
7332 SIZE = 9
7333 iadl=1
7334 DO i = 1, nsl
7335 IF (ikc_sl(i)>0) THEN
7336 iadi=iad_m(i)
7337 n = isl(i)
7338 id = iddl(n)
7339 IF (ndof(n)==0.OR.(ikc(id+1)/=0.AND.ikc(id+2)/=0
7340 . .AND.ikc(id+3)/=0)) THEN
7341 nodof = .true.
7342 ELSE
7343 nodof = .false.
7344 END IF
7345C
7346 DO j = 1, ikc_sl(i)
7347 DO k=iad_slnr(i),iad_slnr(i+1)-1
7348 nj = jdi_slnr(k)
7349 id = iddl(nj)
7350 IF (nodof.AND.(ikincf(ikc(id+1)).OR.ikincf(ikc(id+2)).OR.
7351 . ikincf(ikc(id+3)))) THEN
7352 CALL cp_real(SIZE,ksi(1,iadi),ksl(1,iadl))
7353 iadl=iadl+1
7354 ENDIF
7355 iadi=iadi+1
7356 IF (ndof(nj)==6) THEN
7357 IF (nodof.AND.(ikincf(ikc(id+4)).OR.ikincf(ikc(id+5)).OR.
7358 . ikincf(ikc(id+6)))) THEN
7359 CALL cp_real(SIZE,ksi(1,iadi),ksl(1,iadl))
7360 iadl=iadl+1
7361 ENDIF
7362 iadi=iadi+1
7363 ENDIF
7364 ENDDO
7365Ctmp special case of d_imp in all directions
7366 IF (nodof) THEN
7367 IF (ndof(n)>0.AND.iad_slnr(i)==iad_slnr(i+1))THEN
7368 nb = SIZE
7369 CALL cp_real(nb,ksi(1,iadi),ksl(1,iadl))
7370 iadl=iadl+1
7371 ENDIF
7372 ELSE
7373 nb = SIZE
7374 CALL cp_real(nb,ksi(1,iadi),ksl(1,iadl))
7375 iadl=iadl+1
7376C------case /BCS
7377 IF (iad_slnr(i)==iad_slnr(i+1)) iadi = iadi + 1
7378 ENDIF
7379C
7380 END DO !J = 1, IKC_SL(I)
7381C
7382 ENDIF
7383 ENDDO
7384C------init IKCSL-------
7385 iadi = 1
7386 DO i = 1, nsl
7387 n = isl(i)
7388 IF (ikc_sl(i)>0) THEN
7389 DO j=iad_slnr(i),iad_slnr(i+1)-1
7390 nj = jdi_slnr(j)
7391 id = iddl(nj)
7392 IF (ikincf(ikc(id+1)).OR.ikincf(ikc(id+2)).OR.
7393 . ikincf(ikc(id+3))) THEN
7394 DO k =1,3
7395 ikcsl(k,iadi) = ikc(id+k)
7396 ENDDO
7397 iadi = iadi + 1
7398 ENDIF
7399 IF (ndof(nj)==6) THEN
7400 IF (ikincf(ikc(id+4)).OR.ikincf(ikc(id+5)).OR.
7401 . ikincf(ikc(id+6))) THEN
7402 DO k =1,3
7403 ikcsl(k,iadi) = ikc(id+k+3)
7404 ENDDO
7405 iadi = iadi + 1
7406 ENDIF
7407 ENDIF
7408 ENDDO
7409C----------other kin------------
7410 IF (iad_slnr(i)==iad_slnr(i+1).AND.ndof(n)>0) THEN
7411 id = iddl(n)
7412 IF (ikincf(ikc(id+1)).OR.ikincf(ikc(id+2)).OR.
7413 . ikincf(ikc(id+3))) THEN
7414 DO k =1,3
7415 ikcsl(k,iadi) = ikc(id+k)
7416 ENDDO
7417 iadi = iadi + 1
7418 ENDIF
7419 ENDIF
7420 ENDIF
7421 ENDDO
7422C
7423 RETURN
7424 END
7425!||====================================================================
7426!|| kin_kml ../engine/source/mpi/implicit/imp_fri.F
7427!||--- called by ------------------------------------------------------
7428!|| imp_frkd ../engine/source/mpi/implicit/imp_fri.F
7429!||--- calls -----------------------------------------------------
7430!|| dim_kinfrk ../engine/source/mpi/implicit/imp_fri.F
7431!|| ind_kinfrk ../engine/source/mpi/implicit/imp_fri.F
7432!|| ini_slnr ../engine/source/mpi/implicit/imp_fri.F
7433!||--- uses -----------------------------------------------------
7434!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.f90
7435!||====================================================================
7436 SUBROUTINE kin_kml(
7437 1 IPARI ,INTBUF_TAB,NINT2 ,IINT2 ,
7438 2 NPBY ,LPBY ,ITAB ,NRBYAC ,IRBYAC ,
7439 3 X ,IBFV ,LJ ,SKEW ,XFRAME ,
7440 4 ISKEW ,ICODT ,NDOF ,ILOCP ,NSREM ,
7441 5 IDDL ,IKC ,IAD_M ,NML ,IRBE3 ,
7442 6 LRBE3 ,IRBE2 ,LRBE2 )
7443C-----------------------------------------------
7444C M o d u l e s
7445C-----------------------------------------------
7446 USE intbufdef_mod
7447C----6---------------------------------------------------------------7---------8
7448C I m p l i c i t T y p e s
7449C-----------------------------------------------
7450#include "implicit_f.inc"
7451C-----------------------------------------------
7452C C o m m o n B l o c k s
7453C-----------------------------------------------
7454#include "param_c.inc"
7455C-----------------------------------------------------------------
7456C D u m m y A r g u m e n t s
7457C-----------------------------------------------
7458 INTEGER IBFV(NIFV,*),IPARI(NPARI,*),NSREM,NML
7459 INTEGER NPBY(NNPBY,*),LPBY(*),ITAB(*),NRBYAC,IRBYAC(*),
7460 . NINT2,IINT2(*),ILOCP(*),NDOF(*) ,IDDL(*) ,IKC(*),
7461 . LJ(*),ISKEW(*),ICODT(*),IAD_M(*),IRBE3(*),LRBE3(*),
7462 . IRBE2(*),LRBE2(*)
7463C REAL
7464 my_real
7465 . X(3,*),SKEW(*),XFRAME(*)
7466 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
7467C-----------------------------------------------
7468C L o c a l V a r i a b l e s
7469C-----------------------------------------------
7470 INTEGER LNS,LNS2,NNMAX,NZ,LNS3,LNS4
7471 INTEGER I,J,K,L,N_KINE,IA2(NINT2),IA(NRBYAC)
7472 INTEGER, DIMENSION(:), ALLOCATABLE :: ICOL,NRS
7473C------------------------------------------------------------
7474 ALLOCATE(nrs(nml))
7475C
7476 DO i=1,nml
7477 nrs(i) = 0
7478 ENDDO
7479 CALL dim_kinfrk(
7480 1 npby ,lpby ,itab ,nrbyac ,irbyac ,
7481 2 nint2 ,iint2 ,ipari ,intbuf_tab,ilocp ,
7482 3 ia ,ia2 ,nrs ,lns ,lns2 ,
7483 4 nml ,irbe3 ,lrbe3 ,lns3 ,irbe2 ,
7484 5 lrbe2 ,lns4 )
7485C
7486 nnmax=0
7487 DO i=1,nml
7488 nnmax=max(nnmax,nrs(i))
7489 nrs(i)=0
7490 ENDDO
7491 ALLOCATE(icol(nnmax*nml))
7492C--------ICOL(NNMAX,NML) for independent nodes----
7493 CALL ind_kinfrk(
7494 1 npby ,lpby ,itab ,nrbyac ,irbyac ,
7495 2 nint2 ,iint2 ,ipari ,intbuf_tab,ilocp ,
7496 3 ia ,ia2 ,lns ,lns2 ,nml ,
7497 4 ibfv ,lj ,iskew ,icodt ,nrs ,
7498 5 icol ,nnmax ,irbe3 ,lrbe3 ,lns3 ,
7499 6 irbe2 ,lrbe2 ,lns4 )
7500C
7501 nz = 0
7502 DO i=1,nml
7503 DO j=1,nrs(i)
7504 nz = nz+1
7505 ENDDO
7506 ENDDO
7507 CALL ini_slnr(nml ,nnmax ,nrs ,icol ,nz ,
7508 . ndof ,iad_m )
7509 DEALLOCATE(nrs)
7510 DEALLOCATE(icol)
7511C----6---------------------------------------------------------------7---------8
7512 RETURN
7513 END
7514!||====================================================================
7515!|| tag_intml ../engine/source/mpi/implicit/imp_fri.F
7516!||--- called by ------------------------------------------------------
7517!|| imp_frkd ../engine/source/mpi/implicit/imp_fri.F
7518!||--- uses -----------------------------------------------------
7519!|| imp_intm ../engine/share/modules/imp_intm.F
7520!||====================================================================
7521 SUBROUTINE tag_intml(NSREM ,ILOC ,N_IMPN ,IDDL ,IKC ,
7522 . NDOF ,LSI )
7523C-----------------------------------------------
7524C M o d u l e s
7525C-----------------------------------------------
7526 USE imp_intm
7527C----6---------------------------------------------------------------7---------8
7528C I m p l i c i t T y p e s
7529C-----------------------------------------------
7530#include "implicit_f.inc"
7531C-----------------------------------------------------------------
7532C D u m m y A r g u m e n t s
7533C-----------------------------------------------
7534 INTEGER NSREM,ILOC(*),N_IMPN,IDDL(*) ,IKC(*) ,NDOF(*) ,LSI
7535C REAL
7536C-----------------------------------------------
7537C L o c a l V a r i a b l e s
7538C-----------------------------------------------
7539 INTEGER I,J,N,IG,NM,NDD,ID,IER1,IER2
7540C-----------------------------------------------
7541 DO i = 1, nsrem
7542 DO j =iad_sinr(i),iad_sinr(i+1)-1
7543 ig = jdi_sinr(j)
7544 IF (iloc(ig)==0) THEN
7545 n_impn = n_impn + 1
7546 iloc(ig) = n_impn
7547 ENDIF
7548 ENDDO
7549 ENDDO
7550C---------------
7551 nml = n_impn
7552 IF(ALLOCATED(iml)) DEALLOCATE(iml)
7553 ALLOCATE(iml(nml),stat=ier1)
7554 DO i = 1, nsrem
7555 DO j =iad_sinr(i),iad_sinr(i+1)-1
7556 ig = jdi_sinr(j)
7557 nm = iloc(ig)
7558 iml(nm) = ig
7559 ENDDO
7560 ENDDO
7561C--------use also IKC_SL for ml IFLAG_KC ONLY----
7562 IF(ALLOCATED(ikc_sl)) DEALLOCATE(ikc_sl)
7563 ALLOCATE(ikc_sl(nml),stat=ier2)
7564 lsi = 0
7565 DO i = 1, nml
7566 n = iml(i)
7567 id = iddl(n)
7568 ndd = 0
7569 DO j = 1 , min(3,ndof(n))
7570 ndd = ndd + ikc(id+j)
7571 ENDDO
7572 IF (ndof(n)==0.OR.ndd>0) ndd = nsrem
7573 ikc_sl(i) = ndd
7574 lsi = lsi + ndd
7575 ENDDO
7576C----6---------------------------------------------------------------7---------8
7577 RETURN
7578 END
7579!||====================================================================
7580!|| scom_frk ../engine/source/mpi/implicit/imp_fri.F
7581!||--- called by ------------------------------------------------------
7582!|| imp_frkd ../engine/source/mpi/implicit/imp_fri.F
7583!||--- calls -----------------------------------------------------
7584!|| spmd_exck ../engine/source/mpi/implicit/imp_spmd.F
7585!||--- uses -----------------------------------------------------
7586!|| imp_intm ../engine/share/modules/imp_intm.F
7587!||====================================================================
7588 SUBROUTINE scom_frk(KS11,KR11,SSIZE ,RSIZE)
7589C-----------------------------------------------
7590C M o d u l e s
7591C-----------------------------------------------
7592 USE imp_intm
7593C-----------------------------------------------
7594C I m p l i c i t T y p e s
7595C-----------------------------------------------
7596#include "implicit_f.inc"
7597C-----------------------------------------------
7598C C o m m o n B l o c k s
7599C-----------------------------------------------
7600#include "com01_c.inc"
7601C-----------------------------------------------
7602C D u m m y A r g u m e n t s
7603C-----------------------------------------------
7604 INTEGER SSIZE ,RSIZE
7605 my_real
7606 . KS11(9,*),KR11(9,*)
7607C-----------------------------------------------
7608C L o c a l V a r i a b l e s
7609C-----------------------------------------------
7610 INTEGER I,J,SIZE,IAD_S(NSPMD+1),IAD_R(NSPMD+1)
7611C-----------------------------------------------
7612C S o u r c e L i n e s
7613C-----------------------------------------------
7614 SIZE = 9
7615 iad_s(1) = 1
7616 iad_r(1) = 1
7617 DO i=1,nspmd
7618 iad_s(i+1) = iad_s(i)
7619 iad_r(i+1) = iad_r(i)
7620 DO j=iad_srem(i),iad_srem(i+1)-1
7621 iad_s(i+1) = iad_s(i+1) + ikc_si(j)
7622 END DO
7623 DO j=iad_sl(i),iad_sl(i+1)-1
7624 iad_r(i+1) = iad_r(i+1) + ikc_sl(j)
7625 END DO
7626 END DO
7627C
7628 CALL spmd_exck(ks11,kr11,iad_s,iad_r,SIZE ,ssize,rsize)
7629C
7630 RETURN
7631 END
7632!||====================================================================
7633!|| scom_frk1 ../engine/source/mpi/implicit/imp_fri.F
7634!||--- called by ------------------------------------------------------
7635!|| imp_frkd ../engine/source/mpi/implicit/imp_fri.F
7636!||--- calls -----------------------------------------------------
7637!|| spmd_exci ../engine/source/mpi/implicit/imp_spmd.F
7638!|| spmd_exck ../engine/source/mpi/implicit/imp_spmd.F
7639!||--- uses -----------------------------------------------------
7640!|| imp_intm ../engine/share/modules/imp_intm.F
7641!||====================================================================
7642 SUBROUTINE scom_frk1(KS11,KR11,NFACS,NFACR,IKCS ,IKCR )
7643C-----------------------------------------------
7644C M o d u l e s
7645C-----------------------------------------------
7646 USE imp_intm
7647C-----------------------------------------------
7648C I m p l i c i t T y p e s
7649C-----------------------------------------------
7650#include "implicit_f.inc"
7651C-----------------------------------------------
7652C C o m m o n B l o c k s
7653C-----------------------------------------------
7654#include "com01_c.inc"
7655C-----------------------------------------------
7656C D u m m y A r g u m e n t s
7657C-----------------------------------------------
7658 INTEGER NFACS(*),NFACR(*),IKCS(3,*),IKCR(3,*)
7659 my_real
7660 . ks11(9,*),kr11(9,*)
7661C-----------------------------------------------
7662C L o c a l V a r i a b l e s
7663C-----------------------------------------------
7664 INTEGER I,J,SSIZE,RSIZE,SIZE,IAD_S(NSPMD+1),IAD_R(NSPMD+1)
7665C-----------------------------------------------
7666C S o u r c e L i n e s
7667C-----------------------------------------------
7668 IAD_S(1) = 1
7669 iad_r(1) = 1
7670 DO i=1,nspmd
7671 iad_s(i+1) = iad_s(i)
7672 iad_r(i+1) = iad_r(i)
7673 DO j=iad_sl(i),iad_sl(i+1)-1
7674 iad_s(i+1) = iad_s(i+1) + nfacs(j)
7675 END DO
7676 DO j=iad_srem(i),iad_srem(i+1)-1
7677 iad_r(i+1) = iad_r(i+1) + nfacr(j)
7678 END DO
7679 END DO
7680C
7681 SIZE = 3
7682 ssize = iad_s(nspmd+1) - 1
7683 rsize = iad_r(nspmd+1) - 1
7684 CALL spmd_exci(ikcs,ikcr,iad_s,iad_r,SIZE ,ssize,rsize)
7685 SIZE = 9
7686 iad_s(1) = 1
7687 iad_r(1) = 1
7688 DO i=1,nspmd
7689 iad_s(i+1) = iad_s(i)
7690 iad_r(i+1) = iad_r(i)
7691 DO j=iad_sl(i),iad_sl(i+1)-1
7692 iad_s(i+1) = iad_s(i+1) + nfacs(j)*ikc_sl(j)
7693 END DO
7694 DO j=iad_srem(i),iad_srem(i+1)-1
7695 iad_r(i+1) = iad_r(i+1) + nfacr(j)*ikc_si(j)
7696 END DO
7697 END DO
7698 ssize = iad_s(nspmd+1) - 1
7699 rsize = iad_r(nspmd+1) - 1
7700 CALL spmd_exck(ks11,kr11,iad_s,iad_r,SIZE ,ssize,rsize)
7701C
7702 RETURN
7703 END
7704!||====================================================================
7705!|| upd_kml ../engine/source/mpi/implicit/imp_fri.F
7706!||--- called by ------------------------------------------------------
7707!|| imp_frkd ../engine/source/mpi/implicit/imp_fri.F
7708!||--- calls -----------------------------------------------------
7709!|| bc_updfr ../engine/source/constraints/general/bcs/bc_imp0.F
7710!|| bc_updfr2 ../engine/source/constraints/general/bcs/bc_imp0.F
7711!|| bcl_frk ../engine/source/constraints/general/bcs/bc_imp0.F
7712!|| cp_real ../engine/source/implicit/produt_v.F
7713!|| fv_updfr ../engine/source/constraints/general/impvel/fv_imp0.f
7714!|| fvl_frk ../engine/source/constraints/general/impvel/fv_imp0.F
7715!|| get_iad ../engine/source/mpi/implicit/imp_fri.f
7716!|| getfr_kij ../engine/source/mpi/implicit/imp_fri.F
7717!|| i2_frk0 ../engine/source/interfaces/interf/i2_imp1.F
7718!|| i2_frk1 ../engine/source/interfaces/interf/i2_imp1.F
7719!|| intabfr ../engine/source/mpi/implicit/imp_fri.F
7720!|| l_dir ../engine/source/constraints/general/bcs/bc_imp0.F
7721!|| prerbe2fr ../engine/source/constraints/general/rbe2/rbe2f.f
7722!|| prerbe3fr ../engine/source/constraints/general/rbe3/rbe3f.F
7723!|| rbe2_frk ../engine/source/constraints/general/rbe2/rbe2_imp0.F
7724!|| rbe3_fr0 ../engine/source/constraints/general/rbe3/rbe3_imp0.F
7725!|| rby_frk ../engine/source/constraints/general/rbody/rby_imp0.F
7726!||--- uses -----------------------------------------------------
7727!|| imp_aspc ../engine/share/modules/impbufdef_mod.F
7728!|| imp_intm ../engine/share/modules/imp_intm.F
7729!|| imp_rwl ../engine/share/modules/impbufdef_mod.F
7730!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
7731!||====================================================================
7732 SUBROUTINE upd_kml(
7733 1 IPARI ,INTBUF_TAB,NINT2 ,IINT2 ,
7734 2 NPBY ,LPBY ,ITAB ,NRBYAC ,IRBYAC ,
7735 3 X ,IBFV ,LJ ,SKEW ,XFRAME ,
7736 4 ISKEW ,ICODT ,INLOC ,NSL ,IAD_M ,
7737 5 IDDL ,IKC ,NDOF ,IDDLM ,UD ,
7738 6 A ,KSL ,KSI ,NSREM ,NF_SI ,
7739 7 IDDLI ,IRBE3 ,LRBE3 ,FRBE3 ,IRBE2 ,
7740 8 LRBE2 )
7741C-----------------------------------------------
7742C M o d u l e s
7743C-----------------------------------------------
7744 USE imp_intm
7745 USE imp_rwl
7746 USE imp_aspc
7747 USE intbufdef_mod
7748C-----------------------------------------------
7749C I m p l i c i t T y p e s
7750C-----------------------------------------------
7751#include "implicit_f.inc"
7752C-----------------------------------------------
7753C C o m m o n B l o c k s
7754C-----------------------------------------------
7755#include "param_c.inc"
7756#include "tabsiz_c.inc"
7757C-----------------------------------------------
7758C D u m m y A r g u m e n t s
7759C-----------------------------------------------
7760 INTEGER IPARI(NPARI,*),NSL,IAD_M(*),NSREM
7761 INTEGER NPBY(NNPBY,*),LPBY(*),ITAB(*),NRBYAC,IRBYAC(*),
7762 . NINT2,IINT2(*),IDDL(*),IKC(*),NDOF(*),INLOC(*),
7763 . ibfv(nifv,*),lj(*),iskew(*),icodt(*),iddlm(*),
7764 . nf_si(*) ,iddli(*),irbe3(nrbe3l,*),lrbe3(*),
7765 . irbe2(nrbe2l,*),lrbe2(*)
7766C REAL
7767 my_real
7768 . x(3,*),skew(lskew,*),xframe(*),
7769 . ud(3,*),a(3,*),ksl(9,*) ,ksi(9,*),frbe3(*)
7770 TYPE(intbuf_struct_) INTBUF_TAB(*)
7771C-----------------------------------------------
7772C L o c a l V a r i a b l e s
7773C-----------------------------------------------
7774 INTEGER I,J,N,K,M,NS,NI,NSN,ILEV,IAD_M1(NSREM+1),
7775 . ji,l,nnod,
7776 . nj,nd,nl,isk,ifm,j1,iflag,nss,nm,id,iad0,iad,
7777 . i1,ict,nf,nr,is,jd,ifss,ifsm,ibid,jt(3),jr(3),iads,
7778 . irot,iadr,nn,irad,ic,eid
7779 my_real
7780 . ej(3),ksm(9),knm(9,4),krm(9,4),rbid
7781 my_real,
7782 . DIMENSION(:),ALLOCATABLE :: knm3,krm3
7783C-----only [ksm] to update : second dependant :FRK_SI, second inde. LT_SI,
7784C ---- --added inde,:FRK_SL-----------
7785 ifss = 0
7786 ifsm = 1
7787 nd = 3
7788C------partie kin, vis a vis de SL--------
7789 iad_m1(1) = 1
7790 DO n=1,nsrem
7791 iad_m1(n+1) = iad_m1(n)+ikc_si(n)*nf_si(n)
7792 ENDDO
7793 DO i=1,iad_m(nsl+1)-1
7794 DO j=1,9
7795 ksl(j,i) = zero
7796 ENDDO
7797 ENDDO
7798C------int2----------------------------------
7799 DO i=ni2_fr,1,-1
7800 n=ifrs2(1,i)
7801 ni=ifrs2(2,i)
7802 ji=ipari(1,n)
7803 nsn=ipari(5,n)
7804 ns=intbuf_tab(n)%NSV(ni)
7805 l=intbuf_tab(n)%IRTLM(ni)
7806 nl=4*(l-1)
7807 IF (intbuf_tab(n)%IRECTM(nl+3)==intbuf_tab(n)%IRECTM(nl+4)) THEN
7808 nnod=3
7809 ELSE
7810 nnod=4
7811 ENDIF
7812 ilev =ipari(20,n)
7813C
7814 IF (inloc(ns)>nsl) THEN
7815 nss = inloc(ns)-nsl
7816 nr=iad_slnr(nss+1)- iad_slnr(nss)
7817 CALL intabfr(nr,jdi_slnr(iad_slnr(nss)),ns,j)
7818 IF (j>0) THEN
7819 DO is = 1,nsrem
7820 iad = iad_m(nss) + j + is -2
7821 CALL cp_real(9,ksl(1,iad),ksm)
7822 IF (ilev==1) THEN
7823 CALL i2_frk1(intbuf_tab(n)%IRECTM,intbuf_tab(n)%DPARA,x ,itab ,
7824 . intbuf_tab(n)%NSV,
7825 1 intbuf_tab(n)%IRTLM,ikc ,ndof ,iddl ,iddlm,
7826 2 ibid ,ibid ,rbid,rbid ,rbid ,a ,
7827 3 rbid ,ksm ,knm ,krm ,ni ,
7828 4 ibid ,ifss ,ifsm)
7829 ELSE
7830 CALL i2_frk0(intbuf_tab(n)%IRECTM,intbuf_tab(n)%CSTS,x ,itab ,
7831 . intbuf_tab(n)%NSV,
7832 1 intbuf_tab(n)%IRTLM,ikc ,ndof ,iddl ,iddlm,
7833 2 ibid ,ibid ,rbid,rbid ,rbid ,a ,
7834 3 rbid ,ksm ,knm ,krm ,ni ,
7835 4 ibid ,ifss ,ifsm)
7836 ENDIF
7837 DO k =1,nnod
7838 nj=intbuf_tab(n)%IRECTM(nl+k)
7839 CALL intabfr(nr,jdi_slnr(iad_slnr(nss)),nj,j)
7840 iad = iad_m(nss) + j +is -2
7841 CALL cp_real(9,knm(1,k),ksl(1,iad))
7842 IF (ndof(nj)>3)CALL cp_real(9,krm(1,k),ksl(1,iad+nsrem))
7843 ENDDO
7844 END DO ! IS = 1,NSREM
7845 END IF !(J>0) THEN
7846 ELSE
7847 nss = inloc(ns)
7848 DO is = 1,nsrem
7849 nr =iad_sinr(is+1)- iad_sinr(is)
7850 CALL intabfr(nr,jdi_sinr(iad_sinr(is)),ns,j)
7851 IF (j>0) THEN
7852 DO nf = 1,max(1,nf_si(is))
7853C-------------------in KFR_SI----
7854 IF (ikc_si(is)>0.AND.nf_si(is)>0) THEN
7855 n = 0
7856 CALL get_iad(iad_m1,iad_sinr,jdi_sinr,n ,is ,
7857 1 j ,ikc_si(is),ndof ,iad )
7858 iad = iad + nf-1
7859 CALL cp_real(9,ksi(1,iad),ksm)
7860 ELSE
7861 id = iddl_si(is)
7862 nm = jdi_sinr(iad_sinr(is)+j-1)
7863 jd = iddli(nm)
7864 CALL getfr_kij( id ,jd ,iad_si ,jdi_si,lt_si ,
7865 1 ksm ,nd ,nd )
7866 ENDIF
7867 IF (ilev==1) THEN
7868 CALL i2_frk1(intbuf_tab(n)%IRECTM,intbuf_tab(n)%DPARA,x ,itab ,
7869 . intbuf_tab(n)%NSV,
7870 1 intbuf_tab(n)%IRTLM,ikc ,ndof ,iddl ,iddlm,
7871 2 ibid ,ibid ,rbid,rbid ,rbid ,a ,
7872 3 rbid ,ksm ,knm ,krm ,ni ,
7873 4 ibid ,ifss ,ifsm)
7874 ELSE
7875 CALL i2_frk0(intbuf_tab(n)%IRECTM,intbuf_tab(n)%CSTS,x ,itab ,
7876 . intbuf_tab(n)%NSV,
7877 1 intbuf_tab(n)%IRTLM,ikc ,ndof ,iddl ,iddlm,
7878 2 ibid ,ibid ,rbid,rbid ,rbid ,a ,
7879 3 rbid ,ksm ,knm ,krm ,ni ,
7880 4 ibid ,ifss ,ifsm)
7881 ENDIF
7882 DO k =1,nnod
7883 nj=intbuf_tab(n)%IRECTM(nl+k)
7884 nr =iad_slnr(nss+1)- iad_slnr(nss)
7885 CALL intabfr(nr,jdi_slnr(iad_slnr(nss)),nj,j)
7886 iad = iad_m(nss) + j + is -2
7887 CALL cp_real(9,knm(1,k),ksl(1,iad))
7888 IF (ndof(nj)>3)CALL cp_real(9,krm(1,k),ksl(1,iad+nsrem))
7889 ENDDO
7890 ENDDO
7891 ENDIF
7892 ENDDO
7893 ENDIF
7894C
7895 ENDDO
7896C------RBE2-------
7897 DO i=nrbe2_fr,1,-1
7898 n=ifrs4(1,i)
7899 m=irbe2(3,n)
7900 ns=ifrs4(2,i)
7901 isk = irbe2(7,n)
7902 irad =irbe2(11,n)
7903 ic = irbe2(4,n)
7904C--------remove ICR---
7905 ic =(ic/512)*512
7906 IF (inloc(ns)>nsl) THEN
7907 nss = inloc(ns)-nsl
7908 nr=iad_slnr(nss+1)- iad_slnr(nss)
7909 CALL intabfr(nr,jdi_slnr(iad_slnr(nss)),ns,j)
7910 IF (j>0) THEN
7911 DO is = 1,nsrem
7912 iad = iad_m(nss) + j + is -2
7913 CALL cp_real(9,ksl(1,iad),ksm)
7914 CALL prerbe2fr(ic ,jt ,jr )
7915 CALL rbe2_frk(ns ,m ,x ,isk ,skew(1,isk) ,
7916 1 irad ,ndof ,iddl ,jt ,jr ,
7917 2 ibid ,ibid ,rbid ,rbid ,rbid ,
7918 3 a ,rbid ,ksm ,knm ,krm ,
7919 4 ibid ,ifss ,ifsm )
7920 CALL intabfr(nr,jdi_slnr(iad_slnr(nss)),m,j)
7921 iad = iad_m(nss) + j + is -2
7922 CALL cp_real(9,knm,ksl(1,iad))
7923 CALL cp_real(9,krm,ksl(1,iad+nsrem))
7924 END DO ! IS = 1,NSREM
7925 END IF !(J>0) THEN
7926 ELSE
7927 nss = inloc(ns)
7928 DO is = 1,nsrem
7929 nr =iad_sinr(is+1)- iad_sinr(is)
7930 CALL intabfr(nr,jdi_sinr(iad_sinr(is)),ns,j)
7931 IF (j>0) THEN
7932 DO nf = 1,max(1,nf_si(is))
7933C----------------in KFR_SI------
7934 IF (ikc_si(is)>0.AND.nf_si(is)>0) THEN
7935 n = 0
7936 CALL get_iad(iad_m1,iad_sinr,jdi_sinr,n ,is ,
7937 1 j ,ikc_si(is),ndof ,iad )
7938 iad = iad + nf-1
7939 CALL cp_real(9,ksi(1,iad),ksm)
7940 ELSE
7941 id = iddl_si(is)
7942 nm = jdi_sinr(j+iad_sinr(is)-1)
7943 jd = iddli(nm)
7944 CALL getfr_kij(id ,jd ,iad_si ,jdi_si,lt_si ,
7945 1 ksm ,nd ,nd )
7946 ENDIF
7947 CALL prerbe2fr(ic ,jt ,jr )
7948 CALL rbe2_frk(ns ,m ,x ,isk ,skew(1,isk) ,
7949 1 irad ,ndof ,iddl ,jt ,jr ,
7950 2 ibid ,ibid ,rbid ,rbid ,rbid ,
7951 3 a ,rbid ,ksm ,knm ,krm ,
7952 4 ibid ,ifss ,ifsm )
7953 nr=iad_slnr(nss+1)- iad_slnr(nss)
7954 CALL intabfr(nr,jdi_slnr(iad_slnr(nss)),m,j)
7955 iad = iad_m(nss) + j + is -2
7956 CALL cp_real(9,knm,ksl(1,iad))
7957 CALL cp_real(9,krm,ksl(1,iad+nsrem))
7958 ENDDO
7959 ENDIF
7960 ENDDO
7961 ENDIF
7962 ENDDO
7963C------RBE3----------------------------------
7964 DO i=1,nrbe3_fr
7965 n=ifrs3(i)
7966 ns=irbe3(3,n)
7967 iadr=irbe3(1,n)
7968 nnod=irbe3(5,n)
7969 irot =irbe3(6,n)
7970 eid =irbe3(2,n)
7971 iads = slrbe3/2+iadr
7972 CALL prerbe3fr(irbe3 ,n ,jt ,jr )
7973 ALLOCATE(knm3(9*nnod))
7974 IF (irot>0) ALLOCATE(krm3(9*nnod))
7975 IF (inloc(ns)>nsl) THEN
7976 nss = inloc(ns)-nsl
7977 nr=iad_slnr(nss+1)- iad_slnr(nss)
7978 CALL intabfr(nr,jdi_slnr(iad_slnr(nss)),ns,j)
7979 IF (j>0) THEN
7980 DO is = 1,nsrem
7981 iad = iad_m(nss) + j + is -2
7982 CALL cp_real(9,ksl(1,iad),ksm)
7983 CALL rbe3_fr0(ns ,nnod ,lrbe3(iadr+1) ,x ,irot ,
7984 2 jt ,jr ,frbe3(6*iadr+1) ,skew ,ikc ,
7985 3 ndof ,ibid ,ibid ,rbid ,rbid ,
7986 2 rbid ,ksm ,knm3 ,krm3 ,ibid ,
7987 3 ifss ,ifsm ,itab ,lrbe3(iads+1),eid)
7988 DO k =1,nnod
7989 nj = lrbe3(iadr+k)
7990 CALL intabfr(nr,jdi_slnr(iad_slnr(nss)),nj,j)
7991 iad = iad_m(nss) + j +is -2
7992 id = 9*(k-1) + 1
7993 CALL cp_real(9,knm3(id),ksl(1,iad))
7994 IF (irot>0.AND.ndof(nj)==6)
7995 + CALL cp_real(9,krm3(id),ksl(1,iad+nsrem))
7996 ENDDO
7997 END DO ! IS = 1,NSREM
7998 END IF !(J>0) THEN
7999 ELSE
8000 nss = inloc(ns)
8001 DO is = 1,nsrem
8002 nr =iad_sinr(is+1)- iad_sinr(is)
8003 CALL intabfr(nr,jdi_sinr(iad_sinr(is)),ns,j)
8004 IF (j>0) THEN
8005 DO nf = 1,max(1,nf_si(is))
8006C-------------------in KFR_SI----
8007 IF (ikc_si(is)>0.AND.nf_si(is)>0) THEN
8008 n = 0
8009 CALL get_iad(iad_m1,iad_sinr,jdi_sinr,n ,is ,
8010 1 j ,ikc_si(is),ndof ,iad )
8011 iad = iad + nf-1
8012 CALL cp_real(9,ksi(1,iad),ksm)
8013 ELSE
8014 id = iddl_si(is)
8015 nm = jdi_sinr(iad_sinr(is)+j-1)
8016 jd = iddli(nm)
8017 CALL getfr_kij( id ,jd ,iad_si ,jdi_si,lt_si ,
8018 1 ksm ,nd ,nd )
8019 ENDIF
8020 CALL rbe3_fr0(ns ,nnod ,lrbe3(iadr+1) ,x ,irot ,
8021 2 jt ,jr ,frbe3(6*iadr+1) ,skew ,ikc ,
8022 3 ndof ,ibid ,ibid ,rbid ,rbid ,
8023 2 rbid ,ksm ,knm3 ,krm3 ,ibid ,
8024 3 ifss ,ifsm ,itab ,lrbe3(iads+1),eid)
8025 DO k =1,nnod
8026 nj = lrbe3(iadr+k)
8027 nr =iad_slnr(nss+1)- iad_slnr(nss)
8028 CALL intabfr(nr,jdi_slnr(iad_slnr(nss)),nj,j)
8029 iad = iad_m(nss) + j + is -2
8030 id = 9*(k-1) + 1
8031 CALL cp_real(9,knm3(id),ksl(1,iad))
8032 IF (irot>0.AND.ndof(nj)==6)
8033 + CALL cp_real(9,krm3(id),ksl(1,iad+nsrem))
8034 ENDDO
8035 ENDDO
8036 ENDIF !(J>0)
8037 ENDDO
8038 ENDIF
8039 DEALLOCATE(knm3)
8040 IF (irot>0) DEALLOCATE(krm3)
8041C
8042 ENDDO
8043C------Rigid bodies-------
8044 DO i=nrb_fr,1,-1
8045 m=ifrsr(1,i)
8046 ns=ifrsr(2,i)
8047 IF (inloc(ns)>nsl) THEN
8048 nss = inloc(ns)-nsl
8049 nr=iad_slnr(nss+1)- iad_slnr(nss)
8050 CALL intabfr(nr,jdi_slnr(iad_slnr(nss)),ns,j)
8051 IF (j>0) THEN
8052 DO is = 1,nsrem
8053 iad = iad_m(nss) + j + is -2
8054 CALL cp_real(9,ksl(1,iad),ksm)
8055 CALL rby_frk(ns ,m ,x ,itab ,ikc ,
8056 1 ndof ,iddl ,iddlm,ibid ,ibid ,
8057 2 rbid ,rbid ,rbid ,a ,rbid ,
8058 3 ksm ,knm ,krm ,ibid,ifss,ifsm)
8059 CALL intabfr(nr,jdi_slnr(iad_slnr(nss)),m,j)
8060 iad = iad_m(nss) + j + is -2
8061 CALL cp_real(9,knm,ksl(1,iad))
8062 CALL cp_real(9,krm,ksl(1,iad+nsrem))
8063 END DO ! IS = 1,NSREM
8064 END IF !(J>0) THEN
8065 ELSE
8066 nss = inloc(ns)
8067 DO is = 1,nsrem
8068 nr =iad_sinr(is+1)- iad_sinr(is)
8069 CALL intabfr(nr,jdi_sinr(iad_sinr(is)),ns,j)
8070 IF (j>0) THEN
8071 DO nf = 1,max(1,nf_si(is))
8072C----------------in KFR_SI------
8073 IF (ikc_si(is)>0.AND.nf_si(is)>0) THEN
8074 n = 0
8075 CALL get_iad(iad_m1,iad_sinr,jdi_sinr,n ,is ,
8076 1 j ,ikc_si(is),ndof ,iad )
8077 iad = iad + nf-1
8078 CALL cp_real(9,ksi(1,iad),ksm)
8079 ELSE
8080 id = iddl_si(is)
8081 nm = jdi_sinr(j+iad_sinr(is)-1)
8082 jd = iddli(nm)
8083 CALL getfr_kij(id ,jd ,iad_si ,jdi_si,lt_si ,
8084 1 ksm ,nd ,nd )
8085 ENDIF
8086 CALL rby_frk(ns ,m ,x ,itab ,ikc ,
8087 1 ndof ,iddl ,iddlm,ibid ,ibid ,
8088 2 rbid ,rbid ,rbid ,a ,rbid ,
8089 3 ksm ,knm ,krm ,ibid,ifss,ifsm)
8090 nr=iad_slnr(nss+1)- iad_slnr(nss)
8091 CALL intabfr(nr,jdi_slnr(iad_slnr(nss)),m,j)
8092 iad = iad_m(nss) + j + is - 2
8093 CALL cp_real(9,knm,ksl(1,iad))
8094 CALL cp_real(9,krm,ksl(1,iad+nsrem))
8095 ENDDO
8096 ENDIF
8097 ENDDO
8098 ENDIF
8099 ENDDO
8100C
8101 DO i1 = 1,nbc_fr
8102 ns = ibc_fr(1,i1)
8103 isk= ibc_fr(2,i1)
8104 ict= ibc_fr(3,i1)
8105 IF (inloc(ns)>nsl) THEN
8106 nss = inloc(ns)-nsl
8107 nr=iad_slnr(nss+1)- iad_slnr(nss)
8108 CALL intabfr(nr,jdi_slnr(iad_slnr(nss)),ns,j)
8109 IF (j>0) THEN
8110 DO is = 1,nsrem
8111 iad = iad_m(nss) + j + is -2
8112 CALL cp_real(9,ksl(1,iad),ksm)
8113 CALL bcl_frk(ns ,iddl ,iddlm ,ict ,isk ,
8114 1 skew ,ikc ,ibid ,ibid ,rbid ,
8115 2 rbid ,rbid ,a ,rbid ,ksm ,
8116 3 ibid ,ifss ,ifsm )
8117 CALL cp_real(9,knm,ksl(1,iad))
8118 END DO ! IS = 1,NSREM
8119 END IF !(J>0) THEN
8120 ELSE
8121 nss = inloc(ns)
8122 DO is = 1,nsrem
8123 nr =iad_sinr(is+1)- iad_sinr(is)
8124 CALL intabfr(nr,jdi_sinr(iad_sinr(is)),ns,j)
8125 IF (j>0) THEN
8126 DO nf = 1,max(1,nf_si(is))
8127C----------------in KFR_SI------
8128 IF (ikc_si(is)>0.AND.nf_si(is)>0) THEN
8129 n = 0
8130 CALL get_iad(iad_m1,iad_sinr,jdi_sinr,n ,is ,
8131 1 j ,ikc_si(is),ndof ,iad )
8132 iad = iad + nf-1
8133 CALL cp_real(9,ksi(1,iad),ksm)
8134 ELSE
8135 id = iddl_si(is)
8136 nm = jdi_sinr(iad_sinr(is)+j-1)
8137 jd = iddli(nm)
8138 CALL getfr_kij( id ,jd ,iad_si ,jdi_si,lt_si ,
8139 1 ksm ,nd ,nd )
8140 ENDIF
8141 CALL bcl_frk(ns ,iddl ,iddlm ,ict ,isk ,
8142 1 skew ,ikc ,ibid ,ibid ,rbid ,
8143 2 rbid ,rbid ,a ,rbid ,ksm ,
8144 3 ibid ,ifss ,ifsm )
8145C--------------!!!!!!!!! still--in KFR_SI--!!!!!!----
8146 IF (ikc_si(is)>0.AND.nf_si(is)>0) THEN
8147 CALL cp_real(9,knm,ksi(1,iad))
8148 ELSE
8149 iad = iad_m(nss) + is -1
8150 CALL cp_real(9,knm,ksl(1,iad))
8151 ENDIF
8152 ENDDO
8153 ENDIF
8154 ENDDO
8155 ENDIF
8156 ENDDO
8157C
8158 DO i1 = 1,nspc_fr
8159 n = ispc_fr(i1)
8160 ns = in_spc(n)
8161 iadr = 6*(n-1)+1
8162 nn = ic_spc(n)
8163 IF (inloc(ns)>nsl) THEN
8164 nss = inloc(ns)-nsl
8165 nr=iad_slnr(nss+1)- iad_slnr(nss)
8166 CALL intabfr(nr,jdi_slnr(iad_slnr(nss)),ns,j)
8167 IF (j>0) THEN
8168 DO is = 1,nsrem
8169 iad = iad_m(nss) + j + is -2
8170 CALL cp_real(9,ksl(1,iad),ksm)
8171 CALL bc_updfr(ns ,iddl ,skew_spc(iadr),ji ,iddlm ,
8172 1 ikc ,ibid ,ibid ,rbid ,rbid ,
8173 2 rbid ,a ,rbid ,ksm ,ibid ,
8174 3 ifss ,ifsm )
8175 IF (nn==1) THEN
8176 ej(1)=skew_spc(iadr)
8177 ej(2)=skew_spc(iadr+1)
8178 ej(3)=skew_spc(iadr+2)
8179 CALL l_dir(ej,ji)
8180 CALL bc_updfr(i ,iddl ,ej ,ji ,iddlm ,
8181 1 ikc ,ibid ,ibid ,rbid ,rbid ,
8182 2 rbid ,a ,rbid ,ksm ,ibid ,
8183 3 ifss ,ifsm )
8184 ELSE
8185 CALL bc_updfr2(i ,iddl ,skew_spc(iadr),skew_spc(iadr+3),
8186 1 iddlm ,ibid ,ibid ,ibid ,rbid ,rbid ,
8187 2 rbid ,a ,rbid ,ksm ,ibid ,
8188 3 ifss ,ifsm )
8189 END IF
8190 CALL cp_real(9,knm,ksl(1,iad))
8191 END DO ! IS = 1,NSREM
8192 END IF !(J>0) THEN
8193 ELSE
8194 nss = inloc(ns)
8195 DO is = 1,nsrem
8196 nr =iad_sinr(is+1)- iad_sinr(is)
8197 CALL intabfr(nr,jdi_sinr(iad_sinr(is)),ns,j)
8198 IF (j>0) THEN
8199 DO nf = 1,max(1,nf_si(is))
8200C----------------in KFR_SI------
8201 IF (ikc_si(is)>0.AND.nf_si(is)>0) THEN
8202 n = 0
8203 CALL get_iad(iad_m1,iad_sinr,jdi_sinr,n ,is ,
8204 1 j ,ikc_si(is),ndof ,iad )
8205 iad = iad + nf-1
8206 CALL cp_real(9,ksi(1,iad),ksm)
8207 ELSE
8208 id = iddl_si(is)
8209 nm = jdi_sinr(iad_sinr(is)+j-1)
8210 jd = iddli(nm)
8211 CALL getfr_kij( id ,jd ,iad_si ,jdi_si,lt_si ,
8212 1 ksm ,nd ,nd )
8213 ENDIF
8214 IF (nn==1) THEN
8215 ej(1)=skew_spc(iadr)
8216 ej(2)=skew_spc(iadr+1)
8217 ej(3)=skew_spc(iadr+2)
8218 CALL l_dir(ej,ji)
8219 CALL bc_updfr(i ,iddl ,ej ,ji ,iddlm ,
8220 1 ikc ,ibid ,ibid ,rbid ,rbid ,
8221 2 rbid ,a ,rbid ,ksm ,ibid ,
8222 3 ifss ,ifsm )
8223 ELSE
8224 CALL bc_updfr2(i ,iddl ,skew_spc(iadr),skew_spc(iadr+3),
8225 1 iddlm ,ibid ,ibid ,ibid ,rbid ,rbid ,
8226 2 rbid ,a ,rbid ,ksm ,ibid ,
8227 3 ifss ,ifsm )
8228 END IF
8229C--------------!!!!!!!!! still--in KFR_SI--!!!!!!----
8230 IF (ikc_si(is)>0.AND.nf_si(is)>0) THEN
8231 CALL cp_real(9,knm,ksi(1,iad))
8232 ELSE
8233 iad = iad_m(nss) + is -1
8234 CALL cp_real(9,knm,ksl(1,iad))
8235 ENDIF
8236 ENDDO
8237 ENDIF
8238 ENDDO
8239 ENDIF
8240 ENDDO
8241C
8242 IF (nfx_fr>0) THEN
8243 DO l=1,nfx_fr
8244 i = ifx_fr(1,l)
8245 j1 = ifx_fr(2,l)
8246 ns=iabs(ibfv(1,i))
8247 IF (inloc(ns)>nsl) THEN
8248 nss = inloc(ns)-nsl
8249 nr=iad_slnr(nss+1)- iad_slnr(nss)
8250 CALL intabfr(nr,jdi_slnr(iad_slnr(nss)),ns,j)
8251 IF (j>0) THEN
8252 DO is = 1,nsrem
8253 iad = iad_m(nss) + j + is -2
8254 CALL cp_real(9,ksl(1,iad),ksm)
8255 CALL fvl_frk(j1 ,i ,ibfv ,skew ,xframe,
8256 1 iddl ,iddlm ,ikc ,ibid ,ibid ,
8257 2 rbid ,rbid ,ud ,rbid ,a ,
8258 3 rbid ,ksm ,ibid ,ifss ,ifsm )
8259 CALL intabfr(nr,jdi_slnr(iad_slnr(nss)),ns,j)
8260 iad = iad_m(nss) + j + is -2
8261 CALL cp_real(9,knm,ksl(1,iad))
8262 CALL cp_real(9,krm,ksl(1,iad+nsrem))
8263 END DO ! IS = 1,NSREM
8264 END IF !(J>0) THEN
8265 ELSE
8266 nss = inloc(ns)
8267 DO is = 1,nsrem
8268 nr =iad_sinr(is+1)- iad_sinr(is)
8269 CALL intabfr(nr,jdi_sinr(iad_sinr(is)),ns,j)
8270 IF (j>0) THEN
8271 DO nf = 1,max(1,nf_si(is))
8272C----------------in KFR_SI------
8273 IF (ikc_si(is)>0.AND.nf_si(is)>0) THEN
8274 n = 0
8275 CALL get_iad(iad_m1,iad_sinr,jdi_sinr,n ,is ,
8276 1 j ,ikc_si(is),ndof ,iad )
8277 iad = iad + nf-1
8278 CALL cp_real(9,ksi(1,iad),ksm)
8279 ELSE
8280 id = iddl_si(is)
8281 nm = jdi_sinr(iad_sinr(is)+j-1)
8282 jd = iddli(nm)
8283 CALL getfr_kij( id ,jd ,iad_si ,jdi_si,lt_si ,
8284 1 ksm ,nd ,nd )
8285 ENDIF
8286 CALL fvl_frk(j1 ,i ,ibfv ,skew ,xframe,
8287 1 iddl ,iddlm ,ikc ,ibid ,ibid ,
8288 2 rbid ,rbid ,ud ,rbid ,a ,
8289 3 rbid ,ksm ,ibid ,ifss ,ifsm )
8290C--------------!!!!!!!!! still--in KFR_SI--!!!!!!----
8291 IF (ikc_si(is)>0.AND.nf_si(is)>0) THEN
8292 CALL cp_real(9,knm,ksi(1,iad))
8293 ELSE
8294 iad = iad_m(nss) + is -1
8295 CALL cp_real(9,knm,ksl(1,iad))
8296 ENDIF
8297 ENDDO
8298 ENDIF
8299 ENDDO
8300 ENDIF
8301 ENDDO
8302 ENDIF
8303C
8304 DO l = 1,nrw_fr
8305 i = irw_fr(l)
8306 ns=in_rwl(i)
8307 ej(1)=nor_rwl(1,i)
8308 ej(2)=nor_rwl(2,i)
8309 ej(3)=nor_rwl(3,i)
8310 CALL l_dir(ej,j1)
8311 IF (inloc(ns)>nsl) THEN
8312 nss = inloc(ns)-nsl
8313 nr=iad_slnr(nss+1)- iad_slnr(nss)
8314 CALL intabfr(nr,jdi_slnr(iad_slnr(nss)),ns,j)
8315 IF (j>0) THEN
8316 DO is = 1,nsrem
8317 iad = iad_m(nss) + j + is -2
8318 CALL cp_real(9,ksl(1,iad),ksm)
8319 CALL fv_updfr(ns ,ej ,j1 ,iddl ,iddlm ,
8320 1 ikc ,ibid ,ibid ,rbid ,rbid ,
8321 2 ud ,rbid ,a ,rbid ,ksm ,
8322 3 ibid ,ifss ,ifsm )
8323 CALL intabfr(nr,jdi_slnr(iad_slnr(nss)),ns,j)
8324 iad = iad_m(nss) + j + is -2
8325 CALL cp_real(9,knm,ksl(1,iad))
8326 CALL cp_real(9,krm,ksl(1,iad+nsrem))
8327 END DO ! IS = 1,NSREM
8328 END IF !(J>0) THEN
8329 ELSE
8330 nss = inloc(ns)
8331 DO is = 1,nsrem
8332 nr =iad_sinr(is+1)- iad_sinr(is)
8333 CALL intabfr(nr,jdi_sinr(iad_sinr(is)),ns,j)
8334 IF (j>0) THEN
8335 DO nf = 1,max(1,nf_si(is))
8336C----------------in KFR_SI------
8337 IF (ikc_si(is)>0.AND.nf_si(is)>0) THEN
8338 n = 0
8339 CALL get_iad(iad_m1,iad_sinr,jdi_sinr,n ,is ,
8340 1 j ,ikc_si(is),ndof ,iad )
8341 iad = iad + nf-1
8342 CALL cp_real(9,ksi(1,iad),ksm)
8343 ELSE
8344 id = iddl_si(is)
8345 nm = jdi_sinr(iad_sinr(is)+j-1)
8346 jd = iddli(nm)
8347 CALL getfr_kij( id ,jd ,iad_si ,jdi_si,lt_si ,
8348 1 ksm ,nd ,nd )
8349 ENDIF
8350 CALL fv_updfr(ns ,ej ,j1 ,iddl ,iddlm ,
8351 1 ikc ,ibid ,ibid ,rbid ,rbid ,
8352 2 ud ,rbid ,a ,rbid ,ksm ,
8353 3 ibid ,ifss ,ifsm )
8354C--------------!!!!!!!!! still--in KFR_SI--!!!!!!----
8355 IF (ikc_si(is)>0.AND.nf_si(is)>0) THEN
8356 CALL cp_real(9,knm,ksi(1,iad))
8357 ELSE
8358 iad = iad_m(nss) + is -1
8359 CALL cp_real(9,knm,ksl(1,iad))
8360 ENDIF
8361 ENDDO
8362 ENDIF
8363 ENDDO
8364 ENDIF
8365 ENDDO
8366C--------------------------------------------
8367C
8368 RETURN
8369 END
8370!||====================================================================
8371!|| imp_frkm ../engine/source/mpi/implicit/imp_fri.F
8372!||--- called by ------------------------------------------------------
8373!|| imp_frkd ../engine/source/mpi/implicit/imp_fri.F
8374!||--- calls -----------------------------------------------------
8375!|| cp_int ../engine/source/implicit/produt_v.F
8376!|| cp_real ../engine/source/implicit/produt_v.F
8377!|| getfr_kij ../engine/source/mpi/implicit/imp_fri.f
8378!||--- uses -----------------------------------------------------
8379!|| imp_intm ../engine/share/modules/imp_intm.F
8380!||====================================================================
8381 SUBROUTINE imp_frkm(
8382 1 NSREM ,IKINM ,IKCSI ,IKC ,NDOF ,
8383 2 IDDL ,IDDLM ,INLOC ,IAD_M ,FRK_SI ,
8384 3 FRK_SL ,NF_SI ,IAD_MLD ,IDDLI )
8385C-----------------------------------------------
8386C M o d u l e s
8387C-----------------------------------------------
8388 USE imp_intm
8389C----6---------------------------------------------------------------7---------8
8390C I m p l i c i t T y p e s
8391C-----------------------------------------------
8392#include "implicit_f.inc"
8393C-----------------------------------------------
8394C C o m m o n B l o c k s
8395C-----------------------------------------------
8396#include "com01_c.inc"
8397C-----------------------------------------------------------------
8398C D u m m y A r g u m e n t s
8399C-----------------------------------------------
8400 integer
8401 . nsrem,iddl(*),iddlm(*),inloc(*),ikc(*),ndof(*),iad_m(*),
8402 . ikcsi(3,*),ikinm ,nf_si(*) ,iad_mld(*) ,iddli(*)
8403 my_real
8404 . frk_si(3,3,*) ,frk_sl(3,3,*)
8405C-----------------------------------------------
8406C L o c a l V a r i a b l e s
8407C-----------------------------------------------
8408 INTEGER I,J,N,K,P,L,NL,NJ,NDOFI,NZ,NDS,NKC,IAD,J1,K1,ID,NS,NM
8409 INTEGER IDDL_CP(NDDL_SI),IAD_CP(NDDL_SI+1),JDI_CP(NZ_SI),
8410 . iad_m1(nsrem+1),nr,idm,jd,iadi,
8411 . ier1,ier2,ier3,ier4,ier5,ier6
8412 my_real
8413 . kij(3,3),lt_cp(nz_si)
8414c----------IDDL_SL->condense--For the case of no Kine nodes should change also local id->globle --
8415C-------------(debug) 257564:
8416 CALL cp_int((nddl_si+1),iad_si,iad_cp)
8417 CALL cp_int(nz_si,jdi_si,jdi_cp)
8418 CALL cp_real(nz_si,lt_si,lt_cp)
8419c---------ini IAD_MLD----
8420 ndofi = 3
8421 nl = 0
8422 nz = 0
8423 iad_mld(1) = nl +1
8424 IF (ikinm==0 ) THEN
8425 DO p=1,nspmd
8426 DO i=iad_srem(p),iad_srem(p+1)-1
8427 nl = nl + ndofi
8428 DO k = 1,ndofi
8429 DO j1 =iad_sinr(i), iad_sinr(i+1)-1
8430 nj = jdi_sinr(j1)
8431 id = iddl(nj)
8432 idm = iddlm(nj)
8433C-----------INPEND. LT_CP-------
8434 IF (ndof(nj)>0) THEN
8435 id = iddl_si(i)
8436 jd = iddli(nj)
8437 CALL getfr_kij( id ,jd ,iad_cp ,jdi_cp,lt_cp ,
8438 1 kij ,ndofi,ndofi )
8439 DO k1 = 1,ndofi
8440 nz = nz + 1
8441 jdi_si(nz) = idm + k1
8442 lt_si(nz) = kij(k,k1)
8443 ENDDO
8444 END IF !(NDOF(NJ)>0) THEN
8445 END DO !J1 =IAD_SINR(I), IAD_SINR(I+1)-1
8446 END DO !DO K = 1,NDOFI
8447 END DO
8448 iad_mld(p+1) = nl +1
8449 END DO !DO P=1,NSPMD
8450 ELSE
8451C
8452 iad_m1(1) = 0
8453 DO n=1,nsrem
8454 iad_m1(n+1) = iad_m1(n)+ikc_si(n)*nf_si(n)
8455 ENDDO
8456c----------DIMENSION----
8457 nl = 0
8458 nz = 0
8459 iad = 1
8460 DO i=1,nsrem
8461C-----------SECOND DEPEND.: FRK_SI---------
8462 IF (ikc_si(i)>0) THEN
8463 DO j =1, nf_si(i)
8464 DO k = 1,ndofi
8465 IF (ikcsi(k,iad)==0) THEN
8466 nl = nl + 1
8467 DO j1 =iad_sinr(i), iad_sinr(i+1)-1
8468 nj = jdi_sinr(j1)
8469 id = iddl(nj)
8470 DO k1 = 1,ndofi
8471 IF (ikc(k1+id)==0) nz = nz + 1
8472 ENDDO
8473C-----------DEPEND. SUP-:FRK_SL--------
8474 ns = inloc(nj)
8475 IF (ikc_sl(ns)>0) THEN
8476 DO l =iad_slnr(ns), iad_slnr(ns+1)-1
8477 nm = jdi_slnr(l)
8478 id = iddl(nm)
8479 DO k1 = 1,ndofi
8480 IF (ikc(k1+id)==0) nz = nz + 1
8481 ENDDO
8482 ENDDO
8483 ENDIF
8484 ENDDO
8485 ENDIF
8486 ENDDO
8487 iad = iad + 1
8488 ENDDO
8489C-----------SECOND INDEPEND.:LT,FRK_SL---------
8490 ELSE
8491 DO k = 1,ndofi
8492 nl = nl + 1
8493 DO j1 =iad_sinr(i), iad_sinr(i+1)-1
8494 nj = jdi_sinr(j1)
8495 id = iddl(nj)
8496 ns = inloc(nj)
8497 IF (ikc_sl(ns)>0) THEN
8498C-----------DEPEND. SUP-:FRK_SL--------
8499C-------------debug 257564: forget /BCS
8500 nr = iad_slnr(ns+1)-iad_slnr(ns)
8501 IF (nr==0) THEN
8502 DO k1 = 1,ndofi
8503 IF (ikc(k1+id)==0) nz = nz + 1
8504 ENDDO
8505 ELSE
8506 DO l =iad_slnr(ns), iad_slnr(ns+1)-1
8507 nm = jdi_slnr(l)
8508 id = iddl(nm)
8509 DO k1 = 1,ndofi
8510 IF (ikc(k1+id)==0) nz = nz + 1
8511 ENDDO
8512 IF (ndof(nm)==6) THEN
8513 DO k1 = 1,ndofi
8514 IF (ikc(k1+id+3)==0) nz = nz + 1
8515 ENDDO
8516 END IF
8517 ENDDO
8518 END IF !(NR==0) THEN
8519 ELSE
8520C-----------INPEND. LT_CP-------
8521 nz = nz + ndofi
8522 ENDIF
8523 ENDDO
8524 ENDDO
8525 ENDIF
8526 ENDDO
8527C
8528 nddl_si = nl
8529C
8530 IF(ALLOCATED(iad_si)) DEALLOCATE(iad_si)
8531 ALLOCATE(iad_si(nl+1),stat=ier1)
8532 IF (nz>nz_si) THEN
8533 IF(ALLOCATED(jdi_si)) DEALLOCATE(jdi_si)
8534 ALLOCATE(jdi_si(nz),stat=ier2)
8535 IF(ALLOCATED(lt_si)) DEALLOCATE(lt_si)
8536 ALLOCATE(lt_si(nz),stat=ier3)
8537 ENDIF
8538 nz_si =nz
8539C
8540 nl = 0
8541 nz = 0
8542 iad = 1
8543 iad_si(nl+1) = nz+1
8544 DO p=1,nspmd
8545 DO i=iad_srem(p),iad_srem(p+1)-1
8546C-----------SECOND DEPEND.: FRK_SI---------
8547 IF (ikc_si(i)>0) THEN
8548 nr = iad_sinr(i+1)-iad_sinr(i)
8549 DO j =1, nf_si(i)
8550 DO k = 1,ndofi
8551 IF (ikcsi(k,iad)==0) THEN
8552 nl = nl + 1
8553 DO j1 =iad_sinr(i), iad_sinr(i+1)-1
8554 nj = jdi_sinr(j1)
8555 id = iddl(nj)
8556 idm = iddlm(nj)
8557 IF (ndof(nj)>0) THEN
8558 nkc = 0
8559 iadi = iad_m1(i) +nf_si(i)*(j1-iad_sinr(i))+ j
8560 DO k1 = 1,ndofi
8561 IF (ikc(k1+id)==0) THEN
8562 nz = nz + 1
8563 jdi_si(nz) = idm + k1-nkc
8564 lt_si(nz) = frk_si(k,k1,iadi)
8565 ELSE
8566 nkc = nkc + 1
8567 ENDIF
8568 ENDDO
8569 END IF !(NDOF(NJ)>0) THEN
8570C-----------DEPEND. SUP-:FRK_SL--------
8571 ns = inloc(nj)
8572 IF (ikc_sl(ns)>0) THEN
8573 DO l =iad_slnr(ns), iad_slnr(ns+1)-1
8574 nm = jdi_slnr(l)
8575 id = iddl(nm)
8576 idm = iddlm(nm)
8577 IF (ndof(nm)>0) THEN
8578 nkc = 0
8579 iadi = iad_m(ns) + l-iad_slnr(ns) + i
8580 DO k1 = 1,ndofi
8581 IF (ikc(k1+id)==0) THEN
8582 nz = nz + 1
8583 jdi_si(nz) = idm + k1-nkc
8584 lt_si(nz) = frk_sl(k,k1,iadi)
8585 ELSE
8586 nkc = nkc + 1
8587 ENDIF
8588 ENDDO
8589 END IF !(ndof(nm)>0) THEN
8590 ENDDO
8591 ENDIF
8592 ENDDO
8593 iad_si(nl+1) = nz+1
8594 ENDIF
8595 ENDDO
8596 iad = iad + 1
8597 ENDDO
8598C-----------SECOND INDEPEND.:LT,FRK_SL---------
8599 ELSE
8600 DO k = 1,ndofi
8601 nl = nl + 1
8602 DO j1 =iad_sinr(i), iad_sinr(i+1)-1
8603 nj = jdi_sinr(j1)
8604 id = iddl(nj)
8605 idm = iddlm(nj)
8606c IF (NDOF(NJ)>0) THEN
8607C
8608 nkc = 0
8609 ns = inloc(nj)
8610 IF (ikc_sl(ns)>0) THEN
8611C-----------DEPEND. SUP-:FRK_SL--------
8612 nr = iad_slnr(ns+1)-iad_slnr(ns)
8613C-----------/BCS--------
8614 IF (nr==0) THEN
8615 jd = iddli(nj)
8616 CALL getfr_kij(iddl_si(i),jd ,iad_cp ,jdi_cp,lt_cp ,
8617 1 kij ,ndofi,ndofi )
8618 nkc = 0
8619 DO k1 = 1,ndofi
8620 IF (ikc(k1+id)==0) THEN
8621 nz = nz + 1
8622 jdi_si(nz) = idm + k1 -nkc
8623 lt_si(nz) = kij(k,k1)
8624 ELSE
8625 nkc = nkc + 1
8626 END IF !(IKC(K1+ID)==0) THEN
8627 ENDDO
8628 ELSE
8629 DO l =iad_slnr(ns), iad_slnr(ns+1)-1
8630 nm = jdi_slnr(l)
8631 id = iddl(nm)
8632 idm = iddlm(nm)
8633 nkc = 0
8634 iadi = iad_m(ns) + l-iad_slnr(ns) +i-1
8635 DO k1 = 1,ndofi
8636 IF (ikc(k1+id)==0) THEN
8637 nz = nz + 1
8638 jdi_si(nz) = idm + k1-nkc
8639 lt_si(nz) = frk_sl(k1,k,iadi)
8640 ELSE
8641 nkc = nkc + 1
8642 ENDIF
8643 ENDDO
8644 IF (ndof(nm)==6) THEN
8645 DO k1 = 4,ndofi+3
8646 IF (ikc(k1+id)==0) THEN
8647 nz = nz + 1
8648 jdi_si(nz) = idm + k1-nkc
8649 lt_si(nz) = frk_sl(k1-3,k,iadi+nsrem)
8650 ELSE
8651 nkc = nkc + 1
8652 ENDIF
8653 ENDDO
8654 END IF
8655 ENDDO
8656 END IF !(NR==0) THEN
8657 ELSEIF (ndof(nj)>0) THEN
8658C-----------INPEND. LT_CP-------
8659 id = iddl_si(i)
8660 jd = iddli(nj)
8661 CALL getfr_kij( id ,jd ,iad_cp ,jdi_cp,lt_cp ,
8662 1 kij ,ndofi,ndofi )
8663 DO k1 = 1,ndofi
8664 nz = nz + 1
8665 jdi_si(nz) = idm + k1
8666 lt_si(nz) = kij(k,k1)
8667 ENDDO
8668 ENDIF !IF IKC_SL
8669C END IF !(NDOF(NJ)>0) THEN
8670 ENDDO !DO J1
8671 iad_si(nl+1) = nz+1
8672 ENDDO !DO K
8673 ENDIF !IF IKC_SI
8674 ENDDO !DO I=
8675 iad_mld(p+1) = nl+1
8676 ENDDO ! DO P=
8677 END IF !IF (IKINM==0 )
8678C
8679 IF(ALLOCATED(iddl_si)) DEALLOCATE(iddl_si)
8680c IF(ALLOCATED(IKC_SI)) DEALLOCATE(IKC_SI)
8681 IF(ALLOCATED(ikc_sl)) DEALLOCATE(ikc_sl)
8682 IF(ALLOCATED(usi)) DEALLOCATE(usi)
8683 ALLOCATE(usi(nddl_si),stat=ier4)
8684 IF(ALLOCATED(fsi)) DEALLOCATE(fsi)
8685 ALLOCATE(fsi(nddl_si),stat=ier5)
8686C
8687 RETURN
8688 END
8689!||====================================================================
8690!|| dim_fvn ../engine/source/mpi/implicit/imp_fri.F
8691!||--- called by ------------------------------------------------------
8692!|| imp_frkd ../engine/source/mpi/implicit/imp_fri.F
8693!||====================================================================
8694 SUBROUTINE dim_fvn(
8695 1 NDOF ,IDDL ,IKC ,INLOC ,NFV )
8696C----6---------------------------------------------------------------7---------8
8697C I m p l i c i t T y p e s
8698C-----------------------------------------------
8699#include "implicit_f.inc"
8700C-----------------------------------------------
8701C C o m m o n B l o c k s
8702C-----------------------------------------------
8703#include "com04_c.inc"
8704C-----------------------------------------------------------------
8705C D u m m y A r g u m e n t s
8706C-----------------------------------------------
8707 INTEGER NFV, INLOC(*),NDOF(*),IKC(*),IDDL(*)
8708C REAL
8709C-----------------------------------------------
8710C L o c a l V a r i a b l e s
8711C-----------------------------------------------
8712 integer
8713 . i,j,k,n,nd,ns
8714C----------------------------
8715 nfv=0
8716C--------imposed velocity---------------
8717 DO n = 1, numnod
8718C--------local second node-----
8719 IF (inloc(n)>0) THEN
8720 ns = 0
8721 DO j = 1, min(3,ndof(n))
8722 nd = iddl(n)+j
8723 IF ((ikc(nd)>=2.AND.ikc(nd)<=4).OR.ikc(nd)==9) ns=1
8724 ENDDO
8725 IF (ns==1) nfv = nfv +1
8726 ENDIF
8727 ENDDO
8728C
8729C----6---------------------------------------------------------------7---------8
8730 RETURN
8731 END
8732!||====================================================================
8733!|| ind_fvn ../engine/source/mpi/implicit/imp_fri.f
8734!||--- called by ------------------------------------------------------
8735!|| imp_frkd ../engine/source/mpi/implicit/imp_fri.F
8736!||--- uses -----------------------------------------------------
8737!|| imp_intm ../engine/share/modules/imp_intm.F
8738!||====================================================================
8739 SUBROUTINE ind_fvn(
8740 1 NDOF ,IDDL ,IKC ,INLOC ,NFV )
8741C-----------------------------------------------
8742C M o d u l e s
8743C-----------------------------------------------
8744 USE imp_intm
8745C----6---------------------------------------------------------------7---------8
8746C I m p l i c i t T y p e s
8747C-----------------------------------------------
8748#include "implicit_f.inc"
8749C-----------------------------------------------
8750C C o m m o n B l o c k s
8751C-----------------------------------------------
8752#include "com04_c.inc"
8753C-----------------------------------------------------------------
8754C D u m m y A r g u m e n t s
8755C-----------------------------------------------
8756 INTEGER NFV,INLOC(*),NDOF(*),IKC(*),IDDL(*)
8757C REAL
8758C-----------------------------------------------
8759C L o c a l V a r i a b l e s
8760C-----------------------------------------------
8761 integer
8762 . i,j,k,n,nd,ns,nf
8763C-----------use islm-----------------
8764 IF(ALLOCATED(islm)) DEALLOCATE(islm)
8765 ALLOCATE(islm(nfv))
8766 nf=0
8767C--------imposed velocity---------------
8768 DO n = 1, numnod
8769C--------local second node-----
8770 IF (inloc(n)>0) THEN
8771 ns=0
8772 DO j = 1, min(3,ndof(n))
8773 nd = iddl(n)+j
8774 IF ((ikc(nd)>=2.AND.ikc(nd)<=4).OR.ikc(nd)==9) ns = 1
8775 ENDDO
8776 IF (ns==1) THEN
8777 nf = nf + 1
8778 islm(nf) = n
8779 ENDIF
8780 ENDIF
8781 ENDDO
8782C----6---------------------------------------------------------------7---------8
8783 RETURN
8784 END
8785!||====================================================================
8786!|| imp_fvkss ../engine/source/mpi/implicit/imp_fri.F
8787!||--- called by ------------------------------------------------------
8788!|| imp_frkd ../engine/source/mpi/implicit/imp_fri.F
8789!||--- calls -----------------------------------------------------
8790!|| get_kii ../engine/source/implicit/imp_glob_k.F
8791!|| intabfr ../engine/source/mpi/implicit/imp_fri.F
8792!|| put_kii ../engine/source/implicit/imp_glob_k.F
8793!||--- uses -----------------------------------------------------
8794!|| imp_intm ../engine/share/modules/imp_intm.F
8795!||====================================================================
8796 SUBROUTINE imp_fvkss(
8797 1 KSS ,IDDL ,IDDLM ,IKC ,NSL ,
8798 2 D_IMP ,LB ,NFV ,UDSL ,INLOC ,
8799 3 NDOF )
8800C-----------------------------------------------
8801C M o d u l e s
8802C-----------------------------------------------
8803 USE imp_intm
8804C----6---------------------------------------------------------------7---------8
8805C I m p l i c i t T y p e s
8806C-----------------------------------------------
8807#include "implicit_f.inc"
8808C-----------------------------------------------------------------
8809C D u m m y A r g u m e n t s
8810C-----------------------------------------------
8811 INTEGER NFV,NSL,IDDLM(*),IKC(*),IDDL(*),
8812 . inloc(*),ndof(*)
8813C REAL
8814 my_real
8815 . kss(6,*), d_imp(3,*) ,lb(*) ,udsl(3,*)
8816C-----------------------------------------------
8817C L o c a l V a r i a b l e s
8818C-----------------------------------------------
8819 integer
8820 . i,j,k,n,id,nd,ns,nkc,nm,is,nr,nj,nn,nl,im,
8821 . iad_m1(nsl+1),iadn(nsl),jj
8822 my_real
8823 . f_imp(6) ,kii(6,6)
8824C----------------------------
8825 iad_m1(1) = 1
8826 nn = 0
8827 DO i=1,nsl
8828 nl =0
8829 IF (ikc_sl(i)>0) THEN
8830 nr = iad_slnr(i+1)-iad_slnr(i)
8831 nl = max(1,nr)
8832 nn = nn + nl
8833 iadn(i) = nn
8834 ENDIF
8835 iad_m1(i+1) = iad_m1(i)+nl
8836 ENDDO
8837 DO i = 1, nfv
8838 n = islm(i)
8839 id = iddl(n)
8840 im = iddlm(n)
8841 DO k = 1, 3
8842 nd = id + k
8843 IF ((ikc(nd)>=2.AND.ikc(nd)<=4).OR.ikc(nd)==9) THEN
8844 udsl(k,i) = d_imp(k,n)
8845 ELSE
8846 udsl(k,i) = zero
8847 ENDIF
8848 ENDDO
8849 DO is = 1, nsl
8850 IF (inloc(n)>nsl) THEN
8851 nr = iad_slnr(is+1)-iad_slnr(is)
8852 CALL intabfr(nr,jdi_slnr(is),n,j)
8853 IF (j>0) THEN
8854 nn = iad_m1(is) + j -1
8855 nd = ndof(n)
8856 CALL get_kii(nn ,iddl_sl,iad_ss,diag_sl,lt_sl,kii,nd)
8857 DO j = 1, nd
8858 DO k = j+1, nd
8859 kii(k,j) = kii(j,k)
8860 ENDDO
8861 ENDDO
8862 DO k = 1, nd
8863 f_imp(k) = kii(k,1)*udsl(1,i)+ kii(k,2)*udsl(2,i)+
8864 . kii(k,3)*udsl(3,i)
8865 ENDDO
8866 nkc = 1
8867 DO k = 1, nd
8868 IF (ikc(id+k)==0) THEN
8869 nm = im + nkc
8870 lb(nm) = lb(nm) -f_imp(k)
8871 nkc = nkc + 1
8872 ENDIF
8873 ENDDO
8874 ENDIF
8875 ELSE
8876 IF (n==isl(is)) THEN
8877 j = is
8878 f_imp(1) = kss(1,j)*udsl(1,i)+ kss(4,j)*udsl(2,i)+
8879 . kss(5,j)*udsl(3,i)
8880 f_imp(2) = kss(4,j)*udsl(1,i)+ kss(2,j)*udsl(2,i)+
8881 . kss(6,j)*udsl(3,i)
8882 f_imp(3) = kss(5,j)*udsl(1,i)+ kss(6,j)*udsl(2,i)+
8883 . kss(3,j)*udsl(3,i)
8884 nd = 3
8885 nkc = 1
8886 DO k = 1, nd
8887 IF (ikc(id+k)==0) THEN
8888 nm = im + nkc
8889 lb(nm) = lb(nm) -f_imp(k)
8890 nkc = nkc + 1
8891 ENDIF
8892 ENDDO
8893 DO k = 1, nd
8894 kii(k,k) = kss(k,j)
8895 ENDDO
8896 kii(1,2)=kss(4,j)
8897 kii(1,3)=kss(5,j)
8898 kii(2,3)=kss(6,j)
8899 kii(2,1)=kii(1,2)
8900 kii(3,1)=kii(1,3)
8901 kii(3,2)=kii(2,3)
8902 CALL put_kii(iadn(j),iddl_sl,iad_ss,diag_sl,lt_sl,kii,nd)
8903 ENDIF
8904 ENDIF
8905 ENDDO ! IS = 1, NSL
8906 ENDDO
8907C----6---------------------------------------------------------------7---------8
8908 RETURN
8909 END
8910!||====================================================================
8911!|| ini_frud ../engine/source/mpi/implicit/imp_fri.F
8912!||--- called by ------------------------------------------------------
8913!|| imp_frkd ../engine/source/mpi/implicit/imp_fri.F
8914!||--- calls -----------------------------------------------------
8915!|| intabfr ../engine/source/mpi/implicit/imp_fri.F
8916!|| spmd_exci ../engine/source/mpi/implicit/imp_spmd.F
8917!||--- uses -----------------------------------------------------
8918!|| imp_intm ../engine/share/modules/imp_intm.F
8919!||====================================================================
8920 SUBROUTINE ini_frud(NSREM ,NSL ,NFV ,IFVSI ,IFVSL ,
8921 . NF_SI ,NF_SL ,LVSI )
8922C-----------------------------------------------
8923C M o d u l e s
8924C-----------------------------------------------
8925 USE imp_intm
8926C-----------------------------------------------
8927C I m p l i c i t T y p e s
8928C-----------------------------------------------
8929#include "implicit_f.inc"
8930C-----------------------------------------------
8931C C o m m o n B l o c k s
8932C-----------------------------------------------
8933#include "com01_c.inc"
8934C-----------------------------------------------
8935C D u m m y A r g u m e n t s
8936C-----------------------------------------------
8937 INTEGER NSREM ,NSL,NFV ,IFVSI(*) ,IFVSL(*) ,
8938 . nf_sl(*),nf_si(*),lvsi
8939C REAL
8940C-----------------------------------------------
8941C L o c a l V a r i a b l e s
8942C-----------------------------------------------
8943 INTEGER I,J,N,K,IAD,NJ,L
8944 INTEGER SSIZE ,RSIZE,SIZE,IAD_S(NSPMD+1),IAD_R(NSPMD+1)
8945C--------------------------------------------
8946 iad = 1
8947 DO i = 1, nsl
8948 IF (ikc_sl(i)>0) THEN
8949 DO k=1,nf_sl(i)
8950 ifvsl(iad) = 0
8951 iad = iad + 1
8952 ENDDO
8953 ENDIF
8954 ENDDO
8955C
8956 iad = 1
8957 DO i = 1, nsl
8958 IF (ikc_sl(i)>0.AND.nf_sl(i)>0) THEN
8959 n = isl(i)
8960 CALL intabfr(nfv,islm,n,j)
8961 IF (j>0) THEN
8962 ifvsl(iad) = j
8963 ELSE
8964 DO k=iad_slnr(i),iad_slnr(i+1)-1
8965 nj = jdi_slnr(k)
8966 CALL intabfr(nfv,islm,nj,l)
8967 IF (l>0) ifvsl(iad+k-iad_slnr(i)) = l
8968 ENDDO
8969 ENDIF
8970 iad = iad + nf_sl(i)
8971 ENDIF
8972 ENDDO
8973C
8974 iad_s(1) = 1
8975 iad_r(1) = 1
8976 DO i=1,nspmd
8977 iad_s(i+1) = iad_s(i)
8978 iad_r(i+1) = iad_r(i)
8979 DO j=iad_sl(i),iad_sl(i+1)-1
8980 iad_s(i+1) = iad_s(i+1) + nf_sl(j)
8981 END DO
8982 DO j=iad_srem(i),iad_srem(i+1)-1
8983 iad_r(i+1) = iad_r(i+1) + nf_si(j)
8984 END DO
8985 END DO
8986C
8987 SIZE = 1
8988 ssize = iad_s(nspmd+1) - 1
8989 rsize = iad_r(nspmd+1) - 1
8990 CALL spmd_exci(ifvsl,ifvsi,iad_s,iad_r,SIZE ,ssize,rsize)
8991C
8992 lvsi = 0
8993 iad = 1
8994 DO i = 1, nsrem
8995 IF (ikc_si(i)>0) THEN
8996 DO k=1,nf_si(i)
8997 IF (ifvsi(iad) > 0) lvsi = lvsi +1
8998 iad = iad + 1
8999 ENDDO
9000 ENDIF
9001 ENDDO
9002C
9003 RETURN
9004 END
9005!||====================================================================
9006!|| scom_frud ../engine/source/mpi/implicit/imp_fri.F
9007!||--- called by ------------------------------------------------------
9008!|| imp_frkd ../engine/source/mpi/implicit/imp_fri.F
9009!||--- calls -----------------------------------------------------
9010!|| spmd_exck ../engine/source/mpi/implicit/imp_spmd.F
9011!||--- uses -----------------------------------------------------
9012!|| imp_intm ../engine/share/modules/imp_intm.F
9013!||====================================================================
9014 SUBROUTINE scom_frud(UDS,UDR,NF_S,NF_R,IKCS,IKCR )
9015C-----------------------------------------------
9016C M o d u l e s
9017C-----------------------------------------------
9018 USE imp_intm
9019C-----------------------------------------------
9020C I m p l i c i t T y p e s
9021C-----------------------------------------------
9022#include "implicit_f.inc"
9023C-----------------------------------------------
9024C C o m m o n B l o c k s
9025C-----------------------------------------------
9026#include "com01_c.inc"
9027C-----------------------------------------------
9028C D u m m y A r g u m e n t s
9029C-----------------------------------------------
9030 INTEGER IKCS(*),IKCR(*),NF_S(*),NF_R(*)
9031 my_real
9032 . uds(3,*),udr(3,*)
9033C-----------------------------------------------
9034C L o c a l V a r i a b l e s
9035C-----------------------------------------------
9036 INTEGER I ,J ,K ,L,IADS,IADR,IER1,ID,ID0
9037 INTEGER SSIZE ,RSIZE,SIZE,IAD_S(NSPMD+1),IAD_R(NSPMD+1)
9038 my_real, DIMENSION(:,:),ALLOCATABLE :: uds1
9039C-----------------------------------------------
9040C S o u r c e L i n e s
9041C-----------------------------------------------
9042 SIZE = 3
9043 iads = 1
9044 iadr = 1
9045 iad_s(1) = 1
9046 iad_r(1) = 1
9047 DO i=1,nspmd
9048 iad_s(i+1) = iad_s(i)
9049 iad_r(i+1) = iad_r(i)
9050 DO j=iad_sl(i),iad_sl(i+1)-1
9051 DO k = 1,nf_s(j)
9052 iad_s(i+1) = iad_s(i+1) + min(1,ikcs(iads))
9053 iads = iads + 1
9054 END DO
9055 END DO
9056 DO j=iad_srem(i),iad_srem(i+1)-1
9057 DO k = 1,nf_r(j)
9058 iad_r(i+1) = iad_r(i+1) + min(1,ikcr(iadr))
9059 iadr = iadr + 1
9060 END DO
9061 END DO
9062 END DO
9063 ssize = iad_s(nspmd+1) - 1
9064 rsize = iad_r(nspmd+1) - 1
9065 IF (ssize>0) THEN
9066 ALLOCATE(uds1(3,ssize),stat=ier1)
9067 iads = 1
9068 DO i=1,nspmd
9069 id = iad_s(i)
9070 DO j=iad_sl(i),iad_sl(i+1)-1
9071 DO k = 1,nf_s(j)
9072 id0 = ikcs(iads)
9073 IF (id0>0) THEN
9074 DO l = 1,3
9075 uds1(l,id) = uds(l,id0)
9076 END DO
9077 id = id + 1
9078 ENDIF
9079 iads = iads + 1
9080 END DO
9081 END DO
9082 END DO
9083 ENDIF
9084 CALL spmd_exck(uds1,udr ,iad_s,iad_r,SIZE ,ssize,rsize)
9085 IF (ssize>0) DEALLOCATE(uds1)
9086C
9087 RETURN
9088 END
9089!||====================================================================
9090!|| imp_fvksl ../engine/source/mpi/implicit/imp_fri.F
9091!||--- called by ------------------------------------------------------
9092!|| imp_frkd ../engine/source/mpi/implicit/imp_fri.F
9093!||--- calls -----------------------------------------------------
9094!|| imp_fvksm ../engine/source/mpi/implicit/imp_fri.F
9095!||--- uses -----------------------------------------------------
9096!|| imp_intm ../engine/share/modules/imp_intm.F
9097!||====================================================================
9098 SUBROUTINE imp_fvksl(
9099 1 IDDL ,IDDLM ,IKC ,IFVSI ,NF_SI ,
9100 2 KSI ,LB ,NSREM ,UDSI )
9101C-----------------------------------------------
9102C M o d u l e s
9103C-----------------------------------------------
9104 USE imp_intm
9105C----6---------------------------------------------------------------7---------8
9106C I m p l i c i t T y p e s
9107C-----------------------------------------------
9108#include "implicit_f.inc"
9109C-----------------------------------------------------------------
9110C D u m m y A r g u m e n t s
9111C-----------------------------------------------
9112 INTEGER NSREM,IDDLM(*),IKC(*),IDDL(*),IFVSI(*),NF_SI(*)
9113C REAL
9114 my_real
9115 . ksi(9,*),lb(*) ,udsi(3,*)
9116C-----------------------------------------------
9117C L o c a l V a r i a b l e s
9118C-----------------------------------------------
9119 integer
9120 . i,j,j1,nj,iad,iadu,iadi,id,nd,jd,iad_m1(nsrem+1)
9121C----------------------------
9122 iad_m1(1) = 0
9123 DO i=1,nsrem
9124 iad_m1(i+1) = iad_m1(i)+ikc_si(i)*nf_si(i)
9125 ENDDO
9126 iad = 0
9127 iadu = 0
9128 DO i=1,nsrem
9129 IF (ikc_si(i)>0) THEN
9130 DO j =1, nf_si(i)
9131 iad = iad + 1
9132 IF (ifvsi(iad)>0) THEN
9133 iadu = iadu + 1
9134 DO j1 = iad_sinr(i),iad_sinr(i+1)-1
9135 nj = jdi_sinr(j1)
9136 iadi = iad_m1(i) +nf_si(i)*(j1-iad_sinr(i))+ j
9137 CALL imp_fvksm(
9138 1 nj ,iddl ,iddlm ,ikc ,
9139 2 udsi(1,iadu),ksi(1,iadi),lb )
9140 ENDDO
9141 ENDIF
9142 ENDDO
9143 ENDIF
9144 ENDDO
9145C----6---------------------------------------------------------------7---------8
9146 RETURN
9147 END
9148!||====================================================================
9149!|| imp_fvksm ../engine/source/mpi/implicit/imp_fri.F
9150!||--- called by ------------------------------------------------------
9151!|| imp_fvksl ../engine/source/mpi/implicit/imp_fri.F
9152!||====================================================================
9153 SUBROUTINE imp_fvksm(
9154 1 NJ ,IDDL ,IDDLM ,IKC ,
9155 2 UDS ,KSM ,LB )
9156C----6---------------------------------------------------------------7---------8
9157C I m p l i c i t T y p e s
9158C-----------------------------------------------
9159#include "implicit_f.inc"
9160C-----------------------------------------------------------------
9161C D u m m y A r g u m e n t s
9162C-----------------------------------------------
9163 INTEGER NJ,IDDLM(*),IKC(*),IDDL(*)
9164C REAL
9165 my_real
9166 . ksm(3,3), lb(*) ,uds(3)
9167C-----------------------------------------------
9168C L o c a l V a r i a b l e s
9169C-----------------------------------------------
9170 integer
9171 . k,n,nd,ns,nkc,nm
9172 my_real
9173 . lbd(3)
9174C----------------------------
9175 DO k=1,3
9176 lbd(k) = ksm(1,k)*uds(1)+ ksm(2,k)*uds(2)+
9177 . ksm(3,k)*uds(3)
9178 ENDDO
9179C
9180 nkc = 1
9181 DO k = 1, 3
9182 nd = iddl(nj)+k
9183 nm = iddlm(nj) + nkc
9184 IF (ikc(nd)==0) THEN
9185 lb(nm) = lb(nm) -lbd(k)
9186 nkc = nkc + 1
9187 ENDIF
9188 ENDDO
9189C----6---------------------------------------------------------------7---------8
9190 RETURN
9191 END
9192!||====================================================================
9193!|| imp_fvkm ../engine/source/mpi/implicit/imp_fri.F
9194!||--- called by ------------------------------------------------------
9195!|| imp_frkd ../engine/source/mpi/implicit/imp_fri.F
9196!||--- calls -----------------------------------------------------
9197!|| get_iad ../engine/source/mpi/implicit/imp_fri.F
9198!|| getfr_kij ../engine/source/mpi/implicit/imp_fri.F
9199!|| intabfr ../engine/source/mpi/implicit/imp_fri.F
9200!||--- uses -----------------------------------------------------
9201!|| imp_intm ../engine/share/modules/imp_intm.F
9202!||====================================================================
9203 SUBROUTINE imp_fvkm(
9204 1 KFR_SI ,KFR_SL ,IDDL ,NDOF ,IKC ,
9205 2 INLOC ,IAD_M ,NSREM ,NSL ,UD0 ,
9206 3 FDSI ,NF_SI ,NFV ,NFD ,IDDLI )
9207C-----------------------------------------------
9208C M o d u l e s
9209C-----------------------------------------------
9210 USE imp_intm
9211C----6---------------------------------------------------------------7---------8
9212C I m p l i c i t T y p e s
9213C-----------------------------------------------
9214#include "implicit_f.inc"
9215C-----------------------------------------------------------------
9216C D u m m y A r g u m e n t s
9217C-----------------------------------------------
9218 INTEGER NSREM,IAD_M(*),NSL,IDDL(*),NDOF(*),INLOC(*),
9219 . ikc(*),nf_si(*),nfv,nfd,iddli(*)
9220C REAL
9221 my_real
9222 . ud0(3,*),kfr_si(3,3,*),kfr_sl(3,3,*),fdsi(3,*)
9223C-----------------------------------------------
9224C L o c a l V a r i a b l e s
9225C-----------------------------------------------
9226 INTEGER I,J,N,K,M,NS,IAD_M1(NSREM+1),IS,JD,
9227 . nj,nd,nl,j1,nss,nm,id,iad,nf,nr,iadi
9228 my_real
9229 . ksm(3,3),ud(3,nfv)
9230C----------------------------
9231 nd = 3
9232 DO i = 1, nfd
9233 DO k =1,nd
9234 fdsi(k,i) = zero
9235 ENDDO
9236 ENDDO
9237 iad_m1(1) = 1
9238 DO n=1,nsrem
9239 iad_m1(n+1) = iad_m1(n)+ikc_si(n)*nf_si(n)
9240 ENDDO
9241 DO i = 1, nfv
9242 ns = islm(i)
9243 DO k =1,nd
9244 id = iddl(ns)+k
9245 IF ((ikc(id)>=2.AND.ikc(id)<=4).OR.ikc(id)==9) THEN
9246 ud(k,i)=ud0(k,ns)
9247 ELSE
9248 ud(k,i)=zero
9249 ENDIF
9250 ENDDO
9251 iad = 0
9252 DO is = 1,nsrem
9253 nr =iad_sinr(is+1)- iad_sinr(is)
9254 CALL intabfr(nr,jdi_sinr(iad_sinr(is)),ns,j)
9255 DO nf = 1,max(1,nf_si(is))
9256 iad = iad + 1
9257C----------------in KFR_SL------
9258 IF (inloc(ns)>nsl) THEN
9259C
9260 DO j = iad_sinr(is), iad_sinr(is+1)-1
9261 nj = jdi_sinr(j)
9262 nss = inloc(nj)
9263 nr=iad_slnr(nss+1)- iad_slnr(nss)
9264 CALL intabfr(nr,jdi_slnr(iad_slnr(nss)),ns,j1)
9265 IF (j1>0) THEN
9266 iadi = iad_m(nss) + j1 + is -2
9267 DO k =1,nd
9268 fdsi(k,iad) = fdsi(k,iad)+kfr_sl(1,k,iadi)*ud(1,i)+
9269 . kfr_sl(2,k,iadi)*ud(2,i)+kfr_sl(3,k,iadi)*ud(3,i)
9270 ENDDO
9271 ENDIF !(J1>0)
9272 ENDDO
9273C----------------in KFR_SI------
9274 ELSEIF (ikc_si(is)>0.AND.j>0) THEN
9275 n = 0
9276 CALL get_iad(iad_m1,iad_slnr,jdi_slnr,n ,is ,
9277 1 j ,ikc_si(is),ndof ,iadi )
9278 iadi = iadi + nf-1
9279 DO k =1,nd
9280 fdsi(k,iad) = fdsi(k,iad)+kfr_si(1,k,iadi)*ud(1,i)+
9281 . kfr_si(2,k,iadi)*ud(2,i)+kfr_si(3,k,iadi)*ud(3,i)
9282 ENDDO
9283 ELSEIF (j>0) THEN
9284 id = iddl_si(is)
9285 nm = jdi_sinr(iad_sinr(is)+j-1)
9286 jd = iddli(nm)
9287 CALL getfr_kij( id ,jd ,iad_si ,jdi_si,lt_si ,
9288 1 ksm ,nd ,nd )
9289 DO k =1,nd
9290 fdsi(k,iad) = fdsi(k,iad)+ksm(1,k)*ud(1,i)+
9291 . ksm(2,k)*ud(2,i)+ksm(3,k)*ud(3,i)
9292 ENDDO
9293 ENDIF
9294 ENDDO
9295 ENDDO
9296 ENDDO
9297C----6---------------------------------------------------------------7---------8
9298 RETURN
9299 END
9300!||====================================================================
9301!|| ini_frfd ../engine/source/mpi/implicit/imp_fri.F
9302!||--- called by ------------------------------------------------------
9303!|| imp_frkd ../engine/source/mpi/implicit/imp_fri.F
9304!||--- uses -----------------------------------------------------
9305!|| imp_intm ../engine/share/modules/imp_intm.F
9306!||====================================================================
9307 SUBROUTINE ini_frfd(NSREM ,NFV ,IKCSI ,NF_SI ,FDSI )
9308C-----------------------------------------------
9309C M o d u l e s
9310C-----------------------------------------------
9311 USE imp_intm
9312C----6---------------------------------------------------------------7---------8
9313C I m p l i c i t T y p e s
9314C-----------------------------------------------
9315#include "implicit_f.inc"
9316C-----------------------------------------------------------------
9317C D u m m y A r g u m e n t s
9318C-----------------------------------------------
9319 integer
9320 . nsrem,ikcsi(3,*),nf_si(*) ,nfv
9321 my_real
9322 . fdsi(3,*)
9323C-----------------------------------------------
9324C L o c a l V a r i a b l e s
9325C-----------------------------------------------
9326 INTEGER I,J,N,K,NL,NDOFI,IAD,IADI
9327C
9328 DO i=1,nddl_si
9329 fsi(i) = zero
9330 ENDDO
9331C
9332 IF (nfv==0) RETURN
9333 ndofi = 3
9334 nl = 0
9335 iad = 1
9336 iadi = 1
9337 DO i=1,nsrem
9338C-----------SECOND DEPEND.: FRK_SI---------
9339 IF (ikc_si(i)>0) THEN
9340 DO j =1, nf_si(i)
9341 DO k = 1,ndofi
9342 IF (ikcsi(k,iad)==0) THEN
9343 nl = nl + 1
9344 fsi(nl)=-fdsi(k,iadi+j-1)
9345 ENDIF
9346 ENDDO
9347 iad = iad + 1
9348 ENDDO
9349C-----------SECOND INDEPEND.:LT,FRK_SL---------
9350 ELSE
9351 DO k = 1,ndofi
9352 nl = nl + 1
9353 fsi(nl)=-fdsi(k,iadi)
9354 ENDDO
9355 ENDIF
9356 iadi = iadi + max(1,nf_si(i))
9357 ENDDO
9358C
9359 RETURN
9360 END
9361!||====================================================================
9362!|| cp_slnr ../engine/source/mpi/implicit/imp_fri.F
9363!||--- calls -----------------------------------------------------
9364!|| cp_int ../engine/source/implicit/produt_v.F
9365!||--- uses -----------------------------------------------------
9366!|| imp_intm ../engine/share/modules/imp_intm.F
9367!||====================================================================
9368 SUBROUTINE cp_slnr(IAD_CP ,JDI_CP ,NSL ,NZ)
9369C-----------------------------------------------
9370C M o d u l e s
9371C-----------------------------------------------
9372 USE imp_intm
9373C----6---------------------------------------------------------------7---------8
9374C I m p l i c i t T y p e s
9375C-----------------------------------------------
9376#include "implicit_f.inc"
9377C-----------------------------------------------------------------
9378C D u m m y A r g u m e n t s
9379C-----------------------------------------------
9380 INTEGER NSL,NZ ,IAD_CP(*),JDI_CP(*)
9381C REAL
9382C-----------------------------------------------
9383C L o c a l V a r i a b l e s
9384C-----------------------------------------------
9385C----------------------------
9386 CALL cp_int((nsl+1),iad_slnr,iad_cp)
9387 CALL cp_int(nz,jdi_slnr,jdi_cp)
9388C
9389 IF(ALLOCATED(iml)) DEALLOCATE(iml)
9390 ALLOCATE(iml(nsl))
9391 CALL cp_int(nsl,isl,iml)
9392C----6---------------------------------------------------------------7---------8
9393 RETURN
9394 END
9395!||====================================================================
9396!|| ind_sld ../engine/source/mpi/implicit/imp_fri.F
9397!||--- called by ------------------------------------------------------
9398!|| imp_frkd ../engine/source/mpi/implicit/imp_fri.F
9399!||--- calls -----------------------------------------------------
9400!|| put_kii ../engine/source/implicit/imp_glob_k.F
9401!|| zero1 ../engine/source/system/zero.F
9402!||--- uses -----------------------------------------------------
9403!|| imp_intm ../engine/share/modules/imp_intm.F
9404!||====================================================================
9405 SUBROUTINE ind_sld(NSL ,NDOF ,KSS )
9406C-----------------------------------------------
9407C M o d u l e s
9408C-----------------------------------------------
9409 USE imp_intm
9410C-----------------------------------------------
9411C I m p l i c i t T y p e s
9412C-----------------------------------------------
9413#include "implicit_f.inc"
9414C-----------------------------------------------
9415C D u m m y A r g u m e n t s
9416C-----------------------------------------------
9417 INTEGER NSL ,NDOF(*)
9418 my_real
9419 . kss(6,*)
9420C REAL
9421C-----------------------------------------------
9422C L o c a l V a r i a b l e s
9423C-----------------------------------------------
9424 INTEGER I,J,K,N,P,ID,NJ,NB,NL,NZ,J1,K1,NK,NN,IAD,
9425 . ier1,ier2,ier3,ier4,ier5,ier6,nd
9426 my_real
9427 . kii(6,6)
9428C-------------------------------------
9429C------IDDL as function of kinematic nodes first-----
9430 nn = 0
9431 DO i = 1,nsl
9432 IF (ikc_sl(i)>0) THEN
9433C----------int2,rb-,others-----------
9434 nb = iad_slnr(i+1)-iad_slnr(i)
9435 nn = nn + max(1,nb)
9436 ENDIF
9437 ENDDO
9438 IF(ALLOCATED(iddl_sl)) DEALLOCATE(iddl_sl)
9439 ALLOCATE(iddl_sl(nn),stat=ier1)
9440C------dim--[K_SL]-partie depedant only----LT---
9441 nn = 0
9442 nl = 0
9443 nz = 0
9444 DO i = 1,nsl
9445 IF (ikc_sl(i)>0) THEN
9446C----------int2,rb------------
9447 DO j=iad_slnr(i),iad_slnr(i+1)-1
9448 nn = nn +1
9449 iddl_sl(nn) = nl
9450 nj = jdi_slnr(j)
9451 DO k =1,ndof(nj)
9452 nl = nl + 1
9453 DO k1 = 1, k-1
9454 nz = nz + 1
9455 ENDDO
9456 ENDDO
9457C------ mimj -------
9458 DO j1=iad_slnr(i),j-1
9459 nk = jdi_slnr(j1)
9460 DO k =1,ndof(nk)
9461 nz = nz + ndof(nk)
9462 ENDDO
9463 ENDDO
9464 ENDDO
9465C----------other kin------------
9466 IF (iad_slnr(i)==iad_slnr(i+1)) THEN
9467 nn = nn +1
9468 iddl_sl(nn) = nl
9469 n = isl(i)
9470 DO k =1,min(3,ndof(n))
9471 nl = nl + 1
9472 DO k1 = 1, k-1
9473 nz = nz + 1
9474 ENDDO
9475 ENDDO
9476 ENDIF
9477 ENDIF
9478 ENDDO
9479C-----allocation------
9480 nddl_sl = nl
9481 nz_sl = nz
9482 IF(ALLOCATED(iad_ss)) DEALLOCATE(iad_ss)
9483 ALLOCATE(iad_ss(nl+1),stat=ier2)
9484 IF(ALLOCATED(jdi_sl)) DEALLOCATE(jdi_sl)
9485 ALLOCATE(jdi_sl(nz),stat=ier3)
9486C
9487 nl = 0
9488 nz = 0
9489 nn = 0
9490 iad_ss(nl+1) = nz + 1
9491 DO i = 1, nsl
9492 IF (ikc_sl(i)>0) THEN
9493 iad = nn
9494 DO j=iad_slnr(i),iad_slnr(i+1)-1
9495 nn = nn +1
9496 nj = jdi_slnr(j)
9497 DO k =1,ndof(nj)
9498 nl = nl + 1
9499C------ mij d'abord-------
9500 DO j1=iad_slnr(i),j-1
9501 nk = jdi_slnr(j1)
9502 id = iad + j1-iad_slnr(i)+1
9503 DO k1 =1,ndof(nk)
9504 nz = nz + 1
9505 jdi_sl(nz) = iddl_sl(id)+ k1
9506 ENDDO
9507 ENDDO
9508C------ mii ------
9509 DO k1 = 1, k-1
9510 nz = nz + 1
9511 jdi_sl(nz) = iddl_sl(nn) + k1
9512 ENDDO
9513 iad_ss(nl+1) = nz + 1
9514 ENDDO
9515 ENDDO
9516C----------other kin------------
9517 IF (iad_slnr(i)==iad_slnr(i+1)) THEN
9518 nn = nn +1
9519 n = isl(i)
9520 DO k =1,min(3,ndof(n))
9521 nl = nl + 1
9522 DO k1 = 1, k-1
9523 nz = nz + 1
9524 jdi_sl(nz) = iddl_sl(nn) + k1
9525 ENDDO
9526 iad_ss(nl+1) = nz + 1
9527 ENDDO
9528 ENDIF
9529 ENDIF
9530 ENDDO
9531C
9532 IF(ALLOCATED(diag_sl)) DEALLOCATE(diag_sl)
9533 IF(ALLOCATED(lt_sl)) DEALLOCATE(lt_sl)
9534 ALLOCATE(diag_sl(nl),stat=ier4)
9535 ALLOCATE(lt_sl(nz),stat=ier5)
9536 CALL zero1(diag_sl,nl)
9537 CALL zero1(lt_sl,nz)
9538C----------initiation for the case /BCS
9539 nn = 0
9540 DO i = 1, nsl
9541 IF (ikc_sl(i)>0) THEN
9542C----------other kin------------
9543 IF (iad_slnr(i)==iad_slnr(i+1)) THEN
9544 nn = nn +1
9545 n = isl(i)
9546 nd = min(3,ndof(n))
9547 DO k = 1, nd
9548 kii(k,k) = kss(k,i)
9549 ENDDO
9550 kii(1,2)=kss(4,i)
9551 kii(1,3)=kss(5,i)
9552 kii(2,3)=kss(6,i)
9553 kii(2,1)=kii(1,2)
9554 kii(3,1)=kii(1,3)
9555 kii(3,2)=kii(2,3)
9556 CALL put_kii(nn,iddl_sl,iad_ss,diag_sl,lt_sl,kii,nd)
9557 ENDIF
9558 ENDIF
9559 ENDDO
9560C
9561 RETURN
9562 END
9563!||====================================================================
9564!|| imp_frks ../engine/source/mpi/implicit/imp_fri.F
9565!||--- called by ------------------------------------------------------
9566!|| imp_frkd ../engine/source/mpi/implicit/imp_fri.F
9567!||--- calls -----------------------------------------------------
9568!|| cp_int ../engine/source/implicit/produt_v.F
9569!|| cp_real ../engine/source/implicit/produt_v.F
9570!|| get_kii ../engine/source/implicit/imp_glob_k.F
9571!|| get_kij ../engine/source/implicit/imp_glob_k.F
9572!||--- uses -----------------------------------------------------
9573!|| imp_intm ../engine/share/modules/imp_intm.F
9574!||====================================================================
9575 SUBROUTINE imp_frks(NSL ,IDDL ,IKC ,NDOF ,IDDLM,
9576 . KSS ,IAD_SLD )
9577C-----------------------------------------------
9578C M o d u l e s
9579C-----------------------------------------------
9580 USE imp_intm
9581C-----------------------------------------------
9582C I m p l i c i t T y p e s
9583C-----------------------------------------------
9584#include "implicit_f.inc"
9585C-----------------------------------------------
9586C C o m m o n B l o c k s
9587C-----------------------------------------------
9588#include "com01_c.inc"
9589C-----------------------------------------------
9590C D u m m y A r g u m e n t s
9591C-----------------------------------------------
9592 INTEGER NSL ,IDDL(*),IKC(*),NDOF(*),IDDLM(*),IAD_SLD(*)
9593C REAL
9594 my_real
9595 . kss(6,*)
9596C-----------------------------------------------
9597C L o c a l V a r i a b l e s
9598C-----------------------------------------------
9599 INTEGER IDDL_CP(NDDL_SL),IAD_CP(NDDL_SL+1),JDI_CP(NZ_SL),
9600 . nr,nk,nn,idm,jd,iadi,idj,idjm,iad,ndofi
9601 INTEGER I,J,K,N,P,ID,NJ,NB,NKC,NL,NZ,K1,NKC1,J1,NM,
9602 . ier1,ier2,ier3,ier4,ier5,ier6
9603 my_real
9604 . kii(6,6),kij(6,6),lt_cp(nz_sl),diag_cp(nddl_sl)
9605C-------------------------------------
9606C----------if there is kin modif copy----
9607 IF (nddl_sl>0) THEN
9608 nn = 0
9609 DO i = 1,nsl
9610 IF (ikc_sl(i)>0) THEN
9611C----------int2,rb------------
9612 nb = iad_slnr(i+1)-iad_slnr(i)
9613 nn = nn + max(1,nb)
9614 ENDIF
9615 ENDDO
9616 CALL cp_int((nddl_sl+1),iad_ss,iad_cp)
9617 CALL cp_int(nn,iddl_sl,iddl_cp)
9618 CALL cp_int(nz_sl,jdi_sl,jdi_cp)
9619 CALL cp_real(nddl_sl,diag_sl,diag_cp)
9620 CALL cp_real(nz_sl,lt_sl,lt_cp)
9621 ENDIF
9622C------dim--[K_SL]-
9623 nl = 0
9624 nz = 0
9625 DO i = 1,nsl
9626 IF (ikc_sl(i)>0) THEN
9627 DO j=iad_slnr(i),iad_slnr(i+1)-1
9628 nj = jdi_slnr(j)
9629 id = iddl(nj)
9630 DO k =1,ndof(nj)
9631 IF (ikc(id+k)==0) THEN
9632 nl = nl + 1
9633C----------mij----------
9634 DO j1=iad_slnr(i),j-1
9635 nk = jdi_slnr(j1)
9636 idj = iddl(nk)
9637 DO k1 =1,ndof(nk)
9638 IF (ikc(idj+k1)==0) nz = nz + 1
9639 ENDDO
9640 ENDDO
9641 DO k1 = 1, k-1
9642 IF (ikc(id+k1)==0) nz = nz + 1
9643 ENDDO
9644 ENDIF
9645 ENDDO
9646 ENDDO
9647 IF (iad_slnr(i)==iad_slnr(i+1)) THEN
9648 n = isl(i)
9649 id = iddl(n)
9650 DO k =1,min(3,ndof(n))
9651 IF (ikc(id+k)==0) THEN
9652 nl = nl + 1
9653 DO k1 = 1, k-1
9654 IF (ikc(id+k1)==0) nz = nz + 1
9655 ENDDO
9656 ENDIF
9657 ENDDO
9658 ENDIF
9659C------independent nodes---------
9660 ELSE
9661 n = isl(i)
9662 DO k =1,min(3,ndof(n))
9663 nl = nl + 1
9664 DO k1 = 1, k-1
9665 nz = nz + 1
9666 ENDDO
9667 ENDDO
9668 ENDIF
9669 ENDDO
9670C-----allocation------
9671 IF(ALLOCATED(iddl_sl)) DEALLOCATE(iddl_sl)
9672 ALLOCATE(iddl_sl(nl),stat=ier4)
9673 IF (nl>nddl_sl) THEN
9674 IF(ALLOCATED(iad_ss)) DEALLOCATE(iad_ss)
9675 ALLOCATE(iad_ss(nl+1),stat=ier1)
9676C---------iddl devient idtok---
9677 IF(ALLOCATED(diag_sl)) DEALLOCATE(diag_sl)
9678 ALLOCATE(diag_sl(nl),stat=ier5)
9679 ENDIF
9680 IF (nz>nz_sl) THEN
9681 IF(ALLOCATED(jdi_sl)) DEALLOCATE(jdi_sl)
9682 ALLOCATE(jdi_sl(nz),stat=ier2)
9683 IF(ALLOCATED(lt_sl)) DEALLOCATE(lt_sl)
9684 ALLOCATE(lt_sl(nz),stat=ier3)
9685 ENDIF
9686 nddl_sl = nl
9687 nz_sl = nz
9688C
9689 nl = 0
9690 nz = 0
9691 nn = 0
9692 iad_ss(nl+1) = nz + 1
9693 iad_sld(1) = nl + 1
9694 DO p = 1,nspmd
9695 DO i = iad_sl(p), iad_sl(p+1)-1
9696 IF (ikc_sl(i)>0) THEN
9697 iad = nn
9698 DO j=iad_slnr(i),iad_slnr(i+1)-1
9699 nn = nn + 1
9700 nj = jdi_slnr(j)
9701 id = iddl(nj)
9702 idm = iddlm(nj)
9703 CALL get_kii(nn ,iddl_cp,iad_cp,diag_cp,lt_cp ,kii,ndof(nj))
9704 nkc =0
9705 DO k =1,ndof(nj)
9706 IF (ikc(id+k)==0) THEN
9707 nl = nl + 1
9708 iddl_sl(nl) =idm+k-nkc
9709 diag_sl(nl) = kii(k,k)
9710C----------mij----------
9711 DO j1=iad_slnr(i),j-1
9712 nk = jdi_slnr(j1)
9713 idj = iddl(nk)
9714 idjm = iddlm(nk)
9715 nm = iad + j1 - iad_slnr(i) + 1
9716 CALL get_kij(nm ,nn ,iddl_cp,iad_cp,jdi_cp,lt_cp ,kij ,
9717 . ndof(nk),ndof(nj) ,ier1 )
9718 nkc1 = 0
9719 DO k1 =1,ndof(nk)
9720 IF (ikc(idj+k1)==0) THEN
9721 nz = nz + 1
9722 jdi_sl(nz) = idjm + k1- nkc1
9723 lt_sl(nz) = kij(k1,k)
9724C LT_SL(NZ) = KIJ(K,K1)
9725 ELSE
9726 nkc1 = nkc1 + 1
9727 ENDIF
9728 ENDDO
9729 ENDDO
9730C----------mii----------
9731 nkc1 =0
9732 DO k1 = 1, k-1
9733 IF (ikc(id+k1)==0) THEN
9734 nz = nz + 1
9735 jdi_sl(nz) = idm + k1- nkc1
9736 lt_sl(nz) = kii(k1,k)
9737 ELSE
9738 nkc1 =nkc1+1
9739 ENDIF
9740 ENDDO
9741 iad_ss(nl+1) = nz+1
9742 ELSE
9743 nkc =nkc+1
9744 ENDIF
9745 ENDDO
9746 ENDDO
9747 IF (iad_slnr(i)==iad_slnr(i+1)) THEN
9748 n = isl(i)
9749 id = iddl(n)
9750 idm = iddlm(n)
9751 nn = nn + 1
9752C
9753 ndofi = min(3,ndof(n))
9754 CALL get_kii(nn ,iddl_cp,iad_cp,diag_cp,lt_cp ,kii,ndofi)
9755 nkc =0
9756 DO k =1,ndofi
9757 IF (ikc(id+k)==0) THEN
9758 nl = nl + 1
9759 iddl_sl(nl) =idm+k-nkc
9760 diag_sl(nl) = kii(k,k)
9761 nkc1 =0
9762 DO k1 = 1, k-1
9763 IF (ikc(id+k1)==0) THEN
9764 nz = nz + 1
9765 jdi_sl(nz) = idm + k1- nkc1
9766 lt_sl(nz) = kii(k1,k)
9767 ELSE
9768 nkc1 =nkc1+1
9769 ENDIF
9770 ENDDO
9771 iad_ss(nl+1) = nz+1
9772 ELSE
9773 nkc =nkc+1
9774 ENDIF
9775 ENDDO
9776 ENDIF
9777C------independent nodes---------
9778 ELSE
9779 n = isl(i)
9780 idm = iddlm(n)
9781 DO k =1,min(3,ndof(n))
9782 nl = nl + 1
9783 iddl_sl(nl) =idm+k
9784 diag_sl(nl) =kss(k,i)
9785 DO k1 = 1, k-1
9786 nz = nz + 1
9787 jdi_sl(nz) = idm + k1
9788 id = k1 + k + 1
9789 lt_sl(nz) = kss(id,i)
9790 ENDDO
9791 iad_ss(nl+1) = nz+1
9792 ENDDO
9793 ENDIF
9794 ENDDO
9795 iad_sld(p+1) = nl + 1
9796 ENDDO
9797C
9798 RETURN
9799 END
9800!||====================================================================
9801!|| cp_iadd ../engine/source/mpi/implicit/imp_fri.F
9802!||--- called by ------------------------------------------------------
9803!|| imp_frkd ../engine/source/mpi/implicit/imp_fri.F
9804!||--- calls -----------------------------------------------------
9805!|| cp_int ../engine/source/implicit/produt_v.F
9806!||--- uses -----------------------------------------------------
9807!|| imp_intm ../engine/share/modules/imp_intm.F
9808!||====================================================================
9809 SUBROUTINE cp_iadd(NSL ,NSREM,IAD_SLD ,IAD_MLD)
9810C-----------------------------------------------
9811C M o d u l e s
9812C-----------------------------------------------
9813 USE imp_intm
9814C----6---------------------------------------------------------------7---------8
9815C I m p l i c i t T y p e s
9816C-----------------------------------------------
9817#include "implicit_f.inc"
9818C-----------------------------------------------
9819C C o m m o n B l o c k s
9820C-----------------------------------------------
9821#include "com01_c.inc"
9822C-----------------------------------------------------------------
9823C D u m m y A r g u m e n t s
9824C-----------------------------------------------
9825 INTEGER NSL ,NSREM,IAD_SLD(*),IAD_MLD(*)
9826C REAL
9827C-----------------------------------------------
9828C L o c a l V a r i a b l e s
9829C-----------------------------------------------
9830 INTEGER L
9831C----------------------------
9832 l = nspmd + 1
9833 IF (nsl >0) CALL cp_int(l,iad_sld,iad_sl)
9834 IF (nsrem >0) CALL cp_int(l,iad_mld,iad_srem)
9835C----6---------------------------------------------------------------7---------8
9836 RETURN
9837 END
9838!||====================================================================
9839!|| nddli_frb ../engine/source/mpi/implicit/imp_fri.F
9840!||--- called by ------------------------------------------------------
9841!|| getnddli_g ../engine/source/mpi/implicit/imp_fri.F
9842!||--- calls -----------------------------------------------------
9843!|| spmd_nrow ../engine/source/mpi/implicit/imp_spmd.F
9844!|| spmd_sum_s ../engine/source/mpi/implicit/imp_spmd.F
9845!||--- uses -----------------------------------------------------
9846!|| imp_frk ../engine/share/modules/impbufdef_mod.F
9847!||====================================================================
9848 SUBROUTINE nddli_frb(
9849 1 NDOF ,IKC ,IDDL ,NDOFI ,NDDLIFB ,
9850 2 FR_ELEM ,IAD_ELEM )
9851C-----------------------------------------------
9852C M o d u l e s
9853C-----------------------------------------------
9854 USE imp_frk
9855C-----------------------------------------------
9856C I m p l i c i t T y p e s
9857C-----------------------------------------------
9858#include "implicit_f.inc"
9859C-----------------------------------------------
9860C C o m m o n B l o c k s
9861C-----------------------------------------------
9862#include "com01_c.inc"
9863C-----------------------------------------------
9864C D u m m y A r g u m e n t s
9865C-----------------------------------------------
9866 INTEGER NDOFI(*) ,IDDL(*),IKC(*),NDOF(*),NDDLIFB
9867 integer
9868 . fr_elem(*),iad_elem(2,*)
9869C REAL
9870C-----------------------------------------------
9871C L o c a l V a r i a b l e s
9872C-----------------------------------------------
9873 INTEGER I,J,N,NK,IP,L,IFRE,II,IAD2,IJ,IND,N_FR,NB,
9874 . k,nd,nzzk,nj,nzz,iad,jad,id,jd,idk,nc
9875 INTEGER, DIMENSION(:),ALLOCATABLE :: ITAG,ICONT
9876 my_real
9877 . s1,stmp
9878C
9879 stmp = zero
9880 n_fr = iad_elem(1,nspmd+1)-iad_elem(1,1)
9881 IF (n_fr>0) THEN
9882 ALLOCATE(itag(n_fr),icont(n_fr))
9883 itag = 0
9884 DO ip =1,nspmd
9885 DO nk=iad_elem(1,ip),iad_elem(1,ip+1)-1
9886 n=fr_elem(nk)
9887 idk=iddl(n)
9888 ifre = 0
9889 DO j=1,min(ndof(n),ndofi(n))
9890 IF (ikc(idk+j)==0) ifre=ifre+1
9891 ENDDO
9892 itag(nk) = ifre
9893 ENDDO
9894 ENDDO
9895 CALL spmd_nrow(itag,icont,iad_elem,n_fr)
9896 DO nk=1,n_fr
9897 icont(nk)=min(itag(nk),icont(nk))
9898 IF (icont(nk)>0) THEN
9899 icont(nk) = itag(nk)
9900 itag(nk) = 2
9901 ENDIF
9902 ENDDO
9903 DO nk=1,n_fr
9904 nb=-ifrloc(nk)
9905 IF (nb>0.AND.icont(nk)>0) itag(nb) = itag(nb) + 1
9906 ENDDO
9907 DO nk=1,n_fr
9908 IF (icont(nk)>0) THEN
9909 nb=-ifrloc(nk)
9910 IF (nb<0) nb = nk
9911 s1 = one/itag(nb)
9912 stmp = stmp + s1*icont(nk)
9913 ENDIF
9914 ENDDO
9915 DEALLOCATE(itag,icont)
9916 END IF !(N_FR>0) THEN
9917 CALL spmd_sum_s(stmp)
9918 nddlifb = int(stmp)
9919C
9920 RETURN
9921 END
9922!||====================================================================
9923!|| ndofi_nsl ../engine/source/mpi/implicit/imp_fri.F
9924!||--- called by ------------------------------------------------------
9925!|| nddli_ns ../engine/source/mpi/implicit/imp_fri.f
9926!||--- uses -----------------------------------------------------
9927!|| imp_intm ../engine/share/modules/imp_intm.f
9928!||====================================================================
9929 SUBROUTINE ndofi_nsl(NSL ,NDDLI ,NDOFI )
9930C-----------------------------------------------
9931C M o d u l e s
9932C-----------------------------------------------
9933 USE imp_intm
9934C-----------------------------------------------
9935C I m p l i c i t T y p e s
9936C-----------------------------------------------
9937#include "implicit_f.inc"
9938C-----------------------------------------------
9939C C o m m o n B l o c k s
9940C-----------------------------------------------
9941#include "com04_c.inc"
9942C-----------------------------------------------
9943C D u m m y A r g u m e n t s
9944C-----------------------------------------------
9945 INTEGER NSL,NDOFI(*) ,NDDLI
9946C REAL
9947C-----------------------------------------------
9948C L o c a l V a r i a b l e s
9949C-----------------------------------------------
9950C------- Updated ndofi for nsl ----
9951 INTEGER I,J,N,IDK,NC,NDOFII
9952 ndofii = 3
9953 IF (nddli==0) THEN
9954 DO n =1,numnod
9955 ndofi(n)= 0
9956 ENDDO
9957 ENDIF
9958 DO i =1,nsl
9959 n=isl(i)
9960 IF(ndofi(n)==0) ndofi(n)= -ndofii
9961 ENDDO
9962C
9963 RETURN
9964 END
9965!||====================================================================
9966!|| getnddli_g ../engine/source/mpi/implicit/imp_fri.F
9967!||--- called by ------------------------------------------------------
9968!|| imp_solv ../engine/source/implicit/imp_solv.F
9969!||--- calls -----------------------------------------------------
9970!|| nddli_frb ../engine/source/mpi/implicit/imp_fri.F
9971!|| nddli_ns ../engine/source/mpi/implicit/imp_fri.F
9972!|| spmd_nddlig ../engine/source/mpi/implicit/imp_spmd.F
9973!||--- uses -----------------------------------------------------
9974!|| imp_frk ../engine/share/modules/impbufdef_mod.F
9975!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
9976!||====================================================================
9977 SUBROUTINE getnddli_g(
9978 1 NPBY ,LPBY ,ITAB ,NRBYAC ,IRBYAC ,
9979 2 NINT2 ,IINT2 ,IPARI ,INTBUF_TAB,NDOFI ,
9980 3 NDOF ,IKC ,IDDL ,FR_ELEM ,IAD_ELEM ,
9981 4 NDDLI ,NSL ,NDDLIG ,IRBE3 ,LRBE3 ,
9982 5 IRBE2 ,LRBE2 )
9983C-----------------------------------------------
9984C M o d u l e s
9985C-----------------------------------------------
9986 USE imp_frk
9987 USE intbufdef_mod
9988C-----------------------------------------------
9989C I m p l i c i t T y p e s
9990C-----------------------------------------------
9991#include "implicit_f.inc"
9992C-----------------------------------------------
9993C C o m m o n B l o c k s
9994C-----------------------------------------------
9995#include "param_c.inc"
9996C-----------------------------------------------
9997C D u m m y A r g u m e n t s
9998C-----------------------------------------------
9999 INTEGER NDOFI(*) ,IDDL(*),IKC(*),NDOF(*),NDDLI,NDDLIG,NSL
10000 INTEGER NPBY(NNPBY,*),LPBY(*),ITAB(*),NRBYAC,IRBYAC(*),
10001 . NINT2,IINT2(*),IPARI(NPARI,*),
10002 . IRBE3(*),LRBE3(*),IRBE2(*),LRBE2(*)
10003 INTEGER
10004 . FR_ELEM(*),IAD_ELEM(2,*)
10005C REAL
10006 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
10007C-----------------------------------------------
10008C L o c a l V a r i a b l e s
10009C-----------------------------------------------
10010 INTEGER NDDLIFB,NDDLINS
10011C
10012 CALL NDDLI_FRB(
10013 1 ndof ,ikc ,iddl ,ndofi ,nddlifb ,
10014 2 fr_elem ,iad_elem )
10015 CALL nddli_ns(
10016 1 npby ,lpby ,itab ,nrbyac ,irbyac ,
10017 2 nint2 ,iint2 ,ipari ,intbuf_tab,ndofi ,
10018 3 ndof ,ikc ,iddl ,nsl ,nddli ,
10019 4 nddlins ,irbe3 ,lrbe3 ,irbe2 ,lrbe2 )
10020 CALL spmd_nddlig(nddlins ,nddlifb ,nddlig )
10021C
10022 RETURN
10023 END
10024!||====================================================================
10025!|| nddli_ns ../engine/source/mpi/implicit/imp_fri.F
10026!||--- called by ------------------------------------------------------
10027!|| getnddli_g ../engine/source/mpi/implicit/imp_fri.f
10028!||--- calls -----------------------------------------------------
10029!|| ndofi_nsl ../engine/source/mpi/implicit/imp_fri.F
10030!||--- uses -----------------------------------------------------
10031!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
10032!||====================================================================
10033 SUBROUTINE nddli_ns(
10034 1 NPBY ,LPBY ,ITAB ,NRBYAC ,IRBYAC ,
10035 2 NINT2 ,IINT2 ,IPARI ,INTBUF_TAB,NDOFI ,
10036 3 NDOF ,IKC ,IDDL ,NSL ,NDDLI ,
10037 4 NDDLINS ,IRBE3 ,LRBE3 ,IRBE2 ,LRBE2 )
10038C-----------------------------------------------
10039C M o d u l e s
10040C-----------------------------------------------
10041 USE intbufdef_mod
10042C----6---------------------------------------------------------------7---------8
10043C I m p l i c i t T y p e s
10044C-----------------------------------------------
10045#include "implicit_f.inc"
10046C-----------------------------------------------
10047C C o m m o n B l o c k s
10048C-----------------------------------------------
10049#include "com04_c.inc"
10050#include "param_c.inc"
10051C-----------------------------------------------------------------
10052C D u m m y A r g u m e n t s
10053C-----------------------------------------------
10054C INTEGER NNMAX,NKMAX
10055 INTEGER NDOFI(*) ,IDDL(*),IKC(*),NDOF(*),NDDLINS,NSL
10056 INTEGER NPBY(NNPBY,*),LPBY(*),ITAB(*),NRBYAC,IRBYAC(*),
10057 . NINT2,IINT2(*),IPARI(NPARI,*),NDDLI,
10058 . IRBE3(NRBE3L,*),LRBE3(*),IRBE2(NRBE2L,*),LRBE2(*)
10059C REAL
10060 TYPE(intbuf_struct_) INTBUF_TAB(*)
10061C-----------------------------------------------
10062C L o c a l V a r i a b l e s
10063C-----------------------------------------------
10064 integer
10065 . i,j,k,n,l,nl,nj,ni,j1,m,nsn,n1,n2,nk,id,nm,
10066 . ji,ns,nnod,ndofii,iad
10067C------------
10068 CALL ndofi_nsl(nsl ,nddli ,ndofi )
10069 DO j=1,nint2
10070 n=iint2(j)
10071 nsn = ipari(5,n)
10072 ji=ipari(1,n)
10073 DO i=1,nsn
10074 ni=intbuf_tab(n)%NSV(i)
10075 IF (ndofi(ni)<0) THEN
10076 l=intbuf_tab(n)%IRTLM(i)
10077 nl=4*(l-1)
10078 IF (intbuf_tab(n)%IRECTM(nl+3)==intbuf_tab(n)%IRECTM(nl+4)) THEN
10079 nnod=3
10080 ELSE
10081 nnod=4
10082 ENDIF
10083 DO m=1,nnod
10084 nm=intbuf_tab(n)%IRECTM(nl+m)
10085 IF (ndofi(nm)==0) ndofi(nm) = -6
10086 ENDDO
10087 ENDIF
10088 ENDDO
10089 ENDDO
10090C----RBE2-----
10091 DO n=1,nrbe2
10092 iad=irbe2(1,n)
10093 m =irbe2(3,n)
10094 nsn =irbe2(5,n)
10095 DO i=1,nsn
10096 id = i+iad
10097 ni=lrbe2(id)
10098 IF (ndofi(ni)<0) THEN
10099 IF (ndofi(m)==0) ndofi(m) = -6
10100 ENDIF
10101 ENDDO
10102 ENDDO
10103C--------RBE3----
10104 DO n=1,nrbe3
10105 iad=irbe3(1,n)
10106 ni=irbe3(3,n)
10107 IF (ni==0) cycle
10108 nnod=irbe3(5,n)
10109 IF (ndofi(ni)<0) THEN
10110 DO m=1,nnod
10111 nm=lrbe3(iad+m)
10112 IF (ndofi(nm)==0) ndofi(nm) = -6
10113 ENDDO
10114 ENDIF
10115 ENDDO
10116C-----active rigid body main nodes------
10117 DO j=1,nrbyac
10118 n=irbyac(j)
10119 k=irbyac(j+nrbykin)
10120 m =npby(1,n)
10121 nsn =npby(2,n)
10122 DO i=1,nsn
10123 id = i+k
10124 ni=lpby(id)
10125 IF (ndofi(ni)<0) THEN
10126 IF (ndofi(m)==0) ndofi(m) = -6
10127 ENDIF
10128 ENDDO
10129 ENDDO
10130C---- Odded Ndofi for NSL+Kin -------
10131 nddlins = nddli
10132 DO n =1,numnod
10133 IF(ndofi(n)<0) THEN
10134 ndofii = min(-ndofi(n),ndof(n))
10135 id=iddl(n)
10136 DO j=1,ndofii
10137 IF (ikc(id+j)==0) nddlins = nddlins+1
10138 ENDDO
10139 END IF
10140 ENDDO
10141C----6---------------------------------------------------------------7---------8
10142 RETURN
10143 END
10144!||====================================================================
10145!|| spc_fr_k ../engine/source/mpi/implicit/imp_fri.F
10146!||--- called by ------------------------------------------------------
10147!|| ind_glob_k ../engine/source/implicit/ind_glob_k.F
10148!||--- calls -----------------------------------------------------
10149!|| intab0 ../engine/source/implicit/imp_fsa_inv.F
10150!||--- uses -----------------------------------------------------
10151!|| imp_frk ../engine/share/modules/impbufdef_mod.F
10152!||====================================================================
10153 SUBROUTINE spc_fr_k(
10154 1 IADK ,JDIK ,NDOF ,IDDL ,FR_ELEM ,
10155 2 IAD_ELEM )
10156C-----------------------------------------------
10157C M o d u l e s
10158C-----------------------------------------------
10159 USE imp_frk
10160C-----------------------------------------------
10161C I m p l i c i t T y p e s
10162C-----------------------------------------------
10163#include "implicit_f.inc"
10164C-----------------------------------------------
10165C C o m m o n B l o c k s
10166C-----------------------------------------------
10167#include "com01_c.inc"
10168#include "impl1_c.inc"
10169C-----------------------------------------------
10170C D u m m y A r g u m e n t s
10171C-----------------------------------------------
10172 INTEGER IADK(*) ,JDIK(*),IDDL(*),NDOF(*)
10173 INTEGER
10174 . FR_ELEM(*),IAD_ELEM(2,*)
10175C REAL
10176C-----------------------------------------------
10177C External function
10178C-----------------------------------------------
10179 INTEGER INTAB0
10180 EXTERNAL INTAB0
10181C-----------------------------------------------
10182C L o c a l V a r i a b l e s
10183C-----------------------------------------------
10184 INTEGER I,J,N,NK,IP,L,IFIX,II,IAD2,IJ,IND,N_FR,NB,
10185 . K,ND,NZZK,NJ,NZZ,IAD,JAD,ID,JD,IDK,NC
10186C
10187 IF (NDDLFR<=0) return
10188C-------FR2K-------
10189 iad2 = 0
10190 DO ip =1,nspmd
10191 DO nk=iad_elem(1,ip),iad_elem(1,ip+1)-1
10192 n=fr_elem(nk)
10193 id=iddlfr(nk)+iad2
10194 idk=iddl(n)
10195 DO j=1,ndof(n)
10196 ifr2k(id+j)=idk+j
10197 ENDDO
10198 ENDDO
10199 iad2 = iad2 + nd_fr(ip)
10200 ENDDO
10201 len_v = iad2
10202C
10203 len_k = 0
10204 iad = 0
10205 iad2 = 0
10206 jad = 0
10207 IF (ikpat==0) THEN
10208 DO ip =1,nspmd
10209 DO i=1,nd_fr(ip)
10210 id = i+iad
10211 ii = ifr2k(i+iad2)
10212 DO j=iadfr(id),iadfr(id+1)-1
10213 jd = j + jad
10214 k=jdifr(jd)
10215 ij = ifr2k(k+iad2)
10216 IF (ii<ij) THEN
10217 nc = iadk(ii+1)-iadk(ii)
10218 n=intab0(nc,jdik(iadk(ii)),ij)
10219 IF (n>0) THEN
10220 jfr2k(jd)=n+iadk(ii)-1
10221 ELSE
10222 write(*,*)'index error in SPC_FR_K I<J',ij,ip,nc
10223 ENDIF
10224 ELSE
10225 nc = iadk(ij+1)-iadk(ij)
10226 n=intab0(nc,jdik(iadk(ij)),ii)
10227 IF (n>0) THEN
10228 jfr2k(jd)=n+iadk(ij)-1
10229 ELSE
10230 write(*,*)'index error in SPC_FR_K J<I',ii,ip,nc
10231 ENDIF
10232 ENDIF
10233 ENDDO
10234 ENDDO
10235 nzzk=iadfr(iad+nd_fr(ip)+1)-iadfr(iad+1)
10236 iad = iad + nd_fr(ip) +1
10237 iad2 = iad2 + nd_fr(ip)
10238 jad = jad + nzzk
10239 ENDDO
10240 ELSE
10241 DO ip =1,nspmd
10242 DO i=1,nd_fr(ip)
10243 id = i+iad
10244 ii = ifr2k(i+iad2)
10245 DO j=iadfr(id),iadfr(id+1)-1
10246 jd = j + jad
10247 k=jdifr(jd)
10248 ij = ifr2k(k+iad2)
10249 IF (ii>ij) THEN
10250 nc = iadk(ii+1)-iadk(ii)
10251 n=intab0(nc,jdik(iadk(ii)),ij)
10252 IF (n>0) THEN
10253 jfr2k(jd)=n+iadk(ii)-1
10254 ELSE
10255 write(*,*)'index error in SPC_FR_K I>J',ij,ip,nc
10256 ENDIF
10257 ELSE
10258 nc = iadk(ij+1)-iadk(ij)
10259 n=intab0(nc,jdik(iadk(ij)),ii)
10260 IF (n>0) THEN
10261 jfr2k(jd)=n+iadk(ij)-1
10262 ELSE
10263 write(*,*)'index error in SPC_FR_K J>I',ii,ip,nc
10264 ENDIF
10265 ENDIF
10266 ENDDO
10267 ENDDO
10268 nzzk=iadfr(iad+nd_fr(ip)+1)-iadfr(iad+1)
10269 iad = iad + nd_fr(ip) +1
10270 iad2 = iad2 + nd_fr(ip)
10271 jad = jad + nzzk
10272 ENDDO
10273 END IF !(IKPAT>0)
10274 len_k = iad2+jad
10275C
10276 RETURN
10277 END
10278
l_dir
subroutine l_dir(ej, j)
Definition bc_imp0.F:405
bc_fi
subroutine bc_fi(n, ej, j1, a)
Definition bc_imp0.F:1036
fv_updkd2
subroutine fv_updkd2(skew, skew1, kdd, diag_k)
Definition bc_imp0.F:2515
bcl_frk
subroutine bcl_frk(n, iddl, iddlm, ict, isk, skew, ikc, iadk, jdik, diag_k, lt_k, lb, a, kss, ksm, idlm, ifss, ifsm)
Definition bc_imp0.F:1414
bc_updfr2
subroutine bc_updfr2(n, iddl, skew, skew1, iddlm, ikc, iadk, jdik, diag_k, lt_k, lb, a, kss, ksm, idlm, ifss, ifsm)
Definition bc_imp0.F:2613
bcl_impd
subroutine bcl_impd(ict, isk, skew, i, d)
Definition bc_imp0.F:721
bc_updfr
subroutine bc_updfr(n, iddl, ej, jj, iddlm, ikc, iadk, jdik, diag_k, lt_k, lb, a, kss, ksm, idlm, ifss, ifsm)
Definition bc_imp0.F:1332
bc_updd
subroutine bc_updd(n, ej, j, d)
Definition bc_imp0.F:843
bc_updf
subroutine bc_updf(nbc, ibc, skew, a)
Definition bc_imp0.F:974
bc_upd2d
subroutine bc_upd2d(n, skew, skew1, d)
Definition bc_imp0.F:2469
bc_fi2
subroutine bc_fi2(n, skew, skew1, a)
Definition bc_imp0.F:2562
bcl_impkd
subroutine bcl_impkd(ict, isk, skew, kdd, diag_k)
Definition bc_imp0.F:914
my_real
#define my_real
Definition cppsort.cpp:32
fv_imp0
subroutine fv_imp0(iddl, ifix, ndof, iadk, jdik, diag_k, lt_k, ud, nbk, iab, bk, nddl, rd)
Definition fv_imp0.F:37
fvl_frk
subroutine fvl_frk(j1, n, ibfv, skew, xframe, iddl, iddlm, ikc, iadk, jdik, diag_k, lt_k, ud, lb, a, kss, ksm, idlm, ifss, ifsm)
Definition fv_imp0.F:1633
fv_updfr
subroutine fv_updfr(n, ej, j1, iddl, iddlm, ikc, iadk, jdik, diag_k, lt_k, ud, lb, a, kss, ksm, idlm, ifss, ifsm)
Definition fv_imp0.F:1700
fv_updf
subroutine fv_updf(nfx, ifx, ibfv, skew, xframe, a)
Definition fv_imp0.F:1427
fv_updkd
subroutine fv_updkd(ej, j, kdd, diag_k)
Definition fv_imp0.F:1519
fv_impd
subroutine fv_impd(ibfv, lj, skew, xframe, ud, rd)
Definition fv_imp0.F:932
kin_updf
subroutine kin_updf(n, ej, j1, a)
Definition fv_imp0.F:1487
zero1
subroutine zero1(r, n)
Definition hm_read_rbe3.F:1495
prerbe3fr
subroutine prerbe3fr(irbe3, n, jt, jr)
Definition hm_read_rbe3.F:1513
i2_frfm0
subroutine i2_frfm0(x, irect, crst, nsv, irtl, a, ar, ii, ndof)
Definition i2_imp1.F:1600
i2_frfm1
subroutine i2_frfm1(x, irect, dpara, nsv, irtl, a, ii)
Definition i2_imp1.F:1508
i2_frup1
subroutine i2_frup1(x, irect, dpara, nsv, irtl, ii, kii, kjj)
Definition i2_imp1.F:1792
i2_frk0
subroutine i2_frk0(irect, crst, x, itab, nsv, irtl, ikc, ndof, iddl, iddlm, iadk, jdik, diag_k, lt_k, b, a, kss, ksm, knm, krm, ii, idlm, iss, ism)
Definition i2_imp1.F:2470
i2_frup0
subroutine i2_frup0(x, irect, crst, nsv, irtl, ii, ndof, kss, k)
Definition i2_imp1.F:1702
i2_frk1
subroutine i2_frk1(irect, dpara, x, itab, nsv, irtl, ikc, ndof, iddl, iddlm, iadk, jdik, diag_k, lt_k, b, a, kss, ksm, knm, krm, ii, idlm, iss, ism)
Definition i2_imp1.F:2629
i2_imp1
subroutine i2_imp1(ipari, intbuf_tab, itab, nsc2, isij2, nss2, iss2, x, ms, in, weight, ikc, ndof, nddl, iddl, iadk, jdik, diag_k, lt_k, b)
Definition i2_imp1.F:39
i2_frrd0
subroutine i2_frrd0(x, irect, crst, nsv, irtl, d, dr, ii, ndof)
Definition i2_imp2.F:478
i2_frrd1
subroutine i2_frrd1(x, irect, dpara, nsv, irtl, d, ii)
Definition i2_imp2.F:384
i7mainfr
subroutine i7mainfr(a, v, d, x, ms, ipari, intbuf_tab, num_imp, ns_imp, ne_imp)
Definition i7ke3.F:210
ini_intm
subroutine ini_intm(iloc, n_imps, n_impn)
Definition imp_fri.F:1203
ind_fvn
subroutine ind_fvn(ndof, iddl, ikc, inloc, nfv)
Definition imp_fri.F:8741
cp_iadd
subroutine cp_iadd(nsl, nsrem, iad_sld, iad_mld)
Definition imp_fri.F:9810
ini_ddfv
subroutine ini_ddfv(iddl, ikc, ndof, ipari, intbuf_tab, d, dr, dd, ddr, nsl, irbe3, lrbe3, irbe2, lrbe2)
Definition imp_fri.F:880
ind_fr_k0
subroutine ind_fr_k0(ndof, nrow, nnmax, icol, fr_elem, iad_elem, n_fr)
Definition imp_fri.F:3731
ini_frkc
subroutine ini_frkc(nsrem, nsl, ikc, ndof, iddl)
Definition imp_fri.F:5587
rowfr_dim24
subroutine rowfr_dim24(jlt, ns_imp, ne_imp, irect, nrow, nsn, nin, subtria, nvoisin)
Definition imp_fri.F:5034
kin_kml
subroutine kin_kml(ipari, intbuf_tab, nint2, iint2, npby, lpby, itab, nrbyac, irbyac, x, ibfv, lj, skew, xframe, iskew, icodt, ndof, ilocp, nsrem, iddl, ikc, iad_m, nml, irbe3, lrbe3, irbe2, lrbe2)
Definition imp_fri.F:7443
imp_frks
subroutine imp_frks(nsl, iddl, ikc, ndof, iddlm, kss, iad_sld)
Definition imp_fri.F:9577
ikincf
logical function ikincf(i)
Definition imp_fri.F:7186
rowfr_ind24
subroutine rowfr_ind24(jlt, ns_imp, ne_imp, irect, nrow, icol, nnmax, nsn, nin, subtria, nvoisin)
Definition imp_fri.F:5088
upd_fr_k
subroutine upd_fr_k(iadk, jdik, ndof, ikc, iddl, inloc, fr_elem, iad_elem, nddl)
Definition imp_fri.F:4097
kin_nrmax
subroutine kin_nrmax(nnmax, nkmax, nrowk, icok, icokm, iloc, ink, fr_elem, iad_elem)
Definition imp_fri.F:3219
reorder_fr
subroutine reorder_fr(n, ic, iddl)
Definition imp_fri.F:5234
ini_ksi
subroutine ini_ksi(nsrem, ksi, iddl)
Definition imp_fri.F:5683
ini_frud
subroutine ini_frud(nsrem, nsl, nfv, ifvsi, ifvsl, nf_si, nf_sl, lvsi)
Definition imp_fri.F:8922
upd_ksl
subroutine upd_ksl(ipari, intbuf_tab, nint2, iint2, npby, lpby, itab, nrbyac, irbyac, x, ibfv, lj, skew, xframe, iskew, icodt, inloc, nsl, iad_m, iddl, ikc, ndof, iddlm, ud, a, b, kss, ksl_fr, ksi_fr, irbe3, lrbe3, frbe3, irbe2, lrbe2)
Definition imp_fri.F:5755
mav_ltfr
subroutine mav_ltfr(v, w)
Definition imp_fri.F:4604
upd_fr
subroutine upd_fr(a, ar, x, ipari, intbuf_tab, ndof, ibfv, skew, xframe, irbe3, lrbe3, irbe2, lrbe2)
Definition imp_fri.F:2830
zero_ikin2g
subroutine zero_ikin2g(nkine, iloc)
Definition imp_fri.F:4468
tag_ints
subroutine tag_ints(nsl, iloc, n_impn)
Definition imp_fri.F:825
fr_u2d
subroutine fr_u2d(ndof, lx, d, a, nsrem, nsl)
Definition imp_fri.F:2536
scom_frud
subroutine scom_frud(uds, udr, nf_s, nf_r, ikcs, ikcr)
Definition imp_fri.F:9015
dim_fr_k
subroutine dim_fr_k(elbuf, iparg, ixs, ixq, ixc, ixt, ixp, ixr, ixtg, ixtg1, ixs10, ixs20, ixs16, ndof, nnmax, inloc, fr_elem, iad_elem, n_fr, igeo, fr_i2m, iad_i2m, elbuf_tab)
Definition imp_fri.F:3340
ind_sld
subroutine ind_sld(nsl, ndof, kss)
Definition imp_fri.F:9406
imp_fvksl
subroutine imp_fvksl(iddl, iddlm, ikc, ifvsi, nf_si, ksi, lb, nsrem, udsi)
Definition imp_fri.F:9101
ind_kine_kp
subroutine ind_kine_kp(nrowk, icok, icokm, nnmax, nkmax, nkine, ink, ikpat, iddl)
Definition imp_fri.F:4506
jdifrtok
subroutine jdifrtok(itok)
Definition imp_fri.F:5273
imp_fvksm
subroutine imp_fvksm(nj, iddl, iddlm, ikc, uds, ksm, lb)
Definition imp_fri.F:9156
intabfr
subroutine intabfr(nic, ic, n, intab)
Definition imp_fri.F:2140
dim_frkm
subroutine dim_frkm(nsrem, nsl, ssize, rsize)
Definition imp_fri.F:5637
tag_intml
subroutine tag_intml(nsrem, iloc, n_impn, iddl, ikc, ndof, lsi)
Definition imp_fri.F:7523
fr_matv_gpu
subroutine fr_matv_gpu(nsrem, nsl, lx, f, nindex)
Definition imp_fri.F:2494
set_ikin2g
subroutine set_ikin2g(nkine, inloc)
Definition imp_fri.F:4388
get_ikin2g
subroutine get_ikin2g(nkine, ink, iloc)
Definition imp_fri.F:4429
doub_nrs
subroutine doub_nrs(nsl, nnmax, nrs, icol, ilocp)
Definition imp_fri.F:6645
assem_ksl
subroutine assem_ksl(iddl, k_diag, k_lt, iadk, jdik, kss, nsl)
Definition imp_fri.F:6356
ind_kinfrk
subroutine ind_kinfrk(npby, lpby, itab, nrbyac, irbyac, nint2, iint2, ipari, intbuf_tab, inloc, ia, ia2, nss, nss2, n_kine, ibfv, lj, iskew, icodt, nrs, icol, nnmax, irbe3, lrbe3, lns3, irbe2, lrbe2, lns4)
Definition imp_fri.F:6899
nddli_frb
subroutine nddli_frb(ndof, ikc, iddl, ndofi, nddlifb, fr_elem, iad_elem)
Definition imp_fri.F:9851
imp_frii
subroutine imp_frii(ninter)
Definition imp_fri.F:456
imp_fvkss
subroutine imp_fvkss(kss, iddl, iddlm, ikc, nsl, d_imp, lb, nfv, udsl, inloc, ndof)
Definition imp_fri.F:8800
putfr_kij
subroutine putfr_kij(id, jd, iadk, jdik, k_lt, kij, nk, nl)
Definition imp_fri.F:6505
dim_fvn
subroutine dim_fvn(ndof, iddl, ikc, inloc, nfv)
Definition imp_fri.F:8696
ndofi_nsl
subroutine ndofi_nsl(nsl, nddli, ndofi)
Definition imp_fri.F:9930
ind_fr_k
subroutine ind_fr_k(elbuf, iparg, ixs, ixq, ixc, ixt, ixp, ixr, ixtg, ixtg1, ixs10, ixs20, ixs16, ndof, nnmax, inloc, fr_elem, iad_elem, n_fr, igeo, elbuf_tab)
Definition imp_fri.F:3542
dim_kinefr
subroutine dim_kinefr(npby, lpby, itab, nrbyac, irbyac, nint2, iint2, ipari, intbuf_tab, inloc, lns, lns2, lnss, lnss2, nk_m, irbe3, lns3, lnss3, irbe2, lrbe2, lnr2, lnrs2)
Definition imp_fri.F:1253
imp_frsn
subroutine imp_frsn(ipari, intbuf_tab, nbintc, intlist)
Definition imp_fri.F:384
ind_frkd
subroutine ind_frkd(ipari, intbuf_tab, num_imp, ns_imp, ne_imp, iddl, ikc, ndof, nsrem, ind_imp)
Definition imp_fri.F:4727
fr_a2b
subroutine fr_a2b(ndof, lb, a, nsl)
Definition imp_fri.F:2952
ind_nrfr
subroutine ind_nrfr(nft, nel, npn, npp, nnmax, nrow, icol, fr_elem, iad_elem, n_fr, icok)
Definition imp_fri.F:3635
kin_ksl
subroutine kin_ksl(ipari, intbuf_tab, nint2, iint2, npby, lpby, itab, nrbyac, irbyac, x, ibfv, lj, skew, xframe, iskew, icodt, ndof, ilocp, nsl, iad_m, irbe3, lrbe3, irbe2, lrbe2)
Definition imp_fri.F:6559
get_iad
subroutine get_iad(iad_m, iad_s, jdi_s, nm, is, j, nrj, ndof, iad)
Definition imp_fri.F:7139
fr_matv
subroutine fr_matv(a, v, d, ms, x, dr, ar, ipari, intbuf_tab, ndof, num_imp, ns_imp, ne_imp, lx, nsrem, nsl, ibfv, skew, xframe, f, irbe3, lrbe3, irbe2, lrbe2)
Definition imp_fri.F:2418
tag_intm11
subroutine tag_intm11(jlt, ns_imp, ne_imp, irects, irectm, iloc, n_impn, nsn)
Definition imp_fri.F:4561
getnddli_g
subroutine getnddli_g(npby, lpby, itab, nrbyac, irbyac, nint2, iint2, ipari, intbuf_tab, ndofi, ndof, ikc, iddl, fr_elem, iad_elem, nddli, nsl, nddlig, irbe3, lrbe3, irbe2, lrbe2)
Definition imp_fri.F:9983
imp_frsl
subroutine imp_frsl(nbintc, nsrem, nsl)
Definition imp_fri.F:701
imp_frfv
subroutine imp_frfv(num_imp, ns_imp, ne_imp, ipari, intbuf_tab, iddl, ikc, ndof, nsrem, nsl, d_imp, dd, dr_imp, ddr, a, ar, ms, v, x, lb, nddl, ibfv, skew, xframe, irbe3, lrbe3, irbe2, lrbe2, de, nddl0, w_ddl)
Definition imp_fri.F:143
rowfr_dim11
subroutine rowfr_dim11(jlt, ns_imp, ne_imp, irectm, nrow, nsn, nin)
Definition imp_fri.F:4896
rowfr_ind11
subroutine rowfr_ind11(jlt, ns_imp, ne_imp, irectm, nrow, icol, nnmax, nsn, nin)
Definition imp_fri.F:4985
ini_slnr
subroutine ini_slnr(nsl, nnmax, nrs, icol, nz, ndof, iad_m)
Definition imp_fri.F:6687
mav_ltfr_gpu
subroutine mav_ltfr_gpu(v, w, nindex)
Definition imp_fri.F:4658
ini_frfd
subroutine ini_frfd(nsrem, nfv, ikcsi, nf_si, fdsi)
Definition imp_fri.F:9308
diag_int
subroutine diag_int(nsl, ndof, ipari, intbuf_tab, kss, x, ibfv, skew, xframe, irbe3, lrbe3, irbe2, lrbe2)
Definition imp_fri.F:1839
imp_frki
subroutine imp_frki(ipari, intbuf_tab, num_imp, ns_imp, ne_imp, npby, lpby, itab, nrbyac, irbyac, nint2, iint2, iddl, ikc, ndof, inloc, nsrem, nsl, nbintc, intlist, x, ibfv, lj, skew, xframe, iskew, icodt, irbe3, lrbe3, frbe3, irbe2, lrbe2)
Definition imp_fri.F:260
ind_nrmax
subroutine ind_nrmax(nft, nel, npn, npps, nnmax, nrow, icol, iad_rl, fr_icol, n_frnn)
Definition imp_fri.F:3274
imp_diags
subroutine imp_diags(diag_k, ndof, nsl, ipari, intbuf_tab, irbe3, lrbe3, irbe2)
Definition imp_fri.F:2175
assfr_kij
subroutine assfr_kij(id, jd, iadk, jdik, k_lt, kij, nd)
Definition imp_fri.F:6414
dim_kinfrk
subroutine dim_kinfrk(npby, lpby, itab, nrbyac, irbyac, nint2, iint2, ipari, intbuf_tab, inloc, ia, ia2, nrs, lns, lns2, n_kine, irbe3, lrbe3, lns3, irbe2, lrbe2, lns4)
Definition imp_fri.F:6754
scom_frk1
subroutine scom_frk1(ks11, kr11, nfacs, nfacr, ikcs, ikcr)
Definition imp_fri.F:7643
dim_nrmax
subroutine dim_nrmax(nrow, fr_elem, iad_elem, nnmax)
Definition imp_fri.F:3114
tra_frkm
subroutine tra_frkm(nsl, iddl, ikc, ndof, iad_m, ksi, ksl, ikcsl)
Definition imp_fri.F:7306
iddl_int
subroutine iddl_int(nsl, iddl, ikc, ndof, iddlm, ipari, intbuf_tab, irbe3, lrbe3, frbe3, x, skew, irbe2, lrbe2)
Definition imp_fri.F:1616
imp_diagsn
subroutine imp_diagsn(diag_k, ndof, nsl, ipari, intbuf_tab, irbe3, lrbe3, irbe2)
Definition imp_fri.F:2289
ini_dd0
subroutine ini_dd0(iddl, ikc, ndof, ipari, intbuf_tab, dd, ddr, nsl, irbe3, lrbe3, irbe2, lrbe2)
Definition imp_fri.F:1044
upd_kml
subroutine upd_kml(ipari, intbuf_tab, nint2, iint2, npby, lpby, itab, nrbyac, irbyac, x, ibfv, lj, skew, xframe, iskew, icodt, inloc, nsl, iad_m, iddl, ikc, ndof, iddlm, ud, a, ksl, ksi, nsrem, nf_si, iddli, irbe3, lrbe3, frbe3, irbe2, lrbe2)
Definition imp_fri.F:7741
rowfr_dim
subroutine rowfr_dim(jlt, ns_imp, ne_imp, irect, nrow, nsn, nin)
Definition imp_fri.F:4853
dim_frkm1
subroutine dim_frkm1(nsrem, nsl, iddl, ikc, ndof, nf_si, nf_sl, lsi, lsl, msi, msl)
Definition imp_fri.F:7218
imp_fr7i
subroutine imp_fr7i(ipari, intbuf_tab, num_imp, ns_imp, nsrem, nbintc, intlist)
Definition imp_fri.F:506
imp_fri
subroutine imp_fri(num_imp, ns_imp, ne_imp, ipari, intbuf_tab, npby, lpby, itab, nrbyac, irbyac, nint2, iint2, iddl, ikc, ndof, inloc, nsrem, nsl, nbintc, intlist, x, ibfv, lj, skew, xframe, iskew, icodt, a, ud, lb, ifdis, nddl, urd, iddli, irbe3, lrbe3, frbe3, irbe2, lrbe2)
Definition imp_fri.F:45
cp_slnr
subroutine cp_slnr(iad_cp, jdi_cp, nsl, nz)
Definition imp_fri.F:9369
spc_fr_k
subroutine spc_fr_k(iadk, jdik, ndof, iddl, fr_elem, iad_elem)
Definition imp_fri.F:10156
imp_frkd
subroutine imp_frkd(npby, lpby, itab, nrbyac, irbyac, ipari, intbuf_tab, nint2, iint2, iddl, ikc, ndof, inloc, nsrem, nsl, nbintc, intlist, x, ibfv, lj, skew, xframe, iskew, icodt, a, ud, lb, ifdis, urd, iddli, irbe3, lrbe3, frbe3, irbe2, lrbe2)
Definition imp_fri.F:5344
fr_dlft
subroutine fr_dlft(nddl, idlft0, idlft1)
Definition imp_fri.F:4355
fr_u2dd
subroutine fr_u2dd(d, dr, x, ipari, intbuf_tab, ndof, a, ar, lx, ibfv, skew, xframe, irbe3, lrbe3, irbe2, lrbe2)
Definition imp_fri.F:2607
imp_frkm
subroutine imp_frkm(nsrem, ikinm, ikcsi, ikc, ndof, iddl, iddlm, inloc, iad_m, frk_si, frk_sl, nf_si, iad_mld, iddli)
Definition imp_fri.F:8385
rowfr_ind
subroutine rowfr_ind(jlt, ns_imp, ne_imp, irect, nrow, icol, nnmax, nsn, nin)
Definition imp_fri.F:4939
imp_fvkm
subroutine imp_fvkm(kfr_si, kfr_sl, iddl, ndof, ikc, inloc, iad_m, nsrem, nsl, ud0, fdsi, nf_si, nfv, nfd, iddli)
Definition imp_fri.F:9207
fr_a2bd
subroutine fr_a2bd(ndof, ipari, intbuf_tab, lb, a, ar, irbe3, lrbe3, irbe2, lrbe2)
Definition imp_fri.F:3000
nddli_ns
subroutine nddli_ns(npby, lpby, itab, nrbyac, irbyac, nint2, iint2, ipari, intbuf_tab, ndofi, ndof, ikc, iddl, nsl, nddli, nddlins, irbe3, lrbe3, irbe2, lrbe2)
Definition imp_fri.F:10038
ind_kinefr
subroutine ind_kinefr(npby, lpby, itab, nrbyac, irbyac, nint2, iint2, ipari, intbuf_tab, inloc, nss, nss2, nss_s, nss2_s, kn_m, ibfv, lj, iskew, icodt, irbe3, nss3, nss3_s, irbe2, lrbe2, nsr2, nrs2_s)
Definition imp_fri.F:1365
scom_frk
subroutine scom_frk(ks11, kr11, ssize, rsize)
Definition imp_fri.F:7589
getfr_kij
subroutine getfr_kij(id, jd, iadk, jdik, k_lt, kij, nk, nl)
Definition imp_fri.F:6462
set_ind_fr
subroutine set_ind_fr(nsrem, iddl, ndof, nrow, icol, nnmax)
Definition imp_fri.F:5140
kin_nrmax0
subroutine kin_nrmax0(nnmax, nkmax, nrowk, icok, icokm, iloc, ink, fr_elem, iad_elem)
Definition imp_fri.F:3162
ini_fr_k
subroutine ini_fr_k(elbuf, iparg, ixs, ixq, ixc, ixt, ixp, ixr, ixtg, ixtg1, ixs10, ixs20, ixs16, ndof, nnmax, inloc, fr_elem, iad_elem, n_fr, igeo, fr_i2m, iad_i2m, elbuf_tab, nnrmax)
Definition imp_fri.F:3901
tag_intm
subroutine tag_intm(jlt, ns_imp, ne_imp, irect, nsv, iloc, n_impn, nsn)
Definition imp_fri.F:773
put_kii
subroutine put_kii(ni, iddl, iadk, k_diag, k_lt, kii, nd)
Definition imp_glob_k.F:655
assem_kii
subroutine assem_kii(ni, nel, iddl, iadk, k_diag, k_lt, kii, nd, off)
Definition imp_glob_k.F:964
get_kii
subroutine get_kii(ni, iddl, iadk, k_diag, k_lt, kii, nd)
Definition imp_glob_k.F:593
get_kij
subroutine get_kij(ni, nj, iddl, iadk, jdik, k_lt, kij, nk, nl, ierr)
Definition imp_glob_k.F:715
spmd_ifrf_gpu
subroutine spmd_ifrf_gpu(f_imp, nindex)
Definition imp_spmd.F:4143
spmd_ifru
subroutine spmd_ifru(lx)
Definition imp_spmd.F:3790
spmd_exci
subroutine spmd_exci(its, itr, iad_s, iad_r, size, ssize, rsize)
Definition imp_spmd.F:3555
spmd_isr
subroutine spmd_isr(iad_s, iad_r, its, itr, ssize, rsize)
Definition imp_spmd.F:3441
spmd_exck
subroutine spmd_exck(ks11, kr11, iad_s, iad_r, size, ssize, rsize)
Definition imp_spmd.F:3675
spmd_sumf_v
subroutine spmd_sumf_v(v)
Definition imp_spmd.F:1650
spmd_ifcd
subroutine spmd_ifcd(d_imp, ssize, rsize)
Definition imp_spmd.F:2326
spmd_ifrf
subroutine spmd_ifrf(f_imp)
Definition imp_spmd.F:3908
spmd_nddlig
subroutine spmd_nddlig(nddl, nddlfr, nddlg)
Definition imp_spmd.F:4734
spmd_inis
subroutine spmd_inis(iad_s, iad_r)
Definition imp_spmd.F:2003
spmd_ifru_gpu
subroutine spmd_ifru_gpu(lx, nindex)
Definition imp_spmd.F:4024
spmd_inisl
subroutine spmd_inisl(nbintc, inbsl)
Definition imp_spmd.F:2090
spmd_ifc1
subroutine spmd_ifc1(ssize, rsize, kss)
Definition imp_spmd.F:2190
spmd_ifcf
subroutine spmd_ifcf(f_imp, ssize, rsize)
Definition imp_spmd.F:2450
spmd_sum_s
subroutine spmd_sum_s(s)
Definition imp_spmd.F:1037
spmd_icol
subroutine spmd_icol(iad_s, iad_r, nnmax, icol, nrow, fr_nrow, iad_elem, fr_elem, ssize, rsize)
Definition imp_spmd.F:2679
spmd_max_iv
subroutine spmd_max_iv(iv)
Definition imp_spmd.F:5017
spmd_nrow
subroutine spmd_nrow(nrow, fr_nrow, iad_elem, tsize)
Definition imp_spmd.F:2577
reorder_j
subroutine reorder_j(n, ic, ni, iddl)
Definition ind_glob_k.F:4387
dim_elemsp
subroutine dim_elemsp(elbuf, iparg, ixs, ixq, ixc, ixt, ixp, ixr, ixtg, ixtg1, ixs10, ixs20, ixs16, nrow, inloc, nkmax, icok, igeo, elbuf_tab)
Definition ind_glob_k.F:1323
i24msegv
subroutine i24msegv(ie, irtlmv, subtria, irtlm, nvoisin)
Definition ind_glob_k.F:7958
reorder_l
subroutine reorder_l(n, ic, ni, iddl)
Definition ind_glob_k.F:4452
reorder_a
subroutine reorder_a(n, ic, id)
Definition ind_glob_k.F:4286
rbe3cl
subroutine rbe3cl(inrbe3, ilrbe3, ns, xyz, frbe3, skew, ng, irot, fdstnb, mdstnb)
Definition kinchk.F:1592
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
id
initmumps id
Definition multiplerhs_example.m:4
imp_aspc
Definition impbufdef_mod.F:526
imp_aspc::in_spc
integer, dimension(:), allocatable in_spc
Definition impbufdef_mod.F:529
imp_aspc::ic_spc
integer, dimension(:), allocatable ic_spc
Definition impbufdef_mod.F:529
imp_aspc::nspcl
integer nspcl
Definition impbufdef_mod.F:527
imp_frk
Definition impbufdef_mod.F:740
imp_frk::ndfrmax
integer ndfrmax
Definition impbufdef_mod.F:742
imp_frk::nrmax
integer nrmax
Definition impbufdef_mod.F:742
imp_frk::fr_icol
integer, dimension(:), allocatable fr_icol
Definition impbufdef_mod.F:750
imp_frk::nddlfrb1
integer nddlfrb1
Definition impbufdef_mod.F:746
imp_frk::ifrloc
integer, dimension(:), allocatable ifrloc
Definition impbufdef_mod.F:749
imp_frk::ifr2k
integer, dimension(:), allocatable ifr2k
Definition impbufdef_mod.F:758
imp_frk::ikin2g
integer, dimension(:), allocatable ikin2g
Definition impbufdef_mod.F:752
imp_frk::len_v
integer len_v
Definition impbufdef_mod.F:742
imp_frk::n_frnn
integer n_frnn
Definition impbufdef_mod.F:742
imp_frk::iadfr
integer, dimension(:), allocatable iadfr
Definition impbufdef_mod.F:754
imp_frk::iddlfr
integer, dimension(:), allocatable iddlfr
Definition impbufdef_mod.F:754
imp_frk::jfr2k
integer, dimension(:), allocatable jfr2k
Definition impbufdef_mod.F:758
imp_frk::jdifr
integer, dimension(:), allocatable jdifr
Definition impbufdef_mod.F:754
imp_frk::ddlp0
integer ddlp0
Definition impbufdef_mod.F:746
imp_frk::len_k
integer len_k
Definition impbufdef_mod.F:742
imp_frk::iad_rl
integer, dimension(:), allocatable iad_rl
Definition impbufdef_mod.F:750
imp_frk::nd_fr
integer, dimension(:), allocatable nd_fr
Definition impbufdef_mod.F:754
imp_frk::nzkfr
integer nzkfr
Definition impbufdef_mod.F:742
imp_frk::nddlfr
integer nddlfr
Definition impbufdef_mod.F:742
imp_frk::ddlp1
integer ddlp1
Definition impbufdef_mod.F:746
imp_frk::nddlfrb
integer nddlfrb
Definition impbufdef_mod.F:746
imp_intm
Definition imp_intm.F:118
imp_intm::iddmr2
integer, dimension(:,:), allocatable iddmr2
Definition imp_intm.F:158
imp_intm::ibc_fr
integer, dimension(:,:), allocatable ibc_fr
Definition imp_intm.F:167
imp_intm::iddml
integer, dimension(:,:), allocatable iddml
Definition imp_intm.F:156
imp_intm::ifrsr
integer, dimension(:,:), allocatable ifrsr
Definition imp_intm.F:153
imp_intm::nrb_frs
integer nrb_frs
Definition imp_intm.F:127
imp_intm::ifrs2
integer, dimension(:,:), allocatable ifrs2
Definition imp_intm.F:153
imp_intm::ifrs3
integer, dimension(:), allocatable ifrs3
Definition imp_intm.F:154
imp_intm::jdi_sinr
integer, dimension(:), allocatable jdi_sinr
Definition imp_intm.F:176
imp_intm::nfx_fr
integer nfx_fr
Definition imp_intm.F:127
imp_intm::nrbe2_frs
integer nrbe2_frs
Definition imp_intm.F:127
imp_intm::nspc_fr
integer nspc_fr
Definition imp_intm.F:127
imp_intm::inbsl
integer, dimension(:,:), allocatable inbsl
Definition imp_intm.F:144
imp_intm::iad_sinr
integer, dimension(:), allocatable iad_sinr
Definition imp_intm.F:176
imp_intm::iddmi2
integer, dimension(:,:,:), allocatable iddmi2
Definition imp_intm.F:157
imp_intm::jdi_si
integer, dimension(:), allocatable jdi_si
Definition imp_intm.F:174
imp_intm::iddl_sl
integer, dimension(:), allocatable iddl_sl
Definition imp_intm.F:178
imp_intm::iad_ss
integer, dimension(:), allocatable iad_ss
Definition imp_intm.F:175
imp_intm::ifx_fr
integer, dimension(:,:), allocatable ifx_fr
Definition imp_intm.F:167
imp_intm::nz_sl
integer nz_sl
Definition imp_intm.F:173
imp_intm::nrbe2_fr
integer nrbe2_fr
Definition imp_intm.F:127
imp_intm::nbc_fr
integer nbc_fr
Definition imp_intm.F:127
imp_intm::ifrsr_s
integer, dimension(:), allocatable ifrsr_s
Definition imp_intm.F:160
imp_intm::islm
integer, dimension(:), allocatable islm
Definition imp_intm.F:140
imp_intm::nrbe3_frs
integer nrbe3_frs
Definition imp_intm.F:127
imp_intm::fr_srem
integer, dimension(:), allocatable fr_srem
Definition imp_intm.F:131
imp_intm::iddsl
integer, dimension(:,:), allocatable iddsl
Definition imp_intm.F:156
imp_intm::iad_si
integer, dimension(:), allocatable iad_si
Definition imp_intm.F:174
imp_intm::nml
integer nml
Definition imp_intm.F:127
imp_intm::ispc_fr
integer, dimension(:), allocatable ispc_fr
Definition imp_intm.F:168
imp_intm::jdi_sl
integer, dimension(:), allocatable jdi_sl
Definition imp_intm.F:175
imp_intm::ni2_fr
integer ni2_fr
Definition imp_intm.F:127
imp_intm::shf_int
integer, dimension(:), allocatable shf_int
Definition imp_intm.F:136
imp_intm::iad_slnr
integer, dimension(:), allocatable iad_slnr
Definition imp_intm.F:177
imp_intm::iddmr
integer, dimension(:,:), allocatable iddmr
Definition imp_intm.F:156
imp_intm::iddmi3
integer, dimension(:,:,:), allocatable iddmi3
Definition imp_intm.F:157
imp_intm::ifrs3_s
integer, dimension(:), allocatable ifrs3_s
Definition imp_intm.F:160
imp_intm::nrbe3_fr
integer nrbe3_fr
Definition imp_intm.F:127
imp_intm::ikc_sl
integer, dimension(:), allocatable ikc_sl
Definition imp_intm.F:175
imp_intm::iad_sl
integer, dimension(:), allocatable iad_sl
Definition imp_intm.F:145
imp_intm::ikc_si
integer, dimension(:), allocatable ikc_si
Definition imp_intm.F:174
imp_intm::intp_d
integer intp_d
Definition imp_intm.F:173
imp_intm::ni2_frs
integer ni2_frs
Definition imp_intm.F:127
imp_intm::nddl_si
integer nddl_si
Definition imp_intm.F:173
imp_intm::ifrs4_s
integer, dimension(:), allocatable ifrs4_s
Definition imp_intm.F:161
imp_intm::irw_fr
integer, dimension(:), allocatable irw_fr
Definition imp_intm.F:171
imp_intm::nrb_fr
integer nrb_fr
Definition imp_intm.F:127
imp_intm::nddl_sl
integer nddl_sl
Definition imp_intm.F:173
imp_intm::iad_srem
integer, dimension(:), allocatable iad_srem
Definition imp_intm.F:145
imp_intm::nz_si
integer nz_si
Definition imp_intm.F:173
imp_intm::ind_int
type(int_pointer2), dimension(:), allocatable ind_int
Definition imp_intm.F:133
imp_intm::ifrs2_s
integer, dimension(:), allocatable ifrs2_s
Definition imp_intm.F:160
imp_intm::nrw_fr
integer nrw_fr
Definition imp_intm.F:170
imp_intm::isl
integer, dimension(:), allocatable isl
Definition imp_intm.F:138
imp_intm::iml
integer, dimension(:), allocatable iml
Definition imp_intm.F:142
imp_intm::iddl_si
integer, dimension(:), allocatable iddl_si
Definition imp_intm.F:178
imp_intm::jdi_slnr
integer, dimension(:), allocatable jdi_slnr
Definition imp_intm.F:177
imp_intm::ifrs4
integer, dimension(:,:), allocatable ifrs4
Definition imp_intm.F:153
imp_rwl
Definition impbufdef_mod.F:387
imp_rwl::in_rwl
integer, dimension(:), allocatable in_rwl
Definition impbufdef_mod.F:391
imp_rwl::n_rwl
integer n_rwl
Definition impbufdef_mod.F:389
tri7box::nsvfi
type(int_pointer), dimension(:), allocatable nsvfi
Definition tri7box.F:431
tri7box::nsnfi
type(int_pointer), dimension(:), allocatable nsnfi
Definition tri7box.F:440
cp_real
subroutine cp_real(n, x, xc)
Definition produt_v.F:871
cp_int
subroutine cp_int(n, x, xc)
Definition produt_v.F:916
produt_vmhp
subroutine produt_vmhp(nddl0, nddl, iddl, ndof, ikc, dd, ddr, y, r, w_imp)
Definition produt_v.F:3321
rbe2_frk
subroutine rbe2_frk(ns, m, x, isk, skew0, irad, ndof, iddl, jt, jr, iadk, jdik, diag_k, lt_k, b, a, kss, ksm, knm, krm, idlm, iss, ism)
Definition rbe2_imp0.F:1739
rbe2_impkd
subroutine rbe2_impkd(m, ns, x, isk, jt, jr, ndof, skew0, kdd, diag_km, diag_kn, irad)
Definition rbe2_imp0.F:1645
prerbe2fr
subroutine prerbe2fr(ic, jt, jr)
Definition rbe2f.F:1059
rbe2frf
subroutine rbe2frf(ns, m, a, ar, jt, jr, x, isk, skew0, irad)
Definition rbe2f.F:706
rbe2f
subroutine rbe2f(nsl, isl, x, a, ar, ms, in, weight, jt, jr, f6, m6, stifn, stifr, stif6, stir6, m, irad)
Definition rbe2f.F:135
rbe2_frd
subroutine rbe2_frd(ns, m, x, v, vr, jt, jr, skew0, isk, irad)
Definition rbe2v.F:1025
rbe3_fr0
subroutine rbe3_fr0(ns, nml, iml, x, irot, jt, jr, frbe3, skew, ikc, ndof, iadk, jdik, diag_k, lt_k, kss, ksm, knm, krm, idlm, iss, ism, itab, isk, id)
Definition rbe3_imp0.F:1074
rbe3_frupd
subroutine rbe3_frupd(nir, iml, fdstnb, mdstnb, ndof, jt, irot, kss, diag_m3)
Definition rbe3_imp0.F:1017
rbe3frf
subroutine rbe3frf(nml, iml, ns, a, ar, fdstnb, mdstnb, jt, jr, irot)
Definition rbe3f.F:2155
rbe3_frd
subroutine rbe3_frd(nml, iml, ns, d, dr, fdstnb, mdstnb, jt, jr, irot)
Definition rbe3v.F:231
updfr_rb
subroutine updfr_rb(xs, ys, zs, kii, k)
Definition rby_imp0.F:652
rby_frk
subroutine rby_frk(ns, m, x, itab, ikc, ndof, iddl, iddlm, iadk, jdik, diag_k, lt_k, b, a, kss, ksm, knm, krm, idlm, iss, ism)
Definition rby_imp0.F:894
rby_impf
subroutine rby_impf(x, m, n, ndof, a, ar)
Definition rby_imp0.F:612
rby_imp3
subroutine rby_imp3(x, m, n, d, dr, a, ar)
Definition rby_impd.F:156
nl
character *2 function nl()
Definition message.F:2360
condens_ind
subroutine condens_ind(nddl, nnz, iadk, jdik, ikc)
Definition upd_glob_k.F:330