/***********************************************************************
* This file is part of OpenMolcas.                                     *
*                                                                      *
* OpenMolcas is free software; you can redistribute it and/or modify   *
* it under the terms of the GNU Lesser General Public License, v. 2.1. *
* OpenMolcas is distributed in the hope that it will be useful, but it *
* is provided "as is" and without any express or implied warranties.   *
* For more details see the full text of the license in the file        *
* LICENSE or in <http://www.gnu.org/licenses/>.                        *
*                                                                      *
* Copyright (C) 2012,2013, Victor P. Vysotskiy                         *
***********************************************************************/

/******************************************************************************/
/*                         Molcas Memory Allocator                            */
/*----------------------------------------------------------------------------*/
/*                                                                            */
/*    written by:                                                             */
/*    V. P. Vysotskiy                                                         */
/*    University of Lund, Sweden, 2012-2013                                   */
/*                                                                            */
/*----------------------------------------------------------------------------*/
/*                                                                            */
/*    history: Initial revision                                               */
/*                                                                            */
/******************************************************************************/

#ifdef _DEBUGPRINT_MEM_
# define _MEMORY_TRACE_
#endif
#ifdef _CYGWIN_
# define _DARWIN_
# undef _MEMORY_TRACE_
#endif
#define _POSIX_C_SOURCE 200112L
#include <sys/mman.h>
#include <stddef.h>
#include <ctype.h>
#include <stdio.h>
#include <string.h>
#include <strings.h>
#include <stdlib.h>
#include <unistd.h>
#include <math.h>
#include "molcastype.h"
#ifdef _MEMORY_TRACE_
# include <mcheck.h>
#endif
#ifdef _OPENMP
# include <omp.h>
#endif
#include "mma.h"

#define SFCTR(X) (X - X / 10)
#define MXLINE 9
#define PGSIZE 4096
#define MB 1000000
#define EMPTYE -1000
#define PINNED_MEM 999
#define UNDEF_MEM 0
#define SYS_ATIME 0
#define ALLOC_FLD -2
#define MINMEMPTR -577777000306848070
#ifdef _DEBUGPRINT_MEM_
# define MAXREC 524288
#else
# define MAXREC 524288 /* 8192 */
#endif

#ifdef _MEM_PROF_

#  define FCNST 133679
#  define MEM_THRSHLD 1

#  ifdef _CAPITALS_
#   define dcopy DCOPY
#   define scopy SCOPY
#   define icopy ICOPY
#  else
#   ifndef ADD_
#     define dcopy dcopy_
#     define scopy scopy_
#     define icopy icopy_
#   endif
#  endif

void dcopy(INT *N, double *X, INT *INCX, double *Y, INT *INCY);
void scopy(INT *N, float *X, INT *INCX, float *Y, INT *INCY);
void icopy(INT *N, INT *X, INT *INCX, INT *Y, INT *INCY);
#endif

char *getenvc(const char *);
INT dsize(char datatype[]);

typedef struct mentry mentry;
struct mentry {
  char elbl[MXLINE]; /* label                                      */
  char etyp[MXLINE]; /* datatype                                   */
  INT offset;        /* offset relative to Fortran  xWrkSpc arrays */
  INT len;           /* len = numel*dsize(datatype)                */
  INT atime;         /* an unique ID based on the creation time    */
  void *addr;        /* memory adress returned by malloc           */
};

typedef struct mstat mstat;
struct mstat {
  INT nmentry; /* Total number of entries                    */
  INT naccess; /* Total number of allocs                     */
  INT mxmem;   /* MOLCASMEM                                  */
  INT avmem;   /* maximal available memory for MOLCAS        */
  INT totmem;  /* initial MOLCAS_MEM                         */
};

mstat MlM = { 0, SYS_ATIME + 1, 0, 0, 0 };

double *dptr;
float *sptr;
INT *iptr;
char *cptr;

