lib
/
EXODUS
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
Cloned SEACAS for EXODUS library with extra build files for internal package management.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
4 Commits
1 Branch
0 Tags
19 MiB
 
 
 
 
 
 
Tag: Branch: Tree: 77bd7563eb
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from '77bd7563eb'
${ noResults }
EXODUS/packages/seacas/libraries/supes/mem_mgr/mdinit.F

1719 lines
48 KiB
Raw Blame History

C Copyright(C) 1999-2020, 2022 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS). Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details
SUBROUTINE MDINIT (USERV)
C THIS SUBPROGRAM PROVIDES DATA MANAGEMENT WITH DYNAMIC MEMORY
C ALLOCATION CAPABILITIES. THE ENTIRE PACKAGE IS WRITTEN IN
C STANDARD FORTRAN-77 WITH THE EXCEPTION OF TWO SYSTEM DEPENDENT
C SUBPROGRAMS: IXLNUM AND EXMEMY.
C ENTRY POINTS:
C MDINIT (USERV)
C MCINIT (UCHAR)
C Initializes the data manager and calculates the offset of the
C users base vector.
C MDCOMP
C MCCOMP
C Compresses all storage to consolidate the voids within a
C memory block.
C MDDEBG (UNIT)
C MCDEBG (UNIT)
C Turns on immediate error output at the time an error is triggered.
C MDDEL (NAME1)
C MCDEL (NAME1)
C "Deletes" (frees the storage of) an array.
C MDEFIX (ENUM, COUNT)
C MCEFIX (ENUM, COUNT)
C Resets the error counter for a particular error flag.
C MDEROR (UNIT)
C MCEROR (UNIT)
C Prints an error summary.
C MDERPT (ENUM, COUNT)
C MCERPT (ENUM, COUNT)
C Returns the error count for a particular error flag.
C MCEXEC ()
C MDEXEC ()
C Turns off deferred allocation and resolves all deferred requests.
C MDFILL (TFILL)
C MCFILL (NAME1)
C Turns on data initialization to a specific value.
C MDFIND (NAME1, NEWLOC, NEWLEN)
C MCFIND (NAME1, NEWLOC, NEWLEN)
C Reports the location and length of an array.
C MDFOFF ()
C MCFOFF ()
C Turns off data initialization.
C MDGET (MNGET)
C MCGET (MNGET)
C Requests a contiguous block of storage.
C MDGIVE
C MCGIVE
C Returns storage to the system under certain conditions.
C MDLAST (ENUM)
C MCLAST (ENUM)
C Returns the flag number of the last error.
C MDLIST (UNIT)
C MCLIST (UNIT)
C Prints a storage summary.
C MDLONG (NAME1, NEWLOC, NEWLEN)
C MCLONG (NAME1, NEWLOC, NEWLEN)
C Changes the length of an array.
C MDNAME (NAME1, NAME2)
C MCNAME (NAME1, TNAME2)
C Changes the name of an array.
C MDMEMS (NSUA, NSUD, NSUV, NSULV)
C Reports numeric storage information.
C MCMEMS (NSUA, NSUD, NSUV, NSULV)
C Reports character storage information.
C MDPRNT (NAME1, UNIT, NAME2)
C MCPRNT (NAME1, UNIT, NEWLEN)
C Prints an array.
C MDRSRV (NAME1, NEWLOC, NEWLEN)
C MCRSRV (NAME1, NEWLOC, NEWLEN)
C Reserves space for an array and reports the storage location.
C MDSTAT (MNERRS, MNUSED)
C MCSTAT (MNERRS, MNUSED)
C Reports on accumulated errors and space used.
C MCWAIT ()
C MDWAIT ()
C Turns on deferred allocation mode.
C Associated subroutines:
C IXLCHR MXLIST MYLONG
C MDINIT MXLONG MYMEMY
C MEMTEST MXLOOK MYNSRT
C MXCOMP MXNSRT MYPRNT
C MXDEL MXPRNT MYRSRV
C MXEROR MXRSRV SHFTC
C MXEXEC MYCOMP SHFTI
C MXFIND MYDEL SRCHC
C MXGET MYFIND SRCHI
C MXGIVE MYGET VTABLE
IMPLICIT INTEGER (A-Z)
C Dictionary and tables lengths.
C LDICT Maximum number of dictionary entries/allocated arrays.
C LVOID Maximum number of voids.
C These parameters may be changed independently.
PARAMETER (LPDICT=256, LPVOID=2048)
CHARACTER*8 DICT(LPDICT, 2)
DIMENSION DPOINT(LPDICT, 2, 3)
C * *> 1: LOCATION
C * 2: NUMERIC STORAGE UNITS
C * 3: CHARACTER STORAGE UNITS
C * (-1 FOR NUMERIC)
C *> 1: NUMERIC
C 2: CHARACTER FOR NON MIXED MODE
DIMENSION VOID(LPVOID, 2, 2)
C * *> 1: LOCATION
C * 2: SIZE (IN NUMERIC UNITS FOR MIXED MODE)
C *> 1: NUMERIC
C 2: CHARACTER FOR NON MIXED MODE
C The strategy for the above arrays is to fix the second dimension
C at 1 for mixed mode, but let the first dimension "overrun" so
C that the storage is usable. In nonmixed mode, the first dimension
C will not overrun and the character stuff will use a value of 2 for
C for the second dimension. The mixed vs. nonmixed mode is
C indicated by the variable CHRCOL. (1 = mixed, 2 = nonmixed)
INCLUDE 'params.inc'
DIMENSION ERRVEC(NERVEC)
C Internal base vectors.
C All pointers in the tables are relative to these base vectors, and
C an offset to the users base vector is maintained to give the
C user the correct pointer to the users base vector. They are
C equivalenced to allow printing as real or integer (see mdprnt).
#if __GFORTRAN__ && __GNUC__ >= 10
C ... For some reason, gfortran-10 needs this SAVE in addition to later save...
save myv
#endif
double precision dmyv(1)
REAL RMYV(1)
equivalence (dmyv,rmyv)
DIMENSION MYV(1)
EQUIVALENCE (MYV,RMYV)
PARAMETER (MAXSIZ=2)
CHARACTER*1 MYCHAR(MAXSIZ), CFDATA
C COMMON /EXTCLB/ MYCHAR
LOGICAL INIT, CINIT, DEFER, DEFROK, FILL, CFILL
C Users base vector. This is an argument in the entry point
C MDINIT.
DIMENSION USERV(1)
CHARACTER*1 UCHAR(1)
PARAMETER (NCOLP=132)
CHARACTER*8 NAME1, NAME2, NAMET
CHARACTER*(*) TNAME1, TNAME2
DIMENSION NVOIDS(2), NNAMES(2)
SAVE
C Data initialization
DATA NVOIDS /2*0/, NNAMES /2*0/
DATA ERRVEC /NERVEC*0/
DATA INIT /.FALSE./, CINIT /.FALSE./,
* DEFER /.FALSE./, DEFROK /.FALSE./,
* FILL /.FALSE./, CFILL /.FALSE./
DATA EUNIT /0/
DATA LERROR /0/
DATA CHRCOL /1/
LDICT = 2 * LPDICT
LVOID = 2 * LPVOID
C Get the offset between "USERV" and "MYV". All internal
C information is in terms of "MYV" since most operations are done
C with this base address.
MYLOC = IXLNUM (MYV(1))
ULOC = IXLNUM (USERV(1))
OFFSET = MYLOC - ULOC
C Check to see if deferred mode will be allowed. This requires
C a functioning IXLNUM.
C IF (IXLNUM(NVOIDS(1)) .NE. IXLNUM(NVOIDS(2))) DEFROK = .TRUE.
C ... Using malloc/free -- ignore deferred mode
DEFROK = .false.
C Was MDINIT previously called?
IF (INIT) THEN
LASTER = REINIT
IF (EUNIT .GT. 0) WRITE (EUNIT, *)'SECOND CALL TO MDINIT NOT ',
* 'ALLOWED.'
ELSE
LASTER = SUCCESS
END IF
INIT = .TRUE.
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (LASTER .NE. SUCCESS) LERROR = LASTER
RETURN
C***********************************************************************
ENTRY MCINIT (UCHAR)
C***********************************************************************
C Was MDINIT previously called?
IF (.NOT. INIT) THEN
LASTER = NOINIT
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MDINIT NOT CALLED BEFORE ',
* 'CALLING MCINIT.'
RETURN
END IF
MYCLOC = IXLCHR (MYCHAR(1))
UCLOC = IXLCHR (UCHAR(1))
TEMP = IXLCHR (MYCHAR(2))
IF (MYCLOC .NE. TEMP) THEN
C Mixed mode - character and numeric data intermixed.
CALL EXPARM (NAMET, NAMET, I, CHRNUM, I, I)
COFFST = CHRNUM * MYLOC - UCLOC
ELSE
C Split mode - character and numeric data separate.
COFFST = 0
CHRCOL = 2
CHRNUM = 1
IF (NNAMES(1) .GT. LPDICT) THEN
LASTER = DFULL
ELSE IF (NVOIDS(1) .GT. LPVOID) THEN
LASTER = VFULL
ELSE
LDICT = LPDICT
LVOID = LPVOID
LASTER = SUCCESS
END IF
END IF
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (LASTER .NE. SUCCESS) THEN
LERROR = LASTER
IF (EUNIT .GT. 0) THEN
CALL MXEROR (EUNIT, LASTER, ERRVEC)
WRITE (EUNIT, *) 'ERROR IN MCINIT.'
END IF
ELSE
CINIT = .TRUE.
END IF
RETURN
C***********************************************************************
ENTRY MCCOMP
C***********************************************************************
C Was MCINIT previously called?
IF (.NOT. CINIT) THEN
LASTER = NOINIT
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MCINIT WAS NOT CALLED ',
* 'BEFORE CALLING MCCOMP.'
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
LERROR = LASTER
RETURN
END IF
C***********************************************************************
ENTRY MDCOMP
C***********************************************************************
C This section compresses all void space to the end of each block.
C No attempt is made to shift storage between blocks.
C Was MDINIT previously called?
IF (.NOT. INIT) THEN
LASTER = NOINIT
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MDINIT NOT CALLED BEFORE ',
* 'CALLING MDCOMP.'
RETURN
END IF
C ... Using malloc/free -- ignore MCCOMP/MDDOMP Calls
c CALL MXCOMP (MYV, VOID, LVOID,
c * NVOIDS, DPOINT, LDICT, NNAMES, CHRCOL, LASTER)
c IF (LASTER .EQ. SUCCESS .AND. CHRCOL .EQ. 2) THEN
c CALL MYCOMP (MYCHAR, VOID, LVOID,
c * NVOIDS, DPOINT, LDICT, NNAMES, CHRCOL, LASTER)
c END IF
laster = SUCCESS
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (LASTER .NE. SUCCESS) THEN
LERROR = LASTER
IF (EUNIT .GT. 0) THEN
CALL MXEROR (EUNIT, LASTER, ERRVEC)
WRITE (EUNIT, *) 'ERROR IN MDCOMP/MCCOMP.'
END IF
END IF
RETURN
C***********************************************************************
ENTRY MCDEBG (UNIT)
ENTRY MDDEBG (UNIT)
C***********************************************************************
IF (UNIT .GE. 1) THEN
EUNIT = UNIT
ELSE
EUNIT = 0
END IF
RETURN
C***********************************************************************
ENTRY MDDEL (TNAME1)
C***********************************************************************
C This entry point deletes an entry from the dictionary and
C inserts an entry in the void table.
NAMET = TNAME1
CALL EXUPCS (NAMET)
CALL STRIPB (NAMET, LEFT, RIGHT)
IF (LEFT .GT. RIGHT) THEN
LASTER = BADNAM
LERROR = LASTER
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'BLANK NAME IN MDDEL.'
RETURN
END IF
NAME1 = NAMET(LEFT:RIGHT)
C Was MDINIT previously called?
IF (.NOT. INIT) THEN
LASTER = NOINIT
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MDINIT WAS NOT CALLED ',
* 'BEFORE CALLING MDDEL.'
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
LERROR = LASTER
RETURN
END IF
CALL MXDEL (NAME1, DICT, DPOINT, LDICT, NNAMES, VOID,
* LVOID, NVOIDS, CHRCOL, LASTER, MYLOC)
if (eunit .gt. 0) then
write (eunit,*) 'MDDEL: ', NAME1
end if
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (LASTER .NE. SUCCESS) THEN
LERROR = LASTER
IF (EUNIT .GT. 0) THEN
CALL MXEROR (EUNIT, LASTER, ERRVEC)
WRITE (EUNIT, *) ' MDDEL ERROR.'
END IF
END IF
RETURN
C***********************************************************************
ENTRY MCDEL (TNAME1)
C***********************************************************************
C This entry point deletes an entry from the dictionary and
C inserts an entry in the void table.
NAMET = TNAME1
CALL EXUPCS (NAMET)
CALL STRIPB (NAMET, LEFT, RIGHT)
IF (LEFT .GT. RIGHT) THEN
LASTER = BADNAM
LERROR = LASTER
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'BLANK NAME IN MCDEL.'
RETURN
END IF
NAME1 = NAMET(LEFT:RIGHT)
C Was MCINIT previously called?
IF (.NOT. CINIT) THEN
LASTER = NOINIT
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MCINIT WAS NOT CALLED ',
* 'BEFORE CALLING MCDEL.'
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
LERROR = LASTER
RETURN
END IF
CALL MYDEL (NAME1, DICT, DPOINT, LDICT, NNAMES, VOID,
* LVOID, NVOIDS, CHRCOL, LASTER, MYLOC, MYCLOC)
if (eunit .gt. 0) then
write (eunit,*) 'MCDEL: ', NAME1
end if
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (LASTER .NE. SUCCESS) THEN
LERROR = LASTER
IF (EUNIT .GT. 0) THEN
CALL MXEROR (EUNIT, LASTER, ERRVEC)
WRITE (EUNIT, *) ' MCDEL ERROR.'
END IF
END IF
RETURN
C***********************************************************************
ENTRY MCEFIX (ENUM, COUNT)
ENTRY MDEFIX (ENUM, COUNT)
C***********************************************************************
C This resets the number of occurrences of a particular error.
C If the requested error number (enum) is out of range, an error
C is flagged.
IF (ENUM .GE. 1 .AND. ENUM .LE. NERVEC) THEN
ERRVEC(ENUM) = COUNT
LASTER = SUCCESS
ELSE
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'ILLEGAL ERROR FLAG NUMBER',
* ' SPECIFIED IN MDEFIX.'
LASTER = BADCOD
END IF
LASTER = SUCCESS
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
RETURN
C***********************************************************************
ENTRY MCEROR (UNIT)
ENTRY MDEROR (UNIT)
C***********************************************************************
C This section prints the error codes.
CALL MXEROR (UNIT, LASTER, ERRVEC)
LASTER = SUCCESS
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
RETURN
C***********************************************************************
ENTRY MCERPT (ENUM, COUNT)
ENTRY MDERPT (ENUM, COUNT)
C***********************************************************************
C This reports the number of occurrences of a particular error.
C If the requested error number (ENUM) is out of range, a -1
C is returned.
IF (ENUM .GE. 1 .AND. ENUM .LE. NERVEC) THEN
COUNT = ERRVEC(ENUM)
ELSE
COUNT = -1
END IF
LASTER = SUCCESS
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
RETURN
C***********************************************************************
ENTRY MCEXEC ()
C***********************************************************************
C Was MCINIT previously called?
IF (.NOT. CINIT) THEN
LASTER = NOINIT
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MCINIT NOT CALLED BEFORE ',
* 'CALLING MCEXEC.'
RETURN
END IF
C***********************************************************************
ENTRY MDEXEC ()
C***********************************************************************
C Was MDINIT previously called?
IF (.NOT. INIT) THEN
LASTER = NOINIT
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MDINIT NOT CALLED BEFORE ',
* 'CALLING MDEXEC.'
RETURN
END IF
C ... Using malloc/free -- ignore MCEXEC/MDEXEC calls.
c CALL MXEXEC (MYV, MYCHAR, MYLOC, MYCLOC, UCLOC, COFFST,
c * OFFSET, DPOINT, LDICT, NNAMES,
c * VOID, LVOID, NVOIDS, FILL, FDATA, CFILL, CFDATA, CHRNUM,
c * CHRCOL, LASTER)
c DEFER = .FALSE.
laster = SUCCESS
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (LASTER .NE. SUCCESS) THEN
LERROR = LASTER
IF (EUNIT .GT. 0) THEN
CALL MXEROR (EUNIT, LASTER, ERRVEC)
WRITE (EUNIT, *) ' MDDOFF ERROR.'
END IF
END IF
RETURN
C***********************************************************************
ENTRY MDFILL (TFILL)
C***********************************************************************
C Was MDINIT previously called?
IF (.NOT. INIT) THEN
LASTER = NOINIT
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MDINIT NOT CALLED BEFORE ',
* 'CALLING MDFILL.'
RETURN
END IF
FDATA = TFILL
FILL = .TRUE.
ERRVEC(SUCCESS) = ERRVEC(SUCCESS) + 1
RETURN
C***********************************************************************
ENTRY MCFILL (TNAME1)
C***********************************************************************
C Was MCINIT previously called?
IF (.NOT. CINIT) THEN
LASTER = NOINIT
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MCINIT NOT CALLED BEFORE ',
* 'CALLING MCFILL.'
RETURN
END IF
IF (LEN(TNAME1) .LT. 1) THEN
LASTER = BADNAM
LERROR = LASTER
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'BAD CHARACTER STRING '//
* 'INPUT TO MCFILL.'
RETURN
END IF
CFDATA = TNAME1(1:1)
CFILL = .TRUE.
ERRVEC(SUCCESS) = ERRVEC(SUCCESS) + 1
RETURN
C***********************************************************************
ENTRY MDFIND (TNAME1, NEWLOC, NEWLEN)
C***********************************************************************
C This section finds a name in the dictionary and returns the
C location and length of that vector.
NAMET = TNAME1
CALL EXUPCS (NAMET)
CALL STRIPB (NAMET, LEFT, RIGHT)
IF (LEFT .GT. RIGHT) THEN
LASTER = BADNAM
LERROR = LASTER
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'BLANK NAME IN MDFIND.'
RETURN
END IF
NAME1 = NAMET(LEFT:RIGHT)
C Was MDINIT previously called?
IF (.NOT. INIT) THEN
LASTER = NOINIT
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MDINIT NOT CALLED BEFORE ',
* 'CALLING MDFIND.'
RETURN
END IF
C Find the name in the dictionary.
CALL MXFIND (NAME1, DICT, DPOINT, LDICT, NNAMES,
* CHRCOL, LASTER, ROW)
IF (LASTER .EQ. SUCCESS) THEN
C Entry was found in dictionary.
IF (DPOINT(ROW,1,2) .LT. 0) THEN
DPOINT(ROW,1,1) = IXLNUM(NEWLOC)
NEWLOC = - ULOC
ELSE
NEWLOC = DPOINT(ROW,1,1) + OFFSET
END IF
NEWLEN = ABS(DPOINT(ROW,1,2))
END IF
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (LASTER .NE. SUCCESS) THEN
LERROR = LASTER
IF (EUNIT .GT. 0) THEN
CALL MXEROR (EUNIT, LASTER, ERRVEC)
WRITE (EUNIT, *) 'NAME ', NAME1, ' MDFIND ERROR.'
END IF
END IF
RETURN
C***********************************************************************
ENTRY MCFIND (TNAME1, NEWLOC, NEWLEN)
C***********************************************************************
C This section finds a name in the dictionary and returns the
C location and length of that vector.
NAMET = TNAME1
CALL EXUPCS (NAMET)
CALL STRIPB (NAMET, LEFT, RIGHT)
IF (LEFT .GT. RIGHT) THEN
LASTER = BADNAM
LERROR = LASTER
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'BLANK NAME IN MCFIND.'
RETURN
END IF
NAME1 = NAMET(LEFT:RIGHT)
C Was MCINIT previously called?
IF (.NOT. CINIT) THEN
LASTER = NOINIT
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MCINIT NOT CALLED BEFORE ',
* 'CALLING MCFIND.'
RETURN
END IF
C Find the name in the dictionary.
CALL MYFIND (NAME1, DICT, DPOINT, LDICT, NNAMES,
* CHRCOL, LASTER, ROW)
IF (LASTER .EQ. SUCCESS) THEN
C Entry was found in dictionary.
IF (DPOINT(ROW,CHRCOL,2) .LT. 0) THEN
DPOINT(ROW,CHRCOL,1) = IXLNUM(NEWLOC)
NEWLOC = - UCLOC
ELSE IF (DPOINT(ROW,CHRCOL,3) .EQ. 0) THEN
NEWLOC = 1
ELSE
NEWLOC = (DPOINT(ROW,1,1) - 1) * CHRNUM + 1 + COFFST
END IF
NEWLEN = DPOINT(ROW,1,3)
END IF
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (LASTER .NE. SUCCESS) THEN
LERROR = LASTER
IF (EUNIT .GT. 0) THEN
CALL MXEROR (EUNIT, LASTER, ERRVEC)
WRITE (EUNIT, *) 'NAME ', NAME1, ' MCFIND ERROR.'
END IF
END IF
RETURN
C***********************************************************************
ENTRY MDFOFF ()
C***********************************************************************
C Was MDINIT previously called?
IF (.NOT. INIT) THEN
LASTER = NOINIT
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MDINIT NOT CALLED BEFORE ',
* 'CALLING MDFOFF.'
RETURN
END IF
FILL = .FALSE.
ERRVEC(SUCCESS) = ERRVEC(SUCCESS) + 1
RETURN
C***********************************************************************
ENTRY MCFOFF ()
C***********************************************************************
C Was MCINIT previously called?
IF (.NOT. CINIT) THEN
LASTER = NOINIT
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MCINIT NOT CALLED BEFORE ',
* 'CALLING MCFOFF.'
RETURN
END IF
CFILL = .FALSE.
ERRVEC(SUCCESS) = ERRVEC(SUCCESS) + 1
RETURN
C***********************************************************************
ENTRY MDGET (MNGET)
C***********************************************************************
C This section processes a request for a contiguous
C chunk of memory.
C If a void of sufficient size is available, no action is taken,
C otherwise a call to the system for the memory is made.
C Was MDINIT previously called?
IF (.NOT. INIT) THEN
LASTER = NOINIT
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MDINIT NOT CALLED BEFORE ',
* 'CALLING MDGET.'
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
LERROR = LASTER
RETURN
END IF
C ... Using malloc/free -- ignore mdget calls.
c CALL MXGET (MYLOC, MNGET, VOID, LVOID, NVOIDS,
c * CHRCOL, LASTER, VROW)
if (eunit .gt. 0) then
write (eunit,*) 'MDGET: ', 0
end if
RETURN
C***********************************************************************
ENTRY MCGET (MNGET)
C***********************************************************************
C This section processes a request for a contiguous
C chunk of memory.
C If a void of sufficient size is available, no action is taken,
C otherwise a call to the system for the memory is made.
C Was MCINIT previously called?
IF (.NOT. CINIT) THEN
LASTER = NOINIT
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MCINIT NOT CALLED BEFORE ',
* 'CALLING MCGET.'
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
LERROR = LASTER
RETURN
END IF
C ... Using malloc/free -- ignore mdget calls.
if (eunit .gt. 0) then
write (eunit,*) 'MCGET: ', 0
end if
RETURN
C***********************************************************************
ENTRY MCGIVE
C***********************************************************************
C This section returns unused space at the end of all storage
C blocks to the system. It does not return character memory
C in split mode.
C Was MCINIT previously called?
IF (.NOT. CINIT) THEN
LASTER = NOINIT
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MCINIT NOT CALLED BEFORE ',
* 'CALLING MCGIVE.'
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
LERROR = LASTER
RETURN
END IF
C***********************************************************************
ENTRY MDGIVE
C***********************************************************************
C This section returns unused space at the end of all storage
C blocks to the system.
C Was MDINIT previously called?
IF (.NOT. INIT) THEN
LASTER = NOINIT
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MDINIT NOT CALLED BEFORE ',
* 'CALLING MDGIVE.'
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
LERROR = LASTER
RETURN
END IF
C ... Using malloc/free -- ignore mcgive/mdgive calls.
c CALL MXGIVE (MYLOC, DPOINT, LDICT, NNAMES, VOID, LVOID,
c * NVOIDS, CHRCOL, LASTER)
RETURN
C***********************************************************************
ENTRY MCLAST (ENUM)
ENTRY MDLAST (ENUM)
C***********************************************************************
ENUM = LERROR
RETURN
C***********************************************************************
ENTRY MCLIST (UNIT)
C***********************************************************************
C This section lists the internal tables of the data manager.
C Was MCINIT previously called?
IF (.NOT. CINIT) THEN
LASTER = NOINIT
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MCINIT NOT CALLED BEFORE ',
* 'CALLING MCLIST.'
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
LERROR = LASTER
RETURN
END IF
C***********************************************************************
ENTRY MDLIST (UNIT)
C***********************************************************************
C This section lists the internal tables of the data manager.
C Was MDINIT previously called?
IF (.NOT. INIT) THEN
LASTER = NOINIT
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MDINIT NOT CALLED BEFORE ',
* 'CALLING MDLIST.'
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
LERROR = LASTER
RETURN
END IF
CALL MXLIST (UNIT, OFFSET, DICT, DPOINT, LDICT, NNAMES,
* VOID, LVOID, NVOIDS, CHRCOL)
if (eunit .gt. 0) then
CALL MXLIST (EUNIT, OFFSET, DICT, DPOINT, LDICT, NNAMES,
* VOID, LVOID, NVOIDS, CHRCOL)
end if
LASTER = SUCCESS
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
RETURN
C***********************************************************************
ENTRY MDFREE ()
C***********************************************************************
C This section frees all memory allocated by supes
C Was MDINIT previously called?
IF (.NOT. INIT) THEN
LASTER = NOINIT
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MDINIT NOT CALLED BEFORE ',
* 'CALLING MDFREE.'
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
LERROR = LASTER
RETURN
END IF
CALL MXFREE (OFFSET, DICT, DPOINT, LDICT, NNAMES, CHRCOL, MYLOC)
LASTER = SUCCESS
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
RETURN
C***********************************************************************
ENTRY MDLONG (TNAME1, NEWLOC, NEWLEN)
C***********************************************************************
C This section expands or shortens a vector.
C Any nonnegative value of newlen is permissible.
NAMET = TNAME1
CALL EXUPCS (NAMET)
CALL STRIPB (NAMET, LEFT, RIGHT)
IF (LEFT .GT. RIGHT) THEN
LASTER = BADNAM
LERROR = LASTER
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'BLANK NAME IN MDLONG.'
RETURN
END IF
NAME1 = NAMET(LEFT:RIGHT)
C Was MDINIT previously called?
IF (.NOT. INIT) THEN
LASTER = NOINIT
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MDINIT NOT CALLED BEFORE ',
* 'CALLING MDLONG.'
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
LERROR = LASTER
RETURN
END IF
C Is the new length sensible?
IF (NEWLEN .LT. 0) THEN
LASTER = BADLEN
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'NEGATIVE LENGTH REQUEST ',
* '(', NEWLEN, ') FOR NAME ', NAME1, ' IN MDLONG.'
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
LERROR = LASTER
RETURN
END IF
C Ensure that the amount of space called for is even --- this
C guarantees that the memory will align on an eight byte boundary.
C (this is only a quick fix for the HP750 --- jrr 10/25/91)
dummy = mod( newlen, 2 )
if ( dummy .ne. 0 ) then
junk = newlen + ( 2 - dummy )
else
junk = newlen
endif
#ifdef SDP
INUM = junk
#else
INUM = newlen
#endif
CALL MXLONG (NAME1, INUM, NEWLOC, MYV, MYCHAR, MYLOC,
* MYCLOC, UCLOC, COFFST, OFFSET,
* DICT, DPOINT, LDICT, NNAMES, VOID, LVOID, NVOIDS,
* FILL, FDATA, CFILL, CFDATA, CHRNUM, CHRCOL, LASTER)
if (eunit .gt. 0) then
write (eunit,*) 'MDLONG: ', NAME1, INUM, newloc
end if
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (LASTER .NE. SUCCESS) THEN
LERROR = LASTER
IF (EUNIT .GT. 0) THEN
CALL MXEROR (EUNIT, LASTER, ERRVEC)
WRITE (EUNIT, *) ' MDLONG ERROR.'
END IF
END IF
RETURN
C***********************************************************************
ENTRY MCLONG (TNAME1, NEWLOC, NEWLEN)
C***********************************************************************
C This section expands or shortens a vector.
C Any nonnegative value of newlen is permissible.
NAMET = TNAME1
CALL EXUPCS (NAMET)
CALL STRIPB (NAMET, LEFT, RIGHT)
IF (LEFT .GT. RIGHT) THEN
LASTER = BADNAM
LERROR = LASTER
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'BLANK NAME IN MCLONG.'
RETURN
END IF
NAME1 = NAMET(LEFT:RIGHT)
C Was MCINIT previously called?
IF (.NOT. CINIT) THEN
LASTER = NOINIT
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MCINIT NOT CALLED BEFORE ',
* 'CALLING MCLONG.'
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
LERROR = LASTER
RETURN
END IF
C Is the new length sensible?
IF (NEWLEN .LT. 0) THEN
LASTER = BADLEN
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'NEGATIVE LENGTH REQUEST ',
* '(', NEWLEN, ') FOR NAME ', NAME1, ' IN MCLONG.'
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
LERROR = LASTER
RETURN
END IF
C Ensure that the amount of space called for is a multiple of eight
c ---this guarantees that the memory will align on an eight byte boundary.
C (this is only a quick fix for the HP750 --- jrr 10/25/91)
dummy = mod( newlen, 8 )
if ( dummy .ne. 0 ) then
junk = newlen + ( 8 - dummy )
else
junk = newlen
endif
#ifdef SDP
INUM = junk
#else
INUM = newlen
#endif
CALL MYLONG (NAME1, INUM, NEWLOC, MYV, MYCHAR, MYLOC,
* MYCLOC, UCLOC, COFFST, OFFSET,
* DICT, DPOINT, LDICT, NNAMES, VOID, LVOID, NVOIDS,
* FILL, FDATA, CFILL, CFDATA, CHRNUM, CHRCOL, MAXSIZ, LASTER)
if (eunit .gt. 0) then
write (eunit,*) 'MCLONG: ', NAME1, INUM, newloc
end if
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (LASTER .NE. SUCCESS) THEN
LERROR = LASTER
IF (EUNIT .GT. 0) THEN
CALL MXEROR (EUNIT, LASTER, ERRVEC)
WRITE (EUNIT, *) ' MCLONG ERROR.'
END IF
END IF
RETURN
C***********************************************************************
ENTRY MDMEMS (NSUA, NSUD, NSUV, NSULV)
C***********************************************************************
C This section returns:
C NSUA Number of numeric storage units allocated
C NSUD Number of numeric storage units deferred
C NSUV Number of numeric storage units in voids
C NSULV Number of numeric storage units in largest void
C Was MDINIT previously called?
IF (.NOT. INIT) THEN
LASTER = NOINIT
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MDINIT NOT CALLED BEFORE ',
* 'CALLING MDMEMS.'
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
LERROR = LASTER
RETURN
END IF
NSUA = 0
NSUD = 0
NSUV = 0
NSULV= 0
DO 100 I = 1, NNAMES(1)
IF (DPOINT(I,1,3) .EQ. -1) THEN
NSUA = NSUA + MAX(DPOINT(I,1,2),0)
NSUD = NSUD + MIN(DPOINT(I,1,2),0)
END IF
100 CONTINUE
DO 110 I = 1, NVOIDS(1)
NSUV = NSUV + VOID(I,1,2)
NSULV = MAX ( NSULV, VOID(I,1,2) )
110 CONTINUE
LASTER = SUCCESS
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
RETURN
C***********************************************************************
ENTRY MCMEMS (NSUA, NSUD, NSUV, NSULV)
C***********************************************************************
C This section returns:
C NSUA Number of character storage units allocated
C NSUD Number of character storage units deferred
C NSUV Number of character storage units in voids
C NSULV Number of character storage units in largest void
C Was MDINIT previously called?
IF (.NOT. INIT) THEN
LASTER = NOINIT
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MDINIT NOT CALLED BEFORE ',
* 'CALLING MCMEMS.'
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
LERROR = LASTER
RETURN
END IF
NSUA = 0
NSUD = 0
NSUV = 0
NSULV= 0
DO 120 I = 1, NNAMES(CHRCOL)
IF (DPOINT(I,CHRCOL,3) .GE. 0) THEN
IF (DPOINT(I,CHRCOL,2) .GE. 0) THEN
NSUA = NSUA + DPOINT(I,CHRCOL,3)
ELSE
NSUD = NSUD + DPOINT(I,CHRCOL,3)
END IF
END IF
120 CONTINUE
DO 130 I = 1, NVOIDS(CHRCOL)
NSUV = NSUV + VOID(I,CHRCOL,2)
NSULV = MAX ( NSULV, VOID(I,CHRCOL,2) )
130 CONTINUE
NSUV = NSUV * CHRNUM
NSULV = NSULV * CHRNUM
LASTER = SUCCESS
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
RETURN
C***********************************************************************
ENTRY MDNAME (TNAME1, TNAME2)
C***********************************************************************
C This section renames an array from NAME1 to NAME2.
NAMET = TNAME1
CALL EXUPCS (NAMET)
CALL STRIPB (NAMET, LEFT, RIGHT)
IF (LEFT .GT. RIGHT) THEN
LASTER = BADNAM
LERROR = LASTER
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'BLANK NAME IN MDNAME.'
RETURN
END IF
NAME1 = NAMET(LEFT:RIGHT)
NAMET = TNAME2
CALL EXUPCS (NAMET)
CALL STRIPB (NAMET, LEFT, RIGHT)
IF (LEFT .GT. RIGHT) THEN
LASTER = BADNAM
LERROR = LASTER
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'BLANK NAME IN MDNAME.'
RETURN
END IF
NAME2 = NAMET(LEFT:RIGHT)
C Was MDINIT previously called?
IF (.NOT. INIT) THEN
LASTER = NOINIT
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MDINIT NOT CALLED BEFORE ',
* 'CALLING MDNAME.'
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
LERROR = LASTER
RETURN
END IF
C Find NAME1 in dictionary.
CALL MXFIND (NAME1, DICT, DPOINT, LDICT, NNAMES,
* CHRCOL, LASTER, ROW)
IF (LASTER .EQ. SUCCESS) THEN
LOC = DPOINT(ROW,1,1)
LEN1 = DPOINT(ROW,1,2)
C Delete dictionary entry.
CALL SHFTC (DICT, CHRCOL*LDICT, ROW+1, NNAMES(1), 1)
CALL SHFTI (DPOINT, LDICT*CHRCOL, 3, ROW+1, NNAMES(1), 1)
NNAMES(1) = NNAMES(1) - 1
C insert NAME2 with old pointer and length.
CALL MXNSRT (NAME2, LOC, LEN1, DICT, DPOINT, LDICT,
* NNAMES, CHRCOL, LASTER)
IF (LASTER .NE. SUCCESS) THEN
CALL MXNSRT (NAME1, LOC, LEN1, DICT, DPOINT, LDICT,
* NNAMES, CHRCOL, TMP)
END IF
END IF
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (LASTER .NE. SUCCESS) THEN
LERROR = LASTER
IF (EUNIT .GT. 0) THEN
CALL MXEROR (EUNIT, LASTER, ERRVEC)
WRITE (EUNIT, *)
* ' MDNAME ERROR.', ' FROM: ', NAME1, ' TO: ', NAME2
END IF
END IF
RETURN
C***********************************************************************
ENTRY MCNAME (TNAME1, TNAME2)
C***********************************************************************
C This section renames an array from NAME1 to NAME2.
NAMET = TNAME1
CALL EXUPCS (NAMET)
CALL STRIPB (NAMET, LEFT, RIGHT)
IF (LEFT .GT. RIGHT) THEN
LASTER = BADNAM
LERROR = LASTER
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'BLANK NAME IN MCNAME.'
RETURN
END IF
NAME1 = NAMET(LEFT:RIGHT)
NAMET = TNAME2
CALL EXUPCS (NAMET)
CALL STRIPB (NAMET, LEFT, RIGHT)
IF (LEFT .GT. RIGHT) THEN
LASTER = BADNAM
LERROR = LASTER
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'BLANK NAME IN MCNAME.'
RETURN
END IF
NAME2 = NAMET(LEFT:RIGHT)
C Was MCINIT previously called?
IF (.NOT. CINIT) THEN
LASTER = NOINIT
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MCINIT NOT CALLED BEFORE ',
* 'CALLING MCNAME.'
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
LERROR = LASTER
RETURN
END IF
C Find NAME1 in dictionary.
CALL MYFIND (NAME1, DICT, DPOINT, LDICT, NNAMES,
* CHRCOL, LASTER, ROW)
IF (LASTER .EQ. SUCCESS) THEN
LOC = DPOINT(ROW,CHRCOL,1)
LEN1 = DPOINT(ROW,CHRCOL,2)
LEN2 = DPOINT(ROW,CHRCOL,3)
C Delete dictionary entry.
CALL SHFTC (DICT(1,CHRCOL), CHRCOL*LDICT, ROW+1,
* NNAMES(CHRCOL), 1)
CALL SHFTI (DPOINT(1,CHRCOL,1), LDICT*CHRCOL, 3, ROW+1,
* NNAMES(CHRCOL), 1)
NNAMES(CHRCOL) = NNAMES(CHRCOL) - 1
C insert NAME2 with old pointer and length.
CALL MYNSRT (NAME2, LOC, LEN1, LEN2, DICT, DPOINT, LDICT,
* NNAMES, CHRCOL, LASTER)
IF (LASTER .NE. SUCCESS) THEN
CALL MYNSRT (NAME1, LOC, LEN1, LEN2, DICT, DPOINT, LDICT,
* NNAMES, CHRCOL, TMP)
END IF
END IF
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (LASTER .NE. SUCCESS) THEN
LERROR = LASTER
IF (EUNIT .GT. 0) THEN
CALL MXEROR (EUNIT, LASTER, ERRVEC)
WRITE (EUNIT, *)
* ' MCNAME ERROR.', ' FROM: ', NAME1, ' TO: ', NAME2
END IF
END IF
RETURN
C***********************************************************************
ENTRY MDPRNT (TNAME1, UNIT, TNAME2)
C***********************************************************************
C This section prints a named vector as integer or real, as
C indicated by NAME2.
NAMET = TNAME1
CALL EXUPCS (NAMET)
CALL STRIPB (NAMET, LEFT, RIGHT)
IF (LEFT .GT. RIGHT) THEN
LASTER = BADNAM
LERROR = LASTER
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'BLANK NAME IN MDPRNT.'
RETURN
END IF
NAME1 = NAMET(LEFT:RIGHT)
NAMET = TNAME2
CALL EXUPCS (NAMET)
CALL STRIPB (NAMET, LEFT, RIGHT)
IF (LEFT .GT. RIGHT) THEN
LASTER = BADNAM
LERROR = LASTER
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'BLANK DATA TYPE IN MDPRNT.'
RETURN
END IF
NAME2 = NAMET(LEFT:RIGHT)
C Was MDINIT previously called?
IF (.NOT. INIT) THEN
LASTER = NOINIT
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MDINIT NOT CALLED BEFORE ',
* 'CALLING MDPRNT.'
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
LERROR = LASTER
RETURN
END IF
CALL MXPRNT (NAME1, UNIT, NAME2, MYV, RMYV, OFFSET,
* DICT, DPOINT, LDICT, NNAMES, CHRCOL, NCOLP, LASTER)
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (LASTER .NE. SUCCESS) THEN
LERROR = LASTER
IF (EUNIT .GT. 0) THEN
CALL MXEROR (EUNIT, LASTER, ERRVEC)
WRITE (EUNIT, *) ' MDPRNT ERROR.'
END IF
END IF
RETURN
C***********************************************************************
ENTRY MCPRNT (TNAME1, UNIT, NEWLEN)
C***********************************************************************
C This section prints a named vector as character.
NAMET = TNAME1
CALL EXUPCS (NAMET)
CALL STRIPB (NAMET, LEFT, RIGHT)
IF (LEFT .GT. RIGHT) THEN
LASTER = BADNAM
LERROR = LASTER
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'BLANK NAME IN MCPRNT.'
RETURN
END IF
NAME1 = NAMET(LEFT:RIGHT)
C Was MCINIT previously called?
IF (.NOT. CINIT) THEN
LASTER = NOINIT
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MCINIT NOT CALLED BEFORE ',
* 'CALLING MCPRNT.'
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
LERROR = LASTER
RETURN
END IF
CALL MYPRNT (NAME1, UNIT, MYCHAR, COFFST, COFFST+UCLOC-MYCLOC,
* DICT, DPOINT, LDICT, NNAMES, CHRNUM,
* CHRCOL, NCOLP, NEWLEN, LASTER)
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (LASTER .NE. SUCCESS) THEN
LERROR = LASTER
IF (EUNIT .GT. 0) THEN
CALL MXEROR (EUNIT, LASTER, ERRVEC)
WRITE (EUNIT, *) ' MCPRNT ERROR.'
END IF
END IF
RETURN
C***********************************************************************
ENTRY MDRSRV (TNAME1, NEWLOC, NEWLEN)
C***********************************************************************
C This section reserves space for an array. If a void is not
C available, a system call will be made for the space. Any
C nonnegative request is permissible.
NAMET = TNAME1
CALL EXUPCS (NAMET)
CALL STRIPB (NAMET, LEFT, RIGHT)
IF (LEFT .GT. RIGHT) THEN
LASTER = BADNAM
LERROR = LASTER
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'BLANK NAME IN MDRSRV.'
RETURN
END IF
NAME1 = NAMET(LEFT:RIGHT)
C Was MDINIT previously called?
IF (.NOT. INIT) THEN
LASTER = NOINIT
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MDINIT NOT CALLED BEFORE ',
* 'CALLING MDRSRV.'
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
LERROR = LASTER
RETURN
END IF
C Check for sensible length.
IF (NEWLEN .LT. 0) THEN
LASTER = BADLEN
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'NEGATIVE LENGTH REQUEST ',
* '(', NEWLEN, ') FOR NAME ', NAME1, ' IN MDRSRV.'
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
LERROR = LASTER
RETURN
END IF
C Ensure that the amount of space called for is even --- this
C guarantees that the memory will align on an eight byte boundary.
C (this is only a quick fix for the HP750 --- jrr 10/25/91)
dummy = mod( newlen, 2 )
if ( dummy .ne. 0 ) then
junk = newlen + ( 2 - dummy )
else
junk = newlen
endif
#ifdef SDP
INUM = junk
#else
INUM = newlen
#endif
CALL MXRSRV (MYV, NAME1, INUM, NEWLOC, MYLOC, OFFSET,
* VOID, LVOID, NVOIDS,
* DICT, DPOINT, LDICT, NNAMES, CHRCOL, DEFER, FILL, FDATA,
* LASTER)
if (eunit .gt. 0) then
write (eunit,*) 'MDRSRV: ', NAME1, INUM, newloc
end if
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (LASTER .NE. SUCCESS) THEN
LERROR = LASTER
IF (EUNIT .GT. 0) THEN
CALL MXEROR (EUNIT, LASTER, ERRVEC)
WRITE (EUNIT, *) ' MDRSRV ERROR.'
END IF
END IF
RETURN
C***********************************************************************
ENTRY MCRSRV (TNAME1, NEWLOC, NEWLEN)
C***********************************************************************
C This section reserves space for an array. If a void is not
C available, a system call will be made for the space. Any
C nonnegative request is permissible.
NAMET = TNAME1
CALL EXUPCS (NAMET)
CALL STRIPB (NAMET, LEFT, RIGHT)
IF (LEFT .GT. RIGHT) THEN
LASTER = BADNAM
LERROR = LASTER
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'BLANK NAME IN MCRSRV.'
RETURN
END IF
NAME1 = NAMET(LEFT:RIGHT)
C Was MCINIT previously called?
IF (.NOT. CINIT) THEN
LASTER = NOINIT
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MCINIT NOT CALLED BEFORE ',
* 'CALLING MCRSRV.'
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
LERROR = LASTER
RETURN
END IF
C Check for sensible length.
IF (NEWLEN .LT. 0) THEN
LASTER = BADLEN
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'NEGATIVE LENGTH REQUEST ',
* '(', NEWLEN, ') FOR NAME ', NAME1, ' IN MCRSRV.'
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
LERROR = LASTER
RETURN
END IF
C Ensure that the amount of space called for is a multiple of eight
c ---this guarantees that the memory will align on an eight byte boundary.
C (this is only a quick fix for the HP750 --- jrr 10/25/91)
dummy = mod( newlen, 8 )
if ( dummy .ne. 0 ) then
junk = newlen + ( 8 - dummy )
else
junk = newlen
endif
#ifdef SDP
INUM = junk
#else
INUM = newlen
#endif
CALL MYRSRV (MYCHAR, NAME1, INUM, NEWLOC, MYLOC, MYCLOC,
* UCLOC, OFFSET, COFFST,
* VOID, LVOID, NVOIDS,
* DICT, DPOINT, LDICT, NNAMES, CHRCOL, CHRNUM, DEFER,
* CFILL, CFDATA, MAXSIZ,
* LASTER)
if (eunit .gt. 0) then
write (eunit,*) 'MCRSRV: ', NAME1, INUM, newloc
end if
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (LASTER .NE. SUCCESS) THEN
LERROR = LASTER
IF (EUNIT .GT. 0) THEN
CALL MXEROR (EUNIT, LASTER, ERRVEC)
WRITE (EUNIT, *) ' MCRSRV ERROR.'
END IF
END IF
RETURN
C***********************************************************************
ENTRY MDSTAT (MNERRS, MNUSED)
C***********************************************************************
C This section returns the total number of errors and the total
C amount of numeric storage assigned to arrays.
ERRVEC(SUCCESS) = ERRVEC(SUCCESS) + 1
MNERRS = 0
DO 140 I = 2, NERVEC
MNERRS = MNERRS + ERRVEC(I)
140 CONTINUE
MNUSED = 0
DO 150 I = 1, NNAMES(1)
IF (DPOINT(I,1,3) .EQ. -1) THEN
MNUSED = MNUSED + ABS(DPOINT(I,1,2))
END IF
150 CONTINUE
if (eunit .gt. 0) then
write (eunit,*) 'MDSTAT: ',MNERRS, MNUSED
end if
RETURN
C***********************************************************************
ENTRY MCSTAT (MNERRS, MNUSED)
C***********************************************************************
C This section returns the total number of errors and the total
C amount of character storage assigned to arrays.
ERRVEC(SUCCESS) = ERRVEC(SUCCESS) + 1
MNERRS = 0
DO 160 I = 2, NERVEC
MNERRS = MNERRS + ERRVEC(I)
160 CONTINUE
MNUSED = 0
DO 170 I = 1, NNAMES(CHRCOL)
MNUSED = MNUSED + MAX (0, DPOINT(I,CHRCOL,3))
170 CONTINUE
if (eunit .gt. 0) then
write (eunit, *) 'MCSTAT: ', MNERRS, MNUSED
end if
RETURN
C***********************************************************************
ENTRY MCWAIT ()
C Was MCINIT previously called?
IF (.NOT. CINIT) THEN
LASTER = NOINIT
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MCINIT NOT CALLED BEFORE ',
* 'CALLING MCWAIT.'
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
LERROR = LASTER
RETURN
END IF
ENTRY MDWAIT ()
C***********************************************************************
C Was MDINIT previously called?
IF (.NOT. INIT) THEN
LASTER = NOINIT
ERRVEC(LASTER) = ERRVEC(LASTER) + 1
IF (EUNIT .GT. 0) WRITE (EUNIT, *) 'MDINIT NOT CALLED BEFORE ',
* 'CALLING MDWAIT.'
RETURN
END IF
IF (DEFROK) DEFER = .TRUE.
ERRVEC(SUCCESS) = ERRVEC(SUCCESS) + 1
RETURN
END