cfac_process_root2son.F File Reference

Go to the source code of this file.

Functions/Subroutines

recursive subroutine

cmumps_process_root2son (comm_load, ass_irecv, inode, nelim_root, root, 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 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)

Function/Subroutine Documentation

cmumps_process_root2son()

recursive subroutine cmumps_process_root2son	(	integer	comm_load,
		integer	ass_irecv,
		integer	inode,
		integer	nelim_root,
		type (cmumps_root_struc)	root,
		integer, dimension( lbufr )	bufr,
		integer	lbufr,
		integer	lbufr_bytes,
		integer, dimension( keep(28) )	procnode_steps,
		integer(8)	posfac,
		integer	iwpos,
		integer	iwposcb,
		integer(8)	iptrlu,
		integer(8)	lrlu,
		integer(8)	lrlus,
		integer	n,
		integer, dimension( liw )	iw,
		integer	liw,
		complex, dimension( la )	a,
		integer(8)	la,
		integer, dimension(keep(28))	ptrist,
		integer, dimension(keep(28))	ptlust_s,
		integer(8), dimension(keep(28))	ptrfac,
		integer(8), dimension(keep(28))	ptrast,
		integer, dimension(n)	step,
		integer, dimension(keep(28))	pimaster,
		integer(8), dimension(keep(28))	pamaster,
		integer, dimension( keep(28) )	nstk_s,
		integer	comp,
		integer	iflag,
		integer	ierror,
		integer	comm,
		integer, dimension(n)	perm,
		integer, dimension( lpool )	ipool,
		integer	lpool,
		integer	leaf,
		integer	nbfin,
		integer	myid,
		integer	slavef,
		double precision	opassw,
		double precision	opeliw,
		integer, dimension( n + keep(253) )	itloc,
		complex, dimension(keep(255))	rhs_mumps,
		integer, dimension( n )	fils,
		integer, dimension(keep(28))	dad,
		integer(8), dimension( lptrar ), intent(in)	ptrarw,
		integer(8), dimension( lptrar ), intent(in)	ptraiw,
		integer, dimension(keep8(27))	intarr,
		complex, dimension(keep8(26))	dblarr,
		integer, dimension( 60 )	icntl,
		integer, dimension(500)	keep,
		integer(8), dimension(150)	keep8,
		real, dimension(230)	dkeep,
		integer, dimension( keep(28) )	nd,
		integer, dimension( keep(28) )	frere,
		integer	lptrar,
		integer	nelt,
		integer, dimension( n+1 )	frtptr,
		integer, dimension( nelt )	frtelt,
		integer, dimension(keep(71))	istep_to_iniv2,
		integer, dimension(slavef+2,max(1,keep(56)))	tab_pos_in_pere,
		integer, dimension(n), intent(in)	lrgroups )