#ifdef _OPENMP
omp_lock_t mma_lock;
#endif
#ifdef _TRACK_
INT trc_mentry(mstat *MM, mentry mentries[], mentry *tmp) {
  INT i, j, len, nentry;
  char *p, *base;
  ptrdiff_t match = -1, dist = 0;

  p = tmp->addr;

  for (nentry = MM->nmentry, j = 0; j < nentry; j++) {
    for (base = mentries[j].addr, len = mentries[j].len, i = 0; i < len; i++)
      if ((match = (&base[i] - p)) == 0)
        break;
    if (match == 0)
      break;
  }

  if (match == 0) {
    printf("Tracked %p address belongs to the '%s' memory entry %p of %ld bytes\n", tmp->addr, mentries[j].elbl, mentries[j].addr,
           LIFMT(mentries[j].len));
    dist = (mentries[j].addr + mentries[j].len) - tmp->addr;
  } else {
    printf("Could not track the %p address\n", tmp->addr);
  }

  return (dist);
}
#endif
#ifdef _MEM_PROF_
void anlz_mem(mentry *tgt) {
  INT n, i, nusd = 0;
  INT flIcnst = (INT)FCNST, *iw;
  double flRcnst = (double)FCNST, *rw;
  float flScnst = (float)FCNST, *sw;
  float mfrc = 100;

  if (tgt->len < MEM_THRSHLD)
    return;
  n = tgt->len / dsize(tgt->etyp);

  switch (tgt->etyp[0]) {
  case 'R':
    rw = (double *)tgt->addr;
    for (i = 0; i < n; i++)
      if (rw[i] == flRcnst)
        nusd++;
    break;
  case 'S':
    sw = (float *)tgt->addr;
    for (i = 0; i < n; i++)
      if (sw[i] == flScnst)
        nusd++;
    break;
  case 'I':
    iw = (INT *)tgt->addr;
    for (i = 0; i < n; i++)
      if (iw[i] == flIcnst)
        nusd++;
    break;
  default:
    return;
  }
  mfrc *= (float)nusd;
  mfrc /= n;
  printf("Fraction of memory usage for entry '%s' (offset=%ld) = %4.3f \%\n", tgt->elbl, LIFMT(tgt->offset), mfrc);
}
#endif

INT testmem(INT *MOLCASMEM) {
  INT rc;
  char *twrkspc = NULL;

  twrkspc = malloc(sizeof(char) * (*MOLCASMEM));

  if (twrkspc) {
    rc = 1;
    free(twrkspc);
  } else {
    rc = -1;
#   ifdef _DEBUGPRINT_MEM_
    printf("MOLCAS cannot get %ld bytes of memory !\n", LIFMT(*MOLCASMEM));
#   endif
  }

  return (rc);
}

INT allocmem(double ref[], INT *intof, INT *dblof, INT *chrof, INT *size) {
  INT rc, MOLCASMEM, MAXMEM;
  char c;
  char *ptr;
  int factor = 1;
# ifdef _DEMO_
  char memsize[] = "128";
# else
  char *memsize = NULL;
# endif
/* I. THE 'MOLCASMEM' PART */
# ifndef _DEMO_
  memsize = getenvc("MOLCAS_MEM");
# endif
  if (memsize == NULL) {
    printf("MOLCAS_MEM is not defined!\n");
    return (-1);
  } else {
    ptr = strstr(memsize, "b");
    if (ptr == NULL)
      ptr = strstr(memsize, "B");
    if (ptr != NULL) {
      c = *(ptr - 1);
      switch (c) {
      case 'G':
      case 'g':
        factor = 1024;
        *(ptr - 1) = 0;
        break;
      case 'M':
      case 'm':
        *(ptr - 1) = 0;
        break;
      case 'T':
      case 't':
        factor = 1024 * 1024;
        *(ptr - 1) = 0;
        break;
      default:
        printf("Unknown units for MOLCAS_MEM\n");
        break;
      }
    }
    MOLCASMEM = strtol(memsize, NULL, 10);
    MOLCASMEM *= MB * factor;
    factor = 1;
#   ifdef _MEMORY_TRACE_
    mcheck(NULL);
    mcheck_pedantic(NULL);
    mtrace();
#   endif
#   ifdef _DEBUGPRINT_MEM_
    printf("MOLCAS_MEM=%ld byte\n", LIFMT(MOLCASMEM));
#   endif
  }

  /* when malloc is intercepted, we should not test if the memory
   * can be allocated (testmem) as that might result in very expensive
   * memset calls from various memory inspection tools */
# ifndef _MALLOC_INTERCEPT_
  rc = (testmem(&MOLCASMEM)) ? 0 : -1;
# else
  rc = 0;
# endif

  *size = MOLCASMEM / sizeof(double);

  *dblof = *intof = *chrof = 1;

  dptr = ref;
  sptr = (float *)ref;
  iptr = (INT *)ref;
  cptr = (char *)ref;

  MlM.avmem = MOLCASMEM;
  MlM.totmem = MOLCASMEM;
# ifndef _DEMO_
  free(memsize);
# endif
/* II. THE 'MOLCAS_MAXMEM' PART */
# ifndef _DEMO_
  memsize = getenvc("MOLCAS_MAXMEM");
# endif
  if (memsize == NULL) {
#   ifdef _DEBUGPRINT_MEM_
    printf("WARNING: MOLCAS_MAXMEM is not defined!\n");
#   endif
  } else {
    ptr = strstr(memsize, "b");
    if (ptr == NULL)
      ptr = strstr(memsize, "B");
    if (ptr != NULL) {
      c = *(ptr - 1);
      switch (c) {
      case 'G':
      case 'g':
        factor = 1024;
        *(ptr - 1) = 0;
        break;
      case 'M':
      case 'm':
        factor = 1;
        *(ptr - 1) = 0;
        break;
      case 'T':
      case 't':
        factor = 1024 * 1024;
        *(ptr - 1) = 0;
        break;
      default:
        printf("Unknown units for MOLCAS_MEM\n");
        break;
      }
    }
    MAXMEM = strtol(memsize, NULL, 10);
    MAXMEM *= MB * factor;
#   ifdef _DEBUGPRINT_MEM_
    printf("MOLCAS_MAXMEM=%ld byte\n", LIFMT(MAXMEM));
#   endif
    MlM.mxmem = MAXMEM - MOLCASMEM;
    if (MlM.mxmem < 0) {
      printf("WARNING: MOLCAS_MAXMEM (%ld) < MOLCAS_MEM (%ld)\n", LIFMT(MAXMEM), LIFMT(MOLCASMEM));
      MlM.mxmem = 0;
    }
#   ifndef _DEMO_
    free(memsize);
#   endif
  }
# ifdef _DEBUGPRINT_MEM_
  printf("ref=%p\n", (void *)ref);
  setvbuf(stdout, NULL, _IOLBF, 0);
# endif
# ifdef _OPENMP
  omp_init_lock(&mma_lock);
# endif
  return (rc);
}

