OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
imp_pcg.F File Reference
#include "implicit_f.inc"
#include "comlock.inc"
#include "com04_c.inc"
#include "units_c.inc"
#include "task_c.inc"
#include "impl1_c.inc"

Go to the source code of this file.

Functions/Subroutines

integer function crit_stop (it, r2, it_max, tol)
subroutine imp_isave (nddl, x, r, diag_k, diag_m, nnz, lt_k, lt_k0, lt_m, lt_m0, iadk, jdik, iadk0, jdik0, iadm, jdim, iadm0, jdim0, nnzm, tols, nlim, itol, eps_m, iprec)
subroutine imp_isave2 (nddl, x, diag_k, nnz, lt_k, iadk, jdik, lt_k0, iadk0, jdik0)
subroutine imp_rsave (nddl, x, r)
subroutine imp_pcgh (iprec, nddl, nnz, iadk, jdik, diag_k, lt_k, nddli, itok, iadi, jdii, lt_i, nnzm, iadm, jdim, diag_m, lt_m, x, r, itol, tol, p, z, y, itask, iprint, n_max, eps_m, 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, graphe, iad_elem, fr_elem, itab, insolv, itn, fac_k, ipiv_k, nk, mumps_par, cddlp, isolv, idsc, iddl, ikc, inloc, ind_imp, xi_c, r0, nddli_g, intp_c, irbe3, lrbe3, irbe2, lrbe2)
subroutine pupd (nddl, nddli, itn)
subroutine nlim_mix (nddl, nddli, nlim)
logical function mixedsol ()
subroutine imp_inix (f_ddl, l_ddl, nddl, x, r, w_ddl, itask)
subroutine imp_pro_p (f_ddl, l_ddl, nddl, p, w_ddl, itask)
subroutine imp_inis (nd, f_nd, l_nd, npf, npl, s)
subroutine imp_updv2 (nddl, nddli, iadk, jdik, diag_k, lt_k, itok, iadi, jdii, lt_i, itask, w_ddl, a, ar, ve, 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, ms, xe, irbe3, lrbe3, irbe2, lrbe2, u_tmp, p, y, f_ddl, l_ddl, it, icheck, z, iadm, jdim, diag_m, lt_m)
subroutine imp_updv1 (r2, r2_old, rmax, proj_u, p, it, f_ddl, l_ddl)
subroutine imp_ppcgh (iprec, nddl, nnz, iadk, jdik, diag_k, lt_k, nddli, itok, iadi, jdii, lt_i, nnzm, iadm, jdim, diag_m, lt_m, x, r, itol, tol, p, z, y, itask, iprint, n_max, eps_m, 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, graphe, iad_elem, fr_elem, itab, insolv, itn, fac_k, ipiv_k, nk, mumps_par, cddlp, isolv, idsc, iddl, ikc, inloc, ind_imp, xi_c, r0, nddli_g, intp_c, irbe3, lrbe3, irbe2, lrbe2)
subroutine imp_inist (nddl, nddli, iadk, jdik, diag_k, lt_k, itok, iadi, jdii, lt_i, itask, w_ddl, a, ar, ve, 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, ms, xe, irbe3, lrbe3, irbe2, lrbe2, iadm, jdim, diag_m, lt_m, f_ddl, l_ddl, v_w)
subroutine imp_updst (nddl, nddli, iadk, jdik, diag_k, lt_k, itok, iadi, jdii, lt_i, itask, w_ddl, a, ar, ve, 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, ms, xe, irbe3, lrbe3, irbe2, lrbe2, u, p, y, iadm, jdim, diag_m, lt_m, f_ddl, l_ddl)
subroutine imp_inisi (nddl, iadk, jdik, diag_k, lt_k, nddli, itok, iadi, jdii, lt_i, nnzm, iadm, jdim, diag_m, lt_m, r, p, y, 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, z, iddl, ikc, inloc, ind_imp, xi_c, irbe3, lrbe3, irbe2, lrbe2, itask, w_ddl, f_ddl, l_ddl, sq_diag_m)

Function/Subroutine Documentation

◆ crit_stop()

integer function crit_stop ( integer it,
r2,
integer it_max,
tol )

Definition at line 31 of file imp_pcg.F.

32C-----------------------------------------------
33C I m p l i c i t T y p e s
34C-----------------------------------------------
35#include "implicit_f.inc"
36C-----------------------------------------------
37C D u m m y A r g u m e n t s
38C-----------------------------------------------
39 INTEGER IT,IT_MAX
40 my_real
41 . r2,tol
42C-----------------------------------------------
43C L o c a l V a r i a b l e s
44C-----------------------------------------------
45C-----------------------------
46 IF (it>=it_max) THEN
47 crit_stop = 0
48 RETURN
49 ENDIF
50 IF (r2<=tol) THEN
51 crit_stop = 0
52 ELSE
53 crit_stop = 1
54 ENDIF
55C--------------------------------------------
56 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
crit_stop
integer function crit_stop(it, r2, it_max, tol)
Definition imp_pcg.F:32

◆ imp_inis()

subroutine imp_inis ( integer nd,
integer f_nd,
integer l_nd,
integer npf,
integer npl,
s )

Definition at line 2657 of file imp_pcg.F.

2658C-----------------------------------------------
2659C I m p l i c i t T y p e s
2660C-----------------------------------------------
2661#include "implicit_f.inc"
2662C-----------------------------------------------
2663C D u m m y A r g u m e n t s
2664C-----------------------------------------------
2665 INTEGER ND,F_ND ,L_ND,NPF, NPL
2666 my_real
2667 . s(nd,*),aleat
2668 EXTERNAL aleat
2669C-----------------------------------------------
2670c FUNCTION: initialization of [S]
2671c
2672c Note:
2673c ARGUMENTS: (I: input, O: output, IO: input * output, W: workspace)
2674c
2675c TYPE NAME FUNCTION
2676c I F_ND ,L_ND - equation dimension divised by Nthead
2677c I NPF,NPL - projection vector number (first to last)
2678c I ND - equation dimension
2679c I S(ND,NPV) - S-Matrix
2680C-----------------------------------------------
2681C L o c a l V a r i a b l e s
2682C-----------------------------------------------
2683 INTEGER I,J,M,INORM
2684C---------------------
2685 DO j=npf,npl
2686 DO i=f_nd ,l_nd
2687 s(i,j)=aleat()
2688 ENDDO
2689 ENDDO
2690C
2691 RETURN

◆ imp_inisi()

subroutine imp_inisi ( integer nddl,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_k,
lt_k,
integer nddli,
integer, dimension(*) itok,
integer, dimension(*) iadi,
integer, dimension(*) jdii,
lt_i,
integer nnzm,
integer, dimension(*) iadm,
integer, dimension(*) jdim,
diag_m,
lt_m,
r,
p,
y,
a,
ar,
ve,
ms,
xe,
d,
dr,
integer, dimension(*) ndof,
integer, dimension(*) ipari,
type(intbuf_struct_), dimension(*) intbuf_tab,
integer, dimension(*) num_imp,
integer, dimension(*) ns_imp,
integer, dimension(*) ne_imp,
integer nsrem,
integer nsl,
integer nmonv,
integer, dimension(*) imonv,
integer, dimension(*) monvol,
type (surf_), dimension(nsurf) igrsurf,
volmon,
integer, dimension(*) fr_mv,
integer, dimension(*) ibfv,
skew,
xframe,
z,
integer, dimension(*) iddl,
integer, dimension(*) ikc,
integer, dimension(*) inloc,
integer, dimension(*) ind_imp,
xi_c,
integer, dimension(*) irbe3,
integer, dimension(*) lrbe3,
integer, dimension(*) irbe2,
integer, dimension(*) lrbe2,
integer itask,
integer, dimension(*) w_ddl,
integer f_ddl,
integer l_ddl,
sq_diag_m )

Definition at line 3902 of file imp_pcg.F.

3916C-----------------------------------------------
3917C M o d u l e s
3918C-----------------------------------------------
3919 USE imp_pcg_proj
3920 USE intbufdef_mod
3921 USE groupdef_mod
3922C-----------------------------------------------
3923C I m p l i c i t T y p e s
3924C-----------------------------------------------
3925#include "implicit_f.inc"
3926C-----------------------------------------------
3927C C o m m o n B l o c k s
3928C-----------------------------------------------
3929#include "com04_c.inc"
3930#include "impl1_c.inc"
3931C-----------------------------------------------
3932C D u m m y A r g u m e n t s
3933C-----------------------------------------------
3934 INTEGER NDDL ,IADK(*) ,JDIK(*),
3935 . NDDLI ,ITOK(*) ,IADI(*),JDII(*),
3936 . NNZM ,IADM(*),JDIM(*),ITASK,
3937 . W_DDL(*),IBFV(*),IRBE3(*) ,LRBE3(*),
3938 . IRBE2(*) ,LRBE2(*),F_DDL ,L_DDL
3939 INTEGER NDOF(*),NE_IMP(*),NSREM ,NSL,
3940 . IPARI(*) ,NUM_IMP(*),NS_IMP(*) ,IND_IMP(*)
3941 INTEGER NMONV,IMONV(*),MONVOL(*),FR_MV(*)
3942 INTEGER IDDL(*), IKC(*), INLOC(*)
3943 my_real
3944 . diag_k(*), lt_k(*) ,diag_m(*),lt_m(*) ,
3945 . p(*) ,r(*) ,y(*),lt_i(*) ,xi_c(*),z(*),sq_diag_m(*)
3946 my_real
3947 . a(3,*),ar(3,*),ve(3,*),d(3,*),dr(3,*),xe(3,*),
3948 . ms(*),volmon(*),skew(*) ,xframe(*)
3949
3950 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
3951 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
3952C-----------------------------------------------
3953c FUNCTION: initialization of S,by M_VS PCG iterations
3954c
3955c Note:
3956c ARGUMENTS: (I: input, O: output, IO: input * output, W: workspace)
3957c
3958c TYPE NAME FUNCTION
3959c I NDDL,NNZ - dimension of [K] and number of non zero (strict triangular)
3960c I IADK,JDIK - indice arrays for compressed row(col.) format of [K]
3961c I DIAG_K(NDDL) - diagonal terms of [K]
3962c I LT_K(NNZ) - strict triangular of [K]
3963c O Proj_S(NDDL,M_VS) - [S] reduced small Eigenvectors
3964c IO P,Y,X,R(NDDL) -work vectors
3965C-----------------------------------------------
3966C L o c a l V a r i a b l e s
3967C-----------------------------------------------
3968 INTEGER I,J,IT,IP,NLIM,ND,IUPD,IPRI,IERROR,NNZI,M,
3969 . F_DDLI,L_DDLI,INFO,LW,INORM,NPV,ITP
3970 my_real
3971 . alpha,beta, g0,g1,s
3972 my_real
3973 . aleat
3974 EXTERNAL aleat
3975C---------------------
3976 IF (npcgpv >=0.OR.ncg_run>0) RETURN
3977C
3978 npv=min(nddl-1,m_vs)
3979C---IPRO_S0=1 : alertory updated w/ 1 vector x
3980C---IPRO_S0=2 : ini S w/ first p vectors updated w/ 2 vectors p,x
3981C---IPRO_S0=3 : alertory ini S vectors updated w/ 2 vectors p,x (p<-RR_max)
3982C---------------------
3983 iupd = 0
3984 IF (ipro_s0 > 1) THEN
3985C------seems more stable-----
3986 DO i=f_ddl,l_ddl
3987 r(i) = aleat()
3988 ENDDO
3989C----------------------
3990 CALL my_barrier
3991C---------------------
3992 DO i = f_ddl,l_ddl
3993 p(i) = r(i)
3994 ENDDO
3995 CALL produt_h(f_ddl ,l_ddl ,r ,r ,w_ddl , g0 ,itask )
3996c
3997 DO itp=1,npv
3998 CALL mmav_lth(
3999 1 nddl ,nddli ,iadk ,jdik ,diag_k,
4000 2 lt_k ,iadi ,jdii ,itok ,lt_i ,
4001 3 p ,y ,a ,ar ,
4002 5 ve ,ms ,xe ,d ,dr ,
4003 6 ndof ,ipari ,intbuf_tab ,num_imp,
4004 7 ns_imp,ne_imp,nsrem ,nsl ,ibfv ,
4005 8 skew ,xframe,monvol,volmon,igrsurf ,
4006 9 fr_mv,nmonv ,imonv ,ind_imp,
4007 a xi_c ,iupd ,irbe3 ,lrbe3 ,irbe2 ,
4008 b lrbe2 ,iadm ,jdim ,sq_diag_m,lt_m ,
4009 c f_ddl ,l_ddl ,itask ,z )
4010C----------------------
4011 CALL my_barrier
4012C---------------------
4013C---------------------
4014 CALL produt_h(f_ddl ,l_ddl ,p ,y ,w_ddl , s ,itask )
4015C---------------------
4016 alpha = g0/s
4017C----------------------
4018 CALL my_barrier
4019C---------------------
4020 DO i=f_ddl,l_ddl
4021 r(i) = r(i) - alpha*y(i)
4022 ENDDO
4023C----------------------
4024 CALL my_barrier
4025C---------------------
4026 CALL produt_h( f_ddl ,l_ddl ,r ,r ,w_ddl , g1 ,itask )
4027C---------------------
4028 beta=g1/g0
4029 g0 = g1
4030C----------------------
4031 CALL my_barrier
4032C---------------------
4033 DO i=f_ddl,l_ddl
4034 p(i) = r(i) + beta*p(i)
4035 ENDDO
4036C----------------------
4037 CALL my_barrier
4038C---------------------
4039 DO i=f_ddl,l_ddl
4040 proj_s(i,itp) = p(i)
4041 ENDDO
4042C----------------------
4043 CALL my_barrier
4044C---------------------
4045 END DO !ITP=1,NPC
4046 ELSE
4047 CALL imp_inis(nddl ,f_ddl ,l_ddl ,1 ,npv ,proj_s )
4048C----------------------
4049 CALL my_barrier
4050C---------------------
4051 END IF !(IPRO_S0 > 1) THEN
4052C--------matrix GS orthonalization and normalized
4053 CALL mortho_gs(f_ddl ,l_ddl ,nddl ,1 ,npv ,
4054 . proj_s ,w_ddl ,itask )
4055C
4056 RETURN
alpha
#define alpha
Definition eval.h:35
imp_inis
subroutine imp_inis(nd, f_nd, l_nd, npf, npl, s)
Definition imp_pcg.F:2658
min
#define min(a, b)
Definition macros.h:20
groupdef_mod
Definition groupdef_mod.F:662
imp_pcg_proj
Definition impbufdef_mod.F:646
imp_pcg_proj::m_vs
integer m_vs
Definition impbufdef_mod.F:648
imp_pcg_proj::ncg_run
integer ncg_run
Definition impbufdef_mod.F:648
mortho_gs
subroutine mortho_gs(f_ddl, l_ddl, nddl, md_f, md_l, a, wddl, itask)
Definition produt_v.F:2692
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
produt_h
subroutine produt_h(f_ddl, l_ddl, x, y, w, r, itask)
Definition produt_v.F:1533
my_barrier
subroutine my_barrier
Definition machine.F:31

◆ imp_inist()

subroutine imp_inist ( integer nddl,
integer nddli,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_k,
lt_k,
integer, dimension(*) itok,
integer, dimension(*) iadi,
integer, dimension(*) jdii,
lt_i,
integer itask,
integer, dimension(*) w_ddl,
a,
ar,
ve,
d,
dr,
integer, dimension(*) ndof,
integer, dimension(*) ipari,
type(intbuf_struct_), dimension(*) intbuf_tab,
integer, dimension(*) num_imp,
integer, dimension(*) ns_imp,
integer, dimension(*) ne_imp,
integer nsrem,
integer nsl,
integer nmonv,
integer, dimension(*) imonv,
integer, dimension(*) monvol,
type (surf_), dimension(nsurf) igrsurf,
volmon,
integer, dimension(*) fr_mv,
integer, dimension(*) ibfv,
skew,
xframe,
integer, dimension(*) ind_imp,
xi_c,
ms,
xe,
integer, dimension(*) irbe3,
integer, dimension(*) lrbe3,
integer, dimension(*) irbe2,
integer, dimension(*) lrbe2,
integer, dimension(*) iadm,
integer, dimension(*) jdim,
diag_m,
lt_m,
integer f_ddl,
integer l_ddl,
v_w )

Definition at line 3617 of file imp_pcg.F.

3629C-----------------------------------------------
3630C M o d u l e s
3631C-----------------------------------------------
3632 USE imp_pcg_proj
3633 USE intbufdef_mod
3634 USE groupdef_mod
3635C-----------------------------------------------
3636C I m p l i c i t T y p e s
3637C-----------------------------------------------
3638#include "implicit_f.inc"
3639C-----------------------------------------------
3640C C o m m o n B l o c k s
3641C-----------------------------------------------
3642#include "com04_c.inc"
3643#include "impl1_c.inc"
3644#include "units_c.inc"
3645C-----------------------------------------------
3646C D u m m y A r g u m e n t s
3647C-----------------------------------------------
3648 INTEGER NDDL ,IADK(*) ,JDIK(*), NDDLI ,ITOK(*) ,IADI(*),JDII(*),
3649 . ITASK,W_DDL(*),IBFV(*),IRBE3(*) ,LRBE3(*), IRBE2(*) ,LRBE2(*),F_DDL,L_DDL,IADM(*) ,JDIM(*)
3650 INTEGER NDOF(*),NE_IMP(*),NSREM ,NSL,IPARI(*) ,NUM_IMP(*),NS_IMP(*) ,IND_IMP(*)
3651 INTEGER NMONV,IMONV(*),MONVOL(*),FR_MV(*)
3652 my_real diag_k(*), lt_k(*),lt_i(*) ,xi_c(*),diag_m(*), lt_m(*)
3653 my_real a(3,*),ar(3,*),ve(3,*),d(3,*),dr(3,*),xe(3,*),ms(*),volmon(*),skew(*) ,xframe(*),v_w(*)
3654
3655 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
3656 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
3657C-----------------------------------------------
3658c FUNCTION: initialization of S,T of Projection taking into account to [M] preconditioner
3659c
3660c Note:
3661c ARGUMENTS: (I: input, O: output, IO: input * output, W: workspace)
3662c
3663c TYPE NAME FUNCTION
3664c I NDDL,NNZ - dimension of [K] and number of non zero (strict triangular)
3665c I IADK,JDIK - indice arrays for compressed row(col.) format of [K]
3666c I DIAG_K(NDDL) - diagonal terms of [K]
3667c I LT_K(NNZ) - strict triangular of [K]
3668c O Proj_S(NDDL,M_VS) - [S] reduced small Eigenvectors
3669c O Proj_T(NDDL,M_VS) - [T] =[K][S]
3670c I W1,W2 - work arrays
3671C-----------------------------------------------
3672C L o c a l V a r i a b l e s
3673C-----------------------------------------------
3674#if defined(MYREAL8) && !defined(WITHOUT_LINALG)
3675 CHARACTER JOBZ, UPLO
3676 INTEGER I,J,IT,IP,NLIM,ND,IUPD,IPRI,IERROR,NNZI,M,
3677 . F_DDLI,L_DDLI,INFO,LW,INORM,M_VS1
3678 my_real
3679 . work(3*m_vs+3),w(m_vs+1)
3680CC---------------------
3681C IF (NPCGPV >=0) RETURN
3682C----------------------
3683C CALL MY_BARRIER
3684C---------------------
3685 IF (ncg_run==0) THEN
3686 m_vs1 =m_vs
3687 ELSE
3688 m_vs1 =m_vs+1
3689 END IF
3690 IF (itask==0) npcgpv = m_vs
3691C----------------------
3692 CALL my_barrier
3693C---------------------
3694C---------------------
3695C T=[K][S]
3696C---------------------
3697 iupd = 0
3698 DO m = 1,m_vs1
3699 CALL mmav_lth(
3700 1 nddl ,nddli ,iadk ,jdik ,diag_k,
3701 2 lt_k ,iadi ,jdii ,itok ,lt_i ,
3702 3 proj_s(1,m),proj_t(1,m),a ,ar ,
3703 5 ve ,ms ,xe ,d ,dr ,
3704 6 ndof ,ipari ,intbuf_tab ,num_imp,
3705 7 ns_imp,ne_imp,nsrem ,nsl ,ibfv ,
3706 8 skew ,xframe,monvol,volmon,igrsurf ,
3707 9 fr_mv,nmonv ,imonv ,ind_imp,
3708 a xi_c ,iupd ,irbe3 ,lrbe3 ,irbe2 ,
3709 b lrbe2 ,iadm ,jdim ,diag_m,lt_m ,
3710 c f_ddl ,l_ddl ,itask ,v_w )
3711C----------------------
3712 CALL my_barrier
3713C---------------------
3714 END DO !M = 1,M_VS1
3715C----------------------
3716C [m0]=[S]^t[S]
3717C---------------------
3718C CALL MAM_NM(F_DDL ,L_DDL ,NDDL ,NPCGPV ,PROJ_S ,PROJ_S ,P_M0 ,WDDL , ITASK )
3719C----------------------
3720C [k0]=[S]^t[T]
3721C---------------------
3722 CALL mam_nm(f_ddl ,l_ddl ,nddl ,m_vs1 ,proj_s ,
3723 . proj_t ,proj_k ,w_ddl ,itask )
3724C----------------------
3725 CALL my_barrier
3726C---------------------
3727C ([k0]-lamda(i)[m0])*phi(i)=0; Rather ([m0]-lamda(i)[I])*phi(i)=0
3728C---------------------
3729 IF (itask==0) THEN
3730 jobz='v'
3731 UPLO='u'
3732 LW=3*M_VS1
3733 CALL DSYEV(JOBZ, UPLO, M_VS1,PROJ_K, M_VS1, W, WORK, LW, INFO)
3734C [S]<-[S][phi]
3735C---------------------
3736 CALL MAV_MM(NDDL ,M_VS1 ,PROJ_S ,PROJ_K ,ITASK )
3737C----------------------
3738C [T]<-[T][phi]
3739C---------------------
3740 CALL MAV_MM(NDDL ,M_VS1 ,PROJ_T ,PROJ_K ,ITASK )
3741C----------------------
3742C [LAMDA]^-1<- 1.0/lamda(i)
3743C---------------------
3744 DO I=1,M_VS1
3745 PROJ_LA_1(I)= ONE/SIGN(MAX(EM20,ABS(W(I))),W(I))
3746 ENDDO
3747.AND. if (iline==1IMPDEB>0) then
3748 IF (NCG_RUN==0) THEN
3749 write(iout,*)'info,ini eigenvalue=',info,(ONE/PROJ_LA_1(I),I=1,M_VS1)
3750 ELSEIF (iline==1) THEN
3751 write(iout,*)'info,upd eigenvalue=',info,(ONE/PROJ_LA_1(I),I=1,M_VS1)
3752 END IF
3753 endif
3754 END IF !(ITASK==0) THEN
3755#else
3756 CALL ARRET(5)
3757#endif
3758 RETURN
mam_nm
subroutine mam_nm(f_nd, l_nd, nd, md, a, b, c, wddl, itask)
Definition produt_v.F:2840

◆ imp_inix()

subroutine imp_inix ( integer f_ddl,
integer l_ddl,
integer nddl,
x,
r,
integer, dimension(*) w_ddl,
integer itask )

Definition at line 2514 of file imp_pcg.F.

