dmumps_ooc_buffer.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 dmumps_ooc_buffer
      USE mumps_ooc_common
      IMPLICIT NONE
      PUBLIC
      INTEGER first_hbuf,second_hbuf
      parameter(first_hbuf=0, second_hbuf=1)
      INTEGER,SAVE :: ooc_fct_type_loc
      DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE :: buf_io
      LOGICAL,SAVE :: panel_flag
      INTEGER,SAVE :: earliest_write_min_size
      INTEGER(8),SAVE,DIMENSION(:), ALLOCATABLE ::
     &  i_shift_first_hbuf, i_shift_second_hbuf,
     &  i_shift_cur_hbuf, i_rel_pos_cur_hbuf
      INTEGER, SAVE, DIMENSION(:), ALLOCATABLE ::
     &  last_iorequest, cur_hbuf
      INTEGER, DIMENSION(:),ALLOCATABLE :: i_cur_hbuf_nextpos
      INTEGER,SAVE ::  i_cur_hbuf_fstpos,
     &  i_sub_hbuf_fstpos
      INTEGER(8) :: bufferempty
      parameter(bufferempty=-1_8)
      INTEGER(8), DIMENSION(:),ALLOCATABLE :: nextaddvirtbuffer
      INTEGER(8), DIMENSION(:),ALLOCATABLE :: first_vaddr_in_buf
      CONTAINS
      SUBROUTINE dmumps_ooc_next_hbuf(TYPEF_ARG)
      IMPLICIT NONE
      INTEGER TYPEF_ARG
      SELECT CASE(cur_hbuf(typef_arg))
         CASE (first_hbuf)
            cur_hbuf(typef_arg) = second_hbuf
            i_shift_cur_hbuf(typef_arg) =
     &           i_shift_second_hbuf(typef_arg)
         CASE (second_hbuf)
            cur_hbuf(typef_arg) = first_hbuf
            i_shift_cur_hbuf(typef_arg) =
     &           i_shift_first_hbuf(typef_arg)
      END SELECT
      IF(.NOT.panel_flag)THEN
         i_sub_hbuf_fstpos =i_cur_hbuf_fstpos
         i_cur_hbuf_fstpos =i_cur_hbuf_nextpos(typef_arg)
      ENDIF
      i_rel_pos_cur_hbuf(typef_arg) = 1_8
      RETURN
      END SUBROUTINE dmumps_ooc_next_hbuf
      SUBROUTINE dmumps_ooc_do_io_and_chbuf(TYPEF_ARG,IERR)
      IMPLICIT NONE
      INTEGER TYPEF_ARG
      INTEGER NEW_IOREQUEST
      INTEGER IERR
      ierr=0
      CALL dmumps_ooc_wrt_cur_buf2disk(typef_arg,new_iorequest,
     &     ierr)
      IF(ierr.LT.0)THEN
         RETURN
      ENDIF
      ierr=0
      CALL mumps_wait_request(last_iorequest(typef_arg),ierr)
      IF(ierr.LT.0)THEN
         IF (icntl1>0)
     &   WRITE(icntl1,*) myid_ooc,': ',err_str_ooc(1:dim_err_str_ooc)
         RETURN
      ENDIF
      last_iorequest(typef_arg) = new_iorequest
      CALL dmumps_ooc_next_hbuf(typef_arg)
      IF(panel_flag)THEN
         nextaddvirtbuffer(typef_arg)=bufferempty
      ENDIF
      RETURN
      END SUBROUTINE dmumps_ooc_do_io_and_chbuf
      SUBROUTINE dmumps_ooc_buf_clean_pending(IERR)
      IMPLICIT NONE
      INTEGER, intent(out) :: IERR
      INTEGER TYPEF_LAST        
      INTEGER TYPEF_LOC
      ierr = 0 
      typef_last = ooc_nb_file_type
      DO typef_loc = 1, typef_last
         ierr=0
         CALL  dmumps_ooc_do_io_and_chbuf(typef_loc,ierr)
         IF(ierr.LT.0)THEN
            RETURN
         ENDIF
         ierr=0
         CALL dmumps_ooc_do_io_and_chbuf(typef_loc,ierr)
         IF(ierr.LT.0)THEN
            RETURN
         ENDIF
      ENDDO
      RETURN
      END SUBROUTINE dmumps_ooc_buf_clean_pending
      SUBROUTINE dmumps_ooc_wrt_cur_buf2disk(TYPEF_ARG,IOREQUEST,
     &     IERR)
      IMPLICIT NONE
      INTEGER IOREQUEST,IERR
      INTEGER TYPEF_ARG
      INTEGER FIRST_INODE
      INTEGER(8) :: FROM_BUFIO_POS, SIZE
      INTEGER TYPE
      INTEGER ADDR_INT1,ADDR_INT2
      INTEGER(8) TMP_VADDR
      INTEGER SIZE_INT1,SIZE_INT2
      ierr=0
      IF (i_rel_pos_cur_hbuf(typef_arg) == 1_8) THEN
        iorequest=-1
        RETURN
      END IF      
      IF(panel_flag)THEN
         TYPE=typef_arg-1
         first_inode=-9999
         tmp_vaddr=first_vaddr_in_buf(typef_arg)
      ELSE
         TYPE=fct
         first_inode =
     &        ooc_inode_sequence(i_cur_hbuf_fstpos,typef_arg)
         tmp_vaddr=ooc_vaddr(step_ooc(first_inode),typef_arg)
      ENDIF
      from_bufio_pos=i_shift_cur_hbuf(typef_arg)+1_8
      SIZE = i_rel_pos_cur_hbuf(typef_arg)-1_8
      CALL mumps_ooc_convert_bigintto2int(addr_int1,addr_int2,
     &     tmp_vaddr)
      CALL mumps_ooc_convert_bigintto2int(size_int1,size_int2,
     &     size)
      CALL mumps_low_level_write_ooc_c(low_level_strat_io,
     &     buf_io(from_bufio_pos),size_int1,size_int2,
     &     first_inode,iorequest,
     &     TYPE,addr_int1,addr_int2,ierr)
      if(ierr.LT.0)THEN
         IF (icntl1>0)
     &   WRITE(icntl1,*)myid_ooc,': ',err_str_ooc(1:dim_err_str_ooc)
         RETURN
      ENDIF
      RETURN
      END SUBROUTINE dmumps_ooc_wrt_cur_buf2disk
      SUBROUTINE dmumps_init_ooc_buf(I1,I2,IERR)
      IMPLICIT NONE
      INTEGER I1,I2,IERR 
      INTEGER allocok
      ierr=0
      panel_flag=.false.
      IF(allocated(i_shift_first_hbuf))THEN
         DEALLOCATE(i_shift_first_hbuf)
      ENDIF
      IF(allocated(i_shift_second_hbuf))THEN
         DEALLOCATE(i_shift_second_hbuf)
      ENDIF
      IF(allocated(i_shift_cur_hbuf))THEN
         DEALLOCATE(i_shift_cur_hbuf)
      ENDIF
      IF(allocated(i_rel_pos_cur_hbuf))THEN
         DEALLOCATE(i_rel_pos_cur_hbuf)
      ENDIF
      IF(allocated(last_iorequest))THEN
         DEALLOCATE(last_iorequest)
      ENDIF
      IF(allocated(cur_hbuf))THEN
         DEALLOCATE(cur_hbuf)
      ENDIF
      dim_buf_io = int(keep_ooc(100),8)
      ALLOCATE(i_shift_first_hbuf(ooc_nb_file_type),
     &     stat=allocok)
      IF (allocok > 0) THEN
         IF (icntl1>0) THEN
            WRITE(icntl1,*) 'PB allocation in DMUMPS_INIT_OOC'
         ENDIF
         i1 = -13
         i2 = ooc_nb_file_type
         ierr=-1
         RETURN
      ENDIF
      ALLOCATE(i_shift_second_hbuf(ooc_nb_file_type),
     &     stat=allocok)
      IF (allocok > 0) THEN
         IF (icntl1>0) THEN
            WRITE(icntl1,*) 'PB allocation in DMUMPS_INIT_OOC'
         ENDIF
         i1 = -13
         i2 = ooc_nb_file_type
         ierr=-1
         RETURN
      ENDIF
      ALLOCATE(i_shift_cur_hbuf(ooc_nb_file_type),
     &     stat=allocok)
      IF (allocok > 0) THEN
         IF (icntl1>0) THEN
            WRITE(icntl1,*) 'PB allocation in DMUMPS_INIT_OOC'
         ENDIF
         i1 = -13
         i2 = ooc_nb_file_type
         ierr=-1
         RETURN
      ENDIF
      ALLOCATE(i_rel_pos_cur_hbuf(ooc_nb_file_type),
     &     stat=allocok)
      IF (allocok > 0) THEN
         IF (icntl1>0) THEN
            WRITE(icntl1,*) 'PB allocation in DMUMPS_INIT_OOC'
         ENDIF
         i1 = -13
         i2 = ooc_nb_file_type
         ierr=-1
         RETURN
      ENDIF
      ALLOCATE(last_iorequest(ooc_nb_file_type),
     &     stat=allocok)
      IF (allocok > 0) THEN
         IF (icntl1>0) THEN
            WRITE(icntl1,*) 'PB allocation in DMUMPS_INIT_OOC'
         ENDIF
         i1 = -13
         i2 = ooc_nb_file_type
         ierr=-1
         RETURN
      ENDIF
      ALLOCATE(cur_hbuf(ooc_nb_file_type),
     &     stat=allocok)
      IF (allocok > 0) THEN
         IF (icntl1>0) THEN
            WRITE(icntl1,*) 'PB allocation in DMUMPS_INIT_OOC'
         ENDIF
         i1 = -13
         i2 = ooc_nb_file_type
         ierr=-1
         RETURN
      ENDIF
      ooc_fct_type_loc=ooc_nb_file_type
      ALLOCATE(buf_io(dim_buf_io), stat=allocok)      
      IF (allocok > 0) THEN
         IF (icntl1>0) THEN
            WRITE(icntl1,*) 'PB allocation in DMUMPS_INIT_OOC'
         ENDIF
         i1 = -13
         CALL mumps_set_ierror(dim_buf_io, i2)
         RETURN
      ENDIF
      panel_flag=(keep_ooc(201).EQ.1)
      IF (panel_flag) THEN 
         ierr=0
         keep_ooc(228)=0
         IF(allocated(addvirtlibre))THEN
            DEALLOCATE(addvirtlibre)
         ENDIF
         ALLOCATE(addvirtlibre(ooc_nb_file_type), stat=allocok)
         IF (allocok > 0) THEN
            IF (icntl1>0) THEN
               WRITE(icntl1,*) 'PB allocation in ',
     &              'DMUMPS_INIT_OOC_BUF_PANEL'
            ENDIF
            ierr=-1
            i1=-13
            i2=ooc_nb_file_type
            RETURN
         ENDIF
         addvirtlibre(1:ooc_nb_file_type)=0_8
         IF(allocated(nextaddvirtbuffer))THEN
            DEALLOCATE(nextaddvirtbuffer)
         ENDIF
         ALLOCATE(nextaddvirtbuffer(ooc_nb_file_type), stat=allocok)
         IF (allocok > 0) THEN
            IF (icntl1>0) THEN
               WRITE(icntl1,*) 'PB allocation in ',
     &              'DMUMPS_INIT_OOC_BUF_PANEL'
            ENDIF
            ierr=-1
            i1=-13
            i2=ooc_nb_file_type
            RETURN
         ENDIF
         nextaddvirtbuffer(1:ooc_nb_file_type)  = bufferempty      
         IF(allocated(first_vaddr_in_buf))THEN
            DEALLOCATE(first_vaddr_in_buf)
         ENDIF
         ALLOCATE(first_vaddr_in_buf(ooc_nb_file_type), stat=allocok)
         IF (allocok > 0) THEN
            IF (icntl1>0) THEN
               WRITE(icntl1,*) 'PB allocation in ',
     &              'DMUMPS_INIT_OOC_BUF_PANEL'
            ENDIF
            ierr=-1
            i1=-13
            i2=ooc_nb_file_type
            RETURN
         ENDIF
         CALL dmumps_ooc_init_db_buffer_panel()   
      ELSE
         CALL dmumps_ooc_init_db_buffer()
      ENDIF
      keep_ooc(223)=int(hbuf_size)
      RETURN
      END SUBROUTINE dmumps_init_ooc_buf
      SUBROUTINE dmumps_end_ooc_buf()
      IMPLICIT NONE
      IF(allocated(buf_io))THEN
         DEALLOCATE(buf_io)
      ENDIF
      IF(allocated(i_shift_first_hbuf))THEN
         DEALLOCATE(i_shift_first_hbuf)
      ENDIF
      IF(allocated(i_shift_second_hbuf))THEN
         DEALLOCATE(i_shift_second_hbuf)
      ENDIF
      IF(allocated(i_shift_cur_hbuf))THEN
         DEALLOCATE(i_shift_cur_hbuf)
      ENDIF
      IF(allocated(i_rel_pos_cur_hbuf))THEN
         DEALLOCATE(i_rel_pos_cur_hbuf)
      ENDIF
      IF(allocated(last_iorequest))THEN
         DEALLOCATE(last_iorequest)
      ENDIF
      IF(allocated(cur_hbuf))THEN
         DEALLOCATE(cur_hbuf)
      ENDIF
      IF(panel_flag)THEN
         IF(allocated(nextaddvirtbuffer))THEN
            DEALLOCATE(nextaddvirtbuffer)
         ENDIF         
         IF(allocated(addvirtlibre))THEN
            DEALLOCATE(addvirtlibre)
         ENDIF
         IF(allocated(first_vaddr_in_buf))THEN
            DEALLOCATE(first_vaddr_in_buf)
         ENDIF
      ENDIF
      RETURN
      END SUBROUTINE dmumps_end_ooc_buf
      SUBROUTINE dmumps_ooc_init_db_buffer()
      IMPLICIT NONE
      ooc_fct_type_loc=1
      hbuf_size = dim_buf_io / int(2,kind=kind(dim_buf_io))
      earliest_write_min_size = 0
      i_shift_first_hbuf(ooc_fct_type_loc) = 0_8
      i_shift_second_hbuf(ooc_fct_type_loc) = hbuf_size
      last_iorequest(ooc_fct_type_loc) = -1
      i_cur_hbuf_nextpos = 1
      i_cur_hbuf_fstpos = 1
      i_sub_hbuf_fstpos = 1
      cur_hbuf(ooc_fct_type_loc) = second_hbuf
      CALL dmumps_ooc_next_hbuf(ooc_fct_type_loc)
      END SUBROUTINE dmumps_ooc_init_db_buffer
      SUBROUTINE dmumps_ooc_copy_data_to_buffer(BLOCK,SIZE_OF_BLOCK,
     &     IERR)
      IMPLICIT NONE
      INTEGER(8) :: SIZE_OF_BLOCK
      DOUBLE PRECISION BLOCK(SIZE_OF_BLOCK)
      INTEGER, intent(out) :: IERR
      INTEGER(8) :: I
      ierr=0
      IF (i_rel_pos_cur_hbuf(ooc_fct_type_loc) +
     &    size_of_block <= hbuf_size + 1_8) THEN
      ELSE
        CALL dmumps_ooc_do_io_and_chbuf(ooc_fct_type_loc,ierr)
        IF(ierr.LT.0)THEN
           RETURN
        ENDIF
      END IF
      DO i = 1_8, size_of_block
        buf_io(i_shift_cur_hbuf(ooc_fct_type_loc) +
     &        i_rel_pos_cur_hbuf(ooc_fct_type_loc) + i - 1_8) =
     &    block(i)
      END DO
      i_rel_pos_cur_hbuf(ooc_fct_type_loc) =
     &     i_rel_pos_cur_hbuf(ooc_fct_type_loc) + size_of_block
      RETURN
      END SUBROUTINE dmumps_ooc_copy_data_to_buffer
      SUBROUTINE dmumps_ooc_init_db_buffer_panel()
      IMPLICIT NONE
      INTEGER(8) :: DIM_BUF_IO_L_OR_U
      INTEGER TYPEF, TYPEF_LAST
      INTEGER NB_DOUBLE_BUFFERS
      typef_last = ooc_nb_file_type
      nb_double_buffers = ooc_nb_file_type
      dim_buf_io_l_or_u = dim_buf_io /
     & int(nb_double_buffers,kind=kind(dim_buf_io_l_or_u))
      IF(.NOT.strat_io_async)THEN
         hbuf_size = dim_buf_io_l_or_u
      ELSE
         hbuf_size = dim_buf_io_l_or_u / 2_8
      ENDIF
      DO typef = 1, typef_last
        last_iorequest(typef) = -1
        IF (typef == 1 ) THEN
          i_shift_first_hbuf(typef) = 0_8
        ELSE
          i_shift_first_hbuf(typef) = dim_buf_io_l_or_u
        ENDIF
        IF(.NOT.strat_io_async)THEN
           i_shift_second_hbuf(typef) = i_shift_first_hbuf(typef)
        ELSE
           i_shift_second_hbuf(typef) = i_shift_first_hbuf(typef) +
     &          hbuf_size
        ENDIF
        cur_hbuf(typef) = second_hbuf
        CALL dmumps_ooc_next_hbuf(typef)
      ENDDO
      i_cur_hbuf_nextpos = 1
      RETURN
      END SUBROUTINE dmumps_ooc_init_db_buffer_panel
      SUBROUTINE dmumps_ooc_tryio_chbuf_panel(TYPEF,IERR)
      IMPLICIT NONE
      INTEGER, INTENT(in)  :: TYPEF
      INTEGER, INTENT(out) :: IERR
      INTEGER IFLAG
      INTEGER NEW_IOREQUEST
      ierr=0
      CALL mumps_test_request_c(last_iorequest(typef),iflag,
     &     ierr)
      IF (iflag.EQ.1) THEN
         ierr = 0
         CALL dmumps_ooc_wrt_cur_buf2disk(typef,
     &        new_iorequest,
     &        ierr)
         IF(ierr.LT.0)THEN
            RETURN
         ENDIF
         last_iorequest(typef) = new_iorequest
         CALL dmumps_ooc_next_hbuf(typef)
         nextaddvirtbuffer(typef)=bufferempty
         RETURN
      ELSE IF(iflag.LT.0)THEN
         WRITE(*,*)myid_ooc,': ',err_str_ooc(1:dim_err_str_ooc)
         RETURN
      ELSE
         ierr = 1
         RETURN
      ENDIF
      END SUBROUTINE dmumps_ooc_tryio_chbuf_panel
      SUBROUTINE dmumps_ooc_upd_vaddr_cur_buf (TYPEF,VADDR)
      IMPLICIT NONE
      INTEGER(8), INTENT(in) :: VADDR
      INTEGER, INTENT(in) :: TYPEF
      IF(i_rel_pos_cur_hbuf(typef).EQ.1_8)THEN
         first_vaddr_in_buf(typef)=vaddr
      ENDIF
      RETURN
      END SUBROUTINE dmumps_ooc_upd_vaddr_cur_buf      
      SUBROUTINE dmumps_copy_lu_to_buffer( STRAT, TYPEF, MonBloc,
     &     AFAC, LAFAC,
     &     AddVirtCour, IPIVBEG, IPIVEND, LPANELeff,
     &     IERR)
      IMPLICIT NONE
      INTEGER,          INTENT(IN) :: TYPEF, IPIVBEG, IPIVEND, STRAT
      INTEGER(8),       INTENT(IN) :: LAFAC
      DOUBLE PRECISION, INTENT(IN) :: AFAC(LAFAC)
      INTEGER(8),        INTENT(IN) :: AddVirtCour
      TYPE(io_block),   INTENT(IN) :: MonBloc   
      INTEGER,          INTENT(OUT):: LPANELeff
      INTEGER,          INTENT(OUT):: IERR
      INTEGER   :: II, NBPIVeff
      INTEGER(8) :: IPOS, IDIAG, IDEST
      INTEGER(8) :: DeltaIPOS
      INTEGER   :: StrideIPOS
      ierr=0
      IF (strat.NE.strat_write_max.AND.strat.NE.strat_try_write) THEN
         write(6,*) ' DMUMPS_COPY_LU_TO_BUFFER: STRAT Not implemented '
         CALL mumps_abort()
      ENDIF
      nbpiveff = ipivend - ipivbeg + 1
      IF (monbloc%MASTER .AND. monbloc%Typenode .NE. 3) THEN
        IF (typef.EQ.typef_l) THEN
          lpaneleff = (monbloc%NROW-ipivbeg+1)*nbpiveff
        ELSE
          lpaneleff = (monbloc%NCOL-ipivbeg+1)*nbpiveff
        ENDIF
      ELSE 
          lpaneleff = monbloc%NROW*nbpiveff
      ENDIF
      IF ( ( i_rel_pos_cur_hbuf(typef) + int(lpaneleff - 1,8)
     &     >
     &     hbuf_size )
     &     .OR.
     &     ( (addvirtcour.NE.nextaddvirtbuffer(typef)) .AND.
     &     (nextaddvirtbuffer(typef).NE.bufferempty) )
     &     ) THEN
         IF (strat.EQ.strat_write_max) THEN
            CALL dmumps_ooc_do_io_and_chbuf(typef,ierr) 
         ELSE IF (strat.EQ.strat_try_write) THEN
            CALL dmumps_ooc_tryio_chbuf_panel(typef,ierr) 
            IF (ierr.EQ.1) RETURN
         ELSE
            write(6,*) 'DMUMPS_COPY_LU_TO_BUFFER: STRAT Not implemented'
         ENDIF
      ENDIF
      IF (ierr < 0 ) THEN
        RETURN
      ENDIF
      IF (nextaddvirtbuffer(typef).EQ. bufferempty) THEN
         CALL dmumps_ooc_upd_vaddr_cur_buf (typef,addvirtcour)
         nextaddvirtbuffer(typef) = addvirtcour
      ENDIF
      IF (monbloc%MASTER .AND. monbloc%Typenode .NE. 3) THEN
         idiag =  int(ipivbeg-1,8)*int(monbloc%NCOL,8) + int(ipivbeg,8)
         ipos   = idiag
         idest = i_shift_cur_hbuf(typef) +
     &        i_rel_pos_cur_hbuf(typef)
         IF (typef.EQ.typef_l) THEN
            DO ii = ipivbeg, ipivend
               CALL dcopy(monbloc%NROW-ipivbeg+1, 
     &              afac(ipos), monbloc%NCOL,
     &              buf_io(idest), 1)
               idest = idest + int(monbloc%NROW-ipivbeg+1,8)
               ipos  = ipos  + 1_8
            ENDDO
         ELSE
            DO ii = ipivbeg, ipivend
               CALL dcopy(monbloc%NCOL-ipivbeg+1, 
     &              afac(ipos), 1,
     &              buf_io(idest), 1)
               idest = idest + int(monbloc%NCOL-ipivbeg+1,8)
               ipos  = ipos  + int(monbloc%NCOL,8)
            ENDDO
         ENDIF
      ELSE
         idest = i_shift_cur_hbuf(typef) +
     &        i_rel_pos_cur_hbuf(typef)
         IF (monbloc%Typenode.EQ.3) THEN
           deltaipos  = int(monbloc%NROW,8)
           strideipos = 1
         ELSE
           deltaipos  = 1_8
           strideipos = monbloc%NCOL
         ENDIF
         ipos  = 1_8 + int(ipivbeg - 1,8) * deltaipos
         DO ii = ipivbeg, ipivend
            CALL dcopy(monbloc%NROW, 
     &           afac(ipos), strideipos,
     &           buf_io(idest), 1)
            idest = idest+int(monbloc%NROW,8)
            ipos  = ipos + deltaipos
         ENDDO
      ENDIF
      i_rel_pos_cur_hbuf(typef) =
     &     i_rel_pos_cur_hbuf(typef) + int(lpaneleff,8)
      nextaddvirtbuffer(typef) = nextaddvirtbuffer(typef)
     &                         + int(lpaneleff,8)
      RETURN
      END SUBROUTINE dmumps_copy_lu_to_buffer
      END MODULE dmumps_ooc_buffer