1C
2C  This file is part of MUMPS 5.1.2, released
3C  on Mon Oct  2 07:37:01 UTC 2017
4C
5C
6C  Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria,
7C  University of Bordeaux.
8C
9C  This version of MUMPS is provided to you free of charge. It is
10C  released under the CeCILL-C license:
11C  http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html
12C
13      SUBROUTINE DMUMPS_FREE_BLOCK_CB(SSARBR, MYID, N, IPOSBLOCK,
14     &       RPOSBLOCK,
15     &       IW, LIW,
16     &       LRLU, LRLUS, IPTRLU,
17     &       IWPOSCB, LA, KEEP, KEEP8, IN_PLACE_STATS
18     &     )
19      USE DMUMPS_LOAD
20      IMPLICIT NONE
21      INTEGER(8) :: RPOSBLOCK
22      INTEGER IPOSBLOCK,
23     &         LIW, IWPOSCB, N
24      INTEGER(8) :: LA, LRLU, LRLUS, IPTRLU
25      LOGICAL IN_PLACE_STATS
26      INTEGER IW( LIW ), KEEP(500)
27      INTEGER(8) KEEP8(150)
28      INTEGER MYID
29      LOGICAL SSARBR
30      INTEGER SIZFI_BLOCK, SIZFI
31      INTEGER IPOSSHIFT
32      INTEGER(8) :: SIZFR, SIZFR_BLOCK, SIZFR_BLOCK_EFF,
33     &              SIZEHOLE, MEM_INC
34      INCLUDE 'mumps_headers.h'
35      IPOSSHIFT = IPOSBLOCK + KEEP(IXSZ)
36      SIZFI_BLOCK=IW(IPOSBLOCK+XXI)
37      CALL MUMPS_GETI8( SIZFR_BLOCK,IW(IPOSBLOCK+XXR) )
38      IF (KEEP(216).eq.3) THEN
39        SIZFR_BLOCK_EFF=SIZFR_BLOCK
40      ELSE
41        CALL DMUMPS_SIZEFREEINREC( IW(IPOSBLOCK),
42     &                     LIW-IPOSBLOCK+1,
43     &                     SIZEHOLE, KEEP(IXSZ))
44        SIZFR_BLOCK_EFF=SIZFR_BLOCK-SIZEHOLE
45      ENDIF
46      IF ( IPOSBLOCK .eq. IWPOSCB + 1 ) THEN
47         IPTRLU  = IPTRLU  + SIZFR_BLOCK
48         IWPOSCB = IWPOSCB + SIZFI_BLOCK
49         LRLU    = LRLU  + SIZFR_BLOCK
50         IF (.NOT. IN_PLACE_STATS) THEN
51           LRLUS   = LRLUS + SIZFR_BLOCK_EFF
52           KEEP8(70) = KEEP8(70) + SIZFR_BLOCK_EFF
53           KEEP8(71) = KEEP8(71) + SIZFR_BLOCK_EFF
54         ENDIF
55      MEM_INC = -SIZFR_BLOCK_EFF
56      IF (IN_PLACE_STATS) THEN
57        MEM_INC= 0_8
58      ENDIF
59      CALL DMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE.,
60     &         LA-LRLUS,0_8,MEM_INC,KEEP,KEEP8,LRLUS)
61 90      IF ( IWPOSCB .eq. LIW ) GO TO 100
62         IPOSSHIFT = IWPOSCB + KEEP(IXSZ)
63         SIZFI = IW( IWPOSCB+1+XXI )
64         CALL MUMPS_GETI8( SIZFR,IW(IWPOSCB+1+XXR) )
65         IF ( IW( IWPOSCB+1+XXS ) .EQ. S_FREE ) THEN
66              IPTRLU  = IPTRLU + SIZFR
67              LRLU    = LRLU + SIZFR
68              IWPOSCB = IWPOSCB + SIZFI
69              GO TO 90
70         ENDIF
71 100     CONTINUE
72         IW( IWPOSCB+1+XXP)=TOP_OF_STACK
73      ELSE
74         IW( IPOSBLOCK +XXS)=S_FREE
75         IF (.NOT. IN_PLACE_STATS) THEN
76           LRLUS = LRLUS + SIZFR_BLOCK_EFF
77           KEEP8(70) = KEEP8(70) + SIZFR_BLOCK_EFF
78           KEEP8(71) = KEEP8(71) + SIZFR_BLOCK_EFF
79         ENDIF
80      CALL DMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE.,
81     &            LA-LRLUS,0_8,-SIZFR_BLOCK_EFF,KEEP,KEEP8,LRLUS)
82      END IF
83      RETURN
84      END SUBROUTINE DMUMPS_FREE_BLOCK_CB
85