2515C-----------------------------------------------
2516C M o d u l e s
2517C-----------------------------------------------
2518 USE imp_pcg_proj
2519C-----------------------------------------------
2520C I m p l i c i t T y p e s
2521C-----------------------------------------------
2522#include "implicit_f.inc"
2523C-----------------------------------------------
2524C C o m m o n B l o c k s
2525C-----------------------------------------------
2526#include "impl1_c.inc"
2527C-----------------------------------------------
2528C D u m m y A r g u m e n t s
2529C-----------------------------------------------
2530 INTEGER F_DDL,L_DDL,NDDL,ITASK,W_DDL(*)
2531 my_real
2532 . x(*), r(*)
2533C-----------------------------------------------
2534c FUNCTION: initialization of X0=[S][LAMDA]^-1[S]^t{R}
2535c
2536c Note:
2537c ARGUMENTS: (I: input, O: output, IO: input * output, W: workspace)
2538c
2539c TYPE NAME FUNCTION
2540c I NDDL - equation dimension
2541c I NPV - projection vector number
2542c I W_DDL(*) - itag for each id of subdomains
2543c I F_ND,L_ND,ITASK - id in each ITASK:thread id (//)
2544c I R(NDDL) - right-hand vector
2545c O X(NDDL) - X0
2546C-----------------------------------------------
2547C L o c a l V a r i a b l e s
2548C-----------------------------------------------
2549 INTEGER I,J,M,NPV
2550C----------------------
2551 IF (npcgpv == 0) RETURN
2552 npv = npcgpv
2553C----------------------
2554C {W}=[S]^t{R}
2555C---------------------
2556 CALL mav_nm(f_ddl,l_ddl,nddl ,npv ,proj_s ,
2557 . r ,proj_w,w_ddl,itask )
2558C----------------------
2559 CALL my_barrier
2560C---------------------
2561C [LAMDA]^-1{W}
2562C---------------------
2563 IF (itask ==0) THEN
2564 DO i=1,npv
2565 proj_w(i)=proj_w(i)*proj_la_1(i)
2566 ENDDO
2567C---------------------
2568C {X0}=[S]{W}
2569C---------------------
2570 CALL mav_mn(nddl ,npv ,proj_s ,proj_w ,x ,itask )
2571C----------------------
2572 END IF !(ITASK ==0) THEN
2573C----------------------
2574 RETURN
mav_mn
subroutine mav_mn(nd, md, a, b, c, itask)
Definition produt_v.F:2792
mav_nm
subroutine mav_nm(f_nd, l_nd, nd, md, a, b, c, wddl, itask)
Definition produt_v.F:2749

◆ imp_isave()

subroutine imp_isave ( integer nddl,
x,
r,
diag_k,
diag_m,
integer nnz,
lt_k,
lt_k0,
lt_m,
lt_m0,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
integer, dimension(*) iadk0,
integer, dimension(*) jdik0,
integer, dimension(*) iadm,
integer, dimension(*) jdim,
integer, dimension(*) iadm0,
integer, dimension(*) jdim0,
integer nnzm,
tols,
integer nlim,
integer itol,
eps_m,
integer iprec )

Definition at line 63 of file imp_pcg.F.

69C-----------------------------------------------
70C I m p l i c i t T y p e s
71C-----------------------------------------------
72#include "implicit_f.inc"
73C-----------------------------------------------
74C D u m m y A r g u m e n t s
75C-----------------------------------------------
76 my_real
77 . x(*), r(*), tols, eps_m,
78 . diag_k(*), diag_m(*),
79 . lt_k(*), lt_k0(*), lt_m(*), lt_m0(*)
80 INTEGER NDDL, NNZ, NNZM, NLIM, ITOL, IPREC,
81 . IADK(*), JDIK(*), IADK0(*), JDIK0(*),
82 . IADM(*), JDIM(*), IADM0(*), JDIM0(*)
83C-----------------------------------------------
84C L o c a l V a r i a b l e s
85C-----------------------------------------------
86 OPEN(66,file="input_mat",form="unformatted")
87 WRITE(66)NDDL,NNZ,NNZM,NLIM,ITOL,IPREC
88 WRITE(66)X(1:NDDL)
89 WRITE(66)R(1:NDDL)
90 WRITE(66)DIAG_K(1:NDDL)
91 WRITE(66)DIAG_M(1:NDDL)
92 WRITE(66)LT_K(1:NNZ)
93 WRITE(66)LT_K0(1:NNZ)
94 WRITE(66)LT_M(1:NNZM)
95 WRITE(66)LT_M0(1:NNZM)
96 WRITE(66)IADK(1:NDDL+1)
97 WRITE(66)JDIK(1:IADK(NDDL+1)-1)
98 WRITE(66)IADK0(1:NDDL+1)
99 WRITE(66)JDIK0(1:IADK0(NDDL+1)-1)
100 WRITE(66)IADM(1:NDDL+1)
101 WRITE(66)JDIM(1:IADM(NDDL+1)-1)
102 WRITE(66)IADM0(1:NDDL+1)
103 WRITE(66)JDIM0(1:IADM0(NDDL+1)-1)
104 WRITE(66)EPS_M,TOLS
105 RETURN

◆ imp_isave2()

subroutine imp_isave2 ( integer nddl,
x,
diag_k,
integer nnz,
lt_k,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
lt_k0,
integer, dimension(*) iadk0,
integer, dimension(*) jdik0 )

Definition at line 113 of file imp_pcg.F.

116C-----------------------------------------------
117C I m p l i c i t T y p e s
118C-----------------------------------------------
119#include "implicit_f.inc"
120C-----------------------------------------------
121C D u m m y A r g u m e n t s
122C-----------------------------------------------
123 my_real
124 . x(*),
125 . diag_k(*),
126 . lt_k(*),lt_k0(*)
127 INTEGER NDDL, NNZ,
128 . IADK(*), JDIK(*),IADK0(*), JDIK0(*)
129C-----------------------------------------------
130C L o c a l V a r i a b l e s
131C-----------------------------------------------
132 INTEGER I, J, K
133
134 OPEN(66,file="input_matA")
135 WRITE(66,*)nddl,nddl,nnz+nddl
136 DO i = 1, nddl
137 DO k = iadk(i), iadk(i+1)-1
138 j=jdik(k)
139 IF(j < i) THEN
140 WRITE(66,*)i,j,lt_k(k)
141 else
142 print*,'error1'
143 END IF
144 END DO
145 WRITE(66,*)i,i,diag_k(i)
146 DO k = iadk0(i), iadk0(i+1)-1
147 j=jdik0(k)
148 IF(j > i) THEN
149 WRITE(66,*)i,j,lt_k0(k)
150 else
151 print*,'error2'
152 END IF
153 END DO
154 END DO
155 OPEN(67,file="input_vecX")
156 WRITE(67,*)nddl
157 DO i = 1, nddl
158 WRITE(67,*)x(i)
159 END DO
160 RETURN

◆ imp_pcgh()

subroutine imp_pcgh ( integer iprec,
integer nddl,
integer nnz,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_k,
lt_k,
integer nddli,
integer, dimension(*) itok,
integer, dimension(*) iadi,
integer, dimension(*) jdii,
lt_i,
integer nnzm,
integer, dimension(*) iadm,
integer, dimension(*) jdim,
diag_m,
lt_m,
x,
r,
integer itol,
tol,
p,
z,
y,
integer itask,
integer iprint,
integer n_max,
eps_m,
f_x,
integer istop,
integer, dimension(*) w_ddl,
a,
ar,
ve,
ms,
xe,
d,
dr,
integer, dimension(*) ndof,
integer, dimension(*) ipari,
type(intbuf_struct_), dimension(*) intbuf_tab,
integer, dimension(*) num_imp,
integer, dimension(*) ns_imp,
integer, dimension(*) ne_imp,
integer nsrem,
integer nsl,
integer nmonv,
integer, dimension(*) imonv,
integer, dimension(*) monvol,
type (surf_), dimension(nsurf) igrsurf,
volmon,
integer, dimension(*) fr_mv,
integer, dimension(*) ibfv,
skew,
xframe,
type(prgraph), dimension(*) graphe,
integer, dimension(2,*) iad_elem,
integer, dimension(*) fr_elem,
integer, dimension(*) itab,
integer insolv,
integer itn,
fac_k,
integer, dimension(*) ipiv_k,
integer nk,
integer mumps_par,
integer, dimension(*) cddlp,
integer isolv,
integer idsc,
integer, dimension(*) iddl,
integer, dimension(*) ikc,
integer, dimension(*) inloc,
integer, dimension(*) ind_imp,
xi_c,
r0,
integer nddli_g,
integer intp_c,
integer, dimension(*) irbe3,
integer, dimension(*) lrbe3,
integer, dimension(*) irbe2,
integer, dimension(*) lrbe2 )

Definition at line 227 of file imp_pcg.F.

245C-----------------------------------------------
246C M o d u l e s
247C-----------------------------------------------
248 USE dsgraph_mod
249 USE imp_workh
250 USE imp_frk
251 USE imp_intm
252 USE message_mod
253 USE intbufdef_mod
254 USE groupdef_mod
255C-----------------------------------------------
256C I m p l i c i t T y p e s
257C-----------------------------------------------
258#include "implicit_f.inc"
259C-----------------------------------------------
260C C o m m o n B l o c k s
261C-----------------------------------------------
262#include "comlock.inc"
263#include "com04_c.inc"
264#include "units_c.inc"
265#include "task_c.inc"
266#if defined(MUMPS5)
267#include "dmumps_struc.h"
268#endif
269C-----------------------------------------------
270C D u m m y A r g u m e n t s
271C-----------------------------------------------
272C----------resol [K]{X}={F}---------
273 INTEGER NDDL ,NNZ ,ITOL,
274 . NDDLI ,ITOK(*) ,IADI(*),JDII(*),N_MAX,
275 . NNZM ,IPREC,ITASK,IPRINT,
276 . ISTOP,W_DDL(*),IBFV(*),INTP_C,IRBE3(*) ,LRBE3(*),
277 . IRBE2(*) ,LRBE2(*)
278 INTEGER NDOF(*),NE_IMP(*),NSREM ,NSL,
279 . IPARI(*) ,NUM_IMP(*),NS_IMP(*) ,IND_IMP(*)
280 INTEGER NMONV,IMONV(*),MONVOL(*),FR_MV(*)
281 INTEGER IAD_ELEM(2,*), FR_ELEM(*), ITAB(*),
282 . INSOLV, ITN, IPIV_K(*), NK, CDDLP(*), ISOLV, IDSC,
283 . IDDL(*), IKC(*), INLOC(*),NDDLI_G, MICID
284 my_real
285 . lt_i(*), tol, eps_m, f_x, xi_c(*)
286#if defined knf
287 INTEGER , target, intent(inout) ::
288 . IADK(NDDL+1) ,JDIK(NNZ), IADM(NDDL+1), JDIM(NNZM)
289 my_real , target, intent(inout) ::
290 . diag_k(nddl), lt_k(nnz) ,diag_m(nddl),lt_m(nnzm) ,x(nddl),
291 . p(nddl) ,z(nddl) ,r(nddl) ,y(nddl)
292#elif 1
293 INTEGER
294 . IADK(*) ,JDIK(*), IADM(*),JDIM(*)
295 my_real
296 . diag_k(*), lt_k(*) ,diag_m(*),lt_m(*) ,x(*),
297 . p(*) ,z(*) ,r(*) ,y(*)
298#endif
299 my_real
300 . a(3,*),ar(3,*),ve(3,*),d(3,*),dr(3,*),xe(3,*),
301 . ms(*),volmon(*),skew(*) ,xframe(*),fac_k(*),
302 . r0(*)
303 TYPE(PRGRAPH) :: GRAPHE(*)
304
305#ifdef MUMPS5
306 TYPE(DMUMPS_STRUC) MUMPS_PAR
307#else
308 ! Fake declaration as DMUMPS_STRUC is shipped with MUMPS
309 INTEGER MUMPS_PAR
310#endif
311
312 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
313 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
314C-----------------------------------------------
315C External function
316C-----------------------------------------------
317 LOGICAL MIXEDSOL
318 EXTERNAL mixedsol
319#ifdef MUMPS5
320C-----------------------------------------------
321C L o c a l V a r i a b l e s
322C-----------------------------------------------
323 INTEGER I,J,IT,IP,NLIM,ND,IERR,IPRI,IERROR,NNZI,LOC_PROC,
324 . ICK,ISAVE,N, TB
325 parameter(nd=4)
326 CHARACTER*4 EXIT
327 CHARACTER*11 WARR
328 my_real
329 . s , r2, r02,alpha,beta,g0,g1,rr,tols,toln,tols2
330 INTEGER CRIT_STOP,IUPD,IUPD0,F_DDL,L_DDL,IFLG,GPUR4R8,
331 . ITP,LCOM,NDDL1,LCOMI,LCOMX,K,
332 . NTAG(NDDL),IGATHER(NDDL)
333 EXTERNAL crit_stop
334
335 my_real
336 . anorm2,xnorm2,l_a,l_b2,l_b,a_old,b_old,tmp,r2_old,rmax
337 my_real
338 . cs,dbar, delta, denom, kcond,snprod,qrnorm,
339 . gamma, gbar, gmax, gmin, epsln,lqnorm,diag,cgnorm,
340 . oldb, rhs1, rhs2,sn, zbar, zl ,oldb2,tnorm2,eps(4)
341 double precision
342 . tt, tf
343C--------------GPU SPECIFIC--------------------------
344 real*4, DIMENSION(:),ALLOCATABLE ::
345 . lt_k_sp, lt_k0_sp, lt_m_sp, lt_m0_sp, diag_k_sp, diag_m_sp,
346 . x_sp, r_sp,w_sp, lt_i0_sp
347#if defined knf
348 my_real, DIMENSION(:),ALLOCATABLE :: wr
349 INTEGER, DIMENSION(:),ALLOCATABLE :: IFRTMP, TABLE, INDTMP
350#elif 1
351 my_real, DIMENSION(:),ALLOCATABLE :: w, wr, vgat, vsca, xir, yir
352 INTEGER, DIMENSION(:),ALLOCATABLE :: IFRTMP, INDEX, TABLE, INDTMP
353#endif
354
355c#if defined knf
356c!dec$ attributes offload: mic ::
357c & M_IADK, M_IADM, M_JDIM, M_JDIK
358c INTEGER, pointer, save, dimension(:) ::
359c . M_IADK, M_IADM, M_JDIM, M_JDIK
360c!dec$ attributes offload: mic ::
361c & M_LT_K, M_LT_M, M_DIAG_K, M_DIAG_M, M_P,
362c & M_X, M_R, M_Y, M_Z
363c DOUBLE PRECISION, pointer, save, dimension(:) ::
364c . M_LT_K, M_LT_M, M_DIAG_K, M_DIAG_M, M_P,
365c . M_X, M_R, M_Y, M_Z
366c#endif
367C--------------END GPU SPECIFIC----------------------
368 DATA EXIT /'WITH'/
369 DATA warr /'**WARRING**'/
370C--------------INITIALISATION--------------------------
371 isave=0
372C ISAVE=1 ! sauvegarde input/res
373C ISAVE=2 ! sauvegarde input simple
374#if defined knf
375 IF(nddli > 0)THEN
376 nnzi = iadi0(nddli+1)-iadi0(1)
377 ELSE
378 nnzi = 0
379 END IF
380C
381 lcom=0
382 lcomi=0
383 lcomx=0
384 IF(nspmd > 1)THEN
385 DO i = 1, nspmd
386 lcom = lcom + nd_fr(i)
387 END DO
388 IF(nddli_g > 0)THEN
389 ntag(1:nddl)=0
390 DO i = 1, nspmd
391 DO j = iad_sl(i),iad_sl(i+1)-1
392 k=iddl_sl(j)
393 IF(ntag(k)==0)THEN
394 lcomi=lcomi+1
395 ntag(k)=lcomi
396 igather(lcomi)=k-1
397 ENDIF
398 ENDDO
399 END DO
400 DO i = 1, nspmd
401 lcomx=lcomx+f_ddl+iad_srem(i+1)-iad_srem(i)+1
402 END DO
403 DO i=1,nddl_si
404 DO j =iad_si(i),iad_si(i+1)-1
405 k =jdi_si(j)
406 IF(ntag(k)==0)THEN
407 lcomi=lcomi+1
408 ntag(k)=lcomi
409 igather(lcomi)=k-1
410 ENDIF
411 ENDDO
412 ENDDO
413C
414 DO i=1,nddl_sl
415 k = iddl_sl(i)
416 IF(ntag(k)==0)THEN
417 lcomi=lcomi+1
418 ntag(k)=lcomi
419 igather(lcomi)=k-1
420 ENDIF
421C
422 DO j =iad_ss(i),iad_ss(i+1)-1
423 k =jdi_sl(j)
424 IF(ntag(k)==0)THEN
425 lcomi=lcomi+1
426 ntag(k)=lcomi
427 igather(lcomi)=k-1
428 ENDIF
429 ENDDO
430 ENDDO
431 END IF
432
433C adding stop test in case of SPMD and null domain => bad because need to communicate V
434C IF (NDDL==0 .AND. NNZ==0 .AND. LCOM==0 .AND. LCOMI==0
435C . .AND. LCOMX==0) RETURN
436 END IF
437#endif
438 loc_proc=ispmd+1
439C-----Istop=1 : NIT>=N_LIM+ RR>TOL
440C------X(I)=ZERO----******N_MAX,EPS_M a calculer avant----
441 f_ddl=1+itask*nddl/nthread
442 l_ddl=(itask+1)*nddl/nthread
443C
444 istop=0
445 nlim=n_max
446 CALL nlim_mix(n_max,nddli_g,nlim)
447 nlim=max(nlim,2)
448 tols=max(tol,eps_m)
449 ipri = iprint
450 IF (ispmd/=0) ipri = 0
451C--------
452C routine speciale pour sauvegarder les input
453 IF(isave==1)CALL imp_isave(
454 1 nddl,x,r,diag_k,diag_m,
455 2 nnz,lt_k,lt_k0,lt_m,lt_m0,
456 3 iadk,jdik,iadk0,jdik0,iadm,
457 4 jdim,iadm0,jdim0,nnzm,tols,
458 5 nlim,itol,eps_m,iprec)
459 IF(isave==2)CALL imp_isave2(
460 1 nddl,r,diag_k,nnz,lt_k,
461 3 iadk,jdik,lt_k0,iadk0,jdik0)
462C--------
463 IF (itask == 0) THEN
464 IF(ipri/=0)THEN
465 WRITE(iout,*)' *** BEGIN CONJUGATE GRADIENT ITERATION ***'
466 WRITE(iout,*)
467 ENDIF
468 IF(ipri<0)THEN
469 WRITE(istdo,*)' *** BEGIN CONJUGATE GRADIENT ITERATION ***'
470 WRITE(istdo,*)
471 ENDIF
472 END IF !(ITASK == 0) THEN
473 ip = iabs(ipri)
474 it=0
475C
476 iupd = 0
477 iupd0 = 0
478C----------------------
479 CALL my_barrier
480C---------------------
481C 1 : no gpu
482C -1 : nvidia dp
483C -3 : ocl dp
484cc NOGPU=-1
485cc IF(NOGPU==1)THEN
486C variable to switch between double (GPUR4R8=2)or single (GPUR4R8=1)precision GPU
487 gpur4r8=2
488
489#if !defined knf
490
491 CALL prec_solvh(iprec, itask ,
492 1 graphe,iad_elem,fr_elem,diag_k,lt_k ,
493 2 iadk ,jdik ,itab ,ipri,insolv ,
494 3 itn ,fac_k , ipiv_k, nk ,mumps_par,
495 4 cddlp ,isolv , idsc , iddl ,ikc ,
496 5 inloc ,ndof , nddl ,nnzm ,iadm ,
497 6 jdim ,diag_m , lt_m ,r ,z ,
498 7 f_ddl ,l_ddl )
499C----------------------
500 CALL my_barrier
501C---------------------
502 DO i = f_ddl,l_ddl
503 p(i) = z(i)
504 ENDDO
505 CALL produt_h(f_ddl ,l_ddl ,r ,z ,w_ddl , g0 ,itask )
506C---------------------
507 CALL mav_lth(
508 1 nddl ,nddli ,iadk ,jdik ,diag_k,
509 2 lt_k ,iadi ,jdii ,itok ,lt_i ,
510 3 p ,y ,a ,ar ,
511 5 ve ,ms ,xe ,d ,dr ,
512 6 ndof ,ipari ,intbuf_tab ,num_imp,
513 7 ns_imp,ne_imp,nsrem ,nsl ,ibfv ,
514 8 skew ,xframe,monvol,volmon,igrsurf ,
515 9 fr_mv,nmonv ,imonv ,ind_imp,
516 a xi_c ,iupd ,irbe3 ,lrbe3 ,irbe2 ,
517 b lrbe2 ,f_ddl ,l_ddl ,itask )
518C----------------------
519 CALL my_barrier
520C---------------------
521 CALL produt_h(f_ddl ,l_ddl ,p ,y ,w_ddl , s ,itask )
522C---------------------
523 IF (g0==zero) THEN
524 IF (itol>1) THEN
525 istop=-1
526 GOTO 200
527 ELSE
528 alpha = zero
529 ENDIF
530 ELSE
531 alpha = g0/s
532 ENDIF
533 tols2=tols*tols
534 IF (itol==1) THEN
535 CALL produt_h( f_ddl ,l_ddl ,r ,r ,w_ddl , r02 ,itask )
536C---------------------
537 r2 =r02
538 ELSEIF (itol==3) THEN
539C------ R2<TOL*TOL*ANORM2*XNORM2------
540 r02=abs(g0)
541 r2 =r02
542 l_a=one/alpha
543C L_B2=R02
544 tnorm2=l_a*l_a
545 anorm2=zero
546 xnorm2=zero
547 a_old=l_a
548 b_old=zero
549 oldb = sqrt(r02)
550 ELSEIF (itol==4) THEN
551 r02=alpha*alpha*abs(g0)
552 eps(1)=r02
553 r2=r02
554 ELSE
555 r02=abs(g0)
556 r2 =r02
557 ENDIF
558 IF (r02==zero) THEN
559 istop=-1
560 GOTO 200
561 ENDIF
562 toln=r02*tols2
563 IF(ipri/=0.AND.itask==0)THEN
564 rr = sqrt(r2)
565 IF(ipri<0) WRITE(istdo,1000)it,rr
566 WRITE(iout,1000)it,rr
567 ENDIF
568C-------pour etre coherent avec lanzos for linear
569C----------------------
570 CALL my_barrier
571C---------------------
572 it=1
573 DO i=f_ddl,l_ddl
574 x(i) = x(i) + alpha*p(i)
575 r(i) = r(i) - alpha*y(i)
576 ENDDO
577C----------------------
578 CALL my_barrier
579C---------------------
580 CALL prec_solvh(iprec, itask ,
581 1 graphe,iad_elem,fr_elem,diag_k,lt_k ,
582 2 iadk ,jdik ,itab ,ipri,insolv ,
583 3 itn ,fac_k , ipiv_k, nk ,mumps_par,
584 4 cddlp ,isolv , idsc , iddl ,ikc ,
585 5 inloc ,ndof , nddl ,nnzm ,iadm ,
586 6 jdim ,diag_m , lt_m ,r ,z ,
587 7 f_ddl ,l_ddl )
588C----------------------
589 CALL my_barrier
590C---------------------
591 CALL produt_h( f_ddl ,l_ddl ,r ,z ,w_ddl , g1 ,itask )
592C---------------------
593 beta=g1/g0
594 IF (itol==1) THEN
595 CALL produt_h( f_ddl ,l_ddl ,r ,r ,w_ddl , r2 ,itask )
596 ELSEIF (itol==3) THEN
597C------ R2<TOL*TOL*ANORM2*XNORM2------
598 r2=abs(g1)
599 l_b2=abs(beta)*a_old*a_old
600 l_b=sqrt(l_b2)
601 tnorm2=tnorm2+l_b2
602 b_old=beta
603C* INITIALIZE OTHER QUANTITIES.
604 gbar = l_a
605 dbar = l_b
606 rhs1 = oldb
607 rhs2 = zero
608 gmax = abs( l_a ) + eps_m
609 gmin = gmax
610 oldb2 = l_b2
611 oldb = l_b
612 ELSEIF (itol==4) THEN
613 r2=r02
614 ELSE
615 r2=abs(g1)
616 ENDIF
617 g0 = g1
618 IF (itol==3) toln=toln*tnorm2
619C----------------------
620 CALL my_barrier
621C---------------------
622#include "lockon.inc"
623 istop=crit_stop(it,r2,nlim,toln)
624#include "lockoff.inc"
625 IF(nddli_g>0.AND.intp_c==-1)iupd0 = -intp_c
626 DO WHILE (istop==1)
627 DO i=f_ddl,l_ddl
628 p(i) = z(i) + beta*p(i)
629 ENDDO
630 IF(iupd0>0.AND.it>nddli_g/2) iupd = iupd0
631C----------------------
632 CALL my_barrier
633C---------------------
634 CALL mav_lth(
635 1 nddl ,nddli ,iadk ,jdik ,diag_k,
636 2 lt_k ,iadi ,jdii ,itok ,lt_i ,
637 3 p ,y ,a ,ar ,
638 5 ve ,ms ,xe ,d ,dr ,
639 6 ndof ,ipari ,intbuf_tab ,num_imp,
640 7 ns_imp,ne_imp,nsrem ,nsl ,ibfv ,
641 8 skew ,xframe,monvol,volmon,igrsurf ,
642 9 fr_mv,nmonv ,imonv ,ind_imp,
643 a xi_c ,iupd ,irbe3 ,lrbe3 ,irbe2 ,
644 b lrbe2 ,f_ddl ,l_ddl ,itask )
645C----------------------
646 CALL my_barrier
647C---------------------
648 CALL produt_h(f_ddl ,l_ddl ,p ,y ,w_ddl , s ,itask )
649C---------------------
650 alpha=g0/s
651 DO i=f_ddl,l_ddl
652 x(i) = x(i) + alpha*p(i)
653 r(i) = r(i) - alpha*y(i)
654 ENDDO
655C----------------------
656 CALL my_barrier
657C---------------------
658 CALL prec_solvh(iprec, itask ,
659 1 graphe,iad_elem,fr_elem,diag_k,lt_k ,
660 2 iadk ,jdik ,itab ,ipri,insolv ,
661 3 itn ,fac_k , ipiv_k, nk ,mumps_par,
662 4 cddlp ,isolv , idsc , iddl ,ikc ,
663 5 inloc ,ndof , nddl ,nnzm ,iadm ,
664 6 jdim ,diag_m , lt_m ,r ,z ,
665 7 f_ddl ,l_ddl )
666C----------------------
667 CALL my_barrier
668C---------------------
669 CALL produt_h(f_ddl ,l_ddl ,r ,z ,w_ddl , g1 ,itask )
670C---------------------
671 beta=g1/g0
672 g0 = g1
673 IF (itol==1) THEN
674 CALL produt_h( f_ddl ,l_ddl ,r ,r ,w_ddl , r2 ,itask )
675 ELSEIF (itol==3) THEN
676 r2 =abs(g1)
677 s=one/alpha
678 l_a=s+b_old*a_old
679C----------L_B2 : beta(j-1)^2-A_OLD :1/alpha(j-1)-------
680 l_b2=abs(beta)*s*s
681 l_b=sqrt(l_b2)
682 a_old=s
683 b_old=beta
684 anorm2=tnorm2
685 tnorm2=tnorm2+l_a*l_a+oldb2+l_b2
686 gamma = sqrt( gbar*gbar + oldb2 )
687 cs = gbar / gamma
688 sn = oldb / gamma
689 delta = cs * dbar + sn * l_a
690 gbar = sn * dbar - cs * l_a
691 epsln = sn * l_b
692 dbar = - cs * l_b
693 zl = rhs1 / gamma
694 xnorm2 = xnorm2+zl*zl
695 gmax = max( gmax, gamma )
696 gmin = min( gmin, gamma )
697 rhs1 = rhs2 - delta * zl
698 rhs2 = - epsln * zl
699 toln=tols2*anorm2*xnorm2
700 oldb2 = l_b2
701 oldb = l_b
702 ELSEIF (itol==4) THEN
703 tmp=alpha*alpha*abs(g1)
704 IF (it>=nd) THEN
705 DO j=1,nd-1
706 eps(j)=eps(j+1)
707 ENDDO
708 eps(nd)=tmp
709 r2=zero
710 DO j=1,nd
711 r2=r2+eps(j)
712 ENDDO
713 ELSE
714 eps(it+1)=tmp
715 r2=r2+tmp
716 ENDIF
717 ELSE
718 r2 =abs(g1)
719 ENDIF
720C
721 IF(ipri/=0.AND.itask==0)THEN
722 IF(mod(it,ip)==0)THEN
723 rr = sqrt(r2/r02)
724 WRITE(iout,1001)it,rr
725 IF(ipri<0) WRITE(istdo,1001)it,rr
726 ENDIF
727 ENDIF
728C----------------------
729 CALL my_barrier
730C---------------------
731#include "lockon.inc"
732 istop=crit_stop(it,r2,nlim,toln)
733#include "lockoff.inc"
734
735 IF((iupd>0.AND.it==nlim).OR.
736 . (iupd==0.AND.istop/=1.AND.iupd0>0))THEN
737C------- re-iter with linear Kint------
738 iupd0 = 0
739 IF(iupd>0) iupd = 0
740#include "lockon.inc"
741 istop = 1
742#include "lockoff.inc"
743
744 nlim = nlim + nlim
745 DO i=f_ddl,l_ddl
746 x(i) = zero
747 ENDDO
748C----------------------
749 CALL my_barrier
750C---------------------
751 CALL mav_lth(
752 1 nddl ,nddli ,iadk ,jdik ,diag_k,
753 2 lt_k ,iadi ,jdii ,itok ,lt_i ,
754 3 x ,z ,a ,ar ,
755 5 ve ,ms ,xe ,d ,dr ,
756 6 ndof ,ipari ,intbuf_tab ,num_imp,
757 7 ns_imp,ne_imp,nsrem ,nsl ,ibfv ,
758 8 skew ,xframe,monvol,volmon,igrsurf ,
759 9 fr_mv,nmonv ,imonv ,ind_imp,
760 a xi_c ,iupd ,irbe3 ,lrbe3 ,irbe2 ,
761 b lrbe2 ,f_ddl ,l_ddl ,itask )
762C----------------------
763 CALL my_barrier
764C---------------------
765 DO i=f_ddl,l_ddl
766 r(i) = r0(i)-z(i)
767 ENDDO
768C----------------------
769 CALL my_barrier
770C---------------------
771 CALL prec_solvh(iprec, itask ,
772 1 graphe,iad_elem,fr_elem,diag_k,lt_k ,
773 2 iadk ,jdik ,itab ,ipri,insolv ,
774 3 itn ,fac_k , ipiv_k, nk ,mumps_par,
775 4 cddlp ,isolv , idsc , iddl ,ikc ,
776 5 inloc ,ndof , nddl ,nnzm ,iadm ,
777 6 jdim ,diag_m , lt_m ,r ,z ,
778 7 f_ddl ,l_ddl )
779C----------------------
780 CALL my_barrier
781C---------------------
782 CALL produt_h( f_ddl ,l_ddl ,r ,z ,w_ddl , g0 ,itask )
783 beta = zero
784C------ R2<TOL*TOL*ANORM2*XNORM2------
785 IF (itol==3) THEN
786 tnorm2=l_a*l_a
787 anorm2=zero
788 xnorm2=zero
789 a_old=zero
790 b_old=zero
791 l_b=zero
792C* INITIALIZE OTHER QUANTITIES.
793 gbar = l_a
794 dbar = zero
795 rhs1 = sqrt(r02)
796 rhs2 = zero
797 gmax = abs( l_a ) + eps_m
798 gmin = gmax
799 oldb2 = zero
800 oldb = l_b
801 ELSEIF (itol==4) THEN
802 DO j=1,nd
803 eps(j)=r02
804 ENDDO
805 ENDIF
806 ENDIF
807C----------------------
808 CALL my_barrier
809C---------------------
810 it = it +1
811 ENDDO
812 200 CONTINUE
813
814#elif defined knf
815 IF(gpur4r8==1)THEN
816 ELSEIF(gpur4r8==2)THEN
817 IF(itask==0)THEN
818C Code MIC simple precision
819
820C debut code specifique MIC double precision
821CAD
822CAD
823CAD DIRECTIVES POUR MIC
824CAD
825C init MIC
826 CALL mic_init(
827 . nspmd,loc_proc,l_spmd(loc_proc),idevice,micid,ierr)
828 IF(ierr < 0) THEN
829 IF(ierr==-1)THEN
830 CALL ancmsg(msgid=223,anmode=aninfo_blind)
831 ELSEIF(ierr==-2)THEN
832 CALL ancmsg(msgid=224,anmode=aninfo_blind)
833 ELSEIF(ierr==-3)THEN
834 CALL ancmsg(msgid=225,anmode=aninfo_blind)
835 END IF
836 CALL arret(2)
837 END IF
838 nddl1=nddl+1
839 print *,' INIT MIC CARD NUMBER ',micid
840C dummy variables to be replaced by pointer later
841c M_LT_K => LT_K(1:NNZ)
842c M_JDIK => JDIK(1:NNZ)
843c M_LT_M => LT_M(1:NNZM)
844c M_JDIM => JDIM(1:NNZM)
845c M_DIAG_K => DIAG_K(1:NDDL)
846c M_DIAG_M => DIAG_M(1:NDDL)
847c M_IADK => IADK(1:NDDL1)
848c M_IADM => IADM(1:NDDL1)
849c M_P => P(1:NDDL)
850c M_X => X(1:NDDL)
851c M_R => R(1:NDDL)
852c M_Y => Y(1:NDDL)
853c M_Z => Z(1:NDDL)
854cc call omp_set_num_threads_target (TARGET_MIC, MICID,116)
855 i= omp_get_num_threads()
856 print *,'Number of threads (host):',i
857cc call kmp_set_blocktime_target (TARGET_MIC, MICID,INFINITE)
858 i= kmp_get_blocktime_target(target_mic, micid)
859!dec$ attributes offload: mic :: ONE,ZERO
860!dec$ attributes offload: mic :: MIC_DSCAL,MIC_GATHER,MIC_SCATTER
861!dec$ attributes offload: mic :: MIC_DDOT,MIC_MV,MIC_SPMV,MIC_DAXPY
862!dec$ attributes offload: mic :: MIC_DCOPY
863 tf=omp_get_wtime()
864 tb=0
865!dir$ omp offload target(mic:MICID)
866 & in(lt_k:length(nnz), free_if(.false.), align(512))
867!$OMP PARALLEL
868!$OMP END PARALLEL
869 tb = tb+nnz
870 print *,' Variables1= ',nnz
871!dir$ omp offload target(mic:MICID)
872 & in(jdik:length(nnz), free_if(.false.), align(512))
873!$OMP PARALLEL
874!$OMP END PARALLEL
875 tb = tb+nnz
876 print *,' Variables2= ',nnz
877!dir$ omp offload target(mic:MICID)
878 & in(lt_k0:length(nnz), free_if(.false.), align(512))
879!$OMP PARALLEL
880!$OMP END PARALLEL
881 tb = tb+nnz
882 print *,' Variables3= ',nnz
883!dir$ omp offload target(mic:MICID)
884 & in(jdik0:length(nnz), free_if(.false.), align(512))
885!$omp parallel
886!$OMP END PARALLEL
887 tb = tb+nnz
888 print *,' Variables4= ',nnz
889 IF(iprec == 5) THEN
890!dir$ omp offload target(mic:MICID)
891& in(lt_m:length(nnzm), free_if(.false.), align(512))
892!$OMP PARALLEL
893!$OMP END PARALLEL
894 tb = tb+nnzm
895 print *,' Variables5= ',nnzm
896!dir$ omp offload target(mic:MICID)
897 & in(jdim:length(nnzm), free_if(.false.), align(512))
898!$OMP PARALLEL
899!$OMP END PARALLEL
900 tb = tb+nnzm
901 print *,' Variables6= ',nnzm
902!dir$ omp offload target(mic:MICID)
903 & in(lt_m0:length(nnzm), free_if(.false.), align(512))
904!$OMP PARALLEL
905!$OMP END PARALLEL
906 tb = tb+nnzm
907 print *,' variables7= ',nnzm
908!dir$ omp offload target(mic:MICID)
909 & in (JDIM0:length(nnzm), free_if(.false.), align(512))
910!$OMP PARALLEL
911!$OMP END PARALLEL
912 TB = TB+NNZ
913 print *,' variables8= ',nnzm
914 END IF
915!dir$ omp offload target(mic:MICID)
916 & in (DIAG_K,DIAG_M,x,y,z,r,p:length(nddl),
917 & free_if(.false.))
918!$OMP PARALLEL
919!$OMP END PARALLEL
920 TB = TB+NDDL*7
921 print *,' variables9= ',nddl*7
922!dir$ omp offload target(mic:MICID)
923 & in (IADK,IADK0,IADM,IADM0:length(NDDL1),
924 & free_if(.false.), align(512))
925!$OMP PARALLEL
926!$OMP END PARALLEL
927 TB = TB+nddl1*4
928 print *,' variables10= ',nddl1*4
929 TF=OMP_GET_WTIME()-TF
930 print *,'transfer time cpu => mic(s) =',TF
931 print *,'transfer rate cpu => mic(mb/s)=',
932 . ((TB/(1024*1024))*8)/TF
933 IF(NSPMD > 1)THEN
934 ALLOCATE(W(NDDL),STAT=IERROR)
935 IERROR=IERROR+IERR
936 ALLOCATE(VGAT(LCOM),STAT=IERR)
937 IERROR=IERROR+IERR
938 ALLOCATE(VSCA(LCOM),STAT=IERR)
939 IERROR=IERROR+IERR
940 ALLOCATE(INDEX(LCOM),STAT=IERR)
941 IERROR=IERROR+IERR
942 ALLOCATE(TABLE(NDDL),STAT=IERR)
943 IERROR=IERROR+IERR
944 IF(IERROR /= 0)THEN
945C code erreur
946 END IF
947
948 DO I = 1, NDDL
949C transfo entier vers my_real
950 W(I) = W_DDL(I)
951 END DO
952
953 TABLE(1:NDDL)=0
954 DO I = 1, LCOM
955 N = IFR2K(I)
956 J = TABLE(N)
957 IF(J==0)THEN
958 INDEX(I)=0
959 TABLE(N)=I
960 ELSE
961 INDEX(I)=J
962 END IF
963 END DO
964 DEALLOCATE(TABLE)
965!dir$ omp offload target(mic:MICID)
966 & in (W:length(NDDL), free_if(.false.), align(512))
967!$OMP PARALLEL
968!$OMP END PARALLEL
969 print *,' variables11= ',i
970!dir$ omp offload target(mic:MICID)
971 & in (IFR2K,INDEX:length(LCOM), free_if(.false.))
972c & free_if(.false.), align(512))
973!$OMP PARALLEL
974!$OMP END PARALLEL
975 print *,' variables12= ',i
976 END IF
977
978 IF(NSPMD>1)THEN
979!dir$ omp offload target(mic:MICID)
980 & nocopy(IADK,IADK0,IADM,IADM0,LT_K,LT_K0,
981 & lt_m,lt_m0,JDIK,JDIK0,JDIM,JDIM0,
982 & DIAG_K,DIAG_M,x,y,z,r,p,w)
983 & inout(tt)
984!$OMP PARALLEL default(shared)
985
986
987!$OMP single
988 tt=OMP_GET_WTIME()
989 i= omp_get_num_threads()
990 print *,'number of threads(mic):',i
991!$OMP END single
992
993C-------------IT=0--------
994C----------{Z}=[K]{X}--------
995C----------{Z}=[Dk]{X}+[Lk]{X}+[Lk]^t{X}--------
996
997C D_Z = D_X * DIAG_K
998 CALL MIC_MV(NDDL,X,DIAG_K,Z)
999
1000C D_Z = D_Z + LT_K * D_X
1001 CALL MIC_SPMV(NDDL ,Z ,X ,LT_K ,IADK ,JDIK )
1002C D_Z = D_Z + LT_K0 * D_X
1003 CALL MIC_SPMV(NDDL ,Z ,X ,LT_K0,IADK0,JDIK0)
1004 IF(NDDLI > 0) THEN
1005C D_Z = D_Z + LT_I0 * D_X
1006ctempo CALL MIC_SPMV(NDDL ,Z ,X ,LT_I0,IADI0,JDII0)
1007 END IF
1008C D_R = D_R - D_Z
1009 CALL MIC_DAXPY(NDDL, -ONE, Z, R)
1010
1011C---------------------
1012C----------{Z}=[M]{R}-([M]=[Lm][Dm][Lm]^t)-------
1013C----------->{V}={R}+[Lm]^t{R}-(the first term presents the [I]{R} with is not included in Lm)-------
1014C----------->{W}=[Dm]{V}-------(the first term ->[I]{W}-same as above)
1015C----------->{Z}={W}+[Lm]{W}--------
1016C CALL PREC_SOLVGH
1017 IF(IPREC == 1)THEN
1018C D_Z = D_R
1019 CALL MIC_DCOPY(NDDL, R, Z)
1020 ELSEIF(IPREC == 2)THEN
1021C D_Z = D_R * DIAG_M
1022 CALL MIC_MV(NDDL,R,DIAG_M,Z)
1023 ELSEIF(IPREC == 5)THEN
1024C D_Y = D_R
1025 CALL MIC_DCOPY(NDDL, R, Y)
1026C D_Y = D_Y + LT_M * D_R
1027 CALL MIC_SPMV(NDDL ,Y ,R ,LT_M ,IADM ,JDIM )
1028C D_Z = D_Y * DIAG_M
1029 CALL MIC_MV(NDDL,Y,DIAG_M,Z)
1030C D_Y = D_Z
1031 CALL MIC_DCOPY(NDDL, Z, Y)
1032C D_Z = D_Z + LT_M0 * D_Y
1033 CALL MIC_SPMV(NDDL ,Z ,Y ,LT_M0,IADM0,JDIM0)
1034
1035 ELSE
1036 END IF
1037!$OMP END PARALLEL
1038C----------------------
1039.AND. IF(NSPMD > 1 IPREC > 1)THEN
1040 IF(IMONM > 0) CALL STARTIME(TIMERS,68)
1041!dir$ omp offload target(mic:MICID)
1042 & nocopy(z,ifr2k)
1043 & out(vgat:length(lcom))
1044!$OMP PARALLEL default(shared)
1045 CALL MIC_GATHER(NDDL, LCOM, Z, VGAT, IFR2K)
1046!$OMP END PARALLEL
1047 IF(IMONM > 0) CALL STOPTIME(TIMERS,68)
1048 IF(IMONM > 0) CALL STARTIME(TIMERS,66)
1049 CALL SPMD_SUMFC_V(VGAT,VSCA,INDEX,LCOM)
1050 IF(IMONM > 0) CALL STOPTIME(TIMERS,66)
1051 IF(IMONM > 0) CALL STARTIME(TIMERS,69)
1052!dir$ omp offload target(mic:MICID)
1053 & nocopy(z,ifr2k,index)
1054 & in(vsca:length(lcom))
1055!$OMP PARALLEL default(shared)
1056 CALL MIC_SCATTER(NDDL, LCOM, Z, VSCA, IFR2K, INDEX)
1057!$OMP END PARALLEL
1058 IF(IMONM > 0) CALL STOPTIME(TIMERS,69)
1059 END IF
1060C---------------------
1061!dir$ omp offload target(mic:MICID)
1062 & nocopy(z,p)
1063!$OMP PARALLEL default(shared)
1064C D_P = D_Z
1065 CALL MIC_DCOPY(NDDL, Z, P)
1066!$OMP END PARALLEL
1067C
1068 IF(NSPMD == 1) THEN
1069!dir$ omp offload target(mic:MICID)
1070 & nocopy(r,z)
1071 & inout(G0)
1072!$OMP PARALLEL default(shared) shared(g0)
1073 CALL MIC_DDOT(NDDL, R, Z, G0)
1074!$OMP END PARALLEL
1075 ELSE
1076C si spmd penser a faire avant D_Y = D_Z*W pour les poids
1077C D_Y = D_Z * D_W
1078!dir$ omp offload target(mic:MICID)
1079 & nocopy(z,y,w,r)
1080 & inout(G0)
1081!$OMP PARALLEL default(shared) shared(g0)
1082 CALL MIC_MV(NDDL,Z,W,Y)
1083 CALL MIC_DDOT(NDDL, R, Y, G0)
1084!$OMP END PARALLEL
1085 IF(IMONM > 0) CALL STARTIME(TIMERS,67)
1086 CALL SPMD_SUM_S(G0)
1087 IF(IMONM > 0) CALL STOPTIME(TIMERS,67)
1088 ENDIF
1089
1090!dir$ omp offload target(mic:MICID)
1091 & nocopy(iadk,iadk0,iadm,iadm0,lt_k,lt_k0,lt_m)
1092 & nocopy(lt_m0,jdik,jdik0,jdim,jdim0,diag_k,diag_m,y,p,x,r,z)
1093!$OMP PARALLEL default(shared)
1094C---------------------
1095C CALL MAV_LTGH(
1096C 1 NDDL ,IADK ,JDIK ,DIAG_K,LT_K ,
1097C 2 P ,Y ,F_DDL ,L_DDL ,ITASK )
1098
1099C D_Y = D_P * DIAG_K
1100 CALL MIC_MV(NDDL,P,DIAG_K,Y)
1101C D_Y = D_Y + LT_K * D_P
1102 CALL MIC_SPMV(NDDL ,Y ,P ,LT_K ,IADK ,JDIK )
1103C D_Y = D_Y + LT_K0 * D_P
1104 CALL MIC_SPMV(NDDL ,Y ,P ,LT_K0,IADK0,JDIK0)
1105 IF(NDDLI > 0) THEN
1106C D_Y = D_Y + LT_I0 * D_P
1107ctempo CALL MIC_SPMV(NDDL ,Y ,P ,LT_I0,IADI0,JDII0)
1108 END IF
1109!$OMP END PARALLEL
1110C----------------------
1111 IF(NSPMD > 1)THEN
1112 IF(IMONM > 0) CALL STARTIME(TIMERS,68)
1113!dir$ omp offload target(mic:MICID)
1114 & nocopy(y,ifr2k)
1115 & out(vgat:length(lcom))
1116!$OMP PARALLEL default(shared)
1117 CALL MIC_GATHER(NDDL, LCOM, Y, VGAT, IFR2K)
1118!$OMP END PARALLEL
1119 IF(IMONM > 0) CALL STOPTIME(TIMERS,68)
1120 IF(IMONM > 0) CALL STARTIME(TIMERS,66)
1121 CALL SPMD_SUMFC_V(VGAT,VSCA,INDEX,LCOM)
1122 IF(IMONM > 0) CALL STOPTIME(TIMERS,66)
1123 IF(IMONM > 0) CALL STARTIME(TIMERS,69)
1124!dir$ omp offload target(mic:MICID)
1125 & nocopy(y,ifr2k,index)
1126 & in(vsca:length(lcom))
1127!$OMP PARALLEL default(shared)
1128 CALL MIC_SCATTER(NDDL, LCOM, Y, VSCA, IFR2K, INDEX)
1129!$OMP END PARALLEL
1130 IF(IMONM > 0) CALL STOPTIME(TIMERS,69)
1131 END IF
1132C---------------------
1133 IF(NSPMD == 1) THEN
1134!dir$ omp offload target(mic:MICID)
1135 & nocopy(p,y)
1136 & inout(S)
1137!$OMP PARALLEL default(shared) shared(s)
1138 CALL MIC_DDOT(NDDL, P, Y, S)
1139!$OMP END PARALLEL
1140 ELSE
1141C si spmd penser a faire avant D_Z = D_Y*D_W pour les poids
1142!dir$ omp offload target(mic:MICID)
1143 & nocopy(y,w,p,z)
1144 & inout(S)
1145!$OMP PARALLEL default(shared) shared(s)
1146 CALL MIC_MV(NDDL,Y,W,Z)
1147 CALL MIC_DDOT(NDDL, P, Z, S)
1148!$OMP END PARALLEL
1149 IF(IMONM > 0) CALL STARTIME(TIMERS,67)
1150 CALL SPMD_SUM_S(S)
1151 IF(IMONM > 0) CALL STOPTIME(TIMERS,67)
1152 END IF
1153C---------------------
1154C---------------------
1155 IF (G0==ZERO) THEN
1156 IF (ITOL>1) THEN
1157 ISTOP=-1
1158 GOTO 206
1159 ELSE
1160 ALPHA = ZERO
1161 ENDIF
1162 ELSE
1163 ALPHA = G0/S
1164 ENDIF
1165 TOLS2=TOLS*TOLS
1166 IF (ITOL==1) THEN
1167 IF(NSPMD == 1) THEN
1168!dir$ omp offload target(mic:MICID)
1169 & nocopy(r)
1170 & inout(r02)
1171!$OMP PARALLEL default(shared) shared(r02)
1172 CALL MIC_DDOT(NDDL, R, R, R02)
1173!$OMP END PARALLEL
1174 ELSE
1175C si spmd penser a faire avant D_Z = D_R*W pour les poids
1176!dir$ omp offload target(mic:MICID)
1177 & nocopy(r,w,z)
1178 & inout(r02)
1179!$OMP PARALLEL default(shared) shared(r02)
1180 CALL MIC_MV(NDDL,R,W,Z)
1181 CALL MIC_DDOT(NDDL, Z, Z, R02)
1182!$OMP END PARALLEL
1183 IF(IMONM > 0) CALL STARTIME(TIMERS,67)
1184 CALL SPMD_SUM_S(R02)
1185 IF(IMONM > 0) CALL STOPTIME(TIMERS,67)
1186 END IF
1187C---------------------
1188C---------------------
1189 R2 =R02
1190 ELSEIF (ITOL==3) THEN
1191C------ R2<TOL*TOL*ANORM2*XNORM2------
1192 R02=ABS(G0)
1193 R2 =R02
1194 L_A=ONE/ALPHA
1195C L_B2=R02
1196 TNORM2=L_A*L_A
1197 ANORM2=ZERO
1198 XNORM2=ZERO
1199 A_OLD=L_A
1200 B_OLD=ZERO
1201 OLDB = SQRT(R02)
1202 ELSEIF (ITOL==4) THEN
1203 R02=ALPHA*ALPHA*ABS(G0)
1204 EPS(1)=R02
1205 R2=R02
1206 ELSE
1207 R02=ABS(G0)
1208 R2 =R02
1209 ENDIF
1210 IF (R02==ZERO) THEN
1211 ISTOP=-1
1212 GOTO 206
1213 ENDIF
1214 TOLN=R02*TOLS2
1215.AND. IF(IPRI/=0ITASK==0)THEN
1216 RR = SQRT(R2)
1217 IF(IPRI<0) WRITE(ISTDO,1000)IT,RR
1218 WRITE(IOUT,1000)IT,RR
1219 ENDIF
1220C-------pour etre coherent avec lanzos for linear
1221C----------------------
1222c CALL MY_BARRIER
1223C---------------------
1224 IT=1
1225!dir$ omp offload target(mic:MICID)
1226 & nocopy(iadk,iadk0,iadm,iadm0,lt_k,lt_k0,lt_m)
1227 & nocopy(lt_m0,jdik,jdik0,jdim,jdim0,diag_k,diag_m,y,p,x,r,z)
1228!$OMP PARALLEL default(shared)
1229 CALL MIC_DAXPY(NDDL, ALPHA, P, X)
1230 CALL MIC_DAXPY(NDDL,-ALPHA, Y, R)
1231
1232C----------------------
1233c CALL MY_BARRIER
1234C---------------------
1235C CALL PREC_SOLVGH(IPREC, ITASK ,NDDL ,IADM , JDIM ,
1236C 6 DIAG_M , LT_M ,R ,Z ,
1237C 7 F_DDL ,L_DDL )
1238 IF(IPREC == 1)THEN
1239C D_Z = D_R
1240 CALL MIC_DCOPY(NDDL, R, Z)
1241 ELSEIF(IPREC == 2)THEN
1242C D_Z = D_R * DIAG_M
1243 CALL MIC_MV(NDDL,R,DIAG_M,Z)
1244 ELSEIF(IPREC == 5)THEN
1245C D_Y = D_R
1246 CALL MIC_DCOPY(NDDL, R, Y)
1247C D_Y = D_Y + LT_M * D_R
1248 CALL MIC_SPMV(NDDL ,Y ,R ,LT_M ,IADM ,JDIM )
1249C D_Z = D_Y * DIAG_M
1250 CALL MIC_MV(NDDL,Y,DIAG_M,Z)
1251 CALL MIC_DCOPY(NDDL, Z, Y)
1252C D_Z = D_Z + LT_M0 * D_Y
1253 CALL MIC_SPMV(NDDL ,Z ,Y ,LT_M0,IADM0,JDIM0)
1254 ELSE
1255 END IF
1256!$OMP END PARALLEL
1257C----------------------
1258.AND. IF(NSPMD > 1 IPREC > 1)THEN
1259 IF(IMONM > 0) CALL STARTIME(TIMERS,68)
1260!dir$ omp offload target(mic:MICID)
1261 & nocopy(z,ifr2k)
1262 & out(vgat:length(lcom))
1263!$OMP PARALLEL default(shared)
1264 CALL MIC_GATHER(NDDL, LCOM, Z, VGAT, IFR2K)
1265!$OMP END PARALLEL
1266 IF(IMONM > 0) CALL STOPTIME(TIMERS,68)
1267 IF(IMONM > 0) CALL STARTIME(TIMERS,66)
1268 CALL SPMD_SUMFC_V(VGAT,VSCA,INDEX,LCOM)
1269 IF(IMONM > 0) CALL STOPTIME(TIMERS,66)
1270 IF(IMONM > 0) CALL STARTIME(TIMERS,69)
1271!dir$ omp offload target(mic:MICID)
1272 & nocopy(z,ifr2k,index)
1273 & in(vsca:length(lcom))
1274!$OMP PARALLEL default(shared)
1275 CALL MIC_SCATTER(NDDL, LCOM, Z, VSCA, IFR2K, INDEX)
1276!$OMP END PARALLEL
1277 IF(IMONM > 0) CALL STOPTIME(TIMERS,69)
1278 END IF
1279C---------------------
1280 IF(NSPMD == 1) THEN
1281!dir$ omp offload target(mic:MICID)
1282 & nocopy(r,z)
1283 & inout(G1)
1284!$OMP PARALLEL default(shared) shared(G1)
1285 CALL MIC_DDOT(NDDL, R, Z, G1)
1286!$OMP END PARALLEL
1287 ELSE
1288C si spmd penser a faire avant D_Y = D_Z*D_W pour les poids
1289!dir$ omp offload target(mic:MICID)
1290 & nocopy(z,w,r,y)
1291 & inout(G1)
1292!$OMP PARALLEL default(shared) shared(G1)
1293 CALL MIC_MV(NDDL,Z,W,Y)
1294 CALL MIC_DDOT(NDDL, R, Y, G1)
1295!$OMP END PARALLEL
1296 IF(IMONM > 0) CALL STARTIME(TIMERS,67)
1297 CALL SPMD_SUM_S(G1)
1298 IF(IMONM > 0) CALL STOPTIME(TIMERS,67)
1299 END IF
1300C---------------------
1301 BETA=G1/G0
1302 IF (ITOL==1) THEN
1303 IF(NSPMD == 1) THEN
1304!dir$ omp offload target(mic:MICID)
1305 & nocopy(r)
1306 & inout(R2)
1307!$OMP PARALLEL default(shared) shared(R2)
1308 CALL MIC_DDOT(NDDL, R, R, R2)
1309!$OMP END PARALLEL
1310 ELSE
1311C si spmd penser a faire avant D_Y = D_R*W pour les poids
1312!dir$ omp offload target(mic:MICID)
1313 & nocopy(r,w,y)
1314 & inout(R2)
1315!$OMP PARALLEL default(shared) shared(R2)
1316 CALL MIC_MV(NDDL,R,W,Y)
1317 CALL MIC_DDOT(NDDL, Y, Y, R2)
1318!$OMP END PARALLEL
1319 IF(IMONM > 0) CALL STARTIME(TIMERS,67)
1320 CALL SPMD_SUM_S(R2)
1321 IF(IMONM > 0) CALL STOPTIME(TIMERS,67)
1322 END IF
1323 ELSEIF (ITOL==3) THEN
1324C------ R2<TOL*TOL*ANORM2*XNORM2------
1325 R2=ABS(G1)
1326 L_B2=ABS(BETA)*A_OLD*A_OLD
1327 L_B=SQRT(L_B2)
1328 TNORM2=TNORM2+L_B2
1329 B_OLD=BETA
1330C INITIALIZE OTHER QUANTITIES.
1331 GBAR = L_A
1332 DBAR = L_B
1333 RHS1 = OLDB
1334 RHS2 = ZERO
1335 GMAX = ABS( L_A ) + EPS_M
1336 GMIN = GMAX
1337 OLDB2 = L_B2
1338 OLDB = L_B
1339 ELSEIF (ITOL==4) THEN
1340 R2=R02
1341 ELSE
1342 R2=ABS(G1)
1343 ENDIF
1344 G0 = G1
1345 IF (ITOL==3) TOLN=TOLN*TNORM2
1346C----------------------
1347c CALL MY_BARRIER
1348C---------------------
1349 ISTOP=CRIT_STOP(IT,R2,NLIM,TOLN)
1350
1351C----------------------
1352c LOOP OVER ITERATIONS
1353C---------------------
1354
1355 DO WHILE (ISTOP==1)
1356
1357!dir$ omp offload target(mic:MICID)
1358 & nocopy(iadk,iadk0,iadm,iadm0,lt_k,lt_k0,lt_m)
1359 & nocopy(lt_m0,jdik,jdik0,jdim,jdim0,diag_k,diag_m,y,p,x,r,z)
1360!$OMP PARALLEL default(shared)
1361
1362C D_P = D_Z + BETA*D_P in 2 step : D_P = BETA*D_P ; D_P = D_P + D_Z
1363 CALL MIC_DSCAL(NDDL, BETA, P)
1364 CALL MIC_DAXPY(NDDL, ONE, Z, P)
1365C----------------------
1366c CALL MY_BARRIER
1367C---------------------
1368C CALL MAV_LTGH(
1369C 1 NDDL ,IADK ,JDIK ,DIAG_K,LT_K ,
1370C 2 P ,Y ,F_DDL ,L_DDL ,ITASK )
1371C D_Y = D_P * DIAG_K
1372 CALL MIC_MV(NDDL,P,DIAG_K,Y)
1373C D_Y = D_Y + LT_K * D_P
1374 CALL MIC_SPMV(NDDL ,Y ,P ,LT_K ,IADK ,JDIK )
1375C D_Y = D_Y + LT_K0 * D_P
1376 CALL MIC_SPMV(NDDL ,Y ,P ,LT_K0,IADK0,JDIK0)
1377 IF(NDDLI > 0) THEN
1378C D_Y = D_Y + LT_I0 * D_P
1379ctempo CALL MIC_SPMV(NDDL ,Y ,P ,LT_I0,IADI0,JDII0)
1380 END IF
1381!$OMP END PARALLEL
1382 IF(NSPMD > 1)THEN
1383 IF(IMONM > 0) CALL STARTIME(TIMERS,68)
1384!dir$ omp offload target(mic:MICID)
1385 & nocopy(y,ifr2k)
1386 & out(vgat:length(lcom))
1387!$OMP PARALLEL default(shared)
1388 CALL MIC_GATHER(NDDL, LCOM, Y, VGAT, IFR2K)
1389!$OMP END PARALLEL
1390 IF(IMONM > 0) CALL STOPTIME(TIMERS,68)
1391 IF(IMONM > 0) CALL STARTIME(TIMERS,66)
1392 CALL SPMD_SUMFC_V(VGAT,VSCA,INDEX,LCOM)
1393 IF(IMONM > 0) CALL STOPTIME(TIMERS,66)
1394 IF(IMONM > 0) CALL STARTIME(TIMERS,69)
1395!dir$ omp offload target(mic:MICID)
1396 & nocopy(y,ifr2k,index)
1397 & in(vsca:length(lcom))
1398!$OMP PARALLEL default(shared)
1399 CALL MIC_SCATTER(NDDL, LCOM, Y, VSCA, IFR2K, INDEX)
1400!$OMP END PARALLEL
1401 IF(IMONM > 0) CALL STOPTIME(TIMERS,69)
1402 END IF
1403C---------------------
1404 IF(NSPMD == 1) THEN
1405!dir$ omp offload target(mic:MICID)
1406 & nocopy(p,y)
1407 & inout(S)
1408!$OMP PARALLEL default(shared) shared(S)
1409 CALL MIC_DDOT(NDDL, P, Y, S)
1410!$OMP END PARALLEL
1411 ELSE
1412C si spmd penser a faire avant D_Y = D_Y*W pour les poids
1413!dir$ omp offload target(mic:MICID)
1414 & nocopy(y,w,p,z)
1415 & inout(S)
1416!$OMP PARALLEL default(shared) shared(S)
1417 CALL MIC_MV(NDDL,Y,W,Z)
1418 CALL MIC_DDOT(NDDL, P, Z, S)
1419!$OMP END PARALLEL
1420 IF(IMONM > 0) CALL STARTIME(TIMERS,67)
1421 CALL SPMD_SUM_S(S)
1422 IF(IMONM > 0) CALL STOPTIME(TIMERS,67)
1423 END IF
1424C---------------------
1425 ALPHA=G0/S
1426!dir$ omp offload target(mic:MICID)
1427 & nocopy(iadk,iadk0,iadm,iadm0,lt_k,lt_k0,lt_m)
1428 & nocopy(lt_m0,jdik,jdik0,jdim,jdim0,diag_k,diag_m,y,p,x,r,z)
1429!$OMP PARALLEL default(shared)
1430 CALL MIC_DAXPY(NDDL, ALPHA, P, X)
1431 CALL MIC_DAXPY(NDDL,-ALPHA, Y, R)
1432C----------------------
1433C CALL PREC_SOLVGH(IPREC , ITASK ,NDDL ,IADM , JDIM ,
1434C 6 DIAG_M, LT_M ,R ,Z ,
1435C 7 F_DDL ,L_DDL )
1436 IF(IPREC == 1)THEN
1437C D_Z = D_R
1438 CALL MIC_DCOPY(NDDL, R, Z)
1439 ELSEIF(IPREC == 2)THEN
1440C D_Z = D_R * DIAG_M
1441 CALL MIC_MV(NDDL,R,DIAG_M,Z)
1442 ELSEIF(IPREC == 5)THEN
1443C D_Y = D_R
1444 CALL MIC_DCOPY(NDDL, R, Y)
1445C D_Y = D_Y + LT_M * D_R
1446 CALL MIC_SPMV(NDDL ,Y ,R ,LT_M ,IADM ,JDIM )
1447C D_Z = D_Y * DIAG_M
1448 CALL MIC_MV(NDDL,Y,DIAG_M,Z)
1449 CALL MIC_DCOPY(NDDL, Z, Y)
1450C D_Z = D_Z + LT_M0 * D_Y
1451 CALL MIC_SPMV(NDDL ,Z ,Y ,LT_M0,IADM0,JDIM0)
1452 ELSE
1453 END IF
1454!$OMP END PARALLEL
1455C----------------------
1456.AND. IF(NSPMD > 1 IPREC > 1)THEN
1457 IF(IMONM > 0) CALL STARTIME(TIMERS,68)
1458!dir$ omp offload target(mic:MICID)
1459 & nocopy(z,ifr2k)
1460 & out(vgat:length(lcom))
1461!$OMP PARALLEL default(shared)
1462 CALL MIC_GATHER(NDDL, LCOM, Z, VGAT, IFR2K)
1463!$OMP END PARALLEL
1464 IF(IMONM > 0) CALL STOPTIME(TIMERS,68)
1465 IF(IMONM > 0) CALL STARTIME(TIMERS,66)
1466 CALL SPMD_SUMFC_V(VGAT,VSCA,INDEX,LCOM)
1467 IF(IMONM > 0) CALL STOPTIME(TIMERS,66)
1468 IF(IMONM > 0) CALL STARTIME(TIMERS,69)
1469!dir$ omp offload target(mic:MICID)
1470 & nocopy(z,ifr2k,index)
1471 & in(vsca:length(lcom))
1472!$OMP PARALLEL default(shared)
1473 CALL MIC_SCATTER(NDDL, LCOM, Z, VSCA, IFR2K, INDEX)
1474!$OMP END PARALLEL
1475 IF(IMONM > 0) CALL STOPTIME(TIMERS,69)
1476 END IF
1477C---------------------
1478 IF(NSPMD == 1) THEN
1479!dir$ omp offload target(mic:MICID)
1480 & nocopy(r,z)
1481 & inout(G1)
1482!$OMP PARALLEL default(shared) shared(G1)
1483 CALL MIC_DDOT(NDDL, R, Z, G1)
1484!$OMP END PARALLEL
1485 ELSE
1486C si spmd penser a faire avant D_Y = D_Z*W pour les poids
1487!dir$ omp offload target(mic:MICID)
1488 & nocopy(z,w,r,y)
1489 & inout(G1)
1490!$OMP PARALLEL default(shared) shared(G1)
1491 CALL MIC_MV(NDDL,Z,W,Y)
1492 CALL MIC_DDOT(NDDL, R, Y, G1)
1493!$OMP END PARALLEL
1494 IF(IMONM > 0) CALL STARTIME(TIMERS,67)
1495 CALL SPMD_SUM_S(G1)
1496 IF(IMONM > 0) CALL STOPTIME(TIMERS,67)
1497 END IF
1498C---------------------
1499cc!$OMP single
1500 BETA=G1/G0
1501 G0 = G1
1502cc!$OMP end single
1503 IF (ITOL==1) THEN
1504 IF(NSPMD == 1) THEN
1505!dir$ omp offload target(mic:MICID)
1506 & nocopy(r)
1507 & inout(R2)
1508!$OMP PARALLEL default(shared) shared(R2)
1509 CALL MIC_DDOT(NDDL, R, R, R2)
1510!$OMP END PARALLEL
1511 ELSE
1512C si spmd penser a faire avant D_Y = D_R*W pour les poids
1513!dir$ omp offload target(mic:MICID)
1514 & nocopy(r,w,y)
1515 & inout(R2)
1516!$OMP PARALLEL default(shared) shared(R2)
1517 CALL MIC_MV(NDDL,R,W,Y)
1518 CALL MIC_DDOT(NDDL, Y, Y, R2)
1519!$OMP END PARALLEL
1520 IF(IMONM > 0) CALL STARTIME(TIMERS,67)
1521 CALL SPMD_SUM_S(R2)
1522 IF(IMONM > 0) CALL STOPTIME(TIMERS,67)
1523 END IF
1524 ELSEIF (ITOL==3) THEN
1525 R2 =ABS(G1)
1526 S=ONE/ALPHA
1527 L_A=S+B_OLD*A_OLD
1528C----------L_B2 : beta(j-1)^2-A_OLD :1/alpha(j-1)-------
1529 L_B2=ABS(BETA)*S*S
1530 L_B=SQRT(L_B2)
1531 A_OLD=S
1532 B_OLD=BETA
1533 ANORM2=TNORM2
1534 TNORM2=TNORM2+L_A*L_A+OLDB2+L_B2
1535 GAMMA = SQRT( GBAR*GBAR + OLDB2 )
1536 CS = GBAR / GAMMA
1537 SN = OLDB / GAMMA
1538 DELTA = CS * DBAR + SN * L_A
1539 GBAR = SN * DBAR - CS * L_A
1540 EPSLN = SN * L_B
1541 DBAR = - CS * L_B
1542 ZL = RHS1 / GAMMA
1543 XNORM2 = XNORM2+ZL*ZL
1544 GMAX = MAX( GMAX, GAMMA )
1545 GMIN = MIN( GMIN, GAMMA )
1546 RHS1 = RHS2 - DELTA * ZL
1547 RHS2 = - EPSLN * ZL
1548 TOLN=TOLS2*ANORM2*XNORM2
1549 OLDB2 = L_B2
1550 OLDB = L_B
1551 ELSEIF (ITOL==4) THEN
1552 TMP=ALPHA*ALPHA*ABS(G1)
1553 IF (IT>=ND) THEN
1554 DO J=1,ND-1
1555 EPS(J)=EPS(J+1)
1556 ENDDO
1557 EPS(ND)=TMP
1558 R2=ZERO
1559 DO J=1,ND
1560 R2=R2+EPS(J)
1561 ENDDO
1562 ELSE
1563 EPS(IT+1)=TMP
1564 R2=R2+TMP
1565 ENDIF
1566 ELSE
1567 R2 =ABS(G1)
1568 ENDIF
1569.AND. IF(IPRI/=0ITASK==0)THEN
1570 IF(MOD(IT,IP)==0)THEN
1571 RR = SQRT(R2/R02)
1572 WRITE(IOUT,1001)IT,RR
1573 IF(IPRI<0) WRITE(ISTDO,1001)IT,RR
1574 ENDIF
1575 ENDIF
1576C----------------------
1577c CALL MY_BARRIER
1578C---------------------
1579 ISTOP=CRIT_STOP(IT,R2,NLIM,TOLN)
1580C----------------------
1581c CALL MY_BARRIER
1582C---------------------
1583 IT = IT +1
1584 ENDDO
1585 206 CONTINUE
1586
1587 WRITE(IOUT,1001)IT-1,RR
1588
1589C!dec$ omp offload target(mic:MICID) out(X,R:alloc_if(.false.))
1590!$OMP PARALLEL
1591!$OMP single
1592 tt=OMP_GET_WTIME()-tt
1593 i= omp_get_num_threads()
1594 print *,' '
1595 print *,' '
1596 print *,' execution time on mic with',i,' threads'
1597 print *,' ==> ',tt,' seconds'
1598 print *,' '
1599!$OMP END single
1600!$OMP END PARALLEL
1601 DEALLOCATE(W)
1602 DEALLOCATE(VGAT)
1603 DEALLOCATE(VSCA)
1604 DEALLOCATE(INDEX)
1605c+1 tempo
1606 ELSE ! CODE NSPMD = 1
1607C debut code provisoire
1608!dec$ attributes offload: mic :: ONE,ZERO,ISTDO,IOUT
1609
1610!dir$ omp offload target(mic:MICID)
1611 & nocopy(IADK,IADK0,IADM,IADM0,LT_K,LT_K0,
1612 & lt_m,lt_m0,JDIK,JDIK0,JDIM,JDIM0,
1613 & DIAG_K,DIAG_M,x,y,z,r,p,w)
1614 & inout(tt)
1615
1616!$OMP PARALLEL default(shared)
1617
1618!$OMP single
1619 tt=OMP_GET_WTIME()
1620 i= omp_get_num_threads()
1621 print *,'number of threads(mic):',i
1622!$OMP END single
1623
1624C-------------IT=0--------
1625C----------{Z}=[K]{X}--------
1626C----------{Z}=[Dk]{X}+[Lk]{X}+[Lk]^t{X}--------
1627
1628C D_Z = D_X * DIAG_K
1629 CALL MIC_MV(NDDL,X,DIAG_K,Z)
1630
1631C D_Z = D_Z + LT_K * D_X
1632 CALL MIC_SPMV(NDDL ,Z ,X ,LT_K ,IADK ,JDIK )
1633C D_Z = D_Z + LT_K0 * D_X
1634 CALL MIC_SPMV(NDDL ,Z ,X ,LT_K0,IADK0,JDIK0)
1635 IF(NDDLI > 0) THEN
1636C D_Z = D_Z + LT_I0 * D_X
1637ctempo CALL MIC_SPMV(NDDL ,Z ,X ,LT_I0,IADI0,JDII0)
1638 END IF
1639C D_R = D_R - D_Z
1640 CALL MIC_DAXPY(NDDL, -ONE, Z, R)
1641C---------------------
1642C----------{Z}=[M]{R}-([M]=[Lm][Dm][Lm]^t)-------
1643C----------->{V}={R}+[Lm]^t{R}-(the first term presents the [I]{R} with is not included in Lm)-------
1644C----------->{W}=[Dm]{V}-------(the first term ->[I]{W}-same as above)
1645C----------->{Z}={W}+[Lm]{W}--------
1646C CALL PREC_SOLVGH
1647 IF(IPREC == 1)THEN
1648C D_Z = D_R
1649 CALL MIC_DCOPY(NDDL, R, Z)
1650 ELSEIF(IPREC == 2)THEN
1651C D_Z = D_R * DIAG_M
1652 CALL MIC_MV(NDDL,R,DIAG_M,Z)
1653 ELSEIF(IPREC == 5)THEN
1654C D_Y = D_R
1655 CALL MIC_DCOPY(NDDL, R, Y)
1656C D_Y = D_Y + LT_M * D_R
1657 CALL MIC_SPMV(NDDL ,Y ,R ,LT_M ,IADM ,JDIM )
1658C D_Z = D_Y * DIAG_M
1659 CALL MIC_MV(NDDL,Y,DIAG_M,Z)
1660C D_Y = D_Z
1661 CALL MIC_DCOPY(NDDL, Z, Y)
1662C D_Z = D_Z + LT_M0 * D_Y
1663 CALL MIC_SPMV(NDDL ,Z ,Y ,LT_M0,IADM0,JDIM0)
1664
1665 ELSE
1666 END IF
1667c!$OMP END PARALLEL
1668C----------------------
1669c IF(NSPMD > 1 .AND. IPREC > 1)THEN
1670c IF(IMONM > 0) CALL STARTIME(TIMERS,68)
1671c!dir$ omp offload target(mic:MICID)
1672c & nocopy(z,ifr2k)
1673c & out(vgat:length(lcom))
1674c!$OMP PARALLEL default(shared)
1675c CALL MIC_GATHER(NDDL, LCOM, Z, VGAT, IFR2K)
1676c!$OMP END PARALLEL
1677c IF(IMONM > 0) CALL STOPTIME(TIMERS,68)
1678c IF(IMONM > 0) CALL STARTIME(TIMERS,66)
1679c CALL SPMD_SUMFC_V(VGAT,VSCA,INDEX,LCOM)
1680c IF(IMONM > 0) CALL STOPTIME(TIMERS,66)
1681c IF(IMONM > 0) CALL STARTIME(TIMERS,69)
1682c!dir$ omp offload target(mic:MICID)
1683c & nocopy(z,ifr2k,index)
1684c & in(vsca:length(lcom))
1685c!$OMP PARALLEL default(shared)
1686c CALL MIC_SCATTER(NDDL, LCOM, Z, VSCA, IFR2K, INDEX)
1687c!$OMP END PARALLEL
1688c IF(IMONM > 0) CALL STOPTIME(TIMERS,69)
1689c END IF
1690C---------------------
1691c!dir$ omp offload target(mic:MICID)
1692c & nocopy(z,p)
1693c!$OMP PARALLEL default(shared)
1694C D_P = D_Z
1695 CALL MIC_DCOPY(NDDL, Z, P)
1696c!$OMP END PARALLEL
1697C
1698c IF(NSPMD == 1) THEN
1699c!dir$ omp offload target(mic:MICID)
1700c & nocopy(r,z)
1701c & inout(G0)
1702c!$OMP PARALLEL default(shared) shared(g0)
1703 CALL MIC_DDOT(NDDL, R, Z, G0)
1704c!$OMP END PARALLEL
1705c ELSE
1706C si spmd penser a faire avant D_Y = D_Z*W pour les poids
1707C D_Y = D_Z * D_W
1708c!dir$ omp offload target(mic:MICID)
1709c & nocopy(z,y,w,r)
1710c & inout(G0)
1711c!$OMP PARALLEL default(shared) shared(g0)
1712c CALL MIC_MV(NDDL,Z,W,Y)
1713c CALL MIC_DDOT(NDDL, R, Y, G0)
1714c!$OMP END PARALLEL
1715c IF(IMONM > 0) CALL STARTIME(TIMERS,67)
1716c CALL SPMD_SUM_S(G0)
1717c IF(IMONM > 0) CALL STOPTIME(TIMERS,67)
1718c ENDIF
1719
1720c!dir$ omp offload target(mic:MICID)
1721c & nocopy(iadk,iadk0,iadm,iadm0,lt_k,lt_k0,lt_m)
1722c & nocopy(lt_m0,jdik,jdik0,jdim,jdim0,diag_k,diag_m,y,p,x,r,z)
1723c!$OMP PARALLEL default(shared)
1724C---------------------
1725C CALL MAV_LTGH(
1726C 1 NDDL ,IADK ,JDIK ,DIAG_K,LT_K ,
1727C 2 P ,Y ,F_DDL ,L_DDL ,ITASK )
1728
1729C D_Y = D_P * DIAG_K
1730 CALL MIC_MV(NDDL,P,DIAG_K,Y)
1731C D_Y = D_Y + LT_K * D_P
1732 CALL MIC_SPMV(NDDL ,Y ,P ,LT_K ,IADK ,JDIK )
1733C D_Y = D_Y + LT_K0 * D_P
1734 CALL MIC_SPMV(NDDL ,Y ,P ,LT_K0,IADK0,JDIK0)
1735 IF(NDDLI > 0) THEN
1736C D_Y = D_Y + LT_I0 * D_P
1737ctempo CALL MIC_SPMV(NDDL ,Y ,P ,LT_I0,IADI0,JDII0)
1738 END IF
1739c!$OMP END PARALLEL
1740C----------------------
1741c IF(NSPMD > 1)THEN
1742c IF(IMONM > 0) CALL STARTIME(TIMERS,68)
1743c!dir$ omp offload target(mic:MICID)
1744c & nocopy(y,ifr2k)
1745c & out(vgat:length(lcom))
1746c!$OMP PARALLEL default(shared)
1747c CALL MIC_GATHER(NDDL, LCOM, Y, VGAT, IFR2K)
1748c!$OMP END PARALLEL
1749c IF(IMONM > 0) CALL STOPTIME(TIMERS,68)
1750c IF(IMONM > 0) CALL STARTIME(TIMERS,66)
1751c CALL SPMD_SUMFC_V(VGAT,VSCA,INDEX,LCOM)
1752c IF(IMONM > 0) CALL STOPTIME(TIMERS,66)
1753c IF(IMONM > 0) CALL STARTIME(TIMERS,69)
1754c!dir$ omp offload target(mic:MICID)
1755c & nocopy(y,ifr2k,index)
1756c & in(vsca:length(lcom))
1757c!$OMP PARALLEL default(shared)
1758c CALL MIC_SCATTER(NDDL, LCOM, Y, VSCA, IFR2K, INDEX)
1759c!$OMP END PARALLEL
1760c IF(IMONM > 0) CALL STOPTIME(TIMERS,69)
1761c END IF
1762C---------------------
1763c IF(NSPMD == 1) THEN
1764c!dir$ omp offload target(mic:MICID)
1765c & nocopy(p,y)
1766c & inout(S)
1767c!$OMP PARALLEL default(shared) shared(s)
1768 CALL MIC_DDOT(NDDL, P, Y, S)
1769c!$OMP END PARALLEL
1770c ELSE
1771C si spmd penser a faire avant D_Z = D_Y*D_W pour les poids
1772c!dir$ omp offload target(mic:MICID)
1773c & nocopy(y,w,p,z)
1774c & inout(S)
1775c!$OMP PARALLEL default(shared) shared(s)
1776c CALL MIC_MV(NDDL,Y,W,Z)
1777c CALL MIC_DDOT(NDDL, P, Z, S)
1778c!$OMP END PARALLEL
1779c IF(IMONM > 0) CALL STARTIME(TIMERS,67)
1780c CALL SPMD_SUM_S(S)
1781c IF(IMONM > 0) CALL STOPTIME(TIMERS,67)
1782c END IF
1783C---------------------
1784C---------------------
1785 IF (G0==ZERO) THEN
1786 IF (ITOL>1) THEN
1787 ISTOP=-1
1788 GOTO 2060
1789 ELSE
1790 ALPHA = ZERO
1791 ENDIF
1792 ELSE
1793 ALPHA = G0/S
1794 ENDIF
1795 TOLS2=TOLS*TOLS
1796 IF (ITOL==1) THEN
1797c IF(NSPMD == 1) THEN
1798c!dir$ omp offload target(mic:MICID)
1799c & nocopy(r)
1800c & inout(r02)
1801c!$OMP PARALLEL default(shared) shared(r02)
1802 CALL MIC_DDOT(NDDL, R, R, R02)
1803c!$OMP END PARALLEL
1804c ELSE
1805C si spmd penser a faire avant D_Z = D_R*W pour les poids
1806c!dir$ omp offload target(mic:MICID)
1807c & nocopy(r,w,z)
1808c & inout(r02)
1809c!$OMP PARALLEL default(shared) shared(r02)
1810c CALL MIC_MV(NDDL,R,W,Z)
1811c CALL MIC_DDOT(NDDL, Z, Z, R02)
1812c!$OMP END PARALLEL
1813c IF(IMONM > 0) CALL STARTIME(TIMERS,67)
1814c CALL SPMD_SUM_S(R02)
1815c IF(IMONM > 0) CALL STOPTIME(TIMERS,67)
1816c END IF
1817C---------------------
1818C---------------------
1819 R2 =R02
1820 ELSEIF (ITOL==3) THEN
1821C------ R2<TOL*TOL*ANORM2*XNORM2------
1822c+1
1823!$OMP SINGLE
1824 R02=ABS(G0)
1825 R2 =R02
1826 L_A=ONE/ALPHA
1827C L_B2=R02
1828 TNORM2=L_A*L_A
1829 ANORM2=ZERO
1830 XNORM2=ZERO
1831 A_OLD=L_A
1832 B_OLD=ZERO
1833 OLDB = SQRT(R02)
1834c+1
1835!$OMP END SINGLE
1836 ELSEIF (ITOL==4) THEN
1837 R02=ALPHA*ALPHA*ABS(G0)
1838 EPS(1)=R02
1839 R2=R02
1840 ELSE
1841 R02=ABS(G0)
1842 R2 =R02
1843 ENDIF
1844 IF (R02==ZERO) THEN
1845 ISTOP=-1
1846 GOTO 2060
1847 ENDIF
1848c+1
1849!$OMP SINGLE
1850 TOLN=R02*TOLS2
1851.AND. IF(IPRI/=0ITASK==0)THEN
1852 RR = SQRT(R2)
1853 IF(IPRI<0) WRITE(ISTDO,1000)IT,RR
1854 WRITE(IOUT,1000)IT,RR
1855 ENDIF
1856c+1
1857!$OMP END SINGLE
1858C-------pour etre coherent avec lanzos for linear
1859C----------------------
1860c CALL MY_BARRIER
1861C---------------------
1862 IT=1
1863c!dir$ omp offload target(mic:MICID)
1864c & nocopy(iadk,iadk0,iadm,iadm0,lt_k,lt_k0,lt_m)
1865c & nocopy(lt_m0,jdik,jdik0,jdim,jdim0,diag_k,diag_m,y,p,x,r,z)
1866c!$OMP PARALLEL default(shared)
1867 CALL MIC_DAXPY(NDDL, ALPHA, P, X)
1868 CALL MIC_DAXPY(NDDL,-ALPHA, Y, R)
1869
1870C----------------------
1871c CALL MY_BARRIER
1872C---------------------
1873C CALL PREC_SOLVGH(IPREC, ITASK ,NDDL ,IADM , JDIM ,
1874C 6 DIAG_M , LT_M ,R ,Z ,
1875C 7 F_DDL ,L_DDL )
1876 IF(IPREC == 1)THEN
1877C D_Z = D_R
1878 CALL MIC_DCOPY(NDDL, R, Z)
1879 ELSEIF(IPREC == 2)THEN
1880C D_Z = D_R * DIAG_M
1881 CALL MIC_MV(NDDL,R,DIAG_M,Z)
1882 ELSEIF(IPREC == 5)THEN
1883C D_Y = D_R
1884 CALL MIC_DCOPY(NDDL, R, Y)
1885C D_Y = D_Y + LT_M * D_R
1886 CALL MIC_SPMV(NDDL ,Y ,R ,LT_M ,IADM ,JDIM )
1887C D_Z = D_Y * DIAG_M
1888 CALL MIC_MV(NDDL,Y,DIAG_M,Z)
1889 CALL MIC_DCOPY(NDDL, Z, Y)
1890C D_Z = D_Z + LT_M0 * D_Y
1891 CALL MIC_SPMV(NDDL ,Z ,Y ,LT_M0,IADM0,JDIM0)
1892 ELSE
1893 END IF
1894c!$OMP END PARALLEL
1895C----------------------
1896c IF(NSPMD > 1 .AND. IPREC > 1)THEN
1897c IF(IMONM > 0) CALL STARTIME(TIMERS,68)
1898c!dir$ omp offload target(mic:MICID)
1899c & nocopy(z,ifr2k)
1900c & out(vgat:length(lcom))
1901c!$OMP PARALLEL default(shared)
1902c CALL MIC_GATHER(NDDL, LCOM, Z, VGAT, IFR2K)
1903c!$OMP END PARALLEL
1904c IF(IMONM > 0) CALL STOPTIME(TIMERS,68)
1905c IF(IMONM > 0) CALL STARTIME(TIMERS,66)
1906c CALL SPMD_SUMFC_V(VGAT,VSCA,INDEX,LCOM)
1907c IF(IMONM > 0) CALL STOPTIME(TIMERS,66)
1908c IF(IMONM > 0) CALL STARTIME(TIMERS,69)
1909c!dir$ omp offload target(mic:MICID)
1910c & nocopy(z,ifr2k,index)
1911c & in(vsca:length(lcom))
1912c!$OMP PARALLEL default(shared)
1913c CALL MIC_SCATTER(NDDL, LCOM, Z, VSCA, IFR2K, INDEX)
1914c!$OMP END PARALLEL
1915c IF(IMONM > 0) CALL STOPTIME(TIMERS,69)
1916c END IF
1917C---------------------
1918c IF(NSPMD == 1) THEN
1919c!dir$ omp offload target(mic:MICID)
1920c & nocopy(r,z)
1921c & inout(G1)
1922c!$OMP PARALLEL default(shared) shared(G1)
1923 CALL MIC_DDOT(NDDL, R, Z, G1)
1924c!$OMP END PARALLEL
1925c ELSE
1926C si spmd penser a faire avant D_Y = D_Z*D_W pour les poids
1927c!dir$ omp offload target(mic:MICID)
1928c & nocopy(z,w,r,y)
1929c & inout(G1)
1930c!$OMP PARALLEL default(shared) shared(G1)
1931c CALL MIC_MV(NDDL,Z,W,Y)
1932c CALL MIC_DDOT(NDDL, R, Y, G1)
1933c!$OMP END PARALLEL
1934c IF(IMONM > 0) CALL STARTIME(TIMERS,67)
1935c CALL SPMD_SUM_S(G1)
1936c IF(IMONM > 0) CALL STOPTIME(TIMERS,67)
1937c END IF
1938C---------------------
1939 BETA=G1/G0
1940 IF (ITOL==1) THEN
1941c IF(NSPMD == 1) THEN
1942c!dir$ omp offload target(mic:MICID)
1943c & nocopy(r)
1944c & inout(R2)
1945c!$OMP PARALLEL default(shared) shared(R2)
1946 CALL MIC_DDOT(NDDL, R, R, R2)
1947c!$OMP END PARALLEL
1948c ELSE
1949C si spmd penser a faire avant D_Y = D_R*W pour les poids
1950c!dir$ omp offload target(mic:MICID)
1951c & nocopy(r,w,y)
1952c & inout(R2)
1953c!$OMP PARALLEL default(shared) shared(R2)
1954c CALL MIC_MV(NDDL,R,W,Y)
1955c CALL MIC_DDOT(NDDL, Y, Y, R2)
1956c!$OMP END PARALLEL
1957c IF(IMONM > 0) CALL STARTIME(TIMERS,67)
1958c CALL SPMD_SUM_S(R2)
1959c IF(IMONM > 0) CALL STOPTIME(TIMERS,67)
1960c END IF
1961 ELSEIF (ITOL==3) THEN
1962C------ R2<TOL*TOL*ANORM2*XNORM2------
1963c+1
1964!$OMP SINGLE
1965 R2=ABS(G1)
1966 L_B2=ABS(BETA)*A_OLD*A_OLD
1967 L_B=SQRT(L_B2)
1968 TNORM2=TNORM2+L_B2
1969 B_OLD=BETA
1970C INITIALIZE OTHER QUANTITIES.
1971 GBAR = L_A
1972 DBAR = L_B
1973 RHS1 = OLDB
1974 RHS2 = ZERO
1975 GMAX = ABS( L_A ) + EPS_M
1976 GMIN = GMAX
1977 OLDB2 = L_B2
1978 OLDB = L_B
1979c+1
1980!$OMP END SINGLE
1981 ELSEIF (ITOL==4) THEN
1982 R2=R02
1983 ELSE
1984 R2=ABS(G1)
1985 ENDIF
1986 G0 = G1
1987c+1
1988!$OMP SINGLE
1989 IF (ITOL==3) TOLN=TOLN*TNORM2
1990
1991
1992C----------------------
1993c CALL MY_BARRIER
1994C---------------------
1995C ISTOP=CRIT_STOP(IT,R2,NLIM,TOLN)
1996 IF (IT>=NLIM) THEN
1997 ISTOP = 0
1998 ELSE
1999 IF (R2<=TOLN) THEN
2000 ISTOP = 0
2001 ELSE
2002 ISTOP = 1
2003 ENDIF
2004 ENDIF
2005c+1
2006!$OMP END SINGLE
2007C----------------------
2008c LOOP OVER ITERATIONS
2009C---------------------
2010
2011 DO WHILE (ISTOP==1)
2012
2013c!dir$ omp offload target(mic:MICID)
2014c & nocopy(iadk,iadk0,iadm,iadm0,lt_k,lt_k0,lt_m)
2015c & nocopy(lt_m0,jdik,jdik0,jdim,jdim0,diag_k,diag_m,y,p,x,r,z)
2016c!$OMP PARALLEL default(shared)
2017
2018C D_P = D_Z + BETA*D_P in 2 step : D_P = BETA*D_P ; D_P = D_P + D_Z
2019 CALL MIC_DSCAL(NDDL, BETA, P)
2020 CALL MIC_DAXPY(NDDL, ONE, Z, P)
2021C----------------------
2022c CALL MY_BARRIER
2023C---------------------
2024C CALL MAV_LTGH(
2025C 1 NDDL ,IADK ,JDIK ,DIAG_K,LT_K ,
2026C 2 P ,Y ,F_DDL ,L_DDL ,ITASK )
2027C D_Y = D_P * DIAG_K
2028 CALL MIC_MV(NDDL,P,DIAG_K,Y)
2029C D_Y = D_Y + LT_K * D_P
2030 CALL MIC_SPMV(NDDL ,Y ,P ,LT_K ,IADK ,JDIK )
2031C D_Y = D_Y + LT_K0 * D_P
2032 CALL MIC_SPMV(NDDL ,Y ,P ,LT_K0,IADK0,JDIK0)
2033 IF(NDDLI > 0) THEN
2034C D_Y = D_Y + LT_I0 * D_P
2035ctempo CALL MIC_SPMV(NDDL ,Y ,P ,LT_I0,IADI0,JDII0)
2036 END IF
2037c!$OMP END PARALLEL
2038c IF(NSPMD > 1)THEN
2039c IF(IMONM > 0) CALL STARTIME(TIMERS,68)
2040c!dir$ omp offload target(mic:MICID)
2041c & nocopy(y,ifr2k)
2042c & out(vgat:length(lcom))
2043c!$OMP PARALLEL default(shared)
2044c CALL MIC_GATHER(NDDL, LCOM, Y, VGAT, IFR2K)
2045c!$OMP END PARALLEL
2046c IF(IMONM > 0) CALL STOPTIME(TIMERS,68)
2047c IF(IMONM > 0) CALL STARTIME(TIMERS,66)
2048c CALL SPMD_SUMFC_V(VGAT,VSCA,INDEX,LCOM)
2049c IF(IMONM > 0) CALL STOPTIME(TIMERS,66)
2050c IF(IMONM > 0) CALL STARTIME(TIMERS,69)
2051c!dir$ omp offload target(mic:MICID)
2052c & nocopy(y,ifr2k,index)
2053c & in(vsca:length(lcom))
2054c!$OMP PARALLEL default(shared)
2055c CALL MIC_SCATTER(NDDL, LCOM, Y, VSCA, IFR2K, INDEX)
2056c!$OMP END PARALLEL
2057c IF(IMONM > 0) CALL STOPTIME(TIMERS,69)
2058c END IF
2059C---------------------
2060c IF(NSPMD == 1) THEN
2061c!dir$ omp offload target(mic:MICID)
2062c & nocopy(p,y)
2063c & inout(S)
2064c!$OMP PARALLEL default(shared) shared(S)
2065 CALL MIC_DDOT(NDDL, P, Y, S)
2066c!$OMP END PARALLEL
2067c ELSE
2068C si spmd penser a faire avant D_Y = D_Y*W pour les poids
2069c!dir$ omp offload target(mic:MICID)
2070c & nocopy(y,w,p,z)
2071c & inout(S)
2072c!$OMP PARALLEL default(shared) shared(S)
2073c CALL MIC_MV(NDDL,Y,W,Z)
2074c CALL MIC_DDOT(NDDL, P, Z, S)
2075c!$OMP END PARALLEL
2076c IF(IMONM > 0) CALL STARTIME(TIMERS,67)
2077c CALL SPMD_SUM_S(S)
2078c IF(IMONM > 0) CALL STOPTIME(TIMERS,67)
2079c END IF
2080C---------------------
2081 ALPHA=G0/S
2082c!dir$ omp offload target(mic:MICID)
2083c & nocopy(iadk,iadk0,iadm,iadm0,lt_k,lt_k0,lt_m)
2084c & nocopy(lt_m0,jdik,jdik0,jdim,jdim0,diag_k,diag_m,y,p,x,r,z)
2085c!$OMP PARALLEL default(shared)
2086 CALL MIC_DAXPY(NDDL, ALPHA, P, X)
2087 CALL MIC_DAXPY(NDDL,-ALPHA, Y, R)
2088C----------------------
2089C CALL PREC_SOLVGH(IPREC , ITASK ,NDDL ,IADM , JDIM ,
2090C 6 DIAG_M, LT_M ,R ,Z ,
2091C 7 F_DDL ,L_DDL )
2092 IF(IPREC == 1)THEN
2093C D_Z = D_R
2094 CALL MIC_DCOPY(NDDL, R, Z)
2095 ELSEIF(IPREC == 2)THEN
2096C D_Z = D_R * DIAG_M
2097 CALL MIC_MV(NDDL,R,DIAG_M,Z)
2098 ELSEIF(IPREC == 5)THEN
2099C D_Y = D_R
2100 CALL MIC_DCOPY(NDDL, R, Y)
2101C D_Y = D_Y + LT_M * D_R
2102 CALL MIC_SPMV(NDDL ,Y ,R ,LT_M ,IADM ,JDIM )
2103C D_Z = D_Y * DIAG_M
2104 CALL MIC_MV(NDDL,Y,DIAG_M,Z)
2105 CALL MIC_DCOPY(NDDL, Z, Y)
2106C D_Z = D_Z + LT_M0 * D_Y
2107 CALL MIC_SPMV(NDDL ,Z ,Y ,LT_M0,IADM0,JDIM0)
2108 ELSE
2109 END IF
2110c!$OMP END PARALLEL
2111C----------------------
2112c IF(NSPMD > 1 .AND. IPREC > 1)THEN
2113c IF(IMONM > 0) CALL STARTIME(TIMERS,68)
2114c!dir$ omp offload target(mic:MICID)
2115c & nocopy(z,ifr2k)
2116c & out(vgat:length(lcom))
2117c!$OMP PARALLEL default(shared)
2118c CALL MIC_GATHER(NDDL, LCOM, Z, VGAT, IFR2K)
2119c!$OMP END PARALLEL
2120c IF(IMONM > 0) CALL STOPTIME(TIMERS,68)
2121c IF(IMONM > 0) CALL STARTIME(TIMERS,66)
2122c CALL SPMD_SUMFC_V(VGAT,VSCA,INDEX,LCOM)
2123c IF(IMONM > 0) CALL STOPTIME(TIMERS,66)
2124c IF(IMONM > 0) CALL STARTIME(TIMERS,69)
2125c!dir$ omp offload target(mic:MICID)
2126c & nocopy(z,ifr2k,index)
2127c & in(vsca:length(lcom))
2128c!$OMP PARALLEL default(shared)
2129c CALL MIC_SCATTER(NDDL, LCOM, Z, VSCA, IFR2K, INDEX)
2130c!$OMP END PARALLEL
2131c IF(IMONM > 0) CALL STOPTIME(TIMERS,69)
2132c END IF
2133C---------------------
2134c IF(NSPMD == 1) THEN
2135c!dir$ omp offload target(mic:MICID)
2136c & nocopy(r,z)
2137c & inout(G1)
2138c!$OMP PARALLEL default(shared) shared(G1)
2139 CALL MIC_DDOT(NDDL, R, Z, G1)
2140c!$OMP END PARALLEL
2141c ELSE
2142C si spmd penser a faire avant D_Y = D_Z*W pour les poids
2143c!dir$ omp offload target(mic:MICID)
2144c & nocopy(z,w,r,y)
2145c & inout(G1)
2146c!$OMP PARALLEL default(shared) shared(G1)
2147c CALL MIC_MV(NDDL,Z,W,Y)
2148c CALL MIC_DDOT(NDDL, R, Y, G1)
2149c!$OMP END PARALLEL
2150c IF(IMONM > 0) CALL STARTIME(TIMERS,67)
2151c CALL SPMD_SUM_S(G1)
2152c IF(IMONM > 0) CALL STOPTIME(TIMERS,67)
2153c END IF
2154C---------------------
2155c+1
2156!$OMP single
2157 BETA=G1/G0
2158 G0 = G1
2159c+1
2160!$OMP end single
2161 IF (ITOL==1) THEN
2162c IF(NSPMD == 1) THEN
2163c!dir$ omp offload target(mic:MICID)
2164c & nocopy(r)
2165c & inout(R2)
2166c!$OMP PARALLEL default(shared) shared(R2)
2167 CALL MIC_DDOT(NDDL, R, R, R2)
2168c!$OMP END PARALLEL
2169c ELSE
2170C si spmd penser a faire avant D_Y = D_R*W pour les poids
2171c!dir$ omp offload target(mic:MICID)
2172c & nocopy(r,w,y)
2173c & inout(R2)
2174c!$OMP PARALLEL default(shared) shared(R2)
2175c CALL MIC_MV(NDDL,R,W,Y)
2176c CALL MIC_DDOT(NDDL, Y, Y, R2)
2177c!$OMP END PARALLEL
2178c IF(IMONM > 0) CALL STARTIME(TIMERS,67)
2179c CALL SPMD_SUM_S(R2)
2180c IF(IMONM > 0) CALL STOPTIME(TIMERS,67)
2181c END IF
2182 ELSEIF (ITOL==3) THEN
2183c+1
2184!$OMP single
2185 R2 =ABS(G1)
2186 S=ONE/ALPHA
2187 L_A=S+B_OLD*A_OLD
2188C----------L_B2 : beta(j-1)^2-A_OLD :1/alpha(j-1)-------
2189 L_B2=ABS(BETA)*S*S
2190 L_B=SQRT(L_B2)
2191 A_OLD=S
2192 B_OLD=BETA
2193 ANORM2=TNORM2
2194 TNORM2=TNORM2+L_A*L_A+OLDB2+L_B2
2195 GAMMA = SQRT( GBAR*GBAR + OLDB2 )
2196 CS = GBAR / GAMMA
2197 SN = OLDB / GAMMA
2198 DELTA = CS * DBAR + SN * L_A
2199 GBAR = SN * DBAR - CS * L_A
2200 EPSLN = SN * L_B
2201 DBAR = - CS * L_B
2202 ZL = RHS1 / GAMMA
2203 XNORM2 = XNORM2+ZL*ZL
2204 GMAX = MAX( GMAX, GAMMA )
2205 GMIN = MIN( GMIN, GAMMA )
2206 RHS1 = RHS2 - DELTA * ZL
2207 RHS2 = - EPSLN * ZL
2208 TOLN=TOLS2*ANORM2*XNORM2
2209 OLDB2 = L_B2
2210 OLDB = L_B
2211c+1
2212!$OMP end single
2213 ELSEIF (ITOL==4) THEN
2214 TMP=ALPHA*ALPHA*ABS(G1)
2215 IF (IT>=ND) THEN
2216 DO J=1,ND-1
2217 EPS(J)=EPS(J+1)
2218 ENDDO
2219 EPS(ND)=TMP
2220 R2=ZERO
2221 DO J=1,ND
2222 R2=R2+EPS(J)
2223 ENDDO
2224 ELSE
2225 EPS(IT+1)=TMP
2226 R2=R2+TMP
2227 ENDIF
2228 ELSE
2229 R2 =ABS(G1)
2230 ENDIF
2231c+1
2232!$OMP single
2233.AND. IF(IPRI/=0ITASK==0)THEN
2234 IF(MOD(IT,IP)==0)THEN
2235 RR = SQRT(R2/R02)
2236 WRITE(IOUT,1001)IT,RR
2237 IF(IPRI<0) WRITE(ISTDO,1001)IT,RR
2238 ENDIF
2239 ENDIF
2240C----------------------
2241c CALL MY_BARRIER
2242C---------------------
2243C ISTOP=CRIT_STOP(IT,R2,NLIM,TOLN)
2244 IF (IT>=NLIM) THEN
2245 ISTOP = 0
2246 ELSE
2247 IF (R2<=TOLN) THEN
2248 ISTOP = 0
2249 ELSE
2250 ISTOP = 1
2251 ENDIF
2252 ENDIF
2253C----------------------
2254c CALL MY_BARRIER
2255C---------------------
2256 IT = IT +1
2257c+1
2258!$OMP end single
2259 ENDDO
2260 2060 CONTINUE
2261!$OMP single
2262 tt=OMP_GET_WTIME()-tt
2263 i= omp_get_num_threads()
2264 print *,' '
2265 print *,' '
2266 print *,' execution time on mic with',i,' threads'
2267 print *,' ==> ',tt,' seconds'
2268 print *,' '
2269!$OMP END single
2270c+1
2271!$OMP END PARALLEL
2272 WRITE(IOUT,1001)IT-1,RR
2273 END IF ! fin NSPMD ==1
2274 TF=OMP_GET_WTIME()
2275!dec$ omp offload target(mic:MICID) out(X,R:alloc_if(.false.))
2276!$OMP PARALLEL
2277c!$OMP single
2278c tt=OMP_GET_WTIME()-tt
2279c i= omp_get_num_threads()
2280c print *,' '
2281c print *,' '
2282c print *,' Execution time on MIC with',i,' THREADS'
2283c print *,' ==> ',tt,' SECONDS'
2284c print *,' '
2285c!$OMP END single
2286!$OMP END PARALLEL
2287 TF=OMP_GET_WTIME()-TF
2288 print *,'transfer time mic=>cpu(s) =',TF
2289 print *,'transfer rate mic=>cpu(mb/s)=',
2290 . ((2*NDDL/(1024*1024))*8)/TF
2291c END IF ! fin NSPMD ==1
2292C fin code provisoire
2293
2294c IF(NSPMD > 1) THEN
2295c DEALLOCATE(W)
2296c DEALLOCATE(VGAT)
2297c DEALLOCATE(VSCA)
2298c DEALLOCATE(INDEX)
2299c END IF
2300
2301 END IF ! fin GPUR4R8==2 (MIC double precision)
2302
2303 END IF !only task0
2304C fin code specifique MIC double precision
2305#endif
2306C fin code specifique GPU
2307C routine speciale pour sauvegarder les resultats
2308 IF(ISAVE==1)CALL IMP_RSAVE(NDDL,X,R)
2309
2310C
2311C------due to ISTOP local variable
2312C IF(IT>=NLIM.AND.ISOLV==7) ISTOP = 3
2313 IF(ITASK == 0) THEN
2314#include "lockon.inc"
2315 ISTOP_H = ISTOP
2316#include "lockoff.inc"
2317 CALL PUPD(N_MAX,NDDLI_G,IT)
2318C
2319 IF(IT>=NLIM)THEN
2320 IF (ISOLV==7) THEN
2321#include "lockon.inc"
2322 ISTOP_H = 3
2323#include "lockoff.inc"
2324 ELSE
2325#include "lockon.inc"
2326 ISTOP_H = 1
2327#include "lockoff.inc"
2328
2329.NOT. IF (MIXEDSOL()) THEN
2330 WRITE(IOUT,*)
2331 WRITE(IOUT,1003)NLIM
2332 WRITE(IOUT,*)
2333 WRITE(ISTDO,*)
2334 WRITE(ISTDO,1003)NLIM
2335 WRITE(ISTDO,*)
2336 IF(ITOL==3)THEN
2337 WRITE(IOUT,2000)
2338 . EXIT, SQRT(ANORM2), SQRT(XNORM2),GMAX/GMIN
2339 WRITE(ISTDO,2000)
2340 . EXIT, SQRT(ANORM2), SQRT(XNORM2),GMAX/GMIN
2341 ENDIF
2342C----add condition to remove wrong message with mix solver
2343 IF (R2>HUNDRED*TOLN) THEN
2344 ISTOP_H = 2
2345 RR = SQRT(R2/R02)
2346 WRITE(IOUT,*)
2347 WRITE(IOUT,1004)RR
2348 WRITE(IOUT,*)
2349 WRITE(ISTDO,*)
2350 WRITE(ISTDO,1004)RR
2351 WRITE(ISTDO,*)
2352 ENDIF
2353.NOT. END IF !((MIXEDSOL)) THEN
2354
2355 END IF !(ISOLV==7) THEN
2356 ENDIF
2357 IF(IPRI/=0)THEN
2358 RR = SQRT(R2/R02)
2359 WRITE(IOUT,*)
2360 WRITE(IOUT,1002)IT,RR
2361 IF(ITOL==3)WRITE(IOUT,2000)
2362 . EXIT, SQRT(ANORM2), SQRT(XNORM2),GMAX/GMIN
2363 WRITE(IOUT,*)
2364 IF(IPRI<0) THEN
2365 WRITE(ISTDO,*)
2366 WRITE(ISTDO,1002)IT,RR
2367 IF(ITOL==3)WRITE(ISTDO,2000)
2368 . EXIT, SQRT(ANORM2), SQRT(XNORM2),GMAX/GMIN
2369 WRITE(ISTDO,*)
2370 ENDIF
2371 ENDIF
2372 IF(ITOL==3) THEN
2373 K_LAMDA0= GMIN
2374 K_LAMDA1= GMAX
2375 ELSE
2376 K_LAMDA0= ZERO
2377 K_LAMDA1= ZERO
2378 ENDIF
2379 END IF !(ITASK == 0) THEN
2380C----------------------
2381 CALL MY_BARRIER
2382C----------------------
2383#include "lockon.inc"
2384 ISTOP = ISTOP_H
2385#include "lockoff.inc"
2386
2387 CALL MY_BARRIER
2388C--------------------------------------------
2389 1000 FORMAT(5X,'iteration=',I8,5X,' initial residual norm=',E11.4)
2390 1001 FORMAT(5X,'iteration=',I8,5X,' relative residual norm=',E11.4)
2391 1002 FORMAT(3X,'total c.g. iteration=',I8,5X,
2392 . ' relative residual norm=',E11.4)
2393 1003 FORMAT(5X,
2394 . '---warning : the iteration limit number was reached',I8)
2395 1004 FORMAT(5X,'warning:c.g stop with relative residual norm=',E11.4)
2396 2000 FORMAT(/ 5X, A, 2X, 'anorm =', E12.4, 2X, 'xnorm =', E12.4,2X,
2397 . 'kcond =', E12.4)
2398 2002 FORMAT(/ 5X, 'with', 2X, 'alfa =', E12.4, 2X, 'beta =',
2399 . E12.4,2X,'oldb =', E12.4)
2400 RETURN
2401#endif
the
end diagonal values have been computed in the(sparse) matrix id.SOL
norm
norm(diag(diag(diag(inv(mat))) -id.SOL), 2) % destroy mumps instance id.JOB
mixedsol
logical function mixedsol()
Definition imp_pcg.F:2484
imp_isave
subroutine imp_isave(nddl, x, r, diag_k, diag_m, nnz, lt_k, lt_k0, lt_m, lt_m0, iadk, jdik, iadk0, jdik0, iadm, jdim, iadm0, jdim0, nnzm, tols, nlim, itol, eps_m, iprec)
Definition imp_pcg.F:69
nlim_mix
subroutine nlim_mix(nddl, nddli, nlim)
Definition imp_pcg.F:2451
imp_isave2
subroutine imp_isave2(nddl, x, diag_k, nnz, lt_k, iadk, jdik, lt_k0, iadk0, jdik0)
Definition imp_pcg.F:116
max
#define max(a, b)
Definition macros.h:21
dsgraph_mod
Definition dsgraph_mod.F:31
imp_frk
Definition impbufdef_mod.F:740
imp_frk::nd_fr
integer, dimension(:), allocatable nd_fr
Definition impbufdef_mod.F:754
imp_intm
Definition imp_intm.F:118
imp_intm::jdi_si
integer, dimension(:), allocatable jdi_si
Definition imp_intm.F:174
imp_intm::iddl_sl
integer, dimension(:), allocatable iddl_sl
Definition imp_intm.F:178
imp_intm::iad_ss
integer, dimension(:), allocatable iad_ss
Definition imp_intm.F:175
imp_intm::iad_si
integer, dimension(:), allocatable iad_si
Definition imp_intm.F:174
imp_intm::jdi_sl
integer, dimension(:), allocatable jdi_sl
Definition imp_intm.F:175
imp_intm::iad_sl
integer, dimension(:), allocatable iad_sl
Definition imp_intm.F:145
imp_intm::nddl_si
integer nddl_si
Definition imp_intm.F:173
imp_intm::nddl_sl
integer nddl_sl
Definition imp_intm.F:173
imp_intm::iad_srem
integer, dimension(:), allocatable iad_srem
Definition imp_intm.F:145
imp_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::iadk0
integer, dimension(:), allocatable iadk0
Definition impbufdef_mod.F:584
imp_workh::iadm0
integer, dimension(:), allocatable iadm0
Definition impbufdef_mod.F:584
message_mod
Definition message_mod.F:1249
prec_solvh
subroutine prec_solvh(iprec, itask, graphe, iad_elem, fr_elem, diag_k, lt_k, iadk, jdik, itab, iprint, insolv, it, fac_k, ipiv_k, nk, mumps_par, cddlp, isolv, idsc, iddl, ikc, inloc, ndof, nddl, nnz, iadm, jdim, diag_m, lt_m, v, z, f_ddl, l_ddl)
Definition prec_solv.F:590
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
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

