cfac_process_end_facto_slave.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
      RECURSIVE SUBROUTINE cmumps_end_facto_slave(
     &    COMM_LOAD, ASS_IRECV, 
     &    N, INODE, FPERE, 
     &    root,
     &    MYID, COMM,
     &    
     &    BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC,
     &    IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA,
     &    PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER,
     &    PAMASTER,
     &    NSTK, COMP, IFLAG, IERROR, PERM,
     &    IPOOL, LPOOL, LEAF, NBFIN, SLAVEF,
     &    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 
     &               , LRGROUPS
     &    )
      USE cmumps_load
#if ! defined(NO_FDM_MAPROW)
      USE mumps_fac_maprow_data_m
#endif
      USE cmumps_lr_data_m  
      USE cmumps_struc_def, ONLY : cmumps_root_struc
      IMPLICIT NONE
      include 'mumps_headers.h'
      include 'mpif.h'
      include 'mumps_tags.h'
      INTEGER inode, fpere
      TYPE (cmumps_root_struc) :: root
      INTEGER comm, myid
      INTEGER icntl( 60 ), keep( 500 )
      INTEGER(8) keep8(150)
      REAL    dkeep(230)
      INTEGER comm_load, ass_irecv
      INTEGER n
      INTEGER lbufr, lbufr_bytes
      INTEGER bufr( lbufr )
      INTEGER(8) :: posfac, iptrlu, lrlu, lrlus, la
      INTEGER PROCNODE_STEPS(keep(28)), ptrist(keep(28)),
     &        nstk(keep(28)), ptlust_s(keep(28))
      INTEGER iwpos, iwposcb
      INTEGER liw
      INTEGER iw( liw )
      COMPLEX a( la )
      INTEGER, intent(in) :: lrgroups(n)
      INTEGER lptrar, nelt
      INTEGER frtptr( n+1 ), frtelt( nelt )
      INTEGER(8) :: ptrast(keep(28))
      INTEGER(8) :: ptrfac(keep(28))
      INTEGER(8) :: pamaster(keep(28))
      INTEGER step(n), pimaster(keep(28))
      INTEGER comp, iflag, IERROR
      INTEGER PERM(n)
      INTEGER lpool, leaf
      INTEGER ipool( lpool )
      INTEGER nbfin, slavef
      DOUBLE PRECISION opassw, opeliw
      INTEGER itloc( n + keep(253) ), fils( n ), dad( keep(28) )
      COMPLEX :: rhs_mumps(keep(255))
      INTEGER nd( keep(28) )
      INTEGER(8), INTENT(IN) :: ptrarw( lptrar ), ptraiw( lptrar )
      INTEGER frere(keep(28))
      INTEGER intarr( keep8(27) )
      COMPLEX dblarr( keep8(26) )
      INTEGER istep_to_iniv2(keep(71)), 
     &        tab_pos_in_pere(slavef+2,max(1,keep(56)))
      INTEGER mrs_inode
      INTEGER mrs_ison
      INTEGER mrs_nslaves_pere
      INTEGER mrs_nass_pere
      INTEGER mrs_nfront_pere
      INTEGER mrs_lmap
      INTEGER mrs_nfs4father
      INTEGER, POINTER, DIMENSION(:) :: mrs_slaves_pere, mrs_trow
      INTEGER itype2
      INTEGER ihdr_rec
      parameter(itype2=2)
      INTEGER ioldps, nrow, lda
      INTEGER NPIV, lcont, nelim, nass, ncol_to_send,
     &        shift_list_row_son, shift_list_col_son
      INTEGER(8) :: shift_val_son
      INTEGER(8) :: mem_gain 
      INTEGER(8) :: dyn_size
#if ! defined(NO_FDM_MAPROW)
      TYPE(MAPROW_STRUC_T), POINTER :: mrs
