OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
produt_v.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/.
23C---------------------r={x}^t{y}---
24!||====================================================================
25!|| produt_v ../engine/source/implicit/produt_v.F
26!||--- called by ------------------------------------------------------
27!|| imp_qrf ../engine/source/implicit/imp_pc_inv.F
28!|| mav_qt ../engine/source/implicit/imp_pc_inv.F
29!||--- calls -----------------------------------------------------
30!|| spmd_sum_s ../engine/source/mpi/implicit/imp_spmd.F
31!||====================================================================
32 SUBROUTINE produt_v( NDDL ,X ,Y ,R)
33C-----------------------------------------------
34C I m p l i c i t T y p e s
35C-----------------------------------------------
36#include "implicit_f.inc"
37C-----------------------------------------------
38C C o m m o n B l o c k s
39C-----------------------------------------------
40#include "com01_c.inc"
41C-----------------------------------------------
42C D u m m y A r g u m e n t s
43C-----------------------------------------------
44 INTEGER NDDL
45 my_real
46 . x(*), y(*) ,r
47C-----------------------------------------------
48C L o c a l V a r i a b l e s
49C-----------------------------------------------
50 INTEGER I
51C-----------------------------
52 r = zero
53 DO i=1,nddl
54 r = r + x(i)*y(i)
55 ENDDO
56 IF (nspmd>1) CALL spmd_sum_s(r)
57C--------------------------------------------
58 RETURN
59 END
60C---------------------r={x}^t{y}---
61!||====================================================================
62!|| produt_v_loc ../engine/source/implicit/produt_v.F
63!||--- called by ------------------------------------------------------
64!|| mav_mn ../engine/source/implicit/produt_v.F
65!||====================================================================
66 SUBROUTINE produt_v_loc( NDDL ,X ,Y ,R)
67C-----------------------------------------------
68C I m p l i c i t T y p e s
69C-----------------------------------------------
70#include "implicit_f.inc"
71C D u m m y A r g u m e n t s
72C-----------------------------------------------
73 INTEGER NDDL
74 my_real
75 . x(*), y(*) ,r
76C-----------------------------------------------
77C L o c a l V a r i a b l e s
78C-----------------------------------------------
79 INTEGER I
80C-----------------------------
81 r = zero
82 DO i=1,nddl
83 r = r + x(i)*y(i)
84 ENDDO
85C--------------------------------------------
86 RETURN
87 END
88!||====================================================================
89!|| produt_w ../engine/source/implicit/produt_v.F
90!||--- called by ------------------------------------------------------
91!|| bfgs_1 ../engine/source/implicit/imp_bfgs.F
92!|| bfgs_1p ../engine/source/implicit/imp_bfgs.F
93!|| bfgs_rhd ../engine/source/implicit/imp_bfgs.F
94!|| ext_rhs ../engine/source/implicit/upd_glob_k.F
95!|| imp_chkm ../engine/source/implicit/imp_solv.F
96!|| imp_lanzp ../engine/source/implicit/imp_lanz.F
97!|| nsloan_5 ../engine/source/implicit/imp_bfgs.F
98!|| produt_u ../engine/source/implicit/produt_v.F
99!|| produt_u2 ../engine/source/implicit/produt_v.F
100!|| produt_vm ../engine/source/implicit/produt_v.F
101!|| rer02 ../engine/source/implicit/upd_glob_k.F
102!||--- calls -----------------------------------------------------
103!|| spmd_sum_s ../engine/source/mpi/implicit/imp_spmd.F
104!||====================================================================
105 SUBROUTINE produt_w( NDDL ,X ,Y ,W , R)
106C-----------------------------------------------
107C I m p l i c i t T y p e s
108C-----------------------------------------------
109#include "implicit_f.inc"
110C-----------------------------------------------
111C C o m m o n B l o c k s
112C-----------------------------------------------
113#include "com01_c.inc"
114C-----------------------------------------------
115C D u m m y A r g u m e n t s
116C-----------------------------------------------
117 INTEGER NDDL ,W(*)
118C REAL
119 my_real
120 . x(*), y(*) ,r
121C-----------------------------------------------
122C L o c a l V a r i a b l e s
123C-----------------------------------------------
124 INTEGER I
125C-----------------------------
126 r = zero
127 IF (nspmd>1) THEN
128 DO i=1,nddl
129 IF (w(i)/=0) r = r + x(i)*y(i)
130 ENDDO
131 CALL spmd_sum_s(r)
132 ELSE
133 DO i=1,nddl
134 r = r + x(i)*y(i)
135 ENDDO
136 ENDIF
137C--------------------------------------------
138 RETURN
139 END
140!||====================================================================
141!|| d_to_u ../engine/source/implicit/produt_v.F
142!||--- called by ------------------------------------------------------
143!|| nsloan_5 ../engine/source/implicit/imp_bfgs.F
144!|| produt_vm ../engine/source/implicit/produt_v.F
145!|| produt_vmh ../engine/source/implicit/produt_v.F
146!|| produt_vmhp ../engine/source/implicit/produt_v.F
147!||--- calls -----------------------------------------------------
148!|| condens_b ../engine/source/implicit/upd_glob_k.F
149!|| cp_real ../engine/source/implicit/produt_v.F
150!|| imp_setb ../engine/source/implicit/imp_setb.F
151!||====================================================================
152 SUBROUTINE d_to_u(NDDL0 ,NDDL ,IDDL ,NDOF ,IKC ,
153 . D ,DR ,U )
154C-----------------------------------------------
155C I m p l i c i t T y p e s
156C-----------------------------------------------
157#include "implicit_f.inc"
158C-----------------------------------------------
159C D u m m y A r g u m e n t s
160C-----------------------------------------------
161 INTEGER NDDL,NDDL0,IDDL(*) ,NDOF(*) ,IKC(*)
162C REAL
163 my_real
164 . d(*),dr(*), u(*)
165C-----------------------------------------------
166C L o c a l V a r i a b l e s
167C-----------------------------------------------
168 INTEGER I
169 my_real
170 . x(nddl0)
171C-----------------------------
172 CALL imp_setb(d ,dr ,iddl ,ndof ,x )
173 CALL condens_b(nddl0 ,ikc ,x )
174 CALL cp_real(nddl,x,u)
175C--------------------------------------------
176 RETURN
177 END
178C---------------------r={x}^t{y}--x comes from u(3,*)-
179!||====================================================================
180!|| produt_vm ../engine/source/implicit/produt_v.F
181!||--- calls -----------------------------------------------------
182!|| d_to_u ../engine/source/implicit/produt_v.F
183!|| produt_w ../engine/source/implicit/produt_v.F
184!||====================================================================
185 SUBROUTINE produt_vm(NDDL0 ,NDDL ,IDDL ,NDOF ,IKC ,
186 . DD ,DDR ,Y ,R ,W_IMP )
187C-----------------------------------------------
188C I m p l i c i t T y p e s
189C-----------------------------------------------
190#include "implicit_f.inc"
191C-----------------------------------------------
192C D u m m y A r g u m e n t s
193C-----------------------------------------------
194 INTEGER NDDL,NDDL0,IDDL(*) ,NDOF(*) ,IKC(*) ,W_IMP(*)
195C REAL
196 my_real
197 . dd(*),ddr(*), y(*) ,r
198C-----------------------------------------------
199C L o c a l V a r i a b l e s
200C-----------------------------------------------
201 INTEGER I
202 my_real
203 . x(nddl)
204C-----------------------------
205 CALL d_to_u(nddl0 ,nddl ,iddl ,ndof ,ikc ,
206 . dd ,ddr ,x )
207 CALL produt_w(nddl,x,y,w_imp,r)
208C--------------------------------------------
209 RETURN
210 END
211C---------------------norm2={x}^t{x}--x comes from u(3,*)-
212!||====================================================================
213!|| produt_u ../engine/source/implicit/produt_v.F
214!||--- called by ------------------------------------------------------
215!|| al_constraint1 ../engine/source/implicit/nl_solv.F
216!|| al_constraint2 ../engine/source/implicit/nl_solv.F
217!||--- calls -----------------------------------------------------
218!|| condens_b ../engine/source/implicit/upd_glob_k.F
219!|| imp_setb ../engine/source/implicit/imp_setb.F
220!|| produt_w ../engine/source/implicit/produt_v.F
221!||====================================================================
222 SUBROUTINE produt_u(NDDL0 ,NDDL ,IDDL ,NDOF ,IKC ,
223 . DD ,DDR ,NORM2 ,W_IMP )
224C-----------------------------------------------
225C I m p l i c i t T y p e s
226C-----------------------------------------------
227#include "implicit_f.inc"
228C-----------------------------------------------
229C D u m m y A r g u m e n t s
230C-----------------------------------------------
231 INTEGER NDDL,NDDL0,IDDL(*) ,NDOF(*) ,IKC(*),W_IMP(*)
232C REAL
233 my_real
234 . dd(*),ddr(*), norm2
235C-----------------------------------------------
236C L o c a l V a r i a b l e s
237C-----------------------------------------------
238 INTEGER I
239 my_real
240 . X(NDDL0)
241C-----------------------------
242 CALL imp_setb(dd ,ddr ,iddl ,ndof ,x )
243 CALL condens_b(nddl0 ,ikc ,x )
244 CALL produt_w(nddl,x,x,w_imp,norm2)
245C--------------------------------------------
246 RETURN
247 END
248C---------------------norm2={x}^t{y}--x,y come from D1(3,*),D2--
249!||====================================================================
250!|| produt_u2 ../engine/source/implicit/produt_v.F
251!||--- called by ------------------------------------------------------
252!|| al_constraint1 ../engine/source/implicit/nl_solv.F
253!|| al_constraint2 ../engine/source/implicit/nl_solv.F
254!||--- calls -----------------------------------------------------
255!|| condens_b ../engine/source/implicit/upd_glob_k.F
256!|| imp_setb ../engine/source/implicit/imp_setb.F
257!|| produt_w ../engine/source/implicit/produt_v.F
258!||====================================================================
259 SUBROUTINE produt_u2(NDDL0 ,NDDL ,IDDL ,NDOF ,IKC ,
260 . D1 ,D1R ,D2 ,D2R ,NORM2 ,
261 . W_IMP )
262C-----------------------------------------------
263C I m p l i c i t T y p e s
264C-----------------------------------------------
265#include "implicit_f.inc"
266C-----------------------------------------------
267C D u m m y A r g u m e n t s
268C-----------------------------------------------
269 INTEGER NDDL,NDDL0,IDDL(*) ,NDOF(*) ,IKC(*),W_IMP(*)
270C REAL
271 my_real
272 . D1(*),D1R(*), D2(*),D2R(*), NORM2
273C-----------------------------------------------
274C L o c a l V a r i a b l e s
275C-----------------------------------------------
276 INTEGER I
277 my_real
278 . X(NDDL0),Y(NDDL0)
279C-----------------------------
280 CALL IMP_SETB(D1 ,D1R ,IDDL ,NDOF ,X )
281 CALL imp_setb(d2 ,d2r ,iddl ,ndof ,y )
282 CALL condens_b(nddl0 ,ikc ,x )
283 CALL condens_b(nddl0 ,ikc ,y )
284 CALL produt_w(nddl,x,y,w_imp,norm2)
285C--------------------------------------------
286 RETURN
287 END
288C---------------------r={x}^t{y}--(only with free dof)-
289!||====================================================================
290!|| zero_ud ../engine/source/implicit/produt_v.F
291!||====================================================================
292 SUBROUTINE zero_ud( NUM,IDDL,NDOF,IKC ,D ,DR ,IR)
293C-----------------------------------------------
294C I m p l i c i t T y p e s
295C-----------------------------------------------
296#include "implicit_f.inc"
297C-----------------------------------------------
298C D u m m y A r g u m e n t s
299C-----------------------------------------------
300 INTEGER NUM,IDDL(*),IKC(*) ,NDOF(*) ,IR
301C REAL
302 my_real
303 . D(3,*), DR(3,*)
304C-----------------------------------------------
305C L o c a l V a r i a b l e s
306C-----------------------------------------------
307 INTEGER I,J,ID
308C-----------------------------
309 DO I=1,num
310 DO j=1,3
311 id = iddl(i)+j
312 IF (ikc(id)==2) d(j,i)=zero
313 ENDDO
314 ENDDO
315 IF (ir/=0) THEN
316 DO i=1,num
317 IF (ndof(i)>3) THEN
318 DO j=1,3
319 id = iddl(i)+j+3
320 IF (ikc(id)==2) dr(j,i)=zero
321 ENDDO
322 ENDIF
323 ENDDO
324 ENDIF
325C--------------------------------------------
326 RETURN
327 END
328C-------------produce {w}=[K]{v} using only upper-triangle----
329!||====================================================================
330!|| mav_lt ../engine/source/implicit/produt_v.F
331!||--- called by ------------------------------------------------------
332!|| imp_dykv ../engine/source/implicit/imp_dyna.F
333!|| imp_dykv0 ../engine/source/implicit/imp_dyna.F
334!|| imp_pcg1 ../engine/source/implicit/imp_fsa_inv.F
335!|| sms_pcg1 ../engine/source/ams/sms_fsa_inv.F
336!||====================================================================
337 SUBROUTINE mav_lt(
338 1 NDDL ,NNZ ,IADL ,JDIL ,DIAG_K ,
339 2 LT_K ,V ,W )
340C-----------------------------------------------
341C I m p l i c i t T y p e s
342C-----------------------------------------------
343#include "implicit_f.inc"
344C-----------------------------------------------
345C D u m m y A r g u m e n t s
346C-----------------------------------------------
347 INTEGER NDDL ,NNZ ,IADL(*) ,JDIL(*)
348C REAL
349 my_real
350 . DIAG_K(*), W(*), LT_K(*) ,V(*)
351C-----------------------------------------------
352C L o c a l V a r i a b l e s
353C-----------------------------------------------
354 INTEGER I,J,K
355 my_real
356 . l_k
357C-----------------------------
358 DO i=1,nddl
359 w(i)=diag_k(i)*v(i)
360 ENDDO
361C
362 DO i=1,nddl
363 DO j =iadl(i),iadl(i+1)-1
364 k =jdil(j)
365 l_k = lt_k(j)
366 w(i) = w(i) + l_k*v(k)
367 w(k) = w(k) + l_k*v(i)
368 ENDDO
369 ENDDO
370C--------------------------------------------
371 RETURN
372 END
373C----version //-------------
374C DO I=1,NDDL
375C W(I)=DIAG_K(I)*V(I)
376C ENDDO
377C DO I=1,NDDL-1
378C DO J =IADL(I),IADL(I+1)-1
379C K =JDIL(J)
380C W(K) = W(K) + LT_K(J)*V(I)
381C ENDDO
382C ENDDO
383C
384C DO I=1,NDDL
385C DO J =IADL(I),IADL(I+1)-1
386C K =JDIL(J)
387C W(I) = W(I) + LT_K(J)*V(K)
388C ENDDO
389C ENDDO
390C-------------produit {w}=[K]{v} non-sym----
391!||====================================================================
392!|| mav_lt1 ../engine/source/implicit/produt_v.F
393!||--- called by ------------------------------------------------------
394!|| prec_solv ../engine/source/implicit/prec_solv.F
395!||====================================================================
396 SUBROUTINE mav_lt1(
397 1 NDDL ,NNZ ,IADL ,JDIL ,DIAG_K ,
398 2 LT_K ,V ,W )
399C-----------------------------------------------
400C I m p l i c i t T y p e s
401C-----------------------------------------------
402#include "implicit_f.inc"
403C-----------------------------------------------
404C D u m m y A r g u m e n t s
405C-----------------------------------------------
406 INTEGER NDDL ,NNZ ,IADL(*) ,JDIL(*)
407C REAL
408 my_real
409 . DIAG_K(*), W(*), LT_K(*) ,V(*)
410C-----------------------------------------------
411C L o c a l V a r i a b l e s
412C-----------------------------------------------
413 INTEGER I,J,K
414 my_real
415 . l_k
416C-----------------------------
417 DO i=1,nddl
418 w(i)=diag_k(i)*v(i)
419 ENDDO
420C
421 DO i=1,nddl
422 DO j =iadl(i),iadl(i+1)-1
423 k =jdil(j)
424 l_k = lt_k(j)
425 w(i) = w(i) + l_k*v(k)
426 ENDDO
427 ENDDO
428C--------------------------------------------
429 RETURN
430 END
431C-------------produce {w}=[LT_K]{v}+[LT_I]{v} using only upper-triangle----
432!||====================================================================
433!|| mav_lt2 ../engine/source/implicit/produt_v.F
434!||--- calls -----------------------------------------------------
435!|| int_matv ../engine/source/implicit/imp_int_k.F
436!|| matv_kif ../engine/source/implicit/imp_solv.F
437!|| mv_matv ../engine/source/airbag/monv_imp0.F
438!||--- uses -----------------------------------------------------
439!|| groupdef_mod ../common_source/modules/groupdef_mod.F
440!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
441!||====================================================================
442 SUBROUTINE mav_lt2(
443 1 NDDL ,NDDLI ,IADL ,JDIL ,DIAG_K,
444 2 LT_K ,IADI ,JDII ,ITOK ,LT_I ,
445 3 V ,W ,MONVOL,VOLMON,X ,
446 4 IGRSURF,NMONV ,IMONV,NDOF ,
447 5 IPARI ,INTBUF_TAB ,A ,AR ,
448 6 D ,IBFV ,SKEW ,XFRAME,VE ,
449 7 MS ,NUM_IMP,NS_IMP,NE_IMP,INDEX2,
450 8 XI_C ,IUPD ,IRBE3 ,LRBE3 )
451C-----------------------------------------------
452C M o d u l e s
453C-----------------------------------------------
454 USE intbufdef_mod
455 USE groupdef_mod
456C-----------------------------------------------
457C I m p l i c i t T y p e s
458C-----------------------------------------------
459#include "implicit_f.inc"
460C-----------------------------------------------
461C C o m m o n B l o c k s
462C-----------------------------------------------
463#include "com04_c.inc"
464#include "impl1_c.inc"
465C-----------------------------------------------
466C D u m m y A r g u m e n t s
467C-----------------------------------------------
468 INTEGER NDDL ,NDDLI,IUPD,
469 . IADL(*),JDIL(*),IADI(*),JDII(*),ITOK(*)
470 INTEGER NMONV,IMONV(*),MONVOL(*),
471 . ipari(*) ,ndof(*),ibfv(*),
472 . num_imp(*),ns_imp(*) ,ne_imp(*),index2(*),
473 . irbe3(*) ,lrbe3(*)
474C REAL
475 my_real
476 . diag_k(*), w(*), lt_k(*) ,lt_i(*) ,v(*)
477 my_real
478 . x(3,*),a(3,*),ar(3,*), volmon(*) ,d(3,*),
479 . skew(*) ,xframe(*),ve(3,*),ms(*),xi_c(*)
480
481 TYPE(intbuf_struct_) INTBUF_TAB(*)
482 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
483C-----------------------------------------------
484C L o c a l V a r i a b l e s
485C-----------------------------------------------
486 INTEGER I,J,K,II,KK,IBID
487 my_real
488 . l_k
489C-----------------------------
490 DO i=1,nddl
491 w(i)=diag_k(i)*v(i)
492 ENDDO
493C
494 DO i=1,nddl
495 DO j =iadl(i),iadl(i+1)-1
496 k =jdil(j)
497 l_k = lt_k(j)
498 w(i) = w(i) + l_k*v(k)
499 w(k) = w(k) + l_k*v(i)
500 ENDDO
501 ENDDO
502C ------[K]{V}
503 IF (nddli>0.AND.intp_c<0 ) THEN
504 IF (ilintf>0) THEN
505 CALL int_matv(ipari ,intbuf_tab ,ndof ,num_imp,
506 1 ns_imp ,ne_imp ,index2 ,a ,ar ,
507 2 ve ,xi_c ,ms ,d ,ibfv ,
508 3 skew ,xframe ,v ,w ,iupd ,
509 4 irbe3 ,lrbe3 ,ibid ,ibid )
510 ELSE
511 CALL int_matv(ipari ,intbuf_tab ,ndof ,num_imp,
512 1 ns_imp ,ne_imp ,index2 ,a ,ar ,
513 2 ve ,x ,ms ,d ,ibfv ,
514 3 skew ,xframe ,v ,w ,iupd ,
515 4 irbe3 ,lrbe3 ,ibid ,ibid )
516 ENDIF
517 ELSE
518C ------LT_I
519 DO i=1,nddli
520 ii = itok(i)
521 DO j =iadi(i),iadi(i+1)-1
522 k =jdii(j)
523 kk = itok(k)
524 l_k = lt_i(j)
525 w(ii) = w(ii) + l_k*v(kk)
526 w(kk) = w(kk) + l_k*v(ii)
527 ENDDO
528 ENDDO
529 ENDIF
530 CALL matv_kif(v,w)
531 IF (nmonv>0) THEN
532 CALL mv_matv(monvol ,volmon ,x ,igrsurf,
533 1 ibid ,nmonv ,imonv ,v ,w ,
534 2 ndof ,ipari ,intbuf_tab ,a ,
535 3 ar ,d ,ibfv ,skew ,xframe ,
536 4 irbe3 ,lrbe3 ,ibid ,ibid )
537 ENDIF
538C--------------------------------------------
539 RETURN
540 END
541C------spmd----produce {w}=[LT_K]{v}+[LT_I]{v} using only upper-triangle----
542!||====================================================================
543!|| mav_ltp ../engine/source/implicit/produt_v.F
544!||--- called by ------------------------------------------------------
545!|| imp_lanzp ../engine/source/implicit/imp_lanz.f
546!||--- calls -----------------------------------------------------
547!|| fr_matv ../engine/source/mpi/implicit/imp_fri.F
548!|| int_matvp ../engine/source/implicit/imp_int_k.F
549!|| matv_kif ../engine/source/implicit/imp_solv.F
550!|| mv_matv ../engine/source/airbag/monv_imp0.F
551!|| spmd_sumf_v ../engine/source/mpi/implicit/imp_spmd.F
552!||--- uses -----------------------------------------------------
553!|| groupdef_mod ../common_source/modules/groupdef_mod.F
554!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
555!||====================================================================
556 SUBROUTINE mav_ltp(
557 1 NDDL ,NDDLI ,IADL ,JDIL ,DIAG_K,
558 2 LT_K ,IADI ,JDII ,ITOK ,LT_I ,
559 3 V ,W ,A ,AR ,VE ,
560 5 MS ,X ,D ,DR ,NDOF ,
561 6 IPARI ,INTBUF_TAB ,NUM_IMP,NS_IMP,
562 7 NE_IMP,NSREM ,NSL ,IBFV ,SKEW ,
563 8 XFRAME,MONVOL,VOLMON,IGRSURF,
564 9 FR_MV ,NMONV ,IMONV ,INDEX2 ,XI_C ,
565 A IUPD ,IRBE3 ,LRBE3 ,IRBE2 ,LRBE2 )
566C-----------------------------------------------
567C M o d u l e s
568C-----------------------------------------------
569 USE intbufdef_mod
570 USE groupdef_mod
571C-----------------------------------------------
572C I m p l i c i t T y p e s
573C-----------------------------------------------
574#include "implicit_f.inc"
575C-----------------------------------------------
576C C o m m o n B l o c k s
577C-----------------------------------------------
578#include "com01_c.inc"
579#include "com04_c.inc"
580#include "impl1_c.inc"
581C-----------------------------------------------
582C D u m m y A r g u m e n t s
583C-----------------------------------------------
584 INTEGER NDDL ,NDDLI,NDOF(*),IUPD,
585 . IADL(*),JDIL(*),IADI(*),JDII(*),ITOK(*),
586 . IPARI(*) ,NUM_IMP(*),NS_IMP(*) ,
587 . NE_IMP(*),NSREM ,NSL,IBFV(*),INDEX2(*),
588 . IRBE3(*) ,LRBE3(*),IRBE2(*) ,LRBE2(*)
589 INTEGER NMONV,IMONV(*),MONVOL(*),FR_MV(*)
590C REAL
591 my_real
592 . DIAG_K(*), W(*), LT_K(*) ,LT_I(*) ,V(*) ,
593 . A(3,*),AR(3,*),VE(3,*),D(3,*),DR(3,*),X(3,*),
594 . MS(*),VOLMON(*),SKEW(*),XFRAME(*),XI_C(*)
595
596 TYPE(intbuf_struct_) INTBUF_TAB(*)
597 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
598C-----------------------------------------------
599C L o c a l V a r i a b l e s
600C-----------------------------------------------
601 INTEGER I,J,K,II,KK,IBID
602 my_real
603 . L_K
604C-----------------------------
605 DO I=1,nddl
606 w(i)=diag_k(i)*v(i)
607 ENDDO
608C
609 DO i=1,nddl
610#include "vectorize.inc"
611 DO j =iadl(i),iadl(i+1)-1
612 k =jdil(j)
613 l_k = lt_k(j)
614 w(i) = w(i) + l_k*v(k)
615 w(k) = w(k) + l_k*v(i)
616 ENDDO
617 ENDDO
618C ------[K]{V}
619 IF ((nddli+nsrem+nsl)>0.AND.intp_c<0 ) THEN
620 IF (ilintf>0) THEN
621 CALL int_matvp(ipari ,intbuf_tab ,ndof ,num_imp,
622 1 ns_imp ,ne_imp ,index2 ,a ,ar ,
623 2 ve ,xi_c ,ms ,d ,ibfv ,
624 3 skew ,xframe ,v ,w ,dr ,
625 4 nsrem ,nsl ,iupd ,irbe3 ,lrbe3 ,
626 5 irbe2 ,lrbe2 )
627 ELSE
628 CALL int_matvp(ipari ,intbuf_tab ,ndof ,num_imp,
629 1 ns_imp ,ne_imp ,index2 ,a ,ar ,
630 2 ve ,x ,ms ,d ,ibfv ,
631 3 skew ,xframe ,v ,w ,dr ,
632 4 nsrem ,nsl ,iupd ,irbe3 ,lrbe3 ,
633 5 irbe2 ,lrbe2 )
634 ENDIF
635 ELSE
636C ------LT_I
637 DO i=1,nddli
638 ii = itok(i)
639#include "vectorize.inc"
640 DO j =iadi(i),iadi(i+1)-1
641 k =jdii(j)
642 kk = itok(k)
643 l_k = lt_i(j)
644 w(ii) = w(ii) + l_k*v(kk)
645 w(kk) = w(kk) + l_k*v(ii)
646 ENDDO
647 ENDDO
648 ENDIF
649 CALL matv_kif(v,w)
650 IF (nmonv>0) THEN
651 CALL mv_matv(monvol ,volmon ,x ,igrsurf,
652 1 fr_mv ,nmonv ,imonv ,v ,w ,
653 2 ndof ,ipari ,intbuf_tab ,a ,
654 3 ar ,d ,ibfv ,skew ,xframe ,
655 4 irbe3 ,lrbe3 ,irbe2 ,lrbe2 )
656 ENDIF
657C
658 IF (nspmd>1) THEN
659 IF ((nsrem+nsl)>0.AND.intp_c>=0)
660 . CALL fr_matv( a ,ve ,d ,ms ,x ,
661 1 dr ,ar ,ipari ,intbuf_tab ,
662 2 ndof ,num_imp,ns_imp,ne_imp,v ,
663 3 nsrem ,nsl ,ibfv ,skew ,xframe ,
664 4 w ,irbe3 ,lrbe3 ,irbe2 ,lrbe2 )
665 CALL spmd_sumf_v(w )
666 ENDIF
667C--------------------------------------------
668 RETURN
669 END
670C-------------produit {w}=[K]{v} with {v} non zero indices----
671!||====================================================================
672!|| mav_zi ../engine/source/implicit/produt_v.F
673!||====================================================================
674 SUBROUTINE mav_zi(II,NDDL ,NNZ ,IADL ,JDIL ,DIAG_K ,
675 1 LT_K ,NNZZ ,IADM ,JDIM , LT_M ,W )
676C-----------------------------------------------
677C I m p l i c i t T y p e s
678C-----------------------------------------------
679#include "implicit_f.inc"
680C-----------------------------------------------
681C D u m m y A r g u m e n t s
682C-----------------------------------------------
683 INTEGER NDDL ,NNZ ,IADL(*) ,JDIL(*),
684 1 II,NNZZ ,IADM(*) ,JDIM(*)
685C REAL
686 my_real
687 . diag_k(*), w(*), lt_k(*) ,lt_m(*)
688C-----------------------------------------------
689C L o c a l V a r i a b l e s
690C-----------------------------------------------
691C--- LT_M(NNZM) IADM(NNZZ) position in LT_M,JDIM(NNZZ) line in LT_M
692C-------implicitement v(nnzz+1)=1,jdim(nnzz+1)=ii----
693 INTEGER I,J,K,IZ,IM,JJ
694 my_real
695 . l_k
696C-----------------------------
697 DO i=1,nddl
698 w(i)=zero
699 ENDDO
700 DO i = 1,ii-1
701 DO j =iadl(i),iadl(i+1)-1
702 k =jdil(j)
703 IF (k==ii) THEN
704 w(i) = lt_k(j)
705 ENDIF
706 ENDDO
707 ENDDO
708 w(ii)=diag_k(ii)
709 DO j =iadl(ii),iadl(ii+1)-1
710 k =jdil(j)
711 w(k) = lt_k(j)
712 ENDDO
713C-------Kij Vj (j>i)---
714 DO iz=1,nnzz
715 i =jdim(iz)
716 im=iadm(iz)
717 w(i)=w(i)+diag_k(i)*lt_m(im)
718 DO j =iadl(i),iadl(i+1)-1
719 k =jdil(j)
720 l_k = lt_k(j)*lt_m(im)
721 w(k) = w(k) + l_k
722 ENDDO
723 ENDDO
724C-------Kij Vj (j<i)---
725 DO i = 1,ii-1
726 DO 100 iz=1,nnzz
727 jj =jdim(iz)
728 DO j =iadl(i),iadl(i+1)-1
729 k =jdil(j)
730 IF (k>jj) THEN
731 GOTO 100
732 ELSEIF (k==jj) THEN
733 im=iadm(iz)
734 w(i)=w(i)+lt_k(j)*lt_m(im)
735 ENDIF
736 ENDDO
737 100 CONTINUE
738 ENDDO
739C
740C--------------------------------------------
741 RETURN
742 END
743C-------------produit {w}=[K]{v} with {v}=LT_M(*,II) en format C.C.S.----
744!||====================================================================
745!|| mav_z ../engine/source/implicit/produt_v.F
746!||====================================================================
747 SUBROUTINE mav_z(II,NDDL ,NNZ ,IADL ,JDIL ,DIAG_K ,
748 1 LT_K ,NNZM ,IADM ,JDIM , LT_M ,W )
749C-----------------------------------------------
750C I m p l i c i t T y p e s
751C-----------------------------------------------
752#include "implicit_f.inc"
753C-----------------------------------------------
754C D u m m y A r g u m e n t s
755C-----------------------------------------------
756 INTEGER NDDL ,NNZ ,IADL(*) ,JDIL(*),
757 1 ii,nnzm ,iadm(*) ,jdim(*)
758C REAL
759 my_real
760 . diag_k(*), w(*), lt_k(*) ,lt_m(*)
761C-----------------------------------------------
762C L o c a l V a r i a b l e s
763C-----------------------------------------------
764C-------implicitement LT_M(II,II)=1----
765 INTEGER I,J,K,IM,IZ
766 my_real
767 . l_k
768C-----------------------------
769 DO i=1,nddl
770 w(i)=zero
771 ENDDO
772 DO i = 1,ii-1
773 DO j =iadl(i),iadl(i+1)-1
774 k =jdil(j)
775 IF (k==ii) THEN
776 w(i) = lt_k(j)
777 ENDIF
778 ENDDO
779 ENDDO
780 w(ii)=diag_k(ii)
781 DO j =iadl(ii),iadl(ii+1)-1
782 k =jdil(j)
783 w(k) = lt_k(j)
784 ENDDO
785C-------Kij Vj (j>i)---
786 DO im=iadm(ii),iadm(ii+1)-1
787 i =jdim(im)
788 w(i)=w(i)+diag_k(i)*lt_m(im)
789 DO j =iadl(i),iadl(i+1)-1
790 k =jdil(j)
791 l_k = lt_k(j)*lt_m(im)
792 w(k) = w(k) + l_k
793 ENDDO
794 ENDDO
795C-------Kij Vj (j<i)---
796 DO i = 1,ii-1
797 DO 100 im=iadm(ii),iadm(ii+1)-1
798 iz =jdim(im)
799 DO j =iadl(i),iadl(i+1)-1
800 k =jdil(j)
801 IF (k>iz) THEN
802 GOTO 100
803 ELSEIF (k==iz) THEN
804 w(i)=w(i)+lt_k(j)*lt_m(im)
805 ENDIF
806 ENDDO
807 100 CONTINUE
808 ENDDO
809C--------------------------------------------
810 RETURN
811 END
812!||====================================================================
813!|| buf_dim ../engine/source/implicit/produt_v.F
814!||--- called by ------------------------------------------------------
815!|| imp_cpre ../engine/source/implicit/imp_solv.F
816!||====================================================================
817 SUBROUTINE buf_dim( L1,L2,L3,L4)
818C-----------------------------------------------
819C I m p l i c i t T y p e s
820C-----------------------------------------------
821#include "implicit_f.inc"
822C-----------------------------------------------
823C C o m m o n B l o c k s
824C-----------------------------------------------
825#include "tabsiz_c.inc"
826C-----------------------------------------------
827C D u m m y A r g u m e n t s
828C-----------------------------------------------
829 INTEGER L1,L2,L3 ,L4
830C REAL
831C-----------------------------------------------
832C L o c a l V a r i a b l e s
833C-----------------------------------------------
834C----longueur de ELBUF,BUFMAT--------
835 l1=selbuf
836 l2=sbufmat
837 l3=sfsav
838 l4=svolmon
839C--------------------------------------------
840 RETURN
841 END
842!||====================================================================
843!|| cp_real ../engine/source/implicit/produt_v.F
844!||--- called by ------------------------------------------------------
845!|| clceig ../engine/source/constraints/general/bcs/bc_imp0.F
846!|| cp_ifront ../engine/source/implicit/produt_v.F
847!|| cp_impbuf ../engine/source/implicit/produt_v.F
848!|| d_to_u ../engine/source/implicit/produt_v.F
849!|| dis_cp ../engine/source/implicit/imp_solv.F
850!|| dyna_cpk0 ../engine/source/implicit/imp_dyna.F
851!|| dyna_cpr0 ../engine/source/implicit/imp_dyna.F
852!|| ext_rhs ../engine/source/implicit/upd_glob_k.F
853!|| imp_cpre ../engine/source/implicit/imp_solv.F
854!|| imp_frkm ../engine/source/mpi/implicit/imp_fri.F
855!|| imp_frks ../engine/source/mpi/implicit/imp_fri.F
856!|| imp_kfiltr ../engine/source/implicit/imp_fsa_inv.F
857!|| imp_restarcp ../engine/source/implicit/imp_sol_init.F
858!|| imp_sol_init ../engine/source/implicit/imp_sol_init.F
859!|| imprrest ../engine/source/output/restart/rdresb.F
860!|| ind_lt2ln ../engine/source/implicit/imp_fsa_inv.F
861!|| l2g_kloc ../engine/source/implicit/ind_glob_k.F
862!|| nl_solv ../engine/source/implicit/nl_solv.F
863!|| save_kif ../engine/source/implicit/imp_solv.F
864!|| tra_frkm ../engine/source/mpi/implicit/imp_fri.F
865!|| upd_aspc ../engine/source/constraints/general/bcs/bc_imp0.F
866!|| upd_int_k ../engine/source/implicit/upd_glob_k.F
867!|| upd_kml ../engine/source/mpi/implicit/imp_fri.F
868!|| upd_ksl ../engine/source/mpi/implicit/imp_fri.F
869!||====================================================================
870 SUBROUTINE cp_real( N ,X ,XC)
871C-----------------------------------------------
872C I m p l i c i t T y p e s
873C-----------------------------------------------
874#include "implicit_f.inc"
875C-----------------------------------------------
876C D u m m y A r g u m e n t s
877C-----------------------------------------------
878 INTEGER N
879C REAL
880 my_real
881 . X(*), XC(*)
882C-----------------------------------------------
883C L o c a l V a r i a b l e s
884C-----------------------------------------------
885 INTEGER I
886C-----------------------------
887 DO I=1,n
888 xc(i) = x(i)
889 ENDDO
890C--------------------------------------------
891 RETURN
892 END
893!||====================================================================
894!|| cp_int ../engine/source/implicit/produt_v.F
895!||--- called by ------------------------------------------------------
896!|| cp_iadd ../engine/source/mpi/implicit/imp_fri.F
897!|| cp_ifront ../engine/source/implicit/produt_v.F
898!|| cp_inttd ../engine/source/implicit/imp_int_k.f
899!|| cp_slnr ../engine/source/mpi/implicit/imp_fri.F
900!|| dim_ktot ../engine/source/implicit/ind_glob_k.F
901!|| dim_spa2 ../engine/source/implicit/ind_glob_k.F
902!|| dim_span ../engine/source/implicit/ind_glob_k.F
903!|| doub_nrs ../engine/source/mpi/implicit/imp_fri.F
904!|| dyna_cpk0 ../engine/source/implicit/imp_dyna.F
905!|| imp_frkm ../engine/source/mpi/implicit/imp_fri.F
906!|| imp_frks ../engine/source/mpi/implicit/imp_fri.F
907!|| imp_kfiltr ../engine/source/implicit/imp_fsa_inv.F
908!|| ind_lt2ln ../engine/source/implicit/imp_fsa_inv.F
909!|| ind_spa2 ../engine/source/implicit/ind_glob_k.F
910!|| ind_span ../engine/source/implicit/ind_glob_k.F
911!|| l2g_kloc ../engine/source/implicit/ind_glob_k.F
912!|| rmdim_imp ../engine/source/model/remesh/rm_imp0.F
913!|| save_kif ../engine/source/implicit/imp_solv.F
914!||====================================================================
915 SUBROUTINE cp_int( N ,X ,XC)
916C-----------------------------------------------
917C I m p l i c i t T y p e s
918C-----------------------------------------------
919#include "implicit_f.inc"
920C-----------------------------------------------
921C D u m m y A r g u m e n t s
922C-----------------------------------------------
923 INTEGER N ,X(*), XC(*)
924C REAL
925C-----------------------------------------------
926C L o c a l V a r i a b l e s
927C-----------------------------------------------
928 INTEGER I
929C-----------------------------
930 DO I=1,n
931 xc(i) = x(i)
932 ENDDO
933C--------------------------------------------
934 RETURN
935 END
936C---------------------r={x}^t{y}---
937!||====================================================================
938!|| produt_v0 ../engine/source/implicit/produt_v.F
939!||--- called by ------------------------------------------------------
940!|| imp_pcg1 ../engine/source/implicit/imp_fsa_inv.F
941!|| sms_pcg1 ../engine/source/ams/sms_fsa_inv.F
942!||====================================================================
943 SUBROUTINE produt_v0( NDDL ,X ,Y ,R)
944C-----------------------------------------------
945C I m p l i c i t T y p e s
946C-----------------------------------------------
947#include "implicit_f.inc"
948C-----------------------------------------------
949C D u m m y A r g u m e n t s
950C-----------------------------------------------
951 INTEGER NDDL
952C REAL
953 my_real
954 . X(*), Y(*) ,R
955C-----------------------------------------------
956C L o c a l V a r i a b l e s
957C-----------------------------------------------
958 INTEGER I
959C-----------------------------
960 r = zero
961 DO i=1,nddl
962 r = r + x(i)*y(i)
963 ENDDO
964C--------------------------------------------
965 RETURN
966 END
967!||====================================================================
968!|| buf_dim1 ../engine/source/implicit/produt_v.F
969!||--- called by ------------------------------------------------------
970!|| imp_sol_init ../engine/source/implicit/imp_sol_init.F
971!||====================================================================
972 SUBROUTINE buf_dim1( L1,LT)
973C-----------------------------------------------
974C I m p l i c i t T y p e s
975C-----------------------------------------------
976#include "implicit_f.inc"
977C-----------------------------------------------
978C C o m m o n B l o c k s
979C-----------------------------------------------
980#include "com04_c.inc"
981#include "param_c.inc"
982#include "tabsiz_c.inc"
983C-----------------------------------------------
984C D u m m y A r g u m e n t s
985C-----------------------------------------------
986 INTEGER L1,LT
987C REAL
988C-----------------------------------------------
989C L o c a l V a r i a b l e s
990C-----------------------------------------------
991 INTEGER L2,L3,L4,L5,L6
992C----longueur de ELBUF,BUFMAT--------
993 l1=selbuf
994 l2=sbufmat
995 l3=sfsav
996 l4=svolmon
997 l5=npsav*npart
998 lt = l2+l3+l4+l5
999C--------------------------------------------
1000 RETURN
1001 END
1002!||====================================================================
1003!|| cp_impbuf ../engine/source/implicit/produt_v.F
1004!||--- called by ------------------------------------------------------
1005!|| imp_solv ../engine/source/implicit/imp_solv.F
1006!||--- calls -----------------------------------------------------
1007!|| copy_elbuf ../engine/source/elements/elbuf/copy_elbuf.F
1008!|| copy_intbuf_tab ../common_source/interf/copy_intbuf_tab.F
1009!|| cp_ifront ../engine/source/implicit/produt_v.F
1010!|| cp_real ../engine/source/implicit/produt_v.F
1011!||--- uses -----------------------------------------------------
1012!|| elbufdef_mod ../common_source/modules/mat_elem/elbufdef_mod.F90
1013!|| imp_i7cp ../engine/share/modules/imp_intm.F
1014!|| imp_intbuf ../engine/share/modules/imp_mod_def.F90
1015!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
1016!||====================================================================
1017 SUBROUTINE cp_impbuf(
1018 . IFLAG ,ELBUF ,ELBUF_C ,BUFMAT ,BUFMAT_C ,
1019 . FSAV ,VOLMON ,PARTSAV ,INTBUF_TAB,
1020 . INTBUF_TAB_C ,IPARI ,ISLEN7 ,IRLEN7 ,
1021 . ISLEN11 ,IRLEN11 ,ISLEN17 ,IRLEN17 ,IRLEN7T ,
1022 . ISLEN7T ,IRLEN20 ,ISLEN20 ,IRLEN20T ,ISLEN20T,
1023 . IRLEN20E,ISLEN20E,NEWFRONT,ELBUF_TAB,ELBUF_IMP,
1024 . IPARG )
1025C-----------------------------------------------
1026C M o d u l e s
1027C-----------------------------------------------
1028 USE elbufdef_mod
1029 USE imp_intbuf
1030 USE imp_i7cp
1031 USE intbufdef_mod
1032C-----------------------------------------------
1033C I m p l i c i t T y p e s
1034C-----------------------------------------------
1035#include "implicit_f.inc"
1036C-----------------------------------------------
1037C C o m m o n B l o c k s
1038C-----------------------------------------------
1039#include "com01_c.inc"
1040#include "com04_c.inc"
1041#include "param_c.inc"
1042#include "tabsiz_c.inc"
1043#include "impl1_c.inc"
1044C-----------------------------------------------
1045C D u m m y A r g u m e n t s
1046C-----------------------------------------------
1047 INTEGER IFLAG, IPARI(NPARI,*),ISLEN7 ,IRLEN7 ,
1048 . ISLEN11,IRLEN11,ISLEN17 ,IRLEN17,IRLEN7T ,
1049 . ISLEN7T,IRLEN20,ISLEN20 ,IRLEN20T,ISLEN20T,
1050 . IRLEN20E,ISLEN20E,NEWFRONT(*),IPARG(NPARG,NGROUP)
1051C REAL
1052 my_real
1053 . elbuf(*) ,elbuf_c(*) ,bufmat(*) ,bufmat_c(*) ,
1054 . fsav(*) ,volmon(*) ,partsav(*)
1055 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP) :: ELBUF_TAB, ELBUF_IMP
1056
1057 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*), INTBUF_TAB_C(*)
1058C-----------------------------------------------
1059C L o c a l V a r i a b l e s
1060C-----------------------------------------------
1061 INTEGER LI1,LI2,LI3,LI4,LI5,LI6,LL,N,IAD,JD(50),JFI,
1062 . ITY,IGSTI,NREBOU
1063C--------------Iflag= 1->copy; 2 ->restore---------------
1064 li1=selbuf
1065 li2=sbufmat
1066 li3=sfsav
1067 li4=svolmon
1068 li5=npsav*npart
1069c LI6=SBUFIN
1070C------------BUF->BUF_C--------------------------------
1071 IF (iflag==1) THEN
1072 CALL copy_elbuf(elbuf_tab,elbuf_imp,iparg,ngroup)
1073 CALL cp_real(li1,elbuf,elbuf_c)
1074 CALL cp_real(li2,bufmat,bufmat_c)
1075 ll=li2+1
1076 CALL cp_real(li3,fsav,bufmat_c(ll))
1077 ll=ll+li3
1078 CALL cp_real(li4,volmon,bufmat_c(ll))
1079 ll=ll+li4
1080 CALL cp_real(li5,partsav,bufmat_c(ll))
1081 IF (ninter/=0.AND.iline/=1) THEN
1082C------for int24 + Istif=6
1083 DO n = 1,ninter
1084 ity =ipari(7,n)
1085 IF (ity==0) cycle
1086 igsti =ipari(34,n)
1087 IF (ity == 24.AND.igsti==6) THEN
1088 IF (ipari(53,n)<0) ipari(53,n)= iabs(ipari(53,n))
1089 END IF
1090 !integral copy of interface buffer structure
1091 !INTBUF_TAB -> INTBUF_TAB_C
1092 CALL copy_intbuf_tab(intbuf_tab(n), intbuf_tab_c(n) )
1093 END DO !N = 1,NINTER
1094
1095 CALL cp_ifront(iflag ,ipari ,islen7 ,irlen7 ,
1096 . islen11,irlen11,islen17 ,irlen17,irlen7t ,
1097 . islen7t,irlen20,islen20 ,irlen20t,islen20t,
1098 . irlen20e,islen20e,newfront)
1099 END IF
1100C------------BUF_C->BUF--------------------------------
1101 ELSEIF (iflag==2) THEN
1102 CALL copy_elbuf(elbuf_imp,elbuf_tab,iparg,ngroup)
1103 CALL cp_real(li1,elbuf_c,elbuf)
1104 CALL cp_real(li2,bufmat_c,bufmat)
1105 ll=li2+1
1106 CALL cp_real(li3,bufmat_c(ll),fsav)
1107 ll=ll+li3
1108 CALL cp_real(li4,bufmat_c(ll),volmon)
1109 ll=ll+li4
1110 CALL cp_real(li5,bufmat_c(ll),partsav)
1111 IF (ninter/=0.AND.iline/=1) THEN
1112C------for int24 + Istif=6
1113 DO n = 1,ninter
1114 ity =ipari(7,n)
1115 IF (ity==0) cycle
1116 igsti =ipari(34,n)
1117 nrebou=ipari(53,n)
1118 IF (ity==24.AND.igsti==6.AND.nrebou<0) THEN
1119C---------divergence removes the treatment , line-search doesn't change stif
1120 IF (imconv<-1) THEN
1121 ipari(53,n) = -nrebou
1122 ELSEIF (imconv>=0) THEN
1123 ll =2*ipari(5,n)
1124 CALL cp_real(ll,intbuf_tab(n)%STIF_OLD,intbuf_tab_cp(n)%STIF_OLD)
1125 END IF
1126 END IF
1127 !integral copy of interface buffer structure
1128 !INTBUF_TAB_C -> INTBUF_TAB
1129 CALL copy_intbuf_tab(intbuf_tab_c(n), intbuf_tab(n) )
1130 END DO !N = 1,NINTER
1131
1132C------for int24 + Istif=6 remote part is inside CP_IFRONT
1133 CALL cp_ifront(iflag ,ipari ,islen7 ,irlen7 ,
1134 . islen11,irlen11,islen17 ,irlen17,irlen7t ,
1135 . islen7t,irlen20,islen20 ,irlen20t,islen20t,
1136 . irlen20e,islen20e,newfront)
1137c CALL CP_INTBUF(BUFIN_C,INBUF_C ,BUFIN,INBUF ,IPARI )
1138 END IF
1139 ENDIF
1140C--------------------------------------------
1141 RETURN
1142 END
1143C-------------produce {w}=[K]{v} using only upper-triangle----
1144!||====================================================================
1145!|| mav_lt_h ../engine/source/implicit/produt_v.F
1146!||--- called by ------------------------------------------------------
1147!|| mav_lth0 ../engine/source/implicit/produt_v.F
1148!||--- calls -----------------------------------------------------
1149!|| my_barrier ../engine/source/system/machine.F
1150!||====================================================================
1151 SUBROUTINE mav_lt_h(NDDL ,
1152 1 F_DDL ,L_DDL ,IADL ,JDIL ,DIAG_K ,
1153 2 LT_K ,V ,W )
1154C-----------------------------------------------
1155C I m p l i c i t T y p e s
1156C-----------------------------------------------
1157#include "implicit_f.inc"
1158#include "comlock.inc"
1159C-----------------------------------------------
1160C D u m m y A r g u m e n t s
1161C-----------------------------------------------
1162 INTEGER F_DDL ,L_DDL ,IADL(*) ,JDIL(*),NDDL
1163C REAL
1164 my_real
1165 . diag_k(*), w(*), lt_k(*) ,v(*)
1166C-----------------------------------------------
1167C L o c a l V a r i a b l e s
1168C-----------------------------------------------
1169 INTEGER I,J,K,N
1170 my_real
1171 . l_k,w_tmp(nddl)
1172C----------------------------
1173 DO i=1,nddl
1174 w_tmp(i)=zero
1175 ENDDO
1176 DO i=f_ddl,l_ddl
1177 w(i)=diag_k(i)*v(i)
1178 ENDDO
1179C
1180 DO i=f_ddl,l_ddl
1181 DO j =iadl(i),iadl(i+1)-1
1182 k =jdil(j)
1183 l_k = lt_k(j)
1184 w(i) = w(i) + l_k*v(k)
1185 w_tmp(k) = w_tmp(k) + l_k*v(i)
1186 ENDDO
1187 ENDDO
1188C----------------------
1189 CALL my_barrier
1190C---------------------
1191#include "lockon.inc"
1192 DO i=1,nddl
1193 w(i) = w(i) + w_tmp(i)
1194 ENDDO
1195#include "lockoff.inc"
1196C--------------------------------------------
1197 RETURN
1198 END
1199C------Hybrid----produce {w}=[LT_K]{v}+[LT_I]{v} using only upper-triangle----
1200!||====================================================================
1201!|| mav_lth0 ../engine/source/implicit/produt_v.F
1202!||--- called by ------------------------------------------------------
1203!|| lin_solv ../engine/source/implicit/lin_solv.F
1204!||--- calls -----------------------------------------------------
1205!|| fr_matv ../engine/source/mpi/implicit/imp_fri.F
1206!|| int_matvp ../engine/source/implicit/imp_int_k.F
1207!|| matv_kif ../engine/source/implicit/imp_solv.F
1208!|| mav_lt_h ../engine/source/implicit/produt_v.F
1209!|| mv_matv ../engine/source/airbag/monv_imp0.F
1210!|| my_barrier ../engine/source/system/machine.F
1211!|| spmd_sumf_v ../engine/source/mpi/implicit/imp_spmd.F
1212!||--- uses -----------------------------------------------------
1213!|| groupdef_mod ../common_source/modules/groupdef_mod.F
1214!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
1215!||====================================================================
1216 SUBROUTINE mav_lth0(
1217 1 NDDL ,NDDLI ,IADL ,JDIL ,DIAG_K,
1218 2 LT_K ,IADI ,JDII ,ITOK ,LT_I ,
1219 3 V ,W ,A ,AR ,VE ,
1220 5 MS ,X ,D ,DR ,NDOF ,
1221 6 IPARI ,INTBUF_TAB ,NUM_IMP,NS_IMP,
1222 7 NE_IMP,NSREM ,NSL ,IBFV ,SKEW ,
1223 8 XFRAME,MONVOL,VOLMON,IGRSURF ,
1224 9 FR_MV ,NMONV ,IMONV ,INDEX2 ,XI_C ,
1225 A IUPD ,IRBE3 ,LRBE3 ,IRBE2 ,LRBE2 ,
1226 B F_DDL ,L_DDL ,ITASK )
1227C-----------------------------------------------
1228C M o d u l e s
1229C-----------------------------------------------
1230 USE intbufdef_mod
1231 USE groupdef_mod
1232C-----------------------------------------------
1233C I m p l i c i t T y p e s
1234C-----------------------------------------------
1235#include "implicit_f.inc"
1236#include "comlock.inc"
1237C-----------------------------------------------
1238C C o m m o n B l o c k s
1239C-----------------------------------------------
1240#include "com01_c.inc"
1241#include "com04_c.inc"
1242#include "impl1_c.inc"
1243#include "task_c.inc"
1244C-----------------------------------------------
1245C D u m m y A r g u m e n t s
1246C-----------------------------------------------
1247 INTEGER NDDL ,NDDLI,NDOF(*),IUPD,
1248 . IADL(*),JDIL(*),IADI(*),JDII(*),ITOK(*),
1249 . IPARI(*) ,NUM_IMP(*),NS_IMP(*) ,
1250 . NE_IMP(*),NSREM ,NSL,IBFV(*),INDEX2(*),
1251 . IRBE3(*),LRBE3(*),F_DDL ,L_DDL ,ITASK,
1252 . IRBE2(*),LRBE2(*)
1253 INTEGER NMONV,IMONV(*),MONVOL(*),FR_MV(*)
1254C REAL
1255 my_real
1256 . DIAG_K(*), W(*), LT_K(*) ,LT_I(*) ,V(*) ,
1257 . A(3,*),AR(3,*),VE(3,*),D(3,*),DR(3,*),X(3,*),
1258 . MS(*),VOLMON(*),SKEW(*),XFRAME(*),XI_C(*)
1259
1260 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
1261 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
1262C-----------------------------------------------
1263C L o c a l V a r i a b l e s
1264C-----------------------------------------------
1265 INTEGER I,J,K,II,KK,F_DDLI,L_DDLI
1266 my_real
1267 . L_K,WORK_II(NDDLI)
1268C-----------------------------
1269 CALL MAV_LT_H(NDDL ,
1270 1 F_DDL ,L_DDL ,IADL ,JDIL ,DIAG_K ,
1271 2 LT_K ,V ,W )
1272C----------------------
1273 CALL MY_BARRIER
1274C---------------------
1275C ------[K]{V}
1276 IF ((NDDLI+NSREM+NSL)>0.AND.INTP_C<0 ) THEN
1277C--------spmd only for the moment-------
1278 IF (itask==0) THEN
1279 IF (ilintf>0) THEN
1280 CALL int_matvp(ipari ,intbuf_tab ,ndof ,num_imp,
1281 1 ns_imp ,ne_imp ,index2 ,a ,ar ,
1282 2 ve ,xi_c ,ms ,d ,ibfv ,
1283 3 skew ,xframe ,v ,w ,dr ,
1284 4 nsrem ,nsl ,iupd ,irbe3 ,lrbe3 ,
1285 5 irbe2 ,lrbe2 )
1286 ELSE
1287 CALL int_matvp(ipari ,intbuf_tab ,ndof ,num_imp,
1288 1 ns_imp ,ne_imp ,index2 ,a ,ar ,
1289 2 ve ,x ,ms ,d ,ibfv ,
1290 3 skew ,xframe ,v ,w ,dr ,
1291 4 nsrem ,nsl ,iupd ,irbe3 ,lrbe3 ,
1292 5 irbe2 ,lrbe2 )
1293 ENDIF
1294 END IF !(ITASK==0) THEN
1295 ELSEIF(nddli>0) THEN
1296C ------LT_I //
1297 f_ddli=1+itask*nddli/nthread
1298 l_ddli=(itask+1)*nddli/nthread
1299C
1300 DO i=1,nddli
1301 work_ii(i) = zero
1302 ENDDO
1303C
1304 DO i=f_ddli,l_ddli
1305 ii = itok(i)
1306 DO j =iadi(i),iadi(i+1)-1
1307 k =jdii(j)
1308 kk = itok(k)
1309 l_k = lt_i(j)
1310 work_ii(i) = work_ii(i) + l_k*v(kk)
1311 work_ii(k) = work_ii(k) + l_k*v(ii)
1312 ENDDO
1313 ENDDO
1314C
1315#include "lockon.inc"
1316 DO i=1,nddli
1317 ii = itok(i)
1318 w(ii) = w(ii) + work_ii(i)
1319 ENDDO
1320#include "lockoff.inc"
1321C
1322 END IF !((NDDLI+NSREM+NSL)>0.AND.INTP_C<0 ) THEN
1323C----------------------
1324 CALL my_barrier
1325C---------------------
1326C
1327 IF (itask==0) THEN
1328 CALL matv_kif(v,w)
1329 IF (nmonv>0) THEN
1330 CALL mv_matv(monvol ,volmon ,x ,igrsurf,
1331 1 fr_mv ,nmonv ,imonv ,v ,w ,
1332 2 ndof ,ipari ,intbuf_tab ,a ,
1333 3 ar ,d ,ibfv ,skew ,xframe ,
1334 4 irbe3 ,lrbe3 ,irbe2 ,lrbe2 )
1335 ENDIF
1336C
1337 IF (nspmd>1) THEN
1338 IF ((nsrem+nsl)>0.AND.intp_c>=0)
1339 . CALL fr_matv( a ,ve ,d ,ms ,x ,
1340 1 dr ,ar ,ipari ,intbuf_tab ,
1341 2 ndof ,num_imp,ns_imp,ne_imp,v ,
1342 3 nsrem ,nsl ,ibfv ,skew ,xframe ,
1343 4 w ,irbe3 ,lrbe3 ,irbe2 ,lrbe2 )
1344 CALL spmd_sumf_v(w )
1345 ENDIF
1346 END IF !(ITASK==0) THEN
1347C--------------------------------------------
1348 RETURN
1349 END
1350C------Hybrid----produce {w}=[LT_K]{v}+[LT_I]{v} using only upper-triangle----
1351!||====================================================================
1352!|| mav_lth ../engine/source/implicit/produt_v.f
1353!||--- called by ------------------------------------------------------
1354!|| imp_pcgh ../engine/source/implicit/imp_pcg.F
1355!|| mmav_lth ../engine/source/implicit/produt_v.F
1356!||--- calls -----------------------------------------------------
1357!|| fr_matv ../engine/source/mpi/implicit/imp_fri.F
1358!|| int_matvp ../engine/source/implicit/imp_int_k.F
1359!|| matv_kif ../engine/source/implicit/imp_solv.F
1360!|| mav_liuh ../engine/source/implicit/produt_v.F
1361!|| mav_lu_h ../engine/source/implicit/produt_v.F
1362!|| mv_matv ../engine/source/airbag/monv_imp0.F
1363!|| my_barrier ../engine/source/system/machine.F
1364!|| spmd_sumf_v ../engine/source/mpi/implicit/imp_spmd.F
1365!||--- uses -----------------------------------------------------
1366!|| groupdef_mod ../common_source/modules/groupdef_mod.f
1367!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
1368!||====================================================================
1369 SUBROUTINE mav_lth(
1370 1 NDDL ,NDDLI ,IADL ,JDIL ,DIAG_K,
1371 2 LT_K ,IADI ,JDII ,ITOK ,LT_I ,
1372 3 V ,W ,A ,AR ,VE ,
1373 5 MS ,X ,D ,DR ,NDOF ,
1374 6 IPARI ,INTBUF_TAB ,NUM_IMP,NS_IMP,
1375 7 NE_IMP,NSREM ,NSL ,IBFV ,SKEW ,
1376 8 XFRAME,MONVOL,VOLMON,IGRSURF,
1377 9 FR_MV ,NMONV ,IMONV ,INDEX2 ,XI_C ,
1378 A IUPD ,IRBE3 ,LRBE3 ,IRBE2 ,LRBE2 ,
1379 B F_DDL ,L_DDL ,ITASK )
1380C-----------------------------------------------
1381C M o d u l e s
1382C-----------------------------------------------
1383 USE intbufdef_mod
1384 USE groupdef_mod
1385C-----------------------------------------------
1386C I m p l i c i t T y p e s
1387C-----------------------------------------------
1388#include "implicit_f.inc"
1389#include "comlock.inc"
1390C-----------------------------------------------
1391C C o m m o n B l o c k s
1392C-----------------------------------------------
1393#include "com01_c.inc"
1394#include "com04_c.inc"
1395#include "impl1_c.inc"
1396#include "task_c.inc"
1397#include "timeri_c.inc"
1398C-----------------------------------------------
1399C D u m m y A r g u m e n t s
1400C-----------------------------------------------
1401 INTEGER NDDL ,NDDLI,NDOF(*),IUPD,
1402 . iadl(*),jdil(*),iadi(*),jdii(*),itok(*),
1403 . ipari(*) ,num_imp(*),ns_imp(*) ,
1404 . ne_imp(*),nsrem ,nsl,ibfv(*),index2(*),
1405 . irbe3(*),lrbe3(*),f_ddl ,l_ddl ,itask,
1406 . irbe2(*),lrbe2(*)
1407 INTEGER NMONV,IMONV(*),MONVOL(*),FR_MV(*)
1408C REAL
1409 my_real
1410 . DIAG_K(*), W(*), LT_K(*) ,LT_I(*) ,V(*) ,
1411 . A(3,*),AR(3,*),VE(3,*),D(3,*),DR(3,*),X(3,*),
1412 . MS(*),VOLMON(*),SKEW(*),XFRAME(*),XI_C(*)
1413
1414 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
1415 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
1416C-----------------------------------------------
1417C L o c a l V a r i a b l e s
1418C-----------------------------------------------
1419 INTEGER I,J,K,II,KK,F_DDLI,L_DDLI
1420 my_real
1421 . L_K,WORK_II(NDDLI)
1422C-----------PCG_GP-----------
1423 CALL MAV_LU_H(NDDL ,
1424 1 F_DDL ,L_DDL ,IADL ,JDIL ,DIAG_K ,
1425 2 LT_K ,V ,W )
1426C----------------------
1427 CALL my_barrier
1428C---------------------
1429 IF ((nddli+nsrem+nsl)>0.AND.intp_c<0 ) THEN
1430C--------spmd only for the moment-------
1431 IF (itask==0) THEN
1432 IF (ilintf>0) THEN
1433 CALL int_matvp(ipari,intbuf_tab ,ndof ,num_imp,
1434 1 ns_imp ,ne_imp ,index2 ,a ,ar ,
1435 2 ve ,xi_c ,ms ,d ,ibfv ,
1436 3 skew ,xframe ,v ,w ,dr ,
1437 4 nsrem ,nsl ,iupd ,irbe3 ,lrbe3 ,
1438 5 irbe2 ,lrbe2 )
1439 ELSE
1440 CALL int_matvp(ipari,intbuf_tab ,ndof ,num_imp,
1441 1 ns_imp ,ne_imp ,index2 ,a ,ar ,
1442 2 ve ,x ,ms ,d ,ibfv ,
1443 3 skew ,xframe ,v ,w ,dr ,
1444 4 nsrem ,nsl ,iupd ,irbe3 ,lrbe3 ,
1445 5 irbe2 ,lrbe2 )
1446 ENDIF
1447 END IF !(ITASK==0) THEN
1448 ELSEIF(nddli>0) THEN
1449 f_ddli=1+itask*nddli/nthread
1450 l_ddli=(itask+1)*nddli/nthread
1451C
1452 IF (isolv > 7) THEN
1453 CALL mav_liuh(f_ddli ,l_ddli ,iadi ,jdii ,itok ,
1454 1 lt_i ,work_ii ,v ,w ,itask )
1455C CALL MAV_LUI_H(F_DDL ,L_DDL ,V ,W )
1456 ELSE
1457C ------LT_I //
1458 DO i=1,nddli
1459 work_ii(i) = zero
1460 ENDDO
1461C
1462 DO i=f_ddli,l_ddli
1463 ii = itok(i)
1464 DO j =iadi(i),iadi(i+1)-1
1465 k =jdii(j)
1466 kk = itok(k)
1467 l_k = lt_i(j)
1468 work_ii(i) = work_ii(i) + l_k*v(kk)
1469 work_ii(k) = work_ii(k) + l_k*v(ii)
1470 ENDDO
1471 ENDDO
1472C
1473#include "lockon.inc"
1474 DO i=1,nddli
1475 ii = itok(i)
1476 w(ii) = w(ii) + work_ii(i)
1477 ENDDO
1478#include "lockoff.inc"
1479 END IF !(ISOLV > 7) THEN
1480C
1481 END IF !((NDDLI+NSREM+NSL)>0.AND.INTP_C<0 ) THEN
1482C----------------------
1483 CALL my_barrier
1484C---------------------
1485C
1486 IF (itask==0) THEN
1487 CALL matv_kif(v,w)
1488 IF (nmonv>0) THEN
1489 CALL mv_matv(monvol ,volmon ,x ,igrsurf,
1490 1 fr_mv ,nmonv ,imonv ,v ,w ,
1491 2 ndof ,ipari ,intbuf_tab,a ,
1492 3 ar ,d ,ibfv ,skew ,xframe ,
1493 4 irbe3 ,lrbe3 ,irbe2 ,lrbe2 )
1494 ENDIF
1495C
1496 IF (nspmd>1) THEN
1497 IF ((nsrem+nsl)>0.AND.intp_c>=0)
1498 . CALL fr_matv( a ,ve ,d ,ms ,x ,
1499 1 dr ,ar ,ipari ,intbuf_tab ,
1500 2 ndof ,num_imp,ns_imp,ne_imp,v ,
1501 3 nsrem ,nsl ,ibfv ,skew ,xframe ,
1502 4 w ,irbe3 ,lrbe3 ,irbe2 ,lrbe2 )
1503! IF(IMONM > 0) CALL STARTIME(TIMERS,66)
1504 CALL spmd_sumf_v(w )
1505! IF(IMONM > 0) CALL STOPTIME(TIMERS,66)
1506 ENDIF
1507 END IF !(ITASK==0) THEN
1508C--------------------------------------------
1509 RETURN
1510 END
1511C-----------Hybrid {x}t{y}-.{Weight}--
1512!||====================================================================
1513!|| produt_h ../engine/source/implicit/produt_v.F
1514!||--- called by ------------------------------------------------------
1515!|| bfgs_h1 ../engine/source/implicit/imp_bfgs.F
1516!|| bfgs_h1p ../engine/source/implicit/imp_bfgs.F
1517!|| bfgs_rhdh ../engine/source/implicit/imp_bfgs.F
1518!|| imp_inisi ../engine/source/implicit/imp_pcg.F
1519!|| imp_pcgh ../engine/source/implicit/imp_pcg.F
1520!|| imp_ppcgh ../engine/source/implicit/imp_pcg.F
1521!|| imp_updv2 ../engine/source/implicit/imp_pcg.F
1522!|| mam_nm ../engine/source/implicit/produt_v.F
1523!|| mav_nm ../engine/source/implicit/produt_v.F
1524!|| mortho_gs ../engine/source/implicit/produt_v.F
1525!|| produt_uh ../engine/source/implicit/produt_v.F
1526!|| produt_uh2 ../engine/source/implicit/produt_v.F
1527!|| produt_vmh ../engine/source/implicit/produt_v.F
1528!||--- calls -----------------------------------------------------
1529!|| my_barrier ../engine/source/system/machine.F
1530!|| spmd_sum_s ../engine/source/mpi/implicit/imp_spmd.F
1531!||====================================================================
1532 SUBROUTINE produt_h(F_DDL ,L_DDL ,X ,Y ,W , R ,ITASK )
1533C-----------------------------------------------
1534C I m p l i c i t T y p e s
1535C-----------------------------------------------
1536#include "implicit_f.inc"
1537#include "comlock.inc"
1538C-----------------------------------------------
1539C G l o b a l P a r a m e t e r s
1540C-----------------------------------------------
1541#include "mvsiz_p.inc"
1542C-----------------------------------------------
1543C C o m m o n B l o c k s
1544C-----------------------------------------------
1545#include "param_c.inc"
1546#include "com01_c.inc"
1547#include "impl2_c.inc"
1548#include "timeri_c.inc"
1549C-----------------------------------------------
1550C D u m m y A r g u m e n t s
1551C-----------------------------------------------
1552 INTEGER F_DDL ,L_DDL ,W(*) ,ITASK
1553C REAL
1554 my_real
1555 . x(*), y(*) ,r
1556C-----------------------------------------------
1557C L o c a l V a r i a b l e s
1558C-----------------------------------------------
1559 INTEGER I ,N,J,NE
1560 my_real
1561 . rtmp(mvsiz),rl
1562C-----------------------------
1563 IF (itask==0) r_n2 = zero
1564C----------------------
1565 CALL my_barrier
1566C---------------------
1567 IF (nspmd == 1) THEN
1568 rl = zero
1569 DO n=f_ddl,l_ddl,nvsiz
1570 ne =min(l_ddl-n+1,nvsiz)
1571C
1572 DO i=1,ne
1573 j=n+i-1
1574 rtmp(i) = x(j)*y(j)
1575 ENDDO
1576 DO i=1,ne
1577 rl = rl + rtmp(i)
1578 ENDDO
1579 END DO
1580#include "lockon.inc"
1581 r_n2 = r_n2 + rl
1582#include "lockoff.inc"
1583C------------
1584 ELSE
1585C------------NSPMD>1--------
1586 rl = zero
1587 DO n=f_ddl,l_ddl,mvsiz
1588 ne =min(l_ddl-n+1,mvsiz)
1589C
1590 DO i=1,ne
1591 j=n+i-1
1592 rtmp(i) = x(j)*y(j)*w(j)
1593 ENDDO
1594 DO i=1,ne
1595 rl = rl + rtmp(i)
1596 ENDDO
1597 END DO
1598#include "lockon.inc"
1599 r_n2 = r_n2 + rl
1600#include "lockoff.inc"
1601C----------------------
1602 CALL my_barrier
1603C---------------------
1604 IF (itask==0) THEN
1605! IF(imonm > 0) CALL startime(timers,67)
1606 CALL spmd_sum_s(r_n2)
1607! IF(IMONM > 0) CALL STARTIME(TIMERS,67)
1608 END IF
1609C
1610 END IF !(NSPMD == 1) THEN
1611C----------------------
1612 CALL my_barrier
1613C---------------------
1614 r = r_n2
1615C----------------------
1616 CALL my_barrier
1617C---------------------
1618 RETURN
1619 END
1620C---------------------r={x}^t{y}--x comes from u(3,*)-
1621!||====================================================================
1622!|| produt_vmh ../engine/source/implicit/produt_v.F
1623!||--- calls -----------------------------------------------------
1624!|| d_to_u ../engine/source/implicit/produt_v.F
1625!|| my_barrier ../engine/source/system/machine.F
1626!|| produt_h ../engine/source/implicit/produt_v.F
1627!||--- uses -----------------------------------------------------
1628!|| imp_workh ../engine/share/modules/impbufdef_mod.f
1629!||====================================================================
1630 SUBROUTINE produt_vmh(NDDL0 ,NDDL ,IDDL ,NDOF ,IKC ,
1631 . DD ,DDR ,Y ,R ,W_IMP ,
1632 . F_DDL ,L_DDL ,ITASK )
1633C-----------------------------------------------
1634C M o d u l e s
1635C-----------------------------------------------
1636 USE imp_workh
1637C-----------------------------------------------
1638C I m p l i c i t T y p e s
1639C-----------------------------------------------
1640#include "implicit_f.inc"
1641C-----------------------------------------------
1642C D u m m y A r g u m e n t s
1643C-----------------------------------------------
1644 INTEGER NDDL,NDDL0,IDDL(*) ,NDOF(*) ,IKC(*) ,W_IMP(*) ,
1645 . f_ddl ,l_ddl ,itask
1646C REAL
1647 my_real
1648 . dd(*),ddr(*), y(*) ,r
1649C-----------------------------------------------
1650C L o c a l V a r i a b l e s
1651C-----------------------------------------------
1652 INTEGER I
1653C-----------------------------
1654 IF (itask == 0 ) THEN
1655 ALLOCATE(tmp_w1(nddl))
1656 CALL d_to_u(nddl0 ,nddl ,iddl ,ndof ,ikc ,
1657 . dd ,ddr ,tmp_w1 )
1658 END IF
1659C----------------------
1660 CALL my_barrier
1661C---------------------
1662 CALL produt_h(f_ddl,l_ddl,tmp_w1,y,w_imp,r,itask)
1663C----------------------
1664 CALL my_barrier
1665C---------------------
1666 IF (itask == 0 ) DEALLOCATE(tmp_w1)
1667C--------------------------------------------
1668 RETURN
1669 END
1670C-------------norm2={x}^t{x}--x comes from u(3,*)- Hybrid---
1671!||====================================================================
1672!|| produt_uh ../engine/source/implicit/produt_v.F
1673!||--- called by ------------------------------------------------------
1674!|| al_constrainth1 ../engine/source/implicit/nl_solv.F
1675!|| al_constrainth2 ../engine/source/implicit/nl_solv.F
1676!||--- calls -----------------------------------------------------
1677!|| condens_b ../engine/source/implicit/upd_glob_k.F
1678!|| imp_setb ../engine/source/implicit/imp_setb.F
1679!|| my_barrier ../engine/source/system/machine.F
1680!|| produt_h ../engine/source/implicit/produt_v.F
1681!||--- uses -----------------------------------------------------
1682!|| imp_workh ../engine/share/modules/impbufdef_mod.F
1683!||====================================================================
1684 SUBROUTINE produt_uh(NDDL0 ,NDDL ,IDDL ,NDOF ,IKC ,
1685 . DD ,DDR ,NORM2 ,W_IMP ,F_DDL ,
1686 . L_DDL ,ITASK )
1687C-----------------------------------------------
1688C M o d u l e s
1689C-----------------------------------------------
1690 USE imp_workh
1691C-----------------------------------------------
1692C I m p l i c i t T y p e s
1693C-----------------------------------------------
1694#include "implicit_f.inc"
1695C-----------------------------------------------
1696C D u m m y A r g u m e n t s
1697C-----------------------------------------------
1698 INTEGER NDDL,NDDL0,IDDL(*) ,NDOF(*) ,IKC(*),W_IMP(*) ,
1699 . F_DDL ,L_DDL ,ITASK
1700C REAL
1701 my_real
1702 . DD(*),DDR(*), NORM2
1703C-----------------------------------------------
1704C L o c a l V a r i a b l e s
1705C-----------------------------------------------
1706 INTEGER I
1707C-----------------------------
1708 IF (itask == 0 ) THEN
1709 ALLOCATE(tmp_w1(nddl0))
1710 CALL imp_setb(dd ,ddr ,iddl ,ndof ,tmp_w1)
1711 CALL condens_b(nddl0 ,ikc ,tmp_w1)
1712 END IF
1713C----------------------
1714 CALL my_barrier
1715C---------------------
1716 CALL produt_h(f_ddl,l_ddl,tmp_w1,tmp_w1,w_imp,norm2,itask)
1717C----------------------
1718 CALL my_barrier
1719C---------------------
1720 IF (itask == 0 ) DEALLOCATE(tmp_w1)
1721C--------------------------------------------
1722 RETURN
1723 END
1724C---------------------norm2={x}^t{y}--x,y come from D1(3,*),D2-- Hybrid
1725!||====================================================================
1726!|| produt_uh2 ../engine/source/implicit/produt_v.F
1727!||--- called by ------------------------------------------------------
1728!|| al_constrainth1 ../engine/source/implicit/nl_solv.F
1729!|| al_constrainth2 ../engine/source/implicit/nl_solv.F
1730!||--- calls -----------------------------------------------------
1731!|| condens_b ../engine/source/implicit/upd_glob_k.F
1732!|| imp_setb ../engine/source/implicit/imp_setb.F
1733!|| my_barrier ../engine/source/system/machine.F
1734!|| produt_h ../engine/source/implicit/produt_v.F
1735!||--- uses -----------------------------------------------------
1736!|| imp_workh ../engine/share/modules/impbufdef_mod.F
1737!||====================================================================
1738 SUBROUTINE produt_uh2(NDDL0 ,NDDL ,IDDL ,NDOF ,IKC ,
1739 . D1 ,D1R ,D2 ,D2R ,NORM2 ,
1740 . W_IMP ,F_DDL ,L_DDL ,ITASK )
1741C-----------------------------------------------
1742C M o d u l e s
1743C-----------------------------------------------
1744 USE imp_workh
1745C-----------------------------------------------
1746C I m p l i c i t T y p e s
1747C-----------------------------------------------
1748#include "implicit_f.inc"
1749C-----------------------------------------------
1750C D u m m y A r g u m e n t s
1751C-----------------------------------------------
1752 INTEGER NDDL,NDDL0,IDDL(*) ,NDOF(*) ,IKC(*),W_IMP(*),
1753 . f_ddl ,l_ddl ,itask
1754C REAL
1755 my_real
1756 . d1(*),d1r(*), d2(*),d2r(*), norm2
1757C-----------------------------------------------
1758C L o c a l V a r i a b l e s
1759C-----------------------------------------------
1760 INTEGER I
1761C-----------------------------
1762 IF (itask == 0 ) THEN
1763 ALLOCATE(tmp_w1(nddl0),tmp_w2(nddl0))
1764 CALL imp_setb(d1 ,d1r ,iddl ,ndof ,tmp_w1)
1765 CALL imp_setb(d2 ,d2r ,iddl ,ndof ,tmp_w2)
1766 CALL condens_b(nddl0 ,ikc ,tmp_w1)
1767 CALL condens_b(nddl0 ,ikc ,tmp_w2)
1768 END IF
1769C----------------------
1770 CALL my_barrier
1771C----------------------
1772 CALL produt_h(f_ddl,l_ddl,tmp_w1,tmp_w2,w_imp,norm2,itask)
1773C----------------------
1774 CALL my_barrier
1775C---------------------
1776 IF (itask == 0 ) DEALLOCATE(tmp_w1,tmp_w2)
1777C--------------------------------------------
1778 RETURN
1779 END
1780C-------------produit {w}=[K]{v} using [K] complete----
1781!||====================================================================
1782!|| mav_lu_h ../engine/source/implicit/produt_v.f
1783!||--- called by ------------------------------------------------------
1784!|| mav_ltgh ../engine/source/implicit/produt_v.F
1785!|| mav_lth ../engine/source/implicit/produt_v.F
1786!||--- uses -----------------------------------------------------
1787!|| imp_workh ../engine/share/modules/impbufdef_mod.F
1788!||====================================================================
1789 SUBROUTINE mav_lu_h(NDDL ,
1790 1 F_DDL ,L_DDL ,IADL ,JDIL ,DIAG_K ,
1791 2 LT_K ,V ,W )
1792C-----------------------------------------------
1793C M o d u l e s
1794C-----------------------------------------------
1795 USE imp_workh
1796C-----------------------------------------------
1797C I m p l i c i t T y p e s
1798C-----------------------------------------------
1799#include "implicit_f.inc"
1800C-----------------------------------------------
1801C D u m m y A r g u m e n t s
1802C-----------------------------------------------
1803 INTEGER F_DDL ,L_DDL ,IADL(*) ,JDIL(*),NDDL
1804C REAL
1805 my_real
1806 . DIAG_K(*), W(*), LT_K(*) ,V(*)
1807C-----------------------------------------------
1808C L o c a l V a r i a b l e s
1809C-----------------------------------------------
1810 INTEGER I,J,K,N
1811 my_real
1812 . L_K
1813C----------------------------
1814 DO I=f_ddl,l_ddl
1815 w(i)=diag_k(i)*v(i)
1816 ENDDO
1817C
1818 DO i=f_ddl,l_ddl
1819 DO j =iadl(i),iadl(i+1)-1
1820 k =jdil(j)
1821 l_k = lt_k(j)
1822 w(i) = w(i) + l_k*v(k)
1823 ENDDO
1824 ENDDO
1825C
1826 DO i=f_ddl,l_ddl
1827 DO j =iadk0(i),iadk0(i+1)-1
1828 k =jdik0(j)
1829 l_k = lt_k0(j)
1830 w(i) = w(i) + l_k*v(k)
1831 ENDDO
1832 ENDDO
1833C--------------------------------------------
1834 RETURN
1835 END
1836!||====================================================================
1837!|| cp_ifront ../engine/source/implicit/produt_v.F
1838!||--- called by ------------------------------------------------------
1839!|| cp_impbuf ../engine/source/implicit/produt_v.F
1840!||--- calls -----------------------------------------------------
1841!|| ancmsg ../engine/source/output/message/message.F
1842!|| arret ../engine/source/system/arret.F
1843!|| cp_int ../engine/source/implicit/produt_v.F
1844!|| cp_real ../engine/source/implicit/produt_v.F
1845!||--- uses -----------------------------------------------------
1846!|| imp_i7cp ../engine/share/modules/imp_intm.F
1847!|| message_mod ../engine/share/message_module/message_mod.F
1848!|| tri7box ../engine/share/modules/tri7box.F
1849!||====================================================================
1850 SUBROUTINE cp_ifront(IFLAG ,IPARI ,ISLEN7 ,IRLEN7 ,
1851 . ISLEN11,IRLEN11,ISLEN17 ,IRLEN17,IRLEN7T ,
1852 . ISLEN7T,IRLEN20,ISLEN20 ,IRLEN20T,ISLEN20T,
1853 . IRLEN20E,ISLEN20E,NEWFRONT)
1854C-----------------------------------------------
1855C M o d u l e s
1856C-----------------------------------------------
1857 USE tri7box
1858 USE imp_i7cp
1859 USE message_mod
1860C-----------------------------------------------
1861C I m p l i c i t T y p e s
1862C-----------------------------------------------
1863#include "implicit_f.inc"
1864C-----------------------------------------------
1865C C o m m o n B l o c k s
1866C-----------------------------------------------
1867#include "com01_c.inc"
1868#include "com04_c.inc"
1869#include "task_c.inc"
1870#include "param_c.inc"
1871#include "tabsiz_c.inc"
1872#include "impl1_c.inc"
1873#include "scr18_c.inc"
1874#include "parit_c.inc"
1875C-----------------------------------------------
1876C D u m m y A r g u m e n t s
1877C-----------------------------------------------
1878 INTEGER IFLAG ,IPARI(NPARI,*),ISLEN7 ,IRLEN7 ,
1879 . islen11,irlen11,islen17 ,irlen17,irlen7t ,
1880 . islen7t,irlen20,islen20 ,irlen20t,islen20t,
1881 . irlen20e,islen20e,newfront(*)
1882C REAL
1883C-----------------------------------------------
1884C L o c a l V a r i a b l e s
1885C-----------------------------------------------
1886 INTEGER N, LENS,LENR,INACTI,NSN,NMN,IERR,IID,RID,I,P,
1887 . igap,ityp,lens0,lenr0,intth,j,jfi,jd(50),ity,igsti,
1888 . nrebou
1889C--------------------------------------------
1890 IF(iflag==1) THEN
1891 IF(ALLOCATED(iparicp)) DEALLOCATE(iparicp)
1892 IF(ALLOCATED(iad_stifold)) DEALLOCATE(iad_stifold)
1893 ALLOCATE(iparicp(npari,ninter),iad_stifold(ninter),stat=ierr)
1894 DO i =1, ninter
1895 ity =ipari(7,i)
1896 igsti =ipari(34,i)
1897 iad_stifold(i)=1
1898C IF (ITY == 24.AND.IGSTI==6) THEN
1899C IAD_STIFOLD(I)=JD(32)
1900C END IF
1901 DO j =1, npari
1902 iparicp(j,i) = ipari(j,i)
1903 END DO
1904 END DO
1905 ELSE
1906 DO i =1, ninter
1907 ity =ipari(7,i)
1908 igsti =ipari(34,i)
1909 IF (ity == 24.AND.igsti==6) THEN
1910 iparicp(26,i) = ipari(26,i)
1911 iparicp(27,i) = ipari(27,i)
1912 iparicp(53,i) = ipari(53,i)
1913 END IF
1914 DO j =1, npari
1915 ipari(j,i) = iparicp(j,i)
1916 END DO
1917 END DO
1918 ENDIF !IF(IFLAG==1) THEN
1919C
1920 IF (nspmd<=1) RETURN
1921C
1922 IF(iflag==1) THEN
1923 lii7cp=0
1924 lri7cp=0
1925 IF(ninter/=0) THEN
1926C dim compute---
1927 DO i =1, ninter
1928 ityp = ipari(7,i)
1929 igap = ipari(21,i)
1930 inacti = ipari(22,i)
1931 intth = ipari(47,i)
1932 IF(ityp==7.OR.ityp==10.OR.ityp==11.OR.ityp==24)THEN
1933 lens = 0
1934 lenr = 0
1935 DO p = 1, nspmd
1936 lens = lens + nsnsi(i)%P(p)
1937 lenr = lenr + nsnfi(i)%P(p)
1938 END DO
1939 lii7cp=lii7cp+2*nspmd+2
1940 lii7cp=lii7cp+lens
1941C
1942 IF (lenr>0) THEN
1943 lii7cp=lii7cp+lenr
1944 IF(ityp==7.OR.ityp==10.OR.ityp==24) THEN
1945C-------------------ITAFI,KINFI
1946 lii7cp=lii7cp+2*lenr
1947 IF (intth > 0 ) lii7cp=lii7cp+lenr
1948C-------------------MSFI,STIFI
1949 lri7cp=lri7cp+2*lenr
1950 IF(igap/=0) lri7cp=lri7cp+lenr
1951C-------------------XFI,VFI
1952 lri7cp=lri7cp+6*lenr
1953 IF(iparit==0) THEN
1954C-------------------AFI,STNFI,VSCFI
1955 lri7cp=lri7cp+4*lenr*nthread
1956 IF(kdtint/=0)lri7cp=lri7cp+lenr*nthread
1957 IF(intth > 0 )lri7cp=lri7cp+2*lenr+2*lenr*nthread
1958 ELSE
1959C-----------------PARITON not yet with implicit----
1960 ENDIF
1961C----- IRTLM_FI,TIME_SFI,SECND_FRFI,PENE_OLDFI,STIF_OLDFI
1962 IF(ityp==24) THEN
1963 lii7cp=lii7cp+2*lenr
1964 lri7cp=lri7cp+lenr
1965 lri7cp=lri7cp+6*lenr
1966 lri7cp=lri7cp+5*lenr
1967 lri7cp=lri7cp+2*lenr
1968 END IF
1969 ELSEIF(ityp==11) THEN
1970C-------------------ITAFI
1971 lii7cp=lii7cp+2*lenr
1972C-------------------MASFI,STIFI
1973 lri7cp=lri7cp+3*lenr
1974 IF(igap/=0) lri7cp=lri7cp+lenr
1975 IF (intth > 0 ) lii7cp=lii7cp+lenr
1976C-------------------XFI,VFI
1977 lri7cp=lri7cp+12*lenr
1978 IF(inacti==5.OR.inacti==6)lri7cp=lri7cp+2*lenr
1979 IF(iparit==0) THEN
1980C-------------------AFI,STNFI,VSCFI,AREASFI,TEMPFI
1981 lri7cp=lri7cp+8*lenr*nthread
1982 IF(kdtint/=0)lri7cp=lri7cp+2*lenr*nthread
1983 IF(intth > 0 )lri7cp=lri7cp+3*lenr
1984 ELSE
1985C-----------------PARITON not yet with implicit----
1986 ENDIF
1987 ELSEIF(ityp==17)THEN
1988 END IF
1989 END IF
1990 ENDIF
1991 ENDDO
1992 END IF
1993 IF((lii7cp+lri7cp)==0) RETURN
1994 IF(ninter/=0) THEN
1995 IF(ALLOCATED(ii7cp)) DEALLOCATE(ii7cp)
1996 IF(ALLOCATED(ri7cp)) DEALLOCATE(ri7cp)
1997 IF(ALLOCATED(newfrcp)) DEALLOCATE(newfrcp)
1998 ALLOCATE(ii7cp(lii7cp),newfrcp(snewfront),stat=ierr)
1999 IF(lri7cp>0)ALLOCATE(ri7cp(lri7cp),stat=ierr)
2000C ----copy-to II7CP,RI7CP ---------------
2001 iid=1
2002 rid=1
2003 DO i =1, ninter
2004 ityp = ipari(7,i)
2005 igap = ipari(21,i)
2006 inacti = ipari(22,i)
2007 intth = ipari(47,i)
2008 IF(ityp==7.OR.ityp==10.OR.ityp==11.OR.ityp==24)THEN
2009 ii7cp(iid) = ipari(24,i)
2010 ii7cp(iid+1) = ipari(57,i)
2011 iid=iid+2
2012 CALL cp_int(nspmd,nsnsi(i)%P(1),ii7cp(iid))
2013 iid=iid+nspmd
2014 CALL cp_int(nspmd,nsnfi(i)%P(1),ii7cp(iid))
2015 iid=iid+nspmd
2016 lens = 0
2017 lenr = 0
2018 DO p = 1, nspmd
2019 lens = lens + nsnsi(i)%P(p)
2020 lenr = lenr + nsnfi(i)%P(p)
2021 END DO
2022 IF (lens>0)
2023 . CALL cp_int(lens,nsvsi(i)%P(1),ii7cp(iid))
2024 iid=iid+lens
2025C
2026 IF (lenr>0) THEN
2027 CALL cp_int(lenr,nsvfi(i)%P(1),ii7cp(iid))
2028 iid=iid+lenr
2029 IF(ityp==7.OR.ityp==10.OR.ityp==24) THEN
2030C-------------------ITAFI,KINFI
2031 CALL cp_int(lenr,itafi(i)%P(1),ii7cp(iid))
2032 iid=iid+lenr
2033 CALL cp_int(lenr,kinfi(i)%P(1),ii7cp(iid))
2034 iid=iid+lenr
2035 IF (intth > 0 ) THEN
2036 CALL cp_int(lenr,matsfi(i)%P(1),ii7cp(iid))
2037 iid=iid+lenr
2038 END IF
2039C-------------------MSFI,STIFI
2040 CALL cp_real(lenr,msfi(i)%P(1),ri7cp(rid))
2041 rid=rid+lenr
2042 CALL cp_real(lenr,stifi(i)%P(1),ri7cp(rid))
2043 rid=rid+lenr
2044 IF(igap/=0) THEN
2045 CALL cp_real(lenr,gapfi(i)%P(1),ri7cp(rid))
2046 rid=rid+lenr
2047 ENDIF
2048C-------------------XFI,VFI
2049 CALL cp_real(3*lenr,xfi(i)%P(1,1),ri7cp(rid))
2050 rid=rid+3*lenr
2051 CALL cp_real(3*lenr,vfi(i)%P(1,1),ri7cp(rid))
2052 rid=rid+3*lenr
2053 IF(iparit==0) THEN
2054C-------------------AFI,STNFI,VSCFI
2055 CALL cp_real(3*lenr*nthread,afi(i)%P(1,1),ri7cp(rid))
2056 rid=rid+3*lenr*nthread
2057 CALL cp_real(lenr*nthread,stnfi(i)%P(1),ri7cp(rid))
2058 rid=rid+lenr*nthread
2059 IF(kdtint/=0) THEN
2060 CALL cp_real(lenr*nthread,vscfi(i)%P(1),ri7cp(rid))
2061 rid=rid+lenr*nthread
2062 ENDIF
2063 IF(intth/=0) THEN
2064 CALL cp_real(lenr*nthread,fthefi(i)%P(1),ri7cp(rid))
2065 rid=rid+lenr*nthread
2066 CALL cp_real(lenr*nthread,condnfi(i)%P(1),ri7cp(rid))
2067 rid=rid+lenr*nthread
2068 CALL cp_real(lenr,tempfi(i)%P(1),ri7cp(rid))
2069 rid=rid+lenr
2070 CALL cp_real(lenr,areasfi(i)%P(1),ri7cp(rid))
2071 rid=rid+lenr
2072 ENDIF
2073 ELSE
2074C-----------------PARITON not yet with implicit----
2075 ENDIF
2076 IF(ityp==24) THEN
2077 CALL cp_int(2*lenr,irtlm_fi(i)%P(1,1),ii7cp(iid))
2078 iid=iid+2*lenr
2079 CALL cp_real(lenr,time_sfi(i)%P(1),ri7cp(rid))
2080 rid=rid+lenr
2081 CALL cp_real(6*lenr,secnd_frfi(i)%P(1,1),ri7cp(rid))
2082 rid=rid+6*lenr
2083 CALL cp_real(5*lenr,pene_oldfi(i)%P(1,1),ri7cp(rid))
2084 rid=rid+5*lenr
2085 CALL cp_real(2*lenr,stif_oldfi(i)%P(1,1),ri7cp(rid))
2086 rid=rid+2*lenr
2087 END IF
2088 ELSEIF(ityp==11) THEN
2089C-------------------ITAFI
2090 CALL cp_int(2*lenr,itafi(i)%P(1),ii7cp(iid))
2091 iid=iid+2*lenr
2092 IF (intth > 0 ) THEN
2093 CALL cp_int(lenr,matsfi(i)%P(1),ii7cp(iid))
2094 iid=iid+lenr
2095 END IF
2096C-------------------MSFI,STIFI
2097 CALL cp_real(2*lenr,msfi(i)%P(1),ri7cp(rid))
2098 rid=rid+2*lenr
2099 CALL cp_real(lenr,stifi(i)%P(1),ri7cp(rid))
2100 rid=rid+lenr
2101 IF(igap/=0) THEN
2102 CALL cp_real(lenr,gapfi(i)%P(1),ri7cp(rid))
2103 rid=rid+lenr
2104 ENDIF
2105C-------------------XFI,VFI
2106 CALL cp_real(6*lenr,xfi(i)%P(1,1),ri7cp(rid))
2107 rid=rid+6*lenr
2108 CALL cp_real(6*lenr,vfi(i)%P(1,1),ri7cp(rid))
2109 rid=rid+6*lenr
2110 IF(inacti==5.OR.inacti==6) THEN
2111 CALL cp_real(2*lenr,penfi(i)%P(1,1),ri7cp(rid))
2112 rid=rid+2*lenr
2113 ENDIF
2114 IF(iparit==0) THEN
2115C-------------------AFI,STNFI,VSCFI
2116 CALL cp_real(6*lenr*nthread,afi(i)%P(1,1),ri7cp(rid))
2117 rid=rid+6*lenr*nthread
2118 CALL cp_real(2*lenr*nthread,stnfi(i)%P(1),ri7cp(rid))
2119 rid=rid+2*lenr*nthread
2120 IF(kdtint/=0) THEN
2121 CALL cp_real(2*lenr*nthread,vscfi(i)%P(1),ri7cp(rid))
2122 rid=rid+2*lenr*nthread
2123 ENDIF
2124 IF(intth/=0) THEN
2125 CALL cp_real(lenr,fthefi(i)%P(1),ri7cp(rid))
2126 rid=rid+lenr
2127 CALL cp_real(lenr,tempfi(i)%P(1),ri7cp(rid))
2128 rid=rid+lenr
2129 CALL cp_real(lenr,areasfi(i)%P(1),ri7cp(rid))
2130 rid=rid+lenr
2131 ENDIF
2132 ELSE
2133C-----------------PARITON not yet with implicit----
2134 ENDIF
2135 ELSEIF(ityp==17)THEN
2136 END IF
2137 END IF !IF (LENR>0)
2138 ENDIF !IF(ITYP==7.OR.ITYP==10.OR.IT
2139 ENDDO
2140 lenscp(1)=islen7
2141 lenscp(2)=irlen7
2142 lenscp(3)=islen11
2143 lenscp(4)=irlen11
2144 lenscp(5)=islen17
2145 lenscp(6)=irlen17
2146 lenscp(7)=irlen7t
2147 lenscp(8)=islen7t
2148 lenscp(9)=irlen20
2149 lenscp(10)=islen20
2150 lenscp(11)=irlen20t
2151 lenscp(12)=islen20t
2152 lenscp(13)=irlen20e
2153 lenscp(14)=islen20e
2154 CALL cp_int(snewfront,newfront,newfrcp)
2155 IF (iid>(lii7cp+1).OR.rid>(lri7cp+1)) then
2156 CALL ancmsg(msgid=82,anmode=aninfo,
2157 . i1=iid,i2=lii7cp,i3=rid,i4=lri7cp)
2158 CALL arret(2)
2159 ENDIF
2160 END IF
2161 ELSE
2162 IF((lii7cp+lri7cp)==0) RETURN
2163 IF(ninter/=0) THEN
2164C ----copy- from II7CP,RI7CP -------------
2165 iid=1
2166 rid=1
2167 DO i =1, ninter
2168 ityp = ipari(7,i)
2169 igap = ipari(21,i)
2170 inacti = ipari(22,i)
2171 intth = ipari(47,i)
2172 nrebou=ipari(53,i)
2173 IF(ityp==7.OR.ityp==10.OR.ityp==11.OR.ityp==24)THEN
2174 ipari(24,i) = ii7cp(iid)
2175 ipari(57,i) = ii7cp(iid+1)
2176 iid=iid+2
2177 lenr0 = 0
2178 DO p = 1, nspmd
2179 lenr0 = lenr0 + nsnfi(i)%P(p)
2180 END DO
2181 CALL cp_int(nspmd,ii7cp(iid),nsnsi(i)%P(1))
2182 iid=iid+nspmd
2183 CALL cp_int(nspmd,ii7cp(iid),nsnfi(i)%P(1))
2184 iid=iid+nspmd
2185 lens = 0
2186 lenr = 0
2187 DO p = 1, nspmd
2188 lens = lens + nsnsi(i)%P(p)
2189 lenr = lenr + nsnfi(i)%P(p)
2190 END DO
2191 IF (lens>0) THEN
2192 IF(ASSOCIATED(nsvsi(i)%P)) DEALLOCATE(nsvsi(i)%P)
2193 ALLOCATE(nsvsi(i)%P(lens),stat=ierr)
2194 CALL cp_int(lens,ii7cp(iid),nsvsi(i)%P(1))
2195 iid=iid+lens
2196 ENDIF
2197C-----------------ALLOCATION cp from II7CP,RI7CP----------
2198 IF (lenr>0) THEN
2199 IF(ASSOCIATED(nsvfi(i)%P)) DEALLOCATE(nsvfi(i)%P)
2200 ALLOCATE(nsvfi(i)%P(lenr),stat=ierr)
2201 CALL cp_int(lenr,ii7cp(iid),nsvfi(i)%P(1))
2202 iid=iid+lenr
2203 IF(ityp==7.OR.ityp==10.OR.ityp==24) THEN
2204 IF(ASSOCIATED(itafi(i)%P)) DEALLOCATE(itafi(i)%P)
2205 ALLOCATE(itafi(i)%P(lenr),stat=ierr)
2206 CALL cp_int(lenr,ii7cp(iid),itafi(i)%P(1))
2207 iid=iid+lenr
2208 IF(ASSOCIATED(kinfi(i)%P)) DEALLOCATE(kinfi(i)%P)
2209 ALLOCATE(kinfi(i)%P(lenr),stat=ierr)
2210 CALL cp_int(lenr,ii7cp(iid),kinfi(i)%P(1))
2211 iid=iid+lenr
2212 IF(intth > 0 ) THEN
2213 IF(ASSOCIATED(matsfi(i)%P)) DEALLOCATE(matsfi(i)%P)
2214 ALLOCATE(matsfi(i)%P(lenr),stat=ierr)
2215 CALL cp_int(lenr,ii7cp(iid),matsfi(i)%P(1))
2216 iid=iid+lenr
2217 ENDIF
2218 IF(ASSOCIATED(msfi(i)%P)) DEALLOCATE(msfi(i)%P)
2219 ALLOCATE(msfi(i)%P(lenr),stat=ierr)
2220 CALL cp_real(lenr,ri7cp(rid),msfi(i)%P(1))
2221 rid=rid+lenr
2222 IF(ASSOCIATED(stifi(i)%P)) DEALLOCATE(stifi(i)%P)
2223 ALLOCATE(stifi(i)%P(lenr),stat=ierr)
2224 CALL cp_real(lenr,ri7cp(rid),stifi(i)%P(1))
2225 rid=rid+lenr
2226 IF(igap/=0) THEN
2227 IF(ASSOCIATED(gapfi(i)%P)) DEALLOCATE(gapfi(i)%P)
2228 ALLOCATE(gapfi(i)%P(lenr),stat=ierr)
2229 CALL cp_real(lenr,ri7cp(rid),gapfi(i)%P(1))
2230 rid=rid+lenr
2231 ENDIF
2232 IF(ASSOCIATED(xfi(i)%P)) DEALLOCATE(xfi(i)%P)
2233 ALLOCATE(xfi(i)%P(3,lenr),stat=ierr)
2234 CALL cp_real(3*lenr,ri7cp(rid),xfi(i)%P(1,1))
2235 rid=rid+3*lenr
2236 IF(ASSOCIATED(vfi(i)%P)) DEALLOCATE(vfi(i)%P)
2237 ALLOCATE(vfi(i)%P(3,lenr),stat=ierr)
2238 CALL cp_real(3*lenr,ri7cp(rid),vfi(i)%P(1,1))
2239 rid=rid+3*lenr
2240 IF(iparit==0) THEN
2241 IF(ASSOCIATED(afi(i)%P)) DEALLOCATE(afi(i)%P)
2242 ALLOCATE(afi(i)%P(3,lenr*nthread),stat=ierr)
2243 CALL cp_real(3*lenr*nthread,ri7cp(rid),afi(i)%P(1,1))
2244 rid=rid+3*lenr*nthread
2245 IF(ASSOCIATED(stnfi(i)%P)) DEALLOCATE(stnfi(i)%P)
2246 ALLOCATE(stnfi(i)%P(lenr*nthread),stat=ierr)
2247 CALL cp_real(lenr*nthread,ri7cp(rid),stnfi(i)%P(1))
2248 rid=rid+lenr*nthread
2249 nlskyfi(i)=lenr
2250 IF(kdtint/=0)THEN
2251 IF(ASSOCIATED(vscfi(i)%P)) DEALLOCATE(vscfi(i)%P)
2252 ALLOCATE(vscfi(i)%P(lenr),stat=ierr)
2253 CALL cp_real(lenr*nthread,ri7cp(rid),vscfi(i)%P(1))
2254 rid=rid+lenr*nthread
2255 ENDIF
2256 IF(intth > 0 )THEN
2257C
2258 IF(ASSOCIATED(fthefi(i)%P)) DEALLOCATE(fthefi(i)%P)
2259 ALLOCATE(fthefi(i)%P(lenr*nthread),stat=ierr)
2260 CALL cp_real(lenr*nthread,ri7cp(rid),fthefi(i)%P(1))
2261 rid=rid+lenr*nthread
2262C
2263 IF(ASSOCIATED(condnfi(i)%P)) DEALLOCATE(condnfi(i)%P)
2264 ALLOCATE(condnfi(i)%P(lenr*nthread),stat=ierr)
2265 CALL cp_real(lenr*nthread,ri7cp(rid),condnfi(i)%P(1))
2266 rid=rid+lenr*nthread
2267C
2268 IF(ASSOCIATED(tempfi(i)%P)) DEALLOCATE(tempfi(i)%P)
2269 ALLOCATE(tempfi(i)%P(lenr),stat=ierr)
2270 CALL cp_real(lenr,ri7cp(rid),tempfi(i)%P(1))
2271 rid=rid+lenr
2272C
2273 IF(ASSOCIATED(areasfi(i)%P))DEALLOCATE(areasfi(i)%P)
2274 ALLOCATE(areasfi(i)%P(lenr),stat=ierr)
2275 CALL cp_real(lenr,ri7cp(rid),areasfi(i)%P(1))
2276 rid=rid+lenr
2277 ENDIF
2278 ELSE
2279C-----------------PARITON not yet with implicit----
2280 ENDIF
2281 IF(ityp==24) THEN
2282 IF(ASSOCIATED(irtlm_fi(i)%P))DEALLOCATE(irtlm_fi(i)%P)
2283 ALLOCATE(irtlm_fi(i)%P(2,lenr),stat=ierr)
2284 CALL cp_int(2*lenr,ii7cp(iid),irtlm_fi(i)%P(1,1))
2285 iid=iid+2*lenr
2286 IF(ASSOCIATED(time_sfi(i)%P))DEALLOCATE(time_sfi(i)%P)
2287 ALLOCATE(time_sfi(i)%P(lenr),stat=ierr)
2288 CALL cp_real(lenr,ri7cp(rid),time_sfi(i)%P(1))
2289 rid=rid+lenr
2290 IF(ASSOCIATED(secnd_frfi(i)%P))
2291 + DEALLOCATE(secnd_frfi(i)%P)
2292 ALLOCATE(secnd_frfi(i)%P(6,lenr),stat=ierr)
2293 CALL cp_real(6*lenr,ri7cp(rid),secnd_frfi(i)%P(1,1))
2294 rid=rid+6*lenr
2295 IF(ASSOCIATED(pene_oldfi(i)%P))
2296 + DEALLOCATE(pene_oldfi(i)%P)
2297 ALLOCATE(pene_oldfi(i)%P(5,lenr),stat=ierr)
2298 CALL cp_real(5*lenr,ri7cp(rid),pene_oldfi(i)%P(1,1))
2299 rid=rid+5*lenr
2300 IF (nrebou <0.AND.imconv>=0) THEN
2301 CALL cp_real(2*lenr,stif_oldfi(i)%P(1,1),ri7cp(rid))
2302 ELSE
2303 IF(ASSOCIATED(stif_oldfi(i)%P))
2304 + DEALLOCATE(stif_oldfi(i)%P)
2305 ALLOCATE(stif_oldfi(i)%P(2,lenr),stat=ierr)
2306 CALL cp_real(2*lenr,ri7cp(rid),stif_oldfi(i)%P(1,1))
2307 END IF !(NREBOU <0.AND.IMCONV>=0) THEN
2308 rid=rid+2*lenr
2309 END IF
2310 ELSEIF(ityp==11) THEN
2311C
2312 IF(ASSOCIATED(itafi(i)%P)) DEALLOCATE(itafi(i)%P)
2313 ALLOCATE(itafi(i)%P(2*lenr),stat=ierr)
2314 CALL cp_int(2*lenr,ii7cp(iid),itafi(i)%P(1))
2315 iid=iid+2*lenr
2316 IF(intth > 0 ) THEN
2317 IF(ASSOCIATED(matsfi(i)%P)) DEALLOCATE(matsfi(i)%P)
2318 ALLOCATE(matsfi(i)%P(lenr),stat=ierr)
2319 CALL cp_int(lenr,ii7cp(iid),matsfi(i)%P(1))
2320 iid=iid+lenr
2321 ENDIF
2322 IF(ASSOCIATED(msfi(i)%P)) DEALLOCATE(msfi(i)%P)
2323 ALLOCATE(msfi(i)%P(2*lenr),stat=ierr)
2324 CALL cp_real(2*lenr,ri7cp(rid),msfi(i)%P(1))
2325 rid=rid+2*lenr
2326 IF(ASSOCIATED(stifi(i)%P)) DEALLOCATE(stifi(i)%P)
2327 ALLOCATE(stifi(i)%P(lenr),stat=ierr)
2328 CALL cp_real(lenr,ri7cp(rid),stifi(i)%P(1))
2329 rid=rid+lenr
2330 IF(igap/=0) THEN
2331 IF(ASSOCIATED(gapfi(i)%P)) DEALLOCATE(gapfi(i)%P)
2332 ALLOCATE(gapfi(i)%P(lenr),stat=ierr)
2333 CALL cp_real(lenr,ri7cp(rid),gapfi(i)%P(1))
2334 rid=rid+lenr
2335 ENDIF
2336 IF(ASSOCIATED(xfi(i)%P)) DEALLOCATE(xfi(i)%P)
2337 ALLOCATE(xfi(i)%P(3,2*lenr),stat=ierr)
2338 CALL cp_real(6*lenr,ri7cp(rid),xfi(i)%P(1,1))
2339 rid=rid+6*lenr
2340 IF(ASSOCIATED(vfi(i)%P)) DEALLOCATE(vfi(i)%P)
2341 ALLOCATE(vfi(i)%P(3,2*lenr),stat=ierr)
2342 CALL cp_real(6*lenr,ri7cp(rid),vfi(i)%P(1,1))
2343 rid=rid+6*lenr
2344 IF(inacti==5.OR.inacti==6) THEN
2345 IF(ASSOCIATED(penfi(i)%P)) DEALLOCATE(penfi(i)%P)
2346 ALLOCATE(penfi(i)%P(2,lenr),stat=ierr)
2347 CALL cp_real(2*lenr,ri7cp(rid),penfi(i)%P(1,1))
2348 rid=rid+2*lenr
2349 END IF
2350 IF(iparit==0) THEN
2351
2352 IF(ASSOCIATED(afi(i)%P)) DEALLOCATE(afi(i)%P)
2353 ALLOCATE(afi(i)%P(3,2*lenr*nthread),stat=ierr)
2354 CALL cp_real(6*lenr*nthread,ri7cp(rid),afi(i)%P(1,1))
2355 rid=rid+6*lenr*nthread
2356
2357 IF(ASSOCIATED(stnfi(i)%P)) DEALLOCATE(stnfi(i)%P)
2358 ALLOCATE(stnfi(i)%P(2*lenr*nthread),stat=ierr)
2359 CALL cp_real(2*lenr*nthread,ri7cp(rid),stnfi(i)%P(1))
2360 rid=rid+2*lenr
2361
2362 IF(kdtint/=0)THEN
2363 IF(ASSOCIATED(vscfi(i)%P)) DEALLOCATE(vscfi(i)%P)
2364 ALLOCATE(vscfi(i)%P(2*lenr),stat=ierr)
2365 CALL cp_real(2*lenr*nthread,ri7cp(rid),vscfi(i)%P(1))
2366 rid=rid+2*lenr*nthread
2367 ENDIF
2368 IF(intth > 0 )THEN
2369 IF(ASSOCIATED(fthefi(i)%P)) DEALLOCATE(fthefi(i)%P)
2370 ALLOCATE(fthefi(i)%P(lenr),stat=ierr)
2371 CALL cp_real(lenr,ri7cp(rid),fthefi(i)%P(1))
2372 rid=rid+lenr
2373 IF(ASSOCIATED(tempfi(i)%P)) DEALLOCATE(tempfi(i)%P)
2374 ALLOCATE(tempfi(i)%P(lenr),stat=ierr)
2375 CALL cp_real(lenr,ri7cp(rid),tempfi(i)%P(1))
2376 rid=rid+lenr
2377 IF(ASSOCIATED(areasfi(i)%P))DEALLOCATE(areasfi(i)%P)
2378 ALLOCATE(areasfi(i)%P(lenr),stat=ierr)
2379 CALL cp_real(lenr,ri7cp(rid),areasfi(i)%P(1))
2380 rid=rid+lenr
2381 ENDIF
2382 nlskyfi(i)=lenr*2
2383 ELSE
2384C-----------------PARITON not yet with implicit----
2385 ENDIF
2386 ELSEIF(ityp==17)THEN
2387 ENDIF !IF(ITYP==7.OR.ITYP==10)
2388 ENDIF !IF (LENR.GT0)
2389 ENDIF
2390 ENDDO
2391 islen7 = lenscp(1)
2392 irlen7 = lenscp(2)
2393 islen11= lenscp(3)
2394 irlen11= lenscp(4)
2395 islen17= lenscp(5)
2396 irlen17= lenscp(6)
2397 irlen7t= lenscp(7)
2398 islen7t= lenscp(8)
2399 irlen20= lenscp(9)
2400 islen20= lenscp(10)
2401 irlen20t=lenscp(11)
2402 islen20t=lenscp(12)
2403 irlen20e=lenscp(13)
2404 islen20e=lenscp(14)
2405 CALL cp_int(snewfront,newfrcp,newfront)
2406 IF (iid>(lii7cp+1).OR.rid>(lri7cp+1)) then
2407 CALL ancmsg(msgid=82,anmode=aninfo,
2408 . i1=iid,i2=lii7cp,i3=rid,i4=lri7cp)
2409 CALL arret(2)
2410 ENDIF
2411 END IF !IF(NINTER/=0) THEN
2412 ENDIF !IF(IFLAG==1) THEN
2413C-----------------------------------------------------------------------
2414 RETURN
2415 END
2416C---------norm2={x}^t{x}--x comes from D(3,*)- including kinematic nodes
2417!||====================================================================
2418!|| produt_u0 ../engine/source/implicit/produt_v.F
2419!||--- calls -----------------------------------------------------
2420!|| spmd_sum_s ../engine/source/mpi/implicit/imp_spmd.F
2421!||====================================================================
2422 SUBROUTINE produt_u0(DD ,DDR ,NORM2 ,WEIGHT)
2423C-----------------------------------------------
2424C I m p l i c i t T y p e s
2425C-----------------------------------------------
2426#include "implicit_f.inc"
2427C-----------------------------------------------
2428C C o m m o n B l o c k s
2429C-----------------------------------------------
2430#include "com01_c.inc"
2431#include "com04_c.inc"
2432C-----------------------------------------------
2433C D u m m y A r g u m e n t s
2434C-----------------------------------------------
2435 INTEGER WEIGHT(*)
2436C REAL
2437 my_real
2438 . dd(3,*),ddr(3,*), norm2
2439C-----------------------------------------------
2440C L o c a l V a r i a b l e s
2441C-----------------------------------------------
2442 INTEGER I
2443C-----------------------------
2444 norm2=zero
2445 DO i=1,numnod
2446 IF (weight(i)==1) THEN
2447 norm2 = norm2 + dd(1,i)*dd(1,i)
2448 norm2 = norm2 + dd(2,i)*dd(2,i)
2449 norm2 = norm2 + dd(3,i)*dd(3,i)
2450 END IF
2451 END DO
2452 IF (iroddl>0) THEN
2453 DO i=1,numnod
2454 IF (weight(i)==1) THEN
2455 norm2 = norm2 + ddr(1,i)*ddr(1,i)
2456 norm2 = norm2 + ddr(2,i)*ddr(2,i)
2457 norm2 = norm2 + ddr(3,i)*ddr(3,i)
2458 END IF
2459 END DO
2460 END IF
2461C
2462 IF (nspmd>1) THEN
2463 CALL spmd_sum_s(norm2)
2464 END IF
2465C--------------------------------------------
2466 RETURN
2467 END
2468C
2469C------Hybrid----produit {W}=[DIAG_K]{v}+[LT_K]{v}+[LT_K0]{v}+[KI0]{v}----
2470!||====================================================================
2471!|| mav_ltgh ../engine/source/implicit/produt_v.F
2472!||--- calls -----------------------------------------------------
2473!|| mav_lu_h ../engine/source/implicit/produt_v.F
2474!|| mav_lui_h ../engine/source/implicit/produt_v.F
2475!|| my_barrier ../engine/source/system/machine.F
2476!|| spmd_sumf_v ../engine/source/mpi/implicit/imp_spmd.f
2477!||====================================================================
2478 SUBROUTINE mav_ltgh(
2479 1 NDDL ,IADL ,JDIL ,DIAG_K,LT_K ,
2480 2 V ,W ,F_DDL ,L_DDL ,ITASK ,
2481 3 NDDLI )
2482C-----------------------------------------------
2483C I m p l i c i t T y p e s
2484C-----------------------------------------------
2485#include "implicit_f.inc"
2486C-----------------------------------------------
2487C C o m m o n B l o c k s
2488C-----------------------------------------------
2489#include "com01_c.inc"
2490C-----------------------------------------------
2491C D u m m y A r g u m e n t s
2492C-----------------------------------------------
2493 INTEGER NDDL ,IADL(*),JDIL(*),F_DDL ,L_DDL ,ITASK,
2494 . NDDLI
2495C REAL
2496 my_real
2497 . DIAG_K(*), W(*), LT_K(*) ,V(*)
2498C-----------------------------------------------
2499C L o c a l V a r i a b l e s
2500C-----------------------------------------------
2501 INTEGER I,J
2502C-----------------------------
2503 CALL MAV_LU_H(NDDL ,
2504 1 F_DDL ,L_DDL ,IADL ,JDIL ,DIAG_K ,
2505 2 LT_K ,V ,W )
2506 IF (nddli>0) CALL mav_lui_h(f_ddl ,l_ddl ,v ,w )
2507C----------------------
2508 CALL my_barrier
2509C---------------------
2510 IF (itask==0.AND.nspmd>1) CALL spmd_sumf_v(w )
2511C--------------------------------------------
2512 RETURN
2513 END
2514C-------------produit {w}=[K]{v} using [K] completebut w/o DIAG----
2515!||====================================================================
2516!|| mav_lui_h ../engine/source/implicit/produt_v.F
2517!||--- called by ------------------------------------------------------
2518!|| mav_ltgh ../engine/source/implicit/produt_v.F
2519!||--- uses -----------------------------------------------------
2520!|| imp_workh ../engine/share/modules/impbufdef_mod.F
2521!||====================================================================
2522 SUBROUTINE mav_lui_h(F_DDL ,L_DDL ,V ,W )
2523C-----------------------------------------------
2524C M o d u l e s
2525C-----------------------------------------------
2526 USE imp_workh
2527C-----------------------------------------------
2528C I m p l i c i t T y p e s
2529C-----------------------------------------------
2530#include "implicit_f.inc"
2531C-----------------------------------------------
2532C D u m m y A r g u m e n t s
2533C-----------------------------------------------
2534 INTEGER F_DDL ,L_DDL
2535C REAL
2536 my_real
2537 . w(*), v(*)
2538C-----------------------------------------------
2539C L o c a l V a r i a b l e s
2540C-----------------------------------------------
2541 INTEGER I,J,K
2542 my_real
2543 . L_K
2544C
2545 DO I=f_ddl,l_ddl
2546 DO j =iadi0(i),iadi0(i+1)-1
2547 k =jdii0(j)
2548 l_k = lt_i0(j)
2549 w(i) = w(i) + l_k*v(k)
2550 ENDDO
2551 ENDDO
2552C--------------------------------------------
2553 RETURN
2554 END
2555!||====================================================================
2556!|| cp_dm ../engine/source/implicit/produt_v.F
2557!||--- called by ------------------------------------------------------
2558!|| imp_restarcp ../engine/source/implicit/imp_sol_init.F
2559!|| imp_sol_init ../engine/source/implicit/imp_sol_init.F
2560!|| resol ../engine/source/engine/resol.F
2561!||====================================================================
2562 SUBROUTINE cp_dm(NUMGEO,GEO,IGEO,DMCP,IFLAG)
2563C-----------------------------------------------
2564C I m p l i c i t T y p e s
2565C-----------------------------------------------
2566#include "implicit_f.inc"
2567C-----------------------------------------------
2568C C o m m o n B l o c k s
2569C-----------------------------------------------
2570#include "param_c.inc"
2571C-----------------------------------------------
2572C D u m m y A r g u m e n t s
2573C-----------------------------------------------
2574 INTEGER NUMGEO,IGEO(NPROPGI,*),IFLAG
2575C REAL
2576 my_real
2577 . geo(npropg,*),dmcp(*)
2578C-----------------------------------------------
2579C L o c a l V a r i a b l e s
2580C-----------------------------------------------
2581 INTEGER I,IGTYP
2582C-----remove membraine material damping w/ implicit static-----
2583C-----IFLAG=1 > store dm to DMCP and put dm=zero ; IFLAG=2 reput dm
2584 IF (iflag == 1) THEN
2585 DO i=1,numgeo
2586 igtyp = igeo(11,i)
2587 IF(igtyp==1.OR.(igtyp>=9 .AND. igtyp<=11).OR.igtyp==16) THEN
2588 dmcp(i) = geo(16,i)
2589 geo(16,i) = em30
2590 ENDIF
2591 END DO
2592 ELSE
2593 DO i=1,numgeo
2594 igtyp = igeo(11,i)
2595 IF(igtyp==1.OR.(igtyp>=9 .AND. igtyp<=11).OR.igtyp==16) THEN
2596 geo(16,i) = dmcp(i)
2597 ENDIF
2598 END DO
2599 END IF
2600 RETURN
2601 END
2602!||====================================================================
2603!|| vscal_h ../engine/source/implicit/produt_v.F
2604!||--- called by ------------------------------------------------------
2605!|| mortho_gs ../engine/source/implicit/produt_v.F
2606!|| sms_mortho_gs ../engine/source/ams/sms_proj.F
2607!||====================================================================
2608 SUBROUTINE vscal_h(F_DDL ,L_DDL ,V ,S ,ITASK )
2609C-----------------------------------------------
2610C I m p l i c i t T y p e s
2611C-----------------------------------------------
2612#include "implicit_f.inc"
2613C-----------------------------------------------
2614C D u m m y A r g u m e n t s
2615C-----------------------------------------------
2616 INTEGER F_DDL,L_DDL ,ITASK
2617C REAL
2618 my_real
2619 . s, v(*)
2620C-----------------------------------------------
2621c PURPOSE: V(*)<-S*V(*)
2622c
2623c Note:
2624c ARGUMENTS: (I: input, O: output, IO: input * output, W: workspace)
2625c
2626c TYPE NAME FUNCTION
2627c I F_DDL,L_DDL,ITASK - dim. of V(F_DDL:L_DDL), of Itask (Thread id)
2628c IO V(*) - V(*) scaled for output
2629C-----------------------------------------------
2630C L o c a l V a r i a b l e s
2631C-----------------------------------------------
2632 INTEGER I
2633C-----------------------------
2634 DO i= f_ddl,l_ddl
2635 v(i) = s*v(i)
2636 END DO
2637C--------------------------------------------
2638 RETURN
2639 END
2640!||====================================================================
2641!|| vaxpy_h ../engine/source/implicit/produt_v.F
2642!||--- called by ------------------------------------------------------
2643!|| mortho_gs ../engine/source/implicit/produt_v.F
2644!|| sms_mortho_gs ../engine/source/ams/sms_proj.F
2645!||====================================================================
2646 SUBROUTINE vaxpy_h(F_DDL ,L_DDL ,A ,B ,S ,ITASK )
2647C-----------------------------------------------
2648C I m p l i c i t T y p e s
2649C-----------------------------------------------
2650#include "implicit_f.inc"
2651C-----------------------------------------------
2652C D u m m y A r g u m e n t s
2653C-----------------------------------------------
2654 INTEGER F_DDL,L_DDL ,ITASK
2655C REAL
2656 my_real
2657 . s, a(*),b(*)
2658C-----------------------------------------------
2659c PURPOSE: B(*)<- B(*)+S*A(*)
2660c
2661c Note:
2662c ARGUMENTS: (I: input, O: output, IO: input * output, W: workspace)
2663c
2664c TYPE NAME FUNCTION
2665c I F_DDL,L_DDL,ITASK - dim. of V(F_DDL:L_DDL), of Itask (Thread id)
2666c I A(*) - input vector
2667c IO B(*) - axpy for output
2668C-----------------------------------------------
2669C L o c a l V a r i a b l e s
2670C-----------------------------------------------
2671 INTEGER I
2672C-----------------------------
2673 DO i= f_ddl,l_ddl
2674 b(i) = b(i) + s*a(i)
2675 END DO
2676C--------------------------------------------
2677 RETURN
2678 END
2679!||====================================================================
2680!|| mortho_gs ../engine/source/implicit/produt_v.F
2681!||--- called by ------------------------------------------------------
2682!|| imp_inisi ../engine/source/implicit/imp_pcg.F
2683!|| imp_updst ../engine/source/implicit/imp_pcg.F
2684!||--- calls -----------------------------------------------------
2685!|| my_barrier ../engine/source/system/machine.F
2686!|| produt_h ../engine/source/implicit/produt_v.F
2687!|| vaxpy_h ../engine/source/implicit/produt_v.F
2688!|| vscal_h ../engine/source/implicit/produt_v.F
2689!||====================================================================
2690 SUBROUTINE mortho_gs(F_DDL ,L_DDL ,NDDL ,MD_F ,MD_L ,
2691 . A ,WDDL ,ITASK )
2692C-----------------------------------------------
2693C I m p l i c i t T y p e s
2694C-----------------------------------------------
2695#include "implicit_f.inc"
2696C-----------------------------------------------
2697C D u m m y A r g u m e n t s
2698C-----------------------------------------------
2699 INTEGER NDDL,MD_F,MD_L,F_DDL,L_DDL ,WDDL(*), ITASK
2700C REAL
2701 my_real
2702 . A(NDDL,*)
2703C-----------------------------------------------
2704c FUNCTION: stabilized Gram-Schmidt orthonormalization (from MD_F to MD_L)
2705c
2706c Note:
2707c ARGUMENTS: (I: input, O: output, IO: input * output, W: workspace)
2708c
2709c TYPE NAME FUNCTION
2710c I MD_F to MD_L - vectors to be orthonormalized dim. of A(*,MD) should be MD_L
2711c I F_DDL,L_DDL,ITASK - dim. of A(F_DDL:L_DDL,MD), of Itask (Thread id)
2712c I WDDL(*) - itag for each id(F_DDL,L_DDL) with subdomains
2713c IO A(NDDL,MD) - A(NDDL,MD) orthonormalized for output
2714C-----------------------------------------------
2715C L o c a l V a r i a b l e s
2716C-----------------------------------------------
2717 INTEGER I,J
2718 my_real
2719 . sii,sij,s,sjj
2720C-----------------------------
2721 DO j= md_f ,md_l
2722 DO i=1,j-1
2723 CALL produt_h(f_ddl ,l_ddl ,a(1,i) ,a(1,j) ,wddl, sij ,itask)
2724 s = -sij
2725 CALL vaxpy_h(f_ddl ,l_ddl ,a(1,i) ,a(1,j) ,s ,itask )
2726C----------------------
2727 CALL my_barrier
2728C---------------------
2729 END DO
2730 CALL produt_h(f_ddl ,l_ddl ,a(1,j) ,a(1,j) ,wddl, sjj ,itask)
2731 s= one/max(em20,sqrt(sjj))
2732 CALL vscal_h(f_ddl ,l_ddl ,a(1,j) ,s ,itask )
2733C----------------------
2734 CALL my_barrier
2735C---------------------
2736 END DO
2737C--------------------------------------------
2738 RETURN
2739 END
2740!||====================================================================
2741!|| mav_nm ../engine/source/implicit/produt_v.F
2742!||--- called by ------------------------------------------------------
2743!|| imp_inix ../engine/source/implicit/imp_pcg.F
2744!|| imp_pro_p ../engine/source/implicit/imp_pcg.F
2745!||--- calls -----------------------------------------------------
2746!|| produt_h ../engine/source/implicit/produt_v.F
2747!||====================================================================
2748 SUBROUTINE mav_nm(F_ND ,L_ND ,ND ,MD ,A ,B ,C ,WDDL,ITASK )
2749C-----------------------------------------------
2750C I m p l i c i t T y p e s
2751C-----------------------------------------------
2752#include "implicit_f.inc"
2753C-----------------------------------------------
2754C D u m m y A r g u m e n t s
2755C-----------------------------------------------
2756 INTEGER F_ND ,L_ND ,ND ,MD ,ITASK,WDDL(*)
2757C REAL
2758 my_real
2759 . A(ND,*), B(*), C(*)
2760C-----------------------------------------------
2761c FUNCTION: product {C}=[A]^t{B}
2762c
2763c Note:
2764c ARGUMENTS: (I: input, O: output, IO: input * output, W: workspace)
2765c
2766c TYPE NAME FUNCTION
2767c I ND,MD - Matrix dimension 2D
2768c I WDDL(*) - itag for each id of subdomains
2769c I F_ND,L_ND,ITASK - id in each ITASK:thread id (//)
2770c I A(ND,MN),B(ND) - right-hand vector
2771c O C(NM) - left-hand vector
2772C-----------------------------------------------
2773C L o c a l V a r i a b l e s
2774C-----------------------------------------------
2775 INTEGER I,J,K
2776C-----------------------------
2777 DO I=1,md
2778 CALL produt_h( f_nd ,l_nd ,a(1,i) ,b ,wddl ,c(i),itask)
2779 ENDDO
2780C--------------------------------------------
2781 RETURN
2782 END
2783!||====================================================================
2784!|| mav_mn ../engine/source/implicit/produt_v.F
2785!||--- called by ------------------------------------------------------
2786!|| imp_inix ../engine/source/implicit/imp_pcg.F
2787!|| imp_pro_p ../engine/source/implicit/imp_pcg.F
2788!||--- calls -----------------------------------------------------
2789!|| produt_v_loc ../engine/source/implicit/produt_v.F
2790!||====================================================================
2791 SUBROUTINE mav_mn(ND ,MD ,A ,B ,C ,ITASK )
2792C-----------------------------------------------
2793C I m p l i c i t T y p e s
2794C-----------------------------------------------
2795#include "implicit_f.inc"
2796C-----------------------------------------------
2797C D u m m y A r g u m e n t s
2798C-----------------------------------------------
2799 INTEGER ND ,MD ,ITASK
2800C REAL
2801 my_real
2802 . a(nd,*), b(*), c(*)
2803C-----------------------------------------------
2804c FUNCTION: product {C}=[A]{B}
2805c
2806c Note:
2807c ARGUMENTS: (I: input, O: output, IO: input * output, W: workspace)
2808c
2809c TYPE NAME FUNCTION
2810c I ND,MN - Matrix dimension 2D
2811c I ITASK - thread id (//)
2812c I B(NM) - right-hand vector
2813c O C(ND) - left-hand vector
2814C-----------------------------------------------
2815C L o c a l V a r i a b l e s
2816C-----------------------------------------------
2817 INTEGER I,J,K
2818 my_real
2819 . W(MD)
2820C-----------------------------
2821 IF (itask /= 0) RETURN
2822C------------may add dynamic smp on ND after--
2823 DO i=1,nd
2824 DO j= 1,md
2825 w(j)= a(i,j)
2826 END DO
2827 CALL produt_v_loc( md ,w ,b ,c(i))
2828 ENDDO
2829C--------------------------------------------
2830 RETURN
2831 END
2832!||====================================================================
2833!|| mam_nm ../engine/source/implicit/produt_v.F
2834!||--- called by ------------------------------------------------------
2835!|| imp_inist ../engine/source/implicit/imp_pcg.F
2836!||--- calls -----------------------------------------------------
2837!|| produt_h ../engine/source/implicit/produt_v.F
2838!||====================================================================
2839 SUBROUTINE mam_nm(F_ND ,L_ND ,ND, MD ,A ,B ,C ,WDDL,ITASK)
2840C-----------------------------------------------
2841C I m p l i c i t T y p e s
2842C-----------------------------------------------
2843#include "implicit_f.inc"
2844C-----------------------------------------------
2845C D u m m y A r g u m e n t s
2846C-----------------------------------------------
2847 INTEGER F_ND ,L_ND ,ND ,MD ,ITASK,WDDL(*)
2848C REAL
2849 my_real
2850 . a(nd,*), b(nd,*), c(md,*)
2851C-----------------------------------------------
2852c FUNCTION: product {C}=[A]^t[B]
2853c
2854c Note:
2855c ARGUMENTS: (I: input, O: output, IO: input * output, W: workspace)
2856c
2857c TYPE NAME FUNCTION
2858c I ND,MD - Matrix dimension 2D
2859c I WDDL(*) - itag for each id of subdomains
2860c I F_ND,L_ND,ITASK - id in each ITASK:thread id (//)
2861c I B(ND,MD) - right-hand Matrix
2862c O C(NM,MD) - left-hand vector
2863C-----------------------------------------------
2864C L o c a l V a r i a b l e s
2865C-----------------------------------------------
2866 INTEGER I,J,K
2867C-----------------------------
2868 DO I=1,md
2869 DO j=1,md
2870 CALL produt_h( f_nd ,l_nd ,a(1,i) ,b(1,j) ,wddl,c(i,j),itask)
2871 ENDDO
2872 ENDDO
2873C--------------------------------------------
2874 RETURN
2875 END
2876!||====================================================================
2877!|| mav_mm ../engine/source/implicit/produt_v.F
2878!||--- called by ------------------------------------------------------
2879!|| imp_inist ../engine/source/implicit/imp_pcg.F
2880!|| sms_inist ../engine/source/ams/sms_proj.F
2881!||====================================================================
2882 SUBROUTINE mav_mm(ND ,MD ,A ,B ,ITASK )
2883C-----------------------------------------------
2884C I m p l i c i t T y p e s
2885C-----------------------------------------------
2886#include "implicit_f.inc"
2887C-----------------------------------------------
2888C D u m m y A r g u m e n t s
2889C-----------------------------------------------
2890 INTEGER ND ,MD ,ITASK
2891C REAL
2892 my_real
2893 . a(nd,*), b(md,*)
2894C-----------------------------------------------
2895c FUNCTION: product [A]<-[A][B]
2896c
2897c Note:
2898c ARGUMENTS: (I: input, O: output, IO: input * output, W: workspace)
2899c
2900c TYPE NAME FUNCTION
2901c I ND,MN - Matrix dimension 2D
2902c I ITASK - thread id (//)
2903c IO A(ND,MD) - Matrix A
2904c O B(MD,MD) - Matrix B
2905C-----------------------------------------------
2906C L o c a l V a r i a b l e s
2907C-----------------------------------------------
2908 INTEGER I,J,K
2909 my_real
2910 . C(ND,MD)
2911C-----------------------------
2912 IF (itask /= 0) RETURN
2913C------------may add dynamic smp on ND after--
2914 DO i=1,nd
2915 DO j=1,md
2916 c(i,j)=zero
2917 DO k=1,md
2918 c(i,j) = c(i,j)+a(i,k)*b(k,j)
2919 END DO
2920 ENDDO
2921 ENDDO
2922C
2923 DO i=1,nd
2924 DO j=1,md
2925 a(i,j) = c(i,j)
2926 ENDDO
2927 ENDDO
2928C--------------------------------------------
2929 RETURN
2930 END
2931!||====================================================================
2932!|| mmav_lth ../engine/source/implicit/produt_v.F
2933!||--- called by ------------------------------------------------------
2934!|| imp_inisi ../engine/source/implicit/imp_pcg.F
2935!|| imp_inist ../engine/source/implicit/imp_pcg.F
2936!|| imp_ppcgh ../engine/source/implicit/imp_pcg.F
2937!|| imp_updv2 ../engine/source/implicit/imp_pcg.F
2938!||--- calls -----------------------------------------------------
2939!|| mav_lth ../engine/source/implicit/produt_v.F
2940!|| mmv_lh ../engine/source/implicit/produt_v.F
2941!|| mmv_lth ../engine/source/implicit/produt_v.F
2942!|| my_barrier ../engine/source/system/machine.F
2943!||--- uses -----------------------------------------------------
2944!|| groupdef_mod ../common_source/modules/groupdef_mod.F
2945!|| imp_workh ../engine/share/modules/impbufdef_mod.F
2946!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
2947!||====================================================================
2948 SUBROUTINE mmav_lth(
2949 1 NDDL ,NDDLI ,IADK ,JDIK ,DIAG_K,
2950 2 LT_K ,IADI ,JDII ,ITOK ,LT_I ,
2951 3 V ,W ,A ,AR ,VE ,
2952 5 MS ,X ,D ,DR ,NDOF ,
2953 6 IPARI ,INTBUF_TAB ,NUM_IMP,NS_IMP,
2954 7 NE_IMP,NSREM ,NSL ,IBFV ,SKEW ,
2955 8 XFRAME,MONVOL,VOLMON,IGRSURF ,
2956 9 FR_MV ,NMONV ,IMONV ,IND_IMP ,XI_C ,
2957 A IUPD ,IRBE3 ,LRBE3 ,IRBE2 ,LRBE2 ,
2958 B IADM ,JDIM ,DIAG_M,LT_M ,F_DDL ,
2959 C L_DDL ,ITASK ,V_W )
2960C-----------------------------------------------
2961C M o d u l e s
2962C-----------------------------------------------
2963 USE imp_workh
2964 USE intbufdef_mod
2965 USE groupdef_mod
2966C-----------------------------------------------
2967C I m p l i c i t T y p e s
2968C-----------------------------------------------
2969#include "implicit_f.inc"
2970#include "comlock.inc"
2971C-----------------------------------------------
2972C C o m m o n B l o c k s
2973C-----------------------------------------------
2974#include "com04_c.inc"
2975C-----------------------------------------------
2976C D u m m y A r g u m e n t s
2977C-----------------------------------------------
2978 INTEGER NDDL ,NDDLI,NDOF(*),IUPD,
2979 . IADK(*),JDIK(*),IADI(*),JDII(*),ITOK(*),
2980 . IPARI(*) ,NUM_IMP(*),NS_IMP(*) ,
2981 . NE_IMP(*),NSREM ,NSL,IBFV(*),IND_IMP(*),
2982 . IRBE3(*),LRBE3(*),F_DDL ,L_DDL ,ITASK,
2983 . IRBE2(*),LRBE2(*),IADM(*) ,JDIM(*)
2984 INTEGER NMONV,IMONV(*),MONVOL(*),FR_MV(*)
2985C REAL
2986 my_real
2987 . DIAG_K(*), W(*), LT_K(*) ,LT_I(*) ,V(*) ,
2988 . A(3,*),AR(3,*),VE(3,*),D(3,*),DR(3,*),X(3,*),
2989 . MS(*),VOLMON(*),SKEW(*),XFRAME(*),XI_C(*) ,
2990 . DIAG_M(*),LT_M(*),V_W(*)
2991
2992 TYPE(intbuf_struct_) INTBUF_TAB(*)
2993 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
2994C-----------------------------------------------
2995C L o c a l V a r i a b l e s
2996C-----------------------------------------------
2997C------Hybrid----produit {w}=[K']{v}=Lm[K]Lm^t{v} (Lm=L_M*sqrt(Diag_M))--DIAG_M->sqrt()--
2998C--------------if M=Lm*D*Lm^t, should be -> [K']=sqrt(D)*Lm^t[K]Lm*sqrt(D)
2999 INTEGER I,J,K
3000 my_real
3001 . zw1(nddl)
3002C--------------------------------------------
3003C------------------{zw1}=Lm^t{v}--------------------------
3004 CALL mmv_lh(
3005 1 nddl ,iadm0 ,jdim0 ,diag_m ,lt_m0 ,
3006 2 v ,v_w ,f_ddl ,l_ddl ,itask )
3007C----------------------
3008 CALL my_barrier
3009C---------------------
3010 DO i=1 ,nddl
3011 zw1(i) = v_w(i)
3012 ENDDO
3013C----------------------
3014 CALL my_barrier
3015C-----------------{zw2}=[K]{zw1}----
3016 CALL mav_lth(
3017 1 nddl ,nddli ,iadk ,jdik ,diag_k,
3018 2 lt_k ,iadi ,jdii ,itok ,lt_i ,
3019 3 zw1 ,v_w ,a ,ar ,
3020 5 ve ,ms ,x ,d ,dr ,
3021 6 ndof ,ipari ,intbuf_tab ,num_imp,
3022 7 ns_imp,ne_imp,nsrem ,nsl ,ibfv ,
3023 8 skew ,xframe,monvol,volmon,igrsurf ,
3024 9 fr_mv,nmonv ,imonv ,ind_imp,
3025 a xi_c ,iupd ,irbe3 ,lrbe3 ,irbe2 ,
3026 b lrbe2 ,f_ddl ,l_ddl ,itask )
3027C----------------------
3028 CALL my_barrier
3029C-----------------{w}=[Lm]{zw2}----
3030 CALL mmv_lth(
3031 1 nddl ,iadm ,jdim ,diag_m ,lt_m ,
3032 2 v_w ,w ,f_ddl ,l_ddl ,itask )
3033C
3034 RETURN
3035 END
3036!||====================================================================
3037!|| mmv_lth ../engine/source/implicit/produt_v.F
3038!||--- called by ------------------------------------------------------
3039!|| imp_ppcgh ../engine/source/implicit/imp_pcg.F
3040!|| mmav_lth ../engine/source/implicit/produt_v.F
3041!||--- calls -----------------------------------------------------
3042!|| my_barrier ../engine/source/system/machine.F
3043!|| spmd_sumf_v ../engine/source/mpi/implicit/imp_spmd.F
3044!||====================================================================
3045 SUBROUTINE mmv_lth(
3046 1 NDDL ,IADM ,JDIM ,DIAG_M ,LT_M ,
3047 2 V ,Z ,F_DDL ,L_DDL ,ITASK )
3048C-----------------------------------------------
3049C I m p l i c i t T y p e s
3050C-----------------------------------------------
3051#include "implicit_f.inc"
3052C-----------------------------------------------
3053C C o m m o n B l o c k s
3054C-----------------------------------------------
3055#include "impl1_c.inc"
3056#include "com01_c.inc"
3057C-----------------------------------------------
3058C D u m m y A r g u m e n t s
3059C-----------------------------------------------
3060 INTEGER NDDL ,IADM(*) ,JDIM(*),F_DDL ,L_DDL,ITASK
3061C REAL
3062 my_real
3063 . diag_m(*), z(*), lt_m(*) ,v(*)
3064C-----------------------------------------------
3065C L o c a l V a r i a b l e s
3066C-----------------------------------------------
3067C------hybrid version-solves {z}=[D]^-1/2[Z]^t{v}-----
3068 INTEGER I,J,K
3069C-----------------------------
3070 DO i=f_ddl ,l_ddl
3071 z(i) = v(i)
3072 ENDDO
3073C
3074 IF (iprec==2) THEN
3075 DO i=f_ddl ,l_ddl
3076 z(i) = v(i)*diag_m(i)
3077 ENDDO
3078 ELSEIF (iprec==5) THEN
3079C--------{z}=[Z]^t{v}-------------
3080 DO i=f_ddl ,l_ddl
3081 DO j =iadm(i),iadm(i+1)-1
3082 k = jdim(j)
3083 z(i) = z(i)+lt_m(j)*v(k)
3084 ENDDO
3085 ENDDO
3086C--------{z}=[D]^-1/2{z}-------------
3087 DO i=f_ddl ,l_ddl
3088 z(i) = z(i)*diag_m(i)
3089 ENDDO
3090 END IF !(IPREC==2) THEN
3091C
3092 IF (iprec>1) THEN
3093C----------------------
3094 CALL my_barrier
3095C---------------------
3096 IF (itask==0.AND.nspmd>1) CALL spmd_sumf_v(z)
3097 ENDIF
3098C--------------------------------------------
3099 RETURN
3100 END
3101!||====================================================================
3102!|| mmv_lh ../engine/source/implicit/produt_v.F
3103!||--- called by ------------------------------------------------------
3104!|| imp_ppcgh ../engine/source/implicit/imp_pcg.F
3105!|| mmav_lth ../engine/source/implicit/produt_v.F
3106!||--- calls -----------------------------------------------------
3107!|| my_barrier ../engine/source/system/machine.F
3108!|| spmd_sumf_v ../engine/source/mpi/implicit/imp_spmd.F
3109!||====================================================================
3110 SUBROUTINE mmv_lh(
3111 1 NDDL ,IADM ,JDIM ,DIAG_M ,LT_M ,
3112 2 V ,Z ,F_DDL ,L_DDL ,ITASK )
3113C-----------------------------------------------
3114C I m p l i c i t T y p e s
3115C-----------------------------------------------
3116#include "implicit_f.inc"
3117C-----------------------------------------------
3118C C o m m o n B l o c k s
3119C-----------------------------------------------
3120#include "impl1_c.inc"
3121#include "com01_c.inc"
3122C-----------------------------------------------
3123C D u m m y A r g u m e n t s
3124C-----------------------------------------------
3125 INTEGER NDDL ,IADM(*) ,JDIM(*),F_DDL ,L_DDL,ITASK
3126C REAL
3127 my_real
3128 . DIAG_M(*), Z(*), LT_M(*) ,V(*)
3129C-----------------------------------------------
3130C L o c a l V a r i a b l e s
3131C-----------------------------------------------
3132C-------hybrid version-solves {z}=[Z][D]^-1/2{v}----[Z] en colonne-
3133 INTEGER I,J,K
3134 my_real
3135 . TMP(NDDL)
3136C-----------------------------
3137 DO I=f_ddl ,l_ddl
3138 z(i) = v(i)
3139 ENDDO
3140C
3141 IF (iprec==2) THEN
3142 DO i=f_ddl ,l_ddl
3143 z(i) = v(i)*diag_m(i)
3144 ENDDO
3145 ELSEIF (iprec==5) THEN
3146C--------{z}=[D]^-1/2{v}-------------
3147 DO i=f_ddl ,l_ddl
3148 z(i) = v(i)*diag_m(i)
3149 ENDDO
3150C----------------------
3151 CALL my_barrier
3152C---------------------
3153 DO i=1 ,nddl
3154 tmp(i) = z(i)
3155 ENDDO
3156C----------------------
3157 CALL my_barrier
3158C---------------------
3159C --------{z}=[Z]{z}-------
3160 DO i=f_ddl ,l_ddl
3161 DO j =iadm(i),iadm(i+1)-1
3162 k = jdim(j)
3163 z(i) = z(i)+lt_m(j)*tmp(k)
3164 ENDDO
3165 ENDDO
3166 END IF !(IPREC==2) THEN
3167C
3168 IF (iprec>1) THEN
3169C----------------------
3170 CALL my_barrier
3171C---------------------
3172 IF (itask==0.AND.nspmd>1) CALL spmd_sumf_v(z)
3173 ENDIF
3174C--------------------------------------------
3175 RETURN
3176 END
3177!||====================================================================
3178!|| mav_liuh ../engine/source/implicit/produt_v.F
3179!||--- called by ------------------------------------------------------
3180!|| mav_lth ../engine/source/implicit/produt_v.F
3181!||--- uses -----------------------------------------------------
3182!|| imp_workh ../engine/share/modules/impbufdef_mod.F
3183!||====================================================================
3184 SUBROUTINE mav_liuh(F_DDL ,L_DDL ,IADI ,JDII ,ITOK ,
3185 2 LT_I ,WORK_II ,V ,W ,ITASK )
3186C-----------------------------------------------
3187C M o d u l e s
3188C-----------------------------------------------
3189 USE imp_workh
3190C-----------------------------------------------
3191C I m p l i c i t T y p e s
3192C-----------------------------------------------
3193#include "implicit_f.inc"
3194C-----------------------------------------------
3195C D u m m y A r g u m e n t s
3196C-----------------------------------------------
3197 INTEGER F_DDL ,L_DDL ,IADI(*) ,JDII(*),ITOK(*),ITASK
3198C REAL
3199 my_real
3200 . w(*), lt_i(*) ,v(*) ,work_ii(*)
3201C-----------------------------------------------
3202C L o c a l V a r i a b l e s
3203C-----------------------------------------------
3204 INTEGER I,J,K,N,II,KK
3205 my_real
3206 . L_K
3207C----------------------------
3208 DO I=f_ddl,l_ddl
3209 work_ii(i) = zero
3210 ENDDO
3211C
3212 DO i=f_ddl,l_ddl
3213 DO j =iadi(i),iadi(i+1)-1
3214 k =jdii(j)
3215 kk = itok(k)
3216 l_k = lt_i(j)
3217 work_ii(i) = work_ii(i) + l_k*v(kk)
3218 ENDDO
3219 ENDDO
3220C
3221 DO i=f_ddl,l_ddl
3222 DO j =iadi0(i),iadi0(i+1)-1
3223 k =jdii0(j)
3224 kk = itok(k)
3225 l_k = lt_i0(j)
3226 work_ii(i) = work_ii(i) + l_k*v(kk)
3227 ENDDO
3228 ENDDO
3229C---------------------
3230 DO i=f_ddl,l_ddl
3231 ii = itok(i)
3232 w(ii) = w(ii) + work_ii(i)
3233 ENDDO
3234C--------------------------------------------
3235 RETURN
3236 END
3237C-----------Hybrid {x}t{y}-.{Weight}--HP: Hyprid SMP // inside
3238!||====================================================================
3239!|| produt_hp ../engine/source/implicit/produt_v.F
3240!||--- called by ------------------------------------------------------
3241!|| imp_solv ../engine/source/implicit/imp_solv.F
3242!|| lin_solv ../engine/source/implicit/lin_solv.F
3243!|| nl_solv ../engine/source/implicit/nl_solv.F
3244!|| produt_uhp ../engine/source/implicit/produt_v.f
3245!|| produt_uhp2 ../engine/source/implicit/produt_v.f
3246!|| produt_vmhp ../engine/source/implicit/produt_v.F
3247!||--- calls -----------------------------------------------------
3248!|| imp_smpini ../engine/source/implicit/imp_solv.f
3249!|| spmd_sum_s ../engine/source/mpi/implicit/imp_spmd.F
3250!||====================================================================
3251 SUBROUTINE produt_hp(NDDL ,X ,Y ,W , R )
3252C-----------------------------------------------
3253C I m p l i c i t T y p e s
3254C-----------------------------------------------
3255#include "implicit_f.inc"
3256#include "comlock.inc"
3257C-----------------------------------------------
3258C C o m m o n B l o c k s
3259C-----------------------------------------------
3260#include "com01_c.inc"
3261#include "timeri_c.inc"
3262C-----------------------------------------------
3263C D u m m y A r g u m e n t s
3264C-----------------------------------------------
3265 INTEGER NDDL,W(*)
3266C REAL
3267 my_real
3268 . X(*), Y(*) ,R
3269C-----------------------------------------------
3270C L o c a l V a r i a b l e s
3271C-----------------------------------------------
3272 INTEGER F_DDL ,L_DDL ,ITSK
3273 INTEGER I ,N,J
3274 my_real
3275 . RL
3276C-----------------------------
3277 r = zero
3278C---------------------
3279 IF (nspmd > 1) THEN
3280!$OMP PARALLEL PRIVATE(ITSK,F_DDL ,L_DDL,RL,J)
3281 CALL imp_smpini(itsk ,f_ddl ,l_ddl ,nddl )
3282 rl = zero
3283 DO j=f_ddl,l_ddl
3284 rl = rl + x(j)*y(j)*w(j)
3285 END DO
3286#include "lockon.inc"
3287 r = r + rl
3288#include "lockoff.inc"
3289!$OMP END PARALLEL
3290! IF(IMONM > 0) CALL STARTIME(TIMERS,67)
3291 CALL spmd_sum_s(r)
3292! IF(IMONM > 0) CALL STARTIME(TIMERS,67)
3293C------mono domain
3294 ELSE
3295!$OMP PARALLEL PRIVATE(ITSK,F_DDL ,L_DDL,RL,J )
3296 CALL imp_smpini(itsk ,f_ddl ,l_ddl ,nddl )
3297 rl = zero
3298 DO j=f_ddl,l_ddl
3299 rl = rl + x(j)*y(j)
3300 END DO
3301#include "lockon.inc"
3302 r = r + rl
3303#include "lockoff.inc"
3304!$OMP END PARALLEL
3305 END IF !(NSPMD > 1) THEN
3306C---------------------
3307 RETURN
3308 END
3309C---------------------r={x}^t{y}--x comes from u(1-3,*)-
3310!||====================================================================
3311!|| produt_vmhp ../engine/source/implicit/produt_v.F
3312!||--- called by ------------------------------------------------------
3313!|| imp_frfv ../engine/source/mpi/implicit/imp_fri.F
3314!|| nl_solv ../engine/source/implicit/nl_solv.F
3315!||--- calls -----------------------------------------------------
3316!|| d_to_u ../engine/source/implicit/produt_v.F
3317!|| produt_hp ../engine/source/implicit/produt_v.F
3318!||====================================================================
3319 SUBROUTINE produt_vmhp(NDDL0 ,NDDL ,IDDL ,NDOF ,IKC ,
3320 . DD ,DDR ,Y ,R ,W_IMP )
3321C-----------------------------------------------
3322C I m p l i c i t T y p e s
3323C-----------------------------------------------
3324#include "implicit_f.inc"
3325C-----------------------------------------------
3326C D u m m y A r g u m e n t s
3327C-----------------------------------------------
3328 INTEGER NDDL,NDDL0,IDDL(*) ,NDOF(*) ,IKC(*) ,W_IMP(*)
3329 my_real
3330 . DD(*),DDR(*), Y(*) ,R
3331C-----------------------------------------------
3332C L o c a l V a r i a b l e s
3333C-----------------------------------------------
3334C REAL
3335 my_real
3336 . TMP_W1(NDDL)
3337C-------------to // D_TO_U----------------
3338 CALL D_TO_U(NDDL0 ,NDDL ,IDDL ,NDOF ,IKC ,
3339 . DD ,DDR ,TMP_W1 )
3340C---------------------
3341 CALL produt_hp(nddl,tmp_w1,y,w_imp,r)
3342C--------------------------------------------
3343 RETURN
3344 END
3345C-------------norm2={x}^t{x}--x comes from u(3,*)- Hybrid---
3346!||====================================================================
3347!|| produt_uhp ../engine/source/implicit/produt_v.F
3348!||--- called by ------------------------------------------------------
3349!|| al_constraint1_hp ../engine/source/implicit/nl_solv.f
3350!|| al_constraint2_hp ../engine/source/implicit/nl_solv.F
3351!|| nl_solv ../engine/source/implicit/nl_solv.F
3352!||--- calls -----------------------------------------------------
3353!|| condens_b ../engine/source/implicit/upd_glob_k.F
3354!|| imp_setb ../engine/source/implicit/imp_setb.F
3355!|| produt_hp ../engine/source/implicit/produt_v.F
3356!||====================================================================
3357 SUBROUTINE produt_uhp(NDDL0 ,NDDL ,IDDL ,NDOF ,IKC ,
3358 . DD ,DDR ,NORM2 ,W_IMP )
3359C-----------------------------------------------
3360C I m p l i c i t T y p e s
3361C-----------------------------------------------
3362#include "implicit_f.inc"
3363C-----------------------------------------------
3364C D u m m y A r g u m e n t s
3365C-----------------------------------------------
3366 INTEGER NDDL,NDDL0,IDDL(*) ,NDOF(*) ,IKC(*),W_IMP(*) ,
3367 . f_ddl ,l_ddl ,itask
3368C REAL
3369 my_real
3370 . dd(*),ddr(*), norm2
3371C-----------------------------------------------
3372C L o c a l V a r i a b l e s
3373C-----------------------------------------------
3374 INTEGER I
3375 my_real
3376 . tmp_w1(nddl0)
3377C----------to // IMP_SETB,CONDENS_B-------------------
3378 CALL imp_setb(dd ,ddr ,iddl ,ndof ,tmp_w1)
3379 CALL condens_b(nddl0 ,ikc ,tmp_w1)
3380 CALL produt_hp(nddl,tmp_w1,tmp_w1,w_imp,norm2)
3381 RETURN
3382 END
3383C---------------------norm2={x}^t{y}--x,y come from D1(3,*),D2-- Hybrid
3384!||====================================================================
3385!|| produt_uhp2 ../engine/source/implicit/produt_v.F
3386!||--- called by ------------------------------------------------------
3387!|| al_constraint1_hp ../engine/source/implicit/nl_solv.F
3388!|| al_constraint2_hp ../engine/source/implicit/nl_solv.F
3389!|| nl_solv ../engine/source/implicit/nl_solv.F
3390!||--- calls -----------------------------------------------------
3391!|| condens_b ../engine/source/implicit/upd_glob_k.F
3392!|| imp_setb ../engine/source/implicit/imp_setb.F
3393!|| produt_hp ../engine/source/implicit/produt_v.F
3394!||====================================================================
3395 SUBROUTINE produt_uhp2(NDDL0 ,NDDL ,IDDL ,NDOF ,IKC ,
3396 . D1 ,D1R ,D2 ,D2R ,NORM2 ,
3397 . W_IMP )
3398C-----------------------------------------------
3399C I m p l i c i t T y p e s
3400C-----------------------------------------------
3401#include "implicit_f.inc"
3402C-----------------------------------------------
3403C D u m m y A r g u m e n t s
3404C-----------------------------------------------
3405 INTEGER NDDL,NDDL0,IDDL(*) ,NDOF(*) ,IKC(*),W_IMP(*)
3406C REAL
3407 my_real
3408 . D1(*),D1R(*), D2(*),D2R(*), NORM2
3409C-----------------------------------------------
3410C L o c a l V a r i a b l e s
3411C-----------------------------------------------
3412 INTEGER I
3413 my_real
3414 . TMP_W1(NDDL0),TMP_W2(NDDL0)
3415C-----------------------------
3416 CALL IMP_SETB(D1 ,D1R ,IDDL ,NDOF ,TMP_W1)
3417 CALL IMP_SETB(D2 ,D2R ,IDDL ,NDOF ,TMP_W2)
3418 CALL CONDENS_B(NDDL0 ,IKC ,TMP_W1)
3419 CALL CONDENS_B(NDDL0 ,IKC ,TMP_W2)
3420C----------------------
3421 CALL produt_hp(nddl,tmp_w1,tmp_w2,w_imp,norm2)
3422C--------------------------------------------
3423 RETURN
3424 END
3425C---------norm2={x}^t{x}--x comes from D(3,*)- including kinematic nodes
3426!||====================================================================
3427!|| produt_uhp0 ../engine/source/implicit/produt_v.F
3428!||--- called by ------------------------------------------------------
3429!|| imp_solv ../engine/source/implicit/imp_solv.F
3430!||--- calls -----------------------------------------------------
3431!|| imp_smpini ../engine/source/implicit/imp_solv.F
3432!|| spmd_sum_s ../engine/source/mpi/implicit/imp_spmd.F
3433!||====================================================================
3434 SUBROUTINE produt_uhp0(DD ,DDR ,NORM2 ,WEIGHT)
3435C-----------------------------------------------
3436C I m p l i c i t T y p e s
3437C-----------------------------------------------
3438#include "implicit_f.inc"
3439C-----------------------------------------------
3440C C o m m o n B l o c k s
3441C-----------------------------------------------
3442#include "com01_c.inc"
3443#include "com04_c.inc"
3444#include "comlock.inc"
3445C-----------------------------------------------
3446C D u m m y A r g u m e n t s
3447C-----------------------------------------------
3448 INTEGER WEIGHT(*)
3449C REAL
3450 my_real
3451 . dd(3,*),ddr(3,*), norm2
3452C-----------------------------------------------
3453C L o c a l V a r i a b l e s
3454C-----------------------------------------------
3455 INTEGER ITSK,NODFT ,NODLT,I
3456C-----------------------------
3457 NORM2=zero
3458!$OMP PARALLEL PRIVATE(ITSK,NODFT ,NODLT,I)
3459 CALL imp_smpini(itsk ,nodft ,nodlt ,numnod )
3460 DO i=nodft ,nodlt
3461 IF (weight(i)==1) THEN
3462#include "lockon.inc"
3463 norm2 = norm2 + dd(1,i)*dd(1,i)
3464 norm2 = norm2 + dd(2,i)*dd(2,i)
3465 norm2 = norm2 + dd(3,i)*dd(3,i)
3466#include "lockoff.inc"
3467 END IF
3468 END DO
3469 IF (iroddl>0) THEN
3470 DO i=nodft ,nodlt
3471 IF (weight(i)==1) THEN
3472#include "lockon.inc"
3473 norm2 = norm2 + ddr(1,i)*ddr(1,i)
3474 norm2 = norm2 + ddr(2,i)*ddr(2,i)
3475 norm2 = norm2 + ddr(3,i)*ddr(3,i)
3476#include "lockoff.inc"
3477 END IF
3478 END DO
3479 END IF
3480!$OMP END PARALLEL
3481C
3482 IF (nspmd>1) THEN
3483 CALL spmd_sum_s(norm2)
3484 END IF
3485C--------------------------------------------
3486 RETURN
3487 END
3488!||====================================================================
3489!|| vscal_hp ../engine/source/implicit/produt_v.F
3490!||--- calls -----------------------------------------------------
3491!|| imp_smpini ../engine/source/implicit/imp_solv.F
3492!||====================================================================
3493 SUBROUTINE vscal_hp(N , V ,S )
3494C-----------------------------------------------
3495C I m p l i c i t T y p e s
3496C-----------------------------------------------
3497#include "implicit_f.inc"
3498C-----------------------------------------------
3499C D u m m y A r g u m e n t s
3500C-----------------------------------------------
3501 INTEGER N
3502C REAL
3503 my_real
3504 . s, v(*)
3505C-----------------------------------------------
3506c PURPOSE: V(*) <- S*V(*)
3507c
3508c Note:
3509c ARGUMENTS: (I: input, O: output, IO: input * output, W: workspace)
3510c
3511c TYPE NAME FUNCTION
3512c I N - dim. of V()
3513c IO V(*) - V(*) scaled for output
3514C-----------------------------------------------
3515C L o c a l V a r i a b l e s
3516C-----------------------------------------------
3517 INTEGER I,ITSK,NFT,NLT
3518C-----------------------------
3519!$OMP PARALLEL PRIVATE(ITSK,NFT,NLT,I)
3520 CALL IMP_SMPINI(ITSK ,NFT ,NLT ,N )
3521 DO I = nft ,nlt
3522 v(i) = s*v(i)
3523 END DO !I=NFT ,NLT
3524!$OMP END PARALLEL
3525C--------------------------------------------
3526 RETURN
3527 END
3528!||====================================================================
3529!|| vscaly_hp ../engine/source/implicit/produt_v.F
3530!||--- called by ------------------------------------------------------
3531!|| imp_solv ../engine/source/implicit/imp_solv.F
3532!||--- calls -----------------------------------------------------
3533!|| imp_smpini ../engine/source/implicit/imp_solv.F
3534!||====================================================================
3535 SUBROUTINE vscaly_hp(N , V ,Y ,S )
3536C-----------------------------------------------
3537C I m p l i c i t T y p e s
3538C-----------------------------------------------
3539#include "implicit_f.inc"
3540C-----------------------------------------------
3541C D u m m y A r g u m e n t s
3542C-----------------------------------------------
3543 INTEGER N
3544C REAL
3545 my_real
3546 . S, V(*),Y(*)
3547C-----------------------------------------------
3548c PURPOSE: V(*) <- S*Y(*)
3549c
3550c Note:
3551c ARGUMENTS: (I: input, O: output, IO: input * output, W: workspace)
3552c
3553c TYPE NAME FUNCTION
3554c I N - dim. of V()
3555c I Y(*) - Y(*)
3556c O V(*) - V(*) scaled for output
3557C-----------------------------------------------
3558C L o c a l V a r i a b l e s
3559C-----------------------------------------------
3560 INTEGER I,ITSK,NFT,NLT
3561C-----------------------------
3562!$OMP PARALLEL PRIVATE(ITSK,NFT,NLT,I)
3563 CALL imp_smpini(itsk ,nft ,nlt ,n )
3564 DO i = nft ,nlt
3565 v(i) = s*y(i)
3566 END DO !I=NFT ,NLT
3567!$OMP END PARALLEL
3568C--------------------------------------------
3569 RETURN
3570 END
3571!||====================================================================
3572!|| vaxpy_hp ../engine/source/implicit/produt_v.F
3573!||--- called by ------------------------------------------------------
3574!|| imp_solv ../engine/source/implicit/imp_solv.F
3575!|| nl_solv ../engine/source/implicit/nl_solv.f
3576!||--- calls -----------------------------------------------------
3577!|| imp_smpini ../engine/source/implicit/imp_solv.F
3578!||====================================================================
3579 SUBROUTINE vaxpy_hp(N , V ,Y ,S )
3580C-----------------------------------------------
3581C I m p l i c i t T y p e s
3582C-----------------------------------------------
3583#include "implicit_f.inc"
3584C-----------------------------------------------
3585C D u m m y A r g u m e n t s
3586C-----------------------------------------------
3587 INTEGER N
3588C REAL
3589 my_real
3590 . S, V(*),Y(*)
3591C-----------------------------------------------
3592c PURPOSE: V(*) <- V(*)+S*Y(*)
3593c
3594c Note:
3595c ARGUMENTS: (I: input, O: output, IO: input * output, W: workspace)
3596c
3597c TYPE NAME FUNCTION
3598c I N - dim. of V()
3599c I Y(*) - Y(*)
3600c O V(*) - V(*) scaled for output
3601C-----------------------------------------------
3602C L o c a l V a r i a b l e s
3603C-----------------------------------------------
3604 INTEGER I,ITSK,NFT,NLT
3605C-----------------------------
3606!$OMP PARALLEL PRIVATE(ITSK,NFT,NLT,I)
3607 CALL IMP_SMPINI(ITSK ,NFT ,NLT ,N )
3608 DO I = nft ,nlt
3609 v(i) = v(i) + s*y(i)
3610 END DO !I=NFT ,NLT
3611!$OMP END PARALLEL
3612C--------------------------------------------
3613 RETURN
3614 END
3615!||====================================================================
3616!|| cp_real_hp ../engine/source/implicit/produt_v.F
3617!||--- called by ------------------------------------------------------
3618!|| imp_intfr ../engine/source/implicit/imp_solv.F
3619!|| imp_solv ../engine/source/implicit/imp_solv.F
3620!||--- calls -----------------------------------------------------
3621!|| imp_smpini ../engine/source/implicit/imp_solv.F
3622!||====================================================================
3623 SUBROUTINE cp_real_hp( N ,X ,XC)
3624C-----------------------------------------------
3625C I m p l i c i t T y p e s
3626C-----------------------------------------------
3627#include "implicit_f.inc"
3628C-----------------------------------------------
3629C D u m m y A r g u m e n t s
3630C-----------------------------------------------
3631 INTEGER N
3632C REAL
3633 my_real
3634 . X(*), XC(*)
3635C-----------------------------------------------
3636C L o c a l V a r i a b l e s
3637C-----------------------------------------------
3638 INTEGER I,ITSK,NFT,NLT
3639C-----------------------------
3640!$OMP PARALLEL PRIVATE(ITSK,NFT,NLT,I)
3641 CALL IMP_SMPINI(ITSK ,NFT ,NLT ,N )
3642 DO I = nft ,nlt
3643 xc(i) = x(i)
3644 ENDDO
3645!$OMP END PARALLEL
3646C--------------------------------------------
3647 RETURN
3648 END
3649!||====================================================================
3650!|| cp_int_hp ../engine/source/implicit/produt_v.F
3651!||--- called by ------------------------------------------------------
3652!|| imp_solv ../engine/source/implicit/imp_solv.F
3653!||--- calls -----------------------------------------------------
3654!|| imp_smpini ../engine/source/implicit/imp_solv.F
3655!||====================================================================
3656 SUBROUTINE cp_int_hp( N ,X ,XC)
3657C-----------------------------------------------
3658C I m p l i c i t T y p e s
3659C-----------------------------------------------
3660#include "implicit_f.inc"
3661C-----------------------------------------------
3662C D u m m y A r g u m e n t s
3663C-----------------------------------------------
3664 INTEGER N ,X(*), XC(*)
3665C REAL
3666C-----------------------------------------------
3667C L o c a l V a r i a b l e s
3668C-----------------------------------------------
3669 INTEGER I,ITSK,NFT,NLT
3670C-----------------------------
3671!$OMP PARALLEL PRIVATE(ITSK,NFT,NLT,I)
3672 CALL imp_smpini(itsk ,nft ,nlt ,n )
3673 DO i = nft ,nlt
3674 xc(i) = x(i)
3675 ENDDO
3676!$OMP END PARALLEL
3677C--------------------------------------------
3678 RETURN
3679 END
3680!||====================================================================
3681!|| zeror_hp ../engine/source/implicit/produt_v.f
3682!||--- called by ------------------------------------------------------
3683!|| imp_solv ../engine/source/implicit/imp_solv.F
3684!||--- calls -----------------------------------------------------
3685!|| imp_smpini ../engine/source/implicit/imp_solv.F
3686!||====================================================================
3687 SUBROUTINE zeror_hp( X ,N)
3688C-----------------------------------------------
3689C I m p l i c i t T y p e s
3690C-----------------------------------------------
3691#include "implicit_f.inc"
3692C-----------------------------------------------
3693C D u m m y A r g u m e n t s
3694C-----------------------------------------------
3695 INTEGER N
3696C REAL
3697 my_real
3698 . x(*)
3699C-----------------------------------------------
3700C L o c a l V a r i a b l e s
3701C-----------------------------------------------
3702 INTEGER I,ITSK,NFT,NLT,N3
3703C-----------------------------
3704 N3=3*n
3705!$OMP PARALLEL PRIVATE(ITSK,NFT,NLT,I)
3706 CALL imp_smpini(itsk ,nft ,nlt ,n3 )
3707 DO i = nft ,nlt
3708 x(i) = zero
3709 ENDDO
3710!$OMP END PARALLEL
3711C--------------------------------------------
3712 RETURN
3713 END
copy_elbuf
subroutine copy_elbuf(elbuf_src, elbuf_tgt, iparg, ngroup)
Definition copy_elbuf.F:33
copy_intbuf_tab
subroutine copy_intbuf_tab(intbuf_tab, intbuf_tab_c)
Definition copy_intbuf_tab.F:31
my_real
#define my_real
Definition cppsort.cpp:32
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
cp_inttd
subroutine cp_inttd(nt_imp1, numimp, ns_imp, ne_imp, ind_imp, numimp1)
Definition imp_int_k.F:1379
int_matvp
subroutine int_matvp(ipari, intbuf_tab, ndof, num_imp, ns_imp, ne_imp, index2, a, ar, v, x, ms, x_imp, ibfv, skew, xframe, u, f, dr, nsrem, nsl, iupd, irbe3, lrbe3, irbe2, lrbe2)
Definition imp_int_k.F:2499
int_matv
subroutine int_matv(ipari, intbuf_tab, ndof, num_imp, ns_imp, ne_imp, index2, a, ar, v, x, ms, x_imp, ibfv, skew, xframe, u, f, iupd, irbe3, lrbe3, irbe2, lrbe2)
Definition imp_int_k.F:2402
imp_int_k
subroutine imp_int_k(a, v, icodt, icodr, iskew, ibfv, npc, tf, vel, nsensor, sensor_tab, xframe, rby, x, skew, lpby, npby, itab, weight, ms, in, nrbyac, irbyac, nss, iss, ipari, intbuf_tab, nint2, iint2, iaint2, nss2, iss2, nddli, nnzi, iadi, jdii, diag_i, lt_i, iddli, nddl, iadk, jdik, ikc, diag_k, lt_k, iddl, num_imp, ns_imp, ne_imp, index2, ndofi, itok, ud, lb, gapmin, dirul, nt_rw, num_imp1, irbe3, lrbe3, frbe3, nss3, iss3, irbe2, lrbe2, nsb2, isb2)
Definition imp_int_k.F:56
imp_lanzp
subroutine imp_lanzp(iprec, n, nnz, iadk, jdik, diag_k, lt_k, ni, itok, iadi, jdii, lt_i, nnzm, iadm, jdim, diag_m, lt_m, x, r, itol, rtol, v, w, y, itask, iprint, shift, kcond, n_max, flm, f_x, istop, w_ddl, a, ar, ve, ms, xe, d, dr, ndof, ipari, intbuf_tab, num_imp, ns_imp, ne_imp, nsrem, nsl, nmonv, imonv, monvol, igrsurf, volmon, fr_mv, ibfv, skew, xframe, ind_imp, xi_c, r0, nddli_g, intp_c, irbe3, lrbe3, irbe2, lrbe2)
Definition imp_lanz.F:53
imp_setb
subroutine imp_setb(f, m, iddl, ndof, b)
Definition imp_setb.F:40
imp_solv
subroutine imp_solv(timers, python, icode, iskew, iskwn, ipart, ixtg, ixs, ixq, ixc, ixt, ixp, ixr, ixtg1, itab, itabm1, npc, ibcl, ibfv, sensor_tab, nnlink, lnlink, iparg, igrv, ipari, intbuf_tab, nprw, iconx, npby, lpby, lrivet, nstrf, ljoint, icodt, icodr, isky, adsky, iads_f, ilink, llink, weight, itask, ibvel, lbvel, fbvel, x, d, v, vr, dr, thke, damp, ms, in, pm, skews, geo, eani, bufmat, bufgeo, bufsf, tf, forc, vel, fsav, agrv, fr_wave, parts0, elbuf, rby, rivet, fr_elem, iad_elem, wa, a, ar, stifn, stifr, partsav, fsky, fskyi, iframe, xframe, w16, iactiv, fskym, igeo, ipm, wfext, nodft, nodlt, nint7, num_imp, ns_imp, ne_imp, ind_imp, it, rwbuf, lprw, fr_wall, nbintc, intlist, fopt, rwsav, fsavd, graphe, fac_k, ipiv_k, nkcond, nsensor, monvol, igrsurf, fr_mv, volmon, dirul, nodglob, mumps_par, cddlp, isendto, irecvfrom, newfront, imsch, i2msch, isizxv, ilenxv, islen7, irlen7, islen11, irlen11, islen17, irlen17, irlen7t, islen7t, kinet, num_imp1, temp, dt2prev, waint, lgrav, sh4tree, sh3tree, irlen20, islen20, irlen20t, islen20t, irlen20e, islen20e, irbe3, lrbe3, frbe3, fr_i2m, iad_i2m, fr_rbe3m, iad_rbe3m, frwl6, irbe2, lrbe2, intbuf_tab_c, ikine, diag_sms, icfield, lcfield, cfield, count_remslv, count_remslve, elbuf_tab, elbuf_imp, xdp, weight_md, stack, dimfb, fbsav6, stabsen, tabsensor, drape_sh4n, drape_sh3n, h3d_data, multi_fvm, igrbric, igrsh4n, igrsh3n, igrbeam, forneqs, maxdgap, nddl0, nnzk0, it_t, impbuf_tab, cptreac, fthreac, nodreac, drapeg, interfaces, th_surf, dpl0cld, vel0cld, snpc, stf, glob_therm, wfext_md)
Definition imp_solv.F:173
matv_kif
subroutine matv_kif(v, w)
Definition imp_solv.F:2657
imp_smpini
subroutine imp_smpini(itsk, n1ftsk, n1ltsk, n1)
Definition imp_solv.F:6895
spmd_sumf_v
subroutine spmd_sumf_v(v)
Definition imp_spmd.F:1650
spmd_sum_s
subroutine spmd_sum_s(s)
Definition imp_spmd.F:1037
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
mv_matv
subroutine mv_matv(monvol, volmon, x, igrsurf, fr_mv, nmonv, imonv, u, f, ndof, ipari, intbuf_tab, a, ar, x_imp, ibfv, skew, xframe, irbe3, lrbe3, irbe2, lrbe2)
Definition monv_imp0.F:1773
groupdef_mod
Definition groupdef_mod.F:662
imp_i7cp
Definition imp_intm.F:192
imp_i7cp::lri7cp
integer lri7cp
Definition imp_intm.F:193
imp_i7cp::lii7cp
integer lii7cp
Definition imp_intm.F:193
imp_i7cp::newfrcp
integer, dimension(:), allocatable newfrcp
Definition imp_intm.F:195
imp_i7cp::iad_stifold
integer, dimension(:), allocatable iad_stifold
Definition imp_intm.F:196
imp_i7cp::iparicp
integer, dimension(:,:), allocatable iparicp
Definition imp_intm.F:197
imp_i7cp::ii7cp
integer, dimension(:), allocatable ii7cp
Definition imp_intm.F:195
imp_i7cp::lenscp
integer, dimension(20) lenscp
Definition imp_intm.F:193
imp_workh
Definition impbufdef_mod.F:571
imp_workh::jdik0
integer, dimension(:), allocatable jdik0
Definition impbufdef_mod.F:584
imp_workh::iadi0
integer, dimension(:), allocatable iadi0
Definition impbufdef_mod.F:588
imp_workh::jdim0
integer, dimension(:), allocatable jdim0
Definition impbufdef_mod.F:584
imp_workh::jdii0
integer, dimension(:), allocatable jdii0
Definition impbufdef_mod.F:588
imp_workh::iadk0
integer, dimension(:), allocatable iadk0
Definition impbufdef_mod.F:584
imp_workh::iadm0
integer, dimension(:), allocatable iadm0
Definition impbufdef_mod.F:584
impbufdef_mod
Definition impbufdef_mod.F:36
message_mod
Definition message_mod.F:1249
tri7box::stif_oldfi
type(real_pointer2), dimension(:), allocatable stif_oldfi
Definition tri7box.F:545
tri7box::secnd_frfi
type(real_pointer2), dimension(:), allocatable secnd_frfi
Definition tri7box.F:543
tri7box::condnfi
type(real_pointer), dimension(:), allocatable condnfi
Definition tri7box.F:449
tri7box::time_sfi
type(real_pointer), dimension(:), allocatable time_sfi
Definition tri7box.F:542
tri7box::vfi
type(real_pointer2), dimension(:), allocatable vfi
Definition tri7box.F:459
tri7box::irtlm_fi
type(int_pointer2), dimension(:), allocatable irtlm_fi
Definition tri7box.F:533
tri7box::matsfi
type(int_pointer), dimension(:), allocatable matsfi
Definition tri7box.F:440
tri7box::tempfi
type(real_pointer), dimension(:), allocatable tempfi
Definition tri7box.F:449
tri7box::stifi
type(real_pointer), dimension(:), allocatable stifi
Definition tri7box.F:449
tri7box::nsvsi
type(int_pointer), dimension(:), allocatable nsvsi
Definition tri7box.F:485
tri7box::penfi
type(real_pointer2), dimension(:), allocatable penfi
Definition tri7box.F:459
tri7box::stnfi
type(real_pointer), dimension(:), allocatable stnfi
Definition tri7box.F:449
tri7box::afi
type(real_pointer2), dimension(:), allocatable afi
Definition tri7box.F:459
tri7box::nsnsi
type(int_pointer), dimension(:), allocatable nsnsi
Definition tri7box.F:491
tri7box::gapfi
type(real_pointer), dimension(:), allocatable gapfi
Definition tri7box.F:449
tri7box::nsvfi
type(int_pointer), dimension(:), allocatable nsvfi
Definition tri7box.F:431
tri7box::areasfi
type(real_pointer), dimension(:), allocatable areasfi
Definition tri7box.F:449
tri7box::msfi
type(real_pointer), dimension(:), allocatable msfi
Definition tri7box.F:449
tri7box::vscfi
type(real_pointer), dimension(:), allocatable vscfi
Definition tri7box.F:449
tri7box::xfi
type(real_pointer2), dimension(:), allocatable xfi
Definition tri7box.F:459
tri7box::kinfi
type(int_pointer), dimension(:), allocatable kinfi
Definition tri7box.F:440
tri7box::nlskyfi
integer, dimension(:), allocatable nlskyfi
Definition tri7box.F:512
tri7box::fthefi
type(real_pointer), dimension(:), allocatable fthefi
Definition tri7box.F:449
tri7box::pene_oldfi
type(real_pointer2), dimension(:), allocatable pene_oldfi
Definition tri7box.F:544
tri7box::nsnfi
type(int_pointer), dimension(:), allocatable nsnfi
Definition tri7box.F:440
tri7box::itafi
type(int_pointer), dimension(:), allocatable itafi
Definition tri7box.F:440
nl_solv
subroutine nl_solv(nddl, iddl, ndof, ikc, d, dr, nnz, iadk, jdik, diag_k, lt_k, f, nddli, iadi, jdii, diag_i, lt_i, itok, iadm, jdim, diag_m, lt_m, r02, dd, ddr, itask0, it, itc, ru0, rold, idiv, inprint, icprec, istop, e02, de0, eimp, inloc, nddl0, ls, u02, gap, itab, fr_elem, iad_elem, w_ddl, a, ar, v, ms, x, ipari, intbuf_tab, num_imp, ns_imp, ne_imp, nsrem, nsl, icont, graphe, fac_k, ipiv_k, nk, nmonv, imonv, monvol, igrsurf, fr_mv, volmon, ibfv, skew, xframe, mumps_par, cddlp, ind_imp, nbintc, intlist, newfront, isendto, irecvfrom, irbe3, lrbe3, ndiv, icont0, isign, fext, dg, dgr, dg0, dgr0, rfext, ls1, nodft, nodlt, irbe2, lrbe2, idiv0, relres, anew_stif)
Definition nl_solv.F:74
al_constraint1_hp
subroutine al_constraint1_hp(nddl0, nddl, iddl, ndof, ikc, dd, ddr, dg, dgr, di, dir, w_ddl, l_a, lamda, sw2, ier)
Definition nl_solv.F:1463
produt_u0
subroutine produt_u0(dd, ddr, norm2, weight)
Definition produt_v.F:2423
produt_v0
subroutine produt_v0(nddl, x, y, r)
Definition produt_v.F:944
cp_int_hp
subroutine cp_int_hp(n, x, xc)
Definition produt_v.F:3657
mortho_gs
subroutine mortho_gs(f_ddl, l_ddl, nddl, md_f, md_l, a, wddl, itask)
Definition produt_v.F:2692
mmv_lth
subroutine mmv_lth(nddl, iadm, jdim, diag_m, lt_m, v, z, f_ddl, l_ddl, itask)
Definition produt_v.F:3048
mav_lt_h
subroutine mav_lt_h(nddl, f_ddl, l_ddl, iadl, jdil, diag_k, lt_k, v, w)
Definition produt_v.F:1154
mmav_lth
subroutine mmav_lth(nddl, nddli, iadk, jdik, diag_k, lt_k, iadi, jdii, itok, lt_i, v, w, a, ar, ve, ms, x, d, dr, ndof, ipari, intbuf_tab, num_imp, ns_imp, ne_imp, nsrem, nsl, ibfv, skew, xframe, monvol, volmon, igrsurf, fr_mv, nmonv, imonv, ind_imp, xi_c, iupd, irbe3, lrbe3, irbe2, lrbe2, iadm, jdim, diag_m, lt_m, f_ddl, l_ddl, itask, v_w)
Definition produt_v.F:2960
vscal_h
subroutine vscal_h(f_ddl, l_ddl, v, s, itask)
Definition produt_v.F:2609
cp_real
subroutine cp_real(n, x, xc)
Definition produt_v.F:871
produt_vm
subroutine produt_vm(nddl0, nddl, iddl, ndof, ikc, dd, ddr, y, r, w_imp)
Definition produt_v.F:187
buf_dim1
subroutine buf_dim1(l1, lt)
Definition produt_v.F:973
mav_ltgh
subroutine mav_ltgh(nddl, iadl, jdil, diag_k, lt_k, v, w, f_ddl, l_ddl, itask, nddli)
Definition produt_v.F:2482
mav_mm
subroutine mav_mm(nd, md, a, b, itask)
Definition produt_v.F:2883
zero_ud
subroutine zero_ud(num, iddl, ndof, ikc, d, dr, ir)
Definition produt_v.F:293
mav_mn
subroutine mav_mn(nd, md, a, b, c, itask)
Definition produt_v.F:2792
mav_lt2
subroutine mav_lt2(nddl, nddli, iadl, jdil, diag_k, lt_k, iadi, jdii, itok, lt_i, v, w, monvol, volmon, x, igrsurf, nmonv, imonv, ndof, ipari, intbuf_tab, a, ar, d, ibfv, skew, xframe, ve, ms, num_imp, ns_imp, ne_imp, index2, xi_c, iupd, irbe3, lrbe3)
Definition produt_v.F:451
mav_lt
subroutine mav_lt(nddl, nnz, iadl, jdil, diag_k, lt_k, v, w)
Definition produt_v.F:340
mav_lt1
subroutine mav_lt1(nddl, nnz, iadl, jdil, diag_k, lt_k, v, w)
Definition produt_v.F:399
produt_u
subroutine produt_u(nddl0, nddl, iddl, ndof, ikc, dd, ddr, norm2, w_imp)
Definition produt_v.F:224
vscal_hp
subroutine vscal_hp(n, v, s)
Definition produt_v.F:3494
mav_lth
subroutine mav_lth(nddl, nddli, iadl, jdil, diag_k, lt_k, iadi, jdii, itok, lt_i, v, w, a, ar, ve, ms, x, d, dr, ndof, ipari, intbuf_tab, num_imp, ns_imp, ne_imp, nsrem, nsl, ibfv, skew, xframe, monvol, volmon, igrsurf, fr_mv, nmonv, imonv, index2, xi_c, iupd, irbe3, lrbe3, irbe2, lrbe2, f_ddl, l_ddl, itask)
Definition produt_v.F:1380
produt_vmh
subroutine produt_vmh(nddl0, nddl, iddl, ndof, ikc, dd, ddr, y, r, w_imp, f_ddl, l_ddl, itask)
Definition produt_v.F:1633
mav_ltp
subroutine mav_ltp(nddl, nddli, iadl, jdil, diag_k, lt_k, iadi, jdii, itok, lt_i, v, w, a, ar, ve, ms, x, d, dr, ndof, ipari, intbuf_tab, num_imp, ns_imp, ne_imp, nsrem, nsl, ibfv, skew, xframe, monvol, volmon, igrsurf, fr_mv, nmonv, imonv, index2, xi_c, iupd, irbe3, lrbe3, irbe2, lrbe2)
Definition produt_v.F:566
d_to_u
subroutine d_to_u(nddl0, nddl, iddl, ndof, ikc, d, dr, u)
Definition produt_v.F:154
produt_v_loc
subroutine produt_v_loc(nddl, x, y, r)
Definition produt_v.F:67
mav_liuh
subroutine mav_liuh(f_ddl, l_ddl, iadi, jdii, itok, lt_i, work_ii, v, w, itask)
Definition produt_v.F:3186
mav_lui_h
subroutine mav_lui_h(f_ddl, l_ddl, v, w)
Definition produt_v.F:2523
cp_ifront
subroutine cp_ifront(iflag, ipari, islen7, irlen7, islen11, irlen11, islen17, irlen17, irlen7t, islen7t, irlen20, islen20, irlen20t, islen20t, irlen20e, islen20e, newfront)
Definition produt_v.F:1854
produt_w
subroutine produt_w(nddl, x, y, w, r)
Definition produt_v.F:106
cp_real_hp
subroutine cp_real_hp(n, x, xc)
Definition produt_v.F:3624
mav_zi
subroutine mav_zi(ii, nddl, nnz, iadl, jdil, diag_k, lt_k, nnzz, iadm, jdim, lt_m, w)
Definition produt_v.F:676
vaxpy_h
subroutine vaxpy_h(f_ddl, l_ddl, a, b, s, itask)
Definition produt_v.F:2647
zeror_hp
subroutine zeror_hp(x, n)
Definition produt_v.F:3688
buf_dim
subroutine buf_dim(l1, l2, l3, l4)
Definition produt_v.F:818
produt_h
subroutine produt_h(f_ddl, l_ddl, x, y, w, r, itask)
Definition produt_v.F:1533
produt_uhp0
subroutine produt_uhp0(dd, ddr, norm2, weight)
Definition produt_v.F:3435
mam_nm
subroutine mam_nm(f_nd, l_nd, nd, md, a, b, c, wddl, itask)
Definition produt_v.F:2840
mav_nm
subroutine mav_nm(f_nd, l_nd, nd, md, a, b, c, wddl, itask)
Definition produt_v.F:2749
mav_lu_h
subroutine mav_lu_h(nddl, f_ddl, l_ddl, iadl, jdil, diag_k, lt_k, v, w)
Definition produt_v.F:1792
mmv_lh
subroutine mmv_lh(nddl, iadm, jdim, diag_m, lt_m, v, z, f_ddl, l_ddl, itask)
Definition produt_v.F:3113
produt_uhp
subroutine produt_uhp(nddl0, nddl, iddl, ndof, ikc, dd, ddr, norm2, w_imp)
Definition produt_v.F:3359
produt_uhp2
subroutine produt_uhp2(nddl0, nddl, iddl, ndof, ikc, d1, d1r, d2, d2r, norm2, w_imp)
Definition produt_v.F:3398
produt_uh2
subroutine produt_uh2(nddl0, nddl, iddl, ndof, ikc, d1, d1r, d2, d2r, norm2, w_imp, f_ddl, l_ddl, itask)
Definition produt_v.F:1741
produt_v
subroutine produt_v(nddl, x, y, r)
Definition produt_v.F:33
mav_z
subroutine mav_z(ii, nddl, nnz, iadl, jdil, diag_k, lt_k, nnzm, iadm, jdim, lt_m, w)
Definition produt_v.F:749
cp_dm
subroutine cp_dm(numgeo, geo, igeo, dmcp, iflag)
Definition produt_v.F:2563
produt_u2
subroutine produt_u2(nddl0, nddl, iddl, ndof, ikc, d1, d1r, d2, d2r, norm2, w_imp)
Definition produt_v.F:262
produt_uh
subroutine produt_uh(nddl0, nddl, iddl, ndof, ikc, dd, ddr, norm2, w_imp, f_ddl, l_ddl, itask)
Definition produt_v.F:1687
produt_hp
subroutine produt_hp(nddl, x, y, w, r)
Definition produt_v.F:3252
mav_lth0
subroutine mav_lth0(nddl, nddli, iadl, jdil, diag_k, lt_k, iadi, jdii, itok, lt_i, v, w, a, ar, ve, ms, x, d, dr, ndof, ipari, intbuf_tab, num_imp, ns_imp, ne_imp, nsrem, nsl, ibfv, skew, xframe, monvol, volmon, igrsurf, fr_mv, nmonv, imonv, index2, xi_c, iupd, irbe3, lrbe3, irbe2, lrbe2, f_ddl, l_ddl, itask)
Definition produt_v.F:1227
vscaly_hp
subroutine vscaly_hp(n, v, y, s)
Definition produt_v.F:3536
vaxpy_hp
subroutine vaxpy_hp(n, v, y, s)
Definition produt_v.F:3580
cp_int
subroutine cp_int(n, x, xc)
Definition produt_v.F:916
cp_impbuf
subroutine cp_impbuf(iflag, elbuf, elbuf_c, bufmat, bufmat_c, fsav, volmon, partsav, intbuf_tab, intbuf_tab_c, ipari, islen7, irlen7, islen11, irlen11, islen17, irlen17, irlen7t, islen7t, irlen20, islen20, irlen20t, islen20t, irlen20e, islen20e, newfront, elbuf_tab, elbuf_imp, iparg)
Definition produt_v.F:1025
produt_vmhp
subroutine produt_vmhp(nddl0, nddl, iddl, ndof, ikc, dd, ddr, y, r, w_imp)
Definition produt_v.F:3321
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:889
arret
subroutine arret(nn)
Definition arret.F:87
my_barrier
subroutine my_barrier
Definition machine.F:31
startime
subroutine startime(event, itask)
Definition timer.F:93
condens_b
subroutine condens_b(nddl, ikc, b)
Definition upd_glob_k.F:400