cfac_mem_alloc_cb.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 cmumps_alloc_cb( INPLACE, MIN_SPACE_IN_PLACE,
     &   SSARBR, PROCESS_BANDE,
     &   MYID,N, KEEP,KEEP8,DKEEP,
     &   IW, LIW, A, LA,
     &   LRLU, IPTRLU,IWPOS,IWPOSCB,
     &   SLAVEF, PROCNODE_STEPS, DAD,
     &   PTRIST,PTRAST,STEP,PIMASTER,PAMASTER,
     &   LREQ, LREQCB, NODE_ARG, STATE_ARG, SET_HEADER,
     &   COMP, LRLUS, LRLUSM, IFLAG, IERROR )
!$    USE OMP_LIB
      USE cmumps_load
      IMPLICIT NONE
      INTEGER N,LIW, KEEP(500)
      INTEGER(8) LA, LRLU, IPTRLU, LRLUS, LRLUSM, LREQCB
      INTEGER(8) PAMASTER(KEEP(28)), PTRAST(KEEP(28))
      INTEGER IWPOS,IWPOSCB
      INTEGER(8) :: MIN_SPACE_IN_PLACE
      INTEGER NODE_ARG, STATE_ARG
      INTEGER(8) KEEP8(150)
      REAL DKEEP(230)
      INTEGER IW(LIW),PTRIST(KEEP(28))
      INTEGER STEP(N), PIMASTER(KEEP(28))
      INTEGER, INTENT(IN) :: SLAVEF
      INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28))
      INTEGER MYID, IXXP
      COMPLEX A(LA)
      LOGICAL INPLACE, PROCESS_BANDE, SSARBR, SET_HEADER
      INTEGER COMP, LREQ, IFLAG, IERROR
      include 'mumps_headers.h'
      INTEGER INODE_LOC,NPIV,NASS,NROW,NCB
      INTEGER ISIZEHOLE
      INTEGER(8) :: MEM_GAIN, RSIZEHOLE, LREQCB_EFF, LREQCB_WISHED
      INTEGER(8) :: DYN_SIZE, KEEP8TMPCOPY
      IF ( inplace ) THEN
        lreqcb_eff = min_space_in_place
        IF ( min_space_in_place > 0_8 ) THEN
          lreqcb_wished = lreqcb
        ELSE
          lreqcb_wished = 0_8
        ENDIF
      ELSE
        lreqcb_eff = lreqcb
        lreqcb_wished = lreqcb
      ENDIF
      IF (iwposcb.EQ.liw) THEN
        IF (lreq.NE.keep(ixsz).OR.lreqcb.NE.0_8
     &      .OR. .NOT. set_header) THEN
          WRITE(*,*) "Internal error in CMUMPS_ALLOC_CB ",
     &      set_header, lreq, lreqcb
          CALL mumps_abort()
        ENDIF
        IF (iwposcb-iwpos+1 .LT. keep(ixsz)) THEN
          WRITE(*,*) "Problem with integer stack size",iwposcb,
     &               iwpos, keep(ixsz)
          iflag  = -8
          ierror = lreq
          RETURN
        ENDIF
        iwposcb=iwposcb-keep(ixsz)
        iw(iwposcb+1+xxi)=keep(ixsz)
        CALL mumps_storei8(0_8,iw(iwposcb+1+xxr))
        CALL mumps_storei8(0_8,iw(iwposcb+1+xxd))
        iw(iwposcb+1+xxn)=-919191
        iw(iwposcb+1+xxs)=s_notfree
        iw(iwposcb+1+xxp)=top_of_stack
        RETURN
      ENDIF
      CALL mumps_geti8( dyn_size, iw(iwposcb+1 + xxd))
      IF (dyn_size .EQ. 0_8
     &    .AND. keep(214).EQ.1.AND.
     &    keep(216).EQ.1.AND.
     &    iwposcb.NE.liw) THEN
       IF (iw(iwposcb+1 + xxs).EQ.s_nolcbnocontig.OR.
     &     iw(iwposcb+1 + xxs).EQ.s_nolcbnocontig38) THEN
        ncb  = iw( iwposcb+1 + keep(ixsz) )
        nrow = iw( iwposcb+1 + keep(ixsz) + 2)
        npiv = iw( iwposcb+1 + keep(ixsz) + 3)
        inode_loc= iw( iwposcb+1 + xxn)
        CALL cmumps_get_sizehole(iwposcb+1,iw,liw,
     &                          isizehole,rsizehole)
        IF (iw(iwposcb+1 + xxs).EQ.s_nolcbnocontig) THEN
          CALL cmumps_makecbcontig(a,la,iptrlu+1_8,
     &                           nrow,ncb,npiv+ncb,0,
     &                           iw(iwposcb+1 + xxs),rsizehole)
          iw(iwposcb+1 + xxs) =s_nolcleaned
          mem_gain            = int(nrow,8)*int(npiv,8)
        ENDIF
        IF (iw(iwposcb+1 + xxs).EQ.s_nolcbnocontig38) THEN
          nass = iw( iwposcb+1 + keep(ixsz) + 4)
          CALL cmumps_makecbcontig(a,la,iptrlu+1_8,
     &                           nrow,ncb,npiv+ncb,nass-npiv,
     &                           iw(iwposcb+1 + xxs),rsizehole)
          iw(iwposcb+1 + xxs) =s_nolcleaned38
          mem_gain = int(nrow,8)*int(npiv+ncb-(nass-npiv),8)
        ENDIF
        IF (isizehole.NE.0) THEN
          CALL cmumps_ishift( iw,liw,iwposcb+1,
     &                       iwposcb+iw(iwposcb+1+xxi),
     &                       isizehole )
          iwposcb=iwposcb+isizehole
          iw(iwposcb+1+xxp+iw(iwposcb+1+xxi))=iwposcb+1
          ptrist(step(inode_loc))=ptrist(step(inode_loc))+
     &    isizehole
        ENDIF
        CALL mumps_subtri8toarray(iw(iwposcb+1+xxr), mem_gain)
        iptrlu              = iptrlu+mem_gain+rsizehole
        lrlu                = lrlu+mem_gain+rsizehole
        ptrast(step(inode_loc))=
     &  ptrast(step(inode_loc))+mem_gain+rsizehole
       ENDIF
      ENDIF
      IF (lrlu.LT.lreqcb_wished)THEN
         IF (lreqcb_eff.LT.lreqcb_wished) THEN
          CALL cmumps_compre_new(n,keep,iw,liw,a,la,
     &                    lrlu,iptrlu,iwpos,iwposcb,
     &                    ptrist,ptrast,
     &                    step, pimaster,pamaster,lrlus,
     &                    keep(ixsz), comp, dkeep(97), myid,
     &                    slavef, procnode_steps, dad)
         ENDIF
      ENDIF
      CALL cmumps_get_size_needed 
     &                   (lreq, lreqcb_eff, .false.,
     &                    keep(1), keep8(1),
     &                    n,iw,liw,a,la,
     &                    lrlu,iptrlu,iwpos,iwposcb,
     &                    ptrist,ptrast,
     &                    step, pimaster,pamaster,lrlus,
     &                    keep(ixsz), comp, dkeep(97), myid,
     &                    slavef, procnode_steps, dad, 
     &                    iflag, ierror)
      IF (iflag.LT.0) GOTO 650
      ixxp=iwposcb+xxp+1
      IF (ixxp.GT.liw) THEN
        WRITE(*,*) "Internal error 3 in CMUMPS_ALLOC_CB ",ixxp
      ENDIF
      IF (iw(ixxp).GT.0) THEN
        WRITE(*,*) "Internal error 2 in CMUMPS_ALLOC_CB ",iw(ixxp),ixxp
      ENDIF
      iwposcb = iwposcb - lreq
      IF (set_header) THEN
        iw(ixxp)= iwposcb + 1
        iw(iwposcb+1:iwposcb+1+keep(ixsz))=-99999 
        iw(iwposcb+1+xxi)=lreq
        CALL mumps_storei8(lreqcb, iw(iwposcb+1+xxr))
        CALL mumps_storei8(0_8, iw(iwposcb+1+xxd))
        iw(iwposcb+1+xxs)=state_arg
        iw(iwposcb+1+xxn)=node_arg
        iw(iwposcb+1+xxp)=top_of_stack
        iw(iwposcb+1+xxnbpr)=0 
      ENDIF
      iptrlu = iptrlu - lreqcb
      lrlu   = lrlu - lreqcb
      lrlus  = lrlus - lreqcb_eff
      lrlusm = min(lrlus, lrlusm)
      IF (keep(405) .EQ. 0) THEN
        keep8(69) = keep8(69) + lreqcb_eff
        keep8(68) = max(keep8(69), keep8(68))
      ELSE
!$OMP   ATOMIC CAPTURE
        keep8(69) = keep8(69) + lreqcb_eff
        keep8tmpcopy = keep8(69)
!$OMP   END ATOMIC
!$OMP   ATOMIC UPDATE
        keep8(68) = max(keep8tmpcopy, keep8(68))
!$OMP   END ATOMIC
      ENDIF
      CALL cmumps_load_mem_update(ssarbr,process_bande,
     &              la-lrlus,0_8,lreqcb_eff,keep,keep8,lrlus)
 650  CONTINUE
      RETURN
      END SUBROUTINE cmumps_alloc_cb