imp_solv.F File Reference

#include "implicit_f.inc"
#include "comlock.inc"
#include "param_c.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "com08_c.inc"
#include "impl1_c.inc"
#include "impl2_c.inc"
#include "scr03_c.inc"
#include "scr06_c.inc"
#include "scr16_c.inc"
#include "timeri_c.inc"
#include "units_c.inc"
#include "task_c.inc"
#include "scr11_c.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	imp_solv (output, timers, python, icode, iskew, iskwn, ipart, ixtg, ixs, ixq, ixc, ixt, ixp, ixr, ixtg1, itab, itabm1, npc, ibcl, ibfv, sensor_tab, nnlink, lnlink, iparg, igrv, ipari, intbuf_tab, nprw, iconx, npby, lpby, lrivet, nstrf, ljoint, icodt, icodr, isky, adsky, iads_f, ilink, llink, weight, itask, ibvel, lbvel, fbvel, x, d, v, vr, dr, thke, damp, ms, in, pm, skews, geo, eani, bufmat, bufgeo, bufsf, tf, forc, vel, fsav, agrv, fr_wave, parts0, elbuf, rby, rivet, fr_elem, iad_elem, wa, a, ar, stifn, stifr, partsav, fsky, fskyi, iframe, xframe, w16, iactiv, fskym, igeo, ipm, wfext, nodft, nodlt, nint7, num_imp, ns_imp, ne_imp, ind_imp, it, rwbuf, lprw, fr_wall, nbintc, intlist, fopt, rwsav, fsavd, graphe, fac_k, ipiv_k, nkcond, nsensor, monvol, igrsurf, fr_mv, volmon, dirul, nodglob, mumps_par, cddlp, isendto, irecvfrom, newfront, imsch, i2msch, isizxv, ilenxv, islen7, irlen7, islen11, irlen11, islen17, irlen17, irlen7t, islen7t, kinet, num_imp1, temp, dt2prev, waint, lgrav, sh4tree, sh3tree, irlen20, islen20, irlen20t, islen20t, irlen20e, islen20e, irbe3, lrbe3, frbe3, fr_i2m, iad_i2m, fr_rbe3m, iad_rbe3m, frwl6, irbe2, lrbe2, intbuf_tab_c, ikine, diag_sms, icfield, lcfield, cfield, count_remslv, count_remslve, elbuf_tab, elbuf_imp, xdp, weight_md, stack, dimfb, fbsav6, stabsen, tabsensor, drape_sh4n, drape_sh3n, h3d_data, multi_fvm, igrbric, igrsh4n, igrsh3n, igrbeam, forneqs, maxdgap, nddl0, nnzk0, it_t, impbuf_tab, cptreac, fthreac, nodreac, drapeg, interfaces, th_surf, dpl0cld, vel0cld, snpc, stf, glob_therm, wfext_md)
subroutine	imp_stop (istop)
subroutine	imp_check (itab, nddl, iddl, diag_k, ndof, ikc, inloc, nddl0)
subroutine	pr_infok (nddl0, nnzk0, nddl, nnzk, nnmax)
subroutine	k_band (nddl, iadk, jdik, ndmax)
subroutine	m_lnz (nddl, iadk, jdik, ndmax, nlmax)
subroutine	dim_subnz (iadk, jdik, nc, jm, nnza)
subroutine	imp_checm (itab, nddl, iddl, diag_m, ndof, ikc, inloc, nddl0)
subroutine	imp_b2a (f, m, iddl, ndof, b)
subroutine	ini_kif
subroutine	save_kif (nddl, iadk, jdik, diag_k, lt_k, itok, nddlg)
subroutine	diag_kif (diag_k)
subroutine	matv_kif (v, w)
subroutine	imp_cpre (iflag, nndl, elbuf, elbuf_c, bufmat, fsav, volmon, bufmat_c, x, x_c, partsav, r_imp)
subroutine	imp_check0 (itab, nddl, iddl, diag_k, diag_m, ndof, ikc, inloc, nddl0, nir, nddli, itok, diag_i, iwar, ierr)
subroutine	imp_checm0 (itab, nddl, iddl, diag_m, ndof, ikc, inloc, nddl0, iwar, ierr)
subroutine	imp_chkm (timers, python, icode, iskew, iskwn, ipart, ixtg, ixs, ixq, ixc, ixt, ixp, ixr, ixtg1, itab, itabm1, npc, ibcl, ibfv, sensor_tab, nnlink, lnlink, iparg, igrv, ipari, intbuf_tab, nprw, iconx, npby, lpby, lrivet, nstrf, ljoint, icodt, icodr, isky, adsky, iads_f, ilink, llink, weight, itask, ibvel, lbvel, fbvel, x, d, v, vr, dr, thke, damp, ms, in, pm, skews, geo, eani, bufmat, bufgeo, bufsf, tf, forc, vel, fsav, agrv, fr_wave, parts0, elbuf, rby, rivet, fr_elem, iad_elem, nsensor, wa, a, ar, stifn, stifr, partsav, fsky, fskyi, iframe, xframe, w16, iactiv, fskym, igeo, ipm, wfext, nodft, nodlt, nint7, num_imp, ns_imp, ne_imp, ind_imp, it, rwbuf, lprw, fr_wall, nbintc, intlist, fopt, rwsav, fsavd, dirul, lgrav, irbe3, lrbe3, frbe3, frwl6, irbe2, lrbe2, icfield, lcfield, cfield, elbuf_tab, weight_md, stack, dimfb, fbsav6, stabsen, tabsensor, drape_sh4n, drape_sh3n, h3d_data, nddl0, nnzk0, impbuf_tab, cptreac, fthreac, nodreac, drapeg, th_surf, dpl0cld, vel0cld, snpc, stf, wfext_md, igrsurf)
subroutine	imp_compab (icodt, icodr, iskew, ibfv, npc, tf, vel, nsensor, sensor_tab, xframe, rby, x, skew, lpby, npby, itab, nrbyac, irbyac, nint2, iint2, ipari, intbuf_tab, nt_rw, nddl, ndof, ikc, inloc, iddl, nddl0, iwar, ierr)
subroutine	imp_compabp (icodt, icodr, iskew, ibfv, npc, tf, vel, nsensor, sensor_tab, xframe, rby, x, skew, lpby, npby, itab, nrbyac, irbyac, nint2, iint2, ipari, intbuf_tab, nt_rw, nddl, ndof, ikc, inloc, iddl, nddl0, iwar, ierr)
subroutine	imp_fout (output, a, ar, nfia, nfea, nodft, nodlt, h3d_data, impbuf_tab)
subroutine	imp_fanii (output, fint, nfia, nodft, nodlt, h3d_data)
subroutine	imp_fanie (output, fext, nfia, nfea, nodft, nodlt, h3d_data)
subroutine	ini_kic
subroutine	deallocm
subroutine	deallocm_imp (mumps_par)
subroutine	crit_llim (nddl, nnzk)
subroutine	ini_k0h (nddl, nnz, nnzm, iadk, jdik)
subroutine	set_ksym (nddl, iadk, jdik, lt_k, iadk0, jdik0, lt_k0)
subroutine	get_fext (nddl0, nddl, iddl, ndof, ikc, inloc, lb, fext, ac, acr)
subroutine	re2int5 (nt_imp, numimp, ns_imp, ne_imp, numimpl, ipari, nt_imp0)
subroutine	re2int7 (nt_imp, numimp, ns_imp, ne_imp, ind_imp, numimpl, ipari, nt_imp0)
subroutine	du_ini (nodft, nodlt, dn, dnr, dd, ddr, idiv, icont0)
subroutine	pr_deb (nddl, iddl, ndof, ikc, itab, diag_k, diag_m, inloc, fr_elem, iad_elem, iadk, jdik, lt_k, lt_m, nddli, iadi, jdii, itok, diag_i, lt_i, u, f, it, nsrem, nsl, d, dr, iflag, w_ddl, fext, mext, fint, mint, r01, ndeb, nodglob)
subroutine	pr_matrix (nddl, iddl, ndof, ikc, itab, diag_k, diag_m, inloc, fr_elem, iad_elem, iadk, jdik, lt_k, lt_m, nddli, iadi, jdii, itok, diag_i, lt_i, iflag, it)
subroutine	pr_solnfo (nddl, iddl, ndof, ikc, itab, diag_k, diag_m, inloc, fr_elem, iad_elem, iadk, jdik, lt_k, lt_m, nddli, iadi, jdii, itok, diag_i, lt_i, u, f, it, nsrem, nsl, d, dr, iflag, w_ddl, fext, mext, fint, mint, r01, ndeb, r_imp, i_imp, dd, ddr)
subroutine	write_tpl_file (filnam, ioff1, ioff2, ioff3)
subroutine	int5_diverg (ipari)
subroutine	dis_cp (n, d, dr, iflag)
subroutine	imp_smpini (itsk, n1ftsk, n1ltsk, n1)
subroutine	du_ini_hp (dn, dnr, dd, ddr, idiv, icont0)
subroutine	print_stif (ipari, intbuf_tab, iflag, nn, jg)
subroutine	imp_stif24 (numimp, ipari)
subroutine	upd_rhs_fr (icodt, icodr, iskew, ibfv, xframe, rby, x, skew, lpby, npby, nrbyac, irbyac, nint2, iint2, ipari, intbuf_tab, ndof, iddl, ikc, nddl0, b, iupd, inloc, lj, ac, acr, nt_rw, w_ddl, nddl, r02, irbe3, lrbe3, frbe3, weight, irbe2, lrbe2)
subroutine	imp_intfr (num_imp, ns_imp, ne_imp, ipari, intbuf_tab, npby, lpby, itab, nrbyac, irbyac, nint2, iint2, iddl, ikc, ndof, inloc, nsrem, nsl, nbintc, intlist, x, ibfv, dirul, skew, xframe, iskew, icodt, de, d_imp, lb, ifdis, nddl, dr_imp, iddli, irbe3, lrbe3, frbe3, irbe2, lrbe2, dd, ddr, a, ar, ac, acr, ms, v, nddl0, r02, rby, icodr, nt_rw, w_ddl, weight, irflag)
subroutine	ini_bminma_imp (intbuf_tab)
subroutine	spbrm_pre (itab, x, iparg, ixc, ixtg, partsav, elbuf_tab, pm, ndof, iddl, ikc)
subroutine	spb_refsh4id (jft, jlt, nel, ixc, x, xc, yc, zc, ie, xmin0, ymin0, zmin0, dmin)
subroutine	spb_refsh3id (jft, jlt, nel, ixtg, x, xc, yc, zc, ie, xmin0, ymin0, zmin0, dmin)
subroutine	spb_rm_rig (x, ixc, ixtg, ndof, iddl, ikc, d_imp, dr_imp, icodt, icodr, skew, iskew, itab)
subroutine	spb_ieref_bc (x, ixc, ixtg, d_imp, dmin, ndof, iddl, ikc)
subroutine	spb_rgmod (n_seg, x_ref, d_ref, x, d, x0, y0, z0, dtra, drot)
subroutine	spb_ieref3 (x, ixc, ixtg, ndof, iddl, ikc, d_imp, dr_imp, dmin)
subroutine	imp_intbuf_ini (imp_intbuf_tab, nimp)
subroutine	imp_errmumps (ierr)
subroutine	pvp_k (nd, iadk, jdik, iddl, inloc, ndof, itab, k_diag, k_lt, lamda, node, ms)
subroutine	minv_k (nd, icnds10, iddl, inloc, ndof, ms, tol, ke)
subroutine	getikce (ict, icr, k, ifix)
subroutine	transvg2l (skew, vg, vl)
subroutine	transvl2g (skew, vl, vg)
subroutine	spb_ref_nds (x, d_imp, ndof, iddl, ikc, icodt, icodr, iskew, skew)
subroutine	dealloc_impbuf (impbuf_tab)

Function/Subroutine Documentation

crit_llim()

subroutine crit_llim	(	integer	nddl,
		integer	nnzk )

Definition at line 5031 of file imp_solv.F.

C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "task_c.inc"
#include      "impl1_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
        INTEGER NDDL,NNZK
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER I,J,JD,NP
        my_real
     .    pfac,critl,s1,s2
C------compute auto seclect solver by L_LIM--------------
C--------take into account to parallel capacities of PCG---
        IF (nspmd == 1) THEN
          nddl_g = nddl
          nnzk_g = nnzk
        END IF
        np=nspmd/2
        pfac= two_third*nthread*max(1,np)
        pfac=max(one,pfac)
        s1=nddl_g*five*em03
        s2=nnzk_g*twop8*em04
        critl=half*(s1+s2)
        l_lim=critl*pfac
C------------------------------------------
        RETURN

dealloc_impbuf()

subroutine dealloc_impbuf

(

type (impbuf_struct_)

impbuf_tab

)

Definition at line 9106 of file imp_solv.F.

C-----------------------------------------------
        USE impbufdef_mod
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        TYPE (IMPBUF_STRUCT_) IMPBUF_TAB
C-----------------------------------------------
C   L o c a l  V a r i a b l e s
C-----------------------------------------------
C
        IF (ALLOCATED(impbuf_tab%IDDL)) DEALLOCATE(impbuf_tab%IDDL)
        IF (ALLOCATED(impbuf_tab%NDOF)) DEALLOCATE(impbuf_tab%NDOF)
        IF (ALLOCATED(impbuf_tab%INLOC)) DEALLOCATE(impbuf_tab%INLOC)
        IF (ALLOCATED(impbuf_tab%IRBYAC))DEALLOCATE(impbuf_tab%IRBYAC)
        IF (ALLOCATED(impbuf_tab%NSC))   DEALLOCATE(impbuf_tab%NSC)
        IF (ALLOCATED(impbuf_tab%IINT2)) DEALLOCATE(impbuf_tab%IINT2)
        IF (ALLOCATED(impbuf_tab%NKUD))  DEALLOCATE(impbuf_tab%NKUD)
        IF (ALLOCATED(impbuf_tab%IMONV)) DEALLOCATE(impbuf_tab%IMONV)
        IF (ALLOCATED(impbuf_tab%IADK)) DEALLOCATE(impbuf_tab%IADK)
        IF (ALLOCATED(impbuf_tab%JDIK)) DEALLOCATE(impbuf_tab%JDIK)
        IF (ALLOCATED(impbuf_tab%IKINW)) DEALLOCATE(impbuf_tab%IKINW)
        IF (ALLOCATED(impbuf_tab%IKC)) DEALLOCATE(impbuf_tab%IKC)
        IF (ALLOCATED(impbuf_tab%IKUD)) DEALLOCATE(impbuf_tab%IKUD)
        IF (ALLOCATED(impbuf_tab%W_DDL)) DEALLOCATE(impbuf_tab%W_DDL)
        IF (ALLOCATED(impbuf_tab%IADM)) DEALLOCATE(impbuf_tab%IADM)
        IF (ALLOCATED(impbuf_tab%JDIM)) DEALLOCATE(impbuf_tab%JDIM)
        IF (ALLOCATED(impbuf_tab%CAND_N)) DEALLOCATE(impbuf_tab%CAND_N)
        IF (ALLOCATED(impbuf_tab%CAND_E)) DEALLOCATE(impbuf_tab%CAND_E)
        IF (ALLOCATED(impbuf_tab%INDSUBT)) DEALLOCATE(impbuf_tab%INDSUBT)
        IF (ALLOCATED(impbuf_tab%NDOFI)) DEALLOCATE(impbuf_tab%NDOFI)
        IF (ALLOCATED(impbuf_tab%IDDLI)) DEALLOCATE(impbuf_tab%IDDLI)
        IF (ALLOCATED(impbuf_tab%INBUF_C)) DEALLOCATE(impbuf_tab%INBUF_C)
        IF (ALLOCATED(impbuf_tab%DIAG_K)) DEALLOCATE(impbuf_tab%DIAG_K)
        IF (ALLOCATED(impbuf_tab%LT_K))   DEALLOCATE(impbuf_tab%LT_K)
        IF (ALLOCATED(impbuf_tab%DIAG_M)) DEALLOCATE(impbuf_tab%DIAG_M)
        IF (ALLOCATED(impbuf_tab%LT_M))   DEALLOCATE(impbuf_tab%LT_M)
        IF (ALLOCATED(impbuf_tab%LB))     DEALLOCATE(impbuf_tab%LB)
        IF (ALLOCATED(impbuf_tab%LB0))    DEALLOCATE(impbuf_tab%LB0)
        IF (ALLOCATED(impbuf_tab%BKUD))   DEALLOCATE(impbuf_tab%BKUD)
        IF (ALLOCATED(impbuf_tab%D_IMP))  DEALLOCATE(impbuf_tab%D_IMP)
        IF (ALLOCATED(impbuf_tab%DR_IMP)) DEALLOCATE(impbuf_tab%DR_IMP)
        IF (ALLOCATED(impbuf_tab%ELBUF_C)) DEALLOCATE(impbuf_tab%ELBUF_C)
        IF (ALLOCATED(impbuf_tab%BUFMAT_C))DEALLOCATE(impbuf_tab%BUFMAT_C)
        IF (ALLOCATED(impbuf_tab%X_C)) DEALLOCATE(impbuf_tab%X_C)
        IF (ALLOCATED(impbuf_tab%DD)) DEALLOCATE(impbuf_tab%DD)
        IF (ALLOCATED(impbuf_tab%DDR)) DEALLOCATE(impbuf_tab%DDR)
        IF (ALLOCATED(impbuf_tab%X_A))    DEALLOCATE(impbuf_tab%X_A)
        IF (ALLOCATED(impbuf_tab%FEXT))   DEALLOCATE(impbuf_tab%FEXT)
        IF (ALLOCATED(impbuf_tab%DG))     DEALLOCATE(impbuf_tab%DG)
        IF (ALLOCATED(impbuf_tab%DGR))    DEALLOCATE(impbuf_tab%DGR)
        IF (ALLOCATED(impbuf_tab%DG0))     DEALLOCATE(impbuf_tab%DG0)
        IF (ALLOCATED(impbuf_tab%DGR0))    DEALLOCATE(impbuf_tab%DGR0)
        IF (ALLOCATED(impbuf_tab%BUFIN_C)) DEALLOCATE(impbuf_tab%BUFIN_C)
        IF (ALLOCATED(impbuf_tab%AC)) DEALLOCATE(impbuf_tab%AC)
        IF (ALLOCATED(impbuf_tab%ACR)) DEALLOCATE(impbuf_tab%ACR)
C
        RETURN

deallocm()

subroutine deallocm

Definition at line 4874 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE imp_knon
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        IF(ALLOCATED(in_kn)) DEALLOCATE(in_kn)
        IF(ALLOCATED(id_kn)) DEALLOCATE(id_kn)
        IF (numn_kn>0) THEN
          IF(ALLOCATED(id_knm)) DEALLOCATE(id_knm)
          IF(ALLOCATED(id_knm2)) DEALLOCATE(id_knm2)
          IF(ALLOCATED(id_knm3)) DEALLOCATE(id_knm3)
          IF(ALLOCATED(ii2_kn)) DEALLOCATE(ii2_kn)
          IF(ALLOCATED(irb_kn)) DEALLOCATE(irb_kn)
          IF(ALLOCATED(ibc_kn)) DEALLOCATE(ibc_kn)
          IF(ALLOCATED(ifx_kn)) DEALLOCATE(ifx_kn)
          IF(ALLOCATED(irw_kn)) DEALLOCATE(irw_kn)
          IF(ALLOCATED(irbe3_kn)) DEALLOCATE(irbe3_kn)
          IF(ALLOCATED(fcdi_kn)) DEALLOCATE(fcdi_kn)
          IF(ALLOCATED(mcdi_kn)) DEALLOCATE(mcdi_kn)
        ENDIF
C------------------------------------------
        RETURN

deallocm_imp()

subroutine deallocm_imp

(

integer

mumps_par

)

Definition at line 4922 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE imp_kbcs
        USE imp_bfgs
        USE imp_dyna
        USE imp_workh
        USE imp_pcg_proj
        USE imp_qstat
        USE imp_spbrm
        USE imp_intbuf
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include "com01_c.inc"
#include "impl1_c.inc"
#include "impl2_c.inc"
#if defined(MUMPS5)
#include "dmumps_struc.h"
#endif
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
#ifdef MUMPS5
      TYPE(DMUMPS_STRUC) MUMPS_PAR
#else
      ! Fake declaration as DMUMPS_STRUC is shipped with MUMPS
      INTEGER MUMPS_PAR
#endif
#if defined(MUMPS5)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        IF(imumpsv > 0 ) CALL spmd_mumps_deal(mumps_par)
        IF (isolv>2) THEN
          IF(ALLOCATED(hold)) DEALLOCATE(hold)
        ENDIF
        IF (insolv>1) THEN
          IF(ALLOCATED(bfgs_v)) DEALLOCATE(bfgs_v)
          IF(ALLOCATED(bfgs_w)) DEALLOCATE(bfgs_w)
        ENDIF
        IF (idyna>0) THEN
          IF(ALLOCATED(dy_d)) DEALLOCATE(dy_d)
          IF(ALLOCATED(dy_dr)) DEALLOCATE(dy_dr)
          IF(ALLOCATED(dy_v)) DEALLOCATE(dy_v)
          IF(ALLOCATED(dy_vr)) DEALLOCATE(dy_vr)
c        IF(ALLOCATED(DY_A)) DEALLOCATE(DY_A)
c        IF(ALLOCATED(DY_AR)) DEALLOCATE(DY_AR)
          IF (idy_damp>0) THEN
            DEALLOCATE(dy_diak0,dy_ltk0)
            DEALLOCATE(dy_iadk0,dy_jdik0)
          ENDIF
          IF (hht_a/=zero)DEALLOCATE(dy_r0,dy_r1)
        ENDIF
C---------------lin_solv--------
        IF(ALLOCATED(l_u)) DEALLOCATE(l_u)
        IF(ALLOCATED(diag_t)) DEALLOCATE(diag_t)
        IF(ALLOCATED(l_f0)) DEALLOCATE(l_f0)
        IF (isolv==1.OR.isolv>4) THEN
          IF(ALLOCATED(iadk0)) DEALLOCATE(iadk0)
          IF(ALLOCATED(jdik0)) DEALLOCATE(jdik0)
          IF(ALLOCATED(lt_k0)) DEALLOCATE(lt_k0)
          IF(ALLOCATED(pcg_w1)) DEALLOCATE(pcg_w1)
          IF(ALLOCATED(pcg_w2)) DEALLOCATE(pcg_w2)
          IF(ALLOCATED(pcg_w3)) DEALLOCATE(pcg_w3)
          IF (iprec==5) THEN
            IF(ALLOCATED(iadm0)) DEALLOCATE(iadm0)
            IF(ALLOCATED(jdim0)) DEALLOCATE(jdim0)
            IF(ALLOCATED(lt_m0)) DEALLOCATE(lt_m0)
          ENDIF
          IF (m_vs>0) THEN
            IF(ALLOCATED(proj_s)) DEALLOCATE(proj_s)
            IF(ALLOCATED(proj_t)) DEALLOCATE(proj_t)
            IF(ALLOCATED(proj_la_1)) DEALLOCATE(proj_la_1)
            IF(ALLOCATED(proj_v)) DEALLOCATE(proj_v)
            IF(ALLOCATED(proj_w)) DEALLOCATE(proj_w)
            IF(ALLOCATED(proj_k)) DEALLOCATE(proj_k)
          ENDIF
        ENDIF
        IF(iqstat==1 .AND. iline==0) THEN
          DEALLOCATE(d_n_1)
          IF (iroddl/=0) DEALLOCATE(dr_n_1)
        END IF
        CALL fvbc_deallo
        IF (irig_m>0) THEN
          IF(ALLOCATED(ibc_b)) DEALLOCATE(ibc_b)
          IF(ALLOCATED(ie_bc4)) DEALLOCATE(ie_bc4)
          IF(ALLOCATED(ie_bc3)) DEALLOCATE(ie_bc3)
        END IF
C------    to perform---
c      IF (NINTER>0) THEN
c       IF(ALLOCATED(INTBUF_TAB_CP)) DEALLOCATE(INTBUF_TAB_CP)
c       IF(ALLOCATED(INTBUF_TAB_IMP)) DEALLOCATE(INTBUF_TAB_IMP)
c       IF(ALLOCATED(BMINMA_IMP)) DEALLOCATE(BMINMA_IMP)
c      END IF
C------------------------------------------
        RETURN
#endif

diag_kif()

subroutine diag_kif

(

diag_k

)

Definition at line 2623 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE imp_lintf
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
        my_real
     .    diag_k(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER I,II
C-----------------------------
        RETURN
        DO i=1,nddlif
          ii = iftok(i)
          diag_k(ii) = diag_k(ii) +diag_if(i)
        ENDDO
C-----------------------------
        RETURN

dim_subnz()

subroutine dim_subnz	(	integer, dimension(*)	iadk,
		integer, dimension(*)	jdik,
		integer	nc,
		integer, dimension(*)	jm,
		integer	nnza )

Definition at line 2322 of file imp_solv.F.

C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER  IADK(*)  ,JDIK(*),NC    ,JM(*),NNZA
C     REAL
C-----------------------------------------------
C   External function
C-----------------------------------------------
        INTEGER INTAB0
        EXTERNAL intab0
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER I,J,K,JJ,N
C--------------------------------------------
        nnza=0
        DO i=1,nc
          j=jm(i)
          DO k=iadk(j),iadk(j+1)-1
            jj=jdik(k)
            n=intab0(nc,jm,jj)
            IF (n>0) nnza=nnza+1
          ENDDO
        ENDDO
C
        RETURN

dis_cp()

subroutine dis_cp	(	integer	n,
			d,
			dr,
		integer	iflag )

Definition at line 6849 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE imp_qstat
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER  N,IFLAG
C     REAL
        my_real
     .   d(*),dr(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER I,ND
C------------------------------------------
        IF (iflag ==0 ) THEN
          CALL cp_real(n,d, d_n_1)
          IF (iroddl/=0) CALL cp_real(n,dr, dr_n_1)
        ELSE
          CALL cp_real(n,d_n_1 ,d )
          IF (iroddl/=0) CALL cp_real(n,dr_n_1,dr )
        END IF
C------------------------------------------
        RETURN

du_ini()

subroutine du_ini	(	integer	nodft,
		integer	nodlt,
			dn,
			dnr,
			dd,
			ddr,
		integer	idiv,
		integer	icont0 )

Definition at line 5463 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE imp_dyna
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "impl1_c.inc"
#include      "impl2_c.inc"
#include      "com01_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER NODFT ,NODLT,IDIV   ,ICONT0
        my_real
     .   dn(3,*),dnr(3,*),dd(3,*),ddr(3,*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER I,J,IRES
        my_real
     .    bfac,bdt
C--------------Dn,0=Dn-1--------
C--------special case with /QSTAT diverge by contact, restart w/o resolution
        ires = 1
        IF (iqstat >0 .AND. idiv==-2 .AND. icont0 >0 ) THEN
          idiv=-1
          ires=0
        END IF
C
        bfac=dt1_imp/dt0_imp
        IF (idyna==0) THEN
          IF (ismdisp>0.OR.ires==0) THEN
            DO i = nodft ,nodlt
              dd(1,i) = bfac*dn(1,i)
              dd(2,i) = bfac*dn(2,i)
              dd(3,i) = bfac*dn(3,i)
            END DO
            IF (iroddl/=0) THEN
              DO i = nodft ,nodlt
                ddr(1,i) = bfac*dnr(1,i)
                ddr(2,i) = bfac*dnr(2,i)
                ddr(3,i) = bfac*dnr(3,i)
              END DO
            END IF
          ELSE
            DO i = nodft ,nodlt
              dd(1,i) = dn(1,i)
              dd(2,i) = dn(2,i)
              dd(3,i) = dn(3,i)
            ENDDO
            IF (iroddl/=0) THEN
              DO i = nodft ,nodlt
                ddr(1,i) = dnr(1,i)
                ddr(2,i) = dnr(2,i)
                ddr(3,i) = dnr(3,i)
              ENDDO
            END IF
          END IF
        ELSE
          bdt = half*dt0_imp*dt0_imp*(one-two*dy_b)
          bdt = zero
          DO i = nodft ,nodlt
            dd(1,i) = bfac*dn(1,i)+bdt*dy_a(1,i)
            dd(2,i) = bfac*dn(2,i)+bdt*dy_a(2,i)
            dd(3,i) = bfac*dn(3,i)+bdt*dy_a(3,i)
          END DO
          IF (iroddl/=0) THEN
            DO i = nodft ,nodlt
              ddr(1,i) = bfac*dnr(1,i)+bdt*dy_ar(1,i)
              ddr(2,i) = bfac*dnr(2,i)+bdt*dy_ar(2,i)
              ddr(3,i) = bfac*dnr(3,i)+bdt*dy_ar(3,i)
            END DO
          END IF
        END IF
C------------------------------------------
        RETURN

du_ini_hp()

subroutine du_ini_hp	(		dn,
			dnr,
			dd,
			ddr,
		integer	idiv,
		integer	icont0 )

Definition at line 6948 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE imp_dyna
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "impl1_c.inc"
#include      "impl2_c.inc"
#include      "com01_c.inc"
#include      "com04_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER IDIV   ,ICONT0
        my_real
     .   dn(3,*),dnr(3,*),dd(3,*),ddr(3,*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER NODFT ,NODLT,ITSK
        INTEGER I,J,IRES
        my_real
     .    bfac,bdt
C--------------Dn,0=Dn-1--------
C--------special case with /QSTAT diverge by contact, restart w/o resolution
        ires = 1
        IF (iqstat >0 .AND. idiv==-2 .AND. icont0 >0 ) THEN
          idiv=-1
          ires=0
        END IF
C
        bfac=dt1_imp/dt0_imp
!$OMP PARALLEL PRIVATE(ITSK,NODFT ,NODLT,I,BDT)
        CALL imp_smpini(itsk   ,nodft ,nodlt,numnod  )
        IF (idyna==0) THEN
          IF (ismdisp>0.OR.ires==0) THEN
            DO i = nodft ,nodlt
              dd(1,i) = bfac*dn(1,i)
              dd(2,i) = bfac*dn(2,i)
              dd(3,i) = bfac*dn(3,i)
            END DO
            IF (iroddl/=0) THEN
              DO i = nodft ,nodlt
                ddr(1,i) = bfac*dnr(1,i)
                ddr(2,i) = bfac*dnr(2,i)
                ddr(3,i) = bfac*dnr(3,i)
              END DO
            END IF
          ELSE
            DO i = nodft ,nodlt
              dd(1,i) = dn(1,i)
              dd(2,i) = dn(2,i)
              dd(3,i) = dn(3,i)
            ENDDO
            IF (iroddl/=0) THEN
              DO i = nodft ,nodlt
                ddr(1,i) = dnr(1,i)
                ddr(2,i) = dnr(2,i)
                ddr(3,i) = dnr(3,i)
              ENDDO
            END IF
          END IF
        ELSE
          bdt = half*dt0_imp*dt0_imp*(one-two*dy_b)
          bdt = zero
          DO i = nodft ,nodlt
            dd(1,i) = bfac*dn(1,i)+bdt*dy_a(1,i)
            dd(2,i) = bfac*dn(2,i)+bdt*dy_a(2,i)
            dd(3,i) = bfac*dn(3,i)+bdt*dy_a(3,i)
          END DO
          IF (iroddl/=0) THEN
            DO i = nodft ,nodlt
              ddr(1,i) = bfac*dnr(1,i)+bdt*dy_ar(1,i)
              ddr(2,i) = bfac*dnr(2,i)+bdt*dy_ar(2,i)
              ddr(3,i) = bfac*dnr(3,i)+bdt*dy_ar(3,i)
            END DO
          END IF
        END IF
!$OMP END PARALLEL
C------------------------------------------
        RETURN

get_fext()

subroutine get_fext	(	integer	nddl0,
		integer	nddl,
		integer, dimension(*)	iddl,
		integer, dimension(*)	ndof,
		integer, dimension(*)	ikc,
		integer, dimension(*)	inloc,
			lb,
			fext,
			ac,
			acr )

Definition at line 5213 of file imp_solv.F.

C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "com08_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER NDDL0 ,NDDL   ,IDDL(*),NDOF(*),IKC(*),INLOC(*)
        my_real
     .    lb(*),fext(*),ac(*),acr(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER I,J
        my_real
     .    bfac,ntmp
C-----------------------------------------------
        IF (abs(tt)<em20) RETURN
        bfac=tstop/tt
        IF (nspmd>1) THEN
C -------------------------------
          ntmp = 0
          DO i=1,nddl0
            fext(i)=lb(i)
          ENDDO
          CALL imp_setba(ac    ,acr      ,iddl   ,ndof  ,fext    ,
     1                   ntmp  )
          CALL condens_b(nddl0  ,ikc  ,fext)
          CALL spmd_sumf_v(fext)
          CALL imp_setbp(ac    ,acr    ,iddl   ,ndof   ,ikc   ,
     .                   inloc ,fext   )
          DO i=1,nddl
            fext(i)=bfac*fext(i)
          ENDDO
        ELSE
          DO i=1,nddl0
            fext(i)=bfac*lb(i)
          ENDDO
          CALL condens_b(nddl0  ,ikc  ,fext  )
        END IF
C------------------------------------------
        RETURN

getikce()

subroutine getikce	(	integer	ict,
		integer	icr,
		integer	k,
		integer, dimension(6)	ifix )

Definition at line 8923 of file imp_solv.F.

C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER ICT,ICR,IFIX(6),K
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER ND
C----------------BC-------------------------
        ifix(1:6) = 0
        nd = 0
        IF (ict > 0 .AND. k> 0) THEN
          IF (ict == 4 .AND. k>2) THEN
            ifix(nd +1) = 1
          ELSEIF (ict == 2) THEN
            ifix(nd +2) = 1
          ELSEIF (ict == 1) THEN
            ifix(nd +3) = 1
          ELSEIF (ict == 3) THEN
            ifix(nd +2) = 1
            ifix(nd +3) = 1
          ELSEIF (ict == 5) THEN
            IF (k>2) ifix(nd +1) = 1
            ifix(nd +3) = 1
          ELSEIF (ict == 6) THEN
            IF (k>2) ifix(nd +1) = 1
            ifix(nd +2) = 1
          ELSEIF (ict == 7) THEN
            IF (k>2) ifix(nd +1) = 1
            ifix(nd +2) = 1
            ifix(nd +3) = 1
          ENDIF
        ENDIF
C
        IF (icr > 0 .AND. k==6) THEN
          IF (icr == 1) THEN
            ifix(nd +6) = 1
          ELSEIF (icr == 2) THEN
            ifix(nd +5) = 1
          ELSEIF (icr == 3) THEN
            ifix(nd +5) = 1
            ifix(nd +6) = 1
          ELSEIF (icr == 4) THEN
            ifix(nd +4) = 1
          ELSEIF (icr == 5) THEN
            ifix(nd +4) = 1
            ifix(nd +6) = 1
          ELSEIF (icr == 6) THEN
            ifix(nd +4) = 1
            ifix(nd +5) = 1
          ELSEIF (icr == 7) THEN
            ifix(nd +4) = 1
            ifix(nd +5) = 1
            ifix(nd +6) = 1
          ENDIF
        ENDIF
C
        RETURN

imp_b2a()

subroutine imp_b2a	(		f,
			m,
		integer, dimension(*)	iddl,
		integer, dimension(*)	ndof,
			b )

Definition at line 2444 of file imp_solv.F.

C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER  IDDL(*),NDOF(*)
C     REAL
        my_real
     .   f(3,*),m(3,*),b(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER I,J,ID
C------------------------------------------
        DO i = 1,numnod
          DO j =1,ndof(i)
            id = iddl(i) + j
            IF (j>3) THEN
              m(j-3,i) = b(id)
            ELSE
              f(j,i) = b(id)
            ENDIF
          ENDDO
        ENDDO
C------------------------------------------
        RETURN

imp_check()

subroutine imp_check	(	integer, dimension(*)	itab,
		integer	nddl,
		integer, dimension(*)	iddl,
			diag_k,
		integer, dimension(*)	ndof,
		integer, dimension(*)	ikc,
		integer, dimension(*)	inloc,
		integer	nddl0 )

Definition at line 2048 of file imp_solv.F.

C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
#include      "units_c.inc"
#include      "impl1_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
        INTEGER NDDL,NDDL0,NDOF(*),IDDL(*),IKC(*),INLOC(*),ITAB(*)
        my_real
     .    diag_k(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER NLIM,NID,NN,NKC,NFT,II,IDI,ND,ID,ISTOP
        parameter(nlim=6)
        INTEGER I,J,K,N,INOD(NLIM),IDL(6*NLIM),NFIX(NDDL0)
C------------------------------------------
        nid=0
        DO i=1,nddl
          IF (diag_k(i)<em10) THEN
            nid=nid+1
            idl(nid)=i
            IF (nid==6*nlim) GOTO 100
          ENDIF
        ENDDO
 100    CONTINUE
        IF (nid>0) THEN
c            write(*,*)'nid=',nid
          nkc=0
          DO n = 1,numnod
            i=inloc(n)
            DO j=1,ndof(i)
              nd = iddl(i)+j
              IF (ikc(nd)>0) nkc=nkc+1
              nfix(nd)=nkc
            ENDDO
          ENDDO
          nn=0
          nft=1
          DO 400 k = 1,nid
            DO  n = nft,numnod
              i=inloc(n)
              idi=iddl(i)
              id=idi-nfix(idi)
C          IF (ID>IDL(K)) GOTO 400
              DO j=1,ndof(i)
                nd = idi+j
                id = nd-nfix(nd)
                IF (idl(k)==id) THEN
                  nn=nn+1
                  inod(nn)=itab(i)
c            write(*,*)'id,i,n,j=',id,i,n,j
                  IF (nn==nlim) GOTO 200
                  nft=n+1
                  GOTO 400
                ENDIF
              ENDDO
            ENDDO
 400      CONTINUE
 200      CONTINUE
          IF (nn>0) THEN
            istop=1
            WRITE(iout,*)
     .      ' **ERROR: STIFFNESS MATRIX IS NOT DEFINITE** '
            WRITE(iout,*)'--- LOOK AT NODES:---'
            WRITE(iout,*)(inod(i),i=1,nn)
            WRITE(istdo,*)
     .      ' **ERROR: STIFFNESS MATRIX IS NOT DEFINITE** '
            WRITE(istdo,*)'--- LOOK AT NODES:---'
            WRITE(istdo,*)(inod(i),i=1,nn)
            IF (nrbe2>0.AND.iline==0) istop = 0
            IF (istop>0) CALL imp_stop(-1)
          ENDIF
        ENDIF
C
C------------------------------------------
        RETURN

imp_check0()

subroutine imp_check0	(	integer, dimension(*)	itab,
		integer	nddl,
		integer, dimension(*)	iddl,
			diag_k,
			diag_m,
		integer, dimension(*)	ndof,
		integer, dimension(*)	ikc,
		integer, dimension(*)	inloc,
		integer	nddl0,
		integer	nir,
		integer	nddli,
		integer, dimension(*)	itok,
			diag_i,
		integer	iwar,
		integer	ierr )

Definition at line 2763 of file imp_solv.F.

C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
#include      "units_c.inc"
#include      "task_c.inc"
#include      "com01_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
        INTEGER NDDL,NDDL0,NDOF(*),IDDL(*),IKC(*),INLOC(*),ITAB(*),
     .          NIR,IWAR  ,IERR, NDDLI ,ITOK(*)
        my_real
     .    diag_k(*),diag_m(*),diag_i(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER NLIM,NN,NKC,NFT,II,IDI,ND,ID,NID,NDMAX
        INTEGER I,J,K,N,IDDLM(NUMNOD)
        CHARACTER  DIR(3)
        DATA dir/'X','Y','Z'/
        my_real
     .    s
        my_real,
     .           DIMENSION(:,:),ALLOCATABLE :: sr
C------------------------------------------
        IF (ispmd==0) THEN
          WRITE(iout,*)
          WRITE(iout,*)' ** ZERO STIFFNESS CHECKING **'
          WRITE(iout,*)
          WRITE(istdo,*)' * ZERO STIFFNESS CHECKING '
        ENDIF
        nid=0
        nir=0
        DO i=1,nddl
          diag_m(i) = diag_k(i)
        ENDDO
        DO i=1,nddli
          j=itok(i)
          diag_m(j)=diag_m(j)+diag_i(i)
        ENDDO
        IF (nspmd>1)CALL spmd_sumf_v(diag_m)
        DO i=1,nddl
          IF (diag_m(i)<em10) THEN
            IF (diag_m(i)<=em20) nir =nir +1
            nid = nid + 1
          ENDIF
        ENDDO
C
        IF (nspmd>1) THEN
          s = nid
          CALL spmd_sum_s(s)
          nn = int(s)
          IF (nn>0) THEN
            s = nir
            CALL spmd_sum_s(s)
            nir = int(s)
          ENDIF
        ELSE
          nn = nid
        ENDIF
C
        ierr = ierr + nir
        iwar = iwar + nn-nir
        IF (ispmd==0) WRITE(iout,1000)nn
        IF (nid>0) THEN
          nkc=0
          DO n = 1,numnod
            i=inloc(n)
            iddlm(i)=iddl(i)-nkc
            DO j=1,ndof(i)
              nd = iddl(i)+j
              IF (ikc(nd)>0) nkc=nkc+1
            ENDDO
          ENDDO
        ENDIF
        IF (nspmd>1) THEN
          ndmax = nid
          CALL spmd_max_i(ndmax)
          IF (nid>0) THEN
            ii = 0
            ALLOCATE(sr(3,nid))
            DO  n = 1,numnod
              i=inloc(n)
              idi=iddlm(i)
              nkc = 0
              DO j=1,ndof(i)
                nd = iddl(i)+j
                IF (ikc(nd)==0) THEN
                  nkc=nkc+1
                  id = idi+nkc
                  IF (diag_m(id)<em10) THEN
                    ii = ii + 1
                    sr(1,ii)=itab(i)
                    sr(2,ii)=j
                    sr(3,ii)=diag_m(id)
                  ENDIF
                ENDIF
              ENDDO
            ENDDO
            CALL spmd_send_vr(
     1         nid       ,3    ,sr       ,ndmax     ,iout     )
            DEALLOCATE(sr)
          ENDIF
        ELSE
C
          IF (nid>0) THEN
            DO  n = 1,numnod
              i=inloc(n)
              idi=iddlm(i)
              nkc = 0
              DO j=1,ndof(i)
                nd = iddl(i)+j
                IF (ikc(nd)==0) THEN
                  nkc=nkc+1
                  id = idi+nkc
                  IF (diag_m(id)<em10) THEN
                    IF (j<=3) THEN
                      WRITE(iout,1001)itab(i),dir(j),diag_m(id)
                    ELSE
                      WRITE(iout,1002)itab(i),dir(j-3),diag_m(id)
                    ENDIF
                  ENDIF
                ENDIF
              ENDDO
            ENDDO
          ENDIF
        ENDIF
C------------------------------------------
        RETURN
 1000   FORMAT(' ND. =',i8,5x,'WITH POSSIBLE FREE STIFFNESS CHECKED',/)
 1001   FORMAT(' NODE NUM. =',i10,5x,'TRA_DIR = ',1a,5x,'VAL.= ',g14.7)
 1002   FORMAT(' NODE NUM. =',i10,5x,'ROT_DIR = ',1a,5x,'VAL.= ',g14.7)

imp_checm()

subroutine imp_checm	(	integer, dimension(*)	itab,
		integer	nddl,
		integer, dimension(*)	iddl,
			diag_m,
		integer, dimension(*)	ndof,
		integer, dimension(*)	ikc,
		integer, dimension(*)	inloc,
		integer	nddl0 )

Definition at line 2359 of file imp_solv.F.

C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
#include      "units_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
        INTEGER NDDL,NDDL0,NDOF(*),IDDL(*),IKC(*),INLOC(*),ITAB(*)
        my_real
     .    diag_m(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER NLIM,NID,NN,NKC,NFT,II,IDI,ND,ID
        parameter(nlim=6)
        INTEGER I,J,K,N,INOD(NLIM),IDL(6*NLIM),NFIX(NDDL0)
C------------------------------------------
        nid=0
        DO i=1,nddl
          IF (diag_m(i)>ep10) THEN
            nid=nid+1
            idl(nid)=i
            IF (nid==6*nlim) GOTO 100
          ENDIF
        ENDDO
 100    CONTINUE
        IF (nid>0) THEN
          nkc=0
          DO n = 1,numnod
            i=inloc(n)
            DO j=1,ndof(i)
              nd = iddl(i)+j
              IF (ikc(nd)>0) nkc=nkc+1
              nfix(nd)=nkc
            ENDDO
          ENDDO
          nn=0
          nft=1
          DO 400 k = 1,nid
            DO  n = nft,numnod
              i=inloc(n)
              idi=iddl(i)
              id=idi-nfix(idi)
              DO j=1,ndof(i)
                nd = idi+j
                id = nd-nfix(nd)
                IF (idl(k)==id) THEN
                  nn=nn+1
                  inod(nn)=itab(i)
                  IF (nn==nlim) GOTO 200
                  nft=n+1
                  GOTO 400
                ENDIF
              ENDDO
            ENDDO
 400      CONTINUE
 200      CONTINUE
          IF (nn>0) THEN
            WRITE(iout,*)
     .      ' **WARNING : POSSIBLE NOT DEFINITE STIFFNESS MATRIX ** '
            WRITE(iout,*)'--- LOOK AT NODES:---'
            WRITE(iout,*)(inod(i),i=1,nn)
            WRITE(istdo,*)
     .      ' **WARNING : POSSIBLE NOT DEFINITE STIFFNESS MATRIX ** '
            WRITE(istdo,*)'--- LOOK AT NODES:---'
            WRITE(istdo,*)(inod(i),i=1,nn)
          ENDIF
        ENDIF
C
C------------------------------------------
        RETURN

imp_checm0()

subroutine imp_checm0	(	integer, dimension(*)	itab,
		integer	nddl,
		integer, dimension(*)	iddl,
			diag_m,
		integer, dimension(*)	ndof,
		integer, dimension(*)	ikc,
		integer, dimension(*)	inloc,
		integer	nddl0,
		integer	iwar,
		integer	ierr )

Definition at line 2915 of file imp_solv.F.

C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
#include      "units_c.inc"
#include      "task_c.inc"
#include      "com01_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
        INTEGER NDDL,NDDL0,NDOF(*),IDDL(*),IKC(*),INLOC(*),ITAB(*),
     .          IDDIV,IWAR,IERR
        my_real
     .    diag_m(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER NLIM,NID,NN,NKC,NFT,II,IDI,ND,ID,IW,IR,NDMAX
        INTEGER I,J,K,N,IDDLM(NUMNOD),IDLFT0,IDLFT1
        CHARACTER  DIR(3)
        DATA dir/'X','Y','Z'/
        my_real
     .    s
        my_real,
     .           DIMENSION(:,:),ALLOCATABLE :: sr
C------------------------------------------
        IF (ispmd==0) THEN
          WRITE(iout,*)
          WRITE(iout,*)' ** POSITIVE DEFINITE MATRIX CHECKING **'
          WRITE(iout,*)
          WRITE(istdo,*)' * POSITIVE DEFINITE MATRIX CHECKING '
        ENDIF
        nid=0
        idlft0=0
        ir=0
        IF (nspmd>1)
     .    CALL fr_dlft(nddl,idlft0,idlft1)
        DO i=1+idlft0,nddl
          IF (diag_m(i)<em12.OR.diag_m(i)>ep10) THEN
            IF (diag_m(i)<=em20) ir =ir +1
            nid = nid+ 1
          ENDIF
        ENDDO
C
        IF (nspmd>1) THEN
          s = nid
          CALL spmd_sum_s(s)
          nn = int(s)
          IF (nn>0) THEN
            s = ir
            CALL spmd_sum_s(s)
            ir = int(s)
          ENDIF
        ELSE
          nn = nid
        ENDIF
        ierr = ierr + ir
        iwar = iwar + nn-ir
        IF (ispmd==0) WRITE(iout,1000)nn
        IF (nid>0) THEN
          nkc=0
          DO n = 1,numnod
            i=inloc(n)
            iddlm(i)=iddl(i)-nkc
            DO j=1,ndof(i)
              nd = iddl(i)+j
              IF (ikc(nd)>0) nkc=nkc+1
            ENDDO
          ENDDO
        ENDIF
C
        IF (nspmd>1) THEN
          ndmax = nid
          CALL spmd_max_i(ndmax)
          ALLOCATE(sr(3,nid))
          IF (nid>0) THEN
            ii = 0
            DO  n = 1,numnod
              i=inloc(n)
              idi=iddlm(i)
              IF (ndof(i)>0.AND.idi>=idlft0) THEN
                nkc = 0
                DO j=1,ndof(i)
                  nd = iddl(i)+j
                  IF (ikc(nd)==0) THEN
                    nkc=nkc+1
                    id = idi+nkc
                    IF (diag_m(id)<em12.OR.diag_m(id)>ep10) THEN
                      ii = ii + 1
                      sr(1,ii)=itab(i)
                      sr(2,ii)=j
                      sr(3,ii)=diag_m(id)
                    ENDIF
                  ENDIF
                ENDDO
              ENDIF
            ENDDO
          ENDIF
          CALL spmd_send_vr(
     1          nid       ,3    ,sr       ,ndmax     ,iout     )
          DEALLOCATE(sr)
        ELSE
C
          IF (nid>0) THEN
            DO  n = 1,numnod
              i=inloc(n)
              idi=iddlm(i)
              IF (ndof(i)>0.AND.idi>=idlft0) THEN
                nkc = 0
                DO j=1,ndof(i)
                  nd = iddl(i)+j
                  IF (ikc(nd)==0) THEN
                    nkc=nkc+1
                    id = idi+nkc
                    IF (diag_m(id)<em12.OR.diag_m(id)>ep10) THEN
                      IF (j<=3) THEN
                        WRITE(iout,1001)itab(i),dir(j),diag_m(id)
                      ELSE
                        WRITE(iout,1002)itab(i),dir(j-3),diag_m(id)
                      ENDIF
                    ENDIF
                  ENDIF
                ENDDO
              ENDIF
            ENDDO
          ENDIF
        ENDIF
C------------------------------------------
        RETURN
 1000   FORMAT(' ND. =',i8,5x,'WITH POSSIBLE FREE CONNECTION CHECKED',/)
 1001   FORMAT(' NODE NUM. =',i10,5x,'TRA_DIR = ',1a,5x,'VAL.= ',g14.7)
 1002   FORMAT(' NODE NUM. =',i10,5x,'ROT_DIR = ',1a,5x,'VAL.= ',g14.7)

imp_chkm()

subroutine imp_chkm	(	type(timer_), intent(inout)	timers,
		type(python_), intent(inout)	python,
		integer, dimension(*)	icode,
		integer, dimension(*)	iskew,
		integer, dimension(liskn,*)	iskwn,
		integer, dimension(*)	ipart,
		integer, dimension(nixtg,*)	ixtg,
		integer, dimension(*)	ixs,
		integer, dimension(nixq,*)	ixq,
		integer, dimension(nixc,*)	ixc,
		integer, dimension(nixt,*)	ixt,
		integer, dimension(nixp,*)	ixp,
		integer, dimension(nixr,*)	ixr,
		integer, dimension(4,*)	ixtg1,
		integer, dimension(*)	itab,
		integer, dimension(*)	itabm1,
		integer, dimension(*)	npc,
		integer, dimension(*)	ibcl,
		integer, dimension(*)	ibfv,
		type (sensor_str_), dimension(nsensor)	sensor_tab,
		integer, dimension(10,*)	nnlink,
		integer, dimension(*)	lnlink,
		integer, dimension(nparg,*)	iparg,
		integer, dimension(*)	igrv,
		integer, dimension(npari,*)	ipari,
		type(intbuf_struct_), dimension(*)	intbuf_tab,
		integer, dimension(*)	nprw,
		integer, dimension(*)	iconx,
		integer, dimension(nnpby,*)	npby,
		integer, dimension(*)	lpby,
		integer, dimension(*)	lrivet,
		integer, dimension(*)	nstrf,
		integer, dimension(*)	ljoint,
		integer, dimension(*)	icodt,
		integer, dimension(*)	icodr,
		integer, dimension(*)	isky,
		integer, dimension(*)	adsky,
		integer, dimension(*)	iads_f,
		integer, dimension(*)	ilink,
		integer, dimension(*)	llink,
		integer, dimension(*)	weight,
		integer	itask,
		integer, dimension(nbvelp,*)	ibvel,
		integer, dimension(*)	lbvel,
			fbvel,
			x,
			d,
			v,
			vr,
			dr,
			thke,
			damp,
			ms,
			in,
			pm,
		type(skew_), intent(inout)	skews,
			geo,
			eani,
			bufmat,
			bufgeo,
			bufsf,
			tf,
			forc,
			vel,
			fsav,
			agrv,
			fr_wave,
			parts0,
			elbuf,
			rby,
			rivet,
		integer, dimension(*)	fr_elem,
		integer, dimension(2,*)	iad_elem,
		integer, intent(in)	nsensor,
			wa,
			a,
			ar,
			stifn,
			stifr,
			partsav,
			fsky,
			fskyi,
		integer, dimension(liskn,*)	iframe,
			xframe,
			w16,
		integer, dimension(*)	iactiv,
			fskym,
		integer, dimension(*)	igeo,
		integer, dimension(*)	ipm,
		double precision, intent(inout)	wfext,
		integer	nodft,
		integer	nodlt,
		integer	nint7,
		integer, dimension(*)	num_imp,
		integer, dimension(*)	ns_imp,
		integer, dimension(*)	ne_imp,
		integer, dimension(*)	ind_imp,
		integer	it,
			rwbuf,
		integer, dimension(*)	lprw,
		integer, dimension(nspmd+2,*)	fr_wall,
		integer	nbintc,
		integer, dimension(*)	intlist,
			fopt,
			rwsav,
			fsavd,
		integer, dimension(*)	dirul,
		integer, dimension(*)	lgrav,
		integer, dimension(*)	irbe3,
		integer, dimension(*)	lrbe3,
			frbe3,
		double precision, dimension(*)	frwl6,
		integer, dimension(*)	irbe2,
		integer, dimension(*)	lrbe2,
		integer, dimension(*)	icfield,
		integer, dimension(*)	lcfield,
			cfield,
		type (elbuf_struct_), dimension(ngroup)	elbuf_tab,
		integer, dimension(*)	weight_md,
		type (stack_ply)	stack,
		integer	dimfb,
		double precision, dimension(12,6,dimfb)	fbsav6,
		integer	stabsen,
		integer, dimension(*)	tabsensor,
		type (drape_), dimension(numelc_drape)	drape_sh4n,
		type (drape_), dimension(numeltg_drape)	drape_sh3n,
		type(h3d_database)	h3d_data,
		integer	nddl0,
		integer	nnzk0,
		type (impbuf_struct_), target	impbuf_tab,
		integer	cptreac,
			fthreac,
		integer, dimension(*)	nodreac,
		type (drapeg_)	drapeg,
		type (th_surf_), intent(inout)	th_surf,
		dimension(6,nconld), intent(in)	dpl0cld,
		dimension(6,nconld), intent(in)	vel0cld,
		integer, intent(in)	snpc,
		integer, intent(in)	stf,
		double precision, intent(inout)	wfext_md,
		type (group_), dimension(nsurf)	igrsurf )

Parameters

[in]	snpc	size of NPC
[in]	stf	size of TF / Tabulated function array

Definition at line 3117 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE timer_mod
        USE python_funct_mod, only: python_
        USE dsgraph_mod
        USE imp_worki
        USE elbufdef_mod
        USE intbufdef_mod
        USE stack_mod
        USE h3d_mod
        USE impbufdef_mod
        USE sensor_mod
        USE drape_mod
        USE th_surf_mod , ONLY : th_surf_
        USE skew_mod , ONLY : skew_
        USE groupdef_mod
        use element_mod , only : nixs,nixq,nixc,nixt,nixp,nixr,nixtg
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#if defined(MUMPS5)
#include "dmumps_struc.h"
#endif
#include "timeri_c.inc"
#include "impl1_c.inc"
#include "impl2_c.inc"
#include "param_c.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "units_c.inc"
#include "task_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        TYPE(TIMER_), INTENT(INOUT) :: TIMERS
        TYPE(PYTHON_), INTENT(INOUT) :: PYTHON
        INTEGER ,INTENT(IN) :: SNPC    !< size of NPC
        INTEGER ,INTENT(IN) :: STF     !< size of TF / Tabulated function array
        INTEGER ,INTENT(IN) :: NSENSOR
        INTEGER ITASK,ICODE(*), ISKEW(*), ISKWN(LISKN,*),ITABM1(*),
     .          IPART(*),IXS(*),IXQ(NIXQ,*),IXC(NIXC,*), IXT(NIXT,*),
     .          IXP(NIXP,*),IXR(NIXR,*), IXTG(NIXTG,*), IXTG1(4,*),
     .          ITAB(*),NPC(*), IBCL(*), IBFV(*),IPARG(NPARG,*),IPARI(NPARI,*),
     .          NPRW(*), NPBY(NNPBY,*), LPBY(*),IADS_F(*),
     .          LRIVET(*), NSTRF(*), LJOINT(*), ICODT(*), ICODR(*), ILINK(*),
     .          LLINK(*),ISKY(*),ADSKY(*),
     .          NNLINK(10,*),LNLINK(*),IGRV(*),LGRAV(*),
     .          WEIGHT(*),IFRAME(LISKN,*),IBVEL(NBVELP,*),LBVEL(*),
     .          IACTIV(*),IGEO(*),IPM(*),ICONX(*),NODFT  ,NODLT,IT,
     .          ICFIELD(*),LCFIELD(*),WEIGHT_MD(*),
     .          DIMFB,STABSEN,TABSENSOR(*),CPTREAC,NODREAC(*)
        INTEGER LPRW(*), FR_WALL(NSPMD+2,*), FR_ELEM(*), IAD_ELEM(2,*),NBINTC ,INTLIST(*),DIRUL(*)
        my_real  x(3,*)    ,d(3,*)      ,v(3,*)   ,vr(3,*),damp(*),
     .           ms(*)   ,in(*)   ,pm(npropm,*),geo(npropg,*),
     .           bufmat(*) ,tf(*) ,forc(*)  ,vel(*),fsav(nthvki,*) ,elbuf(*) ,
     .           rwbuf(nrwlp,*),rwsav(*),rby(nrby,*),
     .           rivet(*),wa(*), a(3,*) ,ar(3,*),partsav(*) ,
     .           stifn(*) ,stifr(*),fsky(*),fskyi(*),dr(3,*),
     .           eani(*),agrv(*), thke(*),fr_wave(*),parts0(*),bufgeo(*),
     .           xframe(nxframe,*),w16(*),fbvel(*),fskym(*),bufsf(*),
     .           fopt(6,*),fsavd(nthvki,*),cfield(*),frbe3(*),
     .           fthreac(6,*)
        INTEGER  NDDL0,NNZK0,NINT7
        INTEGER  NUM_IMP(*),NS_IMP(*),NE_IMP(*),IND_IMP(*),IRBE3(*),LRBE3(*),IRBE2(*),LRBE2(*)
        TYPE (DRAPE_) :: DRAPE_SH4N(NUMELC_DRAPE), DRAPE_SH3N(NUMELTG_DRAPE)
        TYPE (DRAPEG_) :: DRAPEG
        my_real, INTENT(IN) :: dpl0cld(6,nconld),vel0cld(6,nconld)
        DOUBLE PRECISION FRWL6(*)
        DOUBLE PRECISION FBSAV6(12,6,DIMFB)
        TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP) :: ELBUF_TAB
        TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
        TYPE (STACK_PLY) :: STACK
        TYPE(H3D_DATABASE) :: H3D_DATA
        TYPE (IMPBUF_STRUCT_) ,TARGET :: IMPBUF_TAB
        TYPE (SENSOR_STR_) ,DIMENSION(NSENSOR) :: SENSOR_TAB
        TYPE (TH_SURF_) , INTENT(INOUT) :: TH_SURF
        TYPE(SKEW_),INTENT(INOUT) :: SKEWS
        DOUBLE PRECISION,INTENT(INOUT) :: WFEXT, WFEXT_MD
        TYPE (GROUP_)  , DIMENSION(NSURF)   :: IGRSURF
C----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER  NNMAX,NKMAX,N_IMPN,N_IMPM,LNSS,LNSS2,NDT,NDS,NT_RW
        INTEGER I,J,NTMP,L1,L2,L3,NNDL,INPRINT,ISTOP,LI10,LI11,
     .          LI1,LI2,LI3,LI4,LI5,LI6,LI7,LI8,LI9,LIF,IC,ISETP,
     .          LI12,LNSS3,LI13,LI14,LI15,LNSB2,LNSRB2
        INTEGER, DIMENSION(:),ALLOCATABLE :: NSS,ISS,NSS2,ISS2,NSS3,ISS3
        INTEGER, DIMENSION(:),ALLOCATABLE :: NSB2,ISB2,IAINT2
        INTEGER  NNOD,IFDIS,N1,N2,N3
        INTEGER LBAND,NCL_MAX,IRFLAG,IBID
        my_real tfexc,tmp,tmp1,tmp2,r2,bfac,faci,r02,gap,rbid,we_imp,lamda,dummy_fext(3,1)
        INTEGER, POINTER     :: NDDL,NNZK,NRBYAC,NINT2,NMC,NMC2,NMONV
        INTEGER, DIMENSION(:) ,POINTER     :: IADK,JDIK,IADM,JDIM
        INTEGER, DIMENSION(:) ,POINTER     :: IDDL,NDOF,INLOC,LSIZE,I_IMP,IKC,
     .                                        IRBYAC,NSC,IINT2,NKUD,IMONV,
     .                                        IKINW,W_DDL,IKUD,NDOFI,IDDLI
        my_real, DIMENSION(:) ,POINTER     :: diag_k,lt_k,diag_m,lt_m,lb,
     .                                        lb0,bkud,d_imp,elbuf_c,bufmat_c,
     .                                        dr_imp,x_c,dd,ddr,x_a,r_imp
        my_real, DIMENSION(:) ,POINTER     :: fext,dg,dgr,dg0,dgr0,bufin_c,ac,acr
        TYPE(PRGRAPH) :: GRAPHE(1)
#ifdef MUMPS5
        TYPE(DMUMPS_STRUC) MUMPS_PAR
#else
        ! Fake declaration as DMUMPS_STRUC is shipped with MUMPS
        INTEGER MUMPS_PAR
#endif
 
C------------------------------
C        Initialisation
C-----------------------------------------------
        dummy_fext = zero
        nddl => impbuf_tab%NDDL
        nnzk => impbuf_tab%NNZK
        nrbyac => impbuf_tab%NRBYAC
        nint2 => impbuf_tab%NINT2
        nmc => impbuf_tab%NMC
        nmc2 => impbuf_tab%NMC2
        nmonv => impbuf_tab%NMONV
        iadk => impbuf_tab%IADK
        jdik => impbuf_tab%JDIK
        iddl => impbuf_tab%IDDL
        ndof => impbuf_tab%NDOF
        inloc => impbuf_tab%INLOC
        lsize => impbuf_tab%LSIZE
        i_imp => impbuf_tab%I_IMP
        irbyac => impbuf_tab%IRBYAC
        nsc => impbuf_tab%NSC
        iint2 => impbuf_tab%IINT2
        nkud => impbuf_tab%NKUD
        imonv => impbuf_tab%IMONV
        ikinw => impbuf_tab%IKINW
        ikc => impbuf_tab%IKC
        w_ddl => impbuf_tab%W_DDL
        ikud => impbuf_tab%IKUD
        iadm => impbuf_tab%IADM
        jdim => impbuf_tab%JDIM
        iddli => impbuf_tab%IDDLI
        ndofi => impbuf_tab%NDOFI
        diag_k  =>impbuf_tab%DIAG_K
        lt_k    =>impbuf_tab%LT_K
        diag_m  =>impbuf_tab%DIAG_M
        lt_m    =>impbuf_tab%LT_M
        lb      =>impbuf_tab%LB
        lb0     =>impbuf_tab%LB0
        bkud    =>impbuf_tab%BKUD
        d_imp   =>impbuf_tab%D_IMP
        elbuf_c =>impbuf_tab%ELBUF_C
        bufmat_c=>impbuf_tab%BUFMAT_C
        x_c     =>impbuf_tab%X_C
        dd      =>impbuf_tab%DD
        ddr     =>impbuf_tab%DDR
        fext  =>impbuf_tab%FEXT
        dg    =>impbuf_tab%DG
        dgr   =>impbuf_tab%DGR
        dg0   =>impbuf_tab%DG0
        dgr0  =>impbuf_tab%DGR0
        dr_imp=>impbuf_tab%DR_IMP
        ac=>impbuf_tab%AC
        acr=>impbuf_tab%ACR
        r_imp => impbuf_tab%R_IMP
        ALLOCATE(iaint2(nint2))
        nddli=0
        istop=0
        inega=0
        nndl = 3*numnod
        nsrem=0
        nsl=0
        isetp = 1
        imp_iw = 0
        imp_ir = 0
        rbid=zero
        ibid= 0
C
        IF (irref>0.AND.imconv==1.AND.iline/=1) THEN
          irflag=irref
        ELSE
          irflag=0
        ENDIF
C
        CALL zeror(d_imp,numnod)
        IF (iroddl/=0) CALL zeror(dr_imp,numnod)
        CALL zeror(ac,numnod)
        IF (iroddl/=0) CALL zeror(acr,numnod)
C----------------------------------
C       FORCES EXTERNES A=Fext-Fint
C----------------------------------
        ncl_max=0
        r_imp(16)=zero
        IF(nconld/=0) THEN
          CALL force_imp(ibcl    ,forc    ,snpc       ,npc        ,tf         ,
     2                   ac      ,v       ,x          ,skews      ,
     3                   acr     ,vr      ,nsensor    ,sensor_tab ,tfexc      ,
     4                   iads_f  ,fsky    ,dummy_fext ,h3d_data   ,cptreac    ,
     5                   fthreac ,nodreac ,th_surf    ,
     6                   dpl0cld ,vel0cld ,d          ,dr         ,nconld     ,
     7                   numnod  ,nfunct  ,stf        ,wfext)
          IF (nspmd>1) THEN
            DO i=iad_elem(1,1),iad_elem(1,nspmd+1)-1
              j = fr_elem(i)
              n1 = 3*(j-1)+1
              n2 = 3*(j-1)+2
              n3 = 3*(j-1)+3
              tmp = abs(ac(n1))+abs(ac(n2))+abs(ac(n3))
              IF (iroddl/=0) tmp = tmp + abs(acr(n1))+abs(acr(n2))+abs(acr(n3))
              IF (tmp>zero) ncl_max = ncl_max + 1
            ENDDO
          ENDIF
        ENDIF
        IF (nspmd>1) THEN
          CALL spmd_max_i(ncl_max)
          IF (ncl_max>0) THEN
            lband = iad_elem(1,nspmd+1)-iad_elem(1,1)
            IF (iroddl/=0) THEN
              ntmp = 6
            ELSE
              ntmp = 3
            ENDIF
            CALL spmd_sumf_a(ac,acr,iad_elem,fr_elem,ntmp,lband)
          ENDIF
        ENDIF
        IF(ngrav/=0) THEN
          CALL gravit_imp(igrv   ,agrv      ,npc        ,tf    ,ac,
     2                    v      ,x         ,skews%SKEW ,ms,tfexc,
     3                    nsensor,sensor_tab            ,weight,
     4                    lgrav  ,itask     ,
     5                    nrbyac ,irbyac    ,npby       ,rby , python)
        ENDIF
        IF(nloadc/=0) THEN
          CALL cfield_imp(icfield  ,cfield,npc   ,tf    ,ac,
     2                    v     ,x     ,xframe  ,ms,tfexc,
     3                    nsensor,sensor_tab,weight,iframe,
     4                    lcfield ,itask,
     5                    nrbyac,irbyac,npby  ,rby,iskwn, python    )
        ENDIF
C-------------dU_d---------------------------------
        IF(nfxvel/=0.AND.imconv==1) THEN
          CALL fv_imp(ibfv        ,npc    ,tf     ,vel   ,sensor_tab,
     1                d_imp       ,dr_imp ,ikc    ,iddl  ,nsensor   ,
     2                skews%SKEW  ,iframe ,xframe ,v     ,vr    ,
     3                x           ,dirul  ,ndof   ,a     ,vr    )
        ENDIF
C-------------U_d--> rigid wall-------------------------------
        nt_rw=0
        IF (nrwall > 0) THEN
          CALL rgwal0_imp(
     1      x           ,d_imp    ,v                 ,rwbuf            , lprw     ,
     2      nprw        ,ms       ,fsav(1 ,ninter+1) , fr_wall         ,
     3      fopt        ,rwsav    ,weight            ,fsavd(1,ninter+1),
     4      nt_rw       ,iddl     ,ikc               ,imconv           , ndof     , frwl6,
     5      weight_md   ,dimfb    ,fbsav6            ,stabsen          , tabsensor, wfext, wfext_md)
          IF(nt_rw > 0) THEN
            CALL fv_rw(iddl   ,ikc   ,ndof  ,d_imp  ,v )
          ENDIF
        ENDIF
        ifdis=nt_rw+nfxvel
        IF(ifdis>0.AND.imconv==1) THEN
          IF(nt_rw>0) THEN
            DO i=1,nddl0
              IF (ikc(i)==3) ikc(i)=4
              IF (ikc(i)==10) ikc(i)=11
            ENDDO
          ENDIF
        ENDIF
        ntmp = nt_rw
        IF (nspmd>1) CALL spmd_max_i(ntmp)
        IF(ntmp>0) THEN
          IF(ispmd==0) THEN
            WRITE(iout,*)'  *--------- RIGID WALL IMPACT---------*'
          ENDIF
        ENDIF
C----------------------------------
        CALL imp_setb(ac    ,acr     ,iddl   ,ndof  ,lb    )
C----------------------------------
C  CHECKING
C----------------------------------
        IF (ispmd==0) THEN
          WRITE(istdo,*)
          WRITE(istdo,*)' ** BEGIN IMPLICIT MODEL CHECKING **'
          WRITE(iout,*)
          WRITE(iout,*)' ** BEGIN IMPLICIT MODEL CHECKING **'
          WRITE(iout,*)
        ENDIF
        IF (nspmd>1) THEN
          CALL imp_compabp(
     1     icodt     ,icodr     ,iskew     ,ibfv      ,npc       ,
     2     tf        ,vel       ,nsensor   ,sensor_tab,xframe    ,
     3     rby       ,x         ,skews%SKEW,lpby      ,npby      ,
     4     itab      ,nrbyac    ,irbyac    ,nint2     ,iint2     ,
     5     ipari     ,intbuf_tab,nt_rw     ,nddl      ,
     6     ndof      ,ikc       ,inloc     ,iddl      ,nddl0     ,
     7     imp_iw    ,imp_ir    )
        ELSE
          CALL imp_compab(
     1     icodt     ,icodr     ,iskew      ,ibfv      ,npc       ,
     2     tf        ,vel       ,nsensor    ,sensor_tab,xframe    ,
     3     rby       ,x         ,skews%SKEW ,lpby      ,npby      ,
     4     itab      ,nrbyac    ,irbyac     ,nint2     ,iint2     ,
     5     ipari     ,intbuf_tab,nt_rw      ,nddl      ,
     6     ndof      ,ikc       ,inloc      ,iddl      ,nddl0     ,
     7     imp_iw    ,imp_ir    )
        ENDIF
 
 
C----------------------------------
C       STIFFNESS MATRIX
C----------------------------------
        IF (isetk==1) THEN
          IF (ispmd==0) THEN
            WRITE(istdo,*)' * FINIT ELEMENT CHECKING '
            WRITE(iout,*)' ** FINIT ELEMENT CHECKING **'
            WRITE(iout,*)
          ENDIF
          IF (imon>0 .AND. itask ==0) CALL startime(timers,31)
          nddl = nddl0
          nnzk = nnzk0
          nnmax=lsize(9)
          nkmax=lsize(10)
          nmc2=lsize(11)
 
          CALL zero1(diag_k,nddl)
          CALL zero1(lt_k,nnzk)
 
          l1 = 1+nixs*numels
          l2 = l1+6*numels10
          l3 = l2+12*numels20
          li1 =1
          li2 = li1+lsize(4)
          li3 = li2+lsize(5)
          li4 = li3+lsize(1)
          li5 = li4+lsize(3)
          li6 = li5+lsize(7)
          li7 = li6+lsize(2)
          li8 = li7+lsize(6)
          li9 = li8+nint2
          li10 = li9+lsize(8)
          li11 = li10+(lsize(8)-lcokm)*lsize(9)
          li12 = li11+lcokm*lsize(10)
          li13 = li12+4*lsize(11)
          li14 = li13+lsize(14)
          li15 = li14+lsize(15)
          lif = li15+lsize(16)
C    /---------------/
c      CALL MY_BARRIER
C    /---------------/
          CALL imp_glob_khp(
     1     pm        ,geo        ,ipm       ,igeo      ,elbuf     ,
     2     ixs       ,ixq        ,ixc       ,ixt       ,ixp       ,
     3     ixr       ,ixtg       ,ixtg1     ,ixs(l1)   ,
     4     ixs(l2)   ,ixs(l3)    ,iparg     ,tf        ,npc       ,
     5     fr_wave   ,w16        ,bufmat    ,thke      ,bufgeo    ,
     6     rby       ,skews%SKEW ,x         ,
     7     wa        ,iddl       ,ndof      ,diag_k    ,lt_k      ,
     8     iadk      ,jdik       ,ikg       ,ibid      ,itask     ,
     9     elbuf_tab ,stack      ,drape_sh4n, drape_sh3n   ,drapeg   )
          nddl_l = nddl
C    /---------------/
c      CALL MY_BARRIER
C    /---------------/
 
C------ 1er VP: for dt check
          IF (impdeb>0.AND.nddl<1000) THEN
            CALL pvp_k(nddl,iadk,jdik,iddl ,inloc,ndof,itab,diag_k,lt_k ,lamda, j , ms  )
            tmp = two*sqrt(one/lamda)
            write(iout,*) 'critical DT =',tmp
          END IF
          IF (idyna>0.OR.iqstat>0)
     .    CALL imp_dynam(nodft  ,nodlt   ,iddl   ,ndof   ,diag_k ,
     .                   ms     ,in      ,hht_a  ,weight ,iadk   ,
     .                   lt_k   )
          CALL upd_glob_k(
     1    icodt     ,icodr     ,iskew      ,ibfv       ,npc       ,
     2    tf        ,vel       ,xframe     ,
     3    rby       ,x         ,skews%SKEW ,lpby       ,npby      ,
     4    itab      ,weight    ,ms         ,in         ,nrbyac    ,
     5    irbyac    ,nsc       ,ikinw(li1) ,nmc        ,ikinw(li2),
     6    ikinw(li3),ikinw(li4),nint2      ,iint2      ,ikinw(li8),
     7    ikinw(li5),ikinw(li6),ikinw(li7) ,ipari      ,intbuf_tab,
     8    nddl      ,nnzk      ,iadk       ,jdik       ,
     9    diag_k    ,lt_k      ,ndof       ,iddl       ,ikc       ,
     a    d_imp     ,lb        ,nkud       ,ikud       ,bkud      ,
     b    nmc2      ,ikinw(li12),nt_rw     ,dr_imp     ,dirul     ,
     c    irbe3     ,lrbe3     ,frbe3      ,ikinw(li13),irbe2    ,
     d    lrbe2     ,ikinw(li14),ikinw(li15))
 
          IF (nspmd>1) THEN
            CALL upd_fr_k(
     1      iadk     ,jdik     ,ndof      ,ikc      ,iddl     ,
     2      inloc    ,fr_elem  ,iad_elem  ,nddl     )
 
            CALL weightddl(iddl  ,ndof  ,ikc  ,weight ,w_ddl  ,inloc )
          ENDIF
          CALL pr_infok(nddl0,nnzk0,nddl,nnzk,max(nnmax,nkmax))
          IF (iprec>4.AND.nkmax>200) THEN
            CALL k_band(nddl,iadk,jdik,ibid)
            maxb = min(maxb,ibid)
            IF (maxb>10000) THEN
              CALL m_lnz(nddl,iadk,jdik,maxb,max_l)
            ENDIF
          ENDIF
 
          CALL ini_k0h(nddl,nnzk,nnzk,iadk,jdik)
          IF (imon>0) CALL stoptime(timers,31)
        ENDIF
 
C----------------------------------
C       MATRICE DE RIGIDITE D'INTERFACE
C----------------------------------
        gap=ep20
        IF (nint7>0) THEN
          l1=lsize(1)
          l2=lsize(2)
          lnss2=0
          lnss=0
          IF (imon>0) CALL startime(timers,31)
          IF (imp_int==1) CALL idel_int(
     1    ipari     ,intbuf_tab,num_imp   ,ns_imp    ,ne_imp    ,
     2    ind_imp   ,ndof      ,nint7     )
          CALL dim_int_k(
     1    ipari     ,intbuf_tab,num_imp   ,ns_imp    ,ne_imp    ,
     2    npby      ,lpby      ,itab      ,nrbyac    ,irbyac    ,
     3    lnss      ,nint2     ,iint2     ,iaint2    ,lnss2     ,
     4    nddli     ,nnzi      ,iddli     ,ndofi     ,n_impn    ,
     5    n_impm    ,nnmax     ,nkmax     ,ndof      ,nsrem     ,
     6    irbe3     ,lrbe3     ,lnss3     ,irbe2     ,lrbe2     ,
     7    lnsb2     ,lnsrb2    ,ind_imp   )
          ALLOCATE(iadi(nddli+1))
          ALLOCATE(itok(nddli))
          ALLOCATE(jdii(nnzi))
          ALLOCATE(nss2(l2),nss3(nrbe3),nsb2(lnsrb2))
          nsb2=0
          ALLOCATE(iss2(lnss2),iss3(lnss3),isb2(lnsb2))
          ALLOCATE(nss(l1))
          ALLOCATE(iss(lnss))
          DO i=1,l1
            nss(i)=0
          ENDDO
          CALL ind_int_k(
     1    ipari     ,intbuf_tab,num_imp   ,ns_imp    ,ne_imp      ,
     2    npby      ,lpby      ,itab      ,nrbyac    ,irbyac      ,
     3    nss       ,iss       ,nint2     ,iint2     ,nss2        ,
     4    iss2      ,nddli     ,nnzi      ,iadi      ,jdii        ,
     5    iddli     ,ndofi     ,n_impn    ,itok      ,iddl        ,
     6    nnmax     ,nkmax     ,n_impm    ,ndof      ,iaint2      ,
     7    irbe3     ,lrbe3     ,nss3      ,iss3      ,irbe2       ,
     8    lrbe2     ,nsb2      ,isb2      ,ind_imp   )
          ALLOCATE(diag_i(nddli))
          ALLOCATE(lt_i(nnzi))
          CALL zero1(diag_i,nddli)
          CALL zero1(lt_i,nnzi)
          IF (nsrem>0)
     1      CALL imp_fr7i(ipari ,intbuf_tab  ,num_imp ,ns_imp ,nsrem ,
     2                    nbintc,intlist)
          !-------A is not updated here -------------------
          CALL imp_int_k(a     ,v          ,
     1    icodt     ,icodr     ,iskew      ,ibfv      ,npc       ,
     2    tf        ,vel       ,nsensor    ,sensor_tab,xframe    ,
     3    rby       ,x         ,skews%SKEW ,lpby      ,npby      ,
     4    itab      ,weight    ,ms         ,in        ,nrbyac    ,
     5    irbyac    ,nss       ,iss        ,ipari     ,intbuf_tab,
     6    nint2     ,iint2     ,iaint2     ,nss2      ,
     7    iss2      ,nddli     ,nnzi       ,iadi      ,jdii      ,
     8    diag_i    ,lt_i      ,iddli      ,nddl0     ,iadk      ,
     9    jdik      ,ikc       ,diag_k     ,lt_k      ,iddl      ,
     a    num_imp   ,ns_imp    ,ne_imp     ,ind_imp   ,ndofi     ,
     b    itok      ,d_imp     ,lb         ,gap       ,dirul     ,
     c    nt_rw     ,ibid      ,irbe3      ,lrbe3     ,frbe3     ,
     d    nss3      ,iss3      ,irbe2      ,lrbe2     ,nsb2      ,
     e    isb2      )
C
          DEALLOCATE(nss2,nss3,nsb2)
          DEALLOCATE(iss2,iss3,isb2)
          DEALLOCATE(nss)
          DEALLOCATE(iss)
          IF (nspmd==1.AND.imconv>=0.AND.(lprint/=0.OR.nprint/=0)) THEN
            WRITE(iout,1006)
            WRITE(iout,1007)nddli,nnzi,nnmax
            WRITE(iout,*)
          ENDIF
          IF (imon>0) CALL stoptime(timers,31)
        ENDIF
C----------------------------------
        IF (nfxvel/=0.AND.imconv==1) THEN
          CALL fv_imp1(nkud   ,ikud    ,bkud    ,lb    )
        ENDIF
C-------------LB,A,AR becomes Fext-Fint---------------------
        CALL upd_rhs(icodt ,icodr ,iskew      ,ibfv    ,xframe ,
     1               rby   ,x     ,skews%SKEW ,lpby   ,npby   ,
     2               nrbyac,irbyac,nint2      ,iint2  ,ipari  ,
     3               intbuf_tab   ,ndof       ,iddl   ,ikc    ,
     4               nddl0 ,lb    ,isetk      ,inloc  ,dirul  ,
     5               a     ,ar    ,ac         ,acr    ,nt_rw  ,
     6               irflag,w_ddl ,nddl       ,r_imp(1),idyna ,
     7               v     ,vr    ,ms         ,in     ,irbe3  ,
     8               lrbe3 ,frbe3 ,weight     ,irbe2  ,lrbe2  )
 
        IF (nspmd>1) THEN
          IF (nbintc>0.) THEN
            iconta = nddli + nsrem
            CALL spmd_max_i(iconta)
            IF (iconta> 0) THEN
              CALL imp_fri(
     1        num_imp   ,ns_imp    ,ne_imp    ,ipari     ,intbuf_tab,
     2        npby      ,lpby      ,itab      ,nrbyac    ,
     3        irbyac    ,nint2     ,iint2     ,iddl      ,ikc       ,
     4        ndof      ,inloc     ,nsrem     ,nsl       ,nbintc    ,
     5        intlist   ,x         ,ibfv      ,dirul     ,skews%SKEW,
     6        xframe    ,iskew     ,icodt     ,a         ,d_imp     ,
     7        lb        ,ifdis     ,nddl      ,dr_imp    ,iddli     ,
     8        irbe3     ,lrbe3     ,frbe3     ,irbe2  ,lrbe2 )
              CALL spmd_min_s(gap)
              CALL spmd_max_i(ifdis)
              IF ((nsrem+nsl)>0.AND.ifdis>0)
     .          CALL imp_frfv(
     1        num_imp   ,ns_imp    ,ne_imp    ,ipari     ,intbuf_tab,
     2        iddl      ,ikc       ,ndof      ,nsrem     ,
     3        nsl       ,d_imp     ,dd        ,dr_imp    ,ddr       ,
     4        a         ,ar        ,ms        ,v         ,x         ,
     5        lb        ,nddl      ,ibfv      ,skews%SKEW,xframe    ,
     6        irbe3     ,lrbe3     ,irbe2     ,lrbe2     ,r_imp(16) ,
     7        nddl0     ,w_ddl     )
            ENDIF
          ENDIF
        ENDIF
        IF (gap<zero) THEN
          imconv = -2
          IF (ispmd==0) THEN
            WRITE(iout,1009)int(-gap)
            WRITE(istdo,1009)int(-gap)
          ENDIF
        ENDIF
C----------------------------------
C       IMPLICIT [K] CHECK
C----------------------------------
        CALL imp_check0(itab  ,nddl  ,iddl  ,diag_k  ,diag_m  ,
     .                  ndof  ,ikc   ,inloc ,nddl0   ,inega   ,
     .                  nddli ,itok  ,diag_i,imp_iw  ,imp_ir )
        IF (inega>0) GOTO 100
        ntmp=0
        CALL produt_w(nddl,lb,lb,w_ddl,r2)
        IF (r2>zero.AND.r2<ep30) THEN
        ELSEIF(iqstat>0) THEN
          WRITE(iout,*)
          WRITE(iout,*)' ** WARNING :IMPLICIT LOADING DATA **'
          imp_iw = imp_iw + 1
        ELSE
          WRITE(iout,*)
          WRITE(iout,*)' ** ERROR :IMPLICIT LOADING DATA **'
          imp_ir = imp_ir + 1
        ENDIF
 
C
C    /---------------/
c      CALL MY_BARRIER
C    /---------------/
        CALL lin_solv(nddl  ,iddl  ,ndof   ,ikc   ,d_imp ,
     1                dr_imp,l_tol ,nnzk   ,iadk  ,jdik  ,
     2                diag_k,lt_k   ,nddli  ,iadi  ,jdii  ,
     3                diag_i,lt_i   ,itok   ,iadm  ,jdim  ,
     4                diag_m,lt_m   ,lb    ,r_imp(6),inloc ,
     5                fr_elem,iad_elem,w_ddl,itask ,isetp  ,
     6                istop ,a     ,ar     ,v    ,
     7                ms    ,x     ,ipari ,intbuf_tab   ,
     8                num_imp,ns_imp,ne_imp,nsrem       ,nsl  ,
     9                ntmp  ,graphe, itab  ,rbid        ,ibid ,
     a                ibid  ,ntmp  ,ibid   ,ibid        ,igrsurf ,
     b                ibid  ,rbid   ,ibfv  ,skews%SKEW  ,
     c                xframe,mumps_par,ibid,ibid  ,rbid ,
     d                irbe3 ,lrbe3 ,irbe2  ,lrbe2 )
        CALL imp_checm0(itab  ,nddl  ,iddl  ,diag_m  ,ndof  ,ikc   ,inloc ,nddl0 ,imp_iw  ,imp_ir)
        IF (nint7>0) THEN
          DEALLOCATE(iadi)
          DEALLOCATE(itok)
          DEALLOCATE(jdii)
          DEALLOCATE(diag_i)
          DEALLOCATE(lt_i)
        ENDIF
 
 100    CONTINUE
C    /---------------/
        CALL my_barrier
C    /---------------/
        IF (ispmd == 0 .AND. itask == 0) THEN
          WRITE(istdo,1011)imp_ir,imp_iw
        ENDIF
 
 1001   FORMAT(' SYMBOLIC DIM : NDDL =',i8,1x,'NNZ =',i8,1x,'NB_MAX =',i8)
 1002   FORMAT(' FINAL    DIM : NDDL =',i8,1x,'NNZ =',i8,1x,'NB_MAX =',i8)
 1006   FORMAT(5x,'--SUPPLEMENTARY STIFFNESS MATRIX',1x, 'DUE TO INTERFACE IS CREATED --')
 1007   FORMAT(5x,' WITH DIM. : ND   =',i8,1x,'NZ  =',i8,1x,'NB_MAX =',i8)
 1009   FORMAT(3x,'**TIMESTEP WILL BE REDUCED TO AVOID DE-ACTIVATION ','IN INTERFACE :**',i8)
 1011   FORMAT(/,2x,'** END IMPLICIT MODEL CHECKING **'/,
     .         5x,'TERMINATION WITH '/,i8,' ERRORS '/,i8,' WARNINGS'/
     .         5x,'** DETAILS REPORTED IN LISTING FILE **'/)
        RETURN

imp_compab()

subroutine imp_compab	(	integer, dimension(*)	icodt,
		integer, dimension(*)	icodr,
		integer, dimension(*)	iskew,
		integer, dimension(nifv,*)	ibfv,
		integer, dimension(*)	npc,
			tf,
			vel,
		integer, intent(in)	nsensor,
		type (sensor_str_), dimension(nsensor)	sensor_tab,
			xframe,
			rby,
			x,
			skew,
		integer, dimension(*)	lpby,
		integer, dimension(nnpby,*)	npby,
		integer, dimension(*)	itab,
		integer	nrbyac,
		integer, dimension(*)	irbyac,
		integer	nint2,
		integer, dimension(*)	iint2,
		integer, dimension(npari,*)	ipari,
		type(intbuf_struct_), dimension(*)	intbuf_tab,
		integer	nt_rw,
		integer	nddl,
		integer, dimension(*)	ndof,
		integer, dimension(*)	ikc,
		integer, dimension(*)	inloc,
		integer, dimension(*)	iddl,
		integer	nddl0,
		integer	iwar,
		integer	ierr )

Definition at line 3746 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE intbufdef_mod
        USE sensor_mod
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "tabsiz_c.inc"
#include      "com01_c.inc"
#include      "com04_c.inc"
#include      "com08_c.inc"
#include      "param_c.inc"
#if defined(MUMPS5)
#include      "dmumps_struc.h"
#endif
#include      "sphcom.inc"
#include      "units_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER ,INTENT(IN) :: NSENSOR
        INTEGER NPC(*),IBFV(NIFV,*),
     .          ICODT(*),ICODR(*),ISKEW(*),NINT2 ,IINT2(*),NT_RW
        INTEGER LPBY(*),NPBY(NNPBY,*),ITAB(*),IPARI(NPARI,*),
     .          NRBYAC,IRBYAC(*),NDDL,NDOF(*),
     .          IDDL(*),IKC(*),INLOC(*) ,NDDL0,IERR,IWAR
        my_real rby(nrby,*) ,x(3,*) ,skew(*)
        my_real tf(*),vel(lfxvelr,*),xframe(nxframe,*)
        TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
        TYPE (SENSOR_STR_) ,DIMENSION(NSENSOR) :: SENSOR_TAB
#if defined(MUMPS5)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER NSN,I,J,K,N,M,JI,NS,NN,IRW,ID
        INTEGER NKINE,IKIN(NUMNOD),IOF(NUMNOD)
        INTEGER ISENS,II,IDEB,IT,ICOMP,NTY,IR,IW
        my_real startt, stopt, ts,ss
        CHARACTER*25  MSG_TYPE(2)
        CHARACTER*25  CSP
        DATA msg_type/ '** WARNING **', '!! ERROR !!'/
C--------implicit imcompability--
        icomp = 0
        it = 1
        WRITE(iout,*)
        WRITE(iout,*)' ** INCOMBABILITY CHECKING **'
        WRITE(iout,*)
        WRITE(istdo,*)
        WRITE(istdo,*)' * INCOMBABILITY CHECKING '
C-----------
        IF (nlaser>0) THEN
          icomp = icomp + nlaser
          iwar = iwar +1
          WRITE(iout,1100)msg_type(it),'IMPACT LASER'
        ENDIF
        DO n =1,ninter
          nty   =ipari(7,n)
          IF (nty==2.OR.nty==7.OR.nty==10.OR.nty==11
     .        .OR.nty==5.OR.nty==24) THEN
            IF(nty==7.AND.ipari(33,n)/=0)THEN
              icomp = icomp + ipari(33,n)
              iwar = iwar +1
              WRITE(iout,1100)msg_type(it),'LAGRANGE MULTIPLIER INTERFACE'
            ENDIF
          ELSEIF (nty>0) THEN
            iwar = iwar +1
            icomp = icomp + 1
            WRITE(csp,'(A,I2.2)')'INTERFACE TYPE ',nty
            WRITE(iout,1100)msg_type(it),csp
          ENDIF
        ENDDO
        IF (nrivet>0) THEN
          icomp = icomp + nrivet
          iwar = iwar +1
          WRITE(iout,1100)msg_type(it),'RIVET'
        ENDIF
        IF (ngjoint>0) THEN
          icomp = icomp + ngjoint
          iwar = iwar +1
          WRITE(iout,1100)msg_type(it),'JOINT TYPE SPRINGS'
        ENDIF
        IF (njoint>0) THEN
          icomp = icomp + njoint
          iwar = iwar +1
          WRITE(iout,1100)msg_type(it),'CYLINDRIC JOINT'
        ENDIF
        IF (nummpc>0) THEN
          icomp = icomp + nummpc
          iwar = iwar +1
          WRITE(iout,1100)msg_type(it),'MULTI-POINT CONSTRAINTS'
        ENDIF
        IF (nlink>0) THEN
          icomp = icomp + nlink
          iwar = iwar +1
          WRITE(iout,1100)msg_type(it),'RIGID LINK'
        ENDIF
        IF (numelx>0) THEN
          icomp = icomp + numelx
          iwar = iwar +1
          WRITE(iout,1100)msg_type(it),'MULTI-PURPOSE ELEMENTS'
        ENDIF
        IF (numels16>0) THEN
          icomp = icomp + numels16
          iwar = iwar +1
          WRITE(iout,1100)msg_type(it),'SOLID 16n. ELEMENTS'
        ENDIF
        IF (numels20>0) THEN
          icomp = icomp + numels20
          iwar = iwar +1
          WRITE(iout,1100)msg_type(it),'SOLID 20n. ELEMENTS'
        ENDIF
        IF (numeltg6>0) THEN
          icomp = icomp + numeltg6
          iwar = iwar +1
          WRITE(iout,1100)msg_type(it),'SHELL S3N6 ELEMENTS'
        ENDIF
        IF (numsph>0) THEN
          icomp = icomp + numsph
          iwar = iwar +1
          WRITE(iout,1100)msg_type(it),'SPH ELEMENTS'
        ENDIF
C
        IF (icomp>0) WRITE(iout,1101) icomp
C--------IKIN: 1 MAIN node of rb, 2 s.n. of int2--,3 s.n. of rb,
C------------: 4 bcs, 5 imposed Dis. ,6 sn of rwall, 7 ns of joint,8 ns os rlink
        DO n =1,numnod
          ikin(n)=0
          IF (ndof(n)>0) THEN
            iof(n)=2
          ELSE
            iof(n)=1
          ENDIF
        ENDDO
C----- MAIN of rigid body first------
        ir =0
        DO i=1,nrbyac
          n=irbyac(i)
          m=npby(1,n)
          IF (ikin(m)==0) THEN
            ikin(m)=1
          ELSE
            WRITE(iout,1001)msg_type(2),itab(m)
            ir = ir + 1
          ENDIF
        ENDDO
        ierr = ierr +ir
C------interface 2--------------
        iw =0
        ir =0
        DO i=1,nint2
          n=iint2(i)
          nsn = ipari(5,n)
          DO j=1,nsn
            ns=intbuf_tab(n)%NSV(j)
            IF (ikin(ns)==0) THEN
              ikin(ns)=2
            ELSEIF(ikin(ns)==1) THEN
              WRITE(iout,1002)msg_type(1),itab(ns)
              iw =iw + 1
            ELSEIF(ikin(ns)==2) THEN
              WRITE(iout,1003)msg_type(2),itab(ns)
              ir =ir + 1
            ENDIF
          ENDDO
        ENDDO
C----- rigid body ------
        DO i=1,nrbyac
          n=irbyac(i)
          k=irbyac(i+nrbykin)
          m=npby(1,n)
          nsn  =npby(2,n)
          DO j=1,nsn
            ns=lpby(k+j)
            IF (ikin(ns)==0) THEN
              ikin(ns)=3
            ELSEIF(ikin(ns)==1) THEN
              WRITE(iout,1004)msg_type(1),itab(ns)
              iw =iw + 1
            ELSEIF(ikin(ns)==2) THEN
              it = min(iof(ns),2)
              WRITE(iout,1005)msg_type(it),itab(ns)
              IF (it==1) THEN
                iw =iw + 1
              ELSEIF (it==2) THEN
                ir =ir + 1
              ENDIF
            ELSEIF(ikin(ns)==3) THEN
              it = min(iof(ns),2)
              WRITE(iout,1006)msg_type(it),itab(ns)
              IF (it==1) THEN
                iw =iw + 1
              ELSEIF (it==2) THEN
                ir =ir + 1
              ENDIF
            ENDIF
          ENDDO
        ENDDO
C--------bcs---------
        IF (iroddl==0) THEN
          DO n = 1,numnod
            IF (icodt(n) > 0) THEN
              IF (ikin(n)==0) THEN
                ikin(n)=4
              ELSEIF(ikin(n)==2) THEN
                it = min(iof(n),2)
                WRITE(iout,1007)msg_type(it),itab(n)
                IF (it==1) THEN
                  iw =iw + 1
                ELSEIF (it==2) THEN
                  ir =ir + 1
                ENDIF
              ELSEIF(ikin(n)==3) THEN
                it = min(iof(n),2)
                WRITE(iout,1008)msg_type(it),itab(n)
                IF (it==1) THEN
                  iw =iw + 1
                ELSEIF (it==2) THEN
                  ir =ir + 1
                ENDIF
              ENDIF
            ENDIF
          ENDDO
        ELSE
          DO n = 1,numnod
            IF ((icodt(n)+icodr(n))>0 ) THEN
              IF (ikin(n)==0) THEN
                ikin(n)=4
              ELSEIF(ikin(n)==2) THEN
                it = min(iof(n),2)
                WRITE(iout,1007)msg_type(it),itab(n)
                IF (it==1) THEN
                  iw =iw + 1
                ELSEIF (it==2) THEN
                  ir =ir + 1
                ENDIF
              ELSEIF(ikin(n)==3) THEN
                it = min(iof(n),2)
                WRITE(iout,1008)msg_type(it),itab(n)
                IF (it==1) THEN
                  iw =iw + 1
                ELSEIF (it==2) THEN
                  ir =ir + 1
                ENDIF
              ENDIF
            ENDIF
          ENDDO
        ENDIF
C--------fxv---------
        DO nn=1,nfxvel,nvsiz
          IF (ibfv(8,nn)==1) GOTO 100
          IF (nsensor>0) THEN
            DO 10 ii = 1, min(nfxvel-ideb,nvsiz)
              n = ii+ideb
              startt = vel(2,n)
              stopt  = vel(3,n)
              IF(tt<startt)GOTO 10
              IF(tt>stopt) GOTO 10
              i=iabs(ibfv(1,n))
              isens=0
              DO k=1,nsensor
                IF(ibfv(4,n)==sensor_tab(k)%SENS_ID) isens=k
              ENDDO
              IF(isens==0)THEN
                ts=tt
              ELSE
                ts = tt-sensor_tab(isens)%TSTART
                IF(ts<zero)GOTO 10
              ENDIF
              IF (ikin(i)==0) THEN
                ikin(i)=5
              ELSEIF(ikin(i)==2) THEN
                WRITE(iout,1009)msg_type(2),itab(i)
                ir =ir + 1
              ELSEIF(ikin(i)==3) THEN
                WRITE(iout,1010)msg_type(2),itab(i)
                ir =ir + 1
              ELSEIF(ikin(i)==4) THEN
                WRITE(iout,1011)msg_type(2),itab(i)
                ir =ir + 1
              ENDIF
 10         CONTINUE
          ELSE
            DO 20 ii = 1, min(nfxvel-ideb,nvsiz)
              n = ii+ideb
              startt = vel(2,n)
              stopt  = vel(3,n)
              IF(tt<startt)GOTO 20
              IF(tt>stopt) GOTO 20
              i=iabs(ibfv(1,n))
              IF (ikin(i)==0) THEN
                ikin(i)=5
              ELSEIF(ikin(i)==2) THEN
                WRITE(iout,1009)msg_type(2),itab(i)
                ir =ir + 1
              ELSEIF(ikin(i)==3) THEN
                WRITE(iout,1010)msg_type(2),itab(i)
                ir =ir + 1
              ELSEIF(ikin(i)==4) THEN
                WRITE(iout,1011)msg_type(2),itab(i)
                ir =ir + 1
              ENDIF
 20         CONTINUE
          ENDIF
C
          ideb = ideb + min(nfxvel-ideb,nvsiz)
 100      CONTINUE
        ENDDO
C--------rwall---------
        IF (nt_rw>0) THEN
          DO i = 1,numnod
            k = min(3,ndof(i))
            irw = 0
            DO j =1,k
              id = iddl(i) + j
              IF (ikc(id)==4.OR.ikc(id)==11) irw = 1
            ENDDO
            IF (irw>0) THEN
              IF (ikin(i)==0) THEN
                ikin(i)=6
              ELSEIF(ikin(i)==2) THEN
                WRITE(iout,1012)msg_type(2),itab(i)
                ir =ir + 1
              ELSEIF(ikin(i)==3) THEN
                WRITE(iout,1013)msg_type(2),itab(i)
                ir =ir + 1
              ELSEIF(ikin(i)==4) THEN
                WRITE(iout,1014)msg_type(2),itab(i)
                ir =ir + 1
              ELSEIF(ikin(i)==5) THEN
                WRITE(iout,1015)msg_type(1),itab(i)
                iw =iw + 1
              ENDIF
            ENDIF
          ENDDO
        ENDIF
        ierr = ierr +ir
        iwar = iwar +iw
        RETURN
 1001   FORMAT(a,' NODE USED FOR DIFF. RBODY MAIN=',i8)
 1002   FORMAT(a,' INCOMPABILITY NODE BETWEEN ',/
     .         'RBODY MAIN AND INTERF. TYPE2 SECONDARY =',i8)
 1003   FORMAT(a,' INCOMPABILITY NODE BETWEEN ',/
     .         'INTERF. TYPE2 SECONDARY AND INTERF. TYPE2 SECONDARY=',i8)
 1004   FORMAT(a,' INCOMPABILITY NODE BETWEEN ',/
     .         ' RBODY MAIN AND RBODY SECONDARY=',i8)
 1005   FORMAT(a,' INCOMPABILITY NODE BETWEEN ',/
     .         ' INTERF. TYPE2 SECONDARY AND RBODY SECONDARY=',i8)
 1006   FORMAT(a,' INCOMPABILITY NODE BETWEEN ',/
     .         ' RBODY SECONDARY AND RBODY SECONDARY=',i8)
 1007   FORMAT(a,' INCOMPABILITY NODE BETWEEN ',/
     .         ' BOUNDARY CONDITIONS AND INTERF. TYPE2 SECONDARY=',i8)
 1008   FORMAT(a,' incompability node between ',/
     .         ' boundary conditions and rbody secondary=',I8)
 1009   FORMAT(A,' incompability node between ',/
     .         ' imposed disp. and interf. type2 secondary=',I8)
 1010   FORMAT(A,' incompability node between ',/
     .         ' imposed disp. and rbody secondary=',I8)
 1011   FORMAT(A,' incompability node between ',/
     .         ' imposed disp. and boundary conditions=',I8)
 1012   FORMAT(A,' incompability node between ',/
     .         ' rwall contact and interf. type2 secondary=',I8)
 1013   FORMAT(A,' incompability node between ',/
     .         ' rwall contact and rbody secondary=',I8)
 1014   FORMAT(A,' incompability node between ',/
     .         ' rwall contact and boundary conditions=',I8)
 1015   FORMAT(A,' incompability node between ',/
     .         ' rwall contact and imposed disp.=',I8)
 1100   FORMAT(A,' IMPLICIT is incompable with :',A/)
 1101   FORMAT(/'**stiffness will be ignored with',1X,I8,
     .          ' incompable options**'/)
#endif

imp_compabp()

subroutine imp_compabp	(	integer, dimension(*)	icodt,
		integer, dimension(*)	icodr,
		integer, dimension(*)	iskew,
		integer, dimension(nifv,*)	ibfv,
		integer, dimension(*)	npc,
			tf,
			vel,
		integer, intent(in)	nsensor,
		type (sensor_str_), dimension(nsensor)	sensor_tab,
			xframe,
			rby,
			x,
			skew,
		integer, dimension(*)	lpby,
		integer, dimension(nnpby,*)	npby,
		integer, dimension(*)	itab,
		integer	nrbyac,
		integer, dimension(*)	irbyac,
		integer	nint2,
		integer, dimension(*)	iint2,
		integer, dimension(npari,*)	ipari,
		type(intbuf_struct_), dimension(*)	intbuf_tab,
		integer	nt_rw,
		integer	nddl,
		integer, dimension(*)	ndof,
		integer, dimension(*)	ikc,
		integer, dimension(*)	inloc,
		integer, dimension(*)	iddl,
		integer	nddl0,
		integer	iwar,
		integer	ierr )

Definition at line 4143 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE intbufdef_mod
        USE sensor_mod
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "com04_c.inc"
#include      "com08_c.inc"
#include      "param_c.inc"
#include      "task_c.inc"
#include      "sphcom.inc"
#include      "units_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER ,INTENT(IN) :: NSENSOR
        INTEGER NPC(*),IBFV(NIFV,*),
     .          ICODT(*),ICODR(*),ISKEW(*),NINT2 ,IINT2(*),NT_RW
        INTEGER LPBY(*),NPBY(NNPBY,*),ITAB(*),IPARI(NPARI,*),
     .          NRBYAC,IRBYAC(*),NDDL,NDOF(*),
     .          IDDL(*),IKC(*),INLOC(*) ,NDDL0,IERR,IWAR
        my_real rby(nrby,*) ,x(3,*) ,skew(*)
        my_real tf(*),vel(lfxvelr,*),xframe(nxframe,*)
        TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
        TYPE (SENSOR_STR_) ,DIMENSION(NSENSOR) :: SENSOR_TAB
#if defined(MUMPS5)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER NSN,I,J,K,N,M,JI,K10,K11,K12,NS,NN,IRW,ID,IV
        INTEGER NKINE,IKIN(NUMNOD),IOF(NUMNOD),VI(3,NUMNOD)
        INTEGER ISENS,II,IDEB,IT,ICOMP,NTY,IR,IW,NVMAX,NSIZ
        my_real startt, stopt, ts,ss
        CHARACTER*25  MSG_TYPE(2)
        DATA msg_type / '** WARNING **', '!! ERROR !!'/
C--------implicit imcompability--
        icomp = 0
        it = 1
        IF (ispmd==0) THEN
          WRITE(iout,*)
          WRITE(iout,*)' ** INCOMBABILITY CHECKING **'
          WRITE(iout,*)
          WRITE(istdo,*)
          WRITE(istdo,*)' * INCOMBABILITY CHECKING '
        ENDIF
C
        nn = nlaser
        CALL spmd_max_i(nn)
        IF (nn>0.AND.ispmd==0) THEN
          icomp = icomp + nn
          iwar = iwar +1
          WRITE(iout,1100)msg_type(it),'IMPACT LASER'
        ENDIF
        iv = 0
        DO n =1,ninter
          nty   =ipari(7,n)
          IF (nty==2.OR.nty==7.OR.nty==10.OR.nty==11
     .        .OR.nty==5.OR.nty==24) THEN
            IF(nty==7.AND.ipari(33,n)/=0)THEN
              icomp = icomp + ipari(33,n)
              iwar = iwar +1
              WRITE(iout,1100)msg_type(it),'LAGRANGE MULTIPLIER INTERFACE'
            ENDIF
          ELSEIF (nty>0) THEN
            iwar = iwar +1
            icomp = icomp + 1
C---------------- hopes that the opposite does not happen -----
            IF (iv<=numnod) THEN
              iv = iv + 1
              vi(1,iv) = nty
            ENDIF
          ENDIF
        ENDDO
        nvmax = iv
        CALL spmd_max_i(nvmax)
        IF (nvmax>0) THEN
          CALL spmd_send_vi(
     1    iv       ,1     ,vi       ,nvmax     ,iout     )
        ENDIF
        nn = nrivet
        CALL spmd_max_i(nn)
        IF (nn>0.AND.ispmd==0) THEN
          icomp = icomp + nn
          iwar = iwar +1
          WRITE(iout,1100)msg_type(it),'RIVET'
        ENDIF
        nn = ngjoint
        CALL spmd_max_i(nn)
        IF (nn>0.AND.ispmd==0) THEN
          icomp = icomp + nn
          iwar = iwar +1
          WRITE(iout,1100)msg_type(it),'JOINT TYPE SPRINGS'
        ENDIF
        nn = njoint
        CALL spmd_max_i(nn)
        IF (nn>0.AND.ispmd==0) THEN
          icomp = icomp + nn
          iwar = iwar +1
          WRITE(iout,1100)msg_type(it),'CYLINDRIC JOINT'
        ENDIF
        nn = nummpc
        CALL spmd_max_i(nn)
        IF (nn>0.AND.ispmd==0) THEN
          icomp = icomp + nn
          iwar = iwar +1
          WRITE(iout,1100)msg_type(it),'MULTI-POINT CONSTRAINTS'
        ENDIF
        nn = nlink
        CALL spmd_max_i(nn)
        IF (nn>0.AND.ispmd==0) THEN
          icomp = icomp + nn
          iwar = iwar +1
          WRITE(iout,1100)msg_type(it),'RIGID LINK'
        ENDIF
        nn = numelx
        CALL spmd_max_i(nn)
        IF (nn>0.AND.ispmd==0) THEN
          icomp = icomp + nn
          iwar = iwar +1
          WRITE(iout,1100)msg_type(it),'MULTI-PURPOSE ELEMENTS'
        ENDIF
        nn = numels16
        CALL spmd_max_i(nn)
        IF (nn>0.AND.ispmd==0) THEN
          icomp = icomp + nn
          iwar = iwar +1
          WRITE(iout,1100)msg_type(it),'SOLID 16n. ELEMENTS'
        ENDIF
        nn = numels20
        CALL spmd_max_i(nn)
        IF (nn>0.AND.ispmd==0) THEN
          icomp = icomp + nn
          iwar = iwar +1
          WRITE(iout,1100)msg_type(it),'SOLID 20n. ELEMENTS'
        ENDIF
        nn = numeltg6
        CALL spmd_max_i(nn)
        IF (nn>0.AND.ispmd==0) THEN
          icomp = icomp + nn
          iwar = iwar +1
          WRITE(iout,1100)msg_type(it),'SHELL S3N6 ELEMENTS'
        ENDIF
        nn = numsph
        CALL spmd_max_i(nn)
        IF (nn>0.AND.ispmd==0) THEN
          icomp = icomp + nn
          iwar = iwar +1
          WRITE(iout,1100)msg_type(it),'SPH ELEMENTS'
        ENDIF
C-----------
        IF (icomp>0.AND.ispmd==0) THEN
          WRITE(iout,1101) icomp
        ENDIF
C--------IKIN: 1 MAIN node of rb, 2 s.n. of int2--,3 s.n. of rb,
C------------: 4 bcs, 5 imposed Dis. ,6 sn of rwall, 7 ns of joint,8 ns os rlink
        nsiz = 3
        DO n =1,numnod
          ikin(n)=0
          IF (ndof(n)>0) THEN
            iof(n)=2
          ELSE
            iof(n)=1
          ENDIF
        ENDDO
C----- MAIN of rigid body first------
        ir =0
        DO i=1,nrbyac
          n=irbyac(i)
          m=npby(1,n)
          IF (ikin(m)==0) THEN
            ikin(m)=1
          ELSE
c        WRITE(IOUT,1001)MSG_TYPE(2),ITAB(M)
            ir = ir + 1
            vi(1,ir) = 1
            vi(2,ir) = 2
            vi(3,ir) = itab(m)
          ENDIF
        ENDDO
        ss = ir
        CALL spmd_sum_s(ss)
        nvmax = ir
        CALL spmd_max_i(nvmax)
        ierr = ierr +int(ss)
        IF (nvmax>0) THEN
          CALL spmd_send_vi(
     1    ir       ,nsiz   ,vi       ,nvmax     ,iout     )
        ENDIF
C------interface 2--------------
        iw =0
        ir =0
        iv =0
        DO i=1,nint2
          n=iint2(i)
          nsn = ipari(5,n)
          ji=ipari(1,n)
          k10=ji-1
          k11=k10+4*ipari(3,n)
C------IRECT(4,NSN)-----
          k12=k11+4*ipari(4,n)
C------NSV(NSN)--node number---
          DO j=1,nsn
            ns=intbuf_tab(n)%NSV(j)
            IF (ikin(ns)==0) THEN
              ikin(ns)=2
            ELSEIF(ikin(ns)==1) THEN
c         WRITE(IOUT,1002)MSG_TYPE(1),ITAB(NS)
              iw =iw + 1
              iv =iv + 1
              vi(1,iv) = 2
              vi(2,iv) = 1
              vi(3,iv) = itab(ns)
            ELSEIF(ikin(ns)==2) THEN
c         WRITE(IOUT,1003)MSG_TYPE(2),ITAB(NS)
              ir =ir + 1
              iv =iv + 1
              vi(1,iv) = 3
              vi(2,iv) = 2
              vi(3,iv) = itab(ns)
            ENDIF
          ENDDO
        ENDDO
        nvmax = iv
        CALL spmd_max_i(nvmax)
        IF (nvmax>0) THEN
          CALL spmd_send_vi(
     1    iv       ,nsiz   ,vi       ,nvmax     ,iout     )
        ENDIF
C----- rigid body ------
        iv =0
        DO i=1,nrbyac
          n=irbyac(i)
          k=irbyac(i+nrbykin)
          m=npby(1,n)
          nsn  =npby(2,n)
          DO j=1,nsn
            ns=lpby(k+j)
            IF (ikin(ns)==0) THEN
              ikin(ns)=3
            ELSEIF(ikin(ns)==1) THEN
c          WRITE(IOUT,1004)MSG_TYPE(1),ITAB(NS)
              iw =iw + 1
              iv =iv + 1
              vi(1,iv) = 4
              vi(2,iv) = 1
              vi(3,iv) = itab(ns)
            ELSEIF(ikin(ns)==2) THEN
              it = min(iof(ns),2)
c          WRITE(IOUT,1005)MSG_TYPE(IT),ITAB(NS)
              iv =iv + 1
              vi(1,iv) = 5
              vi(2,iv) = it
              vi(3,iv) = itab(ns)
              IF (it==1) THEN
                iw =iw + 1
              ELSEIF (it==2) THEN
                ir =ir + 1
              ENDIF
            ELSEIF(ikin(ns)==3) THEN
              it = min(iof(ns),2)
c          WRITE(IOUT,1006)MSG_TYPE(IT),ITAB(NS)
              iv =iv + 1
              vi(1,iv) = 6
              vi(2,iv) = it
              vi(3,iv) = itab(ns)
              IF (it==1) THEN
                iw =iw + 1
              ELSEIF (it==2) THEN
                ir =ir + 1
              ENDIF
            ENDIF
          ENDDO
        ENDDO
        nvmax = iv
        CALL spmd_max_i(nvmax)
        IF (nvmax>0) THEN
          CALL spmd_send_vi(
     1    iv       ,nsiz   ,vi       ,nvmax     ,iout     )
        ENDIF
C--------bcs---------
        iv =0
        IF (iroddl==0) THEN
          DO n = 1,numnod
            IF (icodt(n) > 0) THEN
              IF (ikin(n)==0) THEN
                ikin(n)=4
              ELSEIF(ikin(n)==2) THEN
                it = min(iof(n),2)
c          WRITE(IOUT,1007)MSG_TYPE(IT),ITAB(N)
                iv =iv + 1
                vi(1,iv) = 7
                vi(2,iv) = it
                vi(3,iv) = itab(n)
                IF (it==1) THEN
                  iw =iw + 1
                ELSEIF (it==2) THEN
                  ir =ir + 1
                ENDIF
              ELSEIF(ikin(n)==3) THEN
                it = 1
C          IT = MIN(IOF(N),2)
c          WRITE(IOUT,1008)MSG_TYPE(IT),ITAB(N)
                iv =iv + 1
                vi(1,iv) = 8
                vi(2,iv) = it
                vi(3,iv) = itab(n)
                IF (it==1) THEN
                  iw =iw + 1
                ELSEIF (it==2) THEN
                  ir =ir + 1
                ENDIF
              ENDIF
            ENDIF
          ENDDO
        ELSE
          DO n = 1,numnod
            IF ((icodt(n)+icodr(n))>0 ) THEN
              IF (ikin(n)==0) THEN
                ikin(n)=4
              ELSEIF(ikin(n)==2) THEN
                it = min(iof(n),2)
c          WRITE(IOUT,1007)MSG_TYPE(IT),ITAB(N)
                iv =iv + 1
                vi(1,iv) = 7
                vi(2,iv) = it
                vi(3,iv) = itab(n)
                IF (it==1) THEN
                  iw =iw + 1
                ELSEIF (it==2) THEN
                  ir =ir + 1
                ENDIF
              ELSEIF(ikin(n)==3) THEN
                it = 1
C          IT = MIN(IOF(N),2)
c          WRITE(IOUT,1008)MSG_TYPE(IT),ITAB(N)
                iv =iv + 1
                vi(1,iv) = 8
                vi(2,iv) = it
                vi(3,iv) = itab(n)
                IF (it==1) THEN
                  iw =iw + 1
                ELSEIF (it==2) THEN
                  ir =ir + 1
                ENDIF
              ENDIF
            ENDIF
          ENDDO
        ENDIF
        nvmax = iv
        CALL spmd_max_i(nvmax)
        IF (nvmax>0) THEN
          CALL spmd_send_vi(
     1    iv       ,nsiz   ,vi       ,nvmax     ,iout     )
        ENDIF
C--------fxv---------
        iv =0
        DO nn=1,nfxvel,nvsiz
          IF (ibfv(8,nn)==1) GOTO 100
          IF (nsensor>0) THEN
            DO 10 ii = 1, min(nfxvel-ideb,nvsiz)
              n = ii+ideb
              startt = vel(2,n)
              stopt  = vel(3,n)
              IF(tt<startt)GOTO 10
              IF(tt>stopt) GOTO 10
              i=iabs(ibfv(1,n))
              isens=0
              DO k=1,nsensor
                IF(ibfv(4,n)==sensor_tab(k)%SENS_ID) isens=k
              ENDDO
              IF(isens==0)THEN
                ts=tt
              ELSE
                ts = tt-sensor_tab(isens)%TSTART
                IF(ts<zero)GOTO 10
              ENDIF
              IF (ikin(i)==0) THEN
                ikin(i)=5
              ELSEIF(ikin(i)==2) THEN
c             WRITE(IOUT,1009)MSG_TYPE(2),ITAB(I)
                iv =iv + 1
                vi(1,iv) = 9
                vi(2,iv) = 2
                vi(3,iv) = itab(i)
                ir =ir + 1
              ELSEIF(ikin(i)==3) THEN
c             WRITE(IOUT,1010)MSG_TYPE(2),ITAB(I)
                iv =iv + 1
                vi(1,iv) = 10
                vi(2,iv) = 1
                vi(3,iv) = itab(i)
                iw =iw + 1
              ELSEIF(ikin(i)==4) THEN
c             WRITE(IOUT,1011)MSG_TYPE(2),ITAB(I)
                iv =iv + 1
                vi(1,iv) = 11
                vi(2,iv) = 2
                vi(3,iv) = itab(i)
                ir =ir + 1
              ENDIF
 10         CONTINUE
          ELSE
            DO 20 ii = 1, min(nfxvel-ideb,nvsiz)
              n = ii+ideb
              startt = vel(2,n)
              stopt  = vel(3,n)
              IF(tt<startt)GOTO 20
              IF(tt>stopt) GOTO 20
              i=iabs(ibfv(1,n))
              IF (ikin(i)==0) THEN
                ikin(i)=5
              ELSEIF(ikin(i)==2) THEN
c             WRITE(IOUT,1009)MSG_TYPE(2),ITAB(I)
                iv =iv + 1
                vi(1,iv) = 9
                vi(2,iv) = 2
                vi(3,iv) = itab(i)
                ir =ir + 1
              ELSEIF(ikin(i)==3) THEN
c             WRITE(IOUT,1010)MSG_TYPE(2),ITAB(I)
                iv =iv + 1
                vi(1,iv) = 10
                vi(2,iv) = 1
                vi(3,iv) = itab(i)
                iw =iw + 1
              ELSEIF(ikin(i)==4) THEN
c             WRITE(IOUT,1011)MSG_TYPE(2),ITAB(I)
                iv =iv + 1
                vi(1,iv) = 11
                vi(2,iv) = 2
                vi(3,iv) = itab(i)
                ir =ir + 1
              ENDIF
 20         CONTINUE
          ENDIF
C
          ideb = ideb + min(nfxvel-ideb,nvsiz)
 100      CONTINUE
        ENDDO
        nvmax = iv
        CALL spmd_max_i(nvmax)
        IF (nvmax>0) THEN
          CALL spmd_send_vi(
     1    iv       ,nsiz   ,vi       ,nvmax     ,iout     )
        ENDIF
C--------rwall---------
        iv =0
        IF (nt_rw>0) THEN
          DO i = 1,numnod
            k = min(3,ndof(i))
            irw = 0
            DO j =1,k
              id = iddl(i) + j
              IF (ikc(id)==4.OR.ikc(id)==11) irw = 1
            ENDDO
            IF (irw>0) THEN
              IF (ikin(i)==0) THEN
                ikin(i)=6
              ELSEIF(ikin(i)==2) THEN
c          WRITE(IOUT,1012)MSG_TYPE(2),ITAB(I)
                iv =iv + 1
                vi(1,iv) = 12
                vi(2,iv) = 2
                vi(3,iv) = itab(i)
                ir =ir + 1
              ELSEIF(ikin(i)==3) THEN
c          WRITE(IOUT,1013)MSG_TYPE(2),ITAB(I)
                iv =iv + 1
                vi(1,iv) = 13
                vi(2,iv) = 1
                vi(3,iv) = itab(i)
                iw =iw + 1
              ELSEIF(ikin(i)==4) THEN
c          WRITE(IOUT,1014)MSG_TYPE(2),ITAB(I)
                iv =iv + 1
                vi(1,iv) = 14
                vi(2,iv) = 2
                vi(3,iv) = itab(i)
                ir =ir + 1
              ELSEIF(ikin(i)==5) THEN
c          WRITE(IOUT,1015)MSG_TYPE(1),ITAB(I)
                iv =iv + 1
                vi(1,iv) = 15
                vi(2,iv) = 1
                vi(3,iv) = itab(i)
                iw =iw + 1
              ENDIF
            ENDIF
          ENDDO
        ENDIF
C
        nvmax = iv
        CALL spmd_max_i(nvmax)
        IF (nvmax>0) THEN
          CALL spmd_send_vi(
     1    iv       ,nsiz   ,vi       ,nvmax     ,iout     )
        ENDIF
        ss = ir
        CALL spmd_sum_s(ss)
        ir = int(ss)
        ss = iw
        CALL spmd_sum_s(ss)
        iw = int(ss)
        ierr = ierr +ir
        iwar = iwar +iw
        RETURN
 1100   FORMAT(a,' IMPLICIT IS INCOMPABLE WITH :',a/)
 1101   FORMAT(/'**STIFFNESS WILL BE IGNORED WITH',1x,i8,
     .          ' INCOMPABLE OPTIONS**'/)
C endif MUMPS defined
#endif

imp_cpre()

subroutine imp_cpre	(	integer	iflag,
		integer	nndl,
			elbuf,
			elbuf_c,
			bufmat,
			fsav,
			volmon,
			bufmat_c,
			x,
			x_c,
			partsav,
			r_imp )

Definition at line 2704 of file imp_solv.F.

C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
#include      "param_c.inc"
#include      "scr11_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER IFLAG,NNDL
C     REAL
        my_real
     .    elbuf(*) ,elbuf_c(*),bufmat(*) ,fsav(*),volmon(*) ,bufmat_c(*),
     .    x(*)    ,x_c(*) ,partsav(*),r_imp(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER LI1,LI2,LI3,LI4,LI5
C--------------Iflag= 1->copy; 2 ->restore---------------
        CALL buf_dim(li1,li2,li3,li4)
        IF (iflag==1) THEN
          CALL cp_real(li1,elbuf,elbuf_c)
          CALL cp_real(li2,bufmat,bufmat_c)
          CALL cp_real(li3,fsav,bufmat_c(li2+1))
          CALL cp_real(li4,volmon,bufmat_c(li2+li3+1))
          CALL cp_real(nndl,x,x_c)
          CALL cp_real(npsav*npart,partsav,r_imp(16))
          r_imp(14) = encin
          r_imp(15) = enrot
        ELSEIF (iflag==2) THEN
          CALL cp_real(li1,elbuf_c,elbuf)
          CALL cp_real(li2,bufmat_c,bufmat)
          CALL cp_real(li3,bufmat_c(li2+1),fsav)
          CALL cp_real(li4,bufmat_c(li2+li3+1),volmon)
          CALL cp_real(nndl,x_c,x)
          CALL cp_real(npsav*npart,r_imp(16),partsav)
          encin = r_imp(14)
          enrot = r_imp(15)
        ENDIF
C-----------------------------
        RETURN

imp_errmumps()

subroutine imp_errmumps

(

integer

ierr

)

Definition at line 8650 of file imp_solv.F.

C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include "units_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER  IERR,ISTOP
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        WRITE(istdo,1000)ierr
        WRITE(iout,1000)ierr
        SELECT CASE (-ierr)
         CASE(7,8,9,11,13,14,15,17)
          WRITE(istdo,1030)
          WRITE(iout,1010)
         CASE(6,10)
          WRITE(istdo,2000)
          WRITE(iout,2010)
        END SELECT
        IF(ierr<0)THEN
          istop=-4
          CALL imp_stop(istop)
        END IF
C
        RETURN
 1000   FORMAT(/
     .         '    ** LINEAR SOLVER MUMPS ERROR CODE: ',i6/)
 1030   FORMAT(/
     .         '    ** ERROR MEMORY ISSUE            ' /)
 1010   FORMAT(/
     .         '    ** ERROR MEMORY ISSUE. POSSIBLE SOLUTIONS:' /,
     .         '    *RUN ON A COMPUTER WITH MORE MEMORY ;' /,
     .         '    *TRY LESS THREADS AND LESS PROCS PER COMPUTER NODE ;' /,
     .         '    *CLOSE OTHER APPLICATIONS ;           ' /)
 2000   FORMAT(/
     .         '    ** ERROR OF SINGULAR MATRIX ' /)
 2010   FORMAT(/
     .         '    ** ERROR OF SINGULAR MATRIX. POSSIBLE SOLUTIONS:' /,
     .         '    *CHECK IF THE MODEL IS WELL CONDITIONED ;' /,
     .         '    *TRYING QUASI-STATIC SOLUTION ; ' /)

imp_fanie()

subroutine imp_fanie	(	type(output_)	output,
			fext,
		integer	nfia,
		integer	nfea,
		integer	nodft,
		integer	nodlt,
		type(h3d_database)	h3d_data )

Definition at line 4791 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE h3d_mod
        USE output_mod, ONLY : output_
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "scr14_c.inc"
#include      "scr16_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        TYPE(OUTPUT_) :: OUTPUT
        INTEGER NFIA,NFEA,NODFT,NODLT
C     REAL
        my_real
     .     fext(3,*) 
        TYPE(H3D_DATABASE) :: H3D_DATA
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER N,I,J,K,ND
C---
        IF(anim_v(5)+outp_v(5)+h3d_data%N_VECT_FINT>0) THEN
#include      "vectorize.inc"
          DO n=nodft,nodlt
            output%DATA%VECT_FINT(1,n)= -fext(1,n)
            output%DATA%VECT_FINT(2,n)= -fext(2,n)
            output%DATA%VECT_FINT(3,n)= -fext(3,n)
          ENDDO
        ENDIF
        IF(anim_v(6)+outp_v(6)+h3d_data%N_VECT_FEXT>0) THEN
#include      "vectorize.inc"
          DO n=nodft,nodlt
            output%DATA%VECT_FEXT(1,n)= fext(1,n)
            output%DATA%VECT_FEXT(2,n)= fext(2,n)
            output%DATA%VECT_FEXT(3,n)= fext(3,n)
          ENDDO
        ENDIF
        RETURN

imp_fanii()

subroutine imp_fanii	(	type(output_)	output,
			fint,
		integer	nfia,
		integer	nodft,
		integer	nodlt,
		type(h3d_database)	h3d_data )

Definition at line 4741 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE h3d_mod
        USE output_mod, ONLY : output_
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "scr14_c.inc"
#include      "scr16_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        TYPE(OUTPUT_) :: OUTPUT
        INTEGER NFIA,NODFT,NODLT
C     REAL
        my_real
     .     fint(3,*)  
        TYPE(H3D_DATABASE) :: H3D_DATA
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER N,I,J,K,ND
C---
        IF(anim_v(5)+outp_v(5)+h3d_data%N_VECT_FINT>0) THEN
#include      "vectorize.inc"
          DO n=nodft,nodlt
            output%DATA%VECT_FINT(1,n)= fint(1,n)
            output%DATA%VECT_FINT(2,n)= fint(2,n)
            output%DATA%VECT_FINT(3,n)= fint(3,n)
          ENDDO
        ENDIF
C
        RETURN

imp_fout()

subroutine imp_fout	(	type(output_)	output,
			a,
			ar,
		integer	nfia,
		integer	nfea,
		integer	nodft,
		integer	nodlt,
		type(h3d_database)	h3d_data,
		type (impbuf_struct_), target	impbuf_tab )

Definition at line 4680 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE h3d_mod
        USE output_mod, ONLY : output_
        USE impbufdef_mod
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "scr14_c.inc"
#include      "scr16_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        TYPE(OUTPUT_) :: OUTPUT
        INTEGER NFIA,NFEA,NODFT,NODLT
C     REAL
        my_real
     .     a(3,*)    ,ar(3,*)  
        TYPE(H3D_DATABASE) :: H3D_DATA
        TYPE (IMPBUF_STRUCT_) ,TARGET :: IMPBUF_TAB
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER N,I,J,K,ND
        INTEGER, DIMENSION(:) ,POINTER     :: IDDL,NDOF,IKC
C-------------mis  zero Fint des nodes dependants------------
        iddl => impbuf_tab%IDDL
        ndof => impbuf_tab%NDOF
        ikc => impbuf_tab%IKC
        IF(anim_v(5)+outp_v(5)+h3d_data%N_VECT_FINT>0) THEN
          DO i = nodft,nodlt
            DO j=1,min(3,ndof(i))
              nd = iddl(i)+j
              IF (ikc(nd)/=0) output%DATA%VECT_FINT(j,i)= zero
            ENDDO
            IF (ndof(i)==0) THEN
              output%DATA%VECT_FINT(1,i)= zero
              output%DATA%VECT_FINT(2,i)= zero
              output%DATA%VECT_FINT(3,i)= zero
            ENDIF
          ENDDO
        ENDIF
C
        RETURN

imp_intbuf_ini()

subroutine imp_intbuf_ini	(	type(imp_intbuf_struct_), dimension(*)	imp_intbuf_tab,
		integer, dimension(*)	nimp )

Definition at line 8579 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE imp_intbufdef
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        TYPE(IMP_INTBUF_STRUCT_) IMP_INTBUF_TAB(*)
        INTEGER NIMP(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER I,N,NI,SIZ,I_CONT
C=======================================================================
 
        DO ni= 1, ninter
          i_cont = nimp(ni)
          imp_intbuf_tab(ni)%S_I_STOK        = 1
          imp_intbuf_tab(ni)%S_CAND_N       = 0
          imp_intbuf_tab(ni)%S_CAND_E       = 0
          imp_intbuf_tab(ni)%S_INDSUBT      = 0
          imp_intbuf_tab(ni)%S_HJ         = 0
          imp_intbuf_tab(ni)%S_NJ         = 0
          imp_intbuf_tab(ni)%S_STIF         = 0
          ALLOCATE(imp_intbuf_tab(ni)%I_STOK(imp_intbuf_tab(ni)%S_I_STOK))
          imp_intbuf_tab(ni)%I_STOK(1:imp_intbuf_tab(ni)%S_I_STOK) = 0
          IF (i_cont > 0) THEN
            imp_intbuf_tab(ni)%S_CAND_N       = i_cont
            imp_intbuf_tab(ni)%S_CAND_E       = i_cont
            imp_intbuf_tab(ni)%S_INDSUBT       = i_cont
            imp_intbuf_tab(ni)%S_HJ   = 4*i_cont
            imp_intbuf_tab(ni)%S_NJ   = 3*i_cont
            imp_intbuf_tab(ni)%S_STIF = i_cont
C------Allocate, ini to zero
            ALLOCATE(imp_intbuf_tab(ni)%CAND_N(imp_intbuf_tab(ni)%S_CAND_N))
            imp_intbuf_tab(ni)%CAND_N(1:imp_intbuf_tab(ni)%S_CAND_N) = 0
            ALLOCATE(imp_intbuf_tab(ni)%CAND_E(imp_intbuf_tab(ni)%S_CAND_E))
            imp_intbuf_tab(ni)%CAND_E(1:imp_intbuf_tab(ni)%S_CAND_E) = 0
            ALLOCATE(imp_intbuf_tab(ni)%INDSUBT(imp_intbuf_tab(ni)%S_INDSUBT))
            imp_intbuf_tab(ni)%INDSUBT(1:imp_intbuf_tab(ni)%S_INDSUBT) = 0
C
            ALLOCATE(imp_intbuf_tab(ni)%HJ(imp_intbuf_tab(ni)%S_HJ))
            imp_intbuf_tab(ni)%HJ(1:imp_intbuf_tab(ni)%S_HJ) = zero
            ALLOCATE(imp_intbuf_tab(ni)%NJ(imp_intbuf_tab(ni)%S_NJ))
            imp_intbuf_tab(ni)%NJ(1:imp_intbuf_tab(ni)%S_NJ) = zero
            ALLOCATE(imp_intbuf_tab(ni)%STIF(imp_intbuf_tab(ni)%S_STIF))
            imp_intbuf_tab(ni)%STIF(1:imp_intbuf_tab(ni)%S_STIF) = zero
          END IF
 
        ENDDO !NI=1,NINTER
 
C-----
        RETURN
 

imp_intfr()

subroutine imp_intfr	(	integer, dimension(*)	num_imp,
		integer, dimension(*)	ns_imp,
		integer, dimension(*)	ne_imp,
		integer, dimension(npari,*)	ipari,
		type(intbuf_struct_), dimension(*)	intbuf_tab,
		integer, dimension(nnpby,*)	npby,
		integer, dimension(*)	lpby,
		integer, dimension(*)	itab,
		integer	nrbyac,
		integer, dimension(*)	irbyac,
		integer	nint2,
		integer, dimension(*)	iint2,
		integer, dimension(*)	iddl,
		integer, dimension(*)	ikc,
		integer, dimension(*)	ndof,
		integer, dimension(*)	inloc,
		integer	nsrem,
		integer	nsl,
		integer	nbintc,
		integer, dimension(*)	intlist,
			x,
		integer, dimension(*)	ibfv,
		integer, dimension(*)	dirul,
			skew,
			xframe,
		integer, dimension(*)	iskew,
		integer, dimension(*)	icodt,
			de,
			d_imp,
			lb,
		integer	ifdis,
		integer	nddl,
			dr_imp,
		integer, dimension(*)	iddli,
		integer, dimension(*)	irbe3,
		integer, dimension(*)	lrbe3,
			frbe3,
		integer, dimension(*)	irbe2,
		integer, dimension(*)	lrbe2,
			dd,
			ddr,
			a,
			ar,
			ac,
			acr,
			ms,
			v,
		integer	nddl0,
			r02,
			rby,
		integer, dimension(*)	icodr,
		integer	nt_rw,
		integer, dimension(*)	w_ddl,
		integer, dimension(*)	weight,
		integer	irflag )

Definition at line 7318 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE intbufdef_mod
C----6---------------------------------------------------------------7---------8
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
#include      "param_c.inc"
#include      "impl1_c.inc"
C-----------------------------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER IPARI(NPARI,*),NUM_IMP(*),NS_IMP(*),
     .          NE_IMP(*),NSREM  ,NSL,NBINTC,INTLIST(*),IRFLAG,
     .          IRBE3(*),LRBE3(*),IRBE2(*),LRBE2(*),NDDL0,W_DDL(*),
     .          WEIGHT(*),ICODR(*),NT_RW
        INTEGER NPBY(NNPBY,*),LPBY(*),ITAB(*),NRBYAC,IRBYAC(*),
     .          NINT2,IINT2(*),IDDL(*),IKC(*),NDOF(*),INLOC(*),
     .          IBFV(*),DIRUL(*),ISKEW(*),ICODT(*),IFDIS,NDDL,IDDLI(*)
C     REAL
        my_real
     .         x(3,*),skew(*) ,xframe(*),
     .         a(3,*),d_imp(3,*),lb(*),dr_imp(3,*),frbe3(*),
     .         dd(3,*),ddr(3,*),ar(3,*),ms(*) ,v(3,*),de,
     .         ac(3,*),acr(3,*),r02,rby(nrby,*)
 
        TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER I,J,N,NKC,ND,NDM
        INTEGER, DIMENSION(NDDL0) :: IDM
        my_real, DIMENSION(NDDL0) :: lb0
C
        CALL cp_real_hp(nddl,lb,lb0)
        CALL imp_fri(
     1  num_imp   ,ns_imp    ,ne_imp    ,ipari     ,intbuf_tab,
     2  npby      ,lpby      ,itab      ,nrbyac    ,
     3  irbyac    ,nint2     ,iint2     ,iddl      ,ikc       ,
     4  ndof      ,inloc     ,nsrem     ,nsl       ,nbintc    ,
     5  intlist   ,x         ,ibfv      ,dirul     ,skew      ,
     6  xframe    ,iskew     ,icodt     ,a         ,d_imp     ,
     7  lb        ,ifdis     ,nddl      ,dr_imp    ,iddli     ,
     8  irbe3     ,lrbe3     ,frbe3     ,irbe2     ,lrbe2     )
        IF ( ifdis>0 .AND. intp_c <= 0)
     .   CALL imp_frfv(
     1  num_imp   ,ns_imp    ,ne_imp    ,ipari     ,intbuf_tab,
     2  iddl      ,ikc       ,ndof      ,nsrem     ,
     3  nsl       ,d_imp     ,dd        ,dr_imp    ,ddr       ,
     4  a         ,ar        ,ms        ,v         ,x         ,
     5  lb        ,nddl      ,ibfv      ,skew      ,xframe    ,
     6  irbe3     ,lrbe3     ,irbe2     ,lrbe2     ,de        ,
     7  nddl0     ,w_ddl     )
C--------Fext change (U_d) w/ remot  to re-evalue R02
        IF (irflag>0) THEN
          DO i =1,nddl
            lb0(i) =lb(i)-lb0(i)
          END DO
          DO i =nddl+1,nddl0
            lb0(i) =zero
          END DO
          nkc=0
C------LB0 condensed -> LB0 original
          DO n =1,numnod
            i=inloc(n)
            ndm=iddl(i)-nkc
            DO j=1,ndof(i)
              nd = iddl(i)+j
              IF (ikc(nd)/=0) THEN
                nkc = nkc + 1
                idm(nd)=0
              ELSE
                ndm=ndm+1
                idm(nd)=ndm
              END IF
            ENDDO
          ENDDO
          DO i =nddl0,1,-1
            nd = idm(i)
            IF (nd>0) lb0(i) =lb0(nd)
          END DO
          CALL imp_setba(ac    ,acr     ,iddl   ,ndof  ,lb0   ,1 )
          CALL upd_rhs_fr(icodt ,icodr ,iskew ,ibfv    ,xframe ,
     1                    rby   ,x     ,skew   ,lpby   ,npby   ,
     2                    nrbyac,irbyac,nint2  ,iint2  ,ipari  ,
     3                    intbuf_tab   ,ndof   ,iddl   ,ikc    ,
     4                    nddl0 ,lb0   ,isetk  ,inloc  ,dirul  ,
     5                    ac    ,acr   ,nt_rw  ,w_ddl  ,nddl   ,
     6                    r02   ,irbe3 ,lrbe3  ,frbe3  ,weight ,
     8                    irbe2 ,lrbe2 )
        ENDIF
C----6---------------------------------------------------------------7---------8
        RETURN

imp_smpini()

subroutine imp_smpini	(	integer	itsk,
		integer	n1ftsk,
		integer	n1ltsk,
		integer	n1 )

Definition at line 6908 of file imp_solv.F.

C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "task_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER ITSK   ,N1FTSK ,N1LTSK ,N1
C-----------------------------------------------
C   L o c a l  V a r i a b l e s
C-----------------------------------------------
        INTEGER OMP_GET_THREAD_NUM
        EXTERNAL omp_get_thread_num
C-----------------------------------------------
C   S o u r c e  L i n e s
C-----------------------------------------------
C
C     Initialization of variables for // SMP
C
        itsk = omp_get_thread_num()
        n1ftsk = 1+itsk*n1/ nthread
        n1ltsk = (itsk+1)*n1/ nthread
C
        RETURN

imp_solv()

subroutine imp_solv	(	type (output_), intent(inout)	output,
		type(timer_)	timers,
		type(python_)	python,
		integer, dimension(*)	icode,
		integer, dimension(*)	iskew,
		integer, dimension(liskn,*)	iskwn,
		integer, dimension(*)	ipart,
		integer, dimension(nixtg,*)	ixtg,
		integer, dimension(*)	ixs,
		integer, dimension(nixq,*)	ixq,
		integer, dimension(nixc,*)	ixc,
		integer, dimension(nixt,*)	ixt,
		integer, dimension(nixp,*)	ixp,
		integer, dimension(nixr,*)	ixr,
		integer, dimension(4,*)	ixtg1,
		integer, dimension(*)	itab,
		integer, dimension(*)	itabm1,
		integer, dimension(*)	npc,
		integer, dimension(*)	ibcl,
		integer, dimension(*)	ibfv,
		type (sensor_str_), dimension(nsensor)	sensor_tab,
		integer, dimension(10,*)	nnlink,
		integer, dimension(*)	lnlink,
		integer, dimension(nparg,*)	iparg,
		integer, dimension(*)	igrv,
		integer, dimension(npari,*)	ipari,
		type(intbuf_struct_), dimension(*)	intbuf_tab,
		integer, dimension(*)	nprw,
		integer, dimension(*)	iconx,
		integer, dimension(nnpby,*)	npby,
		integer, dimension(*)	lpby,
		integer, dimension(*)	lrivet,
		integer, dimension(*)	nstrf,
		integer, dimension(*)	ljoint,
		integer, dimension(*)	icodt,
		integer, dimension(*)	icodr,
		integer, dimension(*)	isky,
		integer, dimension(*)	adsky,
		integer, dimension(*)	iads_f,
		integer, dimension(*)	ilink,
		integer, dimension(*)	llink,
		integer, dimension(*)	weight,
		integer	itask,
		integer, dimension(nbvelp,*)	ibvel,
		integer, dimension(*)	lbvel,
			fbvel,
			x,
			d,
			v,
			vr,
			dr,
			thke,
			damp,
			ms,
			in,
			pm,
		type(skew_), intent(inout)	skews,
			geo,
			eani,
			bufmat,
			bufgeo,
			bufsf,
			tf,
			forc,
			vel,
			fsav,
			agrv,
			fr_wave,
			parts0,
			elbuf,
			rby,
			rivet,
		integer, dimension(*)	fr_elem,
		integer, dimension(2,*)	iad_elem,
			wa,
			a,
			ar,
			stifn,
			stifr,
			partsav,
			fsky,
			fskyi,
		integer, dimension(liskn,*)	iframe,
			xframe,
			w16,
		integer, dimension(*)	iactiv,
			fskym,
		integer, dimension(*)	igeo,
		integer, dimension(*)	ipm,
		double precision, intent(inout)	wfext,
		integer	nodft,
		integer	nodlt,
		integer	nint7,
		integer, dimension(*)	num_imp,
		integer, dimension(*)	ns_imp,
		integer, dimension(*)	ne_imp,
		integer, dimension(*)	ind_imp,
		integer	it,
			rwbuf,
		integer, dimension(*)	lprw,
		integer, dimension(nspmd+2,*)	fr_wall,
		integer	nbintc,
		integer, dimension(*)	intlist,
			fopt,
			rwsav,
			fsavd,
		type(prgraph), dimension(*)	graphe,
			fac_k,
		integer, dimension(*)	ipiv_k,
		integer	nkcond,
		integer, intent(in)	nsensor,
		integer, dimension(*)	monvol,
		type (group_), dimension(nsurf)	igrsurf,
		integer, dimension(*)	fr_mv,
			volmon,
		integer, dimension(*)	dirul,
		integer, dimension(*)	nodglob,
		integer	mumps_par,
		integer, dimension(*)	cddlp,
		integer, dimension(*)	isendto,
		integer, dimension(*)	irecvfrom,
		integer, dimension(*)	newfront,
		integer	imsch,
		integer	i2msch,
		integer	isizxv,
		integer	ilenxv,
		integer	islen7,
		integer	irlen7,
		integer	islen11,
		integer	irlen11,
		integer	islen17,
		integer	irlen17,
		integer	irlen7t,
		integer	islen7t,
		integer, dimension(*)	kinet,
		integer, dimension(*)	num_imp1,
			temp,
			dt2prev,
			waint,
		integer, dimension(*)	lgrav,
		integer, dimension(*)	sh4tree,
		integer, dimension(*)	sh3tree,
		integer	irlen20,
		integer	islen20,
		integer	irlen20t,
		integer	islen20t,
		integer	irlen20e,
		integer	islen20e,
		integer, dimension(*)	irbe3,
		integer, dimension(*)	lrbe3,
			frbe3,
		integer, dimension(*)	fr_i2m,
		integer, dimension(*)	iad_i2m,
		integer, dimension(*)	fr_rbe3m,
		integer, dimension(*)	iad_rbe3m,
		double precision, dimension(*)	frwl6,
		integer, dimension(*)	irbe2,
		integer, dimension(*)	lrbe2,
		type(intbuf_struct_)	intbuf_tab_c,
		integer, dimension(*)	ikine,
			diag_sms,
		integer, dimension(*)	icfield,
		integer, dimension(*)	lcfield,
			cfield,
		integer, dimension(*)	count_remslv,
		integer, dimension(*)	count_remslve,
		type (elbuf_struct_), dimension(ngroup)	elbuf_tab,
		type (elbuf_struct_), dimension(ngroup)	elbuf_imp,
		double precision, dimension(3,*)	xdp,
		integer, dimension(*)	weight_md,
		type (stack_ply)	stack,
		integer	dimfb,
		double precision, dimension(12,6,dimfb)	fbsav6,
		integer	stabsen,
		integer, dimension(*)	tabsensor,
		type (drape_), dimension(numelc_drape)	drape_sh4n,
		type (drape_), dimension(numeltg_drape)	drape_sh3n,
		type(h3d_database)	h3d_data,
		type(multi_fvm_struct), intent(inout)	multi_fvm,
		type (group_), dimension(ngrbric)	igrbric,
		type (group_), dimension(ngrshel)	igrsh4n,
		type (group_), dimension(ngrsh3n)	igrsh3n,
		type (group_), dimension(ngrbeam)	igrbeam,
			forneqs,
			maxdgap,
		integer	nddl0,
		integer	nnzk0,
		integer	it_t,
		type (impbuf_struct_), target	impbuf_tab,
		integer	cptreac,
			fthreac,
		integer, dimension(*)	nodreac,
		type (drapeg_)	drapeg,
		type (interfaces_), intent(in)	interfaces,
		type (th_surf_), intent(inout)	th_surf,
		dimension(6,nconld), intent(in)	dpl0cld,
		dimension(6,nconld), intent(in)	vel0cld,
		integer, intent(in)	snpc,
		integer, intent(in)	stf,
		type (glob_therm_), intent(inout)	glob_therm,
		double precision, intent(inout)	wfext_md )

Definition at line 146 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE output_mod
        USE timer_mod
        USE dsgraph_mod
        USE imp_lintf
        USE imp_worki
        USE imp_pcg_proj
        USE message_mod
        USE elbufdef_mod
        USE intbufdef_mod
        USE stack_mod
        USE h3d_mod
        USE multi_fvm_mod
        USE groupdef_mod
        USE drape_mod
        USE impbufdef_mod
        USE sensor_mod
        USE interfaces_mod
        USE th_surf_mod , ONLY : th_surf_
        USE skew_mod
        use glob_therm_mod
        use python_funct_mod, only: python_
        use element_mod , only : nixs,nixq,nixc,nixt,nixp,nixr,nixtg
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "comlock.inc"
#if defined(MUMPS5)
#include      "dmumps_struc.h"
#endif
#include      "param_c.inc"
#include      "com01_c.inc"
#include      "com04_c.inc"
#include      "com08_c.inc"
#include      "impl1_c.inc"
#include      "impl2_c.inc"
#include      "scr03_c.inc"
#include      "scr06_c.inc"
#include      "scr16_c.inc"
#include      "timeri_c.inc"
#include      "units_c.inc"
#include      "task_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        TYPE (OUTPUT_) , INTENT(INOUT) :: OUTPUT
        TYPE(TIMER_) :: TIMERS
        TYPE(PYTHON_) :: PYTHON
        INTEGER ,INTENT(IN) :: NSENSOR
        INTEGER ,INTENT(IN) :: SNPC
        INTEGER ,INTENT(IN) :: STF
        INTEGER ITASK,ICODE(*), ISKEW(*), ISKWN(LISKN,*),ITABM1(*),
     .     IPART(*),IXS(*),IXQ(NIXQ,*),IXC(NIXC,*), IXT(NIXT,*),
     .     IXP(NIXP,*),IXR(NIXR,*), IXTG(NIXTG,*), IXTG1(4,*),
     .     ITAB(*),NPC(*), IBCL(*), IBFV(*),IPARG(NPARG,*),IPARI(NPARI,*),
     .     NPRW(*), NPBY(NNPBY,*), LPBY(*),IADS_F(*),
     .     LRIVET(*), NSTRF(*), LJOINT(*), ICODT(*), ICODR(*), ILINK(*),
     .     LLINK(*),ISKY(*),ADSKY(*),
     .     NNLINK(10,*),LNLINK(*),IGRV(*),IKINE(*),
     .     WEIGHT(*),IFRAME(LISKN,*),IBVEL(NBVELP,*),LBVEL(*),
     .     IACTIV(*),IGEO(*),IPM(*),ICONX(*),NODFT  ,NODLT,IT,
     .     WEIGHT_MD(*),DIMFB,STABSEN,TABSENSOR(*),CPTREAC,NODREAC(*)
        INTEGER LPRW(*), FR_WALL(NSPMD+2,*),FR_ELEM(*),
     .     IAD_ELEM(2,*),NBINTC ,INTLIST(*), IPIV_K(*), NKCOND,
     .     NODGLOB(*), CDDLP(*),LGRAV(*)
        INTEGER NDDL0,NNZK0,IT_T,MONVOL(*),FR_MV(*),
     .          DIRUL(*),SH4TREE(*), SH3TREE(*),
     .          FR_I2M(*),IAD_I2M(*),FR_RBE3M(*),IAD_RBE3M(*),
     .          ICFIELD(*),LCFIELD(*),COUNT_REMSLV(*),COUNT_REMSLVE(*)
        my_real
     .     x(3,*)    ,d(3,*)      ,v(3,*)   ,vr(3,*),damp(*),
     .     ms(*)   ,in(*)   ,pm(npropm,*),geo(npropg,*),
     .     bufmat(*) ,tf(*) ,forc(*)  ,vel(*),fsav(nthvki,*) ,elbuf(*) ,
     .     rwbuf(nrwlp,*),rwsav(*),rby(nrby,*),
     .     rivet(*),wa(*), a(3,*) ,ar(3,*),partsav(*) ,
     .     stifn(*) ,stifr(*),fsky(*),fskyi(*),dr(3,*),
     .     eani(*),agrv(*), thke(*),fr_wave(*),parts0(*),bufgeo(*),
     .     xframe(nxframe,*),w16(*),fbvel(*),fskym(*),bufsf(*),
     .     fopt(6,*),fsavd(nthvki,*), fac_k(*), diag_sms(*),
     .     cfield(*),forneqs(*),maxdgap(ninter),fthreac(6,*)
        INTEGER  NUM_IMP(*),NS_IMP(*),NE_IMP(*),IND_IMP(*),NINT7
        INTEGER NEWFRONT(*),ISENDTO(*),IRECVFROM(*),IMSCH  ,
     .          I2MSCH ,ISIZXV,ILENXV ,ISLEN7  ,IRLEN7 ,ISLEN11,IRLEN11,
     .          ISLEN17,IRLEN17,IRLEN7T,ISLEN7T,
     .          IRLEN20,ISLEN20,IRLEN20T,ISLEN20T,IRLEN20E,ISLEN20E,
     .          KINET(*),NUM_IMP1(*),IRBE3(*),LRBE3(*),IRBE2(*),LRBE2(*)
      my_real, INTENT(IN) :: dpl0cld(6,nconld),vel0cld(6,nconld)
        my_real dt2prev,volmon(*) ,temp(*), waint(*),frbe3(*)
        TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP) :: ELBUF_TAB, ELBUF_IMP
        DOUBLE PRECISION FRWL6(*), XDP(3,*)
        DOUBLE PRECISION FBSAV6(12,6,DIMFB)
C
        TYPE(PRGRAPH) :: GRAPHE(*)
C
#ifdef MUMPS5
      TYPE(DMUMPS_STRUC) MUMPS_PAR
#else
      ! Fake declaration as DMUMPS_STRUC is shipped with MUMPS
      INTEGER MUMPS_PAR
#endif
        TYPE(INTBUF_STRUCT_) INTBUF_TAB(*), INTBUF_TAB_C
        TYPE (STACK_PLY) :: STACK
        TYPE(H3D_DATABASE) :: H3D_DATA
        TYPE(MULTI_FVM_STRUCT), INTENT(INOUT) :: MULTI_FVM
!
        TYPE (GROUP_)  , DIMENSION(NGRBRIC) :: IGRBRIC
        TYPE (GROUP_)  , DIMENSION(NGRSHEL) :: IGRSH4N
        TYPE (GROUP_)  , DIMENSION(NGRSH3N) :: IGRSH3N
        TYPE (GROUP_)  , DIMENSION(NGRBEAM) :: IGRBEAM
        TYPE (GROUP_)  , DIMENSION(NSURF)   :: IGRSURF
        TYPE (DRAPE_)   :: DRAPE_SH4N(NUMELC_DRAPE), DRAPE_SH3N(NUMELTG_DRAPE)
        TYPE (IMPBUF_STRUCT_) ,TARGET :: IMPBUF_TAB
        TYPE (SENSOR_STR_) ,DIMENSION(NSENSOR) :: SENSOR_TAB
        TYPE (DRAPEG_)   :: DRAPEG
        TYPE (INTERFACES_)    ,INTENT(IN)     :: INTERFACES
        TYPE (TH_SURF_) , INTENT(INOUT) :: TH_SURF
        TYPE(SKEW_),INTENT(INOUT) :: SKEWS
        type (glob_therm_) , INTENT(INOUT) :: GLOB_THERM
        DOUBLE PRECISION,INTENT(INOUT) :: WFEXT, WFEXT_MD
C
C---D_IMP: dUn+1,i,DD : ddU,i+1
C---R_IMP[1:R02,2:RRR(R_OLD),3:RU0,4:E02,5:DE_OLD,6:EIMP,7,8,9:for line-search]
C---R_IMP[10: BFAC,DTFAC,11:U2,12:RFAC,13:|FEXT|;14,16:new line-search;17:actual R02;18:GAP;19:TSTART;
C---R_IMP[21:rel res disp.,22:relative residual \1,23:relative residual \1,24:cumulative arc length]
C---------20-25:libre
C---I_IMP[1:IT(TOTAL),2:ITC,3:IT0(IT_OLD),4:IWAIT,5:IDIV,6:NDDLI0,7:1ercontact(used only w/ IREFI=4),
C---8:num. of diverging, 9:ICONT_OLD 10:Isign (Riks);11: Ichang(solver);12: IDIV_OLD;13: NDDLI(SMP) or NDDLI_G(SPMD)
#if defined(MUMPS5)
C----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER  NNMAX,NKMAX,N_IMPN,N_IMPM,LNSS,LNSS2,NDT,NDS,NT_RW
        INTEGER I,J,NTMP,L1,L2,L3,NNDL,INPRINT,ISTOP,LI10,LI11,
     .          LI1,LI2,LI3,LI4,LI5,LI6,LI7,LI8,LI9,LIF,IC,ISETP,
     .          LI12,NDDL_INI0,LI13,LI14,LI15,LNSS3,LNSB2,LNSRB2
        INTEGER, DIMENSION(:),ALLOCATABLE :: IADI0,JDII0
C
        INTEGER, DIMENSION(:),ALLOCATABLE :: NSS,ISS,NSS2,ISS2,NSS3,ISS3
        INTEGER, DIMENSION(:),ALLOCATABLE :: NSB2,ISB2,IAINT2
C      ---INEGA is defined now in impl1_c.inc---
        INTEGER  NNOD,IFDIS,NODFTSK ,NODLTSK,N1,N2,N3
C
        INTEGER LBAND,NCL_MAX,IRFLAG,IPRINT0,IPRJ_S
C
        INTEGER IBID,IFIF,F_DDL,L_DDL,NSPC_OLD,NSPC,NFXV_G
C
        my_real rbid,efac,lbb(nddl0),dummy_fext(3,1)
        my_real tfexc,tmp,tmp1,tmp2,r2,bfac,faci,r02,gap,bid,we_imp
        my_real,DIMENSION(:),ALLOCATABLE :: diag_i0,lt_i0
C
        INTEGER, POINTER     :: NDDL,NNZK,NRBYAC,NINT2,NMC,NMC2,NMONV
        INTEGER, DIMENSION(:) ,POINTER     :: IADK,JDIK,IADM,JDIM
        INTEGER, DIMENSION(:) ,POINTER     :: IDDL,NDOF,INLOC,LSIZE,I_IMP,IKC,
     .                                        IRBYAC,NSC,IINT2,NKUD,IMONV,
     .                                        IKINW,W_DDL,IKUDN,NDOFI,IDDLI,IKUD
        my_real, DIMENSION(:) ,POINTER     :: diag_k,lt_k,diag_m,lt_m,lb,
     .                                        lb0,bkud,d_imp,elbuf_c,bufmat_c,
     .                                        dr_imp,x_c,dd,ddr,x_a,r_imp
        my_real, DIMENSION(:) ,POINTER     :: fext,dg,dgr,dg0,dgr0,bufin_c,ac,acr
c sb
        character*1 anew_stif
 
C-----------------------------------------------
        anew_stif = ' '
        dummy_fext = zero
        rbid = zero
c
C-----------------------------------------------
C---IMCONV : 0 iteration; 1 converge; -1 line-search, -2 change dt during iteration-----
C---         -3 only reset iteration with Dn-1=0-----
C-----------------------------------------------
        nddl => impbuf_tab%NDDL
        nnzk => impbuf_tab%NNZK
        nrbyac => impbuf_tab%NRBYAC
        nint2 => impbuf_tab%NINT2
        nmc => impbuf_tab%NMC
        nmc2 => impbuf_tab%NMC2
        nmonv => impbuf_tab%NMONV
        iadk => impbuf_tab%IADK
        jdik => impbuf_tab%JDIK
        iadm => impbuf_tab%IADM
        jdim => impbuf_tab%JDIM
        iddl => impbuf_tab%IDDL
        ndof => impbuf_tab%NDOF
        inloc => impbuf_tab%INLOC
        lsize => impbuf_tab%LSIZE
        i_imp => impbuf_tab%I_IMP
        irbyac => impbuf_tab%IRBYAC
        nsc => impbuf_tab%NSC
        iint2 => impbuf_tab%IINT2
        nkud => impbuf_tab%NKUD
        imonv => impbuf_tab%IMONV
        ikinw => impbuf_tab%IKINW
        ikc => impbuf_tab%IKC
        w_ddl => impbuf_tab%W_DDL
        ikud => impbuf_tab%IKUD
        ndofi=> impbuf_tab%NDOFI
        iddli=> impbuf_tab%IDDLI
C
        diag_k  =>impbuf_tab%DIAG_K
        lt_k    =>impbuf_tab%LT_K
        diag_m  =>impbuf_tab%DIAG_M
        lt_m    =>impbuf_tab%LT_M
        lb      =>impbuf_tab%LB
        lb0     =>impbuf_tab%LB0
        bkud    =>impbuf_tab%BKUD
        d_imp   =>impbuf_tab%D_IMP
        dr_imp  =>impbuf_tab%DR_IMP
        elbuf_c =>impbuf_tab%ELBUF_C
        bufmat_c=>impbuf_tab%BUFMAT_C
        x_c     =>impbuf_tab%X_C
        x_a     =>impbuf_tab%X_A
        dd      =>impbuf_tab%DD
        ddr     =>impbuf_tab%DDR
        fext  =>impbuf_tab%FEXT
        dg    =>impbuf_tab%DG
        dgr   =>impbuf_tab%DGR
        dg0   =>impbuf_tab%DG0
        dgr0  =>impbuf_tab%DGR0
        ac=>impbuf_tab%AC
        acr=>impbuf_tab%ACR
        r_imp => impbuf_tab%R_IMP
        ALLOCATE(iaint2(nint2))
C--------explicite iteration only-------------
C-------smp // first for IMP_GLOB_K, PCG solver, Nonlinear drivers,
        ndt=nexp
        IF (i_imp(4)>0) THEN
          CALL integrator_hp(ndt  ,d_imp ,dr_imp,
     1                       x     ,v     ,vr    ,a     ,ar    )
C    /---------------/
          i_imp(4)=i_imp(4)-1
          IF (imconv==1) imconv=2
          RETURN
        ENDIF
C------------------------------
C        Initialization
C------------------------------
        iprint0=0
        IF (ispmd==0) THEN
          IF(ncycle==1.AND.imconv==1.AND.i_imp(5)==0) iprint0=1
          IF (iline/=1) inprint=nprint
        ELSE
          inprint=0
        ENDIF
C
        IF (irref>0.AND.imconv==1.AND.iline/=1) THEN
          irflag=irref
        ELSE
          irflag=0
        ENDIF
C
        isetp=isetk
        nddli=0
        nddli_g=0
        IF (nint7==0) THEN
          DO i=1,numnod
            ndofi(i)=0
          ENDDO
        ENDIF
        istop=0
        IF (imconv==2) imconv=1
        nndl = 3*numnod
C
        nsrem=0
        nsl=0
        iconta = 0
C
        we_imp = wfext
        IF (imconv==1) THEN
          iter_nl=0
        ELSE
          iter_nl=it+1
        END IF
        IF(ncycle==1.AND.imconv==1.AND.i_imp(5)==0) THEN
          r_imp(19)=tt-dt2
C---------for interface sorting
          IF(ninter>0) CALL ini_bminma_imp(intbuf_tab)
        END IF
c
C-----------------------------
        IF (imconv==3) CALL cp_real_hp(nndl,x_c,x)
        nfxv_g = nfxvel
        IF (nspmd>1) CALL spmd_max_i(nfxv_g)
C
        IF (ilintf>0) THEN
          ALLOCATE(xi_c(nndl))
          IF (ncycle==1) THEN
            CALL cp_impbuf(
     .           1      ,elbuf,elbuf_c,bufmat ,bufmat_c,
     .                     fsav  ,volmon  ,partsav ,intbuf_tab       ,
     .                     intbuf_tab_c,ipari   ,islen7 ,irlen7   ,
     .                     islen11,irlen11,islen17 ,irlen17,irlen7t  ,
     .                     islen7t,irlen20,islen20 ,irlen20t,islen20t,
     .           irlen20e,islen20e,newfront,elbuf_tab,elbuf_imp,
     .           iparg   )
            CALL cp_real_hp(nndl,x,x_c)
            CALL imp_setb(a ,ar ,iddl ,ndof ,lb0  )
            CALL ini_kif
            i_imp(2)=lprint
            lprint = 0
            CALL cp_real_hp(nndl,x,xi_c)
          ELSE
            CALL cp_impbuf(
     .           2     ,elbuf,elbuf_c,bufmat ,bufmat_c,
     .                     fsav  ,volmon  ,partsav ,intbuf_tab       ,
     .                     intbuf_tab_c,ipari   ,islen7 ,irlen7   ,
     .                     islen11,irlen11,islen17 ,irlen17,irlen7t  ,
     .                     islen7t,irlen20,islen20 ,irlen20t,islen20t,
     .           irlen20e,islen20e,newfront,elbuf_tab,elbuf_imp,
     .           iparg   )
            CALL cp_real_hp(nndl,x_c,x)
            CALL cp_real_hp(nndl,x_c,xi_c)
            CALL integrator1_hp(d_imp ,xi_c )
            CALL imp_b2a(a ,ar ,iddl ,ndof ,lb0  )
            IF (ncycle==ilintf) THEN
              lprint = i_imp(2)
            ELSE
              lprint = 0
            ENDIF
C----------otherwise, X_A is accumulated---
            CALL cp_real_hp(nndl,x,x_a)
          ENDIF
        ENDIF
C
        IF (imconv==1 ) THEN
          r_imp(16)=zero
C          R_IMP(6)=ZERO
C---------initialise D,DD-----
          IF (ncycle>1.AND.iline/=1) THEN
C-----------------Dn,0=Dn-1--------
c              CALL CP_REAL(NNDL,D_IMP,DD)
c              IF (IRODDL/=0) CALL CP_REAL(NNDL,DR_IMP,DDR)
C----------for the case where the run diverges due to the first contact(Gravity)->
C----------use reduced Dn_1 instead of resolution:
            CALL du_ini_hp(d_imp  ,dr_imp,dd    ,
     1                     ddr   ,i_imp(5),i_imp(7))
          ENDIF
          CALL zeror_hp(d_imp,numnod)
          IF (iroddl/=0) CALL zeror_hp(dr_imp,numnod)
C         also allows linear with 'initial state'
          CALL zeror_hp(ac,numnod)
          IF (iroddl/=0) CALL zeror_hp(acr,numnod)
C
          IF (isigini==1.AND.ncycle==1) THEN
            CALL imp_setb(a ,ar ,iddl ,ndof ,lb0  )
          ENDIF
C
          IF (ncycle==1.AND.idyna>0)
     .       CALL dyna_ina(ibcl       ,forc     ,snpc            ,npc     ,tf     ,a   ,
     2                     v          ,x        ,skews           ,ar      ,vr     ,
     3                     sensor_tab ,weight   ,tfexc           ,iads_f  ,
     4                     fsky       ,igrv     ,agrv            ,ms      ,in     ,
     5                     lgrav      ,itask    ,nrbyac          ,irbyac  ,npby   ,
     6                     rby        ,fr_elem  ,iad_elem        ,nddl0   ,nnzk0  ,
     7                     i_imp(5)   ,h3d_data ,cptreac         ,fthreac ,nodreac,
     8                     nsensor    ,th_surf  ,dpl0cld ,
     9                     vel0cld    ,d        ,dr              ,numnod  ,nsurf  ,
     a                     nfunct     ,nconld   ,ngrav           ,ninvel  ,stf    ,numskw,
     b                     wfext,python)
C
C----------------------------------
C       EXTERNAL FORCES A=Fext-Fint
C----------------------------------
C
          ncl_max=0
          IF(nconld/=0) THEN
            IF (imon>0) CALL startime(timers,4)
C         --spmd : force treated like elements ---
            CALL force_imp( ibcl    ,forc       ,snpc       ,npc        ,tf         ,
     2                      ac      ,v          ,x          ,skews      ,
     3                      acr     ,vr         ,nsensor    ,sensor_tab ,tfexc      ,
     4                      iads_f  ,fsky       ,dummy_fext ,h3d_data   ,cptreac    ,
     5                      fthreac ,nodreac    ,th_surf    ,
     6                      dpl0cld ,vel0cld    ,d          ,dr         ,nconld     ,
     7                      numnod  ,nfunct     ,stf        ,wfext)
C
            IF (nspmd>1) THEN
              DO i=iad_elem(1,1),iad_elem(1,nspmd+1)-1
                j = fr_elem(i)
                n1 = 3*(j-1)+1
                n2 = 3*(j-1)+2
                n3 = 3*(j-1)+3
                tmp = abs(ac(n1))+abs(ac(n2))+abs(ac(n3))
                IF (iroddl/=0) tmp = tmp + abs(acr(n1))+abs(acr(n2))+abs(acr(n3))
                IF (tmp>zero) ncl_max = ncl_max + 1
              ENDDO
            ENDIF
C
            IF (imon>0) CALL stoptime(timers,4)
          ENDIF
C
          IF (nspmd>1) THEN
            CALL spmd_max_i(ncl_max)
            IF (ncl_max>0) THEN
              lband = iad_elem(1,nspmd+1)-iad_elem(1,1)
              IF (iroddl/=0) THEN
                ntmp = 6
              ELSE
                ntmp = 3
              ENDIF
              CALL spmd_sumf_a(ac,acr,iad_elem,fr_elem,ntmp,lband)
            ENDIF
          ENDIF
C---------no //SMP for the moment, add it after----
          IF(ngrav/=0) THEN
            IF (imon>0) CALL startime(timers,4)
            CALL gravit_imp(igrv  ,agrv  ,npc   ,tf    ,ac,
     2                      v     ,x     ,skews%SKEW  ,ms,tfexc,
     3                      nsensor,sensor_tab,weight,
     4                      lgrav ,itask,
     5                      nrbyac,irbyac,npby  ,rby, python)
            IF (imon>0) CALL stoptime(timers,4)
          ENDIF
C---------no //SMP for the moment, add it after----
          IF(nloadc/=0) THEN
            IF (imon>0) CALL startime(timers,4)
            CALL cfield_imp(icfield  ,cfield,npc   ,tf    ,ac,
     2                      v     ,x     ,xframe  ,ms,tfexc,
     3                      nsensor,sensor_tab,weight,iframe,
     4                      lcfield ,itask,
     5                      nrbyac,irbyac,npby  ,rby,iskew,python   )
            IF (imon>0) CALL stoptime(timers,4)
          ENDIF
 
 
          wfext = we_imp
C END IF (IMCONV==1)
        ENDIF
C-------------dU_d---------------------------------
        IF(nfxvel/=0.AND.(imconv==1.OR.imconv==3)) THEN
          IF (imon>0) CALL startime(timers,4)
          CALL fv_imp(ibfv  ,npc    ,tf     ,vel   ,sensor_tab,
     1                d_imp  ,dr_imp ,ikc   ,iddl  ,nsensor   ,
     2                skews%SKEW  ,iframe ,xframe ,v     ,vr    ,
     3                x     ,dirul  ,ndof   ,a     ,ar    )
          IF (imon>0) CALL stoptime(timers,4)
        ENDIF
C------------- rgwal0_imp can follow-aSetk = 1, but you have to change-fv_imp1
C-------------(IKC(I)=4->IMCONV=1 to avoid rebound-------
        nt_rw=0
        IF (nrwall>0) THEN
          IF (imon>0) CALL startime(timers,4)
          DO i=1,nddl0
            IF (ikc(i)==3.OR.ikc(i)==10) ikc(i)=0
          ENDDO
          IF (imconv==1) THEN
            DO i=1,nddl0
              IF (ikc(i)==4.OR.ikc(i)==11) ikc(i)=0
            ENDDO
          ENDIF
 
          IF (ismdisp > 0 .AND. iline == 0) THEN
            CALL rgwal0_imp(
     1       x_a         ,d_imp    ,v               ,rwbuf            ,lprw    ,
     2       nprw        ,ms       ,fsav(1,ninter+1),fr_wall          ,
     3       fopt        ,rwsav    ,weight          ,fsavd(1,ninter+1),
     4       nt_rw       ,iddl     ,ikc             ,imconv           ,ndof     , frwl6,
     5       weight_md   ,dimfb    ,fbsav6          ,stabsen          ,tabsensor, wfext, wfext_md)
          ELSE
            CALL rgwal0_imp(
     1       x           ,d_imp    ,v               ,rwbuf            ,lprw     ,
     2       nprw        ,ms       ,fsav(1,ninter+1),fr_wall          ,
     3       fopt        ,rwsav    ,weight          ,fsavd(1,ninter+1),
     4       nt_rw       ,iddl     ,ikc             ,imconv           ,ndof     , frwl6,
     5       weight_md   ,dimfb    ,fbsav6          ,stabsen          ,tabsensor, wfext, wfext_md)
          ENDIF
C
          IF(nt_rw>0) THEN
            CALL fv_rw(iddl   ,ikc   ,ndof  ,d_imp  ,v )
          ENDIF
          IF (imon>0) CALL stoptime(timers,4)
        ENDIF
C
        ifdis=nt_rw+nfxv_g
        IF(ifdis>0.AND.imconv==1) THEN
          IF (ncycle>1.AND.iline/=1)
C--------------Dn,0=Dn-1--------
     .    CALL fv_dd0(iddl   ,ikc   ,ndof  ,dd  ,ddr ,d_imp)
          IF(nt_rw>0) THEN
            DO i=1,nddl0
              IF (ikc(i)==3) ikc(i)=4
C
              IF (ikc(i)==10) ikc(i)=11
            ENDDO
          ENDIF
        ENDIF
C
        irwall = nt_rw
        IF (nspmd>1) CALL spmd_max_i(irwall)
C-------!!!should stop line-search if Rwall activates!!!
        IF(irwall>0.AND.imconv>=0) THEN
          IF(ispmd==0) THEN
            WRITE(iout,*)'  *--------- RIGID WALL IMPACT---------*'
            WRITE(istdo,*)'  *--------- RIGID WALL IMPACT---------*'
          ENDIF
          isetk = 1
        ENDIF
C
C----------------------------------
C       LB=Fext ;
C----------------------------------
C---------
        CALL imp_setb(ac    ,acr     ,iddl   ,ndof  ,lb    )
C-----------------------
citask0        END IF !(ITASK == 0) THEN
C----------------------
c      CALL MY_BARRIER
C---------------------
C-----------------------
        IF (isolv==5.OR.isolv==6.AND.imconv>=0) THEN
          IF (idsc==0) THEN
C-----------one update per increment
            IF (ipupd==0.AND.i_imp(2)==0.AND.it==0) THEN
              idsc=max(idsc,isetk)
            ENDIF
C-----------NDDL could be changed by RWALL impact
            IF(irwall > 0 ) idsc = 1
          ENDIF
        ELSE
          idsc=max(idsc,isetk)
        END IF
C    /---------------/
c      CALL MY_BARRIER
C    /---------------/
C----------------------------------
C       STIFFNESS MATRIX
C----------------------------------
        IF (isetk ==1 ) THEN
          IF (imon>0 .AND. itask ==0) CALL startime(timers,31)
          l1 = 1+nixs*numels
          l2 = l1+6*numels10
          l3 = l2+12*numels20
C----------------------------------
Citask0         IF (ITASK == 0) THEN
C----------------------------------
          nddl = nddl0
          nnzk = nnzk0
          nnmax=lsize(9)
          nkmax=lsize(10)
          nmc2=lsize(11)
          CALL zero1(diag_k,nddl)
          CALL zero1(lt_k,nnzk)
          li1 =1
          li2 = li1+lsize(4)
          li3 = li2+lsize(5)
          li4 = li3+lsize(1)
          li5 = li4+lsize(3)
          li6 = li5+lsize(7)
          li7 = li6+lsize(2)
          li8 = li7+lsize(6)
          li9 = li8+nint2
          li10 = li9+lsize(8)
C
          li11 = li10+(lsize(8)-lcokm)*lsize(9)
          li12 = li11+lcokm*lsize(10)
          li13 = li12+4*lsize(11)
          li14 = li13+lsize(14)
          li15 = li14+lsize(15)
          lif = li15+lsize(16)
C--------- Caution if Rigid Body Reactive (deactive) during a restart it is necessary to revive also DIM
          IF (iline/=1) THEN
            ntmp=0
            IF (i_imp(11)==1) THEN
              ntmp=1
              i_imp(11)=-1
            ENDIF
            CALL ind_glob_k(npby  ,lpby      ,
     1      itab      ,nrbyac    ,irbyac    ,nsc       ,ikinw(li1),
     2      nmc       ,ikinw(li2),ikinw(li3),ikinw(li4),nint2     ,
     3      iint2     ,ipari     ,intbuf_tab,ikinw(li8),ikinw(li5),
     4      ikinw(li6),ikinw(li7),iparg     ,elbuf     ,elbuf_tab ,
     5      ixs       ,ixq       ,ixc       ,ixt       ,ixp       ,
     6      ixr       ,ixtg      ,ixtg1     ,ixs(l1)   ,ixs(l2)   ,
     7      ixs(l3)   ,iddl      ,ndof      ,iadk      ,
     8      jdik      ,nddl      ,nnzk      ,nnmax     ,lsize(8)  ,
     9      inloc     ,nkmax     ,ikinw(li9),ikinw(li10),ikinw(li11),
     a      nmc2      ,ikinw(li12),ntmp     ,lsize(12) ,lsize(13) ,
     b      fr_elem   ,iad_elem  ,ipm       ,igeo      ,irbe3     ,
     c      lrbe3     ,ikinw(li13),fr_i2m   ,iad_i2m   ,fr_rbe3m  ,
     d      iad_rbe3m ,irbe2     ,lrbe2     ,ikinw(li14),ikinw(li15))
C-------------important is no buffer overflow
C           NDDL0 = NDDL
C           NNZK0 = NNZK
          ENDIF
C----------------------------------
citask0         END IF !IF (ITASK == 0) THEN
C----------------------------------
C    /---------------/
c      CALL MY_BARRIER
C    /---------------/
c          NGDONE = 1
          CALL imp_glob_khp(
     1     pm        ,geo       ,ipm       ,igeo      ,elbuf     ,
     2     ixs       ,ixq       ,ixc       ,ixt       ,ixp       ,
     3     ixr       ,ixtg      ,ixtg1     ,ixs(l1)   ,
     4     ixs(l2)   ,ixs(l3)   ,iparg     ,tf        ,npc       ,
     5     fr_wave   ,w16       ,bufmat    ,thke      ,bufgeo    ,
     6     rby       ,skews%SKEW      ,x         ,
     7     wa        ,iddl      ,ndof      ,diag_k    ,lt_k      ,
     8     iadk      ,jdik      ,ikg       ,ibid      ,itask     ,
     9     elbuf_tab ,stack     ,drape_sh4n, drape_sh3n   ,drapeg )
C
C    /---------------/
c      CALL MY_BARRIER
C    /---------------/
          nddl_l = nddl
C-----------------------------
citask0       IF (ITASK == 0) THEN
C-----------------------------
          IF (idyna>0.AND.idy_damp>0) THEN
            CALL dyna_cpk0(nddl  ,nnzk  ,iadk  ,jdik   ,diag_k ,
     .                     lt_k  )
          END IF
C-------estimation of A(t+dt) w/ initial velocity----
          IF (ncycle==1.AND.imconv==1.AND.i_imp(5)==0
     .        .AND.idyna>0.AND.ninvel>0) THEN
            CALL imp_dykv0(nodft  ,nodlt   ,iddl   ,ndof   ,ikc    ,
     .                     diag_k ,iadk    ,jdik   ,lt_k   ,weight ,
     1                     rby    ,x       ,skews%SKEW   ,lpby   ,npby   ,
     2                     nrbyac ,irbyac  ,nint2  ,iint2  ,ipari  ,
     3                     intbuf_tab      ,irbe3  ,lrbe3  ,frbe3  ,
     4                     irbe2  ,lrbe2   ,v      ,vr     ,nddl0  ,
     5                     fr_elem,iad_elem,ms     ,in     )
          END IF
          IF (idyna>0.OR.iqstat>0)
     .     CALL imp_dynam(nodft  ,nodlt   ,iddl   ,ndof   ,diag_k ,
     .                    ms     ,in      ,hht_a  ,weight ,iadk   ,
     .                    lt_k   )
C
          IF (ikpres>0.AND.nbuck==0)
     1      CALL imp_kpres(ibcl  ,forc   ,npc   ,tf    ,x     ,
     2                     skews%SKEW  ,nsensor,sensor_tab,weight,iads_f,
     3                     iddl  ,ndof   ,iadk  ,jdik  ,diag_k,
     4                     lt_k  )
          IF(iautspc>0) THEN
            IF(ncycle==1.AND.imconv==1.AND.i_imp(5)==0) THEN
            ELSE
              CALL get_nspc(nspc_old)
              IF (nspmd > 1) CALL spmd_max_i(nspc_old)
            END IF
          ENDIF
          CALL upd_glob_k(
     1    icodt     ,icodr     ,iskew     ,ibfv      ,npc       ,
     2    tf        ,vel       ,xframe    ,
     3    rby       ,x         ,skews%SKEW      ,lpby      ,npby      ,
     4    itab      ,weight    ,ms        ,in        ,nrbyac    ,
     5    irbyac    ,nsc       ,ikinw(li1),nmc       ,ikinw(li2),
     6    ikinw(li3),ikinw(li4),nint2     ,iint2     ,ikinw(li8),
     7    ikinw(li5),ikinw(li6),ikinw(li7),ipari     ,intbuf_tab,
     8    nddl      ,nnzk      ,iadk      ,jdik      ,
     9    diag_k    ,lt_k      ,ndof      ,iddl      ,ikc       ,
     a    d_imp     ,lb        ,nkud      ,ikud      ,bkud      ,
     b    nmc2      ,ikinw(li12),nt_rw    ,dr_imp    ,dirul     ,
     c    irbe3     ,lrbe3     ,frbe3     ,ikinw(li13),irbe2    ,
     d    lrbe2     ,ikinw(li14),ikinw(li15))
C
          anew_stif = 'Y'
c
          IF (nspmd>1) THEN
            CALL upd_fr_k(
     1      iadk     ,jdik     ,ndof      ,ikc      ,iddl     ,
     2      inloc    ,fr_elem  ,iad_elem  ,nddl     )
C
            CALL weightddl(iddl  ,ndof  ,ikc  ,weight ,w_ddl  ,inloc )
          ENDIF
C--------case autospc---------
          IF(iautspc>0) THEN
            IF(ncycle==1.AND.imconv==1.AND.i_imp(5)==0) THEN
            ELSE
              CALL get_nspc(nspc)
              IF (nspmd > 1) CALL spmd_max_i(nspc)
              IF (nspc/=nspc_old) THEN
                imconv=-2
                IF (ispmd==0) THEN
                  WRITE(iout,1012)nspc_old,nspc
                  WRITE(istdo,1012)nspc_old,nspc
                ENDIF
                CALL put_nspc(nspc_old)
              ENDIF
            END IF
          ENDIF
C
          IF (n_pat>1) THEN
            CALL fil_span1(nrbyac,irbyac,npby,iddl,nddl,ikc,ndof,inloc)
          ENDIF
C
          IF(ncycle==1.AND.imconv==1.AND.i_imp(5)==0) THEN
C--------case mono-domain, Multi-domain NDDL_G is set inside PR_INFOK
            nddl_g = nddl
            CALL pr_infok(nddl0,nnzk0,nddl,nnzk,max(nnmax,nkmax))
C
            IF (iprec>4) THEN
              CALL k_band(nddl,iadk,jdik,ibid)
              maxb = min(maxb,ibid)
              IF (maxb>10000) THEN
                CALL m_lnz(nddl,iadk,jdik,maxb,max_l)
              ENDIF
            ENDIF
C
            ntmp = (tstop-tt)/dt2
            IF (ntmp>=2) THEN
              idsgap = 1
            ELSE
              idsgap = 0
            ENDIF
C
            IF (isolv==7) THEN
              CALL crit_llim(nddl,nnzk)
            END IF
C
            IF (nspmd == 1) THEN
              DO i=1,nddl
                w_ddl(i)=1
              ENDDO
            ENDIF
            IF (imconv/=-2)CALL ini_k0h(nddl,nnzk,nnzk,iadk,jdik)
C
          ENDIF
C
          IF (nint7<=0.AND.imconv==1.AND.nspmd==1)
     .     CALL imp_check(itab  ,nddl  ,iddl  ,diag_k  ,ndof  ,
     .                    ikc   ,inloc ,nddl0 )
C
          IF (imon>0) CALL stoptime(timers,31)
C
          IF (isolv==4.OR.isolv==6) THEN
            CALL arret(5)
          ENDIF
C-----------------------------
citask0         END IF !(ITASK == 0) THEN
C-----------------------------
c      CALL MY_BARRIER
C     ---------------
          IF (imconv==-2.AND.iline==0) THEN
            IF (nint7 > 0) nint7=0
            GOTO 100
          END IF
        ENDIF !IF (ISETK ==1 )
C-----------------------------
citask0       IF (ITASK == 0) THEN
C-----------------------------
        IF (iqstat>0) THEN
          CALL qstat_ini(nddl   ,inloc  ,iddl    ,ndof   ,ikc    ,
     .                   ms     ,in     )
        ENDIF
C----------------------------------
C       MATRICE DE RIGIDITE D'INTERFACE
C----------------------------------
        gap=ep20
        IF (nint7>0) THEN
          l1=lsize(1)
          l2=lsize(2)
          lnss2=0
          lnss=0
          IF (imon>0) CALL startime(timers,31)
          CALL sav_inttd(nint7,num_imp,ns_imp(1+nt_imp5),
     1                   ne_imp(1+nt_imp5),ind_imp,num_imp1)
C
          IF (imp_int==1) CALL idel_int(
     1    ipari     ,intbuf_tab,num_imp   ,ns_imp    ,ne_imp    ,
     2    ind_imp   ,ndof      ,nint7     )
C
          CALL dim_int_k(
     1    ipari     ,intbuf_tab,num_imp   ,ns_imp    ,ne_imp    ,
     2    npby      ,lpby      ,itab      ,nrbyac    ,irbyac    ,
     3    lnss      ,nint2     ,iint2     ,iaint2    ,lnss2     ,
     4    nddli     ,nnzi      ,iddli     ,ndofi     ,n_impn    ,
     5    n_impm    ,nnmax     ,nkmax     ,ndof      ,nsrem     ,
     6    irbe3     ,lrbe3     ,lnss3     ,irbe2     ,lrbe2     ,
     7    lnsb2     ,lnsrb2    ,ind_imp  )
          ALLOCATE(iadi0(nddli+1))
          ALLOCATE(itok(nddli))
          ALLOCATE(jdii0(nnzi))
          ALLOCATE(nss2(l2),nss3(nrbe3),nsb2(lnsrb2))
          nsb2=0
          ALLOCATE(iss2(lnss2),iss3(lnss3),isb2(lnsb2))
          ALLOCATE(nss(l1))
          ALLOCATE(iss(lnss))
C
          DO i=1,l1
            nss(i)=0
          ENDDO
C
          CALL ind_int_k(
     1    ipari     ,intbuf_tab,num_imp   ,ns_imp    ,ne_imp      ,
     2    npby      ,lpby      ,itab      ,nrbyac    ,irbyac      ,
     3    nss       ,iss       ,nint2     ,iint2     ,nss2        ,
     4    iss2      ,nddli     ,nnzi      ,iadi0     ,jdii0       ,
     5    iddli     ,ndofi     ,n_impn    ,itok      ,iddl        ,
     6    nnmax     ,nkmax     ,n_impm    ,ndof      ,iaint2      ,
     7    irbe3     ,lrbe3     ,nss3      ,iss3      ,irbe2       ,
     8    lrbe2     ,nsb2      ,isb2      ,ind_imp  )
          ALLOCATE(diag_i0(nddli))
          ALLOCATE(lt_i0(nnzi))
          CALL zero1(diag_i0,nddli)
          CALL zero1(lt_i0,nnzi)
C
          IF (nsrem>0) THEN
            CALL imp_fr7i(ipari ,intbuf_tab,num_imp ,ns_imp ,nsrem ,
     1                     nbintc,intlist)
            IF (intp_c>0)
     1      CALL ind_frkd(
     2      ipari     ,intbuf_tab,num_imp   ,ns_imp    ,ne_imp    ,
     3      iddli     ,ikc       ,ndof      ,nsrem     ,ind_imp  )
          ENDIF
C
          nddl_l = nddli
Ctmp-------A n'est pas modifie ici -------------------
          IF (ilintf>0) THEN
            CALL imp_int_k(a     ,v         ,
     1      icodt     ,icodr     ,iskew     ,ibfv      ,npc       ,
     2      tf        ,vel       ,nsensor   ,sensor_tab,xframe    ,
     3      rby       ,xi_c      ,skews%SKEW      ,lpby      ,npby      ,
     4      itab      ,weight    ,ms        ,in        ,nrbyac    ,
     5      irbyac    ,nss       ,iss       ,ipari     ,intbuf_tab,
     6      nint2     ,iint2     ,iaint2    ,nss2      ,
     7      iss2      ,nddli     ,nnzi      ,iadi0     ,jdii0     ,
     8      diag_i0   ,lt_i0     ,iddli     ,nddl0     ,iadk      ,
     9      jdik      ,ikc       ,diag_k    ,lt_k      ,iddl      ,
     a      num_imp   ,ns_imp    ,ne_imp    ,ind_imp   ,ndofi     ,
     b      itok      ,d_imp     ,lb        ,gap       ,dirul     ,
     c      nt_rw     ,num_imp1  ,irbe3     ,lrbe3     ,frbe3     ,
     d      nss3      ,iss3      ,irbe2     ,lrbe2     ,nsb2      ,
     e      isb2      )
          ELSEIF (ismdisp>0.AND.iline==0) THEN
            CALL imp_int_k(a     ,v         ,
     1      icodt     ,icodr     ,iskew     ,ibfv      ,npc       ,
     2      tf        ,vel       ,nsensor   ,sensor_tab,xframe    ,
     3      rby       ,x_a       ,skews%SKEW      ,lpby      ,npby      ,
     4      itab      ,weight    ,ms        ,in        ,nrbyac    ,
     5      irbyac    ,nss       ,iss       ,ipari     ,intbuf_tab,
     6      nint2     ,iint2     ,iaint2    ,nss2      ,
     7      iss2      ,nddli     ,nnzi      ,iadi0     ,jdii0     ,
     8      diag_i0   ,lt_i0     ,iddli     ,nddl0     ,iadk      ,
     9      jdik      ,ikc       ,diag_k    ,lt_k      ,iddl      ,
     a      num_imp   ,ns_imp    ,ne_imp    ,ind_imp   ,ndofi     ,
     b      itok      ,d_imp     ,lb        ,gap       ,dirul     ,
     c      nt_rw     ,num_imp1  ,irbe3     ,lrbe3     ,frbe3     ,
     d      nss3      ,iss3      ,irbe2     ,lrbe2     ,nsb2      ,
     e      isb2      )
          ELSE
            CALL imp_int_k(a     ,v         ,
     1      icodt     ,icodr     ,iskew     ,ibfv      ,npc       ,
     2      tf        ,vel       ,nsensor   ,sensor_tab,xframe    ,
     3      rby       ,x         ,skews%SKEW      ,lpby      ,npby      ,
     4      itab      ,weight    ,ms        ,in        ,nrbyac    ,
     5      irbyac    ,nss       ,iss       ,ipari     ,intbuf_tab,
     6      nint2     ,iint2     ,iaint2    ,nss2      ,
     7      iss2      ,nddli     ,nnzi      ,iadi0     ,jdii0     ,
     8      diag_i0    ,lt_i0    ,iddli     ,nddl0     ,iadk      ,
     9      jdik      ,ikc       ,diag_k    ,lt_k      ,iddl      ,
     a      num_imp   ,ns_imp    ,ne_imp    ,ind_imp   ,ndofi     ,
     b      itok      ,d_imp     ,lb        ,gap       ,dirul     ,
     c      nt_rw     ,num_imp1  ,irbe3     ,lrbe3     ,frbe3     ,
     d      nss3      ,iss3      ,irbe2     ,lrbe2     ,nsb2      ,
     e      isb2      )
          ENDIF
          IF (imon>0) CALL stoptime(timers,31)
C
          DEALLOCATE(nss2,nss3,nsb2)
          DEALLOCATE(iss2,iss3,isb2)
          DEALLOCATE(nss)
          DEALLOCATE(iss)
C
          IF (nddli>0) THEN
C
            ifif = 0
            IF (ilintf>0) THEN
              ifif = nddlif
              CALL save_kif(nddli ,iadi0 ,jdii0 ,diag_i0,lt_i0   ,
     1                      itok  ,nddl)
            ENDIF
            IF (ifif>0) THEN
              nddli = nddlif
              ALLOCATE(iadi(nddli+1))
              nnzi = iadif(nddli+1)-iadif(1)
              ALLOCATE(jdii(nnzi))
              DEALLOCATE(itok)
              ALLOCATE(itok(nddli))
              CALL cp_int_hp(nddli+1,iadif,iadi)
              CALL cp_int_hp(nddli,iftok,itok)
              CALL cp_int_hp(nnzi,jdiif,jdii)
              ALLOCATE(diag_i(nddli))
              ALLOCATE(lt_i(nnzi))
              CALL cp_real_hp(nddli,diag_if,diag_i)
              CALL cp_real_hp(nnzi,lt_if,lt_i)
            ELSE
C
              ALLOCATE(iadi(nddli+1))
              ALLOCATE(jdii(nnzi))
              CALL cp_int_hp(nddli+1,iadi0,iadi)
              CALL cp_int_hp(nnzi,jdii0,jdii)
              ALLOCATE(diag_i(nddli))
              ALLOCATE(lt_i(nnzi))
              CALL cp_real_hp(nddli,diag_i0,diag_i)
              CALL cp_real_hp(nnzi,lt_i0,lt_i)
C
            ENDIF
            DEALLOCATE(iadi0)
            DEALLOCATE(jdii0)
            DEALLOCATE(diag_i0)
            DEALLOCATE(lt_i0)
C
            IF (isolv==4.OR.isolv==6) THEN
              CALL arret(5)
            ENDIF
C
          ELSE
            ALLOCATE(iadi(1))
            ALLOCATE(jdii(1))
            DEALLOCATE(iadi0)
            DEALLOCATE(jdii0)
            ALLOCATE(diag_i(1))
            ALLOCATE(lt_i(1))
            DEALLOCATE(diag_i0)
            DEALLOCATE(lt_i0)
          ENDIF
C
C         Store the size of the contact stifness matrix for nonlinear solver outputs
          IF ((nspmd==1.OR.nbintc==0).AND.imconv>=0) i_imp(13) = nddli
          IF ((nspmd==1.OR.nbintc==0).AND.imconv>=0.AND.
     .         (lprint/=0.OR.nprint/=0)) THEN
            WRITE(iout,1006)
            WRITE(istdo,1006)
            WRITE(iout,1007)nddli,nnzi !,NNMAX
            WRITE(istdo,1007)nddli,nnzi !,NNMAX
c            WRITE(IOUT,*)
c            WRITE(ISTDO,*)
          ENDIF
        ENDIF
C----------------------------------
        IF (nfxvel/=0.AND.imconv==1) THEN
          CALL fv_imp1(nkud   ,ikud    ,bkud    ,lb    )
          CALL fvbc_impl1(ibfv   ,skews%SKEW  ,xframe ,dirul ,iddl   ,
     1                    ikc    ,ndof  ,d_imp  ,dr_imp,icodt  ,
     3                    icodr  ,iskew )
        ENDIF
C-------------initialization of Fext---for Riks-->approximation for follower load
C         IF (NCYCLE==1.AND.IDTC==3.AND.IMCONV==1.AND.
        IF (idtc==3.AND.imconv==1.AND.
     .      i_imp(5)==0) THEN
          CALL get_fext(nddl0 ,nddl   ,iddl   ,ndof   ,ikc   ,
     1                  inloc ,lb     ,fext   ,ac     ,acr   )
          r_imp(13) = tstop-tt+dt2
C             R_IMP(13) = SQRT(R2)
        END IF
        IF (idyna>0.AND.idy_damp>0) THEN
          CALL imp_dykv(nodft  ,nodlt   ,iddl   ,ndof   ,ikc    ,
     .                  diag_k ,iadk    ,jdik   ,lt_k   ,weight ,
     1                  rby    ,x       ,skews%SKEW   ,lpby   ,npby   ,
     2                  nrbyac ,irbyac  ,nint2  ,iint2  ,ipari  ,
     3                  intbuf_tab      ,irbe3  ,lrbe3  ,frbe3  ,
     4                  irbe2  ,lrbe2   ,v      ,vr     ,nddl0  ,
     5                  fr_elem,iad_elem,ms     ,in     )
        END IF
C------------- LB, A, AR becomes fext-fint ---------------------------------------------------------
 
        CALL upd_rhs(icodt ,icodr ,iskew ,ibfv    ,xframe ,
     1              rby   ,x     ,skews%SKEW   ,lpby   ,npby   ,
     2              nrbyac,irbyac,nint2  ,iint2  ,ipari  ,
     3              intbuf_tab   ,ndof   ,iddl   ,ikc    ,
     4              nddl0 ,lb    ,isetk  ,inloc  ,dirul  ,
     5              a     ,ar    ,ac     ,acr    ,nt_rw  ,
     6              irflag,w_ddl ,nddl   ,r_imp(1),idyna ,
     7              v     ,vr    ,ms     ,in     ,irbe3  ,
     8              lrbe3 ,frbe3 ,weight ,irbe2  ,lrbe2  )
C
        IF (nspmd>1) THEN
          iconta = nddli + nsrem
          CALL spmd_max_i(iconta)
          IF (nbintc>0.) THEN
            CALL spmd_min_s(gap)
            IF (iconta> 0.AND.gap>zero) THEN
C
              CALL spmd_max_i(ifdis)
              IF (ilintf>0) THEN
                CALL imp_intfr(
     1          num_imp   ,ns_imp    ,ne_imp    ,ipari     ,intbuf_tab,
     2          npby      ,lpby      ,itab      ,nrbyac    ,
     3          irbyac    ,nint2     ,iint2     ,iddl      ,ikc       ,
     4          ndof      ,inloc     ,nsrem     ,nsl       ,nbintc    ,
     5          intlist   ,xi_c      ,ibfv      ,dirul     ,skews%SKEW      ,
     6          xframe    ,iskew     ,icodt     ,r_imp(16) ,d_imp     ,
     7          lb        ,ifdis     ,nddl      ,dr_imp    ,iddli     ,
     8          irbe3     ,lrbe3     ,frbe3     ,irbe2     ,lrbe2     ,
     9          dd        ,ddr       ,a         ,ar        ,ac        ,
     a          acr       ,ms        ,v         ,nddl0     ,r_imp(1)  ,
     b          rby       ,icodr     ,nt_rw     ,w_ddl     ,weight    ,
     c          irflag    )
              ELSEIF (ismdisp>0.AND.iline==0) THEN
                CALL imp_intfr(
     1          num_imp   ,ns_imp    ,ne_imp    ,ipari     ,intbuf_tab,
     2          npby      ,lpby      ,itab      ,nrbyac    ,
     3          irbyac    ,nint2     ,iint2     ,iddl      ,ikc       ,
     4          ndof      ,inloc     ,nsrem     ,nsl       ,nbintc    ,
     5          intlist   ,x_a       ,ibfv      ,dirul     ,skews%SKEW      ,
     6          xframe    ,iskew     ,icodt     ,r_imp(16) ,d_imp     ,
     7          lb        ,ifdis     ,nddl      ,dr_imp    ,iddli     ,
     8          irbe3     ,lrbe3     ,frbe3     ,irbe2     ,lrbe2     ,
     9          dd        ,ddr       ,a         ,ar        ,ac        ,
     a          acr       ,ms        ,v         ,nddl0     ,r_imp(1)  ,
     b          rby       ,icodr     ,nt_rw     ,w_ddl     ,weight    ,
     c          irflag    )
              ELSE
                CALL imp_intfr(
     1          num_imp   ,ns_imp    ,ne_imp    ,ipari     ,intbuf_tab,
     2          npby      ,lpby      ,itab      ,nrbyac    ,
     3          irbyac    ,nint2     ,iint2     ,iddl      ,ikc       ,
     4          ndof      ,inloc     ,nsrem     ,nsl       ,nbintc    ,
     5          intlist   ,x         ,ibfv      ,dirul     ,skews%SKEW,
     6          xframe    ,iskew     ,icodt     ,r_imp(16) ,d_imp     ,
     7          lb        ,ifdis     ,nddl      ,dr_imp    ,iddli     ,
     8          irbe3     ,lrbe3     ,frbe3     ,irbe2     ,lrbe2     ,
     9          dd        ,ddr       ,a         ,ar        ,ac        ,
     a          acr       ,ms        ,v         ,nddl0     ,r_imp(1)  ,
     b          rby       ,icodr     ,nt_rw     ,w_ddl     ,weight    ,
     c          irflag    )
              END IF !(ILINTF>0) THEN
C
              CALL getnddli_g(
     1        npby      ,lpby      ,itab      ,nrbyac    ,irbyac    ,
     2        nint2     ,iint2     ,ipari     ,intbuf_tab,ndofi     ,
     3        ndof      ,ikc       ,iddl      ,fr_elem   ,iad_elem  ,
     4        nddli     ,nsl       ,nddli_g   ,irbe3     ,lrbe3     ,
     5        irbe2     ,lrbe2     )
C         Store the size of the contact stifness matrix for nonlinear solver outputs
              IF (ispmd==0.AND.imconv>=0) i_imp(13) = nddli_g
              IF (ispmd==0.AND.imconv>=0.AND.
     .           (lprint/=0.OR.nprint/=0)) THEN
                WRITE(iout,1006)
                WRITE(istdo,1006)
                WRITE(iout,1011)nddli_g
                WRITE(istdo,1011)nddli_g
                WRITE(iout,*)
                WRITE(istdo,*)
              ENDIF
            ENDIF
          ENDIF
        ENDIF
C
        IF (intp_c<0) THEN
          CALL kin_knl(
     1    ipari     ,intbuf_tab,num_imp   ,ns_imp    ,ne_imp    ,
     2    npby      ,lpby      ,itab      ,nrbyac    ,irbyac    ,
     3    nint2     ,iint2     ,ibfv      ,dirul     ,iskew     ,
     6    icodt     ,ndofi     ,iddl      ,ikc       ,ndof      ,
     5    inloc     ,irbe3     ,lrbe3     ,frbe3     ,x         ,
     6    skews%SKEW,irbe2     ,lrbe2)
        ENDIF
C
        IF (nmonv>0.AND.isetk==1) CALL monv_imp(
     .   monvol ,volmon  ,x      ,igrsurf  ,
     1   nmonv  ,imonv   ,ipari  ,intbuf_tab      ,
     2   a      ,ar      ,ndof   ,iddl   ,ikc     ,
     3   inloc  ,iline   ,ibfv   ,skews%SKEW,xframe  ,
     4   dirul  ,iskew   ,icodt  ,irbe3   ,lrbe3  ,
     5   frbe3  ,irbe2   ,lrbe2  ,nsurf)
C
        IF (gap<zero) THEN
          imconv = -2
          IF (ispmd==0) THEN
            WRITE(iout,1009)int(-gap)
            WRITE(istdo,1009)int(-gap)
          ENDIF
        ENDIF
C------------
        IF (isprb==1.AND.imconv==1) THEN
          DO i=1,nddl
            lb0(i) = lb(i)
          ENDDO
        ENDIF
C
        IF (isigini==1.AND.ncycle==1.AND.imconv==1) THEN
          CALL condens_b(nddl0  ,ikc  ,lb0  )
        ENDIF
C---------for mono
        nddli_g=max(nddli_g,nddli)
        iconta = max(iconta,nddli_g)
        IF (iconta>0) THEN
          IF (isolv<5) idsc = 1
        ENDIF
C
        IF (ilintf>2.AND.ncycle<ilintf) THEN
          nsrem = 0
          nsl = 0
        ENDIF
C
        IF (ilintf>0.AND.nddli==0) THEN
          IF (nddlif>0) THEN
            nddli = nddlif
            IF (ALLOCATED(iadi)) DEALLOCATE(iadi)
            ALLOCATE(iadi(nddli+1))
            nnzi = iadif(nddli+1)-iadif(1)
            IF (ALLOCATED(jdii)) DEALLOCATE(jdii)
            ALLOCATE(jdii(nnzi))
            IF (ALLOCATED(itok)) DEALLOCATE(itok)
            ALLOCATE(itok(nddli))
            CALL cp_int_hp(nddli,iftok,itok)
            CALL cp_int_hp(nddli+1,iadif,iadi)
            CALL cp_int_hp(nnzi,jdiif,jdii)
            IF (ALLOCATED(diag_i)) DEALLOCATE(diag_i)
            ALLOCATE(diag_i(nddli))
            IF (ALLOCATED(lt_i)) DEALLOCATE(lt_i)
            ALLOCATE(lt_i(nnzi))
            CALL cp_real_hp(nddli,diag_if,diag_i)
            CALL cp_real_hp(nnzi,lt_if,lt_i)
          ENDIF
        ENDIF
C
        r_imp(18)=gap
C
        IF (iqstat>0.AND.ilintf>0.AND.ilintf==ncycle)
     .     CALL imp_qifam(nodft  ,nodlt   ,iddl   ,ndof   ,inloc ,
     .                    ikc    ,diag_k  ,ms     ,in     ,weight)
C
C        WRITE(6,*) IMUMPSV,IDSC,IMCONV
#if defined(MUMPS5)
        IF (imumpsv >0 .AND.idsc==1.AND.imconv>=0)
     .    CALL imp_mumps1(nddl0,   nnzk0,     nddl,   nnzk,  nnmax,
     .                    nodglob, iddl,      ndof,   inloc, ikc,
     .                    iadk,    jdik,      diag_k, lt_k,  iad_elem,
     .                    fr_elem, mumps_par, cddlp,  iadi,  jdii,
     .                    itok,    diag_i,    lt_i,   nddli, nnzi    ,
     .                    iprint0, it )
#else
        WRITE(6,*) "Fatal error: MUMPS is required"
        CALL flush(6)
        CALL arret(5)
#endif
        CALL cp_real_hp(nddl,lb,lbb)
C--------PCG w/ Projection----
        IF(ncycle==1.AND.imconv==1.AND.i_imp(5)==0) THEN
          IF (m_vs> 0) THEN
C-------------Case smll model---
            npcgpv=nddl
            IF (nspmd>1)CALL spmd_min_i(npcgpv)
            m_vs=min(m_vs,npcgpv)
            IF (m_vs> 0) npcgpv=-1
          END IF
C---------for free rigi motion for springback(generalization later)
          IF(irig_m>0) THEN
            CALL spbrm_pre(itab ,
     1           x         ,iparg     ,ixc       ,ixtg      ,partsav   ,
     2           elbuf_tab ,pm        ,ndof      ,iddl      ,ikc       )
          END IF
        END IF
C-----------------------------
        IF (iconta>0) isetp = 1
C----------------------------------
C       IMPLICIT RESOLVE
C----------------------------------
 100    CONTINUE
C
        IF (iline==1) THEN
          IF (ncycle==1.AND.ispmd==0.AND.itask==0) THEN
            IF (iqstat>0) THEN
              WRITE(iout,*)
              WRITE(iout,*)' ** BEGIN LINEAR QUASI-STATIC IMPLICIT COMPUTATION **'
              WRITE(istdo,*)
              WRITE(istdo,*)' ** BEGIN LINEAR QUASI-STATIC IMPLICIT COMPUTATION **'
              WRITE(iout,*)
              WRITE(istdo,*)
            ELSE
              WRITE(iout,*)
              WRITE(iout,*)' ** BEGIN LINEAR STATIC IMPLICIT COMPUTATION **'
              WRITE(istdo,*)
              WRITE(istdo,*)' ** BEGIN LINEAR STATIC IMPLICIT COMPUTATION **'
              WRITE(iout,*)
              WRITE(istdo,*)
            END IF !(IQSTAT>0) THEN
          ENDIF
C
          ntmp=0
C
c          R2=ZERO
          CALL produt_hp(nddl,lb,lb,w_ddl,r2)
C
          IF (r2>zero.AND.r2<ep30) THEN
          ELSEIF(iqstat==0.AND.itask==0.AND.nddl>0) THEN
            CALL imp_stop(0)
          ENDIF
C
          CALL lin_solv(nddl  ,iddl  ,ndof   ,ikc   ,d_imp ,
     1                 dr_imp,l_tol ,nnzk   ,iadk  ,jdik  ,
     2                 diag_k,lt_k   ,nddli  ,iadi  ,jdii  ,
     3                 diag_i,lt_i   ,itok   ,iadm  ,jdim  ,
     4                 diag_m,lt_m   ,lb    ,r_imp(6),inloc ,
     5                 fr_elem,iad_elem,w_ddl,itask ,isetp  ,
     6                 istop  ,a     ,ar     ,v    ,
     7                 ms    ,x     ,ipari ,intbuf_tab   ,
     8                 num_imp,ns_imp,ne_imp,nsrem ,nsl  ,
     9                 ntmp  ,graphe, itab  ,rbid  ,ibid ,
     a                 ibid  ,nmonv ,imonv  ,monvol,igrsurf,
     b                 fr_mv ,volmon,ibfv  ,skews%SKEW  ,
     c                 xframe,mumps_par,cddlp,ind_imp,xi_c,
     d                 irbe3 ,lrbe3 ,irbe2  ,lrbe2 )
 
C-----------------------------
citask0        IF (ITASK == 0) THEN
C-----------------------------
          IF (inega>0) THEN
            CALL iddl2nod(nddl  ,iddl  ,ndof  ,ikc   ,inloc ,
     .                    inega ,nnod  )
            IF (nnod>0) THEN
              WRITE(iout,1008)itab(nnod)
              WRITE(istdo,1008)itab(nnod)
            ENDIF
C
          ELSEIF(iprec>1.AND.isolv<=2) THEN
            CALL imp_checm(itab  ,nddl  ,iddl  ,diag_m  ,ndof  ,
     .                     ikc   ,inloc ,nddl0 )
C
          ENDIF
          IF(nfxv_g/=0.AND.(nsrem+nsl-intp_c)>0) THEN
            CALL fv_imp(ibfv  ,npc    ,tf     ,vel   ,sensor_tab,
     1                  d_imp  ,dr_imp ,ikc   ,iddl  ,nsensor   ,
     2                  skews%SKEW  ,iframe ,xframe ,v     ,vr    ,
     3                  x     ,dirul  ,ndof   ,a     ,ar    )
          ENDIF
          CALL recukin(rby   ,lpby  ,npby  ,skews%SKEW  ,iskew ,
     1                 itab  ,weight,ms    ,in    ,
     2                 ibfv  ,vel   ,icodt,icodr ,
     3                 nrbyac,irbyac,nint2 ,iint2 ,ipari ,
     4                 intbuf_tab   ,ndof  ,d_imp ,dr_imp,
     5                 x     ,xframe,dirul ,ixr   ,ixc   ,
     6                 ixtg  ,sh4tree,sh3tree,irbe3 ,lrbe3,
     7                 frbe3 ,irbe2 ,lrbe2 )
          IF (istop>0) CALL imp_stop(-1)
          CALL integratorl_hp(d_imp ,dr_imp,
     1                        x    ,v    ,vr    ,a     ,ar    )
C
c         IF (IMPDEB>0) THEN
c            CALL PR_DEB(NDDL  ,IDDL  ,NDOF   ,IKC   ,ITAB   ,
c     1                  DIAG_K,DIAG_M,INLOC  ,FR_ELEM,IAD_ELEM,
c     2                  IADK  ,JDIK  ,LT_K   ,LT_M   ,NDDLI  ,
c     3                  IADI  ,JDII  ,ITOK   ,DIAG_I ,LT_I   ,
c     4                  LBB   ,LBB   ,0      ,NSREM  ,NSL    ,
c     5                  D_IMP ,DR_IMP,1      ,W_DDL  ,AC     ,
c     6                  ACR   ,A     ,AR     ,R2     ,0  ,NODGLOB)
c         END IF
          IF (ilintf>0.AND.ncycle<ilintf) THEN
            CALL imp_inttd0(output,timers,
     1         ipari ,intbuf_tab    ,x_a     ,d       ,
     2         ms    ,itab   ,in    ,d_imp   ,dr_imp  ,
     3         imsch ,i2msch ,isizxv,ilenxv  ,igrbric ,
     4         islen7,irlen7 ,islen11,irlen11,islen17 ,
     5         irlen17,irlen7t,islen7t,iad_elem,fr_elem ,
     6         nbintc,intlist,itask  ,kinet   ,newfront,
     7         num_imp,ns_imp,ne_imp,ind_imp ,isendto ,
     8         irecvfrom,weight ,ixs   ,temp  ,
     9         dt2prev,waint ,num_imp1,irlen20,islen20,
     a         irlen20t,islen20t,irlen20e,islen20e,
     b         ikine,diag_sms,count_remslv,count_remslve,
     c         nsensor,sensor_tab,xdp,h3d_data,multi_fvm,
     d         forneqs,maxdgap,interfaces,glob_therm)
 
            tt=max(zero,tt-dt2)
            isetk =0
C------- Save FIN by AC, ACR ----------
          ELSE
            IF (ilintf>0) THEN
              nt_imp1 = 0
              DO i = 1,ninter
                num_imp1(i) = 0
              END DO
            ENDIF
C
            CALL integrator1_hp(d_imp ,d    )
            IF ((isecut>0 .OR. iisrot>0 .OR. impose_dr/=0 .OR. idrot==1) .AND. iroddl/=0) THEN
              CALL integrator1_hp(dr_imp,dr)
            ENDIF
C
            IF (iscau>0)CALL integrator1_hp(d_imp ,x    )
          ENDIF
          CALL integrator1_hp(d_imp ,x_a   )
C-----------------------------
citask0        END IF !(ITASK == 0) THEN
C-----------------------------
        ELSE  !  nonlinear
C-------------------------
C        IF (GAP<ZERO) GOTO 300
          IF (r_imp(18)<zero.OR.imconv==-2) GOTO 300
          IF (imconv==1) THEN
C-------- value at the beginning of Increament-Sauf diverges -----
citask0          IF (ITASK == 0) THEN
            IF(ncy_max>0.AND.ncycle>ncy_max) CALL imp_stop(-3)
            IF (inconv==1) THEN
              CALL cp_impbuf(1     ,elbuf   ,elbuf_c ,bufmat ,bufmat_c ,
     .                       fsav  ,volmon  ,partsav ,intbuf_tab       ,
     .                       intbuf_tab_c,ipari   ,islen7 ,irlen7   ,
     .                       islen11,irlen11,islen17 ,irlen17,irlen7t  ,
     .                       islen7t,irlen20,islen20 ,irlen20t,islen20t,
     .             irlen20e,islen20e,newfront,elbuf_tab,elbuf_imp,
     .             iparg   )
            END IF
            IF (ncycle==1) THEN
              IF (isprb==1.AND.i_imp(5)==0) r_imp(1) = zero
              r_imp(1) = max(r_imp(1),rf_min*rf_min)
              r_imp(1) = min(r_imp(1),rf_max*rf_max)
              IF (inconv==1) i_imp(12)=1
            END IF
C--------case of converge with 0 iterations-------
            IF (ismdisp>0) THEN
              CALL cp_real_hp(nndl,x_a,x_c)
            ELSE
              CALL cp_real_hp(nndl,x,x_c)
            END IF
            i_imp(2)=0
            i_imp(6)=iconta
            it=0
citask0          END IF !(ITASK == 0) THEN
C
            IF (isigini==1) THEN
C           TMP1 = DT2*NCYCLE
C           TMP2 = TSTOP-TT+TMP1-DT2
C           BFAC =TMP1/MAX(DT2,TMP2)
C------strickly proportional
              bfac= (tt-r_imp(19))/(tstop-r_imp(19))
              r_imp(10)=bfac-one
              IF (r_imp(10)<zero)CALL vaxpy_hp(nddl ,lb  ,lb0  ,r_imp(10))
            ENDIF
C
C----------------------
c      CALL MY_BARRIER
C---------------------
c          R2=ZERO
            CALL produt_hp(nddl,lb,lb,w_ddl,r2)
C----------------------
c      CALL MY_BARRIER
C---------------------
            IF (r2>=zero.AND.r2<ep30) THEN
            ELSEIF(idyna==0.AND.iqstat==0) THEN
              CALL imp_stop(0)
            ENDIF
C
            IF (inconv == 1) r_imp(1)=max(r_imp(1),r2)
!sb
            IF(n_lim == 1 .AND. isprb == 0) r_imp(1)=r2
!fin sb
            IF (isprb==1) THEN
              IF (sqrt(r2/r_imp(1))<=n_tol) THEN
c            IF (ITASK == 0) THEN
                dt_imp=tstop-tt+dt2
                CALL zeror_hp(d_imp,numnod)
                IF (iroddl/=0) CALL zeror_hp(dr_imp,numnod)
c            END IF !(ITASK == 0) THEN
                GOTO 200
              ENDIF
            END IF !(ISPRB==1) THEN
C
citask0          IF (ITASK == 0) THEN
C
            IF (isprb==1) THEN
              tmp1 = dt2*ncycle
              tmp2 = tstop-tt+tmp1-dt2
              bfac =tmp1/max(dt2,tmp2)
              r_imp(10)=bfac-one
              r_imp(2)=r2*bfac*bfac
              IF (ncycle==1) THEN
                r_imp(12)=em01
C
                IF (iconta>0) r_imp(12)=zep9
              ELSE
                tmp = dt12/max(dt12,tstop-tt)+n_tol/sqrt(r2/r_imp(1))
                tmp = min(half*tmp,one)
                r_imp(12)=r_imp(12)*(one-tmp)+tmp
              ENDIF
            ELSE
              r_imp(2)=r2
            ENDIF
            r_imp(3)=one
            r_imp(4)=r_imp(6)
C
citask0          END IF !(ITASK == 0) THEN
C----------------------
c      CALL MY_BARRIER
C---------------------
            IF (isprb==1) THEN
              tmp = r_imp(10)+one
              CALL vscaly_hp(nddl ,lb  ,lb0  ,tmp )
            END IF
          ELSEIF (imconv==-1) THEN
C--------line-search------
            IF (isprb==1.OR.isigini==1) THEN
              IF (r_imp(10)<zero) THEN
                CALL vaxpy_hp(nddl ,lb  ,lb0  ,r_imp(10))
              ENDIF
            ENDIF
          ELSE
citask0          IF (ITASK == 0) THEN
            it=it+1
            i_imp(2)=i_imp(2)+1
citask0          END IF !(ITASK == 0) THEN
            IF (isprb==1.OR.isigini==1) THEN
              IF (r_imp(10)<zero) THEN
                CALL vaxpy_hp(nddl ,lb  ,lb0  ,r_imp(10))
              ENDIF
            ENDIF
          ENDIF  !         IF (IMCONV==1) THEN
C----------------------
c      CALL MY_BARRIER
C---------------------
citask0        IF (ITASK == 0) THEN
C-----------------------------
          IF (isprb==1) THEN
            faci=min(one,r_imp(12))
            r02=faci*faci*r_imp(1)
          ELSE
            r02=r_imp(1)
          ENDIF
          IF (it==1.AND.irefi==5) THEN
            r02 = max(r02,em20)
            r_imp(6) = max(em20,r_imp(6))
          ENDIF
          IF (it==1.AND.iconta>i_imp(6)) THEN
C       re-evoluer Rref-------
            IF (irefi==5.AND.nfxv_g>0.AND.imconv>=0) THEN
              CALL rer02(rby   ,lpby  ,npby  ,skews%SKEW  ,iskew ,
     1                   itab  ,weight,ms    ,in    ,
     2                   ibfv  ,vel   ,icodt,icodr ,
     3                   nrbyac,irbyac,nint2 ,iint2 ,ipari ,
     4                   intbuf_tab   ,ndof  ,d_imp ,dr_imp,
     5                   x     ,xframe,dirul ,ixr   ,ixc   ,
     6                   ixtg  ,sh4tree,sh3tree,irbe3 ,lrbe3,
     7                   frbe3 ,iadk   ,jdik  ,diag_k,lt_k ,
     8                   iddl  ,ikc    ,inloc ,num_imp,ns_imp,
     9                   ne_imp,ind_imp,nddl  ,w_ddl  ,a   ,
     a                   ar    ,r02    ,irbe2 ,lrbe2  ,x_c  )
              r_imp(1) = max(r02,r_imp(1))
            ENDIF
            IF (i_imp(7)==0.AND.irefi==4) irefi= -4
          ENDIF
          IF (imconv>0.AND.isprb/=1) THEN
            r02 = max(r02,rf_min*rf_min)
            r02 = min(r02,rf_max*rf_max)
          END IF
C
          IF (ncycle==1.AND.insolv>=2.AND.it==0.AND.imconv>=0)
     .     CALL bfgs_ini(nddl,n_lim)
          r_imp(17) = r02
C-----------------------------
citask0        END IF !(ITASK == 0) THEN
C-----------------------------
C----------------------
c      CALL MY_BARRIER
C---------------------
c-------particular case .AND.NFXVEL==0
          IF (nddl_g==0.AND.nfxvel > 0) THEN
            IF (it==0) THEN
C----add 3 to enforce at least one iteration in case of IMPDISP dependent (moving skew or frame)
              imconv=3
              isetk=0
            ELSE
              imconv=1
            END IF
C----------------------
c      CALL MY_BARRIER
C---------------------
          ELSE
            CALL nl_solv(nddl  ,iddl  ,ndof   ,ikc   ,d_imp ,
     1                   dr_imp,nnzk  ,iadk   ,jdik  ,diag_k,
     2                   lt_k  ,lb    ,nddli  ,iadi  ,jdii  ,
     3                   diag_i,lt_i  ,itok   ,iadm  ,jdim  ,
     4                   diag_m,lt_m  ,r_imp(17),dd    ,ddr   ,
     5                   itask ,it  ,i_imp(2),r_imp(3),r_imp(2),
     6                   i_imp(5) ,inprint,isetp ,istop ,r_imp(4),
     7                   r_imp(5),r_imp(6),inloc ,nddl0 ,r_imp(7),
     8                   r_imp(11),r_imp(18),itab  ,fr_elem,iad_elem,
     9                   w_ddl    ,a      ,ar    ,v     ,ms    ,
     a                   x        ,ipari ,intbuf_tab    ,num_imp,
     b                   ns_imp   ,ne_imp,nsrem ,nsl   ,iconta ,
     c                   graphe   ,fac_k ,ipiv_k, nkcond,nmonv  ,
     d                   imonv ,monvol ,igrsurf,fr_mv  ,
     e                   volmon,ibfv   ,skews%SKEW  ,xframe,mumps_par,
     f                   cddlp ,ind_imp,nbintc,intlist,newfront,
     g                   isendto,irecvfrom,irbe3,lrbe3,i_imp(8),
     h                   i_imp(9),i_imp(10),fext  ,dg    ,dgr  ,
     i                   dg0   ,dgr0 ,r_imp(13),r_imp(14),
     j                   nodftsk,nodltsk,irbe2,lrbe2,i_imp(12),
     k                   r_imp(20),anew_stif)
          END IF !(NDDL==0.AND.NFXVEL > 0) THEN
 
C---------------------------------
citask0        IF (ITASK == 0) THEN
C---------------------------------
          IF(nfxvel/=0) THEN
C-----for FV_local
            ntmp=0
            DO i=1,nfxvel
              ntmp=ntmp+iabs(dirul(i))
            END DO
            IF (ntmp>0)
     .      CALL fv_imp(ibfv  ,npc    ,tf     ,vel   ,sensor_tab,
     1                  d_imp  ,dr_imp ,ikc   ,iddl  ,nsensor   ,
     2                  skews%SKEW  ,iframe ,xframe ,v     ,vr    ,
     3                  x     ,dirul  ,ndof   ,a     ,ar    )
          END IF
C--------Rigid motions elimination----
          IF(irig_m>0.AND.imconv==1) THEN
            CALL spb_rm_rig(
     1      x         ,ixc       ,ixtg      ,ndof      ,iddl      ,
     2      ikc       ,d_imp     ,dr_imp    ,icodt     ,icodr ,
     3      skews%SKEW,iskew     ,itab     )
          END IF
          IF(imp_lr > 0)THEN
            CALL recukin(rby   ,lpby  ,npby  ,skews%SKEW  ,iskew ,
     1                   itab  ,weight,ms    ,in    ,
     2                   ibfv  ,vel   ,icodt,icodr ,
     3                   nrbyac,irbyac,nint2 ,iint2 ,ipari ,
     4                   intbuf_tab,ndof  ,d_imp ,dr_imp,
     5                   x_c   ,xframe,dirul ,ixr   ,ixc   ,
     6                   ixtg  ,sh4tree,sh3tree,irbe3 ,lrbe3,
     7                   frbe3 ,irbe2 ,lrbe2 )
          ELSE
            CALL recukin(rby   ,lpby  ,npby  ,skews%SKEW  ,iskew ,
     1                   itab  ,weight,ms    ,in    ,
     2                   ibfv  ,vel   ,icodt,icodr ,
     3                   nrbyac,irbyac,nint2 ,iint2 ,ipari ,
     4                   intbuf_tab   ,ndof  ,d_imp ,dr_imp,
     5                   x     ,xframe,dirul ,ixr   ,ixc   ,
     6                   ixtg  ,sh4tree,sh3tree,irbe3 ,lrbe3,
     7                   frbe3 ,irbe2 ,lrbe2 )
          END IF
c       Print information of non-linear solver
          IF (solvnfo > zero) THEN
            IF (imconv /= -1) THEN
              CALL pr_solnfo(nddl  ,iddl  ,ndof   ,ikc   ,itab   ,
     1                      diag_k,diag_m,inloc  ,fr_elem,iad_elem,
     2                      iadk  ,jdik  ,lt_k   ,lt_m   ,nddli  ,
     3                      iadi  ,jdii  ,itok   ,diag_i ,lt_i   ,
     4                      lbb   ,lbb   ,it     ,nsrem  ,nsl    ,
     5                      d_imp ,dr_imp,1      ,w_ddl  ,ac     ,
     6                      acr   ,a     ,ar     ,r2    ,ndeb0   ,
     7                      r_imp ,i_imp ,dd     ,ddr)
            ENDIF
          ENDIF
c
c        IF (IMPDEB>0) THEN
c          IF (NCYCLE>=NDEB0.AND.NCYCLE<=NDEB1) THEN
c            CALL PRODUT_HP(NDDL,LB,LB,W_DDL,R2)
c            CALL PR_DEB(NDDL  ,IDDL  ,NDOF   ,IKC   ,ITAB   ,
c     1                  DIAG_K,DIAG_M,INLOC  ,FR_ELEM,IAD_ELEM,
c     2                  IADK  ,JDIK  ,LT_K   ,LT_M   ,NDDLI  ,
c     3                  IADI  ,JDII  ,ITOK   ,DIAG_I ,LT_I   ,
c     4                  LBB   ,LBB   ,IT     ,NSREM  ,NSL    ,
c     5                  D_IMP ,DR_IMP,1      ,W_DDL  ,AC     ,
c     6                  ACR   ,A     ,AR     ,R2    ,NDEB0   )
c          END IF
c         END IF
c
          IF (nbintc>0) THEN
            IF (ismdisp>0) THEN
              CALL imp_dtkin(
     1           ipari ,intbuf_tab       ,x_a     ,v       ,
     2           vr    ,itab   ,d_imp   ,dr_imp  ,nbintc  ,
     3           intlist,itask  ,newfront,isendto ,irecvfrom,
     4           iddl  ,ndof   ,ikc     ,tmp     ,ms      ,
     5           nsensor,sensor_tab,maxdgap)
            ELSE
              CALL imp_dtkin(
     1           ipari ,intbuf_tab      ,x       ,v       ,
     2           vr    ,itab   ,d_imp   ,dr_imp  ,nbintc  ,
     3           intlist,itask  ,newfront,isendto ,irecvfrom,
     4           iddl  ,ndof   ,ikc     ,tmp     ,ms      ,
     5           nsensor,sensor_tab,maxdgap)
              IF(nfxv_g/=0.AND.tmp<one)
     .        CALL fv_imp(ibfv  ,npc    ,tf     ,vel   ,sensor_tab,
     1                    d_imp  ,dr_imp ,ikc   ,iddl  ,nsensor   ,
     2                    skews%SKEW  ,iframe ,xframe ,v     ,vr    ,
     3                    x     ,dirul  ,ndof   ,a     ,ar    )
            END IF !(ISMDISP>0) THEN
          END IF
C
C---------------------------------
citask0        END IF !(ITASK == 0) THEN
C---------------------------------
 300      CONTINUE
C---------------------------------
citask0        IF (ITASK == 0) THEN
C---------------------------------
          IF (ismdisp>0) THEN
            CALL cp_real_hp(nndl,x_c,x_a)
          ELSE
            CALL cp_real_hp(nndl,x_c,x)
          END IF
          CALL cp_impbuf(2      ,elbuf   ,elbuf_c ,bufmat  ,bufmat_c  ,
     .                   fsav   ,volmon  ,partsav ,intbuf_tab       ,
     .                   intbuf_tab_c ,ipari   ,islen7 ,irlen7   ,
     .                   islen11,irlen11,islen17 ,irlen17,irlen7t  ,
     .                   islen7t,irlen20,islen20 ,irlen20t,islen20t,
     .         irlen20e,islen20e,newfront,elbuf_tab,elbuf_imp,
     .         iparg   )
 
          IF (ncycle == 1 .AND. istop == 0 .AND.isolv == 7) THEN
            IF (it == 1 .AND. i_imp(5) == 0 ) THEN
              WRITE (iout, *)
     .        "    **PCG SOLVER HAS BEEN SELECTED FIRSTLY FOR THIS RUN**"
              WRITE (istdo, *)
     .        "    **PCG SOLVER HAS BEEN SELECTED FIRSTLY FOR THIS RUN**"
            END IF
          END IF
 
          IF (istop>0) THEN
            IF (istop == 3 .AND.isolv == 7) THEN
 
              isolv = 3
              isetk = 1
              ikpat = 0
              i_imp(11)=1
              istop = 0
              iprec = 1
              IF (nspmd > 1 ) THEN
                IF (imumpsd == 0) imumpsd = 1
                IF (imumpsv == 0) imumpsv = 1
              END IF
              IF (ncycle == 1 ) THEN
                IF (ispmd  == 0) THEN
                  WRITE (iout, *)
     .            "    **DIRECT SOLVER HAS BEEN SELECTED FOR THIS RUN**"
                  WRITE (istdo, *)
     .            "    **DIRECT SOLVER HAS BEEN SELECTED FOR THIS RUN**"
                END IF !(NSPMD  == 0) THEN
              ELSE
                IF (ispmd  == 0) THEN
                  WRITE (iout, *)
     .            "    **PCG SOLVER HAS BEEN CHANGED TO DIRECT SOLVER **"
                  WRITE (istdo, *)
     .            "    **PCG SOLVER HAS BEEN CHANGED TO DIRECT SOLVER **"
                END IF !(NSPMD  == 0) THEN
              END IF
 
            ENDIF
            imconv=-2
            CALL iddl2nod(nddl  ,iddl  ,ndof  ,ikc   ,inloc ,
     .                    istop ,nnod  )
            IF (nnod>0) THEN
              WRITE(iout,1008)itab(nnod)
              WRITE(istdo,1008)itab(nnod)
            ENDIF
          ENDIF
          inconv = min(1,imconv)
          IF (imconv<=-2) THEN
            CALL zeror_hp(d_imp,numnod)
            IF (iroddl/=0) CALL zeror_hp(dr_imp,numnod)
            r_imp(6)=r_imp(4)
            i_imp(5)=-2
            IF (isprb==1.AND.imconv==-3.AND.iconta==0) THEN
              DO i=1,nddl
                lb(i) = lb0(i)
              ENDDO
              imconv=1
              GOTO 100
            ENDIF
            tt=max(zero,tt-dt2)
            ncycle=ncycle-1
            IF (ncycle==0) dt1=zero
            CALL int5_diverg(ipari )
            IF (imconv==-2.AND.i_imp(11)/=1) THEN
C-----------change dt------
              CALL imp_dtn(it,r_imp(11),r_imp(10),r_imp(24))
C           CALL NUL_ETFAC_A
              CALL etfac_ini(iparg )
              IF (dt_imp==dt_min) THEN
                CALL imp_stop(imconv)
              ENDIF
            ENDIF
          ENDIF
C
          IF (imconv<=-2.OR.imconv==0) THEN
            IF (it==1.AND.iconta>i_imp(6)) THEN
              r02 =r_imp(17)
              IF (irefi==1) THEN
                r02 = min(r02,ten*r_imp(1))
              ELSEIF (irefi==2) THEN
                r02 = min(r02,onep2*r_imp(1))
              ELSEIF (irefi==3.OR.irefi==4.OR.irefi==5) THEN
                r02 = min(r02,r_imp(1))
              ELSEIF (irefi==-4) THEN
                i_imp(7) = 1
                irefi = 4
              END IF
C----Used for gravity case
              IF (ncycle > 1) i_imp(7) = 1
              r_imp(1)=max(r_imp(1),r02)
            ENDIF
          ENDIF !IF (IMCONV<=-2.OR.IMCONV==0)
C------------for restart---
          IF (imconv>0) THEN
            r_imp(1) = max(r_imp(1),rf_min*rf_min)
            r_imp(1) = min(r_imp(1),rf_max*rf_max)
          ENDIF
C
          IF (imconv==2) dt2=dt2/i_imp(2)
C---------------------------------
 200      CONTINUE
C    /---------------/
c      CALL MY_BARRIER
C    /---------------/
C---------------------------------
citask0        IF (ITASK == 0) THEN
C---------------------------------
          IF (imconv==1.OR.imconv==2.OR.imconv==3) THEN
            IF(idyna>0.AND.nfxvel/=0) THEN
              CALL fv_fint0(ibfv  ,npc    ,tf   ,vel   ,sensor_tab,
     1                     d_imp ,dr_imp,ikc   ,iddl  ,nsensor   ,
     2                     skews%SKEW   ,iframe ,xframe,a    ,ar    ,
     3                     x      ,ndof  ,ms   ,in    ,weight ,
     4                     rby    )
            END IF
            IF (imconv/=3) CALL integrator1_hp(d_imp ,d     )
            IF (r_imp(11)<em10)
     .      CALL produt_uhp0(d_imp ,dr_imp,r_imp(11),weight)
            CALL imp_dtn(it,r_imp(11),r_imp(10),r_imp(24))
            IF ( iqstat>0) CALL dis_cp(nndl,d_imp,dr_imp,0    )
          ENDIF
          IF (inconv==1 .AND. (isecut>0.OR.iisrot>0
     .       .OR. impose_dr/=0 .OR. idrot==1)
     .       .AND. iroddl/=0) THEN
            IF (imconv/=3) CALL integrator1_hp(dr_imp,dr)
          ENDIF
          IF (ismdisp>0) THEN
            CALL integrator_hp(ndt   ,d_imp ,dr_imp,
     1                         x_a   ,v     ,vr    ,a     ,ar    )
          ELSE
C
            CALL integrator_hp(ndt   ,d_imp ,dr_imp,
     1                         x     ,v     ,vr    ,a     ,ar    )
          ENDIF
C
          IF(idyna>0.AND.imconv==1)  THEN
            CALL dyna_wex(ibcl  ,forc   ,snpc,npc   ,tf    ,ac    ,
     2                    v     ,x      ,skews  ,acr   ,vr    ,
     3                    sensor_tab,weight,wfext ,iads_f,
     4                    fsky  ,igrv   ,agrv  ,ms    ,in    ,
     5                    lgrav ,itask ,nrbyac,irbyac ,
     6                    npby  ,rby   ,ibfv    ,vel   ,d_imp  ,
     7                    dr_imp,ikc   ,iddl  ,iframe,xframe  ,
     8                    ndof  ,h3d_data,cptreac,fthreac,nodreac,nsensor,
     9                    th_surf ,dpl0cld,
     a                    vel0cld, numnod,nsurf,nfunct,nconld,
     b                    ngrav,nfxvel,stf,numskw,python)
            CALL dyna_cpr0(nddl0  )
          END IF
C----------D_imp taking D_n-1 :exception for case with Gravity-----
          IF (imconv<=-2 .AND.iqstat>0 .AND. i_imp(7) >0) THEN
            CALL dis_cp(nndl,d_imp,dr_imp,1    )
          END IF
C
          IF (imconv == 3 ) inconv = 0
          IF (imconv<=-2) imconv=1
          IF (imconv==1) i_imp(1)=i_imp(1)+it+1
          IF (imconv==1) i_imp(12)=inconv
          i_imp(4)=ndt-1
          it_t = i_imp(1)
C--------
citask0        END IF !(ITASK == 0) THEN
C
        ENDIF !IF (ILINE==1) THEN
C----------------------
        CALL my_barrier
C---------------------
citask0       IF (ITASK == 0) THEN
        IF (nint7>0) THEN
          DEALLOCATE(iadi)
          DEALLOCATE(itok)
          DEALLOCATE(jdii)
          DEALLOCATE(diag_i)
          DEALLOCATE(lt_i)
        ENDIF
C
        IF ((nsrem+nsl)>0) CALL ini_kic
        IF (ilintf>0) DEALLOCATE(xi_c)
        IF (intp_c<0) CALL deallocm
        IF (nint2>0) DEALLOCATE(iaint2)
 
citask0       END IF !(ITASK == 0) THEN
c
 1001   FORMAT(' symbolic dim : nddl =',I8,1X,'nnz =',I8,1X,'nb_max =',I8)
 1002   FORMAT(' final    dim : nddl =',I8,1X,'nnz =',I8,1X,'nb_max =',I8)
 1003   FORMAT(/,5X,'--stiffness matrix is reformed --')
 1004   FORMAT(3X,'line. solver : isolv =',I4,2X,'prec. meth. =',I4,2X,
     .         'tol =',E11.4)
 1005   FORMAT(5X,'--stiffness matrix will be reformed after each ',I4,
     .         2X,'iterations--')
 1006   FORMAT(5X,'--supplementary contact stiffness matrix',
     .            1X, 'is created--')
 1007   FORMAT(5X,' with dim. : nd   =',I8,1X,'nz  =',I8) !,1X,'nb_max =',I8)
 1008   FORMAT(3X,'**warning: stiffness matrix is not definite**'/,
     .         3X,'**look at node: ',I8)
 1009   FORMAT(3X,'**timestep will be reduced to avoid de-activation ',
     .            'in interface:**',I8)
 1010   FORMAT(/,5X,'--stiffness matrix is reformed',1X,
     .         'due to rigid wall impact--'/,5X,'with impact num. =',I8)
 1011   FORMAT(5X,' with dim. : nd   =',I8)
 1012   FORMAT(3X,'**timestep will be reduced due to ',
     .            'dim.(nd) change w/autospc::**',2i8)
        RETURN
C endif MUMPS defined
#endif

imp_stif24()

subroutine imp_stif24	(	integer, dimension(*)	numimp,
		integer, dimension(npari,*)	ipari )

Definition at line 7110 of file imp_solv.F.

C-----------------------------------------------
        USE tri7box
        USE imp_i7cp
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "com04_c.inc"
#include      "com08_c.inc"
#include      "impl1_c.inc"
#include      "param_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER  NUMIMP(*),IPARI(NPARI,*)
C-----------------------------------------------
C   L o c a l  V a r i a b l e s
C-----------------------------------------------
        INTEGER I,J,K,L,N,IAD,N_MAX(NINTER),IFLAG,P,
     .         ITY,NSN,IGSTI,IBIT,RID,INTTH,
     .         IGAP,INACTI,IN1CON,NCONT0,NREBOU
C-----------------------------------------------
C   S o u r c e  L i n e s
C-----------------------------------------------
C-----Calculation NCONT0, Communication is necessary
        IF (tt == zero.AND.inconv==1) THEN
          DO n = 1,ninter
            ity   =ipari(7,n)
            IF (ity==24) THEN
              ipari(26,n)= 0
              ipari(53,n)= 0
            END IF
          END DO
        END IF
        iflag=0
        DO n = 1,ninter
          ity   =ipari(7,n)
          igsti =ipari(34,n)
          n_max(n)=0
          IF (ity == 24.AND.igsti==6) THEN
            n_max(n) =numimp(n)
            iflag=1
          END IF
        END DO
        IF (iflag==0.OR.imconv<0) RETURN
C
        IF (nspmd>1) CALL spmd_allglob_isum9(n_max,ninter)
 
        DO n = 1,ninter
          ity   =ipari(7,n)
          igsti =ipari(34,n)
          IF (ity /= 24.AND.igsti/=6) cycle
          in1con =ipari(26,n)
          ncont0 =ipari(27,n)
          nrebou =ipari(53,n)
          IF (n_max(n)>0 .AND. in1con==0) THEN
            IF (inconv==1) THEN
              in1con = ncycle+1
            ELSE
              in1con = ncycle
            END IF
          END IF
C---------rebound----
          IF (ncont0>0 .AND.n_max(n)==0) THEN
C------first one will keep negative IN1CON till converging
            IF (ncycle == in1con) THEN
              nrebou=1
            ELSE
C--------rebound nb >2
              nrebou=2
            END IF
c        write(iout,*)'NREBOU,NIN,imconv,ispmd=',
c     +                NREBOU,N,imconv,ispmd
C---------negative :rebound active
            ipari(53,n)=-nrebou
          END IF
          ipari(26,n)=in1con
          ipari(27,n)=n_max(n)
        END DO
C
        RETURN

imp_stop()

subroutine imp_stop

(

integer

istop

)

Definition at line 1996 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE message_mod
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
#include "comlock.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include "units_c.inc"
#include      "task_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
        integer
     .    istop,img
        CHARACTER*60       MSG(-4:2)
        DATA               msg
     .    / 'STOPPED DUE TO SOLVER ERROR **',
     .      'STOPPED DUE TO NCYCLE LIMIT **',
     .      'STOPPED DUE TO TIMESTEP LIMIT **',
     .      'STOPPED DUE TO MODELLING DATA **',
     .      'stopped due to loading DATA **' ,
     .      'stopped due to divergence **'  ,
     .      'stop with checking **'  /
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        IF (ISPMD==0) THEN
          IMG=ISTOP
          IF (ISTOP>2) IMG=1
          CALL ANCMSG(MSGID=79,ANMODE=ANINFO,
     .                C1=MSG(IMG),I1=ISTOP)
          CALL MY_FLUSH(IOUT)
        ENDIF
        CALL ARRET(2)
C------------------------------------------
        RETURN

ini_bminma_imp()

subroutine ini_bminma_imp

(

type(intbuf_struct_), dimension(ninter)

intbuf_tab

)

Definition at line 7437 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE intbufdef_mod
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
C-----------------------------------------------
        TYPE(INTBUF_STRUCT_):: INTBUF_TAB(NINTER)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER  N
C-----------------------------------------------
        DO n = 1,ninter
          intbuf_tab(n)%BMINMA_IMP(1)=-ep30
          intbuf_tab(n)%BMINMA_IMP(2)=-ep30
          intbuf_tab(n)%BMINMA_IMP(3)=-ep30
          intbuf_tab(n)%BMINMA_IMP(4)=ep30
          intbuf_tab(n)%BMINMA_IMP(5)=ep30
          intbuf_tab(n)%BMINMA_IMP(6)=ep30
        END DO
C------------------------------------------
        RETURN

ini_k0h()

subroutine ini_k0h	(	integer	nddl,
		integer	nnz,
		integer	nnzm,
		integer, dimension(*)	iadk,
		integer, dimension(*)	jdik )

Definition at line 5083 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE imp_workh
        USE imp_pcg_proj
        USE message_mod
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "impl1_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER NDDL,NNZ,NNZM,IADK(*),JDIK(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER IERR,LNZM
C------------------for lin_solv---------------
        ALLOCATE(l_u(nddl),diag_t(nddl),l_f0(nddl),stat=ierr)
        IF (ierr/=0) THEN
          CALL ancmsg(msgid=19,anmode=aninfo,
     .                c1='FOR IMPLICIT SOLVER')
          CALL arret(2)
        ENDIF
        IF (isolv==1.OR.isolv>4) THEN
          ALLOCATE(pcg_w1(nddl),pcg_w2(nddl),pcg_w3(nddl),stat=ierr)
          ALLOCATE(iadk0(nddl+1),jdik0(nnz),lt_k0(nnz),stat=ierr)
          IF (ierr/=0) THEN
            CALL ancmsg(msgid=19,anmode=aninfo,
     .                  c1='FOR PCG SOLVER')
            CALL arret(2)
          ENDIF
          lt_k0=zero
          IF (iprec==5) THEN
            lnzm = nnzm
            IF (n_pat>1) CALL dim_span(n_pat,nddl,iadk,jdik,lnzm,ierr)
            ALLOCATE(iadm0(nddl+1),jdim0(lnzm),lt_m0(lnzm),stat=ierr)
            IF (ierr/=0) THEN
              CALL ancmsg(msgid=19,anmode=aninfo,
     .                    c1='FOR PCG(IPREC=5) SOLVER')
              CALL arret(2)
            ENDIF
            lt_m0=zero
          END IF !(IPREC==5) THEN
        END IF !(ISOLV==1.OR.ISOLV>4) THEN
C
        IF (m_vs>0) THEN
          lnzm=m_vs+1
          ALLOCATE(proj_s(nddl,lnzm),proj_t(nddl,lnzm),proj_la_1(lnzm),
     .                    proj_v(nddl),proj_w(lnzm),proj_k(lnzm,lnzm),
     .                    stat=ierr)
          IF (ierr/=0) THEN
            CALL ancmsg(msgid=19,anmode=aninfo,
     .                  c1='FOR PCG SOLVER')
            CALL arret(2)
          ENDIF
          ncg_run = 0
          proj_v = zero
        END IF
C------------------------------------------
        RETURN

ini_kic()

subroutine ini_kic

Definition at line 4848 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE imp_intm
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        nddl_si = 0
        nddl_sl = 0
        nz_si = 0
        nz_sl = 0
C------------------------------------------
        RETURN

ini_kif()

subroutine ini_kif

Definition at line 2485 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE imp_lintf
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        nddlif = 0
        nzif = 0
C------------------------------------------
        RETURN

int5_diverg()

subroutine int5_diverg

(

integer, dimension(npari,*)

ipari

)

Definition at line 6799 of file imp_solv.F.

C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
#include      "param_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER  IPARI(NPARI,*)
C     REAL
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER  N, NTY
C--------------------------------------------
        DO n=1,ninter
          nty   =ipari(7,n)
C-----------------------------------------------------------------------
          IF(nty == 5 ) THEN
C-----------------------------------------------------------------------
            ipari(16,n)=ipari(16,n)-1
C-----------------------------------------------------------------------
          ELSEIF(nty == 10)THEN
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
          ELSEIF(nty == 11)THEN
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
          ELSEIF(nty == 24 ) THEN
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
          ENDIF
        END DO
C-----------------------------------------------------------------------
        RETURN

k_band()

subroutine k_band	(	integer	nddl,
		integer, dimension(*)	iadk,
		integer, dimension(*)	jdik,
		integer	ndmax )

Definition at line 2253 of file imp_solv.F.

C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
        INTEGER NDDL,IADK(*),JDIK(*),NDMAX
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER I,J,JD,ND(NDDL)
C------------------------------------------
        DO i = 1, nddl
          nd(i) = 1 + iadk(i+1) - iadk(i)
          DO j = iadk(i),iadk(i+1)-1
            jd = jdik(j)
            nd(jd) = nd(jd) + 1
          ENDDO
        ENDDO
C
        ndmax = 0
        DO i = 1, nddl
          ndmax = max(ndmax,nd(i))
        ENDDO
C------------------------------------------
        RETURN

m_lnz()

subroutine m_lnz	(	integer	nddl,
		integer, dimension(*)	iadk,
		integer, dimension(*)	jdik,
		integer	ndmax,
		integer	nlmax )

Definition at line 2292 of file imp_solv.F.

C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
        INTEGER NDDL,IADK(*),JDIK(*),NDMAX,NLMAX
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER I,J,JD,JM(NDMAX+1),NC,NNZ
C------------------------------------------
        DO i=1,nddl
          CALL sp_stat0(i  ,iadk  ,jdik  ,nc    ,jm    )
          CALL dim_subnz(iadk  ,jdik  ,nc    ,jm    ,nnz  )
          nlmax = max(nlmax,nnz)
        ENDDO
C------------------------------------------
        RETURN

matv_kif()

subroutine matv_kif	(		v,
			w )

Definition at line 2661 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE imp_lintf
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
        my_real
     .    w(*), v(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER I,J,K,II,KK
        my_real
     .     l_k
C-----------------------------
        RETURN
        DO i=1,nddlif
          ii = iftok(i)
c        W(II) = W(II) +DIAG_IF(I)*V(II)
          DO j =iadif(i),iadif(i+1)-1
            k =jdiif(j)
            kk = iftok(k)
            l_k = lt_if(j)
            w(ii) = w(ii) + l_k*v(kk)
            w(kk) = w(kk) + l_k*v(ii)
          ENDDO
        ENDDO
C-----------------------------
        RETURN

minv_k()

subroutine minv_k	(	integer	nd,
		integer, dimension(3,*)	icnds10,
		integer, dimension(*)	iddl,
		integer, dimension(*)	inloc,
		integer, dimension(*)	ndof,
			ms,
			tol,
			ke )

Definition at line 8807 of file imp_solv.F.

C----6---------------------------------------------------------------7---------8
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER ND
        INTEGER ICNDS10(3,*),IDDL(*),INLOC(*),NDOF(*)
C     REAL
        my_real
     .     ke(nd,nd) ,ms(*),tol
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER I,K,J,IK,ID,JD,L,N,NN,N1,N2,II,JJ,JK
        my_real
     .     ev(nd,nd),ew(nd),
     .     la,msd(nd),msij,lamda,me(nd,nd),msnd,msii
C----6----------------------------------
        lamda = zero
        me(1:nd,1:nd) = zero
        DO i =1,ns10e
          nn  = iabs(icnds10(1,i))
          n1  = icnds10(2,i)
          n2  = icnds10(3,i)
          id=inloc(nn)
          msnd = ms(id)
          DO j=1,ndof(id)
            ik = iddl(id)+j
            me(ik,ik)=me(ik,ik)+msnd
          END DO
          ii=inloc(n1)
          msii = third*ms(ii) + fourth*msnd
          DO j=1,ndof(ii)
            ik = iddl(ii)+j
            me(ik,ik)=me(ik,ik)+msii
          END DO
          jj=inloc(n2)
          msii = third*ms(jj) + fourth*msnd
          DO j=1,ndof(jj)
            ik = iddl(jj)+j
            me(ik,ik)=me(ik,ik)+msii
          END DO
C--------- m12
          msii = fourth*msnd
C--------suppose NDOF(II)= NDOF(JJ) = NDOF(ID)
          DO j=1,ndof(ii)
            ik = iddl(ii)+j
            jk = iddl(jj)+j
            me(ik,jk)=me(ik,jk)+msii
            me(jk,ik)=me(jk,ik)+msii
          END DO
C--------- m13,m23
          msii = -half*msnd
          DO j=1,ndof(ii)
            ik = iddl(ii)+j
            jk = iddl(id)+j
            me(ik,jk)=me(ik,jk)+msii
            me(jk,ik)=me(jk,ik)+msii
          END DO
          DO j=1,ndof(jj)
            ik = iddl(jj)+j
            jk = iddl(id)+j
            me(ik,jk)=me(ik,jk)+msii
            me(jk,ik)=me(jk,ik)+msii
          END DO
        END DO !I =1,NS10E
        DO i =1,nd
          DO j =i,nd
            me(j,i)=me(i,j)
          END DO
        END DO
        CALL jacobien(me,nd,ew,ev,tol,lamda)
C-------[EV]'-> [EV]*EW^-1/2
        DO i =1,nd
c        print *,'M, ME(I,I),I=',ME(I,I),I
          ew(i)=one/sqrt(ew(i))
        END DO
        DO i =1,nd
          DO j =1,nd
            ev(i,j)=ev(i,j)*ew(j)
          END DO
        END DO
C-------[K]-> [EV]^t*[K]*[EV]
        me(1:nd,1:nd) = zero
        DO i=1,nd
          DO j=1,nd
            DO k = 1,nd
              me(i,j)=me(i,j)+ke(i,k)*ev(k,j)
            ENDDO
          ENDDO
        ENDDO
        ke(1:nd,1:nd) = zero
        DO i=1,nd
          DO j=1,nd
            DO k = 1,nd
              ke(i,j)=ke(i,j)+ev(k,i)*me(k,j)
            ENDDO
          ENDDO
        ENDDO
C
        RETURN

pr_deb()

subroutine pr_deb	(	integer	nddl,
		integer, dimension(*)	iddl,
		integer, dimension(*)	ndof,
		integer, dimension(*)	ikc,
		integer, dimension(*)	itab,
			diag_k,
			diag_m,
		integer, dimension(*)	inloc,
		integer, dimension(*)	fr_elem,
		integer, dimension(2,*)	iad_elem,
		integer, dimension(*)	iadk,
		integer, dimension(*)	jdik,
			lt_k,
			lt_m,
		integer	nddli,
		integer, dimension(*)	iadi,
		integer, dimension(*)	jdii,
		integer, dimension(*)	itok,
			diag_i,
			lt_i,
			u,
			f,
		integer	it,
		integer	nsrem,
		integer	nsl,
			d,
			dr,
		integer	iflag,
		integer, dimension(*)	w_ddl,
			fext,
			mext,
			fint,
			mint,
			r01,
		integer	ndeb,
		integer, dimension(*)	nodglob )

Definition at line 5553 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE imp_frk
        USE imp_intm
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "com04_c.inc"
#include      "task_c.inc"
#include      "impl1_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
        INTEGER NDDL  ,IDDL(*) ,NDOF(*)   ,IKC(*)   ,ITAB(*),IFLAG,
     .          FR_ELEM(*),IAD_ELEM(2,*),INLOC(*),IADK(*),JDIK(*),NODGLOB(*),
     .          NDDLI,IADI(*),JDII(*),ITOK(*),IT,NSREM  ,NSL,W_DDL(*),NDEB
        my_real
     .    diag_k(*),diag_m(*),lt_k(*),lt_m(*) ,diag_i(*),lt_i(*),
     .    u(*),f(*),d(3,*),dr(3,*),fext(3,*),mext(3,*),fint(3,*),
     .    r01 ,mint(3,*),vq(3,3)
C-----------------------------------------------
c FUNCTION: print-out selected values in function of Ifalg
c
c Note:
c ARGUMENTS:  (I: input, O: output, IO: input * output, W: workspace)
c
c TYPE NAME                FUNCTION
c  I   NDDL,NDOF(N)      - num. of total DOF after condensation; Num of DOF of node N
c  I   IDDL(N)           - ID of DOF (before condensation) num of node N: IDDL(N)+1,NDOF(N)
c  I   IKC(NDDL0)        - different independent dof, IKC()=0-> independent dof
c  I   ITAB(N)           - user's node id
c  I   IADK(NDDL+1),JDIK(NNZ)-indices of assemblaged [K] of compressed format
c  I   DIAG_K(NDDL),LT_K(NNZ)-diag_[K] and compressed non zero strick trianluar [K]
c  I   IADM(NDDL+1),JDIM(NNZ)-same than [K], [M]: preconditioner matrix used for PCG only
c  I   DIAG_M(NDDL),LT_M(NNZ)-
c  I   IADI(NDDLI+1),JDII(NNZI)-indices of local [K_i] of contact spring
c  I   ITOK(NDDLI),DIAG_I(NDDL),LT_I(NNZ)- indice from local to glocal [K]
c  I   NSREM ,NSL        -remote SECONDARY and local communated SECONDARY node number (due to // contact)
c  I   U(NDDL),F(NDDL)   - U not available, F-> force Residual {Fext}-{Fint}
c  I   IT                -nonlinear iteration number
c  I   D,DR(3,NUMNOD)    -nodal displacement and rotation
c  I   IFLAG             -print-out options ,see below
c  I   W_DDL             -flag of physical presence of the boundary dof of diff. domains //
c  I   FEXT,MEXT(3,NUMNOD)- external nodal forces and moments
c  I   FINT,MINT(3,NUMNOD)- internal nodal forces and moments
c  I   R01                -force residual norm
c  I   Ndeb               begin of debugging No of cycle.
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
Ctmp +3
        INTEGER i,j,N,ID,ND,IDDLM(NUMNOD),NKC,IDF,nnod,nk,iad,iad2,id2,
     .          IDDL_FRONT(NDDL),ID2N(NUMNOD),NKFRONT,INOD,K,NN,II,
     .          IDDL_FRONT1(NSPMD,NDDL),ITAG(2,NSPMD),INDEX,ILOC,JJ,KK
        CHARACTER CHIF
        CHARACTER*9 FILNAME
        my_real
     .    s_max,xl,yl,zl
C------iflag=1 ->U,F;iflag=2 ->+ [ki];iflag=3 ->+ [k];--iflag=4 ->+[m];
        idf = ispmd+11
        WRITE(chif,'(I1)')ispmd
        filname='DEB'//chif//'.TMP'
        OPEN(unit=idf,file=filname,status='UNKNOWN',form='FORMATTED')
        write(idf,*)'NCYCLE,IT,NUMNOD,NDDL=',ncycle,it,numnod,nddl
        write(idf,*)'NDDLI,NSREM,NSL,IMCONV,NDEB=', nddli,nsrem ,nsl,
     .                imconv,ndeb
        if (imconv==-1.and.(nsrem +nsl)==0) then
          return
        end if
        write(idf,*)'R01=',r01
c        write(IDF,*)'nddlfr=',nddlfr
        if (ncycle==(ndeb+1).AND.it==0.AND.imconv>=0) then
          nkc=0
          DO n =1,numnod
            i=inloc(n)
            iddlm(i)=iddl(i)-nkc
            DO j=1,ndof(i)
              nd = iddl(i)+j
              IF (ikc(nd)/=0) nkc = nkc + 1
            ENDDO
c       if (NDOF(I)/=0)
            write(idf,*)'I,ITAB,NDOF,IDDLM=',i,itab(i),ndof(i),
     .                    iddlm(i),nodglob(i)
          ENDDO
        endif
c        if (NSPMD==1) then
c         I = 849965
        ii=0
        s_max=zero
        nn =0
        k=0
        nkc=0
        DO n =1,numnod
          i=inloc(n)
          iddlm(i)=iddl(i)-nkc
          jj=0
          DO j=1,ndof(i)
            nd = iddl(i)+j
            IF (ikc(nd)/=0) THEN
              nkc = nkc + 1
            ELSE
              jj = jj + 1
              id =iddlm(i) + jj
              id2n(id)=i
              write(idf,*)'DIAG_K,F,N,id=',diag_k(id),f(id),itab(i),id
              if (abs(f(id))>s_max) THEN
                s_max= abs(f(id))
                ii = id
                nn = i
                k=j
              endif
            END IF
          ENDDO
        ENDDO
        if (nn>0) write(idf,*)'MAX_F,N,J=',f(ii),itab(nn),k
c        DO N =1,NDDL
c         I = ITOK(N)
c         I = N
c         write(IDF,*),'NC,DIAG_k,DIAG_M=',
c     .      IADK(I+1)-IADK(I),DIAG_K(I),DIAG_M(I)
c         write(IDF,*)'DIAG_K,F(I)=',DIAG_K(I),F(I),I
c         if (abs(f(i))>S_MAX) THEN
c         S_MAX= abs(f(i))
c         II = I
c         endif
c        ENDDO
c         write(IDF,*)'MAX_F=',F(II),II
        if (iflag>1) then
          DO n =1,numnod
            i=inloc(n)
            write(idf,*)'FEXT,MEXT,I,ITAB=',i,itab(i)
            write(idf,*)fext(1,i),fext(2,i),fext(3,i)
            IF (iroddl/=0)write(idf,*)mext(1,i),mext(2,i),mext(3,i)
          ENDDO
          DO n =1,numnod
            i=inloc(n)
            write(idf,*)'FINT,MINT,I,ITAB=',i,itab(i)
            write(idf,*)fint(1,i),fint(2,i),fint(3,i)
c         IF (IRODDL/=0)write(IDF,*)MINT(1,I),MINT(2,I),MINT(3,I)
c         XL = VQ(1,1)*FINT(1,I)+ VQ(1,2)*FINT(2,I)+VQ(1,3)*FINT(3,I)
c         YL = VQ(2,1)*FINT(1,I)+ VQ(2,2)*FINT(2,I)+VQ(2,3)*FINT(3,I)
c         ZL = VQ(3,1)*FINT(1,I)+ VQ(3,2)*FINT(2,I)+VQ(3,3)*FINT(3,I)
c         write(IDF,*)'FINT,local=',I,ITAB(I)
c         write(IDF,*)XL,YL,ZL
          ENDDO
        endif
        if (iflag>=1) then
          DO n =1,numnod
            i=inloc(n)
c          if (NDOF(I)/=0) then
            write(idf,*)'D,DR,I,ITAB=',i,itab(i)
            write(idf,*)d(1,i),d(2,i),d(3,i)
            IF (iroddl/=0)write(idf,*)dr(1,i),dr(2,i),dr(3,i)
c          end if !(NDOF(I)/=0) then
          ENDDO
        endif
        if (nspmd>1) then
C
          IF (intp_d>0) THEN
            write(idf,*)'NDDL_SL,NDDL_SI=',nddl_sl,nddl_si
            DO i=1,nsl
              n=isl(i)
              write (idf,*)'NS,I=',n,itab(n),i
            END DO
            DO i=1,nddl_sl
              id=iddl_sl(i)
              write(idf,*)'ID,DIAG_SL=',id,diag_sl(i)
            END DO
            DO i=1,nddl_sl
              DO j = iad_ss(i), iad_ss(i+1)-1
                write(idf,*)'LT_SL,NJ,J=',lt_sl(j),jdi_sl(j),j
              END DO
            END DO
            write (idf,*)'NDDL_SI=',nddl_si
            DO i=1,nddl_si
              DO j = iad_si(i), iad_si(i+1)-1
                write(idf,*)'LT_SI,NJ,J=',lt_si(j),jdi_si(j),j
              END DO
            END DO
          ELSE
            DO i=1,nsl
              n=isl(i)
              DO j=1,min(3,ndof(n))
                id = iddsl(j,i)
                IF (id>0) write(idf,*)'ID,DIAG_SL=',id,diag_s(j,i)
              END DO
              write (idf,*)'NS,I=',n,i
            END DO
          END IF
          iad = 0
          iad2 = 0
          write(idf,*)'LEN_K,LEN_V=',len_k,len_v
          DO i =1,nspmd
            nkc=0
            DO nk=iad_elem(1,i),iad_elem(1,i+1)-1
              n=fr_elem(nk)
              nd=0
              write(idf,*)'N,ITAB,IDDLFR,IP=',n,itab(n),iddlfr(nk),i
              DO j=1,ndof(n)
                IF (ikc(iddl(n)+j)<1) THEN
c          ND=ND+1
                  id=iddlfr(nk)+iad-nkc+j
                  id2=iddlfr(nk)+iad2-nkc+j
                  write(idf,*)
     .            'FR_ID,id2,id2k,NC=',id,id2,ifr2k(id2),iadfr(id+1)-iadfr(id)
                  IF (iadfr(id+1)<iadfr(id)) write(idf,*)iadfr(id+1),iadfr(id)
                ELSE
                  nkc=nkc+1
                ENDIF
              ENDDO
            ENDDO
            iad = iad + nd_fr(i) + 1
            iad2 = iad2 + nd_fr(i)
          ENDDO
        endif
        if (iflag>=1) then
          write(idf,*)'[Ki]=',nddli
          DO i =1,nddli
            n=id2n(itok(i))
            write(idf,*)'DIAG_I,itok,N=',diag_i(i),itok(i),itab(n)
          ENDDO
          DO i =1,nddli
            n=id2n(itok(i))
            write(idf,*)'NR,I(itok),N=',iadi(i+1)-iadi(i),itok(i),itab(n)
            DO j=iadi(i),iadi(i+1)-1
              n=id2n(itok(jdii(j)))
              write(idf,*)'LT_I,_id_NJ,NJ,J=',lt_i(j),itok(jdii(j)),itab(n),j
            ENDDO
          ENDDO
        endif
        if (iflag>1) then
          write(idf,*)'LT_[K]=',nddl
          DO i =1,nddl
            write(idf,*)'NR,I=',iadk(i+1)-iadk(i),i
            DO j=iadk(i),iadk(i+1)-1
              write(idf,*)'LT_K,NJ,J=',lt_k(j),jdik(j),j
            ENDDO
          ENDDO
        endif
C------------------------------------------
        RETURN

pr_infok()

subroutine pr_infok	(	integer	nddl0,
		integer	nnzk0,
		integer	nddl,
		integer	nnzk,
		integer	nnmax )

Definition at line 2144 of file imp_solv.F.

C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "units_c.inc"
#include      "task_c.inc"
#include      "impl1_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
        INTEGER NDDL0,NNZK0,NDDL,NNZK,NNMAX
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER NDDLG0,NNZKG0,NDDLG,NNZKG,NNMAXG,NNMAX0
        INTEGER NDDL0P(NSPMD),NNZK0P(NSPMD),NDDLP(NSPMD) ,
     .          NNZKP(NSPMD),NNMAXP(NSPMD),I
C------------------------------------------
        IF (nspmd>1) THEN
          nddlg0 = nddl0
          nnzkg0 = nnzk0
          nddlg = nddl
          nnzkg = nnzk
          nnmaxg = nnmax
          CALL spmd_inf_g(
     1     nddlg0   ,nnzkg0  ,nddlg    ,nnzkg    ,nnmaxg    ,
     2     nddl0p   ,nnzk0p  ,nddlp    ,nnzkp    ,nnmaxp    )
          IF (ispmd==0) THEN
            IF (imp_chk>0) THEN
              WRITE(iout,*)
              WRITE(iout,*)'  *--------- STIFFNESS MATRIX INFO. ---------*'
              WRITE(iout,1001)nddlg0,nnzkg0,nnmaxg
              WRITE(iout,*)
              DO i=1,nspmd
                WRITE(iout,1003)i,nddl0p(i),nnzk0p(i),nnmaxp(i)
              ENDDO
              WRITE(iout,*)
              WRITE(iout,1002)nddlg,nnzkg,nnmaxg
              WRITE(iout,*)
              DO i=1,nspmd
                WRITE(iout,1003)i,nddlp(i),nnzkp(i),nnmaxp(i)
              ENDDO
            ELSE
              WRITE(iout,*)
              WRITE(istdo,*)
              WRITE(iout,*)'  *--------- STIFFNESS MATRIX SETUP ---------*'
              WRITE(istdo,*)'  *--------- STIFFNESS MATRIX SETUP ---------*'
              WRITE(iout,1001)nddlg0,nnzkg0,nnmaxg
              WRITE(istdo,1001)nddlg0,nnzkg0,nnmaxg
              WRITE(iout,*)
              WRITE(istdo,*)
              DO i=1,nspmd
                WRITE(iout,1003)i,nddl0p(i),nnzk0p(i),nnmaxp(i)
                WRITE(istdo,1003)i,nddl0p(i),nnzk0p(i),nnmaxp(i)
              ENDDO
              WRITE(iout,*)
              WRITE(istdo,*)
              WRITE(iout,1002)nddlg,nnzkg,nnmaxg
              WRITE(istdo,1002)nddlg,nnzkg,nnmaxg
              WRITE(iout,*)
              WRITE(istdo,*)
              DO i=1,nspmd
                WRITE(iout,1003)i,nddlp(i),nnzkp(i),nnmaxp(i)
                WRITE(istdo,1003)i,nddlp(i),nnzkp(i),nnmaxp(i)
              ENDDO
C          IF (L_LIM==0) L_LIM=NDDLG
            ENDIF
          ENDIF
        ELSE
          IF (imp_chk>0) THEN
            WRITE(iout,*)
            WRITE(iout,*)'  *--------- STIFFNESS MATRIX INFO. ---------*'
            WRITE(iout,1001)nddl0,nnzk0,nnmax
            WRITE(iout,1002)nddl,nnzk,nnmax
            WRITE(iout,*)
          ELSE
            WRITE(iout,*)
            WRITE(istdo,*)
            WRITE(iout,*)'  *--------- STIFFNESS MATRIX SETUP ---------*'
            WRITE(istdo,*)'  *--------- STIFFNESS MATRIX SETUP ---------*'
            WRITE(iout,1001)nddl0,nnzk0,nnmax
            WRITE(istdo,1001)nddl0,nnzk0,nnmax
            WRITE(iout,1002)nddl,nnzk,nnmax
            WRITE(istdo,1002)nddl,nnzk,nnmax
            WRITE(iout,*)
            WRITE(istdo,*)
          ENDIF
          IF (l_lim==0) l_lim=nddl
        ENDIF
 1001   FORMAT(' SYMBOLIC DIM : ND =',i8,1x,'NZ =',i10,1x,'NB_MAX =',i8)
 1002   FORMAT(' FINAL    DIM : ND =',i8,1x,'NZ =',i10,1x,'NB_MAX =',i8)
 1003   FORMAT(' PROC=',i5,5x,'ND =',i8,1x,'NZ =',i10,1x,'NB_MAX =',i8)
C------------------------------------------
        RETURN

pr_matrix()

subroutine pr_matrix	(	integer	nddl,
		integer, dimension(*)	iddl,
		integer, dimension(*)	ndof,
		integer, dimension(*)	ikc,
		integer, dimension(*)	itab,
			diag_k,
			diag_m,
		integer, dimension(*)	inloc,
		integer, dimension(*)	fr_elem,
		integer, dimension(2,*)	iad_elem,
		integer, dimension(*)	iadk,
		integer, dimension(*)	jdik,
			lt_k,
			lt_m,
		integer	nddli,
		integer, dimension(*)	iadi,
		integer, dimension(*)	jdii,
		integer, dimension(*)	itok,
			diag_i,
			lt_i,
		integer	iflag,
		integer	it )

Definition at line 5814 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE imp_frk
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "com04_c.inc"
#include      "task_c.inc"
#include      "impl1_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
        INTEGER NDDL  ,IDDL(*) ,NDOF(*)   ,IKC(*)   ,ITAB(*),IFLAG,
     .          FR_ELEM(*),IAD_ELEM(2,*),INLOC(*),IADK(*),JDIK(*),
     .          NDDLI,IADI(*),JDII(*),ITOK(*),it
        my_real
     .    diag_k(*),diag_m(*),lt_k(*),lt_m(*) ,diag_i(*),lt_i(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
Ctmp +3
        INTEGER i,j,N,ID,ND,IDDLM(NUMNOD),NKC,IDF,nnod,nk,iad,iad2,id2,
     .          NKFRONT,INOD,K,NN,II,INDEX,ILOC,JJ,KK
        CHARACTER CHIF
        CHARACTER*9 FILNAME
        my_real
     .    s_max,xl,yl,zl
C------
        idf = ispmd+15
        WRITE(chif,'(I1)')ispmd
        filname='MAT'//chif//'.TMP'
        OPEN(unit=idf,file=filname,status='UNKNOWN',form='FORMATTED')
        write(idf,*)'NCYCLE,NUMNOD,NDDL,NDI=',ncycle,numnod,nddl,nddli
        if (imconv<0) return
c        write(IDF,*)'nddlfr=',nddlfr
        if (ncycle==1) then
          nkc=0
          DO n =1,numnod
            i=inloc(n)
            iddlm(i)=iddl(i)-nkc
            DO j=1,ndof(i)
              nd = iddl(i)+j
              IF (ikc(nd)/=0) nkc = nkc + 1
            ENDDO
            if (ndof(i)/=0)
     .       write(idf,*)'I,ITAB,NDOF,IDDL=',i,itab(i),ndof(i),
     .                     iddl(i)
          ENDDO
        endif
        DO n =1,nddl
          i = n
c         write(IDF,*),'NC,DIAG_k,DIAG_M=',
c     .      IADK(I+1)-IADK(I),DIAG_K(I),DIAG_M(I)
          write(idf,*)'DIAG_K,DIAG_M=',diag_k(i),diag_m(i),i
        ENDDO
        if (nspmd>1) then
C
          iad = 0
          iad2 = 0
          write(idf,*)'LEN_K,LEN_V=',len_k,len_v
          DO i =1,nspmd
            nkc=0
            DO nk=iad_elem(1,i),iad_elem(1,i+1)-1
              n=fr_elem(nk)
              nd=0
              write(idf,*)'N,ITAB,IDDLFR,IP=',n,itab(n),iddlfr(nk),i
              DO j=1,ndof(n)
                IF (ikc(iddl(n)+j)<1) THEN
c          ND=ND+1
                  id=iddlfr(nk)+iad-nkc+j
                  id2=iddlfr(nk)+iad2-nkc+j
                  write(idf,*)
     .            'FR_ID,id2,id2k,NC=',id,id2,ifr2k(id2),iadfr(id+1)-iadfr(id)
                  IF (iadfr(id+1)<iadfr(id)) write(idf,*)iadfr(id+1),iadfr(id)
                ELSE
                  nkc=nkc+1
                ENDIF
              ENDDO
            ENDDO
            iad = iad + nd_fr(i) + 1
            iad2 = iad2 + nd_fr(i)
          ENDDO
        endif
        if (nddli>0.AND.iflag>0) then
          write(idf,*)'[Ki]=',nddli
          DO i =1,nddli
            write(idf,*)'DIAG_I,itok=',diag_i(i),itok(i)
          ENDDO
          DO i =1,nddli
            write(idf,*)'NR,I=',iadi(i+1)-iadi(i),i
            DO j=iadi(i),iadi(i+1)-1
              write(idf,*)'LT_I,NJ,J=',lt_i(j),itok(jdii(j)),j
            ENDDO
          ENDDO
        endif
        if (nddl>1.and.iflag>1) then
          write(idf,*)'LT_[K]=',nddl
          DO i =1,nddl
            write(idf,*)'NR,I=',iadk(i+1)-iadk(i),i
            DO j=iadk(i),iadk(i+1)-1
              write(idf,*)'LT_K,NJ,J=',lt_k(j),jdik(j),j
            ENDDO
          ENDDO
          if (iflag>1) then
            write(idf,*)'LT_[M]=',nddl
            DO i =1,nddl
              write(idf,*)'NR,I=',iadk(i+1)-iadk(i),i
              DO j=iadk(i),iadk(i+1)-1
                write(idf,*)'LT_M,NJ,J=',lt_m(j),jdik(j),j
              ENDDO
            ENDDO
          endif !(IFLAG>1) then
        endif
C------------------------------------------
        RETURN

pr_solnfo()

subroutine pr_solnfo	(	integer	nddl,
		integer, dimension(*)	iddl,
		integer, dimension(*)	ndof,
		integer, dimension(*)	ikc,
		integer, dimension(*)	itab,
			diag_k,
			diag_m,
		integer, dimension(*)	inloc,
		integer, dimension(*)	fr_elem,
		integer, dimension(2,*)	iad_elem,
		integer, dimension(*)	iadk,
		integer, dimension(*)	jdik,
			lt_k,
			lt_m,
		integer	nddli,
		integer, dimension(*)	iadi,
		integer, dimension(*)	jdii,
		integer, dimension(*)	itok,
			diag_i,
			lt_i,
			u,
			f,
		integer	it,
		integer	nsrem,
		integer	nsl,
			d,
			dr,
		integer	iflag,
		integer, dimension(*)	w_ddl,
			fext,
			mext,
			fint,
			mint,
			r01,
		integer	ndeb,
			r_imp,
		integer, dimension(*)	i_imp,
			dd,
			ddr )

Definition at line 5952 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE imp_frk
        USE imp_intm
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "com04_c.inc"
#include      "com08_c.inc"
#include      "task_c.inc"
#include      "impl1_c.inc"
#include      "impl2_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
        INTEGER NDDL  ,IDDL(*) ,NDOF(*)   ,IKC(*)   ,ITAB(*),IFLAG,
     .          FR_ELEM(*),IAD_ELEM(2,*),INLOC(*),IADK(*),JDIK(*),
     .          NDDLI,IADI(*),JDII(*),ITOK(*),IT,NSREM  ,NSL,W_DDL(*),
     .          NDEB,I_IMP(*)
        my_real
     .    diag_k(*),diag_m(*),lt_k(*),lt_m(*) ,diag_i(*),lt_i(*),
     .    u(*),f(*),d(3,*),dr(3,*),fext(3,*),mext(3,*),fint(3,*),
     .    r01 ,mint(3,*),vq(3,3),r_imp(*),dd(3,*),ddr(3,*)
C-----------------------------------------------
c FUNCTION: print-out solver info such as maximum residual, relative residuals, line-search coefficient, tolerance
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER I,J,N,ID,ND,IDDLM(NUMNOD),NKC,IDF,NNOD,NK,IAD,IAD2,
     .          IDDL_FRONT(NDDL),ID2N(NUMNOD),NKFRONT,INOD,ID2,CUMUL_IT,
     .          IDDL_FRONT1(NSPMD,NDDL),ITAG(2,NSPMD),INDEX,ILOC,JJ,KK,
     .          K,K2,K3,KR,K2R,K3R,NN,NN2,NN3,NNR,NN2R,NN3R,II,IIR,II2,
     .          ITABMAX,IRTABMAX,ITABMAX2,IRTABMAX2,ITABMAX3,IRTABMAX3
        my_real
     .    f_max,fr_max,d_max,dr_max,dd_max,ddr_max,
     .    fmax,frmax,dmax,drmax,ddmax,ddrmax,tole,tolf,tolu
        CHARACTER NODEID*10,FILNAM*100
c       if (IMCONV==-1.and.(NSREM +NSL)==0) then
c         return
c       end if
c       if (NCYCLE==(NDEB+1).AND.IT==0.AND.IMCONV>=0) then
c        NKC=0
c       DO N =1,NUMNOD
c        I=INLOC(N)
c        IDDLM(I)=IDDL(I)-NKC
c        DO J=1,NDOF(I)
c         ND = IDDL(I)+J
c         IF (IKC(ND)/=0) NKC = NKC + 1
c        ENDDO
c       ENDDO
c       endif
        ii=0
        iir=0
        f_max=zero
        fr_max=zero
        d_max=zero
        dr_max=zero
        dd_max=zero
        ddr_max=zero
        fmax=zero
        frmax=zero
        dmax=zero
        drmax=zero
        ddmax=zero
        ddrmax=zero
        nn=0
        nn2=0
        nn3=0
        k=0
        k2=0
        k3=0
        nnr=0
        nn2r=0
        nn3r=0
        kr=0
        k2r=0
        k3r=0
        nkc=0
        DO n =1,numnod
          i=inloc(n)
          iddlm(i)=iddl(i)-nkc
          jj=0
          DO j=1,ndof(i)
            nd = iddl(i)+j
            IF (ikc(nd)/=0) THEN
              nkc = nkc + 1
            ELSE
              jj = jj + 1
              id =iddlm(i) + jj
              id2 = iddlm(i)
c          ID2N(ID)=I
              IF (j < 4) THEN
                IF (abs(f(id))>f_max) THEN
                  f_max= abs(f(id))
                  ii = id
                  nn = i
                  k = j
                ENDIF
                IF (abs(d(j,i))>d_max) THEN
                  d_max= abs(d(j,i))
                  nn2 = i
                  k2 = j
                ENDIF
                IF (abs(dd(j,i))>dd_max) THEN
                  dd_max= abs(dd(j,i))
                  nn3 = i
                  k3 = j
                ENDIF
              ELSE
                IF (abs(f(id))>fr_max) THEN
                  fr_max= abs(f(id))
                  iir = id
                  nnr = i
                  kr = j
                ENDIF
                IF (abs(dr(j-3,i))>dr_max) THEN
                  dr_max= abs(dr(j-3,i))
                  nn2r = i
                  k2r = j
                ENDIF
                IF (abs(ddr(j-3,i))>ddr_max) THEN
                  ddr_max= abs(ddr(j-3,i))
                  nn3r = i
                  k3r = j
                ENDIF
              ENDIF
            ENDIF
          ENDDO
        ENDDO
        IF (ii /= 0) fmax = f(ii)
        itabmax = itab(nn)
        IF (iir /= 0) frmax = f(iir)
        irtabmax = itab(nnr)
        IF (nn2 /= 0) dmax = d(k2,nn2)
        itabmax2 = itab(nn2)
        IF (nn2r /= 0) drmax = dr(k2r-3,nn2r)
        irtabmax2 = itab(nn2r)
        IF (nn3 /= 0) ddmax = dd(k3,nn3)
        itabmax3 = itab(nn3)
        IF (nn3r /= 0) ddrmax = ddr(k3r-3,nn3r)
        irtabmax3 = itab(nn3r)
c      Compute maximum value F(II) with several processes in SPMD
        IF (nspmd>1) THEN
          CALL spmd_max_f(fmax,itabmax,k)
          CALL spmd_max_f(dmax,itabmax2,k2)
          CALL spmd_max_f(ddmax,itabmax3,k3)
          CALL spmd_max_f(frmax,irtabmax,kr)
          CALL spmd_max_f(drmax,irtabmax2,k2r)
          CALL spmd_max_f(ddrmax,irtabmax3,k3r)
        END IF
c      Write solver information
        IF (ispmd==0) THEN
          IF (it == zero) THEN
            WRITE(isolinfo,1667) ncycle
          ENDIF
          WRITE(isolinfo,1060) it
          WRITE(isolinfo,1066) fmax,itabmax,k
          WRITE(isolinfo,1064) dmax,itabmax2,k2
          WRITE(isolinfo,1062) ddmax,itabmax3,k3
          WRITE(isolinfo,1065) frmax,irtabmax,kr
          WRITE(isolinfo,1063) drmax,irtabmax2,k2r
          WRITE(isolinfo,1061) ddrmax,irtabmax3,k3r
          WRITE (nodeid,'(I10)') itabmax
          cumul_it = i_imp(1)+it
c        Write monitor file
          IF (k==0) THEN
            WRITE(isolmntr,1160) cumul_it,0,' MaxResidualForce  ',nodeid//'  ',fmax
          ELSEIF (k==1) THEN
            WRITE(isolmntr,1160) cumul_it,0,' MaxResidualForce  ',nodeid//'_X',fmax
          ELSEIF (k==2) THEN
            WRITE(isolmntr,1160) cumul_it,0,' MaxResidualForce  ',nodeid//'_Y',fmax
          ELSEIF (k==3) THEN
            WRITE(isolmntr,1160) cumul_it,0,' MaxResidualForce  ',nodeid//'_Z',fmax
          ENDIF
c         WRITE (NODEID,'(I10)') ITABMAX2
c         IF (K2==0) THEN
c           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxIncrementDisp  ',NODEID//'  ',DMAX
c         ELSEIF (K2==1) THEN
c           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxIncrementDisp  ',NODEID//'_X',DMAX
c         ELSEIF (K2==2) THEN
c           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxIncrementDisp  ',NODEID//'_Y',DMAX
c         ELSEIF (K2==3) THEN
c           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxIncrementDisp  ',NODEID//'_Z',DMAX
c         ENDIF
          WRITE (nodeid,'(I10)') itabmax3
          IF (k3==0) THEN
            WRITE(isolmntr,1160) cumul_it,0,' MaxCorrectionDisp ',nodeid//'  ',ddmax
          ELSEIF (k3==1) THEN
            WRITE(isolmntr,1160) cumul_it,0,' MaxCorrectionDisp ',nodeid//'_X',ddmax
          ELSEIF (k3==2) THEN
            WRITE(isolmntr,1160) cumul_it,0,' maxcorrectiondisp ',NODEID//'_y',DDMAX
          ELSEIF (K3==3) THEN
            WRITE(ISOLMNTR,1160) CUMUL_IT,0,' maxcorrectiondisp ',NODEID//'_z',DDMAX
          ENDIF
          WRITE (NODEID,'(i10)') IRTABMAX
          IF (KR==0) THEN
            WRITE(ISOLMNTR,1160) CUMUL_IT,0,' maxresidualmoment ',NODEID//'  ',FRMAX
          ELSEIF (KR==4) THEN
            WRITE(ISOLMNTR,1160) CUMUL_IT,0,' maxresidualmoment ',NODEID//'_x',FRMAX
          ELSEIF (KR==5) THEN
            WRITE(ISOLMNTR,1160) CUMUL_IT,0,' maxresidualmoment ',NODEID//'_y',FRMAX
          ELSEIF (KR==6) THEN
            WRITE(ISOLMNTR,1160) CUMUL_IT,0,' maxresidualmoment ',NODEID//'_z',FRMAX
          ENDIF
c         WRITE (NODEID,'(I10)') IRTABMAX2
c         IF (K2R==0) THEN
c           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxIncrementRota  ',NODEID//'  ',DRMAX
c         ELSEIF (K2R==4) THEN
c           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxIncrementRota  ',NODEID//'_X',DRMAX
c         ELSEIF (K2R==5) THEN
c           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxIncrementRota  ',NODEID//'_Y',DRMAX
c         ELSEIF (K2R==6) THEN
c           WRITE(ISOLMNTR,1160) CUMUL_IT,0,' MaxIncrementRota  ',NODEID//'_Z',DRMAX
c         ENDIF
          WRITE (NODEID,'(i10)') IRTABMAX3
          IF (K3R==0) THEN
            WRITE(ISOLMNTR,1160) CUMUL_IT,0,' maxcorrectionrota ',NODEID//'  ',DDRMAX
          ELSEIF (K3R==4) THEN
            WRITE(ISOLMNTR,1160) CUMUL_IT,0,' maxcorrectionrota ',NODEID//'_x',DDRMAX
          ELSEIF (K3R==5) THEN
            WRITE(ISOLMNTR,1160) CUMUL_IT,0,' maxcorrectionrota ',NODEID//'_y',DDRMAX
          ELSEIF (K3R==6) THEN
            WRITE(ISOLMNTR,1160) CUMUL_IT,0,' maxcorrectionrota ',NODEID//'_z',DDRMAX
          ENDIF
          WRITE(NODEID,'(i10)') 0
          WRITE(ISOLMNTR,1160) CUMUL_IT,0,' normresidualdisp  ',NODEID//'  ',R_IMP(20)
          WRITE(ISOLMNTR,1160) CUMUL_IT,0,' normresidualforce ',NODEID//'  ',R_IMP(21)
          WRITE(ISOLMNTR,1160) CUMUL_IT,0,' normresidualenergy',NODEID//'  ',R_IMP(22)
          WRITE(ISOLMNTR,1160) CUMUL_IT,0,' dimcontactmatrix  ',nodeid//'  ',float(i_imp(13))
          WRITE(isolmntr,1160) cumul_it,0,' TimeStep          ',nodeid//'  ',dt2
C         CALL MY_FLUSH(ISOLMNTR)
          CALL flush(isolmntr)
          IF (imconv == 1) THEN
            IF (nitol == 1) THEN
              WRITE(isolinfo,1067)
            ELSE IF (nitol == 2) THEN
              WRITE(isolinfo,1069)
            ELSE IF (nitol == 3) THEN
              WRITE(isolinfo,1071)
            ELSE IF (nitol == 12) THEN
              WRITE(isolinfo,1073)
            ELSE IF (nitol == 13) THEN
              WRITE(isolinfo,1075)
            ELSE IF (nitol == 23) THEN
              WRITE(isolinfo,1077)
            ELSE IF (nitol == 123) THEN
              WRITE(isolinfo,1079)
            END IF
          ELSE IF (imconv == -2) THEN
            IF (nitol == 1) THEN
              WRITE(isolinfo,1068)
            ELSE IF (nitol == 2) THEN
              WRITE(isolinfo,1070)
            ELSE IF (nitol == 3) THEN
              WRITE(isolinfo,1072)
            ELSE IF (nitol == 12) THEN
              WRITE(isolinfo,1074)
            ELSE IF (nitol == 13) THEN
              WRITE(isolinfo,1076)
            ELSE IF (nitol == 23) THEN
              WRITE(isolinfo,1078)
            ELSE IF (nitol == 123) THEN
              WRITE(isolinfo,1080)
            END IF
          ENDIF
          IF (nitol == 1) THEN
            tole = n_tol
            tolf = em02
            tolu = em02
          ELSE IF (nitol == 2) THEN
            tole = em03
            tolf = n_tol
            tolu = em02
          ELSE IF (nitol == 3) THEN
            tole = em03
            tolf = em02
            tolu = n_tol
          ELSE IF (nitol == 12) THEN
            tole = n_tole
            tolf = n_tolf
            tolu = em02
          ELSE IF (nitol == 13) THEN
            tole = n_tole
            tolf = em02
            tolu = n_tolu
          ELSE IF (nitol == 23) THEN
            tole = em03
            tolf = n_tolf
            tolu = n_tolu
          ELSE IF (nitol == 123) THEN
            tole = n_tole
            tolf = n_tolf
            tolu = n_tolu
          END IF
          IF (imconv == -1) THEN
c         Nothing since line search not ended
          ELSEIF (imconv == 0) THEN
            WRITE(isolhist,1666)cumul_it+1,ncycle,it,r_imp(20),
     .          r_imp(21),r_imp(22),tole,tolf,tolu,
     .          zero,zero,tt,r_imp(9)
          ELSEIF (imconv == 1) THEN
c         Converged step
            IF (idtc==3) THEN
              WRITE(isolhist,1668)cumul_it+1,ncycle,it,r_imp(20),
     .             r_imp(21),r_imp(22),tole,tolf,tolu,
     .             zero,zero,tt,r_imp(9),tt,r_imp(24)
              WRITE(isolhist,1668)cumul_it+1,ncycle,it,r_imp(20),
     .             r_imp(21),r_imp(22),tole,tolf,tolu,
     .             one,zero,tt,r_imp(9),tt,r_imp(24)
              WRITE(isolhist,1668)cumul_it+1,ncycle,it,r_imp(20),
     .             r_imp(21),r_imp(22),tole,tolf,tolu,
     .             zero,zero,tt,r_imp(9),tt,r_imp(24)
            ELSE
              WRITE(isolhist,1666)cumul_it+1,ncycle,it,r_imp(20),
     .             r_imp(21),r_imp(22),tole,tolf,tolu,
     .             zero,zero,tt,r_imp(9)
              WRITE(isolhist,1666)cumul_it+1,ncycle,it,r_imp(20),
     .             r_imp(21),r_imp(22),tole,tolf,tolu,
     .             one,zero,tt,r_imp(9)
              WRITE(isolhist,1666)cumul_it+1,ncycle,it,r_imp(20),
     .             r_imp(21),r_imp(22),tole,tolf,tolu,
     .             zero,zero,tt,r_imp(9)
            ENDIF
c         Write .progress file
            rewind(isolpgrs)
            WRITE(isolpgrs,'(I4)') cumul_it
            WRITE(isolpgrs,'(E11.4)') tt
            WRITE(isolpgrs,'(I4)') nint(tt/tstop*hundred)
            WRITE(isolpgrs,'(I4)') 0
            WRITE(isolpgrs,'(I4)') 0
            CALL flush(isolpgrs)
          ELSEIF (imconv == -2) THEN
c         Diverged step
            WRITE(isolhist,1666)cumul_it+1,ncycle,it,r_imp(20),
     .           r_imp(21),r_imp(22),tole,tolf,tolu,
     .           zero,zero,tt,r_imp(9)
            WRITE(isolhist,1666)cumul_it+1,ncycle,it,r_imp(20),
     .           r_imp(21),r_imp(22),tole,tolf,tolu,
     .           zero,one,tt,r_imp(9)
            WRITE(isolhist,1666)cumul_it+1,ncycle,it,r_imp(20),
     .           r_imp(21),r_imp(22),tole,tolf,tolu,
     .           zero,zero,tt,r_imp(9)
          ENDIF
        ENDIF
1060    FORMAT('       ITERATION',i4)
1061    FORMAT('           LARGEST CORRECTION ROTA.  ',e11.4,
     .         '   AT NODE  ',i10,'   DOF  ',i4)
1062    FORMAT('           LARGEST CORRECTION DISP.  ',e11.4,
     .         '   AT NODE  ',i10,'   DOF  ',i4)
1063    FORMAT('           LARGEST INCREMENT ROTA.   ',e11.4,
     .         '   AT NODE  ',i10,'   DOF  ',i4)
1064    FORMAT('           LARGEST INCREMENT DISP.   ',e11.4,
     .         '   AT NODE  ',i10,'   DOF  ',i4)
1065    FORMAT('           largest residual moment   ',E11.4,
     .         '   at node  ',I10,'   dof  ',I4)
1066    FORMAT('           largest residual force    ',E11.4,
     .         '   at node  ',I10,'   dof  ',I4)
1067    FORMAT('       accepted equilibrium based on small residual energy')
1068    FORMAT('       rejected equilibrium based on small residual energy')
1069    FORMAT('       accepted equilibrium based on small residual force')
1070    FORMAT('       rejected equilibrium based on small residual force')
1071    FORMAT('       accepted equilibrium based on small residual disp.')
1072    FORMAT('       rejected equilibrium based on small residual disp.')
1073    FORMAT('       accepted equilibrium based on small residual energy and force')
1074    FORMAT('       rejected equilibrium based on small residual energy and force')
1075    FORMAT('       accepted equilibrium based on small residual energy and disp.')
1076    FORMAT('       rejected equilibrium based on small residual energy and disp.')
1077    FORMAT('       accepted equilibrium based on small residual force and disp.')
1078    FORMAT('       rejected equilibrium based on small residual force and disp.')
1079    FORMAT('       accepted equilibrium based on small residual energy, force and disp.')
1080    FORMAT('       rejected equilibrium based on small residual energy, force and disp.')
1666    FORMAT(I10,',',I10,',',I10,',',E10.2,',',E10.2,',',e10.2,',',e10.2,',',e10.2,',',e10.2,',',e10.2,
     .         ',',e10.2,',',e10.2,',',e10.2)
1667    FORMAT('   * CYCLE',i6)
1668    FORMAT(i10,',',i10,',',i10,',',e10.2,',',e10.2,',',e10.2,',',e10.2,',',e10.2,',',e10.2,',',e10.2,
     .         ',',e10.2,',',e10.2,',',e10.2,',',e10.2,',',e10.2)
1160    FORMAT(i6,i6,a19,a12,e12.4)
C------------------------------------------
        RETURN

print_stif()

subroutine print_stif	(	integer, dimension(npari,ninter)	ipari,
		type(intbuf_struct_), dimension(*)	intbuf_tab,
		integer	iflag,
		integer	nn,
		integer	jg )

Definition at line 7043 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE tri7box
        USE intbufdef_mod
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "com04_c.inc"
#include      "units_c.inc"
#include      "param_c.inc"
#include      "task_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER IPARI(NPARI,NINTER)
        INTEGER IFLAG, NN     ,JG
        INTEGER LENS, LENR,P,N
        INTEGER IEDGE,NSN
 
        TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
C------------------------------------------
        return
        IF (nspmd==1) THEN
          nsn   =ipari(5,nn)
          n = 21
          if (ncycle>=81.and.ncycle<=81) then
c         write(iout,*)'IFLAG,ISPMD=',IFLAG,ISPMD
c         write(iout,*)'IRTLM(1,)=',INBUF(K1)
c      call my_flush(6)
          end if
        ELSE
          lens = 0
          lenr = 0
          DO p = 1, nspmd
            lens = lens + nsnsi(nn)%P(p)
            lenr = lenr + nsnfi(nn)%P(p)
          END DO
          if (ncycle>=80.and.ncycle<=81.AND.lenr >0) then
            write(iout,*)'IFLAG,ISPMD=',iflag,ispmd
            write(iout,*)'STIF_OLDFI()%P(1=',stif_oldfi(nn)%P(1,jg)
          end if
c      if (NCYCLE>=78.and.NCYCLE<=79.AND.LENS >0) then
c       N = 55
c       K1 = KD(16)+ 2*(N -1)
c         write(iout,*)'IFLAG,ISPMD=',IFLAG,ISPMD
c         write(iout,*)'IRTLM(1,N)=',INBUF(K1)
c      end if
        END IF !(NSPMD==1) THEN
        RETURN

pvp_k()

subroutine pvp_k	(	integer	nd,
		integer, dimension(*)	iadk,
		integer, dimension(*)	jdik,
		integer, dimension(*)	iddl,
		integer, dimension(*)	inloc,
		integer, dimension(*)	ndof,
		integer, dimension(*)	itab,
			k_diag,
			k_lt,
			lamda,
		integer	node,
			ms )

Definition at line 8711 of file imp_solv.F.

C----6---------------------------------------------------------------7---------8
        USE ecnd_mod
C----6---------------------------------------------------------------7---------8
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
#include      "units_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER ND,NODE
        INTEGER JDIK(*)  ,IADK(*),IDDL(*),INLOC(*),NDOF(*),ITAB(*)
C     REAL
        my_real
     .     k_diag(*) ,k_lt(*) ,lamda,ms(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER I,K,J,IK,ID,JD,L,N,NN,JJ,IDT
        my_real
     .     ke(nd,nd) ,ev(nd,nd),ew(nd),la,tol,msd(nd),msij,tol1
C----6----------------------------------
        tol=em5
        tol1=em10
        ke(1:nd,1:nd)=zero
        node = 0
        lamda = zero
        IF (ns10e==0) THEN
C-----taking into account to M-1
          DO n =1,numnod
            i=inloc(n)
            DO j=1,ndof(i)
              ik = iddl(i)+j
              msd(ik)=ms(i)
C----free node
              IF (msd(ik)<em20) msd(ik)=one
            ENDDO
          ENDDO
          DO k=1,nd
            ke(k,k) = k_diag(k)/msd(k)
            DO j = iadk(k),iadk(k+1)-1
              jd = jdik(j)
              msij=one/sqrt(msd(k))/sqrt(msd(jd))
              ke(k,jd) = k_lt(j)*msij
              ke(jd,k) = ke(k,jd)
            ENDDO
          ENDDO
        ELSE
C-------itet=2 (not dumped [M]), should not mix w/ other elements
          DO k=1,nd
            ke(k,k) = k_diag(k)
            DO j = iadk(k),iadk(k+1)-1
              jd = jdik(j)
              ke(k,jd) = k_lt(j)
              ke(jd,k) = ke(k,jd)
            ENDDO
          ENDDO
          CALL minv_k(nd  ,icnds10,iddl ,inloc,ndof,
     .                ms  ,tol ,ke   )
        END IF !(NS10E==0) THEN
        CALL jacobien(ke,nd,ew,ev,tol1,lamda)
C--- Node: N'Direction: J
        id = 0
        DO k=1,nd
          IF (ew(k)>=lamda) id = k
          IF (id > 0 ) cycle
        ENDDO
        DO n =1,numnod
          i=inloc(n)
          jj = 0
          DO j=1,ndof(i)
            ik = iddl(i)+j
            IF (ik==id) jj= j
          ENDDO
          IF (jj > 0) THEN
            node= n
            WRITE(iout,*)'1er EIGENVALUE(K/M) OF NODE+DIR:',lamda,itab(n),jj
            cycle
          END IF
        ENDDO
C
        RETURN

re2int5()

subroutine re2int5	(	integer	nt_imp,
		integer, dimension(*)	numimp,
		integer, dimension(*)	ns_imp,
		integer, dimension(*)	ne_imp,
		integer, dimension(ninter,*)	numimpl,
		integer, dimension(npari,*)	ipari,
		integer	nt_imp0 )

Definition at line 5268 of file imp_solv.F.

C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
#include      "task_c.inc"
#include      "param_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER  NT_IMP,NUMIMP(*),NS_IMP(*),NE_IMP(*),
     .           NUMIMPL(NINTER,*),IPARI(NPARI,*),NT_IMP0
C-----------------------------------------------
C   L o c a l  V a r i a b l e s
C-----------------------------------------------
        INTEGER I,J,K,L,N,IAD,IAD1,IADT,ITY,L_CP,L_CPJ,NIMPJ,
     .          IADN(NTHREAD)
        INTEGER, DIMENSION(:),ALLOCATABLE :: NS_CP,NE_CP
        INTEGER IER1
C-----------------------------------------------
C   S o u r c e  L i n e s
C-----------------------------------------------
C-----------------------------------------
        nt_imp = 0
        iadt = 0
        l_cpj = 0
        DO j = 1,nthread
          nimpj = iadt
          DO n = 1,ninter
            ity   =ipari(7,n)
            IF (ity==3.OR.ity==4.OR.ity==5) THEN
              numimp(n)=0
              iadt =iadt + numimpl(n,j)
            END IF
          END DO
          nimpj = -nimpj+iadt
          l_cpj = max(l_cpj,nimpj)
        END DO
        IF (iadt==0) RETURN
C
        IF (nthread==1) THEN
          DO n = 1,ninter
            numimp(n) =numimpl(n,1)
          END DO
        ELSE
          l_cp = l_cpj*nthread
          ALLOCATE(ns_cp(l_cp),ne_cp(l_cp),stat=ier1)
C
          iad=0
          DO j = 1,nthread
            iad1=(j-1)*nt_imp0
            DO i = 1,l_cpj
              ns_cp(iad+i) = ns_imp(iad1+i)
              ne_cp(iad+i) = ne_imp(iad1+i)
            END DO
            iad =iad + l_cpj
            iadn(j) =0
          END DO
C
          iad = 0
          DO n = 1,ninter
            ity   =ipari(7,n)
            numimp(n)=0
            IF (ity==3.OR.ity==4.OR.ity==5) THEN
              DO j = 1,nthread
                iad1=(j-1)*l_cp/ nthread + iadn(j)
                DO i = 1,numimpl(n,j)
                  ns_imp(iad+i) = ns_cp(iad1+i)
                  ne_imp(iad+i) = ne_cp(iad1+i)
                END DO
                iad =iad + numimpl(n,j)
                numimp(n) = numimp(n)+numimpl(n,j)
                iadn(j) = iadn(j) + numimpl(n,j)
C-------reput zero
                numimpl(n,j)=0
              END DO
            END IF
          END DO
          DEALLOCATE(ns_cp,ne_cp)
        END IF !(NTHREAD==1) THEN
C
        nt_imp = nt_imp + iadt
C
        RETURN

re2int7()

subroutine re2int7	(	integer	nt_imp,
		integer, dimension(*)	numimp,
		integer, dimension(*)	ns_imp,
		integer, dimension(*)	ne_imp,
		integer, dimension(*)	ind_imp,
		integer, dimension(ninter,*)	numimpl,
		integer, dimension(npari,*)	ipari,
		integer	nt_imp0 )

Definition at line 5365 of file imp_solv.F.

C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
#include      "task_c.inc"
#include      "param_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER  NT_IMP,NUMIMP(*),NS_IMP(*),NE_IMP(*),IND_IMP(*),
     .           NUMIMPL(NINTER,*),IPARI(NPARI,*),NT_IMP0
C-----------------------------------------------
C   L o c a l  V a r i a b l e s
C-----------------------------------------------
        INTEGER I,J,K,L,N,IAD,IAD1,IADT,ITY,IAD0,L_CP,L_CPJ,NIMPJ,
     .          NT_IMP7,IADN(NTHREAD)
        INTEGER, DIMENSION(:),ALLOCATABLE :: NS_CP,NE_CP,IND_CP
        INTEGER IER1
C-----------------------------------------------
C   S o u r c e  L i n e s
C-----------------------------------------------
        iadt = 0
        l_cpj = 0
        DO j = 1,nthread
          nimpj = iadt
          DO n = 1,ninter
            ity   =ipari(7,n)
            IF (ity==7.OR.ity==10.OR.ity==11.OR.ity==24) THEN
              numimp(n)=0
              iadt =iadt + numimpl(n,j)
            END IF
          END DO
          nimpj = -nimpj+iadt
          l_cpj = max(l_cpj,nimpj)
        END DO
        IF (iadt==0) GOTO 100
 
        IF (nthread==1) THEN
          DO n = 1,ninter
            numimp(n) =numimpl(n,1)
          END DO
        ELSE
          l_cp = l_cpj*nthread
          ALLOCATE(ns_cp(l_cp),ne_cp(l_cp),ind_cp(l_cp),stat=ier1)
 
          iad0=nt_imp
          nt_imp7=nt_imp0-nt_imp
          iad =0
          DO j = 1,nthread
            iad1=iad0+(j-1)*nt_imp7
            DO i = 1,l_cpj
              ns_cp(iad+i) = ns_imp(iad1+i)
              ne_cp(iad+i) = ne_imp(iad1+i)
              ind_cp(iad+i) = ind_imp(iad1+i)
            END DO
            iad =iad + l_cpj
            iadn(j) =0
          END DO
 
          iad = iad0
          DO n = 1,ninter
            ity   =ipari(7,n)
            IF (ity==7.OR.ity==10.OR.ity==11.OR.ity==24) THEN
              DO j = 1,nthread
                iad1=(j-1)*l_cp/ nthread + iadn(j)
                DO i = 1,numimpl(n,j)
                  ns_imp(iad+i) = ns_cp(iad1+i)
                  ne_imp(iad+i) = ne_cp(iad1+i)
                  ind_imp(iad+i) = ind_cp(iad1+i)
                END DO
                iad =iad + numimpl(n,j)
                numimp(n) = numimp(n)+numimpl(n,j)
                iadn(j) = iadn(j) + numimpl(n,j)
C        ----reput zero
                numimpl(n,j)=0
              END DO
            END IF
          END DO
          DEALLOCATE(ns_cp,ne_cp,ind_cp)
        END IF !(NTHREAD==1) THEN
C
        nt_imp = nt_imp + iadt
C-------int24, Istif=6
 100    CONTINUE
        CALL imp_stif24(numimp  ,ipari   )
        RETURN

save_kif()

subroutine save_kif	(	integer	nddl,
		integer, dimension(*)	iadk,
		integer, dimension(*)	jdik,
			diag_k,
			lt_k,
		integer, dimension(*)	itok,
		integer	nddlg )

Definition at line 2512 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE imp_lintf
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER NDDL,IADK(*),JDIK(*),ITOK(*),NDDLG
C     REAL
        my_real
     .    diag_k(*),lt_k(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER IADCP(NDDLIF+1),JDICP(NZIF),ITOCP(NDDLIF)
        INTEGER NDDLI0,NZI0,NZK,IERR1,IERR2,ITAG(NDDLG),
     .          I,J,II,NL,NR,ITON(NDDL)
        my_real
     .    diag_cp(nddlif),lt_cp(nzif)
C------------------------------------------
        IF (nddl==0) RETURN
        IF (nddlif==0) THEN
          nddlif = nddl
          nzif =iadk(nddl+1)-iadk(1)
          IF(ALLOCATED(iadif)) DEALLOCATE(iadif)
          IF(ALLOCATED(jdiif)) DEALLOCATE(jdiif)
          IF(ALLOCATED(iftok)) DEALLOCATE(iftok)
          ALLOCATE(iadif(nddlif+1),iftok(nddlif),jdiif(nzif),stat=ierr1)
          CALL cp_int((nddlif+1),iadk,iadif)
          CALL cp_int(nddlif,itok,iftok)
          CALL cp_int(nzif,jdik,jdiif)
          IF(ALLOCATED(diag_if)) DEALLOCATE(diag_if)
          IF(ALLOCATED(lt_if)) DEALLOCATE(lt_if)
          ALLOCATE(diag_if(nddlif),lt_if(nzif),stat=ierr2)
          CALL cp_real(nddlif,diag_k,diag_if)
          CALL cp_real(nzif,lt_k,lt_if)
        ELSE
          CALL cp_int((nddlif+1),iadif,iadcp)
          CALL cp_int(nddlif,iftok,itocp)
          CALL cp_real(nddlif,diag_if,diag_cp)
          CALL cp_int(nzif,jdiif,jdicp)
          CALL cp_real(nzif,lt_if,lt_cp)
          nddli0 = nddlif
          nzi0 = nzif
          DO i = 1,nddlg
            itag(i) = 0
          ENDDO
          DO i = 1,nddli0
            itag(iftok(i)) = i
          ENDDO
          DO i = 1,nddl
            j = itok(i)
            IF (itag(j)==0) THEN
              nddlif = nddlif+1
              nzif = nzif+iadk(i+1)-iadk(i)
              iton(i) = nddlif
            ELSE
              iton(i) = itag(j)
            ENDIF
          ENDDO
          IF(ALLOCATED(iadif)) DEALLOCATE(iadif)
          IF(ALLOCATED(jdiif)) DEALLOCATE(jdiif)
          IF(ALLOCATED(iftok)) DEALLOCATE(iftok)
          ALLOCATE(iadif(nddlif+1),iftok(nddlif),jdiif(nzif),stat=ierr1)
          IF(ALLOCATED(diag_if)) DEALLOCATE(diag_if)
          IF(ALLOCATED(lt_if)) DEALLOCATE(lt_if)
          ALLOCATE(diag_if(nddlif),lt_if(nzif),stat=ierr2)
C---------copy old-----
          CALL cp_int((nddli0+1),iadcp,iadif)
          CALL cp_int(nddli0,itocp,iftok)
          CALL cp_real(nddli0,diag_cp,diag_if)
          CALL cp_int(nzi0,jdicp,jdiif)
          CALL cp_real(nzi0,lt_cp,lt_if)
C---------add [k]-----
          nl = nddli0
          nzif = nzi0
          DO i = 1,nddl
            j = itok(i)
            IF (itag(j)==0) THEN
              nl = nl + 1
              nr = iadk(i+1)-iadk(i)
              iftok(nl) = j
              diag_if(nl)=diag_k(i)
              DO ii = iadk(i),iadk(i+1)-1
                nzif = nzif + 1
                jdiif(nzif) = iton(jdik(ii))
                lt_if(nzif) = lt_k(ii)
              ENDDO
              iadif(nl+1) = nzif + 1
            ENDIF
          ENDDO
C
          IF (nl/=nddlif)
     .      print *,'--MEMERY PROBLEM [K]if--:',nl,nddlif
        ENDIF
C------------------------------------------
        RETURN

set_ksym()

subroutine set_ksym	(	integer	nddl,
		integer, dimension(*)	iadk,
		integer, dimension(*)	jdik,
			lt_k,
		integer, dimension(*)	iadk0,
		integer, dimension(*)	jdik0,
			lt_k0 )

Definition at line 5160 of file imp_solv.F.

C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER  NDDL,IADK(*),JDIK(*),IADK0(*),JDIK0(*)
        my_real
     .    lt_k(*),lt_k0(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER  I,J,K,JD,ICOL(NDDL),NRI,NR0
C----6--K0:matrice complete(non triang)
        DO i = 1, nddl
          icol(i) = iadk(i+1) - iadk(i)
        ENDDO
        DO i = 1, nddl
          DO j = iadk(i),iadk(i+1)-1
            jd = jdik(j)
            icol(jd) = icol(jd) + 1
          ENDDO
        ENDDO
        iadk0(1) = 1
        DO i = 1,nddl
          iadk0(i+1) = iadk0(i)+icol(i)-iadk(i+1)+iadk(i)
          icol(i) = 0
        ENDDO
        DO i = 1,nddl
          DO j=iadk(i),iadk(i+1)-1
            jd = jdik(j)
            k = iadk0(jd) + icol(jd)
            jdik0(k) = i
            lt_k0(k) = lt_k(j)
            icol(jd) = icol(jd) + 1
          ENDDO
        ENDDO
C
        RETURN

spb_ieref3()

subroutine spb_ieref3	(		x,
		integer, dimension(nixc,*)	ixc,
		integer, dimension(nixtg,*)	ixtg,
		integer, dimension(*)	ndof,
		integer, dimension(*)	iddl,
		integer, dimension(*)	ikc,
			d_imp,
			dr_imp,
			dmin )

Definition at line 8457 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE imp_spbrm
        use element_mod , only : nixc,nixtg
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        integer
     .     ixc(nixc,*), ixtg(nixtg,*), ndof(*),iddl(*),ikc(*)
C     REAL
        my_real
     .     dmin,x(3,*) ,d_imp(3,*) ,dr_imp(3,*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER  N,I,J,ND,NN,IE,IEM,K,NSAVE(4)
        my_real
     .         d(3),dd,dr(3),ddr,dmint
C----- find reference element: around element center))
C--------NSAVE(1) : XMIN, 2 : YMIN, 3 : ZMIN, 4 : DMIN
        dmin=ep30
        IF (ncycle==1 )THEN
          nsave(1:4) = e_ref(1:4)
          e_ref(1:4) = 0
          DO i = 1,4
            ie =iabs(nsave(i))
            IF (ie==0) cycle
            DO k = 1,3
              d(k) = zero
              dr(k) = zero
              IF (nsave(4)<0) THEN
                DO j= 1,3
                  n = ixtg(j+1,ie)
                  d(k) = d(k) + d_imp(k,n)
                  dr(k) = dr(k) + dr_imp(k,n)
                END DO
              ELSE
                DO j= 1,4
                  n = ixc(j+1,ie)
                  d(k) = d(k) + d_imp(k,n)
                  dr(k) = dr(k) + dr_imp(k,n)
                END DO
              END IF
            END DO
            dd = min(abs(d(1)),abs(d(2)),abs(d(3)))
            ddr = max(abs(dr(1)),abs(dr(2)),abs(dr(3)))
C   -------min(max(DR(j))) (1:4)------
            IF (ddr < dmin) THEN
              dmin = ddr
              IF (nsave(4)<0) THEN
                e_ref(1:3) = ixtg(2:4,ie)
                e_ref(4) = e_ref(3)
              ELSE
                e_ref(1:4) = ixc(2:5,ie)
              END IF
            END IF
          END DO
C
          IF (nspmd>1) THEN
            dmint = dmin
            CALL spmd_min_s(dmint)
C------not in this domain-----
            IF (dmint<dmin) THEN
              e_ref(1:4) = 0
            END IF
          END IF
          IF ((e_ref(1)+e_ref(2)+e_ref(3)+e_ref(4))==0) THEN
            n_seg = 0
          ELSEIF(e_ref(4) == e_ref(3)) THEN
            n_seg = 3
          ELSE
            n_seg = 4
          END IF
C---- Ncycle>1
        ELSE
          IF ((e_ref(1)+e_ref(2)+e_ref(3)+e_ref(4))==0) n_seg = 0
          IF (n_seg>0) THEN
            DO k = 1, 3
              dr(k) = zero
              DO j= 1,3
                n = e_ref(j)
                dr(k) = dr(k) + dr_imp(k,n)
              END DO
              IF (e_ref(4) /= e_ref(3)) THEN
                n = e_ref(4)
                dr(k) = dr(k) + dr_imp(k,n)
              END IF
            END DO
            dmin = max(abs(dr(1)),abs(dr(2)),abs(dr(3)))
          END IF !(N_SEG>0) THEN
        END IF !(NCYCLE==1 )THEN
        x_ref(1:3,1:4) = zero
        d_ref(1:3,1:4) = zero
        IF (n_seg > 0) THEN
          DO j= 1,4
            n = e_ref(j)
            x_ref(1:3,j)= x(1:3,n)
            d_ref(1:3,j)= d_imp(1:3,n)
          END DO
        END IF
C------------------------------------------
        RETURN

spb_ieref_bc()

subroutine spb_ieref_bc	(		x,
		integer, dimension(nixc,*)	ixc,
		integer, dimension(nixtg,*)	ixtg,
			d_imp,
			dmin,
		integer, dimension(*)	ndof,
		integer, dimension(*)	iddl,
		integer, dimension(*)	ikc )

Definition at line 8197 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE imp_spbrm
        use element_mod , only : nixc,nixtg
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        integer
     .     ndof(*),iddl(*),ikc(*),ixc(nixc,*), ixtg(nixtg,*)
C     REAL
        my_real
     .     dmin,x(3,*) ,d_imp(3,*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER  N,I,J,ND,NN,IE,IEM,K
        my_real
     .         d(3),dd,dmint
C------remove rigid motion of springback (incremental)
C----- find reference element: IF BCS the smallest Disp(at element center)) w/BCS C-------
C------doing  once: NCYCLE=1
        dmin=ep30
        IF (ncycle==1 )THEN
          ilskew = 0
          lskew_g = 0
          ikce(1:6) = 0
          e_ref(1:4) = 0
          DO i = 1, ne_bc4
            ie =ie_bc4(i)
            DO k = 1,3
              d(k) = zero
              DO j= 1,4
                n = ixc(j+1,ie)
                d(k) = d(k) + d_imp(k,n)
              END DO
            END DO
            dd = min(abs(d(1)),abs(d(2)),abs(d(3)))
            IF (dd < dmin) THEN
              dmin = dd
              e_ref(1:4) = ixc(2:5,ie)
            END IF
          END DO
C
          DO i = 1, ne_bc3
            ie =ie_bc3(i)
            DO k = 1,3
              d(k) = zero
              DO j= 1,3
                n = ixtg(j+1,ie)
                d(k) = d(k) + d_imp(k,n)
              END DO
            END DO
            dd = min(abs(d(1)),abs(d(2)),abs(d(3)))
            IF (dd < dmin) THEN
              dmin = dd
              e_ref(1:3) = ixtg(2:4,ie)
              e_ref(4) = e_ref(3)
            END IF
          END DO
C-----not to use allow BCS (global only IKC=1) dof direction
C----- add BCS w/ SKEW (ILSKEW=1 w/ ref); Ud (IKC=2,9) could also be added--
          DO j = 1, 4
            n = e_ref(j)
            IF (n==0) cycle
            DO k= 1,ndof(n)
              nd = iddl(n)+k
              IF (ikc(nd)>0.AND.ikce(k)==0) ikce(k) = 1
            END DO
          END DO
C--------to limit change during the iteration and dependant of np
          IF (nspmd>1) THEN
            dmint = dmin
            CALL spmd_min_s(dmint)
C------not in this domain-----
            IF (dmint<dmin) THEN
              e_ref(1:4) = 0
            END IF
          END IF
          IF ((e_ref(1)+e_ref(2)+e_ref(3)+e_ref(4))==0) THEN
            n_seg = 0
          ELSEIF(e_ref(4) == e_ref(3)) THEN
            n_seg = 3
          ELSE
            n_seg = 4
          END IF
          IF (n_seg>0) THEN
            DO j = 1, 4
              n = e_ref(j)
              IF (n==0) cycle
              DO k= 1,ndof(n)
                nd = iddl(n)+k
                IF (ikc(nd)==8) ilskew = n
              END DO
            END DO
            IF (ilskew >0) lskew_g=1
          END IF
C-------Ncycle>1
        ELSEIF ((e_ref(1)+e_ref(2)+e_ref(3)+e_ref(4)) >0) THEN
          DO k = 1, 3
            d(k) = zero
            DO j= 1,3
              n = e_ref(j)
              d(k) = d(k) + d_imp(k,n)
            END DO
            IF (e_ref(4) /= e_ref(3)) THEN
              n = e_ref(4)
              d(k) = d(k) + d_imp(k,n)
            END IF
          END DO
          dmin = min(abs(d(1)),abs(d(2)),abs(d(3)))
        END IF !(NCYCLE==1 )THEN
        x_ref(1:3,1:4) = zero
        d_ref(1:3,1:4) = zero
        IF (n_seg > 0) THEN
          DO j= 1,4
            n = e_ref(j)
            x_ref(1:3,j)= x(1:3,n)
            d_ref(1:3,j)= d_imp(1:3,n)
          END DO
        END IF
C------------------------------------------
        RETURN

spb_ref_nds()

subroutine spb_ref_nds	(		x,
			d_imp,
		integer, dimension(*)	ndof,
		integer, dimension(*)	iddl,
		integer, dimension(*)	ikc,
		integer, dimension(*)	icodt,
		integer, dimension(*)	icodr,
		integer, dimension(*)	iskew,
			skew )

Definition at line 9048 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE imp_spbrm
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "param_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        integer
     .     ndof(*),iddl(*),ikc(*),icodt(*),icodr(*),iskew(*)
C     REAL
        my_real
     .     x(3,*) ,d_imp(3,*) ,skew(lskew,*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER  N,I,J,ND,NN,IE,IEM,K,ISK
        my_real
     .         d(3),dd,dmint
C------case input 3 ref_nodes
        x_ref(1:3,1:4) = zero
        d_ref(1:3,1:4) = zero
        n_seg = 3
        DO j= 1,n_seg
          n = e_ref(j)
          IF (n==0) cycle
          x_ref(1:3,j)= x(1:3,n)
          d_ref(1:3,j)= d_imp(1:3,n)
        END DO
        IF (ilskew>0) THEN
C----get ISK(from E_REF)set [Q],transfert DTRA,DROT to local reset IKCE(6) put (j)=0 for fixing dir
          nn = ilskew
          isk = iskew(nn)
C---------local IKC
          rlskew(1:9) = skew(1:9,isk)
          CALL getikce(icodt(nn),icodr(nn),ndof(nn),ikce)
        END IF
C------------------------------------------
        RETURN

spb_refsh3id()

subroutine spb_refsh3id	(	integer	jft,
		integer	jlt,
		integer	nel,
		integer, dimension(nixtg,*)	ixtg,
			x,
			xc,
			yc,
			zc,
		integer, dimension(4)	ie,
			xmin0,
			ymin0,
			zmin0,
			dmin )

Definition at line 7867 of file imp_solv.F.

      use element_mod , only : nixtg
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER IXTG(NIXTG,*),JFT, JLT,IE(4),NEL
C     REAL
        my_real
     .         x(3,*),xc,yc,zc,xmin0,ymin0,zmin0,dmin
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER  N,I,II,ND,INDEX(NEL),IEL,J
        my_real
     .         xmin,xmax,ymin,ymax,zmin,zmax,d,xm,ym,zm,dminl,
     .         xminl,yminl,zminl
C---get reference ele (shell for the moment) for rigid motion compute
C---- E_id : nearest the gravity center----
        nd =0
        DO i = jft,jlt
          xmin=ep30
          xmax=-ep30
          ymin=ep30
          ymax=-ep30
          zmin=ep30
          zmax=-ep30
          DO j=1,3
            n= ixtg(j+1,i)
            xmin=min(xmin,x(1,n))
            xmax=max(xmax,x(1,n))
            ymin=min(ymin,x(2,n))
            ymax=max(ymax,x(2,n))
            zmin=min(zmin,x(3,n))
            zmax=max(zmax,x(3,n))
          END DO
          IF((xc < xmin.OR.xc > xmax).AND.(yc < ymin.OR.yc > ymax)
     +       .AND.(zc < zmin.OR.zc > zmax)) cycle
          nd = nd +1
          index(nd) = i
        END DO
        IF (nd ==0) THEN
          iel =0
        ELSE
          DO ii = 1,nd
            i = index(ii)
            xm = zero
            ym = zero
            zm = zero
            DO j=1,3
              n= ixtg(j+1,i)
              xm=xm+x(1,n)
              ym=ym+x(2,n)
              zm=zm+x(3,n)
            END DO
            xm = third*xm - xc
            ym = third*ym - yc
            zm = third*zm - zc
            xminl=abs(xm)
            yminl=abs(ym)
            zminl=abs(zm)
            IF (xminl<xmin0) THEN
              ie(1) = i
              xmin0 = xminl
            END IF
            IF (yminl<ymin0) THEN
              ie(2) = i
              ymin0 = yminl
            END IF
            IF (zminl<zmin0) THEN
              ie(3) = i
              zmin0 = zminl
            END IF
            d=xm*xm+ym*ym
c         D=XM*XM+YM*YM+ZM*ZM
            IF (d < dmin) THEN
              dmin = d
C------------- tag tria w/ negative
              ie(4) = -i
            END IF
          END DO
        ENDIF
c       IF (IEL>0 .AND.DMINL<DMIN) THEN
c        IE(1:3) = IXTG(2:4,IEL)
c        IE(4) = IE(3)
c        DMIN= DMINL
c       END IF
C
        RETURN

spb_refsh4id()

subroutine spb_refsh4id	(	integer	jft,
		integer	jlt,
		integer	nel,
		integer, dimension(nixc,*)	ixc,
			x,
			xc,
			yc,
			zc,
		integer, dimension(4)	ie,
			xmin0,
			ymin0,
			zmin0,
			dmin )

Definition at line 7766 of file imp_solv.F.

      use element_mod , only : nixc
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER IXC(NIXC,*),JFT, JLT,IE(4),NEL
C     REAL
        my_real
     .         x(3,*),xc,yc,zc,dmin,xmin0,ymin0,zmin0
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER  N,I,II,ND,INDEX(NEL),IEL,J
        my_real
     .         xmin,xmax,ymin,ymax,zmin,zmax,d,xm,ym,zm,dminl,
     .         xminl,yminl,zminl
C---get reference ele (shell for the moment) for rigid motion compute
C---- E_id : nearest the gravity center----
        nd =0
        DO i = jft,jlt
          xmin=ep30
          xmax=-ep30
          ymin=ep30
          ymax=-ep30
          zmin=ep30
          zmax=-ep30
          DO j=1,4
            n= ixc(j+1,i)
            xmin=min(xmin,x(1,n))
            xmax=max(xmax,x(1,n))
            ymin=min(ymin,x(2,n))
            ymax=max(ymax,x(2,n))
            zmin=min(zmin,x(3,n))
            zmax=max(zmax,x(3,n))
          END DO
          IF((xc < xmin.OR.xc > xmax).AND.(yc < ymin.OR.yc > ymax)
     +       .AND.(zc < zmin.OR.zc > zmax)) cycle
          nd = nd +1
          index(nd) = i
        END DO
        IF (nd ==0) THEN
          iel =0
        ELSE
          DO ii = 1,nd
            i = index(ii)
            xm = zero
            ym = zero
            zm = zero
            DO j=1,4
              n= ixc(j+1,i)
              xm=xm+x(1,n)
              ym=ym+x(2,n)
              zm=zm+x(3,n)
            END DO
            xm = fourth*xm- xc
            ym = fourth*ym- yc
            zm = fourth*zm- zc
            xminl=abs(xm)
            yminl=abs(ym)
            zminl=abs(zm)
C-------- Z direction is removed
            IF (xminl<xmin0) THEN
              ie(1) = i
              xmin0 = xminl
            END IF
            IF (yminl<ymin0) THEN
              ie(2) = i
              ymin0 = yminl
            END IF
c          IF (ZMINL<ZMIN0) THEN
c           IE(3) = I
c           ZMIN0 = ZMINL
c          END IF
            d=xm*xm+ym*ym
c         D=XM*XM+YM*YM+ZM*ZM
            IF (d < dmin) THEN
              dmin = d
C---------first node-----
              ie(4) = i
            END IF
          END DO
        ENDIF
c       IF (IEL>0 .AND.DMINL<DMIN) THEN
c        IE(1:4) = IXC(2:5,IEL)
c        DMIN= DMINL
c       END IF
C
        RETURN

spb_rgmod()

subroutine spb_rgmod	(	integer	n_seg,
			x_ref,
			d_ref,
			x,
			d,
			x0,
			y0,
			z0,
			dtra,
			drot )

Definition at line 8337 of file imp_solv.F.

C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER N_SEG
C     REAL
        my_real
     .     x_ref(3,4),d_ref(3,4),x(3,*),d(3,*),dtra(3),drot(3),
     .     x0  ,y0  ,z0
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER  I, J, II, L, JJ,NJ,K,NIR
C     REAL
        my_real
     .     xx,yy,zz,xxx,yyy,zzz,xy,yz,zx,xy2,yz2,zx2,
     .     b1,b2,b3,c1,c2,c3,facm,rj(3,3,4),
     .     x22,y22,z22,det,xm(4),ym(4),zm(4)
        my_real
     .     xs,ys,zs
C------------------------------------
C     JACOBIAN MATRIX [C]
C------------------------------------
        nir=n_seg
        DO j=1,nir
C        NJ=IRECT(J)
          xm(j)=x_ref(1,j)
          ym(j)=x_ref(2,j)
          zm(j)=x_ref(3,j)
        ENDDO
        IF(nir==3) THEN
          xm(4)=zero
          ym(4)=zero
          zm(4)=zero
        ENDIF
        facm = one / nir
C----------------------------------------------------
C       AVERAGE ROTATION SPEED OF THE MAIN SEGMENT
C----------------------------------------------------
        x0=facm*(xm(1)+xm(2)+xm(3)+xm(4))
        y0=facm*(ym(1)+ym(2)+ym(3)+ym(4))
        z0=facm*(zm(1)+zm(2)+zm(3)+zm(4))
        DO j=1,nir
          xm(j)=xm(j)-x0
          ym(j)=ym(j)-y0
          zm(j)=zm(j)-z0
        ENDDO
C-------
        xx=0
        yy=0
        zz=0
        xy=0
        yz=0
        zx=0
        DO j=1,nir
          xx=xx+ xm(j)*xm(j)
          yy=yy+ ym(j)*ym(j)
          zz=zz+ zm(j)*zm(j)
          xy=xy+ xm(j)*ym(j)
          yz=yz+ ym(j)*zm(j)
          zx=zx+ zm(j)*xm(j)
        ENDDO
        zzz=xx+yy
        xxx=yy+zz
        yyy=zz+xx
        xy2=xy*xy
        yz2=yz*yz
        zx2=zx*zx
        det= xxx*yyy*zzz -xxx*yz2 -yyy*zx2 -zzz*xy2 -two*xy*yz*zx
        det=one/det
        b1=(zzz*yyy-yz2)*det
        b2=(xxx*zzz-zx2)*det
        b3=(yyy*xxx-xy2)*det
        c3=(zzz*xy+yz*zx)*det
        c1=(xxx*yz+zx*xy)*det
        c2=(yyy*zx+xy*yz)*det
        DO j=1,nir
          x22 = c1*xm(j)
          y22 = c2*ym(j)
          z22 = c3*zm(j)
C-------RJ=(R^tR)^-1Rj^t-(j=1,ndir)---
          rj(1,1,j)=z22-y22
          rj(2,1,j)=b2*zm(j)-c1*ym(j)
          rj(3,1,j)=c1*zm(j)-b3*ym(j)
          rj(1,2,j)=-b1*zm(j)+c2*xm(j)
          rj(2,2,j)=-z22+x22
          rj(3,2,j)=-c2*zm(j)+b3*xm(j)
          rj(1,3,j)=b1*ym(j)-c3*xm(j)
          rj(2,3,j)=c3*ym(j)-b2*xm(j)
          rj(3,3,j)=y22-x22
        ENDDO
C
        DO i=1,3
          dtra(i)= zero
          drot(i) = zero
          DO j=1,nir
C         NJ=IRECT(J)
            drot(i)=drot(i)+rj(i,1,j)*d_ref(1,j)+
     .              rj(i,2,j)*d_ref(2,j)+rj(i,3,j)*d_ref(3,j)
            dtra(i)=dtra(i)+facm*d_ref(i,j)
          END DO
        END DO
C
        RETURN

spb_rm_rig()

subroutine spb_rm_rig	(		x,
		integer, dimension(nixc,*)	ixc,
		integer, dimension(nixtg,*)	ixtg,
		integer, dimension(*)	ndof,
		integer, dimension(*)	iddl,
		integer, dimension(*)	ikc,
			d_imp,
			dr_imp,
		integer, dimension(*)	icodt,
		integer, dimension(*)	icodr,
			skew,
		integer, dimension(*)	iskew,
		integer, dimension(*)	itab )

Definition at line 7980 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE imp_spbrm
        use element_mod , only : nixc,nixtg
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "com04_c.inc"
#include      "param_c.inc"
#include      "units_c.inc"
#include      "task_c.inc"
#include      "impl1_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER ICODT(*),ICODR(*),ISKEW(*)
        integer
     .     ixc(nixc,*), ixtg(nixtg,*), ndof(*),iddl(*),ikc(*),itab(*)
C     REAL
        my_real
     .     x(3,*) ,d_imp(3,*) ,dr_imp(3,*)  ,skew(lskew,*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER  N,I,J,ND,NN,IE,IEM,NKC,K,ILOC,ISK,IKCL(6)
        my_real
     .         dmin,d,xc,yc,zc,dtra(3),drot(3),drs(3),lsm(3),
     .         x0,y0,z0,dtral(3),drotl(3),lsml(3),drs1(3),drot1(3),drotl1(3)
C------remove rigid motion of springback (increment)
C----- find reference element: IF BCS the one of smallest Disp w/ BCS (doing ech time)
C------------------------------else nearest the GC of blank (done only once)
C------should update X_REF,D_REF each cycle---
C------case input 3N---
        IF (irig_m>1) THEN
          CALL spb_ref_nds(
     1     x         ,d_imp     ,ndof      ,iddl      ,ikc       ,
     2     icodt     ,icodr     ,iskew     ,skew      )
          IF (ilskew>0) THEN
C----get ISK(from E_REF)set [Q],transfert DTRA,DROT to local reset IKCE(6) put (j)=0 for fixing dir
            nn = ilskew
            isk = iskew(nn)
C---------local IKC
            rlskew(1:9) = skew(1:9,isk)
            CALL getikce(icodt(nn),icodr(nn),ndof(nn),ikce)
          END IF
          IF (nspmd>1) CALL spmd_n_ref()
        ELSE
          IF (nbc_b>0) THEN
            CALL spb_ieref_bc(
     1      x         ,ixc       ,ixtg      ,d_imp    ,dmin   ,
     2      ndof      ,iddl      ,ikc       )
            IF (ilskew>0) THEN
C----get ISK(from E_REF)set [Q],transfert DTRA,DROT to local reset IKCE(6) put (j)=0 for fixing dir
              nn = ilskew
              isk = iskew(nn)
C---------local IKC
              rlskew(1:9) = skew(1:9,isk)
              CALL getikce(icodt(nn),icodr(nn),ndof(nn),ikce)
            END IF
          ELSE
            CALL spb_ieref3(
     1      x         ,ixc       ,ixtg      ,ndof      ,iddl      ,
     2      ikc       ,d_imp     ,dr_imp    ,dmin )
          END IF
C--------communication IKCE,X_REF,D_REF,RLSKEW,N_SEG, LSKEW_G
          IF (nspmd>1) CALL spmd_e_ref(dmin)
        END IF !(IRIG_M>1) THEN
C
        IF (n_seg==0) RETURN
C-----IKCE : only local BCS nodes are initialized-----
        CALL spb_rgmod(n_seg ,x_ref ,d_ref ,x   ,d_imp  ,
     +                 x0  ,y0  ,z0  ,dtra,drot )
        IF (nbc_b>0.OR.lskew_g>0) THEN
          DO j=1,3
            IF (ikce(j)==1) dtra(j)= zero
          ENDDO
c        IF (IRODDL/=0) THEN
          DO j=1,3
            IF (ikce(j+3)==1) drot(j)=zero
          ENDDO
c        END IF
        END IF
        IF (lskew_g>0) THEN
          CALL transvg2l(rlskew,dtra,dtral)
          CALL transvg2l(rlskew,drot,drotl)
          DO j=1,3
            IF (ikce(j)==1) dtral(j)= zero
            IF (ikce(j+3)==1) drotl(j)=zero
          ENDDO
          IF (iroddl/=0) CALL transvl2g(rlskew,drotl,drot)
          DO i =1,numnod
            nkc=0
            DO j=1,min(3,ndof(i))
              nd = iddl(i)+j
              IF (ikc(nd)/=0) nkc = nkc + 1
            ENDDO
            drot1(1:3) = drot(1:3)
C--------exclude the node w/all translational fixed
            IF (nkc<3.AND.ndof(i)>0) THEN
              lsm(1)=x(1,i)-x0
              lsm(2)=x(2,i)-y0
              lsm(3)=x(3,i)-z0
C----transfert LSM to local
c         CALL TRANSVG2L(RLSKEW,LSM,LSML)
              CALL velrot(drotl,lsml,drs)
C------otherwise DL(1:3)= DRS+ DTRAL if fixing put DL(j)=0
              drs(1:3) = drs(1:3) + dtral(1:3)
              IF (nkc>0) THEN
C----------suppose the same ISK w/ reference one
                CALL getikce(icodt(i),icodr(i),ndof(i),ikcl)
                DO j=1,3
                  drotl1(j) = drotl(j)
                  IF (ikcl(j)==1) drs(j)= zero
                  IF (ikcl(j+3)==1) drotl1(j)= zero
                ENDDO
                CALL transvl2g(rlskew,drotl1,drot1)
              END IF !(NKC>0) THEN
              CALL transvl2g(rlskew,drs,drs1)
C----transfert DL DROT,to global
              DO k=1,3
                d_imp(k,i)=d_imp(k,i)- drs1(k)
              ENDDO
              IF (iroddl/=0) THEN
                DO k=1,3
                  dr_imp(k,i)=dr_imp(k,i)- drot1(k)
                ENDDO
              END IF
            END IF
          ENDDO
        ELSE
          DO i =1,numnod
            nkc=0
            DO j=1,min(3,ndof(i))
              nd = iddl(i)+j
              IF (ikc(nd)/=0) nkc = nkc + 1
            ENDDO
C--------exclude the node w/all translational fixed
            IF (nkc<3.AND.ndof(i)>0) THEN
              lsm(1)=x(1,i)-x0
              lsm(2)=x(2,i)-y0
              lsm(3)=x(3,i)-z0
              CALL velrot(drot,lsm,drs)
              DO k=1,3
                nd = iddl(i)+k
                IF (ikc(nd)==0)d_imp(k,i)=d_imp(k,i)- drs(k)- dtra(k)
              ENDDO
              IF (iroddl/=0) THEN
                DO k=1,3
                  nd = iddl(i)+k+3
                  IF (ikc(nd)==0) dr_imp(k,i)=dr_imp(k,i)- drot(k)
                ENDDO
              END IF
            END IF
          ENDDO
        END IF
        IF (ittoff>0 .AND.ncycle==1) THEN
          write(iout,*)
          write(iout,*)'Segment served as Reference are the following nodes:'
          if (irig_m>1) THEN
            if (e_ref(1)>0) write(iout,*) 'NODE_ref 1 :',itab(e_ref(1))
            if (e_ref(2)>0) write(iout,*) 'NODE_ref 2 :',itab(e_ref(2))
            if (e_ref(3)>0) write(iout,*) 'NODE_ref 3 :',itab(e_ref(3))
          else
            if (e_ref(1)>0.AND.e_ref(2)>0.AND.e_ref(3)>0) then
              write(iout,*) (itab(e_ref(i)),i=1,n_seg)
            else
              write(iout,*) (e_ref(i),i=1,n_seg)
            end if
          end if
          write(iout,*)'Reference point at this moment:'
          write(iout,*)x0  ,y0  ,z0
          write(iout,*)'DTRA,DROT,N_SEG,ncycle=',n_seg,ncycle
          write(iout,*)dtra(1),dtra(2),dtra(3)
          write(iout,*)drot(1),drot(2),drot(3)
          write(iout,*)'ILSKEW,LSKEW_G,ISPMD=',ilskew,lskew_g,ispmd
          write(iout,*)rlskew(1),rlskew(2),rlskew(3)
          write(iout,*)
        END IF
c       IF (ITTOFF>0.AND.NCYCLE>1) THEN
c        write(iout,*)
c        write(iout,*)'DTRA,DROT,N_SEG,ILOC,ncycle=',N_SEG,ILOC,ncycle
c        write(iout,*)DTRA(1),DTRA(2),DTRA(3)
c        write(iout,*)DROT(1),DROT(2),DROT(3)
c        write(iout,*)'LSKEW_G,ISPMD=',LSKEW_G,ISPMD
c        write(iout,*)RLSKEW(1),RLSKEW(2),RLSKEW(3)
c        write(iout,*)
c       END IF
c      write(iout,*)'E_REF(i)=',(itab(E_REF(i)),i=1,4)
c      IF (ISPMD==0) THEN
c      write(iout,*)'X0,DTRA,DROT,N_SEG,ncycle=',N_SEG,ncycle
c      write(iout,*)X0  ,Y0  ,Z0
c      write(iout,*)DTRA(1),DTRA(2),DTRA(3)
c      write(iout,*)DROT(1),DROT(2),DROT(3)
c      END IF
C------------------------------------------
        RETURN

spbrm_pre()

subroutine spbrm_pre	(	integer, dimension(*)	itab,
			x,
		integer, dimension(nparg,*)	iparg,
		integer, dimension(nixc,*)	ixc,
		integer, dimension(nixtg,*)	ixtg,
			partsav,
		type (elbuf_struct_), dimension(ngroup)	elbuf_tab,
			pm,
		integer, dimension(*)	ndof,
		integer, dimension(*)	iddl,
		integer, dimension(*)	ikc )

Definition at line 7485 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE elbufdef_mod
        USE imp_spbrm
        use element_mod , only : nixc,nixtg
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "com04_c.inc"
#include      "param_c.inc"
#include      "impl1_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        integer
     .     ixc(nixc,*), ixtg(nixtg,*), iparg(nparg,*),
     .      ndof(*),iddl(*),ikc(*),itab(*)
C     REAL
        my_real
     .     x(3,*)  ,partsav(npsav,*) ,pm(*)
        TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP)      :: ELBUF_TAB
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER  N4,N3,I,II,J,N, NG,MLW, NF1,NKC,ND,IP4,IP3,IG,
     +           JFT,JLT,NBC,ITY,NEL,NFT,NBCS,E_ID,N1,N2,K
        INTEGER, DIMENSION(:),ALLOCATABLE :: ITAG
C     REAL
        my_real
     .       xc,yc,zc,mas,mas3,dmin,xmin,ymin,zmin,mast,
     .       dming,xming,yming,zming
C---limitations : only the blank is deformable(shell only), all tools(part)are rigids---
C------------blank could be composed w/ 4N,3N and in diff parts
C------ IRIG_M>1 -> input E_REF id
C---IF there id BC (symmetry) in the blank----
C----- put N1,N2,N3 (sys_id) in E_REF(1:3),  E_REF(4)=E_REF(3)
        rlskew(1:9) = zero
        IF (irig_m>1 ) THEN
          nbc_b = 0
          ilskew = 0
          lskew_g = 0
          ikce(1:6) = 0
          n1=0
          n2=0
          n3=0
          DO i = 1, numnod
            IF(itab(i)==e_ref(1)) n1=i
            IF(itab(i)==e_ref(2)) n2=i
            IF(itab(i)==e_ref(3)) n3=i
          END DO
          e_ref(1)= n1
          e_ref(2)= n2
          e_ref(3)= n3
          DO j = 1, 3
            n = e_ref(j)
            IF (n==0) cycle
            DO k= 1,ndof(n)
              nd = iddl(n)+k
              IF (ikc(nd)>0.AND.ikce(k)==0) ikce(k) = 1
              IF (ikc(nd)==8) ilskew = n
            END DO
          END DO
          IF (ilskew >0)  lskew_g=1
C--- ending routine
        RETURN
        END IF
        nbc = 0
        DO i =1,numnod
          nkc=0
          DO j=1,min(3,ndof(i))
            nd = iddl(i)+j
            IF (ikc(nd)/=0) nkc = nkc + 1
          ENDDO
C--------exclude fixing all translational
          IF (nkc>0.AND.nkc<3) nbc = nbc +1
        ENDDO
        IF (nbc >0) THEN
C----------pense      deallocate
          AllOCATE(ibc_b(nbc))
          nbc = 0
          DO i =1,numnod
            nkc=0
            DO j=1,min(3,ndof(i))
              nd = iddl(i)+j
              IF (ikc(nd)/=0) nkc = nkc + 1
            ENDDO
            IF (nkc>0.AND.nkc<3) THEN
              nbc = nbc +1
              ibc_b(nbc) = i
            END IF
          ENDDO
        END IF
C------global NBC---
        nbc_b = nbc
        IF (nspmd>1) CALL spmd_max_i(nbc_b)
C---get reference elem (shell for the moment) for rigid motion compute
C---- E_id : nearest the gravity center if no BC,
C-----E_REF(4) saved 4 nodes which are Xmin, Ymin,Zmin,Dmin, will be updated by v,vr
        IF (nbc >0) THEN
          ALLOCATE(itag(numnod))
          itag = 0
          DO i =1,nbc
            n = ibc_b(i)
            itag(n) =1
          END DO
          ne_bc4 = 0
          ne_bc3 = 0
          DO ng = 1, ngroup
            IF(iparg(8,ng)==1) cycle
            ity   =iparg(5,ng)
            IF (ity /= 3 .AND. ity /= 7) cycle
            mlw   =iparg(1,ng)
C
            IF (mlw == 0 .OR. mlw == 13) cycle
            nel   =iparg(2,ng)
            jft   =iparg(3,ng) + 1
            jlt   = iparg(3,ng) + nel
            IF (ity==7) THEN
              DO i = jft,jlt
                nbcs = 0
                DO j=1,3
                  n= ixtg(j+1,i)
                  nbcs = nbcs + itag(n)
                END DO
                IF (nbcs >0) ne_bc3 =ne_bc3 + 1
              END DO
            ELSEIF (ity==3) THEN
              DO i = jft,jlt
                nbcs = 0
                DO j=1,4
                  n= ixc(j+1,i)
                  nbcs = nbcs + itag(n)
                END DO
                IF (nbcs >0) ne_bc4 =ne_bc4 + 1
              END DO
            END IF
          END DO !NG = 1, NGROUP
          IF (ne_bc3 >0) ALLOCATE(ie_bc3(ne_bc3))
          IF (ne_bc4 >0) ALLOCATE(ie_bc4(ne_bc4))
          ne_bc4 = 0
          ne_bc3 = 0
          DO ng = 1, ngroup
            IF(iparg(8,ng)==1) cycle
            ity   =iparg(5,ng)
            IF (ity /= 3 .AND. ity /= 7) cycle
            mlw   =iparg(1,ng)
C
            IF (mlw == 0 .OR. mlw == 13) cycle
            nel   =iparg(2,ng)
            jft   =iparg(3,ng) + 1
            jlt   = iparg(3,ng) + nel
            IF (ity==7) THEN
              DO i = jft,jlt
                nbcs = 0
                DO j=1,3
                  n= ixtg(j+1,i)
                  nbcs = nbcs + itag(n)
                END DO
                IF (nbcs >0) THEN
                  ne_bc3 =ne_bc3 + 1
                  ie_bc3(ne_bc3) = i
                END IF
              END DO
            ELSEIF (ity==3) THEN
              DO i = jft,jlt
                nbcs = 0
                DO j=1,4
                  n= ixc(j+1,i)
                  nbcs = nbcs + itag(n)
                END DO
                IF (nbcs >0) THEN
                  ne_bc4 =ne_bc4 + 1
                  ie_bc4(ne_bc4) = i
                END IF
              END DO
            END IF
          END DO !NG =
C-------NBC = 0
        ELSEIF (nbc_b == 0) THEN
          n3=0
          n4=0
          mas =zero
          xc = zero
          yc = zero
          zc = zero
          DO ng = 1, ngroup
            IF(iparg(8,ng)==1) cycle
            ity   =iparg(5,ng)
            IF (ity /= 3 .AND. ity /= 7) cycle
            mlw   =iparg(1,ng)
C MLW= 0 ----> void; MLW = 13 ----> rigid material
            IF (mlw == 0 .OR. mlw == 13) cycle
            nel   =iparg(2,ng)
            jft=1
            jlt=min(nvsiz,nel)
            nf1 = iparg(3,ng)+1
            IF (ity==7) THEN
              n3 =n3 +1
              CALL cgshell3(elbuf_tab(ng),jft,jlt ,pm   ,ixtg(1,nf1),
     +                     x   ,mas,xc ,yc ,zc )
            ELSEIF (ity==3) THEN
              n4 =n4 +1
              CALL cgshell4(elbuf_tab(ng),jft,jlt ,pm   ,ixc(1,nf1),
     +                     x   ,mas,xc ,yc ,zc )
            END IF
          END DO !IG = 1, NGROUC
C
          IF (n3==0.AND.n4==0) THEN
C-------warning out--
          ELSE
            IF (nspmd>1) THEN
              mast = mas
              CALL spmd_sum_s(mast)
              CALL spmd_sum_s(xc)
              CALL spmd_sum_s(yc)
              CALL spmd_sum_s(zc)
              mas = mast
            END IF
            xc = xc/mas
            yc = yc/mas
            zc = zc/mas
C
            xmin=ep30
            ymin=ep30
            zmin=ep30
            dmin=ep30
            DO ng = 1, ngroup
              IF(iparg(8,ng)==1) cycle
              ity   =iparg(5,ng)
              IF (ity /= 3 .AND. ity /= 7) cycle
              mlw   =iparg(1,ng)
C
              IF (mlw == 0 .OR. mlw == 13) cycle
              nel   =iparg(2,ng)
              jft   =iparg(3,ng) + 1
              jlt   = iparg(3,ng) + nel
              IF (ity==7) THEN
                CALL spb_refsh3id(jft,jlt,nel,ixtg,x,xc,yc,zc,
     +                            e_ref,xmin,ymin,zmin,dmin)
              ELSEIF (ity==3) THEN
                CALL spb_refsh4id(jft,jlt,nel,ixc,x,xc,yc,zc,
     +                            e_ref,xmin,ymin,zmin,dmin)
              END IF
            END DO !IG = 1, NGROUC
C------- To get unique ref-element
            IF (nspmd>1) THEN
              xming = xmin
              CALL spmd_min_s(xming)
              IF (xming<xmin) e_ref(1)=0
              yming = ymin
              CALL spmd_min_s(yming)
              IF (yming<ymin) e_ref(2)=0
              zming = zmin
              CALL spmd_min_s(zming)
              IF (zming<zmin) e_ref(3)=0
              dming = dmin
              CALL spmd_min_s(dming)
              IF (dming<dmin) e_ref(4)=0
            END IF
          END IF   !((N3==0.AND.N4==0).OR.N3>1 .OR. N4>1)
        END IF !(nbc>0) THEN
        IF (nbc >0) DEALLOCATE(itag)
C
        RETURN

transvg2l()

subroutine transvg2l	(		skew,
			vg,
			vl )

Definition at line 8992 of file imp_solv.F.

C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        my_real
     .     skew(*),vg(*),vl(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER J
C----------------------------------------
        vl(1)=skew(1)*vg(1)+skew(2)*vg(2)+skew(3)*vg(3)
        vl(2)=skew(4)*vg(1)+skew(5)*vg(2)+skew(6)*vg(3)
        vl(3)=skew(7)*vg(1)+skew(8)*vg(2)+skew(9)*vg(3)
C
        RETURN

transvl2g()

subroutine transvl2g	(		skew,
			vl,
			vg )

Definition at line 9018 of file imp_solv.F.

C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        my_real
     .     skew(*),vg(*),vl(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER J
C----------------------------------------
        vg(1)=skew(1)*vl(1)+skew(4)*vl(2)+skew(7)*vl(3)
        vg(2)=skew(2)*vl(1)+skew(5)*vl(2)+skew(8)*vl(3)
        vl(3)=skew(3)*vl(1)+skew(6)*vl(2)+skew(9)*vl(3)
C
        RETURN

upd_rhs_fr()

subroutine upd_rhs_fr	(	integer, dimension(*)	icodt,
		integer, dimension(*)	icodr,
		integer, dimension(*)	iskew,
		integer, dimension(nifv,*)	ibfv,
			xframe,
			rby,
			x,
			skew,
		integer, dimension(*)	lpby,
		integer, dimension(nnpby,*)	npby,
		integer	nrbyac,
		integer, dimension(*)	irbyac,
		integer	nint2,
		integer, dimension(*)	iint2,
		integer, dimension(npari,*)	ipari,
		type(intbuf_struct_), dimension(*)	intbuf_tab,
		integer, dimension(*)	ndof,
		integer, dimension(*)	iddl,
		integer, dimension(*)	ikc,
		integer	nddl0,
			b,
		integer	iupd,
		integer, dimension(*)	inloc,
		integer, dimension(*)	lj,
			ac,
			acr,
		integer	nt_rw,
		integer, dimension(*)	w_ddl,
		integer	nddl,
			r02,
		integer, dimension(*)	irbe3,
		integer, dimension(*)	lrbe3,
			frbe3,
		integer, dimension(*)	weight,
		integer, dimension(*)	irbe2,
		integer, dimension(*)	lrbe2 )

Definition at line 7213 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE intbufdef_mod
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
#include      "param_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER IBFV(NIFV,*),ICODT(*),ICODR(*),ISKEW(*),
     .          NINT2 ,IINT2(*),LJ(*),NDDL0,IUPD,
     .          INLOC(*),NT_RW,W_DDL(*) ,NDDL
        INTEGER LPBY(*),NPBY(NNPBY,*),NDOF(*),IDDL(*),IKC(*),
     .          IPARI(NPARI,*), NRBYAC,IRBYAC(*)
        INTEGER WEIGHT(*),IRBE3(*),LRBE3(*),IRBE2(*),LRBE2(*)
        my_real
     .     rby(nrby,*) ,x(3,*) ,skew(*),r02
        my_real
     .    b(*) ,xframe(nxframe,*),ac(3,*),acr(3,*),frbe3(*)
 
        TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER I,J,K,N,JI,JB,K1,IFLAG
C-------R02 correction due the fact that IMP_FRI is done after [K],{LB}condensation----------
C-------only Fext is re-computed, others don't change-------
C-------int2,RBE3,rby speciale (Fext seulement)----------
        IF (iupd==0) THEN
          DO i=1,nint2
            n=iint2(i)
            CALL i2_impr1(ipari(1,n),intbuf_tab(n),
     .                    x  ,ndof ,iddl    ,b  )
          ENDDO
          IF (nrbe2>0) THEN
            CALL rbe2_impr1(
     1                      irbe2  ,lrbe2 ,x     ,skew   ,ndof   ,
     2                      iddl   ,b     ,weight)
          ENDIF
          IF (nrbe3>0) THEN
            CALL rbe3_impr1(
     1                      irbe3  ,lrbe3 ,frbe3  ,x     ,skew   ,
     2                      ndof   ,iddl  ,b      ,weight)
          ENDIF
          DO i=1,nrbyac
            n=irbyac(i)
            k1=irbyac(i+nrbykin)+1
            CALL rby_impr1(x, rby(1,n),lpby(k1),npby(1,n),
     1                     ndof  ,iddl   ,b    )
          ENDDO
        ENDIF
C-------int2,rby speciale (elements deleted)----------
        DO i=1,nint2
          n=iint2(i)
          CALL i2_impr2(ipari(1,n),intbuf_tab(n) ,ac    ,acr  ,
     .                  x  ,ndof ,iddl    ,b  )
        ENDDO
        IF (nrbe3>0) THEN
          CALL rbe3_impr2(
     1                    irbe3  ,lrbe3 ,frbe3  ,x     ,skew   ,
     2                    ndof   ,iddl  ,b      ,weight,ac     ,
     3                    acr    )
        ENDIF
        DO i=1,nrbyac
          n=irbyac(i)
          k1=irbyac(i+nrbykin)+1
          CALL rby_impr2(x, rby(1,n),lpby(k1),npby(1,n),
     1                   ndof  ,iddl   ,b    ,ac    ,acr  )
        ENDDO
C-------------
        CALL ext_rhs(icodt ,icodr ,iskew ,ibfv    ,xframe ,
     1               x     ,skew  ,ndof  ,iddl    ,ikc    ,
     2               nddl0 ,b     ,inloc  ,lj     ,ac     ,
     3               acr   ,nt_rw ,w_ddl  ,nddl   ,r02    )
C
        RETURN

write_tpl_file()

subroutine write_tpl_file	(	character(*)	filnam,
		character(*)	ioff1,
		character(*)	ioff2,
		character(*)	ioff3 )

Definition at line 6353 of file imp_solv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
 
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "impl1_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
        CHARACTER(*) FILNAM,IOFF1,IOFF2,IOFF3
        my_real
     .    r01
C-----------------------------------------------
c FUNCTION: print-out tcp file
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER I,J
        my_real
     .    f_max
C-----------------------------------------------
        WRITE(isoltpl,1000) filnam
        WRITE(isoltpl,1001)
        WRITE(isoltpl,1002) ioff2,1,4,1,3,4,1,'Residual force',1
     .     ,'Residual force','Residual force','Residual force'
     .     ,'Residual force','Residual force','Residual force'
        WRITE(isoltpl,1002) ioff2,1,4,1,0,4,1,'Tolerance force',1
     .     ,'Tolerance force','Tolerance force','Tolerance force'
     .     ,'Tolerance force','Tolerance force','Tolerance force'
        WRITE(isoltpl,1002) ioff3,1,46,1,3,46,1,'Residual disp.',1
     .     ,'Residual disp.','Residual disp.','Residual disp.'
     .     ,'Residual disp.','Residual disp.','Residual disp.'
        WRITE(isoltpl,1002) ioff3,1,46,1,0,4,1,'Tolerance disp.',1
     .     ,'Tolerance disp.','Tolerance disp.','Tolerance disp.'
     .     ,'Tolerance disp.','Tolerance disp.','Tolerance disp.'
        WRITE(isoltpl,1002) ioff1,1,0,1,3,0,1,'Residual energy',1
     .     ,'Residual energy','Residual energy','Residual energy'
     .     ,'Residual energy','Residual energy','Residual energy'
        WRITE(isoltpl,1002) ioff1,1,0,1,0,4,1,'Tolerance energy',1
     .     ,'Tolerance energy','Tolerance energy','Tolerance energy'
     .     ,'Tolerance energy','Tolerance energy','Tolerance energy'
        WRITE(isoltpl,1002) 'On',1,55,1,0,55,1,'Converged step',2
     .     ,'Converged step','Converged step','Converged step'
     .     ,'Converged step','Converged step','Converged step'
        WRITE(isoltpl,1002) 'On',1,2,1,0,2,1,'Diverged step',2
     .     ,'Diverged step','Diverged step','Diverged step'
     .     ,'Diverged step','Diverged step','Diverged step'
        WRITE(isoltpl,1003)
        WRITE(isoltpl,1004) 2,2,2,'Cumulative iterations','Line search coefficient'
        WRITE(isoltpl,1002) 'On',1,50,1,3,50,1,'Line search coefficient',1
     .     ,'Line search coefficient','Line search coefficient','Line search coefficient'
     .     ,'Line search coefficient','Line search coefficient','Line search coefficient'
        WRITE(isoltpl,1003)
        IF (idtc==3) THEN
          WRITE(isoltpl,1004) 3,3,3,'Arc length','Load factor'
          WRITE(isoltpl,1006) 'On',1,27,1,3,27,1,'Load factor',1
     .       ,'Load factor','Load factor','Load factor'
     .       ,'Load factor','Load factor','Load factor'
        ELSE
          WRITE(isoltpl,1004) 3,3,3,'Cumulative iterations','Time (s)'
          WRITE(isoltpl,1002) 'On',1,27,1,3,27,1,'Time',1
     .       ,'Time','Time','Time'
     .       ,'Time','Time','Time'
        ENDIF
        WRITE(isoltpl,1005)
1000    FORMAT('    *BeginPage() // Page 1'/
     .         '        *Title("',a,'", On)'/
     .         '        *TitleFont("Arial", 1, 0, 12)'/
     .         '        *Layout(9)'/
c     .       '        *BeginAnimator(Transient)'/
c     .       '            *CurrentTime(Undeformed)'/
c     .       '            *StartTime(0,0000000)'/
c     .       '            *EndTime(1,0000000)'/
c     .       '            *Increment(Forward, Frame, 1, BounceOff)'/
c     .       '        *EndAnimator()'/
     .         '        *WindowIDs(191, 192, 193)'
     .         )
1001    FORMAT('        *ExportFormat("PNG")'/
     .         '        *BeginPlot()'/
     .         '            *PlotType(0)'/
     .         '            *BeginPlotHeader(On)'/
     .         '                *PrimaryFont("Arial", 0, 0, 14)'/
     .         '                *SecondaryFont("Arial", 0, 0, 10)'/
     .         '                *TertiaryFont("Arial", 0, 0, 10)'/
     .         '                *Color(0)'/
     .         '                *Text("Relative residuals")'/
     .         '                *HeaderAlignment(2)'/
     .         '            *EndPlotHeader()'/
     .         '            *BeginPlotFooter(Off)'/
     .         '                *PrimaryFont("Arial", 0, 0, 10)'/
     .         '                *SecondaryFont("Arial", 0, 0, 10)'/
     .         '                *TertiaryFont("Arial", 0, 0, 10)'/
     .         '                *Color(0)'/
     .         '                *Text("{p1w1c1.y.HWRequest} - {p1w1c1.y.HWComponent}")'/
     .         '                *FooterAlignment(2)'/
     .         '            *EndPlotFooter()'/
     .         '            *BeginLegend(On)'/
     .         '                *Font("Arial", 0, 0, 8)'/
     .         '                *BorderWidth(1)'/
     .         '                *Color(0)'/
     .         '                *Leader(Left)'/
     .         '                *Location(BELOW)'/
     .         '                *AutoPosition(False)'/
     .         '                *Reversed(no)'/
     .         '            *EndLegend()'/
     .         '            *UniformAspectRatio(0)'/
     .         '            *FrameColor(66)'/
     .         '            *BackgroundColor(1)'/
     .         '            *GridLineColor(9)'/
     .         '            *ZeroLineColor(0)'/
     .         '            *BeginAxis(X, "Primary", on)'/
     .         '                *Label("Cumulative iterations")'/
     .         '                *Scale(Linear)'/
     .         '                *TicMethod(Increment)'/
     .         '                *Min(0)'/
     .         '                *Max(1)'/
     .         '                *Format(Auto)'/
     .         '                *Precision(5)'/
     .         '                *Increment(10)'/
     .         '                *Grids(1)'/
     .         '                *Color(67)'/
     .         '                *AutoFit(TRUE)'/
     .         '                *LabelFont("Arial", 0, 0, 10)'/
     .         '                *TicsFont("Arial", 0, 0, 8)'/
     .         '                *FitRange(FALSE)'/
     .         '            *EndAxis()'/
     .         '            *BeginAxis(Y, "Primary", on)'/
     .         '                *Label("Relative residual")'/
     .         '                *Scale(Log)'/
     .         '                *TicMethod(PerAxis)'/
     .         '                *Min(0)'/
     .         '                *Max(1)'/
     .         '                *Format(Auto)'/
     .         '                *Precision(4)'/
     .         '                *TicsPerDecade(1)'/
     .         '                *GridsPerDecade(1)'/
     .         '                *Color(67)'/
     .         '                *AutoFit(TRUE)'/
     .         '                *LabelFont("Arial", 0, 0, 10)'/
     .         '                *TicsFont("Arial", 0, 0, 8)'/
     .         '                *FitRange(FALSE)'/
     .         '            *EndAxis()'/
     .         '            *BeginAxis(Y, "Y1", on)'/
     .         '                *Label("")'/
     .         '                *Scale(Linear)'/
     .         '                *TicMethod(PerAxis)'/
     .         '                *Min(0)'/
     .         '                *Max(1)'/
     .         '                *Format(Auto)'/
     .         '                *Precision(0)'/
     .         '                *Tics(2)'/
     .         '                *Grids(2)'/
     .         '                *Color(67)'/
     .         '                *AutoFit(TRUE)'/
     .         '                *LabelFont("Arial", 0, 0, 8)'/
     .         '                *TicsFont("Arial", 0, 0, 8)'/
     .         '                *FitRange(FALSE)'/
     .         '            *EndAxis()'
     .         )
1002    FORMAT('            *BeginCurve(',a,', "{y.HWComponent}")'/
     .         '                *Line(',i2,',',i2,',',i2,')'/
     .         '                *Symbol(',i2,',',i2,',',i2,')'/
     .         '                *Shade(False)'/
     .         '                *Bar(0, 0, 2)'/
     .         '                *ShowInLegend(True)'/
     .         '                *LayerNumber(31)'/
     .         '                *BeginVector(Y, File)'/
     .         '                    *Filename(PLOT_FILE_1)'/
     .         '                    *Datatype("Unknown")'/
     .         '                    *Request("Block 1")'/
     .         '                    *Component("',a,'")'/
     .         '                    *ScaleFactor("1")'/
     .         '                    *Offset("0")'/
     .         '                    *AxisIndex(',i1,')'/
     .         '                    *Attribute("HWReaderHints", "HWReaderHints", "String", "(USE_RXRESULT_READER_FOR_DSY)")'/
     .         '                    *Attribute("HWFile", "File", "String", PLOT_FILE_1)'/
     .         '                    *Attribute("HWSolver", "Solver", "String", "Unknown")'/
     .         '                    *Attribute("HWDatatype", "Datatype", "String", "Unknown")'/
     .         '                    *Attribute("HWRequest", "Request", "String", "Block 1")'/
     .         '                    *Attribute("HWComponent", "Component", "String", "',a,'")'/
     .         '                    *Attribute("HWComplexComponent", "ComplexComponent", "String", "',a,'")'/
     .         '                    *Attribute("HWReader", "Reader", "String", "hgtextcolumn.exe")'/
     .         '                    *Attribute("HWWordSize", "WordSize", "String", "8")'/
     .         '                *EndVector()'/
     .         '                *BeginVector(X, File)'/
     .         '                    *Filename(PLOT_FILE_1)'/
     .         '                    *Datatype("Unknown")'/
     .         '                    *Request("Block 1")'/
     .         '                    *Component("Cumulative iterations")'/
     .         '                    *ScaleFactor("1")'/
     .         '                    *Offset("0")'/
     .         '                    *AxisIndex(1)'/
     .         '                    *Attribute("HWReaderHints", "HWReaderHints", "String", "(USE_RXRESULT_READER_FOR_DSY)")'/
     .         '                    *Attribute("HWFile", "File", "String", PLOT_FILE_1)'/
     .         '                    *Attribute("HWSolver", "Solver", "String", "Unknown")'/
     .         '                    *Attribute("HWDatatype", "Datatype", "String", "Unknown")'/
     .         '                    *Attribute("HWRequest", "Request", "String", "Block 1")'/
     .         '                    *Attribute("HWComponent", "Component", "String", "Cumulative iterations")'/
     .         '                    *Attribute("HWComplexComponent", "ComplexComponent", "String", "Cumulative iterations")'/
     .         '                    *Attribute("HWReader", "Reader", "String", "hgtextcolumn.exe")'/
     .         '                    *Attribute("HWWordSize", "WordSize", "String", "8")'/
     .         '                *EndVector()'/
     .         '                *BeginVector(Time, File)'/
     .         '                    *Filename(PLOT_FILE_1)'/
     .         '                    *Datatype("Time")'/
     .         '                    *ScaleFactor("1")'/
     .         '                    *Offset("0")'/
     .         '                    *Attribute("HWReaderHints", "HWReaderHints", "String", "(USE_RXRESULT_READER_FOR_DSY)")'/
     .         '                    *Attribute("HWFile", "File", "String", PLOT_FILE_1)'/
     .         '                    *Attribute("HWSolver", "Solver", "String", "Unknown")'/
     .         '                    *Attribute("HWDatatype", "Datatype", "String", "Time")'/
     .         '                    *Attribute("HWRequest", "Request", "String", "Time")'/
     .         '                    *Attribute("HWComponent", "Component", "String", "Time")'/
     .         '                    *Attribute("HWComplexComponent", "ComplexComponent", "String", "Time")'/
     .         '                    *Attribute("HWReader", "Reader", "String", "hgtextcolumn.exe")'/
     .         '                    *Attribute("HWWordSize", "WordSize", "String", "8")'/
     .         '                *EndVector()'/
     .         '                *BeginVector(U, File)'/
     .         '                    *Filename(PLOT_FILE_1)'/
     .         '                    *Datatype("Unknown")'/
     .         '                    *Request("Block 1")'/
     .         '                    *Component("Cumulative iterations")'/
     .         '                    *ScaleFactor("1")'/
     .         '                    *Offset("0")'/
     .         '                    *AxisIndex(1)'/
     .         '                    *Attribute("HWReaderHints", "HWReaderHints", "String", "(USE_RXRESULT_READER_FOR_DSY)")'/
     .         '                    *Attribute("HWFile", "File", "String", PLOT_FILE_1)'/
     .         '                    *Attribute("HWSolver", "Solver", "String", "Unknown")'/
     .         '                    *Attribute("HWDatatype", "Datatype", "String", "Unknown")'/
     .         '                    *Attribute("HWRequest", "Request", "String", "Block 1")'/
     .         '                    *Attribute("HWComponent", "Component", "String", "Cumulative iterations")'/
     .         '                    *Attribute("HWComplexComponent", "ComplexComponent", "String", "Cumulative iterations")'/
     .         '                    *Attribute("HWReader", "Reader", "String", "hgtextcolumn.exe")'/
     .         '                    *Attribute("HWWordSize", "WordSize", "String", "8")'/
     .         '                *EndVector()'/
     .         '                *BeginVector(V, File)'/
     .         '                    *Filename(PLOT_FILE_1)'/
     .         '                    *Datatype("Unknown")'/
     .         '                    *Request("Block 1")'/
     .         '                    *Component("',a,'")'/
     .         '                    *ScaleFactor("1")'/
     .         '                    *Offset("0")'/
     .         '                    *AxisIndex(1)'/
     .         '                    *Attribute("HWReaderHints", "HWReaderHints", "String", "(USE_RXRESULT_READER_FOR_DSY)")'/
     .         '                    *Attribute("HWFile", "File", "String", PLOT_FILE_1)'/
     .         '                    *Attribute("HWSolver", "Solver", "String", "Unknown")'/
     .         '                    *Attribute("HWDatatype", "Datatype", "String", "Unknown")'/
     .         '                    *Attribute("HWRequest", "Request", "String", "Block 1")'/
     .         '                    *Attribute("HWComponent", "Component", "String", "',a,'")'/
     .         '                    *Attribute("HWComplexComponent", "ComplexComponent", "String", "',a,'")'/
     .         '                    *Attribute("HWReader", "Reader", "String", "hgtextcolumn.exe")'/
     .         '                    *Attribute("HWWordSize", "WordSize", "String", "8")'/
     .         '                *EndVector()'/
     .         '                *Attribute("HWLastGoodCurveName", "HWLastGoodCurveName", "String", "',a,'")'/
     .         '            *EndCurve()'
     .         )
1003    FORMAT('        *EndPlot()')
1004    FORMAT('        *ExportFormat("PNG")'/
     .         '        *BeginPlot()'/
     .         '            *PlotType(0)'/
     .         '            *BeginPlotHeader(On)'/
     .         '                *PrimaryFont("Arial", 0, 0, 14)'/
     .         '                *SecondaryFont("Arial", 0, 0, 10)'/
     .         '                *TertiaryFont("Arial", 0, 0, 10)'/
     .         '                *Color(0)'/
     .         '                *Text("{p1w',i1,'c1.y.HWComponent}")'/
     .         '                *HeaderAlignment(2)'/
     .         '            *EndPlotHeader()'/
     .         '            *BeginPlotFooter(Off)'/
     .         '                *PrimaryFont("Arial", 0, 0, 10)'/
     .         '                *SecondaryFont("Arial", 0, 0, 10)'/
     .         '                *TertiaryFont("Arial", 0, 0, 10)'/
     .         '                *Color(0)'/
     .         '                *Text("{p1w',i1,'c1.y.HWRequest} - {p1w',i1,'c1.y.HWComponent}")'/
     .         '                *FooterAlignment(2)'/
     .         '            *EndPlotFooter()'/
     .         '            *BeginLegend(On)'/
     .         '                *Font("Arial", 0, 0, 8)'/
     .         '                *BorderWidth(1)'/
     .         '                *Color(0)'/
     .         '                *Leader(Left)'/
     .         '                *Location(BELOW)'/
     .         '                *AutoPosition(False)'/
     .         '                *Reversed(no)'/
     .         '            *EndLegend()'/
     .         '            *UniformAspectRatio(0)'/
     .         '            *FrameColor(66)'/
     .         '            *BackgroundColor(1)'/
     .         '            *GridLineColor(9)'/
     .         '            *ZeroLineColor(0)'/
     .         '            *BeginAxis(X, "Primary", on)'/
     .         '                *Label("',a,'")'/
     .         '                *Scale(Linear)'/
     .         '                *TicMethod(Increment)'/
     .         '                *Min(0)'/
     .         '                *Max(1)'/
     .         '                *Format(Auto)'/
     .         '                *Precision(5)'/
     .         '                *Increment(10)'/
     .         '                *Grids(1)'/
     .         '                *Color(67)'/
     .         '                *AutoFit(TRUE)'/
     .         '                *LabelFont("Arial", 0, 0, 10)'/
     .         '                *TicsFont("Arial", 0, 0, 8)'/
     .         '                *FitRange(FALSE)'/
     .         '            *EndAxis()'/
     .         '            *BeginAxis(Y, "Primary", on)'/
     .         '                *Label("',a,'")'/
     .         '                *Scale(Linear)'/
     .         '                *TicMethod(PerAxis)'/
     .         '                *Min(0)'/
     .         '                *Max(1)'/
     .         '                *Format(Auto)'/
     .         '                *Precision(5)'/
     .         '                *Tics(11)'/
     .         '                *Grids(1)'/
     .         '                *Color(67)'/
     .         '                *AutoFit(TRUE)'/
     .         '                *LabelFont("Arial", 0, 0, 10)'/
     .         '                *TicsFont("Arial", 0, 0, 8)'/
     .         '                *FitRange(FALSE)'/
     .         '            *EndAxis()'
     .         )
1005    FORMAT('        *EndPlot()'/
     .         '        *TimeScales(1, 1, 1)'/
     .         '        *TimeDelays(0, 0, 0)'/
     .         '        *AnimationEnable(1, 1, 1)'/
     .         '        *SyncTolerance(2e-008)'/
     .         '        *SyncTableGenerationPolicy(ALL_BLOCKS)'/
     .         '    *EndPage()'/
     .         '*EndDefine()'
     .         )
1006    FORMAT('            *BeginCurve(',a,', "{y.HWComponent}")'/
     .         '                *Line(',i2,',',i2,',',i2,')'/
     .         '                *Symbol(',i2,',',i2,',',i2,')'/
     .         '                *Shade(False)'/
     .         '                *Bar(0, 0, 2)'/
     .         '                *ShowInLegend(True)'/
     .         '                *LayerNumber(31)'/
     .         '                *BeginVector(Y, File)'/
     .         '                    *Filename(PLOT_FILE_1)'/
     .         '                    *Datatype("Unknown")'/
     .         '                    *Request("Block 1")'/
     .         '                    *Component("',a,'")'/
     .         '                    *ScaleFactor("1")'/
     .         '                    *Offset("0")'/
     .         '                    *AxisIndex(',i1,')'/
     .         '                    *Attribute("HWReaderHints", "HWReaderHints", "String", "(USE_RXRESULT_READER_FOR_DSY)")'/
     .         '                    *Attribute("HWFile", "File", "String", PLOT_FILE_1)'/
     .         '                    *Attribute("HWSolver", "Solver", "String", "Unknown")'/
     .         '                    *Attribute("HWDatatype", "Datatype", "String", "Unknown")'/
     .         '                    *Attribute("HWRequest", "Request", "String", "Block 1")'/
     .         '                    *Attribute("HWComponent", "Component", "String", "',a,'")'/
     .         '                    *Attribute("HWComplexComponent", "ComplexComponent", "String", "',a,'")'/
     .         '                    *Attribute("HWReader", "Reader", "String", "hgtextcolumn.exe")'/
     .         '                    *Attribute("HWWordSize", "WordSize", "String", "8")'/
     .         '                *EndVector()'/
     .         '                *BeginVector(X, File)'/
     .         '                    *Filename(PLOT_FILE_1)'/
     .         '                    *Datatype("Unknown")'/
     .         '                    *Request("Block 1")'/
     .         '                    *Component("Arc length")'/
     .         '                    *ScaleFactor("1")'/
     .         '                    *Offset("0")'/
     .         '                    *AxisIndex(1)'/
     .         '                    *Attribute("HWReaderHints", "HWReaderHints", "String", "(USE_RXRESULT_READER_FOR_DSY)")'/
     .         '                    *Attribute("HWFile", "File", "String", PLOT_FILE_1)'/
     .         '                    *Attribute("HWSolver", "Solver", "String", "Unknown")'/
     .         '                    *Attribute("HWDatatype", "Datatype", "String", "Unknown")'/
     .         '                    *Attribute("HWRequest", "Request", "String", "Block 1")'/
     .         '                    *Attribute("HWComponent", "Component", "String", "Arc length")'/
     .         '                    *Attribute("HWComplexComponent", "ComplexComponent", "String", "Arc length")'/
     .         '                    *Attribute("HWReader", "Reader", "String", "hgtextcolumn.exe")'/
     .         '                    *Attribute("HWWordSize", "WordSize", "String", "8")'/
     .         '                *EndVector()'/
     .         '                *BeginVector(Time, File)'/
     .         '                    *Filename(PLOT_FILE_1)'/
     .         '                    *Datatype("Time")'/
     .         '                    *ScaleFactor("1")'/
     .         '                    *Offset("0")'/
     .         '                    *Attribute("HWReaderHints", "HWReaderHints", "String", "(USE_RXRESULT_READER_FOR_DSY)")'/
     .         '                    *Attribute("HWFile", "File", "String", PLOT_FILE_1)'/
     .         '                    *Attribute("HWSolver", "Solver", "String", "Unknown")'/
     .         '                    *Attribute("HWDatatype", "Datatype", "String", "Time")'/
     .         '                    *Attribute("HWRequest", "Request", "String", "Time")'/
     .         '                    *Attribute("HWComponent", "Component", "String", "Time")'/
     .         '                    *Attribute("HWComplexComponent", "ComplexComponent", "String", "Time")'/
     .         '                    *Attribute("HWReader", "Reader", "String", "hgtextcolumn.exe")'/
     .         '                    *Attribute("HWWordSize", "WordSize", "String", "8")'/
     .         '                *EndVector()'/
     .         '                *BeginVector(U, File)'/
     .         '                    *Filename(PLOT_FILE_1)'/
     .         '                    *Datatype("Unknown")'/
     .         '                    *Request("Block 1")'/
     .         '                    *Component("Arc length")'/
     .         '                    *ScaleFactor("1")'/
     .         '                    *Offset("0")'/
     .         '                    *AxisIndex(1)'/
     .         '                    *Attribute("HWReaderHints", "HWReaderHints", "String", "(USE_RXRESULT_READER_FOR_DSY)")'/
     .         '                    *Attribute("HWFile", "File", "String", PLOT_FILE_1)'/
     .         '                    *attribute("HWSolver", "Solver", "String", "Unknown")'/
     .         '                    *attribute("HWDatatype", "Datatype", "String", "Unknown")'/
     .         '                    *attribute("HWRequest", "Request", "String", "Block 1")'/
     .         '                    *attribute("HWComponent", "Component", "String", "Arc length")'/
     .         '                    *attribute("HWComplexComponent", "ComplexComponent", "String", "Arc length")'/
     .         '                    *attribute("HWReader", "Reader", "String", "hgtextcolumn.exe")'/
     .         '                    *attribute("HWWordSize", "WordSize", "String", "8")'/
     .         '                *endvector()'/
     .         '                *beginvector(v, file)'/
     .         '                    *filename(plot_file_1)'/
     .         '                    *datatype("Unknown")'/
     .         '                    *request("Block 1")'/
     .         '                    *component("',A,'")'/
     .         '                    *scalefactor("1")'/
     .         '                    *offset("0")'/
     .         '                    *axisindex(1)'/
     .         '                    *attribute("HWReaderHints", "HWReaderHints", "String", "(USE_RXRESULT_READER_FOR_DSY)")'/
     .         '                    *attribute("HWFile", "File", "String", plot_file_1)'/
     .         '                    *attribute("HWSolver", "Solver", "String", "Unknown")'/
     .         '                    *attribute("HWDatatype", "Datatype", "String", "Unknown")'/
     .         '                    *attribute("HWRequest", "Request", "String", "Block 1")'/
     .         '                    *attribute("HWComponent", "Component", "String", "',A,'")'/
     .         '                    *attribute("HWComplexComponent", "ComplexComponent", "String", "',A,'")'/
     .         '                    *attribute("HWReader", "Reader", "String", "hgtextcolumn.exe")'/
     .         '                    *attribute("HWWordSize", "WordSize", "String", "8")'/
     .         '                *endvector()'/
     .         '                *attribute("HWLastGoodCurveName", "HWLastGoodCurveName", "String", "',A,'")'/
     .         '            *endcurve()'
     .         )
C------------------------------------------
        RETURN