◆ imp_ppcgh()

subroutine imp_ppcgh ( integer iprec,
integer nddl,
integer nnz,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_k,
lt_k,
integer nddli,
integer, dimension(*) itok,
integer, dimension(*) iadi,
integer, dimension(*) jdii,
lt_i,
integer nnzm,
integer, dimension(*) iadm,
integer, dimension(*) jdim,
diag_m,
lt_m,
x,
r,
integer itol,
tol,
p,
z,
y,
integer itask,
integer iprint,
integer n_max,
eps_m,
f_x,
integer istop,
integer, dimension(*) w_ddl,
a,
ar,
ve,
ms,
xe,
d,
dr,
integer, dimension(*) ndof,
integer, dimension(*) ipari,
type(intbuf_struct_), dimension(*) intbuf_tab,
integer, dimension(*) num_imp,
integer, dimension(*) ns_imp,
integer, dimension(*) ne_imp,
integer nsrem,
integer nsl,
integer nmonv,
integer, dimension(*) imonv,
integer, dimension(*) monvol,
type (surf_), dimension(nsurf) igrsurf,
volmon,
integer, dimension(*) fr_mv,
integer, dimension(*) ibfv,
skew,
xframe,
type(prgraph), dimension(*) graphe,
integer, dimension(2,*) iad_elem,
integer, dimension(*) fr_elem,
integer, dimension(*) itab,
integer insolv,
integer itn,
fac_k,
integer, dimension(*) ipiv_k,
integer nk,
integer mumps_par,
integer, dimension(*) cddlp,
integer isolv,
integer idsc,
integer, dimension(*) iddl,
integer, dimension(*) ikc,
integer, dimension(*) inloc,
integer, dimension(*) ind_imp,
xi_c,
r0,
integer nddli_g,
integer intp_c,
integer, dimension(*) irbe3,
integer, dimension(*) lrbe3,
integer, dimension(*) irbe2,
integer, dimension(*) lrbe2 )

