cfac_mem_alloc_cb.F File Reference

Go to the source code of this file.

Functions/Subroutines
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)

Function/Subroutine Documentation

cmumps_alloc_cb()

subroutine cmumps_alloc_cb	(	logical	inplace,
		integer(8)	min_space_in_place,
		logical	ssarbr,
		logical	process_bande,
		integer	myid,
		integer	n,
		integer, dimension(500)	keep,
		integer(8), dimension(150)	keep8,
		real, dimension(230)	dkeep,
		integer, dimension(liw)	iw,
		integer	liw,
		complex, dimension(la)	a,
		integer(8)	la,
		integer(8)	lrlu,
		integer(8)	iptrlu,
		integer	iwpos,
		integer	iwposcb,
		integer, intent(in)	slavef,
		integer, dimension(keep(28)), intent(in)	procnode_steps,
		integer, dimension(keep(28)), intent(in)	dad,
		integer, dimension(keep(28))	ptrist,
		integer(8), dimension(keep(28))	ptrast,
		integer, dimension(n)	step,
		integer, dimension(keep(28))	pimaster,
		integer(8), dimension(keep(28))	pamaster,
		integer	lreq,
		integer(8)	lreqcb,
		integer	node_arg,
		integer	state_arg,
		logical	set_header,
		integer	comp,
		integer(8)	lrlus,
		integer(8)	lrlusm,
		integer	iflag,
		integer	ierror )

Definition at line 14 of file cfac_mem_alloc_cb.F.

!$    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