#endif
      INTEGER :: iwhandler_save
      INTEGER    :: lrstatus
      LOGICAL    :: cb_stored_in_blrstruc, compress_cb
        IF (keep(50).EQ.0) THEN
          ihdr_rec=6
        ELSE
          ihdr_rec=8
        ENDIF
        ioldps = ptrist(step(inode))
        iwhandler_save = iw(ioldps+xxa)
        lrstatus = iw(ioldps+xxlr)
        compress_cb    = ((lrstatus.EQ.1).OR.
     &                  (lrstatus.EQ.3))
        IF (.NOT.
     &       (
     &         (keep(486).EQ.2) 
     &       )
     &       .AND..NOT.compress_cb) THEN
          CALL cmumps_blr_end_front(iw(ioldps+xxf), iflag, keep8,
     &                              keep(34))
        ENDIF
        iw(ioldps+xxs)=s_all
         ioldps = ptrist(step(inode))
         lrstatus = iw(ioldps+xxlr)
         IF ( (keep(214).EQ.1)
     &      ) THEN
          CALL cmumps_stack_band( n, inode,
     &    ptrist, ptrast, ptlust_s, ptrfac, iw, liw, a, la,
     &    lrlu, lrlus, iwpos, iwposcb, posfac, comp, 
     &    iptrlu, opeliw, step, pimaster, pamaster,
     &    iflag, ierror, slavef, procnode_steps, dad, myid, comm,
     &    keep,keep8, dkeep, itype2
     &     )
          ioldps = ptrist(step(inode)) 
          IF (keep(38).NE.fpere) THEN
            cb_stored_in_blrstruc = .false.
            lrstatus              = iw(ioldps+xxlr)
            IF ((lrstatus.EQ.1).OR.(lrstatus.EQ.3)) THEN
              cb_stored_in_blrstruc = .true.
              iw(ioldps+xxs) = s_nolnocb
              CALL mumps_geti8(mem_gain, iw(ioldps+xxr))
              lrlus  = lrlus + mem_gain
              keep8(69) = keep8(69) - mem_gain
              CALL cmumps_load_mem_update(.false.,.false.,
     &              la-lrlus,0_8,-mem_gain,keep,keep8,lrlus)
            ELSE
              iw(ioldps+xxs)=s_nolcbnocontig
              CALL mumps_geti8( dyn_size, iw(ioldps+xxd))
              IF (dyn_size .GT.0) THEN
              ELSE IF (keep(216).NE.3) THEN
               mem_gain=int(iw( ioldps + 2 + keep(ixsz) ),8)*
     &                int(iw( ioldps + 3 + keep(ixsz) ),8)
               lrlus = lrlus+mem_gain
               keep8(69) = keep8(69) - mem_gain
               CALL cmumps_load_mem_update(.false.,.false.,
     &              la-lrlus,0_8,-mem_gain,keep,keep8,lrlus)
              ENDIF
            ENDIF
          ENDIF
          CALL mumps_geti8( dyn_size, iw(ioldps+xxd))
          IF (dyn_size > 0_8) THEN
          ELSE IF (keep(216).EQ.2) THEN
           IF (fpere.NE.keep(38)) THEN
             IF (.NOT. cb_stored_in_blrstruc) THEN
                CALL cmumps_makecbcontig(a,la,ptrast(step(inode)),
     &            iw( ioldps + 2 + keep(ixsz) ),
     &            iw( ioldps + keep(ixsz) ),
     &            iw( ioldps + 3 + keep(ixsz) )+
     &            iw( ioldps + keep(ixsz) ), 0,
     &            iw( ioldps + xxs ), 0_8 )
                iw(ioldps+xxs)=s_nolcbcontig
             ENDIF
           ENDIF
          ENDIF 
         ENDIF 
      IF ( keep(38).EQ.fpere) THEN
       lcont  = iw(ioldps+keep(ixsz))
       nrow   = iw(ioldps+2+keep(ixsz))
       npiv   = iw(ioldps+3+keep(ixsz))
       nass   = iw(ioldps+4+keep(ixsz))
       nelim  = nass-npiv
       ncol_to_send =  lcont-nelim
       shift_list_row_son = 6 + iw(ioldps+5+keep(ixsz)) + keep(ixsz)
       shift_list_col_son = shift_list_row_son + nrow + nass
       shift_val_son      = int(nass,8)
       lda                = lcont + npiv
      IF (iw(ioldps+ihdr_rec+keep(ixsz)).EQ.s_rootband_init) THEN
        iw(ioldps+ihdr_rec+keep(ixsz)) = s_rec_contstatic
      ELSE
      ENDIF
       CALL cmumps_build_and_send_cb_root( comm_load, ass_irecv, 
     &    n, inode, fpere, 
     &    ptrist, ptrast, 
     &    root, nrow, ncol_to_send, shift_list_row_son,
     &    shift_list_col_son , shift_val_son, lda, 
     &    root_cont_static, myid, comm,
     &    
     &    bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
     &    iwpos, iwposcb, iptrlu, lrlu, lrlus, iw, liw, a, la,
     &    ptrist, ptlust_s, ptrfac, ptrast, step, pimaster,
     &    pamaster,
     &    nstk, comp, iflag, ierror, perm,
     &    ipool, lpool, leaf, nbfin, slavef,
     &    opassw, opeliw, itloc, rhs_mumps, fils, dad, ptrarw, ptraiw,
     &    intarr,dblarr,icntl,keep,keep8,dkeep,.false.,nd,frere,
     &    lptrar, nelt, frtptr, frtelt, 
     &    istep_to_iniv2, tab_pos_in_pere 
     &               , lrgroups
     &    )
       IF ( iflag < 0 ) GOTO 600
       IF (nelim.EQ.0) THEN
         IF (keep(214).EQ.2) THEN
          CALL cmumps_stack_band( n, inode,  
     &    ptrist, ptrast, ptlust_s, ptrfac, iw, liw, a, la,
     &    lrlu, lrlus, iwpos, iwposcb, posfac, comp,
     &    iptrlu, opeliw, step, pimaster, pamaster,
     &    iflag, ierror, slavef, procnode_steps, dad, myid,
     &    comm, keep,keep8,dkeep, itype2
     &    )
         ENDIF
         CALL cmumps_free_band( n, inode, ptrist, ptrast, iw, liw,
     &        a, la, lrlu, lrlus, iwposcb, iptrlu, step,
     &        myid, keep, keep8, itype2
     &         )
       ELSE
         ioldps = ptrist(step(inode))
         IF (iw(ioldps+ihdr_rec+keep(ixsz)).EQ.s_root2son_called) THEN
           CALL cmumps_free_band( n, inode, ptrist, ptrast, iw, liw,
     &        a, la, lrlu, lrlus, iwposcb, iptrlu, step,
     &        myid, keep, keep8, itype2
     &         )
         ELSE
          iw(ioldps+ihdr_rec+keep(ixsz)) = s_rootband_init
          IF (keep(214).EQ.1.AND.keep(216).NE.3) THEN
           iw(ioldps+xxs)=s_nolcbnocontig38
           CALL cmumps_sizefreeinrec( iw(ioldps),
     &                     liw-ioldps+1,
     &                     mem_gain, keep(ixsz) )
           lrlus = lrlus + mem_gain
           keep8(69) = keep8(69) - mem_gain
              CALL cmumps_load_mem_update(.false.,.false.,
     &                la-lrlus,0_8,-mem_gain,keep,keep8,lrlus)
            IF (keep(216).EQ.2) THEN
              CALL cmumps_makecbcontig(a,la,ptrast(step(inode)),
     &         iw( ioldps + 2 + keep(ixsz) ),
     &         iw( ioldps + keep(ixsz) ),
     &         iw( ioldps + 3 + keep(ixsz) )+
     &         iw( ioldps + keep(ixsz) ),
     &         iw( ioldps + 4 + keep(ixsz) ) -
     &         iw( ioldps + 3 + keep(ixsz) ),
     &         iw( ioldps + xxs ),0_8)
              iw(ioldps+xxs)=s_nolcbcontig38
            ENDIF
          ENDIF
         ENDIF 
       ENDIF 
      ENDIF 
 600  CONTINUE