/*-----------------------------------------------------------------------------*/
INT dsize(char datatype[]) {
  INT bsize = -1;
  switch (datatype[0]) {
  case 'R':
    bsize = sizeof(double);
    break;
  case 'S':
    bsize = sizeof(float);
    break;
  case 'I':
    bsize = sizeof(INT);
    break;
  case 'C':
    bsize = sizeof(char);
    break;
  default:
    printf("MMA: not supported datatype '%s'\n", datatype);
#   ifdef _DEBUGPRINT_MEM_
    abort();
#   endif
  }
  return (bsize);
}

/*-----------------------------------------------------------------------------*/
void l2u(char *str) {

  INT i, n = 0;

  if (str != NULL)
    n = strlen(str);

  for (i = 0; i < n; i++) {
    str[i] = toupper(str[i]);
    if (str[i] == 32)
      break;
  }
  str[i] = '\0';

  return;
}
/*-----------------------------------------------------------------------------*/
void string2UC(char *src, char *dest) {
  strcpy(dest, src);
  l2u(dest);
  return;
}

INT memop(char *op) {
# ifdef _TRACK_
  enum memops { ALLO, FREE, LENG, CHEC, MAX, LIST, TERM, FLUS, PINN, RGST, EXCL, TRCK };
# else
  enum memops { ALLO, FREE, LENG, CHEC, MAX, LIST, TERM, FLUS, PINN, RGST, EXCL };
# endif
  if (strstr(op, "ALLO"))
    return (ALLO);
  if (strstr(op, "FREE"))
    return (FREE);
  if (strstr(op, "LENG"))
    return (LENG);
  if (strstr(op, "CHEC"))
    return (CHEC);
  if (strstr(op, "MAX"))
    return (MAX);
  if (strstr(op, "LIST"))
    return (LIST);
  if (strstr(op, "TERM"))
    return (TERM);
  if (strstr(op, "FLUS"))
    return (FLUS);
  if (strstr(op, "PINN"))
    return (PINN);
  if (strstr(op, "RGST"))
    return (RGST);
  if (strstr(op, "EXCL"))
    return (EXCL);
# ifdef _TRACK_
  if (strstr(op, "TRCK"))
    return (TRCK);
# endif
  return (-1);
}

