sfac_process_band.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
      SUBROUTINE smumps_process_desc_bande( MYID, BUFR, LBUFR, 
     &     LBUFR_BYTES,
     &     IWPOS, IWPOSCB,
     &     IPTRLU, LRLU, LRLUS,
     &     N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD,
     &     PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP,
     &     KEEP,KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2,
#if ! defined(NO_FDM_DESCBAND)
     &     iwhandler_in,
#endif
     &     iflag, ierror )
      USE smumps_load
      USE smumps_lr_data_m, ONLY: smumps_blr_init_front,
     &                            smumps_blr_save_nfs4father
#if ! defined(NO_FDM_DESCBAND)
      USE mumps_fac_descband_data_m
#endif
      IMPLICIT NONE
      INTEGER MYID
      INTEGER KEEP(500)
      INTEGER(8) KEEP8(150)
      REAL DKEEP(230)
      INTEGER LBUFR, LBUFR_BYTES
      INTEGER BUFR( LBUFR )
      INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA
      INTEGER IWPOS, IWPOSCB, N, LIW
      INTEGER IW( LIW )
      REAL A( LA )
      INTEGER, INTENT(IN) :: SLAVEF
      INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28))
      INTEGER(8) :: PAMASTER(KEEP(28))
      INTEGER(8) :: PTRAST(KEEP(28))
      INTEGER PTRIST(KEEP(28)), STEP(N), 
     & pimaster(keep(28)), 
     & itloc( n + keep(253) )
      REAL :: RHS_MUMPS(KEEP(255))
      INTEGER :: ISTEP_TO_INIV2(KEEP(71))
#if ! defined(NO_FDM_DESCBAND)
      INTEGER IWHANDLER_IN
#endif
      INTEGER COMP, IFLAG, IERROR
      INTEGER INODE, NBPROCFILS, NCOL, NROW, NASS, NSLAVES
      INTEGER NSLAVES_HDR, NFRONT
      INTEGER LREQ
      INTEGER :: IBUFR
      INTEGER(8) :: LREQCB
#if ! defined(NO_FDM_DESCBAND)
      INTEGER :: IWHANDLER_LOC
#endif
      DOUBLE PRECISION FLOP1
      include 'mumps_headers.h'
#if ! defined(NO_FDM_DESCBAND)
      INTEGER :: INFO_TMP(2)
#else
#endif
      INTEGER :: LRSTATUS
      INTEGER :: ESTIM_NFS4FATHER_ATSON
      LOGICAL :: LR_ACTIVATED, COMPRESS_CB
      REAL, POINTER, DIMENSION(:) :: DYNAMIC_CB
      INTEGER(8) :: TMP_ADDRESS
      INTEGER :: allocok
      INODE = bufr( 2 )
      nbprocfils = bufr( 3 )
      nrow        = bufr( 4 )
      ncol        = bufr( 5 )
      nass        = bufr( 6 )
      nfront      = bufr( 7 )
      nslaves_hdr = bufr( 8 )
      nslaves     = bufr( 9 )
      lrstatus    = bufr(10 )
      estim_nfs4father_atson = bufr(11)
      ibufr    = 12
#if ! defined(NO_FDM_DESCBAND)
      iwhandler_loc = iwhandler_in
      IF ((iwhandler_in .LE. 0) .AND.
     &   (inode .NE. inode_waited_for)) THEN
        info_tmp=0
        CALL mumps_fdbd_save_descband(inode, bufr(1), bufr,
     &                                iwhandler_loc, info_tmp)
        IF (info_tmp(1) < 0) THEN
          iflag = info_tmp(1)
          ierror = info_tmp(2)
          RETURN
        ENDIF
        GOTO 555
      ENDIF