Definition at line 2907 of file imp_pcg.F.

2925C-----------------------------------------------
2926C M o d u l e s
2927C-----------------------------------------------
2928 USE dsgraph_mod
2929 USE imp_workh
2930 USE imp_pcg_proj
2931 USE intbufdef_mod
2932 USE groupdef_mod
2933C-----------------------------------------------
2934C I m p l i c i t T y p e s
2935C-----------------------------------------------
2936#include "implicit_f.inc"
2937C-----------------------------------------------
2938C C o m m o n B l o c k s
2939C-----------------------------------------------
2940#if defined(MUMPS5)
2941#include "dmumps_struc.h"
2942#endif
2943#include "com04_c.inc"
2944#include "units_c.inc"
2945#include "task_c.inc"
2946C-----------------------------------------------
2947C D u m m y A r g u m e n t s
2948C-----------------------------------------------
2949C----------resol [K]{X}={F}---------
2950 INTEGER NDDL ,NNZ ,IADK(*) ,JDIK(*),ITOL,
2951 . NDDLI ,ITOK(*) ,IADI(*),JDII(*),N_MAX,
2952 . NNZM ,IADM(*),JDIM(*),IPREC,ITASK,IPRINT,
2953 . ISTOP,W_DDL(*),IBFV(*),INTP_C,IRBE3(*) ,LRBE3(*),
2954 . IRBE2(*) ,LRBE2(*)
2955 INTEGER NDOF(*),NE_IMP(*),NSREM ,NSL,
2956 . IPARI(*) ,NUM_IMP(*),NS_IMP(*) ,IND_IMP(*)
2957 INTEGER NMONV,IMONV(*),MONVOL(*),FR_MV(*)
2958 INTEGER IAD_ELEM(2,*), FR_ELEM(*), ITAB(*),
2959 . INSOLV, ITN, IPIV_K(*), NK, CDDLP(*), ISOLV, IDSC,
2960 . IDDL(*), IKC(*), INLOC(*),NDDLI_G
2961 my_real diag_k(*), lt_k(*) ,diag_m(*),lt_m(*) ,x(*), tol, p(*) ,z(*) ,r(*) ,y(*),lt_i(*) ,eps_m,f_x,xi_c(*)
2962 my_real a(3,*),ar(3,*),ve(3,*),d(3,*),dr(3,*),xe(3,*), ms(*),volmon(*),skew(*) ,xframe(*),fac_k(*), r0(*)
2963 TYPE(PRGRAPH) :: GRAPHE(*)
2964#ifdef MUMPS5
2965 TYPE(DMUMPS_STRUC) MUMPS_PAR
2966#else
2967 ! Fake declaration as DMUMPS_STRUC is shipped with MUMPS
2968 INTEGER MUMPS_PAR
2969#endif
2970 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
2971 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
2972#ifdef MUMPS5
2973C-----------------------------------------------
2974C L o c a l V a r i a b l e s
2975C-----------------------------------------------
2976 INTEGER I,J,IT,IP,NLIM,ND,IERR,IPRI,IERROR,NNZI,LOC_PROC,ICK
2977 parameter(nd=4)
2978 CHARACTER*4 EXIT
2979 CHARACTER*11 WARR
2980 my_real s , r2, r02,alpha,beta,g0,g1,rr,tols,toln,tols2
2981 INTEGER CRIT_STOP,IUPD,IUPD0,F_DDL,L_DDL,IFLG,GPUR4R8,ITP
2982 EXTERNAL crit_stop
2983 my_real anorm2,xnorm2,l_a,l_b2,l_b,a_old,b_old,tmp,g00,r2_old,rmax
2984 my_real cs,dbar, delta, denom, kcond,snprod,qrnorm,gamma, gbar, gmax, gmin, epsln,lqnorm,diag,cgnorm,
2985 . oldb, rhs1, rhs2,sn, zbar, zl ,oldb2,tnorm2,eps(4)
2986C--------------P-PCG Usage--------------------------
2987 my_real, DIMENSION(:),ALLOCATABLE :: sq_diag_m
2988 SAVE sq_diag_m
2989C--------------END GPU SPECIFIC----------------------
2990 DATA EXIT /'WITH'/
2991 DATA warr /'**WARRING**'/
2992C-----------------------------------------------
2993 loc_proc=ispmd+1
2994C--------------INITIALISATION--------------------------
2995C-----Istop=1 : NIT>=N_LIM+ RR>TOL
2996C------X(I)=ZERO----******N_MAX,EPS_M a calculer avant----
2997 f_ddl=1+itask*nddl/nthread
2998 l_ddl=(itask+1)*nddl/nthread
2999C
3000 istop=0
3001 nlim=n_max
3002 CALL nlim_mix(n_max,nddli_g,nlim)
3003 nlim=max(nlim,2)
3004 tols=max(tol,eps_m)
3005 ipri = iprint
3006 IF (ispmd/=0) ipri = 0
3007C--------
3008 IF (itask == 0) THEN
3009 IF(ipri/=0)THEN
3010 WRITE(iout,*)'*** BEGIN PROJECTED CONJUGATE GRADIENT ITERATION ***'
3011 WRITE(iout,*)
3012 ENDIF
3013 IF(ipri<0)THEN
3014 WRITE(istdo,*)'*** BEGIN PROJECTED CONJUGATE GRADIENT ITERATION ***'
3015 WRITE(istdo,*)
3016 ENDIF
3017 END IF !(ITASK == 0) THEN
3018 ip = iabs(ipri)
3019 it=0
3020C-------------Vector Z is no more necessary-> work array for A'*v (MMAV_LTH)
3021 iupd = 0
3022 iupd0 = 0
3023 IF (iprec>1) THEN
3024 IF (itask == 0) ALLOCATE (sq_diag_m(nddl))
3025C----------------------
3026 CALL my_barrier
3027C--------For S ini only-------------
3028 DO i = f_ddl,l_ddl
3029 sq_diag_m(i) = sqrt(diag_m(i))
3030 ENDDO
3031 END IF !(IPREC>1) THEN
3032C----------------------
3033 CALL my_barrier
3034C--------For S ini only----X is in place of R to not change R---------
3035 rmax=zero
3036 CALL imp_inisi(
3037 1 nddl ,iadk ,jdik ,diag_k ,lt_k ,
3038 2 nddli ,itok ,iadi ,jdii ,lt_i ,
3039 3 nnzm ,iadm ,jdim ,diag_m ,lt_m ,
3040 4 x ,p ,y ,
3041 8 a ,ar ,ve ,ms ,xe ,
3042 9 d ,dr ,ndof ,ipari ,intbuf_tab,
3043 a num_imp,ns_imp,ne_imp,nsrem ,
3044 b nsl ,nmonv ,imonv ,monvol,igrsurf ,
3045 c volmon,fr_mv ,ibfv ,skew ,
3046 d xframe ,z ,iddl ,ikc ,inloc ,
3047 g ind_imp,xi_c ,irbe3 ,lrbe3 ,irbe2 ,
3048 h lrbe2 ,itask ,w_ddl ,f_ddl ,l_ddl ,
3049 i sq_diag_m)
3050C /---------------/
3051 CALL my_barrier
3052C /---------------/
3053 CALL imp_inist(
3054 1 nddl ,nddli ,iadk ,jdik ,diag_k ,
3055 2 lt_k ,itok ,iadi ,jdii ,lt_i ,
3056 3 itask ,w_ddl ,a ,ar ,ve ,
3057 4 d ,dr ,ndof ,ipari ,intbuf_tab,
3058 5 num_imp,ns_imp,ne_imp,nsrem ,
3059 6 nsl ,nmonv ,imonv ,monvol,igrsurf ,
3060 7 volmon,fr_mv ,ibfv ,skew ,
3061 8 xframe ,ind_imp,xi_c ,ms ,xe ,
3062 9 irbe3 ,lrbe3 ,irbe2 ,lrbe2 ,iadm ,
3063 a jdim ,sq_diag_m, lt_m ,f_ddl ,l_ddl,
3064 b z )
3065C /---------------/
3066 CALL my_barrier
3067C /---------------/
3068C--------b'=Lm^t b--------------
3069 CALL mmv_lth(nddl ,iadm ,jdim ,sq_diag_m,lt_m ,
3070 2 r ,z ,f_ddl ,l_ddl ,itask )
3071C----------------------
3072 CALL my_barrier
3073C---------------------
3074 DO i = f_ddl,l_ddl
3075 r(i) = z(i)
3076 ENDDO
3077 CALL produt_h(f_ddl ,l_ddl ,r ,r ,w_ddl , g0 ,itask )
3078C------x' ini
3079 CALL imp_inix(f_ddl,l_ddl,nddl,x ,r ,w_ddl,itask )
3080C----------------------
3081 CALL my_barrier
3082C---------------------
3083 CALL mmav_lth(
3084 1 nddl ,nddli ,iadk ,jdik ,diag_k,
3085 2 lt_k ,iadi ,jdii ,itok ,lt_i ,
3086 3 x ,y ,a ,ar ,
3087 5 ve ,ms ,xe ,d ,dr ,
3088 6 ndof ,ipari ,intbuf_tab ,num_imp,
3089 7 ns_imp,ne_imp,nsrem ,nsl ,ibfv ,
3090 8 skew ,xframe,monvol,volmon,igrsurf ,
3091 9 fr_mv,nmonv ,imonv ,ind_imp,
3092 a xi_c ,iupd ,irbe3 ,lrbe3 ,irbe2 ,
3093 b lrbe2 ,iadm ,jdim ,sq_diag_m,lt_m ,
3094 c f_ddl ,l_ddl ,itask ,z )
3095C----------------------
3096 CALL my_barrier
3097C---------------------
3098 IF (itol==1) THEN
3099 r02 = g0
3100 ELSEIF (itol==3) THEN
3101C----------initialization of XNORM2
3102 CALL produt_h( f_ddl ,l_ddl ,x ,x ,w_ddl , xnorm2 ,itask )
3103 END IF
3104C
3105 DO i=f_ddl,l_ddl
3106 r(i) = r(i)-y(i)
3107 ENDDO
3108C----------------------
3109 CALL my_barrier
3110C---------------------
3111C CALL PREC_SOLVH(IPREC, ITASK ,
3112c 1 GRAPHE,IAD_ELEM,FR_ELEM,DIAG_K,LT_K ,
3113c 2 IADK ,JDIK ,ITAB ,IPRI,INSOLV ,
3114c 3 ITN ,FAC_K , IPIV_K, NK ,MUMPS_PAR,
3115c 4 CDDLP ,ISOLV , IDSC , IDDL ,IKC ,
3116c 5 INLOC ,NDOF , NDDL ,NNZM ,IADM ,
3117c 6 JDIM ,DIAG_M , LT_M ,R ,Z ,
3118c 7 F_DDL ,L_DDL )
3119 DO i = f_ddl,l_ddl
3120 p(i) = r(i)
3121 ENDDO
3122C----------------------
3123 CALL my_barrier
3124C---------------------
3125 CALL imp_pro_p(f_ddl,l_ddl,nddl ,p ,w_ddl,itask )
3126C----------------------
3127 CALL my_barrier
3128C---------------------
3129 CALL produt_h(f_ddl ,l_ddl ,r ,r ,w_ddl , g0 ,itask )
3130C---------------------
3131 CALL mmav_lth(
3132 1 nddl ,nddli ,iadk ,jdik ,diag_k,
3133 2 lt_k ,iadi ,jdii ,itok ,lt_i ,
3134 3 p ,y ,a ,ar ,
3135 5 ve ,ms ,xe ,d ,dr ,
3136 6 ndof ,ipari ,intbuf_tab ,num_imp,
3137 7 ns_imp,ne_imp,nsrem ,nsl ,ibfv ,
3138 8 skew ,xframe,monvol,volmon,igrsurf ,
3139 9 fr_mv,nmonv ,imonv ,ind_imp,
3140 a xi_c ,iupd ,irbe3 ,lrbe3 ,irbe2 ,
3141 b lrbe2 ,iadm ,jdim ,sq_diag_m,lt_m ,
3142 c f_ddl ,l_ddl ,itask ,z )
3143C----------------------
3144 CALL my_barrier
3145C---------------------
3146 CALL imp_updv2(
3147 1 nddl ,nddli ,iadk ,jdik ,diag_k ,
3148 2 lt_k ,itok ,iadi ,jdii ,lt_i ,
3149 3 itask ,w_ddl ,a ,ar ,ve ,
3150 4 d ,dr ,ndof ,ipari ,intbuf_tab,
3151 5 num_imp,ns_imp,ne_imp,nsrem ,
3152 6 nsl ,nmonv ,imonv ,monvol,igrsurf ,
3153 7 volmon,fr_mv ,ibfv ,skew ,
3154 8 xframe ,ind_imp,xi_c ,ms ,xe ,
3155 9 irbe3 ,lrbe3 ,irbe2 ,lrbe2 ,proj_v,
3156 a p ,y ,f_ddl ,l_ddl ,0 ,
3157 b 0 ,z ,iadm ,jdim ,sq_diag_m,
3158 c lt_m )
3159 CALL produt_h(f_ddl ,l_ddl ,p ,y ,w_ddl , s ,itask )
3160C---------------------
3161 IF (g0==zero) THEN
3162 IF (itol>1) THEN
3163 istop=-1
3164 GOTO 200
3165 ELSE
3166 alpha = zero
3167 ENDIF
3168 ELSE
3169 alpha = g0/s
3170 ENDIF
3171 tols2=tols*tols
3172 IF (itol==1) THEN
3173C---------------------
3174 r2 =g0
3175 ELSEIF (itol==3) THEN
3176C------ R2<TOL*TOL*ANORM2*XNORM2------
3177 r02=abs(g0)
3178 r2 =r02
3179 l_a=one/alpha
3180C L_B2=R02
3181 tnorm2=l_a*l_a
3182 anorm2=zero
3183 IF (m_vs == 0) xnorm2=zero
3184 a_old=l_a
3185 b_old=zero
3186 oldb = sqrt(r02)
3187 ELSEIF (itol==4) THEN
3188 r02=alpha*alpha*abs(g0)
3189 eps(1)=r02
3190 r2=r02
3191 ELSE
3192 r02=abs(g0)
3193 r2 =r02
3194 ENDIF
3195 IF (r02==zero) THEN
3196 istop=-1
3197 GOTO 200
3198 ENDIF
3199 toln=r02*tols2
3200 IF(ipri/=0.AND.itask==0)THEN
3201 rr = sqrt(r2)
3202 IF(ipri<0) WRITE(istdo,1000)it,rr
3203 WRITE(iout,1000)it,rr
3204 ENDIF
3205C-------pour etre coherent avec lanzos for linear
3206C----------------------
3207 CALL my_barrier
3208C---------------------
3209 it=1
3210 DO i=f_ddl,l_ddl
3211 x(i) = x(i) + alpha*p(i)
3212 r(i) = r(i) - alpha*y(i)
3213 ENDDO
3214C----------------------
3215 CALL my_barrier
3216C---------------------
3217c CALL PREC_SOLVH(IPREC, ITASK ,
3218c 1 GRAPHE,IAD_ELEM,FR_ELEM,DIAG_K,LT_K ,
3219c 2 IADK ,JDIK ,ITAB ,IPRI,INSOLV ,
3220c 3 ITN ,FAC_K , IPIV_K, NK ,MUMPS_PAR,
3221c 4 CDDLP ,ISOLV , IDSC , IDDL ,IKC ,
3222c 5 INLOC ,NDOF , NDDL ,NNZM ,IADM ,
3223c 6 JDIM ,DIAG_M , LT_M ,R ,Z ,
3224c 7 F_DDL ,L_DDL )
3225C---------------------
3226 CALL produt_h( f_ddl ,l_ddl ,r ,r ,w_ddl , g1 ,itask )
3227C---------------------
3228 beta=g1/g0
3229 IF (itol==1) THEN
3230 r2 = g1
3231 ELSEIF (itol==3) THEN
3232C------ R2<TOL*TOL*ANORM2*XNORM2------
3233 r2=abs(g1)
3234 l_b2=abs(beta)*a_old*a_old
3235 l_b=sqrt(l_b2)
3236 tnorm2=tnorm2+l_b2
3237 b_old=beta
3238C* INITIALIZE OTHER QUANTITIES.
3239 gbar = l_a
3240 dbar = l_b
3241 rhs1 = oldb
3242 rhs2 = zero
3243 gmax = abs( l_a ) + eps_m
3244 gmin = gmax
3245 oldb2 = l_b2
3246 oldb = l_b
3247 ELSEIF (itol==4) THEN
3248 r2=r02
3249 ELSE
3250 r2=abs(g1)
3251 ENDIF
3252 g0 = g1
3253 IF (itol==3) toln=toln*tnorm2
3254C----------------------
3255 CALL my_barrier
3256C---------------------
3257 istop=crit_stop(it,r2,nlim,toln)
3258 IF(nddli_g>0.AND.intp_c==-1)iupd0 = -intp_c
3259 DO WHILE (istop==1)
3260 DO i=f_ddl,l_ddl
3261 p(i) = r(i) + beta*p(i)
3262 ENDDO
3263 IF(iupd0>0.AND.it>nddli_g/2) iupd = iupd0
3264C
3265C------PCG(PROJECTION)----
3266 CALL imp_pro_p(f_ddl,l_ddl,nddl ,p ,w_ddl,itask )
3267C
3268C----------------------
3269 CALL my_barrier
3270C---------------------
3271 CALL mmav_lth(
3272 1 nddl ,nddli ,iadk ,jdik ,diag_k,
3273 2 lt_k ,iadi ,jdii ,itok ,lt_i ,
3274 3 p ,y ,a ,ar ,
3275 5 ve ,ms ,xe ,d ,dr ,
3276 6 ndof ,ipari ,intbuf_tab ,num_imp,
3277 7 ns_imp,ne_imp,nsrem ,nsl ,ibfv ,
3278 8 skew ,xframe,monvol,volmon,igrsurf ,
3279 9 fr_mv,nmonv ,imonv ,ind_imp,
3280 a xi_c ,iupd ,irbe3 ,lrbe3 ,irbe2 ,
3281 b lrbe2 ,iadm ,jdim ,sq_diag_m,lt_m ,
3282 c f_ddl ,l_ddl ,itask ,z )
3283C----------------------
3284 CALL my_barrier
3285C---------------------
3286 ick=0
3287 CALL imp_updv2(
3288 1 nddl ,nddli ,iadk ,jdik ,diag_k ,
3289 2 lt_k ,itok ,iadi ,jdii ,lt_i ,
3290 3 itask ,w_ddl ,a ,ar ,ve ,
3291 4 d ,dr ,ndof ,ipari ,intbuf_tab,
3292 5 num_imp,ns_imp,ne_imp,nsrem ,
3293 6 nsl ,nmonv ,imonv ,monvol,igrsurf ,
3294 7 volmon,fr_mv ,ibfv ,skew ,
3295 8 xframe ,ind_imp,xi_c ,ms ,xe ,
3296 9 irbe3 ,lrbe3 ,irbe2 ,lrbe2 ,proj_v,
3297 a p ,y ,f_ddl ,l_ddl ,it ,
3298 b ick ,z ,iadm ,jdim ,sq_diag_m,
3299 c lt_m )
3300C----------------------
3301 CALL my_barrier
3302C---------------------
3303 CALL produt_h(f_ddl ,l_ddl ,p ,y ,w_ddl , s ,itask )
3304C---------------------
3305 alpha=g0/s
3306 IF(mod(it,10)<0)THEN
3307 DO i=f_ddl,l_ddl
3308 x(i) = x(i) + alpha*p(i)
3309 ENDDO
3310 CALL mmav_lth(
3311 1 nddl ,nddli ,iadk ,jdik ,diag_k,
3312 2 lt_k ,iadi ,jdii ,itok ,lt_i ,
3313 3 x ,y ,a ,ar ,
3314 5 ve ,ms ,xe ,d ,dr ,
3315 6 ndof ,ipari ,intbuf_tab ,num_imp,
3316 7 ns_imp,ne_imp,nsrem ,nsl ,ibfv ,
3317 8 skew ,xframe,monvol,volmon,igrsurf ,
3318 9 fr_mv,nmonv ,imonv ,ind_imp,
3319 a xi_c ,iupd ,irbe3 ,lrbe3 ,irbe2 ,
3320 b lrbe2 ,iadm ,jdim ,sq_diag_m,lt_m ,
3321 c f_ddl ,l_ddl ,itask ,z )
3322 DO i=f_ddl,l_ddl
3323 r(i) = r0(i) - y(i)
3324 ENDDO
3325C----------------------
3326 CALL my_barrier
3327C---------------------
3328 ELSE
3329 DO i=f_ddl,l_ddl
3330 x(i) = x(i) + alpha*p(i)
3331 r(i) = r(i) - alpha*y(i)
3332 ENDDO
3333 END IF ! IF(MOD(IT,IP)==0)THEN
3334C----------------------
3335 CALL my_barrier
3336C---------------------
3337c CALL PREC_SOLVH(IPREC, ITASK ,
3338c 1 GRAPHE,IAD_ELEM,FR_ELEM,DIAG_K,LT_K ,
3339c 2 IADK ,JDIK ,ITAB ,IPRI,INSOLV ,
3340c 3 ITN ,FAC_K , IPIV_K, NK ,MUMPS_PAR,
3341c 4 CDDLP ,ISOLV , IDSC , IDDL ,IKC ,
3342c 5 INLOC ,NDOF , NDDL ,NNZM ,IADM ,
3343c 6 JDIM ,DIAG_M , LT_M ,R ,Z ,
3344c 7 F_DDL ,L_DDL )
3345C---------------------
3346 CALL produt_h(f_ddl ,l_ddl ,r ,r ,w_ddl , g1 ,itask )
3347C---------------------
3348 beta=g1/g0
3349 g0 = g1
3350 IF (itol==1) THEN
3351 r2 = g1
3352 ELSEIF (itol==3) THEN
3353 r2 =abs(g1)
3354 s=one/alpha
3355 l_a=s+b_old*a_old
3356C----------L_B2 : beta(j-1)^2-A_OLD :1/alpha(j-1)-------
3357 l_b2=abs(beta)*s*s
3358 l_b=sqrt(l_b2)
3359 a_old=s
3360 b_old=beta
3361 anorm2=tnorm2
3362 tnorm2=tnorm2+l_a*l_a+oldb2+l_b2
3363 gamma = sqrt( gbar*gbar + oldb2 )
3364 cs = gbar / gamma
3365 sn = oldb / gamma
3366 delta = cs * dbar + sn * l_a
3367 gbar = sn * dbar - cs * l_a
3368 epsln = sn * l_b
3369 dbar = - cs * l_b
3370 zl = rhs1 / gamma
3371 xnorm2 = xnorm2+zl*zl
3372 gmax = max( gmax, gamma )
3373 gmin = min( gmin, gamma )
3374 rhs1 = rhs2 - delta * zl
3375 rhs2 = - epsln * zl
3376 toln=tols2*anorm2*xnorm2
3377 oldb2 = l_b2
3378 oldb = l_b
3379 ELSEIF (itol==4) THEN
3380 tmp=alpha*alpha*abs(g1)
3381 IF (it>=nd) THEN
3382 DO j=1,nd-1
3383 eps(j)=eps(j+1)
3384 ENDDO
3385 eps(nd)=tmp
3386 r2=zero
3387 DO j=1,nd
3388 r2=r2+eps(j)
3389 ENDDO
3390 ELSE
3391 eps(it+1)=tmp
3392 r2=r2+tmp
3393 ENDIF
3394 ELSE
3395 r2 =abs(g1)
3396 ENDIF
3397C
3398 CALL imp_updv1(
3399 1 r2 ,r2_old ,rmax ,proj_v,p ,
3400 2 it ,f_ddl,l_ddl )
3401C
3402 IF(ipri/=0.AND.itask==0)THEN
3403 IF(mod(it,ip)==0)THEN
3404 rr = sqrt(r2/r02)
3405 WRITE(iout,1001)it,rr
3406 IF(ipri<0) WRITE(istdo,1001)it,rr
3407 ENDIF
3408 ENDIF
3409C----------------------
3410 CALL my_barrier
3411C---------------------
3412 istop=crit_stop(it,r2,nlim,toln)
3413 IF((iupd>0.AND.it==nlim).OR.
3414 . (iupd==0.AND.istop/=1.AND.iupd0>0))THEN
3415C------- re-iter with linear Kint------
3416 iupd0 = 0
3417 IF(iupd>0) iupd = 0
3418 istop = 1
3419 nlim = nlim + nlim
3420 DO i=f_ddl,l_ddl
3421 x(i) = zero
3422 ENDDO
3423C----------------------
3424 CALL my_barrier
3425C---------------------
3426 CALL mmav_lth(
3427 1 nddl ,nddli ,iadk ,jdik ,diag_k,
3428 2 lt_k ,iadi ,jdii ,itok ,lt_i ,
3429 3 x ,y ,a ,ar ,
3430 5 ve ,ms ,xe ,d ,dr ,
3431 6 ndof ,ipari ,intbuf_tab ,num_imp,
3432 7 ns_imp,ne_imp,nsrem ,nsl ,ibfv ,
3433 8 skew ,xframe,monvol,volmon,igrsurf ,
3434 9 fr_mv,nmonv ,imonv ,ind_imp,
3435 a xi_c ,iupd ,irbe3 ,lrbe3 ,irbe2 ,
3436 b lrbe2 ,iadm ,jdim ,sq_diag_m,lt_m ,
3437 c f_ddl ,l_ddl ,itask ,z )
3438C----------------------
3439 CALL my_barrier
3440C---------------------
3441 DO i=f_ddl,l_ddl
3442 r(i) = r0(i)-y(i)
3443 ENDDO
3444C----------------------
3445 CALL my_barrier
3446c CALL PREC_SOLVH(IPREC, ITASK ,
3447c 1 GRAPHE,IAD_ELEM,FR_ELEM,DIAG_K,LT_K ,
3448c 2 IADK ,JDIK ,ITAB ,IPRI,INSOLV ,
3449c 3 ITN ,FAC_K , IPIV_K, NK ,MUMPS_PAR,
3450c 4 CDDLP ,ISOLV , IDSC , IDDL ,IKC ,
3451c 5 INLOC ,NDOF , NDDL ,NNZM ,IADM ,
3452c 6 JDIM ,DIAG_M , LT_M ,R ,Z ,
3453c 7 F_DDL ,L_DDL )
3454C---------------------
3455 CALL produt_h( f_ddl ,l_ddl ,r ,r ,w_ddl , g0 ,itask )
3456 beta = zero
3457C------ R2<TOL*TOL*ANORM2*XNORM2------
3458 IF (itol==3) THEN
3459 tnorm2=l_a*l_a
3460 anorm2=zero
3461 xnorm2=zero
3462 a_old=zero
3463 b_old=zero
3464 l_b=zero
3465C* INITIALIZE OTHER QUANTITIES.
3466 gbar = l_a
3467 dbar = zero
3468 rhs1 = sqrt(r02)
3469 rhs2 = zero
3470 gmax = abs( l_a ) + eps_m
3471 gmin = gmax
3472 oldb2 = zero
3473 oldb = l_b
3474 ELSEIF (itol==4) THEN
3475 DO j=1,nd
3476 eps(j)=r02
3477 ENDDO
3478 ENDIF
3479 ENDIF
3480C----------------------
3481 CALL my_barrier
3482C---------------------
3483 it = it +1
3484 ENDDO
3485 200 CONTINUE
3486C--------PCG (PROJECTION)
3487 IF (istop==0) THEN
3488 CALL imp_updst(
3489 1 nddl ,nddli ,iadk ,jdik ,diag_k ,
3490 2 lt_k ,itok ,iadi ,jdii ,lt_i ,
3491 3 itask ,w_ddl ,a ,ar ,ve ,
3492 4 d ,dr ,ndof ,ipari ,intbuf_tab,
3493 5 num_imp,ns_imp,ne_imp,nsrem ,
3494 6 nsl ,nmonv ,imonv ,monvol,igrsurf ,
3495 7 volmon,fr_mv ,ibfv ,skew ,
3496 8 xframe ,ind_imp,xi_c ,ms ,xe ,
3497 9 irbe3 ,lrbe3 ,irbe2 ,lrbe2 ,x ,
3498 a p ,y ,iadm ,jdim ,sq_diag_m ,
3499 b lt_m ,f_ddl ,l_ddl )
3500C----------------------
3501 CALL my_barrier
3502C----------------------
3503C--------x=Lm x'--------------
3504 CALL mmv_lh(nddl ,iadm0 ,jdim0 ,sq_diag_m,lt_m0 ,
3505 2 x ,z ,f_ddl ,l_ddl ,itask )
3506 DO i=f_ddl,l_ddl
3507 x(i) = z(i)
3508 ENDDO
3509 IF (itask == 0) THEN
3510 ncg_run = ncg_run + 1
3511 IF (iprec>1) DEALLOCATE(sq_diag_m)
3512 END IF
3513C----------------------
3514 CALL my_barrier
3515C---------------------
3516 END IF
3517C------due to ISTOP local variable
3518C IF(IT>=NLIM.AND.ISOLV==7) ISTOP = 3
3519c IF(ITOL==3)then
3520c DO I=F_DDL,L_DDL
3521c Z(I)=X(I)/DIAG_M(I)
3522c ENDDO
3523C----------------------
3524c CALL MY_BARRIER
3525C---------------------
3526c CALL PRODUT_H( F_DDL ,L_DDL ,X ,Z ,W_DDL , XNORM2 ,ITASK )
3527c END IF
3528 IF(itask == 0) THEN
3529 istop_h = istop
3530 CALL pupd(n_max,nddli_g,it)
3531C
3532 IF(it>=nlim)THEN
3533 IF (isolv==7) THEN
3534 istop_h = 3
3535 ELSE
3536
3537 WRITE(iout,*)
3538 WRITE(iout,1003)nlim
3539 WRITE(iout,*)
3540 WRITE(istdo,*)
3541 WRITE(istdo,1003)nlim
3542 WRITE(istdo,*)
3543 IF(itol==3)THEN
3544 WRITE(iout,2000) EXIT, sqrt(anorm2), sqrt(xnorm2),gmax/gmin
3545 WRITE(istdo,2000) EXIT, sqrt(anorm2), sqrt(xnorm2),gmax/gmin
3546 ENDIF
3547 istop_h = 1
3548 IF (r2>hundred*toln) THEN
3549 istop_h = 2
3550 rr = sqrt(r2/r02)
3551 WRITE(iout,*)
3552 WRITE(iout,1004)rr
3553 WRITE(iout,*)
3554 WRITE(istdo,*)
3555 WRITE(istdo,1004)rr
3556 WRITE(istdo,*)
3557 ENDIF
3558
3559 END IF !(ISOLV==7) THEN
3560 ENDIF
3561 IF(ipri/=0)THEN
3562 rr = sqrt(r2/r02)
3563 WRITE(iout,*)
3564 WRITE(iout,1002)it,rr
3565 IF(itol==3)WRITE(iout,2000) EXIT, sqrt(anorm2), sqrt(xnorm2),gmax/gmin
3566C WRITE(IOUT,*) 'TOLN,TOLS2=',TOLN,TOLS2
3567 WRITE(iout,*)
3568 IF(ipri<0) THEN
3569 WRITE(istdo,*)
3570 WRITE(istdo,1002)it,rr
3571 IF(itol==3)WRITE(istdo,2000)EXIT, sqrt(anorm2), sqrt(xnorm2),gmax/gmin
3572 WRITE(istdo,*)
3573 ENDIF
3574 ENDIF
3575 IF(itol==3) THEN
3576 k_lamda0= gmin
3577 k_lamda1= gmax
3578 ELSE
3579 k_lamda0= zero
3580 k_lamda1= zero
3581 ENDIF
3582 END IF !(ITASK == 0) THEN
3583C----------------------
3584 CALL my_barrier
3585C----------------------
3586 istop = istop_h
3587C--------------------------------------------
3588 1000 FORMAT(5x,'ITERATION=',i8,5x,' INITIAL RESIDUAL NORM=',e11.4)
3589 1001 FORMAT(5x,'ITERATION=',i8,5x,' RELATIVE RESIDUAL NORM=',e11.4)
3590 1002 FORMAT(3x,'TOTAL C.G. ITERATION=',i8,5x,
3591 . ' RELATIVE RESIDUAL NORM=',e11.4)
3592 1003 FORMAT(5x,
3593 . '---WARNING : THE ITERATION LIMIT NUMBER WAS REACHED',i8)
3594 1004 FORMAT(5x,'WARNING:C.G STOP WITH RELATIVE RESIDUAL NORM=',e11.4)
3595 2000 FORMAT(/ 5x, a, 2x, 'ANORM =', e12.4, 2x, 'XNORM =', e12.4,2x,
3596 . 'KCOND =', e12.4)
3597 2002 FORMAT(/ 5x, 'WITH', 2x, 'ALFA =', e12.4, 2x, 'BETA =',
3598 . e12.4,2x,'OLDB =', e12.4)
3599 RETURN
3600#endif
pupd
subroutine pupd(nddl, nddli, itn)
Definition imp_pcg.F:2411
imp_pro_p
subroutine imp_pro_p(f_ddl, l_ddl, nddl, p, w_ddl, itask)
Definition imp_pcg.F:2588
imp_inix
subroutine imp_inix(f_ddl, l_ddl, nddl, x, r, w_ddl, itask)
Definition imp_pcg.F:2515
imp_updst
subroutine imp_updst(nddl, nddli, iadk, jdik, diag_k, lt_k, itok, iadi, jdii, lt_i, itask, w_ddl, a, ar, ve, 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, ms, xe, irbe3, lrbe3, irbe2, lrbe2, u, p, y, iadm, jdim, diag_m, lt_m, f_ddl, l_ddl)
Definition imp_pcg.F:3784
imp_updv2
subroutine imp_updv2(nddl, nddli, iadk, jdik, diag_k, lt_k, itok, iadi, jdii, lt_i, itask, w_ddl, a, ar, ve, 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, ms, xe, irbe3, lrbe3, irbe2, lrbe2, u_tmp, p, y, f_ddl, l_ddl, it, icheck, z, iadm, jdim, diag_m, lt_m)
Definition imp_pcg.F:2718
imp_updv1
subroutine imp_updv1(r2, r2_old, rmax, proj_u, p, it, f_ddl, l_ddl)
Definition imp_pcg.F:2840
imp_inisi
subroutine imp_inisi(nddl, iadk, jdik, diag_k, lt_k, nddli, itok, iadi, jdii, lt_i, nnzm, iadm, jdim, diag_m, lt_m, r, p, y, 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, z, iddl, ikc, inloc, ind_imp, xi_c, irbe3, lrbe3, irbe2, lrbe2, itask, w_ddl, f_ddl, l_ddl, sq_diag_m)
Definition imp_pcg.F:3916
imp_inist
subroutine imp_inist(nddl, nddli, iadk, jdik, diag_k, lt_k, itok, iadi, jdii, lt_i, itask, w_ddl, a, ar, ve, 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, ms, xe, irbe3, lrbe3, irbe2, lrbe2, iadm, jdim, diag_m, lt_m, f_ddl, l_ddl, v_w)
Definition imp_pcg.F:3629
imp_workh::istop_h
integer istop_h
Definition impbufdef_mod.F:573
mmv_lth
subroutine mmv_lth(nddl, iadm, jdim, diag_m, lt_m, v, z, f_ddl, l_ddl, itask)
Definition produt_v.F:3048
mmv_lh
subroutine mmv_lh(nddl, iadm, jdim, diag_m, lt_m, v, z, f_ddl, l_ddl, itask)
Definition produt_v.F:3113