/*-----------------------------------------------------------------------------*/
void dump_mentry(char *tag, mentry *curr) {
  if (curr) {
    printf("MA_DUMP_INFO < %s > name=%s, datatype=%s, offset=%ld (adress=%p), len=%ld\n", tag, curr->elbl, curr->etyp,
           LIFMT(curr->offset), curr->addr, LIFMT(curr->len));
  } else {
    printf("MA_DUMP_INFO < %s >  EMPTY RECORD!\n", tag);
  }
  return;
}
/*-----------------------------------------------------------------------------*/
INT find_mentry(mentry mentries[], mentry *tmp) {
  INT i;
# ifdef _DEBUGPRINT_MEM_
  mentry *tgt = NULL;
# endif
  for (i = 0; i < MAXREC; i++)
    if (mentries[i].offset == tmp->offset)
      break;
# ifdef _DEBUGPRINT_MEM_
  printf("#i=%ld\n", LIFMT(i));
  if (mentries[i].offset == tmp->offset)
    tgt = &mentries[i];
  dump_mentry("TARGET", tgt);
# endif

# ifdef _DEBUGPRINT_MEM_
  if (tgt) {
    if (strcmp(tgt->elbl, tmp->elbl) != 0)
      printf("WARNING: Data  labels    are not matching: %s (stored) and %s (requested)\n", tgt->elbl, tmp->elbl);
    if (strcmp(tgt->etyp, tmp->etyp) != 0)
      printf("WARNING: Data  types     are not matching: %s (stored) and %s (requested)\n", tgt->etyp, tmp->etyp);
    if (tgt->len != tmp->len)
      printf("WARNING: Entry lengths   are not matching: %ld (stored) and %ld (requested)\n", LIFMT(tgt->len), LIFMT(tmp->len));
  }
# endif
  return (i);
}
/*-----------------------------------------------------------------------------*/
INT ismax_mentry(INT i) {
  if (i == MAXREC) {
#   ifdef _DEBUGPRINT_MEM_
    abort();
#   else
    return (1);
#   endif
  } else {
    return 0;
  }
}
/*-----------------------------------------------------------------------------*/
char *woff2cptr(char etyp[], INT offset) {

  char *wrkspc = NULL;

  switch (etyp[0]) {
  case 'R':
    wrkspc = (char *)&dptr[offset];
    break;
  case 'S':
    wrkspc = (char *)&sptr[offset];
    break;
  case 'I':
    wrkspc = (char *)&iptr[offset];
    break;
  case 'C':
    wrkspc = &cptr[offset];
    break;
  default:
    printf("MMA: not supported datatype %s\n", etyp);
  }
  return (wrkspc);
}

/*-----------------------------------------------------------------------------*/
INT cptr2woff(char etyp[], void *c_ptr) {

  ptrdiff_t dist = UNDEF_MEM;

  switch (etyp[0]) {
  case 'R':
    dist = (double *)c_ptr - dptr;
    break;
  case 'S':
    dist = (float *)c_ptr - sptr;
    break;
  case 'I':
    dist = (INT *)c_ptr - iptr;
    break;
  case 'C':
    dist = (char *)c_ptr - cptr;
    break;
  default:
    printf("MMA: not supported datatype %s\n", etyp);
  }
  return (dist);
}

/*-----------------------------------------------------------------------------*/
INT mma_avmem(void) {
  return MlM.avmem;
}

/*-----------------------------------------------------------------------------*/
INT add_mentry(mstat *MM, mentry mentries[], mentry *tmp) {
  ptrdiff_t dist = UNDEF_MEM;
  char *wrkspc = NULL;
  mentry *newe;
# ifdef _MEM_PROF_
  INT n, incx = 0, incy = 1;
  INT flIcnst = (INT)FCNST;
  double flRcnst = (double)FCNST;
  float flScnst = (float)FCNST;
# endif
# ifdef _DARWIN_
# else
  int rc;
# endif

# ifdef _DEBUGPRINT_MEM_
  printf("++++++++ Adding new entry %s of type = %s with length=%ld\n", tmp->elbl, tmp->etyp, LIFMT(tmp->len));
# endif

  newe = &mentries[MM->nmentry++];

  memcpy(newe, tmp, sizeof(mentry));
  MM->naccess++;

  if (newe->atime)
    newe->atime = MM->naccess;

  if (tmp->len == 0) {
#   ifdef _DEBUGPRINT_MEM_
    printf("Request for a zero allocation detected!\n");
#   endif
    newe->offset = MINMEMPTR + MM->naccess;
    return (newe->offset);
  }

  if (tmp->offset == UNDEF_MEM) {
    wrkspc = (char *)malloc(tmp->len);
  } else {
#   ifdef _DARWIN_
    wrkspc = (char *)malloc((size_t)tmp->len);
#   else
    rc = posix_memalign((void **)&wrkspc, (size_t)sysconf(_SC_PAGESIZE), (size_t)tmp->len);
    (void)rc;
#   endif
#   ifdef _DEBUGPRINT_MEM_
    if (mlock((void *)wrkspc, (size_t)tmp->len))
      dump_mentry("Cannot lock memory:", tmp);
#   else
    mlock((void *)wrkspc, (size_t)tmp->len);
#   endif
  }
  if (!wrkspc && tmp->len)
    return (ALLOC_FLD); /* This is an exceptional case, i.e. wrkspc==NULL */

  MM->avmem -= tmp->len;

# ifdef _DEBUGPRINT_MEM_
  bzero((void *)wrkspc, (size_t)tmp->len);
# endif
  newe->addr = (void *)wrkspc;

# ifdef _MEM_PROF_
  n = tmp->len / dsize(tmp->etyp);
# endif
  switch (tmp->etyp[0]) {
  case 'R':
    dist = (double *)wrkspc - dptr;
#   ifdef _MEM_PROF_
    dcopy(&n, &flRcnst, &incx, (double *)wrkspc, &incy);
#   endif
    break;
  case 'S':
    dist = (float *)wrkspc - sptr;
#   ifdef _MEM_PROF_
    scopy(&n, &flScnst, &incx, (float *)wrkspc, &incy);
#   endif
    break;
  case 'I':
    dist = (INT *)wrkspc - iptr;
#   ifdef _MEM_PROF_
    icopy(&n, &flIcnst, &incx, (INT *)wrkspc, &incy);
#   endif
    break;
  case 'C':
    dist = wrkspc - cptr;
    break;
  default:
    printf("MMA: not supported datatype %s\n", tmp->etyp);
  }
# ifdef _DEBUGPRINT_MEM_
  printf("dist=%ld\n", LIFMT(dist));
  printf("entry %s has been allocated at %p\n", newe->elbl, newe->addr);
# endif
  newe->offset = (INT)dist;
# ifdef _DEBUGPRINT_MEM_
  dump_mentry("NEW ENTRY", newe);
# endif
  return (newe->offset);
}