#endif
      IF ( keep(50) .eq. 0 ) THEN
         flop1 = dble( nass * nrow ) +
     &     dble(nrow*nass)*dble(2*ncol-nass-1)
      ELSE
         flop1 = dble( nass ) * dble( nrow )
     &            * dble( 2 * ncol - nrow - nass + 1)
      END IF
      CALL smumps_load_update(1,.true.,flop1, keep,keep8)
      IF ( keep(50) .eq. 0 ) THEN
        nslaves = nslaves_hdr + xtra_slaves_unsym
      ELSE
        nslaves = nslaves_hdr + xtra_slaves_sym   
      END IF
      lreq   = nrow + ncol + 6 + nslaves + keep(ixsz)
      lreqcb = int(ncol,8) * int(nrow,8)
      IF ( lreqcb .GT. lrlus .AND. keep(101) .EQ. 0 .AND.
     &     keep8(73) + lreqcb .LE. keep8(75) ) THEN
        CALL smumps_alloc_cb(.false., 0_8, .false.,.true.,
     &       myid,n, keep, keep8, dkeep, iw, liw, a, la,
     &       lrlu, iptrlu,iwpos,iwposcb, slavef, procnode_steps, dad,
     &       ptrist,ptrast, step, pimaster,pamaster,
     &       lreq, 0_8, 
     &       inode, s_active, .true.,
     &       comp, lrlus, keep8(67), iflag, ierror
     &     )
        IF ( iflag .LT. 0 ) RETURN
#if defined(MUMPS_ALLOC_FROM_C)
        CALL mumps_malloc_c( tmp_address,
     &      lreqcb * int(keep(35),8) )
        IF (tmp_address .EQ. 0_8) THEN
          allocok=1 
        ELSE 
          allocok=0
        ENDIF
#else
        ALLOCATE(dynamic_cb(lreqcb), stat=allocok)
#endif
        IF (allocok .GT. 0) THEN
          CALL smumps_free_block_cb_static( .false., myid, n,
     &    iwposcb + 1, iw, liw, lrlu, lrlus, iptrlu, iwposcb,
     &    la, keep, keep8, .false. )
        ELSE
          CALL mumps_dm_fac_upd_dyn_memcnts( lreqcb,
     &    keep(405).EQ.1, 
     &    keep8, iflag, ierror,
     &    .true., 
     &    .false. ) 
#if ! defined(MUMPS_ALLOC_FROM_C)
          CALL mumps_addr_c( dynamic_cb(1), tmp_address )
#endif
          CALL mumps_storei8(lreqcb, iw(iwposcb+1+xxd))
          ptrist(step(inode)) = iwposcb + 1
          ptrast(step(inode)) = tmp_address
        ENDIF
      ENDIF
      IF ( ptrist(step(inode)) .EQ. 0 ) THEN
        CALL smumps_alloc_cb(.false., 0_8, .false.,.true.,
     &     myid,n, keep, keep8, dkeep, iw, liw, a, la,
     &     lrlu, iptrlu,iwpos,iwposcb, slavef, procnode_steps, dad,
     &     ptrist,ptrast, step, pimaster,pamaster,
     &     lreq, lreqcb, inode, s_active, .true.,
     &     comp, lrlus, keep8(67), iflag, ierror
     &     )
        IF ( iflag .LT. 0 ) RETURN
        ptrist(step(inode)) = iwposcb + 1
        ptrast(step(inode)) = iptrlu  + 1_8
      ENDIF
#     if ! defined(NO_FDM_DESCBAND)
 555  CONTINUE
#     endif
#     if ! defined(NO_FDM_DESCBAND)
        IF ((iwhandler_in .LE. 0) .AND.
     &     (inode .NE. inode_waited_for)) THEN
          RETURN
        ENDIF
        iw(iwposcb+1+xxa) = iwhandler_loc