◆ imp_pro_p()

subroutine imp_pro_p ( integer f_ddl,
integer l_ddl,
integer nddl,
p,
integer, dimension(*) w_ddl,
integer itask )

Definition at line 2587 of file imp_pcg.F.

2588C-----------------------------------------------
2589C M o d u l e s
2590C-----------------------------------------------
2591 USE imp_pcg_proj
2592C-----------------------------------------------
2593C I m p l i c i t T y p e s
2594C-----------------------------------------------
2595#include "implicit_f.inc"
2596C-----------------------------------------------
2597C C o m m o n B l o c k s
2598C-----------------------------------------------
2599#include "impl1_c.inc"
2600C-----------------------------------------------
2601C D u m m y A r g u m e n t s
2602C-----------------------------------------------
2603 INTEGER F_DDL ,L_DDL ,NDDL,ITASK,W_DDL(*)
2604 my_real
2605 . p(*)
2606C-----------------------------------------------
2607c FUNCTION: Projection of {p}={p}-[S][LAMDA]^-1[T]^t{p}
2608c
2609c Note:
2610c ARGUMENTS: (I: input, O: output, IO: input * output, W: workspace)
2611c
2612c TYPE NAME FUNCTION
2613c I NDDL - equation dimension
2614c I NPV - projection vector number
2615c I W_DDL(*) - itag for each id of subdomains
2616c I F_ND,L_ND,ITASK - id in each ITASK:thread id (//)
2617c IO P(NDDL) - PCG p vector
2618C-----------------------------------------------
2619C L o c a l V a r i a b l e s
2620C-----------------------------------------------
2621 INTEGER I,J,NPV
2622 my_real
2623 . p1(nddl)
2624C----------------------
2625 IF (npcgpv == 0) RETURN
2626 npv = npcgpv
2627C----------------------
2628C {W}=[T]^t{p}
2629C---------------------
2630 CALL mav_nm(f_ddl,l_ddl,nddl ,npv ,proj_t ,
2631 . p ,proj_w ,w_ddl,itask )
2632C----------------------
2633 CALL my_barrier
2634C---------------------
2635C [LAMDA]^-1{W}
2636C---------------------
2637 IF (itask==0) THEN
2638 DO i=1,npv
2639 proj_w(i)=proj_w(i)*proj_la_1(i)
2640 ENDDO
2641C----------------------
2642C {P1}=[S]{W}
2643C---------------------
2644 CALL mav_mn(nddl ,npv ,proj_s ,proj_w ,p1 ,itask )
2645 DO i=1,nddl
2646 p(i)=p(i)-p1(i)
2647 ENDDO
2648 END IF
2649C
2650 RETURN

◆ imp_rsave()

subroutine imp_rsave ( integer nddl,
x,
r )

Definition at line 168 of file imp_pcg.F.

170C-----------------------------------------------
171C I m p l i c i t T y p e s
172C-----------------------------------------------
173#include "implicit_f.inc"
174C-----------------------------------------------
175C D u m m y A r g u m e n t s
176C-----------------------------------------------
177 my_real
178 . x(*), r(*)
179 INTEGER NDDL
180C-----------------------------------------------
181C L o c a l V a r i a b l e s
182C-----------------------------------------------
183
184 WRITE(66)x(1:nddl)
185 WRITE(66)r(1:nddl)
186 CLOSE(66)
187 RETURN

◆ imp_updst()

subroutine imp_updst ( integer nddl,
integer nddli,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_k,
lt_k,
integer, dimension(*) itok,
integer, dimension(*) iadi,
integer, dimension(*) jdii,
lt_i,
integer itask,
integer, dimension(*) w_ddl,
a,
ar,
ve,
d,
dr,
integer, dimension(*) ndof,
integer, dimension(*) ipari,
type(intbuf_struct_), dimension(*) intbuf_tab,
integer, dimension(*) num_imp,
integer, dimension(*) ns_imp,
integer, dimension(*) ne_imp,
integer nsrem,
integer nsl,
integer nmonv,
integer, dimension(*) imonv,
integer, dimension(*) monvol,
type (surf_), dimension(nsurf) igrsurf,
volmon,
integer, dimension(*) fr_mv,
integer, dimension(*) ibfv,
skew,
xframe,
integer, dimension(*) ind_imp,
xi_c,
ms,
xe,
integer, dimension(*) irbe3,
integer, dimension(*) lrbe3,
integer, dimension(*) irbe2,
integer, dimension(*) lrbe2,
u,
p,
y,
integer, dimension(*) iadm,
integer, dimension(*) jdim,
diag_m,
lt_m,
integer f_ddl,
integer l_ddl )

Definition at line 3772 of file imp_pcg.F.

3784C-----------------------------------------------
3785C M o d u l e s
3786C-----------------------------------------------
3787 USE imp_pcg_proj
3788 USE intbufdef_mod
3789 USE groupdef_mod
3790C-----------------------------------------------
3791C I m p l i c i t T y p e s
3792C-----------------------------------------------
3793#include "implicit_f.inc"
3794C-----------------------------------------------
3795C C o m m o n B l o c k s
3796C-----------------------------------------------
3797#include "com04_c.inc"
3798#include "impl1_c.inc"
3799C-----------------------------------------------
3800C D u m m y A r g u m e n t s
3801C-----------------------------------------------
3802 INTEGER F_DDL,L_DDL,NDDL ,IADK(*) ,JDIK(*),
3803 . NDDLI ,ITOK(*) ,IADI(*),JDII(*),
3804 . ITASK,W_DDL(*),IBFV(*),IRBE3(*) ,LRBE3(*),
3805 . IRBE2(*) ,LRBE2(*),IADM(*) ,JDIM(*)
3806 INTEGER NDOF(*),NE_IMP(*),NSREM ,NSL,
3807 . IPARI(*) ,NUM_IMP(*),NS_IMP(*) ,IND_IMP(*)
3808 INTEGER NMONV,IMONV(*),MONVOL(*),FR_MV(*)
3809 my_real
3810 . diag_k(*), lt_k(*),lt_i(*) ,xi_c(*),u(*),p(*),y(*)
3811 my_real
3812 . a(3,*),ar(3,*),ve(3,*),d(3,*),dr(3,*),xe(3,*),
3813 . ms(*),volmon(*),skew(*) ,xframe(*),
3814 . diag_m(*), lt_m(*)
3815
3816 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
3817 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
3818C-----------------------------------------------
3819c FUNCTION: update S,T of Projection taking into account to preconditioner [M]
3820c
3821c Note:
3822c ARGUMENTS: (I: input, O: output, IO: input * output, W: workspace)
3823c
3824c TYPE NAME FUNCTION
3825c I NDDL,NNZ - dimension of [K] and number of non zero (strict triangular)
3826c I IADK,JDIK - indice arrays for compressed row(col.) format of [K]
3827c I DIAG_K(NDDL) - diagonal terms of [K]
3828c I LT_K(NNZ) - strict triangular of [K]
3829c O Proj_S(NDDL,M_VS) - [S] reduced small Eigenvectors
3830c O Proj_T(NDDL,M_VS) - [T] =[K][S]
3831c I W1,W2 - work arrays
3832C-----------------------------------------------
3833C L o c a l V a r i a b l e s
3834C-----------------------------------------------
3835 CHARACTER JOBZ, UPLO
3836 INTEGER I,J,IT,IP,NLIM,ND,IUPD,IPRI,IERROR,NNZI,M,
3837 . INFO,LW,M_VS1,INORM,NP
3838 my_real
3839 . work(3*m_vs+3),w(m_vs+1)
3840C------M_VS input one -NPCGPV: activated ---------------
3841 IF (npcgpv == 0) RETURN
3842C----------------------
3843 CALL my_barrier
3844C---------------------
3845 m_vs1 = npcgpv+ 1
3846C------add previous solution U ; default : IPRO_S0=2
3847C---IPRO_S0=1 : alertory updated w/ 1 vector x
3848C---IPRO_S0=2 : ini S w/ first p vectors updated w/ 2 vectors p,x
3849C---IPRO_S0=3 : ini S w/ first p vectors updated w/ 2 vectors p,x (p<-RR_max)
3850C---IPRO_S0=4 : ini S w/ first p vectors updated w/ 2 vectors v,x (v update each ite)
3851c IF (IPRO_S0 > 2.AND.IPRO_S0 < 4.AND.NCG_RUN==0) THEN
3852c CALL IMP_INIS(NDDL ,F_DDL ,L_DDL , 1,NPCGPV-1 ,PROJ_S )
3853C----------------------
3854c CALL MY_BARRIER
3855C---------------------
3856c CALL MORTHO_GS(F_DDL ,L_DDL ,NDDL ,1 ,NPCGPV-1 ,
3857c . PROJ_S ,W_DDL ,ITASK )
3858C----------------------
3859c CALL MY_BARRIER
3860C---------------------
3861c END IF !(IPRO_S0 > 1.AND.NCG_RUN==0) THEN
3862C
3863 IF (ipro_s0==2) THEN
3864 DO i=f_ddl,l_ddl
3865 proj_s(i,npcgpv)=u(i)
3866 proj_s(i,m_vs1)=p(i)
3867 ENDDO
3868 ELSEIF (ipro_s0==3.OR.ipro_s0==4) THEN
3869 DO i=f_ddl,l_ddl
3870 proj_s(i,npcgpv)=u(i)
3871 proj_s(i,m_vs1)=proj_v(i)
3872 ENDDO
3873 ELSE
3874 DO i=f_ddl,l_ddl
3875 proj_s(i,m_vs1)=u(i)
3876 ENDDO
3877 END IF !(MOD(IPRO_S0,2)==0) THEN
3878C----------------------
3879 CALL my_barrier
3880C---------------------
3881 CALL mortho_gs(f_ddl ,l_ddl ,nddl ,npcgpv ,m_vs1 ,
3882 . proj_s ,w_ddl ,itask )
3883C-------will do (T=[K]S ...) in IMP_INIST
3884C
3885 RETURN

◆ imp_updv1()

subroutine imp_updv1 ( r2,
r2_old,
rmax,
proj_u,
p,
integer it,
integer f_ddl,
integer l_ddl )

Definition at line 2837 of file imp_pcg.F.

2840C-----------------------------------------------
2841C I m p l i c i t T y p e s
2842C-----------------------------------------------
2843#include "implicit_f.inc"
2844C-----------------------------------------------
2845C C o m m o n B l o c k s
2846C-----------------------------------------------
2847#include "impl1_c.inc"
2848C-----------------------------------------------
2849C D u m m y A r g u m e n t s
2850C-----------------------------------------------
2851 INTEGER IT,F_DDL,L_DDL
2852 my_real
2853 . r2, r2_old ,rmax ,proj_u(*),p(*)
2854C-----------------------------------------------
2855C L o c a l V a r i a b l e s
2856C-----------------------------------------------
2857 INTEGER I
2858 my_real
2859 . rr
2860C-----------------------------------
2861 IF (ipro_s0==4) RETURN
2862C
2863 IF (it==1) THEN
2864 r2_old=r2
2865 ELSE
2866 rr=r2/r2_old
2867 r2_old=r2
2868 IF (rmax<rr) THEN
2869 DO i=f_ddl,l_ddl
2870 proj_u(i) = p(i)
2871 ENDDO
2872 rmax=rr
2873 ENDIF
2874 END IF
2875C
2876 RETURN

◆ imp_updv2()

subroutine imp_updv2 ( integer nddl,
integer nddli,
integer, dimension(*) iadk,
integer, dimension(*) jdik,
diag_k,
lt_k,
integer, dimension(*) itok,
integer, dimension(*) iadi,
integer, dimension(*) jdii,
lt_i,
integer itask,
integer, dimension(*) w_ddl,
a,
ar,
ve,
d,
dr,
integer, dimension(*) ndof,
integer, dimension(*) ipari,
type(intbuf_struct_), dimension(*) intbuf_tab,
integer, dimension(*) num_imp,
integer, dimension(*) ns_imp,
integer, dimension(*) ne_imp,
integer nsrem,
integer nsl,
integer nmonv,
integer, dimension(*) imonv,
integer, dimension(*) monvol,
type (surf_), dimension(nsurf) igrsurf,
volmon,
integer, dimension(*) fr_mv,
integer, dimension(*) ibfv,
skew,
xframe,
integer, dimension(*) ind_imp,
xi_c,
ms,
xe,
integer, dimension(*) irbe3,
integer, dimension(*) lrbe3,
integer, dimension(*) irbe2,
integer, dimension(*) lrbe2,
u_tmp,
p,
y,
integer f_ddl,
integer l_ddl,
integer it,
integer icheck,
z,
integer, dimension(*) iadm,
integer, dimension(*) jdim,
diag_m,
lt_m )

Definition at line 2706 of file imp_pcg.F.

2718C-----------------------------------------------
2719C M o d u l e s
2720C-----------------------------------------------
2721 USE imp_pcg_proj
2722 USE intbufdef_mod
2723 USE groupdef_mod
2724C-----------------------------------------------
2725C I m p l i c i t T y p e s
2726C-----------------------------------------------
2727#include "implicit_f.inc"
2728C-----------------------------------------------
2729C C o m m o n B l o c k s
2730C-----------------------------------------------
2731#include "com04_c.inc"
2732#include "impl1_c.inc"
2733#include "units_c.inc"
2734C-----------------------------------------------
2735C D u m m y A r g u m e n t s
2736C-----------------------------------------------
2737 INTEGER F_DDL,L_DDL,NDDL ,IADK(*) ,JDIK(*),
2738 . NDDLI ,ITOK(*) ,IADI(*),JDII(*),
2739 . ITASK,W_DDL(*),IBFV(*),IRBE3(*) ,LRBE3(*),
2740 . IRBE2(*) ,LRBE2(*),IT,ICHECK,IADM(*),JDIM(*)
2741 INTEGER NDOF(*),NE_IMP(*),NSREM ,NSL,
2742 . IPARI(*) ,NUM_IMP(*),NS_IMP(*) ,IND_IMP(*)
2743 INTEGER NMONV,IMONV(*),MONVOL(*),FR_MV(*)
2744 my_real
2745 . diag_k(*), lt_k(*),lt_i(*) ,xi_c(*),u_tmp(*),p(*),y(*)
2746 my_real
2747 . a(3,*),ar(3,*),ve(3,*),d(3,*),dr(3,*),xe(3,*),
2748 . ms(*),volmon(*),skew(*) ,xframe(*),
2749 . z(*),diag_m(*),lt_m(*)
2750
2751 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
2752 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
2753C-----------------------------------------------
2754c FUNCTION: update S,T of Projection
2755c
2756c Note:
2757c ARGUMENTS: (I: input, O: output, IO: input * output, W: workspace)
2758c
2759c TYPE NAME FUNCTION
2760c I NDDL,NNZ - dimension of [K] and number of non zero (strict triangular)
2761c I IADK,JDIK - indice arrays for compressed row(col.) format of [K]
2762c I DIAG_K(NDDL) - diagonal terms of [K]
2763c I LT_K(NNZ) - strict triangular of [K]
2764c O Proj_S(NDDL,M_VS) - [S] reduced small Eigenvectors
2765c O Proj_T(NDDL,M_VS) - [T] =[K][S]
2766C-----------------------------------------------
2767C L o c a l V a r i a b l e s
2768C-----------------------------------------------
2769#if defined(MYREAL8) && !defined(WITHOUT_LINALG)
2770 CHARACTER JOBZ, UPLO
2771 INTEGER I,J,IP,NLIM,ND,IUPD,IPRI,IERROR,NNZI,M,
2772 . F_DDLI,L_DDLI,INFO,LW,M_VS1,INORM,NP
2773 my_real
2774 . work(3*m_vs+3),w(m_vs+1),p2,py,s,vp,vy,p_k2(2,2),
2775 . work_t(nddl)
2776C--- COMPUTE another lowest eigenvecor V(U_TMP)
2777 IF (ipro_s0/=4) RETURN
2778C
2779 CALL produt_h( f_ddl ,l_ddl ,p ,p ,w_ddl , p2 ,itask )
2780 CALL produt_h( f_ddl ,l_ddl ,p ,y ,w_ddl , py ,itask )
2781 IF (it==0 ) THEN
2782 m_tmp(1,1)=one
2783 s = one/sqrt(p2)
2784 k_tmp(1,1)=py/p2
2785 DO i=f_ddl,l_ddl
2786 u_tmp(i)=s*p(i)
2787 ENDDO
2788 ELSE
2789 CALL produt_h( f_ddl ,l_ddl ,p ,u_tmp,w_ddl , vp ,itask )
2790 CALL produt_h( f_ddl ,l_ddl ,y ,u_tmp,w_ddl , vy ,itask )
2791 m_tmp(1,2)=vp
2792 m_tmp(2,2)=p2
2793 k_tmp(1,2)=vy
2794 k_tmp(2,2)=py
2795 nd =2
2796 jobz='V'
2797 uplo='U'
2798 lw=3*nd
2799 CALL dsygv( 1, jobz, uplo, nd, k_tmp, nd, m_tmp, nd, w, work,
2800 $ lw, info )
2801 DO i=f_ddl,l_ddl
2802 u_tmp(i)=k_tmp(1,1)*u_tmp(i)+k_tmp(2,1)*p(i)
2803 ENDDO
2804 m_tmp(1,1)=one
2805 k_tmp(1,1)=w(1)
2806 ENDIF
2807C-------checking V(U_TMP)
2808 if (icheck==1.OR.impdeb>0) then
2809 CALL produt_h( f_ddl ,l_ddl ,u_tmp,u_tmp,w_ddl , s ,itask )
2810 CALL mmav_lth(
2811 1 nddl ,nddli ,iadk ,jdik ,diag_k,
2812 2 lt_k ,iadi ,jdii ,itok ,lt_i ,
2813 3 u_tmp ,work_t,a ,ar ,
2814 5 ve ,ms ,xe ,d ,dr ,
2815 6 ndof ,ipari ,intbuf_tab ,num_imp,
2816 7 ns_imp,ne_imp,nsrem ,nsl ,ibfv ,
2817 8 skew ,xframe,monvol,volmon,igrsurf ,
2818 9 fr_mv,nmonv ,imonv ,ind_imp,
2819 a xi_c ,iupd ,irbe3 ,lrbe3 ,irbe2 ,
2820 b lrbe2 ,iadm ,jdim ,diag_m,lt_m ,
2821 c f_ddl ,l_ddl ,itask ,z )
2822 CALL produt_h( f_ddl ,l_ddl ,u_tmp,work_t,w_ddl ,p2,itask)
2823 write(iout,*)'inf,|v|,vAv,lamda1=',info,s,p2,k_tmp(1,1)
2824 endif
2825
2826#else
2827 CALL arret(5)
2828#endif
2829C
2830 RETURN
dsygv
subroutine dsygv(itype, jobz, uplo, n, a, lda, b, ldb, w, work, lwork, info)
DSYGV
Definition dsygv.f:175

◆ mixedsol()

logical function mixedsol

Definition at line 2483 of file imp_pcg.F.

2484C-----------------------------------------------
2485C I m p l i c i t T y p e s
2486C-----------------------------------------------
2487#include "implicit_f.inc"
2488C-----------------------------------------------
2489C C o m m o n B l o c k s
2490C-----------------------------------------------
2491#include "impl1_c.inc"
2492C-----------------------------------------------
2493C L o c a l V a r i a b l e s
2494C-----------------------------------------------
2495 INTEGER I,J
2496C-----------------------------------------------
2497 mixedsol=.false.
2498 IF ((isolv==5.OR.isolv==6).AND.it_pcg<0) mixedsol=.true.
2499
2500 RETURN

◆ nlim_mix()

subroutine nlim_mix ( integer nddl,
integer nddli,
integer nlim )

Definition at line 2450 of file imp_pcg.F.

2451C-----------------------------------------------
2452C I m p l i c i t T y p e s
2453C-----------------------------------------------
2454#include "implicit_f.inc"
2455C-----------------------------------------------
2456C C o m m o n B l o c k s
2457C-----------------------------------------------
2458#include "impl1_c.inc"
2459C-----------------------------------------------
2460C D u m m y A r g u m e n t s
2461C-----------------------------------------------
2462 INTEGER NDDL,NDDLI,NLIM
2463C-----------------------------------------------
2464C L o c a l V a r i a b l e s
2465C-----------------------------------------------
2466 INTEGER I
2467C-----------------------------
2468 IF (isolv/=5.AND.isolv/=6) RETURN
2469 IF (ipupd>0) THEN
2470 nlim=10*ipupd+nddli
2471 ELSE
2472 nlim=10+nddl/100+nddli
2473 ENDIF
2474 nlim=min(nlim,nddl)
2475C--------------------------------------------
2476 RETURN

◆ pupd()

subroutine pupd ( integer nddl,
integer nddli,
integer itn )

Definition at line 2410 of file imp_pcg.F.

2411C-----------------------------------------------
2412C I m p l i c i t T y p e s
2413C-----------------------------------------------
2414#include "implicit_f.inc"
2415C-----------------------------------------------
2416C C o m m o n B l o c k s
2417C-----------------------------------------------
2418#include "impl1_c.inc"
2419C-----------------------------------------------
2420C D u m m y A r g u m e n t s
2421C-----------------------------------------------
2422 INTEGER NDDL,NDDLI,ITN
2423C-----------------------------------------------
2424C L o c a l V a r i a b l e s
2425C-----------------------------------------------
2426 INTEGER I,NLIM
2427C-----------------------------
2428C
2429 it_pcg = it_pcg + itn
2430 IF (isolv==5.OR.isolv==6) THEN
2431 IF (ipupd>0) THEN
2432 nlim=ipupd+nddli/10
2433 ELSE
2434 nlim=max(5,nddl/10000)+nddli/10
2435 ENDIF
2436 IF (itn>nlim) THEN
2437c WRITE(IOUT,*) '****RE-FRACTO. DUE TO ITN=',ITN
2438 it_pcg = -it_pcg
2439 ENDIF
2440 END IF
2441C--------------------------------------------
2442 RETURN