/*-----------------------------------------------------------------------------*/
INT reg_mentry(mstat *MM, mentry mentries[], mentry *tmp) {
  mentry *newe;
# ifdef _DEBUGPRINT_MEM_
  printf("++++++++ Registering new entry %s of type = %s with length=%ld\n", tmp->elbl, tmp->etyp, LIFMT(tmp->len));
# endif

  newe = &mentries[MM->nmentry++];
  memcpy(newe, tmp, sizeof(mentry));
  MM->naccess++;

  if (MlM.mxmem < tmp->len) {
    MlM.avmem -= tmp->len;
  } else {
    MM->mxmem -= tmp->len;
  }
  newe->addr = woff2cptr(tmp->etyp, tmp->offset);
  newe->atime = MM->naccess;

# ifdef _DEBUGPRINT_MEM_
  dump_mentry("NEW ENTRY HAS BEEN REGISTERED", newe);
# endif
  return (newe->atime);
}

/*-----------------------------------------------------------------------------*/
INT del_mentry(mstat *MM, mentry mentries[], mentry *tmp, INT i) {

  char *wrkspc = NULL;
  mentry *tgt, *lst;

# ifdef _DEBUGPRINT_MEM_
  printf("-------- Deleting entry '%9s' of type = '%9s' with length=%12ld (offset=%12ld)\n", tmp->elbl, tmp->etyp, LIFMT(tmp->len),
         LIFMT(tmp->offset));
# endif

  if (i == 0)
    i = find_mentry(mentries, tmp);

  if (ismax_mentry(i)) {
#   ifdef _DEBUGPRINT_MEM_
    abort();
#   else
    return (-1);
#   endif
  }
  tgt = &mentries[i];
  lst = &mentries[--MM->nmentry];

# ifdef _DEBUGPRINT_MEM_
  dump_mentry("DELETING ENTRY", tgt);
# endif

# ifdef _MEM_PROF_
  anlz_mem(tgt);
# endif

  MM->avmem += tgt->len;

  wrkspc = tgt->addr;
# ifdef _DEBUGPRINT_MEM_
  printf("Deallocating memory %s at adress %p\n", tgt->elbl, wrkspc);
# endif

  //    printf("Deallocating memory %s at adress %p\n",tgt->elbl, wrkspc);
  //    printf("Could you see me? - 00\n"); //yma

  if (tgt->len)
    free(wrkspc);

  if (tgt != lst)
    memcpy(tgt, lst, sizeof(mentry));
  bzero((void *)lst, (size_t)sizeof(mentry));

  lst->len = EMPTYE;

  return (0);
}

/*-----------------------------------------------------------------------------*/
INT exc_mentry(mstat *MM, mentry mentries[], mentry *tmp) {
  INT i;
  mentry *tgt, *lst;

# ifdef _DEBUGPRINT_MEM_
  printf("-------- Deleting entry '%9s' of type = '%9s' with length=%12ld (offset=%12ld)\n", tmp->elbl, tmp->etyp, LIFMT(tmp->len),
         LIFMT(tmp->offset));
# endif

  i = find_mentry(mentries, tmp);

  if (ismax_mentry(i))
    return (-1);

  tgt = &mentries[i];
  lst = &mentries[--MM->nmentry];

# ifdef _DEBUGPRINT_MEM_
  dump_mentry("REMOVING ENTRY", tgt);
# endif

  MM->avmem += tgt->len;

  memcpy(tgt, lst, sizeof(mentry));
  bzero((void *)lst, (size_t)sizeof(mentry));

  lst->len = EMPTYE;

  return (0);
}