Definition at line 14 of file cfac_process_root2son.F.

      USE cmumps_struc_def, ONLY : cmumps_root_struc
      IMPLICIT NONE
      include 'mpif.h'
      TYPE (CMUMPS_ROOT_STRUC) :: root
      INTEGER KEEP(500), ICNTL( 60 )
      INTEGER(8) KEEP8(150)
      REAL       DKEEP(230)
      INTEGER COMM_LOAD, ASS_IRECV
      INTEGER INODE, NELIM_ROOT
      INTEGER LBUFR, LBUFR_BYTES
      INTEGER BUFR( LBUFR )
      INTEGER(8) :: LA, POSFAC, IPTRLU, LRLU, LRLUS
      INTEGER IWPOS, IWPOSCB
      INTEGER N, LIW
      INTEGER IW( LIW )
      COMPLEX 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_S(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 NELT, LPTRAR
      INTEGER FRTPTR( N+1 ), FRTELT( NELT )
      INTEGER MYID, SLAVEF, NBFIN
      DOUBLE PRECISION OPASSW, OPELIW
      INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD(KEEP(28))
      COMPLEX :: RHS_MUMPS(KEEP(255))
      INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR )
      INTEGER ND( KEEP(28) ), 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)))
      include 'mumps_tags.h'
      include 'mumps_headers.h'
      INTEGER I, LCONT, NCOL_TO_SEND, LDA
      INTEGER(8) :: SHIFT_VAL_SON, POSELT
      INTEGER FPERE, IOLDPS, NFRONT, NPIV, NASS, NSLAVES,
     &        H_INODE, NELIM, NBCOL, LIST_NELIM_ROW, 
     &        LIST_NELIM_COL, NELIM_LOCAL, TYPE_SON, 
     &        NROW, NCOL, NBROW, SHIFT_LIST_ROW_SON,
     &        SHIFT_LIST_COL_SON, LDAFS, IERR,
     &        ISON, PDEST_MASTER_ISON
      INTEGER :: STATUS(MPI_STATUS_SIZE)
      LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED
      INTEGER MSGSOU, MSGTAG
      LOGICAL TRANSPOSE_ASM
      INTEGER  MUMPS_PROCNODE, MUMPS_TYPENODE
      EXTERNAL mumps_procnode, mumps_typenode
      fpere = keep(38)
      type_son = mumps_typenode(procnode_steps(step(inode)),keep(199))
      IF ( mumps_procnode( procnode_steps(step(inode)), 
     &     keep(199) ).EQ.myid) THEN
       ioldps   = ptlust_s(step(inode))
       nfront   = iw(ioldps+keep(ixsz))
       npiv     = iw(ioldps+1+keep(ixsz))
       nass     = iabs(iw(ioldps + 2+keep(ixsz)))
       nslaves  =  iw(ioldps+5+keep(ixsz))
       h_inode  = 6 + nslaves + keep(ixsz)
       nelim    = nass - npiv
       nbcol = nfront - npiv
       list_nelim_row = ioldps + h_inode + npiv
       list_nelim_col = list_nelim_row + nfront
       IF (nelim.LE.0) THEN
            write(6,*) ' ERROR 1 in CMUMPS_PROCESS_ROOT2SON ', nelim
            write(6,*) myid,':Process root2son: INODE=',inode,
     & 'Header=',iw(ptlust_s(step(inode)):ptlust_s(step(inode))
     &  +5+keep(ixsz))
            CALL mumps_abort()
           ENDIF
       nelim_local = nelim_root
       DO i=1, nelim
        root%RG2L_ROW(iw(list_nelim_row)) = nelim_local
        root%RG2L_COL(iw(list_nelim_col)) = nelim_local
        nelim_local = nelim_local + 1
        list_nelim_row = list_nelim_row + 1
        list_nelim_col = list_nelim_col + 1
       ENDDO
       nbrow = nfront - npiv
       nrow = nelim
       IF ( keep( 50 ) .eq. 0 ) THEN
         ncol = nfront - npiv
       ELSE
         ncol = nelim
       END IF
       shift_list_row_son = h_inode + npiv
       shift_list_col_son = h_inode + nfront + npiv
       IF ( keep(50).eq.0 .OR. type_son .eq. 1 ) THEN
         ldafs = nfront
       ELSE
         ldafs = nass
       END IF
       shift_val_son = int(npiv,8) * int(ldafs,8) + int(npiv,8)
       CALL cmumps_build_and_send_cb_root( comm_load,
     &   ass_irecv, 
     &   n, inode, fpere,
     &   ptlust_s(1), ptrast(1),
     &   root, nrow, ncol, shift_list_row_son,
     &   shift_list_col_son , shift_val_son, ldafs,
     &   root_non_elim_cb, myid, comm,
     &   bufr, lbufr, lbufr_bytes, procnode_steps, posfac,
     &   iwpos, iwposcb, iptrlu, lrlu, lrlus, iw, liw, a, la,
     &   ptrist, ptlust_s(1), ptrfac(1), ptrast(1),
     &   step, pimaster, pamaster,
     &   nstk_s, 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.LT.0 ) RETURN
       IF (type_son.EQ.1) THEN
        nrow = nfront - nass
        ncol = nelim
        shift_list_row_son = h_inode + nass
        shift_list_col_son = h_inode + nfront + npiv
        shift_val_son      = int(nass,8) * int(nfront,8) + int(npiv,8)
        IF ( keep( 50 ) .eq. 0 ) THEN
          transpose_asm = .false.
        ELSE
          transpose_asm = .true.
        END IF
        CALL cmumps_build_and_send_cb_root( comm_load, ass_irecv,
     &    n, inode, fpere,
     &    ptlust_s, ptrast,
     &    root, nrow, ncol, shift_list_row_son,
     &    shift_list_col_son , shift_val_son, nfront,
     &    root_non_elim_cb, 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_s, comp, iflag, ierror, perm,
     &    ipool, lpool, leaf, nbfin, slavef,
     &    opassw, opeliw, itloc, rhs_mumps,
     &    fils, dad, ptrarw, ptraiw,
     &    intarr,dblarr,icntl,keep,keep8,dkeep,
     &    transpose_asm,nd,frere,
     &    lptrar, nelt, frtptr, frtelt, 
     &    istep_to_iniv2, tab_pos_in_pere, lrgroups )
        IF (iflag.LT.0 ) RETURN
       ENDIF
       ioldps = ptlust_s(step(inode))
       poselt = ptrast(step(inode))
       iw(ioldps + 4+keep(ixsz)) = step(inode)
       ptrfac(step(inode))=poselt
       IF ( type_son .eq. 1 ) THEN
         nbrow = nfront - npiv
       ELSE
         nbrow = nelim
       END IF
       IF ( type_son .eq. 1 .OR. keep(50).EQ.0) THEN
         lda = nfront
       ELSE
         lda = npiv+nbrow
       ENDIF
       CALL cmumps_compact_factors(a(poselt), lda,
     &          npiv, nbrow, keep,
     &          int(lda,8)*int(nbrow+npiv,8), iw(ioldps+h_inode+nfront))
       iw(ioldps + keep(ixsz))     = nbcol
       iw(ioldps + 1 +keep(ixsz)) = nass - npiv
       IF (type_son.EQ.2) THEN
        iw(ioldps + 2 +keep(ixsz)) = nass
       ELSE
        iw(ioldps + 2 +keep(ixsz)) = nfront
       ENDIF
       iw(ioldps + 3 +keep(ixsz)) = npiv
      CALL cmumps_compress_lu(0_8,myid,n,ioldps,type_son,iw,liw,
     &    a, la, posfac, lrlu, lrlus,
     &    iwpos, ptrast,ptrfac,step, keep,keep8, .false.,inode,ierr
     &    , lrgroups, nass
     &    )
      IF(ierr.LT.0)THEN
         iflag=ierr
         ierror=0
         RETURN
      ENDIF
      ELSE 
        ison = inode
        pdest_master_ison = 
     &      mumps_procnode( procnode_steps(step(ison)), keep(199) )
        IF ( ptrist(step(ison)) .EQ. 0) THEN
          CALL cmumps_treat_descband( ison, comm_load,
     &    ass_irecv,
     &    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 ( iflag .LT. 0 ) RETURN
        ENDIF
        DO WHILE (
     &     ( iw( ptrist(step(ison)) + 1  +keep(ixsz)) .NE.
     &       iw( ptrist(step(ison)) + 3  +keep(ixsz)) ) .OR.
     &     ( keep(50) .NE. 0 .AND.
     &       iw( ptrist(step(ison)) + 6  +keep(ixsz)) .NE. 0 ) )
          IF ( keep(50).eq.0) THEN
            msgsou = pdest_master_ison
            msgtag = bloc_facto
          ELSE
            IF ( iw( ptrist(step(ison)) + 1  +keep(ixsz)) .NE.
     &           iw( ptrist(step(ison)) + 3  +keep(ixsz)) ) THEN
              msgsou = pdest_master_ison
              msgtag = bloc_facto_sym
            ELSE
              msgsou = mpi_any_source
              msgtag = bloc_facto_sym_slave
            END IF
          END IF
          blocking  = .true.
          set_irecv = .false.
          message_received = .false.
          CALL cmumps_try_recvtreat( comm_load, ass_irecv,
     &    blocking, set_irecv, message_received,
     &    msgsou, msgtag,
     &    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 ( iflag .LT. 0 ) RETURN
        END DO
       ioldps = ptrist(step(inode))
       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
       IF (nelim.LE.0) THEN
         write(6,*) myid,': INODE,LCONT, NROW, NPIV, NASS, NELIM=',
     &   inode,lcont, nrow, npiv, nass, nelim
         write(6,*) myid,': IOLDPS=',ioldps
         write(6,*) myid,': ERROR 2 in CMUMPS_PROCESS_ROOT2SON '
         CALL mumps_abort()
       ENDIF
       nslaves= iw(ioldps+5+keep(ixsz))
       h_inode = 6 + nslaves + keep(ixsz)
       list_nelim_col = ioldps + h_inode + nrow + npiv
       nelim_local = nelim_root
       DO i = 1, nelim
        root%RG2L_COL(iw(list_nelim_col)) = nelim_local
        root%RG2L_ROW(iw(list_nelim_col)) = nelim_local
        nelim_local = nelim_local + 1
        list_nelim_col = list_nelim_col + 1
       ENDDO
       shift_list_row_son = 6 + iw(ioldps+5+keep(ixsz)) + keep(ixsz)
       shift_list_col_son = shift_list_row_son + nrow + npiv
       ncol_to_send       = nelim
       lda = -9999
       shift_val_son = -9999_8
       IF ( keep( 50 ) .eq. 0 ) THEN
         transpose_asm = .false.
       ELSE
         transpose_asm = .true.
       END IF
       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_non_elim_cb, 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_s, comp, iflag, ierror, perm,
     &    ipool, lpool, leaf, nbfin, slavef,
     &    opassw, opeliw, itloc, rhs_mumps,
     &    fils, dad, ptrarw, ptraiw,
     &    intarr,dblarr,icntl,keep,keep8,dkeep,transpose_asm,
     &    nd, frere, lptrar, nelt, frtptr, frtelt, 
     &   istep_to_iniv2, tab_pos_in_pere, lrgroups)
        IF (iflag.LT.0 ) RETURN
       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,type_son
     &      )
       ENDIF
        IF (iflag.LT.0) THEN
           CALL cmumps_bdc_error( myid, slavef, comm, keep )
        ENDIF
      ENDIF
      RETURN