zfac_front_type2_aux.F

Go to the documentation of this file.

C
C  This file is part of MUMPS 5.5.1, released
C  on Tue Jul 12 13:17:24 UTC 2022
C
C
C  Copyright 1991-2022 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria,
C  Mumps Technologies, University of Bordeaux.
C
C  This version of MUMPS is provided to you free of charge. It is
C  released under the CeCILL-C license 
C  (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and
C  https://cecill.info/licences/Licence_CeCILL-C_V1-en.html)
C
      MODULE zmumps_fac_front_type2_aux_m
      CONTAINS
      SUBROUTINE zmumps_fac_i_ldlt_niv2( 
     &      DIAG_ORIG, SIZEDIAG_ORIG, GW_FACTCUMUL,
     &      NFRONT, NASS, IBEG_BLOCK_TO_SEND, IBEG_BLOCK, IEND_BLOCK,
     &      NASS2, TIPIV,
     &      N, INODE, IW, LIW, A, LA, NNEGW, NB22T2W, NBTINYW,
     &      DET_EXPW, DET_MANTW, DET_SIGNW,
     &                   INOPV, IFLAG,
     &                   IOLDPS, POSELT, UU, 
     &                   SEUIL,KEEP,KEEP8,PIVSIZ,
     &                   DKEEP,PIVNUL_LIST,LPN_LIST,
     &                   PP_FIRST2SWAP_L, PP_LastPanelonDisk,
     &                   PP_LastPIVRPTRIndexFilled, 
     &                   PIVOT_OPTION,   
     &                   Inextpiv, IEND_BLR, LR_ACTIVATED,
     &                   OOC_EFFECTIVE_ON_FRONT)
      USE mumps_ooc_common, ONLY : typef_l   
      USE zmumps_fac_front_aux_m
      IMPLICIT NONE
      INTEGER SIZEDIAG_ORIG
      DOUBLE PRECISION    DIAG_ORIG(SIZEDIAG_ORIG)
      DOUBLE PRECISION    GW_FACTCUMUL
      INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,INOPV
      INTEGER NASS2, IBEG_BLOCK_TO_SEND, IBEG_BLOCK, IEND_BLOCK
      INTEGER, intent(inout) :: NNEGW, NB22T2W, NBTINYW
      INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW
      COMPLEX(kind=8), intent(inout) :: DET_MANTW
      INTEGER TIPIV( NASS2 )
      INTEGER PIVSIZ,LPIV
      INTEGER, intent(in)    :: PIVOT_OPTION, IEND_BLR
      LOGICAL, intent(in)    :: LR_ACTIVATED
      INTEGER, intent(inout) :: Inextpiv
      LOGICAL, intent(in)    :: OOC_EFFECTIVE_ON_FRONT
      INTEGER(8) :: LA
      COMPLEX(kind=8) A(LA) 
      DOUBLE PRECISION UU, UULOC, SEUIL
      COMPLEX(kind=8) CSEUIL
      INTEGER IW(LIW) 
      INTEGER   IOLDPS
      INTEGER(8) :: POSELT
      INTEGER KEEP(500)
      INTEGER(8) KEEP8(150)
      INTEGER LPN_LIST
      INTEGER PIVNUL_LIST(LPN_LIST)
      DOUBLE PRECISION DKEEP(230)
      INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk
      INTEGER PP_LastPIVRPTRIndexFilled
      include 'mpif.h'
      INTEGER(8) :: POSPV1,POSPV2,OFFDAG,APOSJ
      INTEGER JMAX
      INTEGER :: IPIVNUL, HF 
      DOUBLE PRECISION RMAX,AMAX,TMAX,RMAX_NORELAX,MAX_PREV_in_PARPIV
      DOUBLE PRECISION MAXPIV, ABS_PIVOT
      DOUBLE PRECISION RMAX_NOSLAVE, TMAX_NOSLAVE
      COMPLEX(kind=8) PIVOT,DETPIV
      DOUBLE PRECISION    ABSDETPIV
      include 'mumps_headers.h'
      INTEGER(8) :: APOSMAX, APOSROW
      INTEGER(8) :: APOS
      INTEGER(8) :: J1, J2, JJ, KK
      DOUBLE PRECISION       :: GROWTH, RSWOP
      DOUBLE PRECISION       :: UULOCM1
      INTEGER    :: LDAFS
      INTEGER(8) :: LDAFS8
      DOUBLE PRECISION, PARAMETER :: RZERO = 0.0d0
      DOUBLE PRECISION, PARAMETER :: RONE  = 1.0d0
      COMPLEX(kind=8) ZERO, ONE
      parameter( zero = (0.0d0,0.0d0) )
      parameter( one = (1.0d0,0.0d0) )
      DOUBLE PRECISION PIVNUL, VALTMP
      COMPLEX(kind=8) FIXA
      INTEGER NPIV,IPIV,K219
      INTEGER NPIVP1,ILOC,K,J
      INTEGER ISHIFT, K206, IPIV_END, IPIV_SHIFT
      INTRINSIC max
      INTEGER I_PIVRPTR, I_PIVR, NBPANELS_L
      DOUBLE PRECISION GW_FACT 
      gw_fact = rone
      amax = rzero
      rmax = rzero
      tmax = rzero
      rmax_noslave = rzero
      pivot = one
      hf = 6 + iw(ioldps+5+keep(ixsz)) + keep(ixsz)
      k206  = keep(206)
      pivnul = dkeep(1)
      fixa   = cmplx(dkeep(2),kind=kind(fixa))
      cseuil = cmplx(seuil,kind=kind(cseuil))
      ldafs  = nass
      ldafs8 = int(ldafs,8)
      IF ((keep(50).NE.1) .AND. ooc_effective_on_front) THEN
             CALL zmumps_get_ooc_perm_ptr(typef_l, nbpanels_l, 
     &       i_pivrptr, i_pivr, 
     &       ioldps+2*nfront+6+iw(ioldps+5+keep(ixsz))
     &              +keep(ixsz),
     &       iw, liw)
      ENDIF
        uuloc = uu
        k219  = keep(219)  
        IF (uuloc.GT.rzero) THEN 
          uulocm1 = rone/uuloc
        ELSE
          k219=0
          uulocm1 = rone
        ENDIF
        IF (k219.LT.2) gw_factcumul = rone
        pivsiz = 1
        npiv    = iw(ioldps+1+keep(ixsz))
        npivp1  = npiv + 1
        iloc = npivp1 - ibeg_block_to_send + 1
        tipiv( iloc ) = iloc
        aposmax = poselt+ldafs8*ldafs8-1_8
        IF(inopv .EQ. -1) THEN
           apos = poselt + ldafs8*int(npivp1-1,8) + int(npiv,8)
           pospv1 = apos
           abs_pivot = abs(pivot)
           CALL zmumps_update_minmax_pivot 
     &           ( abs_pivot,
     &             dkeep, keep, .true.)
           IF(abs_pivot.LT.seuil) THEN
              IF(dble(a(apos)) .GE. rzero) THEN
                 a(apos) = cseuil
              ELSE
                 a(apos) = -cseuil
              ENDIF
              nbtinyw = nbtinyw + 1
           ELSE IF (keep(258) .NE.0 ) THEN
             CALL zmumps_updatedeter( a(apos), det_mantw, det_expw )
           ENDIF
           IF ((keep(50).NE.1) .AND. ooc_effective_on_front) THEN
             CALL zmumps_store_perminfo( iw(i_pivrptr), nbpanels_l,
     &               iw(i_pivr), nass, npivp1, npivp1, 
     &               pp_lastpanelondisk,
     &               pp_lastpivrptrindexfilled)
           ENDIF
           GO TO 420
        ENDIF
        inopv   = 0
      IF ((k219.GE.2).AND.(npivp1.EQ.1)) THEN 
        gw_factcumul = rone
        IF (k219.EQ.3) THEN
         DO ipiv=1,nass
            diag_orig(ipiv)  = abs(a(poselt +
     &                              (ldafs8+1_8)*int(ipiv-1,8)))
         ENDDO
        ELSE IF (k219.GE.4) THEN
         diag_orig  = rzero
         DO ipiv=1,nass
          apos = poselt + ldafs8*int(ipiv-1,8) 
          pospv1 = apos + int(ipiv - 1,8)
          diag_orig(ipiv) = max( abs(a(pospv1)), diag_orig(ipiv) ) 
          DO j=ipiv+1,nass
           diag_orig(ipiv) = max( abs(a(pospv1)), diag_orig(ipiv) ) 
           diag_orig(ipiv+j-ipiv) = max( abs(a(pospv1)), 
     &                                   diag_orig(ipiv+j-ipiv) ) 
           pospv1 = pospv1 + ldafs8
          ENDDO
         ENDDO
        ENDIF
      ENDIF
      ishift = 0              
      ipiv_end = iend_block   
      IF (k206.GE.1) THEN
        IF (inextpiv.GT.npivp1.AND.inextpiv.LE.iend_block) THEN
          ishift = inextpiv - npivp1
        ENDIF
        IF ( k206.EQ.1
     &      .OR.  (k206 .GT.1 .AND. iend_block.EQ.iend_blr) ) THEN
          ipiv_end = iend_block + ishift
        ENDIF
      ENDIF  
       DO 460 ipiv_shift = npivp1+ishift, ipiv_end
            IF (ipiv_shift .LE. iend_block) THEN
              ipiv=ipiv_shift
            ELSE
              ipiv = ipiv_shift-iend_block-1+npivp1
              IF (ibeg_block.EQ.npivp1) THEN
                EXIT
              ENDIF
            ENDIF
            apos = poselt + ldafs8*int(ipiv-1,8) + int(npiv,8)
            pospv1 = apos + int(ipiv - npivp1,8)
            pivot     = a(pospv1)
            abs_pivot = abs(pivot)
            IF (uuloc.EQ.rzero.OR.pivot_option.EQ.0) THEN 
              IF(abs_pivot.LT.seuil) THEN
                CALL zmumps_update_minmax_pivot 
     &               ( abs_pivot,
     &                 dkeep, keep, .true.)
                IF(dble(pivot) .GE. rzero) THEN
                    a(pospv1) = cseuil
                ELSE
                    a(pospv1) = -cseuil
                ENDIF
                nbtinyw = nbtinyw + 1
              ELSE IF (abs_pivot.EQ.rzero) THEN
                    GO TO 630 
              ELSE
                CALL zmumps_update_minmax_pivot 
     &           ( abs_pivot, dkeep, keep, .false.)
                IF (keep(258) .NE. 0) THEN
                 CALL zmumps_updatedeter(pivot, det_mantw, det_expw )
                ENDIF
              ENDIF
              GO TO 420
            ENDIF
            amax = -rone
            jmax = 0
            j1 = apos
            j2 = pospv1 - 1_8
            DO jj=j1,j2
               IF(abs(a(jj)) .GT. amax) THEN
                  amax = abs(a(jj))
                  jmax = ipiv - int(pospv1-jj)
               ENDIF
            ENDDO
            j1 = pospv1 + ldafs8
            DO j=1, iend_block - ipiv
               IF(abs(a(j1)) .GT. amax) THEN
                  amax = abs(a(j1))
                  jmax = ipiv + j
               ENDIF
               j1 = j1 + ldafs8
            ENDDO
            rmax_noslave = rzero
            IF (pivot_option.EQ.2) THEN
              DO j=1,nass - iend_block
                rmax_noslave = max(abs(a(j1+ldafs8*int(j-1,8))),
     &                             rmax_noslave)
              ENDDO
            ENDIF
            IF (k219.NE.0) THEN
             rmax_norelax = dble(a(aposmax+int(ipiv,8)))
             rmax         = rmax_norelax
             IF (k219.GE.2) THEN
              IF (abs_pivot.NE.rzero.AND.
     &            abs_pivot.GE.uuloc*max(rmax,rmax_noslave,amax)) 
     &            THEN
               growth = rone
               IF (k219.EQ.3) THEN
                IF (diag_orig(ipiv).EQ.rzero) THEN
                 diag_orig(ipiv) = abs_pivot
                ELSE
                 growth =  abs_pivot / diag_orig(ipiv)
                ENDIF
               ELSE IF (k219.GE.4) THEN
                IF (diag_orig(ipiv).EQ.rzero) THEN
                 diag_orig(ipiv) = max(amax,rmax_noslave)
                ELSE
                 growth = max(abs_pivot,amax,rmax_noslave)/
     &                         diag_orig(ipiv)
                ENDIF
               ENDIF
               rmax = rmax*max(growth,gw_factcumul)
              ENDIF
             ENDIF   
            ELSE     
             rmax         = rzero
             rmax_norelax = rzero
            ENDIF
            rmax_noslave = max(rmax_norelax,rmax_noslave)
            rmax         = max(rmax,rmax_noslave)
            IF (max(amax,rmax,abs_pivot).LE.pivnul) THEN
               IF ((k219.NE.0)
     &             .AND.(k219.NE.-1)
     &             .AND.(rmax_norelax.LT.0)
     &             .AND.(ipiv.GT.1)) THEN
                 max_prev_in_parpiv = rzero
                 DO jj=1,ipiv-1
                  max_prev_in_parpiv= max( max_prev_in_parpiv, 
     &                dble(a(aposmax+int(jj,8))) )
                 ENDDO
                 IF (max_prev_in_parpiv.GT.pivnul) THEN
                   aposrow = poselt + ldafs8*int(ipiv-1,8)
                   DO jj=1,ipiv-1
                     IF (abs(a(aposrow+jj-1)).GT.pivnul) THEN
                       GOTO 460
                     ENDIF
                   ENDDO
                 ENDIF
               ENDIF
               CALL zmumps_update_minmax_pivot 
     &           ( abs(a(pospv1)), dkeep, keep, .true.)
               keep(109) = keep(109) + 1
               ipivnul = keep(109)
               pivnul_list(ipivnul) = iw( ioldps+hf+npiv+ipiv-npivp1 )
               IF (dble(fixa).GT.rzero) THEN
                 IF(dble(pivot) .GE. rzero) THEN
                   a(pospv1) = fixa
                 ELSE
                   a(pospv1) = -fixa
                 ENDIF
               ELSE
                 j1 = apos
                 j2 = pospv1 - 1_8
                 DO jj=j1,j2
                    a(jj) = zero
                 ENDDO
                 DO j=1, nass-ipiv
                   a(pospv1+int(j,8)*ldafs8) = zero
                 ENDDO
                 valtmp = max(1.0d10*rmax, sqrt(huge(rmax))/1.0d8)
                 a(pospv1) = cmplx(valtmp,kind=kind(a))
               ENDIF
               pivot = a(pospv1)
               abs_pivot = abs(pivot)
               GO TO 415
            ENDIF
             rmax         = max(rmax,abs(rmax_norelax))
        IF (abs_pivot.GE.uuloc*max(rmax,amax)
     &      .AND. abs_pivot .GT. max(seuil, tiny(rmax))) THEN
          CALL zmumps_update_minmax_pivot 
     &       ( abs_pivot, dkeep, keep, .false.)
          IF (keep(258) .NE.0 ) THEN
            CALL zmumps_updatedeter(pivot, det_mantw, det_expw )
          ENDIF
          GO TO 415
        END IF
         IF (npivp1.EQ.iend_block) THEN
           GOTO 460
         ELSE IF (jmax .EQ.0) THEN
           GOTO 460
         ENDIF
         IF (max(abs(pivot),rmax,amax).LE.tiny(rmax)) THEN
           GOTO 460
         ENDIF
            IF (rmax_noslave.LT.amax) THEN
               j1 = apos
               j2 = pospv1 - 1_8
               DO jj=j1,j2
                  IF(int(pospv1-jj) .NE. ipiv-jmax) THEN
                     rmax_noslave = max(rmax_noslave,abs(a(jj)))
                  ENDIF
               ENDDO
               DO j=1,nass-ipiv
                  IF(ipiv+j .NE. jmax) THEN
                     rmax_noslave = max(abs(a(pospv1+ldafs8*int(j,8))),
     &                                  rmax_noslave)
                  ENDIF
               ENDDO
               rmax = max(rmax, rmax_noslave)
            ENDIF            
            aposj = poselt + int(jmax-1,8)*ldafs8 + int(npiv,8)
            pospv2 = aposj + int(jmax - npivp1,8)
            IF (ipiv.LT.jmax) THEN
               offdag = aposj + int(ipiv - npivp1,8)
            ELSE
               offdag = apos + int(jmax - npivp1,8)
            END IF
            tmax_noslave = rzero
            IF(jmax .LT. ipiv) THEN
               jj = pospv2
               DO k = 1, nass-jmax
                  jj = jj+ldafs8    
                  IF (jmax+k.NE.ipiv) THEN
                     tmax_noslave=max(tmax_noslave,abs(a(jj)))
                  ENDIF
               ENDDO
               DO kk =  aposj, pospv2-1_8
                  tmax_noslave = max(tmax_noslave,abs(a(kk)))
               ENDDO
              ELSE
               jj = pospv2
               DO k = 1, nass-jmax
                  jj = jj+ldafs8 
                  tmax_noslave=max(tmax_noslave,abs(a(jj)))
               ENDDO
               DO kk =  aposj, pospv2 - 1_8
                  IF (kk.NE.offdag) THEN
                     tmax_noslave = max(tmax_noslave,abs(a(kk)))
                  ENDIF
               ENDDO
            ENDIF 
            IF (k219.NE.0) THEN
             tmax = max(seuil*uulocm1,
     &                   abs(dble(a(aposmax+int(jmax,8))))
     &                  )
            ELSE    
             tmax = seuil*uulocm1
            ENDIF
            IF (k219.GE.2) THEN
             growth = rone  
             IF (k219.EQ.3) THEN
              IF (diag_orig(jmax).EQ.rzero) THEN
                 diag_orig(jmax) = abs(a(pospv2))
              ELSE
                growth = abs(a(pospv2))/diag_orig(jmax)
              ENDIF
             ELSE IF (k219.EQ.4) THEN
              IF (diag_orig(jmax).EQ.rzero) THEN
               diag_orig(jmax)=max(abs(a(pospv2)),amax,tmax_noslave)
              ELSE
               growth = max(abs(a(pospv2)),amax,tmax_noslave) 
     &                  / diag_orig(jmax)
              ENDIF
             ENDIF
             tmax = tmax*max(growth,gw_factcumul)
            ENDIF  
            tmax = max(tmax,tmax_noslave)
            detpiv = a(pospv1)*a(pospv2) - a(offdag)*a(offdag)
            absdetpiv = abs(detpiv)
            IF (seuil.GT.rzero) THEN
               IF (sqrt(absdetpiv) .LE. seuil ) THEN
                 GOTO 460
               ENDIF
            ENDIF
            maxpiv = max(abs(a(pospv1)),abs(a(pospv2)))
            IF (maxpiv.EQ.rzero) maxpiv = rone
            IF ((abs(a(pospv2))*rmax+amax*tmax)*uuloc.GT.
     &            absdetpiv .OR. absdetpiv .EQ. rzero) THEN
              GO TO 460
            ENDIF
            IF ((abs(a(pospv1))*tmax+amax*rmax)*uuloc.GT.
     &           absdetpiv .OR. absdetpiv .EQ. rzero) THEN
              GO TO 460
            ENDIF
           CALL zmumps_update_minmax_pivot 
     &           ( sqrt(abs(detpiv)),
     &             dkeep, keep, .false.)
           IF (keep(258).NE.0) THEN
             CALL zmumps_updatedeter(detpiv, det_mantw, det_expw )
           ENDIF
           pivsiz = 2
           nb22t2w = nb22t2w+1
 415       CONTINUE
           IF (k206.GE.1) THEN
             inextpiv = max(npivp1+pivsiz, ipiv+1)
           ENDIF
           DO k=1,pivsiz
              IF (pivsiz .EQ. 2 ) THEN
                IF (k==1) THEN
                  lpiv = min(ipiv, jmax)
                  tipiv(iloc) = -(lpiv - ibeg_block_to_send + 1)
                ELSE
                  lpiv = max(ipiv, jmax)
                  tipiv(iloc+1) = -(lpiv - ibeg_block_to_send + 1)
                ENDIF
              ELSE
                lpiv = ipiv
                tipiv(iloc) = ipiv - ibeg_block_to_send + 1
              ENDIF
              IF (lpiv.EQ.npivp1) THEN
                 GOTO 416
              ENDIF
              keep8(80) = keep8(80)+1
              CALL zmumps_swap_ldlt( a, la, iw, liw,
     &             ioldps, npivp1, lpiv, poselt, nass,
     &             ldafs, nfront, 2, k219, keep(50),
     &             keep(ixsz), ibeg_block_to_send )
              IF (k219.GE.3) THEN
               rswop = diag_orig(lpiv)   
               diag_orig(lpiv) = diag_orig(npivp1) 
               diag_orig(npivp1) = rswop 
              ENDIF
 416          CONTINUE
              IF ((keep(50).NE.1) .AND. ooc_effective_on_front) THEN
                CALL zmumps_store_perminfo( 
     &           iw(i_pivrptr), nbpanels_l,
     &           iw(i_pivr), nass, npivp1, lpiv, pp_lastpanelondisk,
     &           pp_lastpivrptrindexfilled)
              ENDIF
              npivp1 = npivp1+1
           ENDDO
           IF(pivsiz .EQ. 2) THEN
              a(poselt+ldafs8*int(npiv,8)+int(npiv+1,8)) = detpiv
           ENDIF
           GOTO 420
  460   CONTINUE
          IF (k206 .GE. 1) THEN
            inextpiv=iend_block+1
          ENDIF
      IF (iend_block.EQ.nass) THEN
       inopv = 1
      ELSE
       inopv = 2
      ENDIF
      GO TO 420
  630 CONTINUE
      iflag = -10
  420 CONTINUE
      IF (k219.GE.2) THEN
       IF(inopv .EQ. 0) THEN
         IF(pivsiz .EQ. 1) THEN
            gw_fact = max(amax,rmax_noslave)/abs_pivot
         ELSE IF(pivsiz .EQ. 2) THEN
            gw_fact = max(
     &          (abs(a(pospv2))*rmax_noslave+amax*tmax_noslave) 
     &             /  absdetpiv ,
     &          (abs(a(pospv1))*tmax_noslave+amax*rmax_noslave) 
     &            /  absdetpiv
     &          )
         ENDIF
         gw_fact = min(gw_fact, uulocm1)  
         gw_factcumul = max(gw_fact,gw_factcumul)
       ENDIF 
      ENDIF  
      RETURN
      END SUBROUTINE zmumps_fac_i_ldlt_niv2
      SUBROUTINE zmumps_fac_mq_ldlt_niv2
     &     (iend_block,
     &     nass, npiv, inode, a, la, ldafs, 
     &     poselt,ifinb,pivsiz,
     &     k219, pivot_option, iend_blr, lr_activated)
      IMPLICIT NONE
      INTEGER(8), intent(in) :: LA, POSELT
      INTEGER,    intent(in) :: K219
      COMPLEX(kind=8), intent(inout) :: A(LA)
      INTEGER, intent(in)    :: IEND_BLOCK
      INTEGER, intent(in)    :: NPIV, PIVSIZ
      INTEGER, intent(in)    :: NASS,INODE,LDAFS
      INTEGER, intent(out)   :: IFINB
      INTEGER, intent(in)    :: PIVOT_OPTION, IEND_BLR
      LOGICAL, intent(in)    :: LR_ACTIVATED
      COMPLEX(kind=8)    VALPIV
      INTEGER NCB1
      INTEGER(8) :: APOS, APOSMAX
      INTEGER(8) :: LPOS, LPOS1, LPOS2, K1POS 
      INTEGER(8) :: JJ, K1, K2
      INTEGER(8) :: POSPV1, POSPV2, OFFDAG, OFFDAG_OLD
      INTEGER(8) :: LDAFS8
      INTEGER NEL2
      COMPLEX(kind=8) ONE, ALPHA
      COMPLEX(kind=8) ZERO
      INTEGER NPIV_NEW, I
      INTEGER(8) :: IBEG, IEND, IROW, J8
      INTEGER    :: J2
      COMPLEX(kind=8) SWOP,DETPIV,MULT1,MULT2, A11, A22, A12
      parameter(one=(1.0d0,0.0d0), alpha=(-1.0d0,0.0d0))
      parameter(zero=(0.0d0,0.0d0))
      include 'mumps_headers.h'
      ldafs8 = int(ldafs,8)
      npiv_new = npiv + pivsiz
      ifinb  = 0
      nel2   = iend_block - npiv_new
      IF (nel2.EQ.0) THEN
        IF (iend_block.EQ.nass) THEN
          ifinb        = -1
        ELSE
          ifinb        = 1
        ENDIF
      ENDIF
      IF(pivsiz .EQ. 1) THEN
         apos   = poselt + int(npiv,8)*(ldafs8 + 1_8)
         valpiv = one/a(apos)
         lpos   = apos + ldafs8
         DO i = 1, nel2
           k1pos = lpos + int(i-1,8)*ldafs8
           a(apos+int(i,8))=a(k1pos)
           a(k1pos) = a(k1pos) * valpiv
           DO jj=1_8, int(i,8)
             a(k1pos+jj)=a(k1pos+jj) - a(k1pos) * a(apos+jj)
           ENDDO
         ENDDO
         IF (pivot_option.EQ.2) THEN
           ncb1 = nass - iend_block
         ELSE
           ncb1 = iend_blr - iend_block
         ENDIF
!$OMP    PARALLEL DO PRIVATE(JJ,K1POS) IF (NCB1 > 300)
         DO i=nel2+1, nel2 + ncb1
           k1pos = lpos+ int(i-1,8)*ldafs8
           a(apos+int(i,8))=a(k1pos)
           a(k1pos) = a(k1pos) * valpiv
           DO jj = 1_8, int(nel2,8)
             a(k1pos+jj)=a(k1pos+jj) - a(k1pos) * a(apos+jj)
           ENDDO
         ENDDO
!$OMP    END PARALLEL DO
         IF (k219.eq. -1) THEN
           aposmax = poselt + int(nass,8) * ldafs8 + int(npiv,8)
           a(aposmax) = a(aposmax) * abs(valpiv)
           DO j8 = 1_8, int(nel2+ncb1,8)
             a(aposmax+j8) = a(aposmax+j8) +
     &                      a(aposmax) * abs(a(apos+j8))
           ENDDO
         ENDIF
      ELSE
         pospv1 = poselt + int(npiv,8)*(ldafs8 + 1_8)
         pospv2 = pospv1+ldafs8+1_8
         offdag_old = pospv2 - 1_8
         offdag = pospv1+1_8
         swop = a(pospv2)
         detpiv = a(offdag)
         a22 = a(pospv1)/detpiv   
         a11 =  swop/detpiv       
         a12 = -a(offdag_old)/detpiv   
         a(offdag)     = a(offdag_old)  
         a(offdag_old) = zero
         lpos1   = pospv2 + ldafs8 - 1_8
         lpos2   = lpos1 + 1_8
         CALL zcopy(nass-npiv_new, a(lpos1), ldafs, a(pospv1+2_8), 1)
         CALL zcopy(nass-npiv_new, a(lpos2), ldafs, a(pospv2+1_8), 1)
         jj = pospv2 + int(nass-1,8)
         ibeg = jj + 2_8
         iend = ibeg
         DO j2 = 1,nel2
            k1 = jj
            k2 = jj+1_8
            mult1 = - (a11*a(k1)+a12*a(k2))
            mult2 = - (a12*a(k1)+a22*a(k2))
            k1 = pospv1+2_8
            k2 = pospv2+1_8
            DO irow = ibeg,iend
               a(irow) = a(irow) + mult1*a(k1) + mult2*a(k2)
               k1 = k1 + 1_8
               k2 = k2 + 1_8
            ENDDO
            a(jj) = -mult1
            a(jj+1_8) = -mult2
            ibeg = ibeg + int(nass,8) 
            iend = iend + int(nass + 1,8)
            jj = jj+int(nass,8)
         ENDDO
         iend = iend-1_8
         DO j2 = iend_block+1,nass
            k1 = jj
            k2 = jj+1_8
            mult1 = - (a11*a(k1)+a12*a(k2))
            mult2 = - (a12*a(k1)+a22*a(k2))
            k1 = pospv1+2_8
            k2 = pospv2+1_8
            DO irow = ibeg,iend
               a(irow) = a(irow) + mult1*a(k1) + mult2*a(k2)
               k1 = k1 + 1_8
               k2 = k2 + 1_8
            ENDDO
            a(jj) = -mult1
            a(jj+1_8) = -mult2
            ibeg = ibeg + int(nass,8) 
            iend = iend + int(nass,8) 
            jj = jj+int(nass,8) 
         ENDDO
         IF (k219.eq. -1) THEN
           aposmax = poselt + int(nass,8) * ldafs8 + int(npiv,8)
           jj = aposmax
           k1 = jj
           k2 = jj + 1_8
           mult1 = abs(a11)*a(k1)+abs(a12)*a(k2)
           mult2 = abs(a12)*a(k1)+abs(a22)*a(k2)
           k1 = pospv1 + 2_8
           k2 = pospv2 + 1_8
           ibeg = aposmax + 2_8
           iend = aposmax + 1_8 + nass - npiv_new
           DO irow = ibeg,  iend
             a(irow) = a(irow) + mult1*abs(a(k1)) + mult2*abs(a(k2))
             k1 = k1 + 1_8
             k2 = k2 + 1_8
           ENDDO
           a(jj) = mult1
           a(jj+1_8) = mult2
         ENDIF
      ENDIF
      RETURN
      END SUBROUTINE zmumps_fac_mq_ldlt_niv2
      SUBROUTINE  zmumps_send_factored_blk( COMM_LOAD, ASS_IRECV, N,
     &             INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, LDA_FS,
     &             IBEG_BLOCK, IEND, TIPIV, LPIV, LASTBL, NB_BLOC_FAC,
     &             COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF,
     &             IFLAG, IERROR, IPOOL,LPOOL, 
     &             SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU,
     &             LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC,
     &             STEP, PIMASTER, PAMASTER,
     &             NSTK_S,PERM,PROCNODE_STEPS, root,
     &             OPASSW, OPELIW, ITLOC, RHS_MUMPS,
     &             FILS, DAD, PTRARW, PTRAIW,
     &             INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE,
     &             LPTRAR, NELT, FRTPTR, FRTELT, 
     &             ISTEP_TO_INIV2, TAB_POS_IN_PERE
     &             , NELIM, LR_ACTIVATED, NPARTSASS, CURRENT_BLR_PANEL
     &             , BLR_LorU 
     &             , LRGROUPS
     &            )
      USE zmumps_buf
      USE zmumps_load
      USE zmumps_lr_type
      USE zmumps_struc_def, ONLY : zmumps_root_struc
      IMPLICIT NONE
      include 'mpif.h'
      TYPE (ZMUMPS_ROOT_STRUC) :: root
      INTEGER COMM_LOAD, ASS_IRECV
      INTEGER N, INODE, FPERE, LIW, IBEG_BLOCK, IEND, LPIV, 
     &        ioldps, lda_fs, nb_bloc_fac
      INTEGER(8) :: POSELT, LA
      INTEGER IW(LIW), TIPIV(LPIV)
      LOGICAL LASTBL
      COMPLEX(kind=8) A(LA)
      INTEGER COMM, MYID, LBUFR, LBUFR_BYTES
      INTEGER NELT, LPTRAR
      INTEGER FRTPTR( N+1 ), FRTELT( NELT ) 
      INTEGER KEEP(500)
      INTEGER(8) KEEP8(150)
      DOUBLE PRECISION    DKEEP(230)
      INTEGER NBFIN, IFLAG, IERROR, LEAF, LPOOL,
     &        SLAVEF, ICNTL(60)
      INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS
      INTEGER IWPOS, IWPOSCB, COMP
      INTEGER BUFR( LBUFR ), IPOOL(LPOOL),
     &        ITLOC(N+KEEP(253)), FILS(N), DAD( KEEP(28) ),
     &        ND( KEEP(28) ), FRERE( KEEP(28) )
      INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR)
      COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255))
      INTEGER(8) :: PTRAST  (KEEP(28))
      INTEGER(8) :: PTRFAC  (KEEP(28))
      INTEGER(8) :: PAMASTER(KEEP(28))
      INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)),
     &        step(n), pimaster(keep(28)),
     &        nstk_s(keep(28)),
     &        perm(n), procnode_steps(keep(28))
      INTEGER ISTEP_TO_INIV2(KEEP(71)), 
     &        tab_pos_in_pere(slavef+2,max(1,keep(56)))
      DOUBLE PRECISION OPASSW, OPELIW
      COMPLEX(kind=8) DBLARR(KEEP8(26))
      INTEGER INTARR(KEEP8(27))
      LOGICAL, intent(in) ::  LR_ACTIVATED  
      TYPE (LRB_TYPE), DIMENSION(:) :: BLR_LorU
      INTEGER, intent(in) :: LRGROUPS(N)
      INTEGER ::  NELIM
      INTEGER, intent(in) :: NPARTSASS, CURRENT_BLR_PANEL
      include 'mumps_headers.h'
      INTEGER(8) :: APOS, LREQA
      INTEGER NPIV, NCOL, PDEST, NSLAVES, WIDTH
      INTEGER IERR, LREQI
      INTEGER :: STATUS(MPI_STATUS_SIZE)
      LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED
      DOUBLE PRECISION FLOP1,FLOP2
      LOGICAL COMPRESS_CB
      compress_cb    = ((iw(ioldps+xxlr).EQ.1).OR.
     &                    (iw(ioldps+xxlr).EQ.3))
      nslaves= iw(ioldps+5+keep(ixsz))
      IF (nslaves.EQ.0) THEN
           WRITE(6,*) ' ERROR 1 in ZMUMPS_SEND_FACTORED_BLK '
           CALL mumps_abort()
          ENDIF
      npiv   = iend - ibeg_block + 1
      ncol   = lda_fs - ibeg_block + 1
      apos   = poselt + int(lda_fs,8)*int(ibeg_block-1,8) +
     &                  int(ibeg_block - 1,8)
      IF (ibeg_block > 0) THEN
       CALL mumps_get_flops_cost( lda_fs, ibeg_block-1, lpiv,
     &                            keep(50),2,flop1)
      ELSE
        flop1=0.0d0
      ENDIF
      CALL mumps_get_flops_cost( lda_fs, iend, lpiv,
     &                           keep(50),2,flop2)
      flop2 = flop1 - flop2
      CALL zmumps_load_update(1, .false., flop2, keep,keep8)
      IF ((npiv.GT.0) .OR. 
     &    ((npiv.EQ.0).AND.(lastbl))
     &   ) THEN
        IF ((npiv.EQ.0).AND.(lastbl)) THEN
          IF (compress_cb) THEN
          iw(ioldps+xxlr) = iw(ioldps+xxlr) -1
          compress_cb = .false.
          ENDIF
        ENDIF
        pdest  = ioldps + 6 + keep(ixsz)
        IF (( npiv .NE. 0 ).AND.(keep(50).NE.0)) THEN
          nb_bloc_fac = nb_bloc_fac + 1
        END IF
        ierr = -1
        DO WHILE (ierr .EQ.-1)
          width = nslaves   
          CALL zmumps_buf_send_blocfacto( inode, lda_fs, ncol, 
     &               npiv, fpere, lastbl, tipiv, a(apos),
     &               iw(pdest), nslaves, keep,
     &               nb_bloc_fac,
     &               nslaves, width, comm,
     &               nelim, npartsass, current_blr_panel,
     &               lr_activated, blr_loru, 
     &        ierr )
          IF (ierr.EQ.-1) THEN
            blocking  = .false.
            set_irecv = .true.
            message_received = .false.
            CALL zmumps_try_recvtreat( comm_load, ass_irecv, 
     &       blocking, set_irecv, message_received,
     &       mpi_any_source, mpi_any_tag,
     &       status, bufr, lbufr,
     &       lbufr_bytes,
     &       procnode_steps, posfac, iwpos, iwposcb, iptrlu,
     &       lrlu, lrlus, n, iw, liw, a, la, ptrist,
     &       ptlust_s, ptrfac,
     &       ptrast, step, pimaster, pamaster, nstk_s, comp, iflag,
     &       ierror, comm,
     &       perm,
     &       ipool, lpool, leaf, nbfin, myid, slavef,
     &       root, opassw, opeliw, itloc, rhs_mumps,
     &       fils, dad, ptrarw, ptraiw,
     &       intarr, dblarr, icntl, keep,keep8,dkeep, nd, frere,
     &       lptrar, nelt, frtptr, frtelt, 
     &       istep_to_iniv2, tab_pos_in_pere, .true.
     &               , lrgroups
     &        )
            IF (message_received) THEN
              poselt = ptrast(step(inode))
              apos   = poselt + int(lda_fs,8)*int(ibeg_block-1,8) +
     &                 int(ibeg_block - 1,8)
            ENDIF
            IF ( iflag .LT. 0 ) GOTO 500
          ENDIF
        ENDDO
        IF (ierr .EQ. -2 .OR. ierr.EQ.-3 ) THEN
          IF (ierr.EQ.-2) iflag = -17
          IF (ierr.EQ.-3) iflag = -20
          lreqa = int(ncol,8)*int(npiv,8)
          lreqi = npiv + 6 + 2*nslaves + 2
          CALL mumps_set_ierror(
     &    int(lreqi,8) * int(keep(34),8) + lreqa * int(keep(35),8),
     &    ierror)
          GOTO 300
        ENDIF
      ENDIF
      GOTO 500
  300 CONTINUE
      CALL zmumps_bdc_error( myid, slavef, comm, keep )
  500 CONTINUE
      RETURN
      END SUBROUTINE  zmumps_send_factored_blk
      END MODULE zmumps_fac_front_type2_aux_m