/*-----------------------------------------------------------------------------*/
void flushMM(mstat *MM, mentry mentries[], mentry *tmp) {
  mentry *tgt;
  INT latime, i;

  if (MM->nmentry == 0)
    return;

  i = find_mentry(mentries, tmp);
# ifdef _DEBUGPRINT_MEM_
  if ((ismax_mentry(i)) || (mentries[i].len == EMPTYE)) {
    printf("It should never happen!\n");
    abort();
  }
# else
  if (ismax_mentry(i))
    return;
# endif
  tgt = &mentries[i];
  latime = tgt->atime;

# ifdef _DEBUGPRINT_MEM_
  dump_mentry("FLUSH", tgt);
# endif
# ifdef _DEBUGPRINT_MEM_
  printf("Going to delete all memory entries older than atime=%ld\n", LIFMT(latime));
# endif
# ifdef _DEBUGPRINT_FLUSH_
  printf("---------------------------------------------------------------------------------------------\n");
  printf("  Nr.\t Label\t\tType\t\tOffset\t\tLength\t   Atime\t  Address\n");
  printf("---------------------------------------------------------------------------------------------\n");
  for (i = MM->nmentry - 1; i > 0; i--)
    if (mentries[i].atime > latime)
      printf("%3ld\t%-12s\t%4s\t%14ld\t%12ld   %9ld\t[%p]\n", LIFMT(i + 1), mentries[i].elbl, mentries[i].etyp,
             LIFMT(mentries[i].offset), LIFMT(mentries[i].len), LIFMT(mentries[i].atime), mentries[i].addr);
  printf("---------------------------------------------------------------------------------------------\n");
# endif
  for (i = MM->nmentry - 1; i > 0; i--)
    if (mentries[i].atime > latime)
      del_mentry(MM, mentries, &mentries[i], i);

  return;
}

/*-----------------------------------------------------------------------------*/
void list_MlM(mstat *MM, mentry mentries[]) {

  INT i = 1;
  if (MM->nmentry == 0)
    return;
  printf("---------------------------------------------------------------------------------------------\n");
  printf("  Nr.\t Label\t\tType\t\tOffset\t\tLength\t   Atime\t  Address\n");
  printf("---------------------------------------------------------------------------------------------\n");
  for (i = 0; i < MM->nmentry; i++)
    printf("%3ld\t%-12s\t%4s\t%14ld\t%12ld   %9ld\t[%p]\n", LIFMT(i + 1), mentries[i].elbl, mentries[i].etyp,
           LIFMT(mentries[i].offset), LIFMT(mentries[i].len), LIFMT(mentries[i].atime), mentries[i].addr);
  printf("---------------------------------------------------------------------------------------------\n");
  printf("Maximal available memory for Molcas = %ld\n", LIFMT(MM->avmem));
  return;
}

/*-----------------------------------------------------------------------------*/
void set_mentry(mentry *tmp, char *lbl, char *typ, INT *offset, INT *len) {
  strcpy(tmp->elbl, lbl);
  strcpy(tmp->etyp, typ);
  tmp->len = (*len);
  tmp->offset = (*offset);
  tmp->atime = 1;
  tmp->addr = NULL;
  return;
}

void print_params(char *func, char *name, char *Op, char *dtyp, INT *offset, INT *len) {
  printf("%s Calling parameters: ('%s','%s','%s',%ld,%ld)\n", func, name, Op, dtyp, LIFMT(*offset), LIFMT(*len));
  return;
}

