/***********************************************************************
* 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 MB 1000000
#define EMPTYE -1000
#define PINNED_MEM 999
#define UNDEF_MEM 0
#define SYS_ATIME 0
#define ALLOC_FLD -2
#define MINMEMPTR -577777000306848070
#define MAXREC 524288

#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 address 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                         */
};

enum memops { ALLO, FREE, LIST, TERM, RGST, EXCL };

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

double anchor[1];
char *cptr = (char *)anchor;

#ifdef _OPENMP
omp_lock_t mma_lock;
#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 '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(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);

  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 *)cptr);
  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 '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) {
  if (strstr(op, "ALLO"))
    return (ALLO);
  if (strstr(op, "FREE"))
    return (FREE);
  if (strstr(op, "LIST"))
    return (LIST);
  if (strstr(op, "TERM"))
    return (TERM);
  if (strstr(op, "RGST"))
    return (RGST);
  if (strstr(op, "EXCL"))
    return (EXCL);
  return (-1);
}

/*-----------------------------------------------------------------------------*/
void dump_mentry(char *tag, mentry *curr) {
  if (curr) {
    printf("MA_DUMP_INFO < %s > name=%s, datatype=%s, offset=%ld (address=%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;
  }
}
/*-----------------------------------------------------------------------------*/
void *woff2cptr(INT offset) {

  return ((void *)&cptr[offset]);
}

/*-----------------------------------------------------------------------------*/
INT cptr2woff(void *c_ptr) {

  return ((INT)((char *)c_ptr - cptr) + 1);
}

/*-----------------------------------------------------------------------------*/
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 - (double *)cptr;
#   ifdef _MEM_PROF_
    dcopy(&n, &flRcnst, &incx, (double *)wrkspc, &incy);
#   endif
    break;
  case 'I':
    dist = (INT *)wrkspc - (INT *)cptr;
#   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->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 address %p\n", tgt->elbl, wrkspc);
# endif

  //    printf("Deallocating memory %s at address %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 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) {

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

  INT rc = 1, allo = 1;

# ifdef _MEMORY_MTRACE_
  mcheck_check_all();
# endif
  switch (*op) {
  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 LIST:
    list_MlM(&MlM, MDATA);
    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 RGST:
    rc = reg_mentry(&MlM, MDATA, tmp);
    break;
  case EXCL:
    rc = exc_mentry(&MlM, MDATA, tmp);
    break;
  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);
}

INT c_getmem(char *name, char *Op, char *dtyp, INT *offset, INT *len) {

  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);
# 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);
}

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

  mentry tmp;
  char Op[] = "ALLO", ctyp[] = "CHAR", e_name[MXLINE];
  void *mblck = NULL;
  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);

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

  return (mblck);
}

INT freemblck(void *mblck) {

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

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