#if ! defined(NO_FDM_MAPROW)
      ioldps = ptrist(step(inode)) 
      IF (fpere .NE. keep(38)) THEN
       IF (mumps_fmrd_is_maprow_stored( iw(ioldps+xxa) )) THEN
        CALL mumps_fmrd_retrieve_maprow( iw(ioldps+xxa), mrs )
        IF (fpere .NE. mrs%INODE) THEN
          WRITE(*,*) " Internal error 1 in CMUMPS_END_FACTO_SLAVE",
     &               inode, mrs%INODE, fpere
          CALL mumps_abort()
        ENDIF
        mrs_inode        = mrs%INODE
        mrs_ison         = mrs%ISON
        mrs_nslaves_pere = mrs%NSLAVES_PERE
        mrs_nass_pere    = mrs%NASS_PERE
        mrs_nfront_pere  = mrs%NFRONT_PERE
        mrs_lmap         = mrs%LMAP
        mrs_nfs4father   = mrs%NFS4FATHER
        mrs_slaves_pere  => mrs%SLAVES_PERE
        mrs_trow         => mrs%TROW
        CALL cmumps_maplig( comm_load, ass_irecv,
     &           bufr, lbufr, lbufr_bytes,
     &  mrs_inode, mrs_ison,
     &  mrs_nslaves_pere, mrs_slaves_pere(1),
     &  mrs_nfront_pere, mrs_nass_pere, mrs_nfs4father,
     &  mrs_lmap, mrs_trow(1),
     &  procnode_steps, slavef, posfac, iwpos, iwposcb, iptrlu, lrlu,
     &  lrlus, n, iw, liw, a, la, ptrist, ptlust_s, ptrfac,
     &  ptrast, step, pimaster, pamaster, nstk, comp,
     &  iflag, ierror, myid, comm, perm, ipool, lpool, leaf,
     &  nbfin, icntl, keep,keep8,dkeep,
     &  root, opassw, opeliw,
     &  itloc, rhs_mumps,
     &  fils, dad, ptrarw, ptraiw, intarr, dblarr, nd, frere,
     &  lptrar, nelt, frtptr, frtelt, 
     &
     &  istep_to_iniv2, tab_pos_in_pere 
     &               , lrgroups
     &  )
       CALL mumps_fmrd_free_maprow_struc( iwhandler_save )
       ENDIF
      ENDIF
#endif
      RETURN
      END SUBROUTINE cmumps_end_facto_slave