INT c_getmem_kern(INT *op, mentry *tmp, INT *offset, INT *len) {
# ifdef _TRACK_
  enum memops { ALLO, FREE, LENG, CHEC, MAX, LIST, TERM, FLUS, PINN, RGST, EXCL, TRCK };
# else
  enum memops { ALLO, FREE, LENG, CHEC, MAX, LIST, TERM, FLUS, PINN, RGST, EXCL };
# endif

  static mentry MDATA[MAXREC] = { { "\0", "\0", 0, EMPTYE, 0, NULL } };

  mentry *tmpp;
  INT rc = 1, i, allo = 1, maxMM;

# ifdef _MEMORY_MTRACE_
  mcheck_check_all();
# endif
  switch (*op) {
  case PINN:
    allo = 0;
    /* fall through */
  case ALLO:
    tmp->offset = (allo) ? UNDEF_MEM
                         : PINNED_MEM; /* Just to be sure that we are not going to allocate the PINNED memory for wrong reasons */
                                       /* Checking for memory leaks     */
    if (MlM.nmentry == MAXREC) {
      list_MlM(&MlM, MDATA);
      printf("MEMORY ERROR: Possible memory leak detected: The number of memory blocks exceeds the limit of %d entries\n", MAXREC);
      return (-3);
    }
    /* Checking for free memory available */
    if (MlM.avmem < tmp->len) {
      if ((MlM.avmem + MlM.mxmem) < tmp->len) {
        list_MlM(&MlM, MDATA);
        printf("MEMORY ERROR: Memory is exhausted!\n");
        printf("MEMORY ERROR: Available memory = %ld ( %ld Mb ) !\n", LIFMT(MlM.avmem + MlM.mxmem),
               LIFMT((MlM.avmem + MlM.mxmem) / MB));
        printf("MEMORY ERROR: Requested memory = %ld ( %ld Mb ) !\n", LIFMT(tmp->len), LIFMT(tmp->len / MB));
        printf("MEMORY ERROR: The suggested MOLCAS_MEM=%ld !\n", LIFMT((tmp->len - MlM.avmem + MlM.totmem) / MB + 1));
        return (-4);
      } else {
#       ifdef _DEBUGPRINT_MEM_
        printf("MEMORY WARNING: MOLCAS_MEM has been increased by MOLCAS_MAXMEM (%ld) !\n", LIFMT(MlM.mxmem));
#       endif
        MlM.avmem += tmp->len;
        MlM.mxmem -= tmp->len;
      }
    }
    *offset = add_mentry(&MlM, MDATA, tmp);
    if (*offset == ALLOC_FLD) { /* Failed to allocate the requested memory */
      list_MlM(&MlM, MDATA);
      return (-5);
    }

    break;
  case FREE:
    if (MlM.nmentry == 0) {
      printf("WARNING: Attempt to operate on zero allocated memory blocks\n");
      exit(-3);
    }
    rc = del_mentry(&MlM, MDATA, tmp, 0);

    if (rc < 0)
      list_MlM(&MlM, MDATA);

    break;
  case MAX:
#   ifdef _DEBUGPRINT_MEM_
    printf("MOLCAS_MEM=%ld byte \n", LIFMT(SFCTR(MlM.avmem)));
#   endif
    maxMM = SFCTR(MlM.avmem);

    /* if malloc is intercepted, we should not test if the memory
     * can be allocated (testmem) as that might result in very expensive
     * memset calls from various memory inspection tools */
#   ifndef _MALLOC_INTERCEPT_
    while (maxMM > 0 && testmem(&maxMM) < 0)
      maxMM = SFCTR(maxMM);
#   endif
#   ifdef _DEBUGPRINT_MEM_
    if (maxMM != SFCTR(MlM.avmem))
      printf("MOLCAS MAXMEM: initial = %ld, allocatable =%ld\n", LIFMT(SFCTR(MlM.avmem)), LIFMT(maxMM));
#   endif
    if (maxMM <= 0) {
      printf("MEMORY ERROR: the memory limit has been reached. No window for further memory allocation.\n");
      rc = -1;
    }

    *len = maxMM / dsize(tmp->etyp);

    break;
  case CHEC:
#   ifdef _MEMORY_TRACE_
    mcheck_check_all();
#   endif
    break;
  case LIST:
    list_MlM(&MlM, MDATA);
    break;
  case LENG:
    i = find_mentry(MDATA, tmp);
    tmpp = &MDATA[i];
    *len = (tmpp) ? (tmpp->len / dsize(tmpp->etyp)) : 0;
    break;
  case TERM:
#   ifdef _MEMORY_MTRACE_
    muntrace();
    mcheck_check_all();
#   endif
    tmp->offset = SYS_ATIME;
    if (MlM.nmentry == 0) {
      break;
    } else {
#     if defined (_DEBUGPRINT_MEM_) || ! defined (_DEVEL_)
      printf("MEMORY ERROR: some memory allocations are not released!\n");
      rc = -1;
#     else
      printf("MEMORY WARNING: some memory allocations are not released!\n");
#     endif
      break;
    }
  case FLUS:
    printf("**************************************************\n");
    printf("MEMORY WARNING: use of FLUSH operation deprecated!\n");
    printf("please contact the developer of this module and\n");
    printf("ask him/her to fix this!\n");
    printf("**************************************************\n");
    flushMM(&MlM, MDATA, tmp);
    break;
  case RGST:
    rc = reg_mentry(&MlM, MDATA, tmp);
    break;
  case EXCL:
    rc = exc_mentry(&MlM, MDATA, tmp);
    break;
# ifdef _TRACK_
  case TRCK:
    rc = trc_mentry(&MlM, MDATA, tmp);
    *len = rc / (dsize(tmp->etyp));
    break;
# endif
  default:
    rc = -1;
    printf("Unsupported memory operation !\n");
  }
# ifdef _DEBUGPRINT_MEM_
  list_MlM(&MlM, MDATA);
  if (MlM.avmem < 0) {
    printf("Integer Overflow has been detected!\n");
    rc = -1;
  }
# endif
  return (rc);
}

