sol_common.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 mumps_sol_get_npiv_liell_ipos ( ISTEP, KEEP,
     &           NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N )
      IMPLICIT NONE
      INTEGER, INTENT(IN)  :: ISTEP, LIW, KEEP(500), N
      INTEGER, INTENT(IN)  :: IW( LIW )
      INTEGER, INTENT(IN)  :: STEP( N ), PTRIST( KEEP(28) )
      INTEGER, INTENT(OUT) :: NPIV, LIELL, IPOS
      include 'mumps_headers.h'
      INTEGER :: SROOT
      IF (keep(38) .NE. 0) THEN
        sroot = step(keep(38))
      ELSE IF (keep(20) .NE. 0) THEN
        sroot = step(keep(20))
      ELSE
        sroot = 0
      ENDIF
      ipos = ptrist(istep)
      IF (ipos .LE. 0) THEN
        WRITE(*,*) "Internal error 1 in MUMPS_SOL_GET_NPIV_LIELL_IPOS",
     &  istep 
        CALL mumps_abort()
      ENDIF
      npiv = iw(ipos+3+keep(ixsz))
      IF ( istep.EQ.sroot ) THEN
             ipos = ptrist(istep)
             liell = iw(ipos+3+keep(ixsz))
             npiv = liell
             ipos= ptrist(istep)+5+keep(ixsz)
      ELSE
             ipos = ptrist(istep) + 2+ keep(ixsz)
             liell = iw(ipos-2)+iw(ipos+1)
             ipos= ipos+1
             npiv = iw(ipos)
             ipos= ipos+1
             ipos= ipos+1+iw( ptrist(istep) + 5 +keep(ixsz))
      ENDIF
      RETURN
      END SUBROUTINE mumps_sol_get_npiv_liell_ipos
      SUBROUTINE mumps_build_irhs_loc(MYID_NODES, NSLAVES, N,
     &           PTRIST, KEEP,KEEP8, IW, LIW, STEP, PROCNODE_STEPS,
     &           IRHS_loc, ROW_OR_COL_INDICES)
      IMPLICIT NONE
      INTEGER, INTENT(IN)    :: KEEP(500)
      INTEGER(8), INTENT(IN) :: KEEP8(150)
      INTEGER, INTENT(IN)    :: MYID_NODES, NSLAVES, N, LIW
      INTEGER, INTENT(IN)    :: PTRIST(KEEP(28))
      INTEGER, INTENT(IN)    :: IW(LIW), STEP(N)
      INTEGER, INTENT(IN)    :: PROCNODE_STEPS(KEEP(28))
      INTEGER, INTENT(OUT)   :: IRHS_loc(KEEP(89))
      INTEGER, INTENT(IN)    :: ROW_OR_COL_INDICES
      INTEGER :: ISTEP
      INTEGER :: NPIV, LIELL, IPOS
      INTEGER :: IIRHS_loc 
      INTEGER :: J1 
      include 'mumps_headers.h'
      INTEGER, EXTERNAL :: MUMPS_PROCNODE
      iirhs_loc = 0
      DO istep = 1, keep(28)
        IF (myid_nodes == mumps_procnode(procnode_steps(istep),
     &                                   keep(199))) THEN
          CALL mumps_sol_get_npiv_liell_ipos ( istep, keep,
     &           npiv, liell, ipos, iw, liw, ptrist, step, n )
          IF ( row_or_col_indices .EQ. 0 .OR. keep(50).NE.0 ) THEN
            j1 = ipos + 1
          ELSE IF (row_or_col_indices .EQ. 1 ) THEN
            j1 = ipos + liell + 1
          ELSE
            WRITE(*,*) "Internal error 1 in MUMPS_BUILD_IRHS_loc",
     &      row_or_col_indices
            CALL mumps_abort()
          ENDIF
          IF (iirhs_loc+npiv .GT. keep(89)) THEN
            WRITE(*,*) "Internal error 2 in MUMPS_BUILD_IRHS_loc",
     &      iirhs_loc, keep(89)
            CALL mumps_abort()
          ENDIF
          irhs_loc(iirhs_loc+1:iirhs_loc+npiv)=iw(j1:j1+npiv-1)
          iirhs_loc=iirhs_loc+npiv
        ENDIF
      ENDDO
      IF (iirhs_loc .NE. keep(89)) THEN
        WRITE(*,*) "Internal error 3 in MUMPS_BUILD_IRHS_loc",
     &  iirhs_loc, keep(89)
        CALL mumps_abort()
      ENDIF
      RETURN
      END SUBROUTINE mumps_build_irhs_loc
      SUBROUTINE mumps_sol_rhsmapinfo( N, Nloc_RHS, INFO23,
     &                           IRHS_loc, MAP_RHS_loc,
     &                           POSINRHSCOMP_FWD,
     &                           NSLAVES, MYID_NODES, COMM_NODES,
     &                           ICNTL, INFO )
      IMPLICIT NONE
      INTEGER, INTENT(IN)    :: N, Nloc_RHS
      INTEGER, INTENT(IN)    :: INFO23
      INTEGER, INTENT(IN)    :: IRHS_loc   (max(1,Nloc_RHS))     
      INTEGER, INTENT(OUT)   :: MAP_RHS_loc(max(1,Nloc_RHS)) 
      INTEGER, INTENT(IN)    :: POSINRHSCOMP_FWD (N)
      INTEGER, INTENT(IN)    :: NSLAVES, MYID_NODES, COMM_NODES
      INTEGER, INTENT(INOUT) :: INFO(80)
      INTEGER, INTENT(IN)    :: ICNTL(60)
      include 'mpif.h'
      INTEGER :: I, NFS_LOC, NFS_TOT, IERR_MPI, allocok
      INTEGER, ALLOCATABLE, DIMENSION(:) :: GLOBAL_MAPPING 
      ALLOCATE(global_mapping(n), stat=allocok)
      IF (allocok .GT. 0) THEN
        info(1)=-13
        info(2)= n
      ENDIF
      CALL mpi_allreduce(mpi_in_place, allocok, 1,
     &                   mpi_integer, mpi_sum,
     &                   comm_nodes, ierr_mpi)
      IF (allocok .NE. 0) RETURN
      nfs_loc = 0
      nfs_tot = 0
      DO i = 1, n
        IF (posinrhscomp_fwd(i) .LE. 0) THEN
          global_mapping(i) = 0
        ELSE
          global_mapping(i) = myid_nodes
          nfs_loc = nfs_loc + 1
        ENDIF
      ENDDO
      IF (nfs_loc .NE. info23) THEN
        WRITE(*,*) "Internal error 1 in MUMPS_SOL_RHSMAPINFO",
     &  nfs_loc, info23
        CALL mumps_abort()
      ENDIF
      CALL mpi_allreduce(nfs_loc, nfs_tot, 1, mpi_integer,
     &                   mpi_sum, comm_nodes, ierr_mpi)
      IF (nfs_tot .NE. n) THEN
        WRITE(*,*) "Internal error 1 in MUMPS_SOL_RHSMAPINFO",
     &  nfs_loc, nfs_tot, n
        CALL mumps_abort()
      ENDIF
      CALL mpi_allreduce(mpi_in_place, global_mapping, n, mpi_integer,
     &                   mpi_sum, comm_nodes, ierr_mpi)
      DO i = 1, nloc_rhs
        IF (irhs_loc(i) .GE.1 .AND. irhs_loc(i) .LE. n) THEN
          map_rhs_loc(i) = global_mapping(irhs_loc(i))
        ELSE
          map_rhs_loc(i) = -87878787
        ENDIF
      ENDDO
      DEALLOCATE(global_mapping)
      RETURN
      END SUBROUTINE mumps_sol_rhsmapinfo
      SUBROUTINE mumps_compute_lastfs_dyn( INODE, LASTFSSBTR_DYN,
     &MTYPE, KEEP, IW, LIW, N, STEP, PTRIST, FILS, FRERE )
      IMPLICIT NONE
      INTEGER, INTENT(IN)  :: INODE
      INTEGER, INTENT(OUT) :: LASTFSSBTR_DYN
      INTEGER, INTENT(IN)  :: N, MTYPE, LIW, KEEP(500)
      INTEGER, INTENT(IN)  :: IW(LIW), STEP( N ), PTRIST( KEEP(28) )
      INTEGER, INTENT(IN)  :: FILS(N), FRERE( KEEP(28) )
      INTEGER :: NPIV, LIELL, IPOS, INODE_CUR, IN
      INODE_CUR = inode
 10   CONTINUE
      CALL  mumps_sol_get_npiv_liell_ipos ( step(inode_cur), keep,
     &     npiv, liell, ipos, iw, liw, ptrist, step, n )
      IF ( npiv .NE. 0 ) THEN
        IF (mtype .EQ. 1 .OR. keep(50) .NE. 0) THEN
          lastfssbtr_dyn = iw( ipos + npiv )
        ELSE
          lastfssbtr_dyn = iw( ipos+npiv+liell )
        ENDIF
      ELSE
        in = inode_cur
        DO WHILE (in.GT. 0)
          in = fils(in)
        ENDDO
        IF (in .LT. 0) THEN
          inode_cur = -in
          GOTO 10
        ELSE
          DO
            IF (inode_cur .EQ. inode) THEN
              lastfssbtr_dyn = 0
              EXIT
            ENDIF
            inode_cur = frere(step(inode_cur))
            IF (inode_cur .GT. 0) THEN
              GOTO 10
            ELSE
              inode_cur = -inode_cur
            ENDIF
          ENDDO
        ENDIF
      ENDIF
      RETURN
      END SUBROUTINE mumps_compute_lastfs_dyn