#     endif
        iw(iwposcb+1+xxf) = -9999
      iw( iwposcb + 1+keep(ixsz) ) = ncol
      iw( iwposcb + 2+keep(ixsz) ) = - nass
      iw( iwposcb + 3+keep(ixsz) ) = nrow
      iw( iwposcb + 4+keep(ixsz) ) = 0
      iw( iwposcb + 5+keep(ixsz) ) = nass
      iw( iwposcb + 6+keep(ixsz) ) = nslaves
      iw( iwposcb + 7+keep(ixsz)+nslaves : 
     &           iwposcb + 6+keep(ixsz)+nslaves + nrow + ncol )
     &= bufr( ibufr + nslaves_hdr :
     &        ibufr + nslaves_hdr + nrow + ncol - 1 )
      IF ( keep(50) .eq. 0 ) THEN
        iw( iwposcb + 7+keep(ixsz) ) = s_rootband_init
        IF (nslaves_hdr.GT.0) THEN
          write(6,*) " Internal error in SMUMPS_PROCESS_DESC_BANDE "
          CALL mumps_abort()
        ENDIF
      ELSE
        iw( iwposcb+7+keep(ixsz) ) = huge(iw(iwposcb+7+keep(ixsz)))
        iw( iwposcb + 8+keep(ixsz) ) = nfront
        iw( iwposcb + 9+keep(ixsz) ) = s_rootband_init
        iw( iwposcb + 7+xtra_slaves_sym+keep(ixsz):
     &      iwposcb + 6+xtra_slaves_sym+keep(ixsz)+nslaves_hdr ) =
     &       bufr( ibufr: ibufr - 1 + nslaves_hdr )
      END IF
      iw(iwposcb+1+xxnbpr)=nbprocfils
      iw(iwposcb+1+xxlr)=lrstatus
      compress_cb    = ((lrstatus.EQ.1).OR.
     &                  (lrstatus.EQ.3))
      lr_activated   = (lrstatus.GT.0)
      IF (lr_activated.AND.
     &       (keep(480).NE.0
     &       .OR.
     &       (
     &         (keep(486).EQ.2) 
     &       )
     &       .OR.compress_cb
     &       )) THEN
         info_tmp=0
         CALL smumps_blr_init_front (iw(iwposcb+1+xxf), info_tmp) 
         IF (info_tmp(1).LT.0)  THEN
          iflag = info_tmp(1)
          ierror = info_tmp(2)
          RETURN
         ENDIF
         IF (compress_cb.AND.
     &     (keep(219).NE.0).AND.(keep(50).EQ.2).AND.
     &     (estim_nfs4father_atson.GE.0)
     &    ) THEN
            CALL smumps_blr_save_nfs4father ( iw(iwposcb+1+xxf),
     &             estim_nfs4father_atson )
         ENDIF
      ENDIF
      IF (nbprocfils .EQ. 0) THEN
      ENDIF
      RETURN
      END SUBROUTINE smumps_process_desc_bande
      RECURSIVE SUBROUTINE smumps_treat_descband( INODE,
     &    COMM_LOAD, ASS_IRECV,
     &    BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC,
     &    IWPOS, IWPOSCB, IPTRLU,
     &    LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST,
     &    PTLUST, 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,
     &    STACK_RIGHT_AUTHORIZED
     &    , LRGROUPS
     & )
#     if ! defined(NO_FDM_DESCBAND)
      USE mumps_fac_descband_data_m