#ifdef _TRACK_
void track_mem(char *address) {

  mentry tmp;
  char e_name[] = "TRCK", Op[] = "TRCK", e_dtyp[] = "CHAR";
  INT offset = 0, blen = 1, op;

  bzero(&tmp, sizeof(mentry));
  set_mentry(&tmp, e_name, e_dtyp, &offset, &blen);
  tmp.addr = address;

  op = memop(Op);

  c_getmem_kern(&op, &tmp, &offset, &blen);

  return;
}
#endif

INT c_getmem(char *name, char *Op, char *dtyp, INT *offset, INT *len) {
# ifdef _TRACK_
  enum memops { ALLO, FREE, LENG, CHEC, MAX, LIST, TERM, FLUS, PINN, RGST, EXCL, TRCK };
# else
  enum memops { ALLO, FREE, LENG, CHEC, MAX, LIST, TERM, FLUS, PINN, RGST, EXCL };
# endif

  mentry tmp;

  INT rc, op, blen;
  char e_name[MXLINE];
  char e_dtyp[MXLINE];
  char action[MXLINE];

  string2UC(name, e_name);
  string2UC(dtyp, e_dtyp);
  string2UC(Op, action);

  op = memop(action);
# ifdef _DEBUGPRINT_MEM_
  print_params("C_GetMem", name, Op, dtyp, offset, len);
  printf("Op=%s (%ld)\n", Op, LIFMT(memop(Op)));
# endif

  blen = (e_dtyp[0] == 'C') ? 1 : 0;
  blen += dsize(e_dtyp) * (*len);

  bzero(&tmp, sizeof(mentry));
  set_mentry(&tmp, e_name, e_dtyp, offset, &blen);
# ifdef _OPENMP
  omp_set_lock(&mma_lock);
# endif
  rc = c_getmem_kern(&op, &tmp, offset, len);
# ifdef _OPENMP
  omp_unset_lock(&mma_lock);
  if (op == TERM)
    omp_destroy_lock(&mma_lock);
# endif
  if (rc < 0) {
    print_params("C_GetMem", name, Op, dtyp, offset, len);
  }
  return (rc);
}

char *allomblck(char *name, INT *len) {

  mentry tmp;
  char Op[] = "ALLO", ctyp[] = "CHAR", *mblck = NULL, e_name[MXLINE];
  INT rc, op, blen, offset = 0;

  op = memop(Op);
  string2UC(name, e_name);
# ifdef _DEBUGPRINT_MEM_
  print_params("C_GetMem", name, Op, ctyp, &offset, len);
  printf("Op=%s (%ld)\n", Op, LIFMT(memop(Op)));
# endif

  blen = (*len) + 1;
  bzero(&tmp, sizeof(mentry));
  set_mentry(&tmp, e_name, ctyp, &offset, &blen);
  tmp.atime = SYS_ATIME;

  rc = c_getmem_kern(&op, &tmp, &offset, len);

  if (rc >= 0) {
    mblck = woff2cptr(ctyp, offset);
  } else {
    print_params("C_GetMem", name, Op, ctyp, &offset, len);
  }

  return (mblck);
}

char *pinnmblck(char *name, INT *len) {

  char Op[] = "PINN", ctyp[] = "CHAR", *mblck = NULL;
  INT rc, offset;

  rc = c_getmem(name, Op, ctyp, &offset, len);
  if (rc >= 0)
    mblck = woff2cptr(ctyp, offset);

  return (mblck);
}

INT freemblck(char *mblck) {

  char Op[] = "FREE", ctyp[] = "CHAR", name[] = "DELMEM";
  INT offset, len, rc;

  offset = cptr2woff(ctyp, mblck);
  rc = c_getmem(name, Op, ctyp, &offset, &len);
  mblck = NULL;
  return (rc);
}

INT lengmblck(char *mblck) {

  char Op[] = "LENG", ctyp[] = "CHAR", name[] = "LENMEM";
  INT offset, len;

  offset = cptr2woff(ctyp, mblck);
  c_getmem(name, Op, ctyp, &offset, &len);

  return (len);
}

INT trckmblck(char *mblck) {

  char Op[] = "TRCK", ctyp[] = "CHAR", name[] = "TRACK";
  INT offset, len, rc;

  offset = cptr2woff(ctyp, mblck);
  rc = c_getmem(name, Op, ctyp, &offset, &len);

  return (rc);
}