#     endif
      USE smumps_struc_def, ONLY : smumps_root_struc
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: inode  
      TYPE (smumps_root_struc) :: root
      INTEGER keep(500), icntl(60)
      INTEGER(8) keep8(150)
      REAL       dkeep(230)
      INTEGER lbufr, lbufr_bytes
      INTEGER comm_load, ass_irecv
      INTEGER bufr( lbufr )
      INTEGER(8) :: la, posfac, iptrlu, lrlu, lrlus
      INTEGER iwpos, iwposcb
      INTEGER n, liw
      INTEGER iw( liw )
      REAL a( la )
      INTEGER, intent(in) :: lrgroups(n)
      INTEGER(8) :: ptrast(keep(28))
      INTEGER(8) :: ptrfac(keep(28))
      INTEGER(8) :: pamaster(keep(28))
      INTEGER ptrist( keep(28) ),
     &        ptlust(keep(28))
      INTEGER step(n),
     & pimaster(keep(28))
      INTEGER comp
      INTEGER nstk_s(keep(28)), procnode_steps( keep(28) )
      INTEGER perm(n)
      INTEGER iflag, ierror, comm
      INTEGER lpool, leaf
      INTEGER ipool( lpool )
      INTEGER myid, slavef, nbfin
      DOUBLE PRECISION opassw, opeliw
      INTEGER nelt, lptrar
      INTEGER frtptr( n+1 ), frtelt( nelt )
      INTEGER itloc( n + keep(253) ), fils( n ), dad( keep(28) )
      REAL :: rhs_mumps(keep(255))
      INTEGER(8), INTENT(IN) :: ptrarw( lptrar ), ptraiw( lptrar )
      INTEGER nd( keep(28) ), frere( keep(28) )
      INTEGER istep_to_iniv2(keep(71)),
     &        tab_pos_in_pere(slavef+2,max(1,keep(56)))
      REAL dblarr( keep8(26) )
      INTEGER intarr( keep8(27) )
      LOGICAL, intent(in) :: stack_right_authorized
      include 'mpif.h'
      include 'mumps_tags.h'
      include 'mumps_headers.h'
      LOGICAL :: blocking, set_irecv, message_received
      INTEGER :: status(mpi_status_size)
      INTEGER :: src_descband
#if ! defined(NO_FDM_DESCBAND)
      INTEGER :: iwhandler
      TYPE(descband_struc_t), POINTER :: descband_struc
#endif
      INTEGER mumps_procnode
      EXTERNAL mumps_procnode
      src_descband = mumps_procnode( procnode_steps(step(inode)),
     &           keep(199) )
#     if ! defined(NO_FDM_DESCBAND)
      IF (mumps_fdbd_is_descband_stored( inode, iwhandler )) THEN 
        CALL mumps_fdbd_retrieve_descband(iwhandler, descband_struc)
        CALL smumps_process_desc_bande( myid, descband_struc%BUFR(1),
     &       descband_struc%LBUFR,
     &       lbufr_bytes,
     &       iwpos, iwposcb,
     &       iptrlu, lrlu, lrlus,
     &       n, iw, liw, a, la, slavef, procnode_steps, dad,
     &       ptrist, ptrast, step, pimaster, pamaster, comp,
     &       keep, keep8, dkeep, itloc, rhs_mumps, istep_to_iniv2,
     &       iwhandler,
     &       iflag, ierror )
        IF (iflag .LT. 0) GOTO 500 
        CALL mumps_fdbd_free_descband_struc(iw(ptrist(step(inode))+xxa))
      ELSE 
         IF (inode_waited_for.GT.0) THEN
          WRITE(*,*) " Internal error 1 in SMUMPS_TREAT_DESCBAND",
     &    inode, inode_waited_for
          CALL mumps_abort()
        ENDIF
        inode_waited_for = inode
#     endif
      DO WHILE (ptrist(step(inode)) .EQ. 0)
        blocking = .true.
        set_irecv = .false.
        message_received = .false.
        CALL smumps_try_recvtreat(comm_load,
     &    ass_irecv, blocking, set_irecv, message_received,
     &    src_descband, maitre_desc_bande,
     &    status, 
     &    bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
     &    iwpos, iwposcb, iptrlu,
     &    lrlu, lrlus, n, iw, liw, a, la, ptrist,
     &    ptlust, 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 (iflag .LT. 0) THEN
          RETURN
        ENDIF
      ENDDO
#     if ! defined(NO_FDM_DESCBAND)
        inode_waited_for = -1
      ENDIF
#     endif
      RETURN
 500  CONTINUE
      CALL smumps_bdc_error( myid, slavef, comm, keep )
      RETURN
      END SUBROUTINE smumps_treat_descband