/*===========================================================================
  Copyright (C) 1995-2010 European Southern Observatory (ESO)
 
  This program is free software; you can redistribute it and/or 
  modify it under the terms of the GNU General Public License as 
  published by the Free Software Foundation; either version 2 of 
  the License, or (at your option) any later version.
 
  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.
 
  You should have received a copy of the GNU General Public 
  License along with this program; if not, write to the Free 
  Software Foundation, Inc., 675 Massachusetts Ave, Cambridge, 
  MA 02139, USA.
 
  Correspondence concerning ESO-MIDAS should be addressed as follows:
	Internet e-mail: midas@eso.org
	Postal address: European Southern Observatory
			Data Management Division 
			Karl-Schwarzschild-Strasse 2
			D 85748 Garching bei Muenchen 
			GERMANY
===========================================================================*/

/*++++++++++++++++++++++++ MIDAS monitor routines PREPD +++++++++++++++++++++++
.LANGUAGE  C
.IDENTIFICATION  Module PREPD
.AUTHOR  K. Banse			ESO - Garching
.ENVIRONMENT  VMS and UNIX
.KEYWORDS
  MIDAS monitor, processing of operands
.COMMENTS
  holds EVALU, KEYFUNC, Replace_it, REPLACE, REPFORM, KEY_ACCESS, GETOP
.VERSION  [1.00]  870720: from FORTRAN version as of 870414

 101021			last modif
---------------------------------------------------------------------------*/
 
#include <fcntl.h>
#include <fileexts.h>
 
#include <osyparms.h>
#include <monitdef.h>
#include <midback.h>
#include <fsydef.h>

#include <string.h>
#include <stdlib.h>


#define  BIT_0 0x1

extern char DATA_PATH[328];

size_t   sdum;

/*

*/
 
int EVALU(nt)
 
/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
Evaluate the logical expression stored in TOKEN[nt] - [nt+2] and return
with 0 = .false. and 1 = .true. or -1 if something went wrong...
TOKEN[nt] - [nt+2]: A op B, where op =  == ,  != ,  > ,  >= ,  <  or  <=
TOKEN[nt],[nt+2] consist of variables (ASCII string, ASCII constants - i.e. 1
or numerical constants of type integer or real
.ALGORITHM
cumbersome, but straight forward
.RETURNS
0, if false - 1, if true
-1, if something wrong
-----------------------------------------------------------------*/
 
int   nt	/* IN: no. of token, where expression starts  */;
 
{	
int   ibuf1, ibuf2;
int   retval, n, nnt, noff;
register int nr;
int   iop1=0, iop2=0;
	
float	rbuf1, rbuf2;
float	rop1=0., rop2=0.;
	
double	dbuf1, dbuf2;
double	dop1=0., dop2=0.;
 
char	*cop1, *cop2;
char	type[12], typ1, typ2, restype;
char    wbuf[2048];
register char cc;
static char   opcode[13] = "EQNEGTGELTLE" ;
static char   invcode[13] = "NEEQLELTGEGT";
	

 
cop1 = wbuf;		/* handle 1. operand  */
 
if ( (TOKEN[nt].STR[1] == '$') &&		/*  check for MIDAS function  */
     ((TOKEN[nt].STR[0] == 'm') || (TOKEN[nt].STR[0] == 'M')) )
   {
   n = TOKEN[nt].LEN - 2;
   noff = 1024;
   KEYFUNC(&TOKEN[nt].STR[2],n,&ibuf1,&rbuf1,cop1,&dbuf1,&noff,type);
   if (type[0] == ' ')			/* try to compute ... */
      {
      if (KEYCOMP(1,nt,type) != 0) type[0] = ' ';
      if (type[0] == 'I')
         ibuf1 = KAUX.IVAL;
      else if (type[0] == 'R')
         rbuf1 = KAUX.RVAL;
      else if (type[0] == 'D')
         dbuf1 = KAUX.DVAL;
      }
   }
else
   GETOP(TOKEN[nt].STR,TOKEN[nt].LEN,&ibuf1,&rbuf1,cop1,&dbuf1,&sdum,type,1024);

if (type[0] == ' ')
   {
   ERRORS.INDEX = nt;
   goto badeval;
   }
typ1 = type[0];
 
 
cop2 = &wbuf[1024];		/*  handle 2. operand  */
nnt = nt + 2;
if ( (TOKEN[nnt].STR[1] == '$') &&            /*  check for MIDAS function  */
     ((TOKEN[nnt].STR[0] == 'm') || (TOKEN[nnt].STR[0] == 'M')) )
   {
   n = TOKEN[nnt].LEN - 2;
   noff = 1024;
   KEYFUNC(&TOKEN[nnt].STR[2],n,&ibuf2,&rbuf2,cop2,&dbuf2,&noff,type);
   if (type[0] == ' ')                  /* try to compute ... */
      {
      if (KEYCOMP(1,nnt,type) != 0) type[0] = ' ';
      if (type[0] == 'I')
         ibuf2 = KAUX.IVAL;
      else if (type[0] == 'R')
         rbuf2 = KAUX.RVAL;
      else if (type[0] == 'D')
         dbuf2 = KAUX.DVAL;
      }
   }
else
   GETOP(TOKEN[nnt].STR,TOKEN[nnt].LEN,&ibuf2,&rbuf2,cop2,&dbuf2,&sdum,type,1024);

if (type[0] == ' ')
   {
   ERRORS.INDEX = nnt;
   goto badeval;
   }
typ2 = type[0];
	
 
/* maximize type + adjust operands to highest type  */
 
if ((typ1 == 'C') || (typ2 == 'C'))
   {
   if (typ1 != typ2)
      {
      ERRORS.INDEX = nnt;
      goto badeval; 		/* we only allow typ1//typ2 = CC  */
      }
   restype = 'C';
   CGN_UPSTR(cop1);		/* convert to upper case  */
   CGN_UPSTR(cop2);
   goto sect_3500;		/* character stuff is handled elsewhere  */
   }
	
 
/* 1. operand = integer  */
 
if (typ1 == 'I')
   {
   if (typ2 == 'R')
      {
      rop1 = (float) ibuf1;
      rop2 = rbuf2;
      }
   else if (typ2 == 'D')
      {
      dop1 = (double) ibuf1;
      dop2 = dbuf2;
      }
   else
      {
      iop1 = ibuf1;
      iop2 = ibuf2;
      }
 
   restype = typ2;
   }
 
/* 1. operand = real  */
 
else if (typ1 == 'R')
   {
   if (typ2 == 'I')
      {
      rop1 = rbuf1;
      rop2 = (float) ibuf2;
      restype = typ1;
      }
   else if (typ2 == 'D')
      {
      dop1 = (double) rbuf1;
      dop2 = dbuf2;
      restype = typ2;
      }
   else
      {
      rop1 = rbuf1;
      rop2 = rbuf2;
      restype = typ1;
      }
   }
	
/* 1. operand = double prec.  */
 
else
   {
   dop1 = dbuf1;			/* double prec. is highest type...  */
   restype = 'D';
   if (typ2 == 'I')
      dop2 = (double) ibuf2;
   else if (typ2 == 'R')
      dop2 = (double) rbuf2;
   else
      dop2 = dbuf2;
   }
 
	
/*   now do the actual operation  */
 
sect_3500:
 
noff = 0;				/* default to .EQ. */
retval = 1;

nnt = nt + 1;
cc = TOKEN[nnt].STR[1];
if (cc == 'G')
   {
   noff = 1;
   if (TOKEN[nnt].STR[2] == 'E') noff = 2;
   }
else if (cc == 'L')
   {
   retval = 0;
   noff = 1;
   if (TOKEN[nnt].STR[2] == 'T') noff = 2;
   }
else if (cc == 'N')
   retval = 0;

	
/* now handle the different cases (switched via 'noff')  */
 

switch(noff)
   {
   case 0:			   /*  handle .EQ. + .NE. */
    if (restype == 'I') 
       {
       if (iop1 == iop2) return (retval);
       }
    else if (restype == 'R') 
       {
       if (rop1 == rop2) return (retval);
       }
    else if (restype == 'D') 
       {
       if (dop1 == dop2) return (retval);
       }
    else 
       if (strcmp(cop1,cop2) == 0) return (retval);
    break;
 
   case 1:			/*  handle  .GT. + .LE.  */
    if (restype == 'I') 
       {
       if (iop1 > iop2) return (retval);
       }
    else if (restype == 'R') 
       {
       if (rop1 > rop2) return (retval);
       }
    else if (restype == 'D') 
       {
       if (dop1 > dop2) return (retval);
       }
    else 
       if (strcmp(cop1,cop2) > 0) return (retval);
    break;

   case 2:			/*  handle  .GE. + .LT.  */
    if (restype == 'I') 
       {
       if (iop1 >= iop2) return (retval);
       }
    else if (restype == 'R') 
       {
       if (rop1 >= rop2) return (retval);
       }
    else if (restype == 'D') 
       {
       if (dop1 >= dop2) return (retval);
       }
    else 
       if (strcmp(cop1,cop2) >= 0) return (retval);
    break;
 
   default:
    break;
   }			

return (1-retval);			/*  1/0 => 0/1  */


badeval:
(void) strcpy(LINE.STR,"IF ");		/* rebuild original command */
(void) strcat(LINE.STR,TOKEN[nt].STR);
n = (int)strlen(LINE.STR);
LINE.STR[n++] = ' ';
nnt = nt + 1;
for (nr=0; nr<12; nr+=2)                /* loop through possible codes  */
   {
   if ((TOKEN[nnt].STR[1] == opcode[nr])&&(TOKEN[nnt].STR[2] == opcode[nr+1]))
      {
      TOKEN[nnt].STR[1] = invcode[nr++];
      TOKEN[nnt].STR[2] = invcode[nr];
      break;                         
      }
   }
(void) strcpy(&LINE.STR[n],TOKEN[nnt++].STR);
n = (int)strlen(LINE.STR);
LINE.STR[n++] = ' ';
(void) strcpy(&LINE.STR[n],TOKEN[nnt].STR);
return (-1);
}
/*

*/
 
void KEYFUNC(parm,lparm,ires,rres,cres,dres,crlen,restype)
 
/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  calculate functions of the form M$FUNC(OPA,OPB,...)
  Note, that all 2-args functions have also to be added to KEXP_CLEAN !!
.ALGORITHM
  test function, extract operands + evaluate function, determine type of result
  currently support functions are:
  M$ABS(op1) - op1 either integer or real value, result same type
  M$AGL(op1) - op1 char., result will be character string from agldevs.dat
  M$EXIST(op1) - op1 char., result integer, test if file 'op1' exists or not
  M$EXISTK(op1) - op1 char., result integer, test if key 'op1' exists or not
  M$EXISTD(op1,op2) - op1 char., op2 char., result integer,
	               test if descriptor 'op2' of file 'op1' exists or not
  M$EXISTC(op1,op2) - op1 char., op2 char., result integer,
	               test if column 'op2' of table 'op1' exists or not
  M$FILTYP(op1,op2) - op1 ch., op2 ch. = default file type if op1 without it;
                      result integer, = 1, if p1 is an image
  		     		      = 2, if p1 is a table
  		     		      = 0, else
  M$FTSET(op1) - op1 char. - result integer: 1 if filetype given, else 0
  M$INDEX(op1,op2) - op1, op2 either char. key or char. constant (i.e. "abcd")
                  result will be integer, emulates the FORTRAN INDEX function
  M$INDEXB(op1,op2) - as M$INDEX but starting from the back of the string
  M$ISODATE() - result is current time in ISO 8601 format
  M$LEN(op1) - op1 char., result integer, get length of op1 using a blank as
               delimiter
  M$LN, EXP, LOG10, EXP10, SIN, COS, TAN, 
        SQRT, ASIN, ACOS, ATAN(op1) - the usual mathematical functions...
  M$LOWER(op1) - op1 char., result will be op1 in lowercase
  M$NINT(op1) - op1 real or double, result integer
  M$PARSE(op1,op2) - op1 char., op2 char. parse 'op1' and fill keys 
                     'op2'01,'op2'02,.. and 'op2'no
  M$SECS() - result will be seconds since 1. Jan 1970 (as long int)
  M$STRCMP(op1,op2) - compare op1 char.with op2 char., return integer like
		      from strcmp(c1,c2)
  M$STRLEN(op1) - op1 char., result integer, get string length of op1 including 
                 blanks
  M$SYMBOL(op1) - op1 char., result char., get DCL symbol
  M$SYSTEM(op1) - op1 char., execute host command `op1'
                  result is integer status of host system
  M$UPPER(op1) - op1 char., result will be op1 in uppercase
  M$TIME() - result is char. string containing current time
  M$TIME(op1) - op1 = 1, result contains current date as yyyy-mm-dd
                op1 = -1, result contains yesterday's date as yyyy-mm-dd
  M$TSTNO(op1) - op1 char., result integer, test if op1 is a number or not
  M$VALUE(op1,op2,op3) - get value of:
			 image pixel, descr value, or table element
  M$TNULL(op1,op2,op3) - return 1, if table element is NULL, else return 0
			 same info is also stored in keyword MID$INFO(8)

----------------------------------------------------------------*/
 
char   *parm;		/* IN: points to function     
                      	       leading M$ already stripped off  */
int    lparm;		/* IN: length of 'parm'  */
int    *ires;		/* OUT: integer result  */
float  *rres;		/* OUT: real result  */
char   *cres;		/* OUT: char. result  */
double *dres;		/* OUT: double prec. result  */
int    *crlen;		/* IN/OUT: max. length of `cres' (IN) 
				   actual length of cres (OUT) */
char   *restype;	/* OUT: type of result = I, R, C or D or ' ' = bad! */

 
{
#define  MAX_FUNCT  35

int   imno, stat, l1, l2, m, n, n1, n2, nbra, fno;
int   fp, ibuf[5], unit;
register int nr;

char	savchar, gettype[12], func[7], *c1, *c2, *tp;
char    wbuf[2048], htext[72];
 
/* 2-arg, 3-arg functions have to be synchronized with KEXP_CLEAN (prepg.c)! */

static char   *midfunc[MAX_FUNCT] = 
			{ "VALUE", "INDEX", "TIME", "ABS", "NINT",
			  "TSTNO", "EXIST", "LEN", "SYMBO", "LN", 
			  "LOG10", "EXP", "EXP10", "SIN", "COS", 
			  "TAN", "SQRT", "ASIN", "ACOS", "ATAN",
			  "LOG", "UPPER", "LOWER", "SECS", "AGL",
			  "FILTY","PARSE","FTSET","STRLE", "STRCM",
			  "ISODA", "TRIM", "REPLA", "SYSTE", "TNULL" };
	
struct FCB_STRUCT  *fcbp;

struct FCT_STRUCT  *fctpntr;



 
*restype = ' ';					/* init to failure...  */
c1 = wbuf;
c2 = &wbuf[1024];
 
m = CGN_INDEXC(parm,'(');
if ( (m <= 0) || (m > 7) ) return;

if (m > 5) m = 5;
CGN_UPCOPY(func,parm,m);			/* isolate function name */
func[m] = '\0';
 
	
/*  compare with existing functions  */

for (nbra=0; nbra<9; nbra++)
   {
   if (strcmp(func,midfunc[nbra]) == 0)
      goto sect_1000;
   }

for (nbra=9; nbra<21; nbra++)
   {
   if (strcmp(func,midfunc[nbra]) == 0)
      goto sect_2000;
   }

m = MAX_FUNCT - 1; 
for (nbra=21; nbra<m; nbra++)
   {
   if (strcmp(func,midfunc[nbra]) == 0)
      goto sect_3000;
   }

/* so it must be the last function,  TNULL(table,col,row),
   a wrapper around VALUE(table,col,row) 
   which returns 1 if table element is NULL, otherwise 0 */

nbra = MAX_FUNCT - 1;		/* handle like VALUE(table,col,row) */

sect_1000:
switch(nbra)
   {	
 
case 0:    /*  handle VALUE(oper1[,oper2[,oper3]]) */
case 34:   /*  handle TNULL(oper1,oper2,oper3) */

   KIWORDS[OFF_INFO+7] = nbra;		/* so TABLE_ACCESS knows its caller */

   n1 = lparm - 7;			/* length without VALUE(...) */
   (void) strcpy(cres,parm+6);
   Replace_it(cres,&n1,*crlen,ires,rres,dres,gettype);
   if (func[0] == 'T')			/* M$TNULL(table,col,row) */
      {
      if (gettype[0] != ' ')		/* table element was accessed */
         {
         *ires = KIWORDS[OFF_INFO+7];
         *restype = 'I';
         }
      }
   else
      {
      *restype = gettype[0];	
      if (*restype == 'C') *crlen = n1;
      }
   return;


case 1:   /*  handle INDEX(oper1,oper2), result will be integer no.  */
 
   if ((parm[5] == 'B') || (parm[5] == 'b'))	/* INDEXB */
      n2 = 7;
   else						/* INDEX  */
      n2 = 6;
   if (parm[n2] == '"')			/* we have a char. string */
      {
      n = CGN_INDEXS(parm+(n2+1),"\",");	/* look for closing ", */
      n += (n2 + 2);			/* 	move to following comma */
      }
   else
      n = CGN_INDEXC(parm,',');		/* isolate 1. operand  */
   n1 = n - n2;
   GETOP(parm+n2,n1,ires,rres,c1,dres,&sdum,gettype,1024);	/* get 1. operand  */
   if (gettype[0] != 'C') return;
	
   n1 = lparm - n - 2;
   GETOP(parm+n+1,n1,ires,rres,c2,dres,&sdum,gettype,1024);	/* get 2. operand  */
   if (gettype[0] == 'C')
      {
      if (n2 == 7)
         *ires = CGN_JNDEXS(c1,c2) + 1;	   /* we use FORTRAN counting ...  */
      else
         *ires = CGN_INDEXS(c1,c2) + 1;
      *restype = 'I';
      }
   return;
 

case 2:   /*  handle TIME() and TIME(iop), result will be char. string
              don't forget that parser will change TIME() to TIME(0) */

   n1 = lparm - 6;
   GETOP(parm+5,n1,&n,rres,cres,dres,&sdum,gettype,1);
   if (gettype[0] != 'I')
      {
      if (gettype[0] == 'D')
         n = (int) *dres;       /* m$time(-1) => TIME(-1.), so it's double.. */
      else
         n = 0;
      }
   if (n != 0)
      {
      if (n > 0) n--;		/* remove the offset for positive n again */
      *crlen = CGN_DATE(0,n,cres);
      }
   else
      {
      OSY_ASCTIM(cres);				/* get date + time */
      *crlen = (int) strlen(cres);
      }
 
   *restype = 'C';
   return;
 

case 3:   /*  handle ABS(operand)  */
 
   n1 = lparm - 5;
   GETOP(parm+4,n1,ires,rres,cres,dres,&sdum,gettype,1);
 
   if (gettype[0] == 'I')
      {
      if (*ires < 0) *ires = -(*ires);
      }
   else if (gettype[0] == 'R')
      {
      if (*rres < 0.0) *rres = -(*rres);
      }
   else if (gettype[0] == 'D')
      {
      if (*dres < 0.0) *dres = -(*dres);
      }
   else
      return;					/* wrong data type...  */
	
   *restype = gettype[0];
   return;
 

case 4:   /*  handle NINT(operand), result will be integer  */
 
   n1 = lparm - 6;
   GETOP(parm+5,n1,ires,rres,c1,dres,&sdum,gettype,60);
 
   if ((gettype[0] == ' ') || (gettype[0] == 'C')) 
      return;						/* invalid option */

   else if (gettype[0] == 'R')
      *ires = CGN_NINT(*rres);

   else if (gettype[0] == 'D')
      *ires = CGN_DNINT(*dres);

   *restype = 'I';
   return;
 

case 5:   /*  handle TSTNO(operand), result will be 1 or 0 */
 
   n1 = lparm - 7;
   GETOP(parm+6,n1,ires,rres,c1,dres,&sdum,gettype,MAX_TOKEN);
   if (gettype[0] != 'C')
      *ires = 1;				/* it's a number already... */
   else
      {
      if (CGN_NUMBER(c1) == 1)
         *ires = 1;			/* it's a number  */
      else
         *ires = 0;			/* simple character string  */
      }
 
   *restype = 'I';
   return;
 

case 6:   /*  handle EXISTz(operand), result will be integer no.  */
 
   *ires = 0;				/* default to failure  */
   if ((parm[5] == 'D') || (parm[5] == 'd'))
      goto sect_6600;				/* M$EXISTD */
   else if ((parm[5] == 'C') || (parm[5] == 'c'))
      goto sect_6500;				/* M$EXISTC */
   else if ((parm[5] == 'K') || (parm[5] == 'k'))
      n2 = 7;					/* M$EXISTK  */
   else				
      n2 = 6;					/* M$EXIST   */ 
   n1 = lparm - n2 - 1;
   GETOP(parm+n2,n1,ires,rres,c1,dres,&sdum,gettype,MAX_TOKEN);
   if (gettype[0] != 'C') return;		/* we need a char. keyword */

   *ires = 0;				/* default to failure...  */
   if (n2 == 6)					/* look for file  */
      {
      CGN_LOGNAM(c1,c2,200);			/* translate logical name */
#if vms
      FSY_OPEN(c2,(int)strlen(c2),&n,&stat);
      if (stat & BIT_0) 
         {
         *ires = 1;
         stat = SYS$DASSGN(n);
         }
      else if (stat == 98954)	      /* 1828a (hex) - file locked (FRAMACC) */
         *ires = 1;

      else			/* try once more after Midas-cleaning */
         {
         m = CGN_singleframe(c2,1,c1);      /* assume image type */
         if (m == 1)
            {
            FSY_OPEN(c1,(int)strlen(c1),&n,&stat);
            if (stat & BIT_0)
               {
               *ires = 1;
               stat = SYS$DASSGN(n);
               }
            else if (stat == 98954)   /* 1828a (hex) - file locked (FRAMACC) */
               *ires = 1;
            }
         }

#else
      fp = open(c2,O_RDONLY);			/* read only */
      if (fp >= 0)
         {
         *ires = 1;
         close(fp);
         }
      else 			/* try once more after Midas-cleaning */
         {
         m = CGN_singleframe(c2,1,c1);	/* assume image type */
         if (m == 1)
            {
            fp = open(c1,O_RDONLY);			/* read only */
            if (fp >= 0)
               {
               *ires = 1;
               close(fp);
               }
            }
         if (*ires != 1)		/* if not found, try the DPATH option */
            {
            char  work[168];

            for (m=0; m<4; m++)
               {
               n = m*80;
               if (DATA_PATH[n] != '^')
                  {
                  (void) memcpy(work,&DATA_PATH[n],(size_t)80);
                  work[80] = ' ';
                  n = CGN_INDEXC(work,' ');
                  (void) strcpy(&work[n],c1);          /* use new path */
                  fp = open(work,O_RDONLY);		/* open - read only */
                  if (fp >= 0)
                     {
                     *ires = 1;
                     close(fp);
                     break;
                     }
                  }
               }
            }
         }
#endif

      }
   else						/* look for keyword  */
      {
      if ( MID_FNDKEY(c1,gettype,&l2,&l2,&unit) >= 0 )
         *ires = 1;
      }
   *restype = 'I';
   return;
 

   /*  handle EXISTC(table,label), result will be column no.  */

sect_6500:
   *ires = -2;
   m = CGN_INDEXC(parm,',');                    /* isolate 1. operand  */
   n1 = m - 7;
   GETOP(parm+7,n1,ires,rres,c1,dres,&sdum,gettype,MAX_TOKEN);       /* get 1. op */
   if (gettype[0] != 'C') return;

   FRAMACC('O',c1,2,&imno);			/* open table */
   if (imno >= 0) 
      {
      n2 = lparm - m - 2;
      GETOP(parm+m+1,n2,ires,rres,c2,dres,&sdum,gettype,MAX_TOKEN);  /* get 2. op */
      *ires = -1;
      if (gettype[0] == 'C')
         {			/* c2 = " " returns 0 (sequence no.)... */
         if (*c2 != ' ') stat = TCCSER(imno,c2,ires);
         }
      }

   *restype = 'I';
   return;

 
   /*  handle EXISTD(oper1,oper2), result will be integer no.  */
 
sect_6600:
   m = CGN_INDEXC(parm,',');			/* isolate 1. operand  */
   n1 = m - 7;
   GETOP(parm+7,n1,ires,rres,c1,dres,&sdum,gettype,MAX_TOKEN);	/* get 1. op */
   if (gettype[0] != 'C') return;
 
   FRAMACC('O',c1,0,&imno);
   if (imno >= 0)
      {
      n2 = lparm - m - 2;
      GETOP(parm+m+1,n2,ires,rres,c2,dres,&sdum,gettype,MAX_TOKEN);	/* get 2. op */
      if (gettype[0] == 'C') 
         {
         int dsclen;
         char realdescr[52];

         c1[0] = ' ';
         fctpntr = FCT.ENTRIES + imno;
         fcbp = fctpntr->FZP;
         dsclen = CGN_UPCOPY(realdescr,c2,49);	/* -> uppercase name */

         m = MID_YDSCDIR(imno,'F',realdescr,c1,&n,&n,&unit,&l1,&l2,htext);
         if (m != ERR_NORMAL)
            KIWORDS[OFF_PRSTAT] = 0;
         else
            *ires = 1;
         }
      }
 
   *restype = 'I';
   return;
 

case 7:   /*  handle LEN(operand), result will be integer no.  */
 
   n1 = lparm - 5;
   GETOP(parm+4,n1,ires,rres,c1,dres,&sdum,gettype,1024);
   if (gettype[0] != 'C') return;
	
   n1 = (int)strlen(c1) - 1;
   if ((wbuf[0] == '"') && (wbuf[n1] == '"'))
      m = n1 + 1;
   else
      {
      m = CGN_INDEXC(c1,' ');
      if (m < 0) m = n1 + 1;
      }
   *ires = m;
 
   *restype = 'I';
   return;
 

case 8:   /*  handle SYMBOL(operand)  */
 
   n1 = lparm - 8;			/* and get its length  */
   GETOP(parm+7,n1,ires,rres,c1,dres,&sdum,gettype,MAX_TOKEN);	/* get 1. op */
   if (gettype[0] == 'C') 
      {
      n2 = *crlen - 1;			/* max length of result string */
      OSY_GETSYMB(c1,cres,n2);
      *crlen = (int)strlen(cres);
      *restype = 'C';
      }
   return;
   }

sect_2000:
switch(nbra)
   {	
 
/*  handle LN, LOG10, EXP, EXP10, SIN, COS, TAN, SQRT, 
           ASIN, ACOS, ATAN(operand)                       */
case 9: 
   n2 = 4;
   goto sect_10010;
 
case 10:
   n2 = 7;
   goto sect_10010;

case 11:
   n2 = 5;				/* EXP  */
   goto sect_10010;
 
case 12:
   n2 = 7;				/* EXP10  */
   goto sect_10010;
 
case 13:				/* SIN, COS, TAN */
case 14:
case 15:
   n2 = 5;
   goto sect_10010;
 
case 16:				/* SQRT, ASIN, ACOS, ATAN */
case 17:
case 18:
case 19:
   n2 = 6;
   goto sect_10010;

case 20:
   nbra = 10;				/* old LOG function */
   n2 = 5;
    
sect_10010:
   fno = nbra - 8;
   n1 = lparm - n2;
   GETOP(parm+n2-1,n1,ires,rres,c1,dres,&sdum,gettype,60);
	
   if (gettype[0] == 'C')		/* we don't like that!! */
      return;
   else if (gettype[0] == 'R')
      *dres = *rres;
   else if (gettype[0] == 'I')
      *dres = (double) *ires;

   CGN_FUNC(fno,dres);
   *restype = 'D';
   return;
}
 

sect_3000:
switch(nbra)
   {	
 
case 21:  		 /*  UPPER(operand), LOWER(operand)  */
case 22:
 
   n1 = lparm - 7;
   GETOP(parm+6,n1,ires,rres,cres,dres,&sdum,gettype,*crlen);
 
   if (gettype[0] == 'C')
      {
      if (nbra == 21)
         CGN_UPSTR(cres);
      else
         CGN_LOWSTR(cres);
      *crlen = (int)strlen(cres);
      *restype = 'C';
      }
   return;

 
case 23:  		 /*  SECS()  */

   *ires = (int) oshtime();
   *restype = 'I';
   return; 


case 24:   /*  handle AGL(operand)  */

   n1 = lparm - 5;
   GETOP(parm+4,n1,ires,rres,c1,dres,&sdum,gettype,20);
   if (gettype[0] != 'C') return;
 
   memset((void *)cres,32,(size_t)20);		/* clean result string first */
   cres[20] = '\0';
   *crlen = 20;
   *restype = 'C';
   (void) OSY_TRNLOG("AGL3CONFIG",c2,200,&m);
#if vms
if (c2[m-1] != FSY_DISKEND)
   {
   if (c2[m-1] != FSY_DIREND) c2[m++] = FSY_DIREND;
   }
#else
   if (c2[m-1] != FSY_DIREND) c2[m++] = FSY_DIREND;
#endif
   (void) strcpy(&c2[m],"agldevs.dat");

   fp = osaopen(c2,0);				/* only for reading */
   if (fp < 0) return;

read_agl:
   n1 = osaread(fp,c2,40);

   if (n1 < 0) goto eof_agl;
   if ((n1 == 0) || (c2[0] == '#')) goto read_agl;

   l1 = CGN_INDEXC(c1,'.');
   n2 = CGN_INDEXC(c2,':');
   if (n2 > 0)
      {					/* handle pc2usr1.c:pscript.c ... */
      if ((l1 < 1 ) && (c2[n2-2] == '.'))
         {
         savchar = '.';
         n2 -= 2;
         }
      else
         savchar = ':';
      c2[n2] = '\0';

#if vms 
      if (strcmp(c1,c2) != 0)
         {	 			/* try with uppercase */
         CGN_UPSTR(c2);
         if (strcmp(c1,c2) != 0) goto read_agl;
         }
#else
      if (strcmp(c1,c2) != 0) goto read_agl;
#endif 

      c2[n2] = savchar;
      for (nr=n2; nr<n1; nr++)
         {
         if ((c2[nr] == ' ') || (c2[nr] == '\t')) break;
         }

      (void) strncpy(cres,c2,nr);
      cres[nr++] = ' ';
      cres[nr] = '\0';
      *crlen = nr;
      }
   else
      goto read_agl;

eof_agl:
   osaclose(fp);
   return;


case 25:   /*  handle FILTYP(op1,op2), result will be 0, 1, 2  or 9 */

   *restype = 'I';
   *ires = 0;

   m = CGN_INDEXC(parm,',');			/* isolate 1. operand */
   n1 = m - 7;
   GETOP(parm+7,n1,ires,rres,c1,dres,&sdum,gettype,MAX_TOKEN);	/* get 1. op */
   if (gettype[0] != 'C') return;

   n2 = lparm - m - 2;
   GETOP(parm+m+1,n2,ires,rres,c2,dres,&sdum,gettype,MAX_TOKEN);	/* get 2. op */
   if (gettype[0] != 'C') return;		/* not good... */
   if (c2[0] != ' ') 
      {
      if ((c2[0] == '"') && (c2[1] == ' '))
         n = 0;
      else if (c2[0] == '?')			/* we just want to know */
         {
         stat = MID_fitstest(c1);
         if (stat == 0)
            *ires = 1;				/* Yes. it's a FITS file */
         else if (stat == -2)
            *ires = 0;
         else
            *ires = -1;
         return;
         }
      else
         n = 1;
      }
   else
      n = 0;

   n1 = CGN_JNDEXC(c1,FSY_TYPMARK);		/* look for '.' */
   if (n1 < 1)
      {
      if (n == 1) (void) strcat(c1,c2);		/* append given type */
      }
   else
      {
      n2 = CGN_JNDEXC(c1,FSY_DIREND);		/* look for '/' or ']' */
      if (n2 > n1)		      /* so the `.' was in a directory */
         {
         if (n == 1) (void) strcat(c1,c2);	/* append given type */
         }
      stat = strcmp(&c1[n1],".cat");
      if (stat == 0)				/* it's a catalog */
         {
         fp = osaopen(c1,0);
         if (fp > -1)
            {
            *ires = 9;
            osaclose(fp);
            }
         return;
         }
      }

   stat = SCFINF(c1,9,ibuf);
   if (stat == ERR_NORMAL)
      {
      if (ibuf[1] == F_IMA_TYPE)
         *ires = 1;
      else if (ibuf[1] == F_TBL_TYPE)
         *ires = 2;
      else
         *ires = 3;
      }
    
   return;


case 26:   /*  handle PARSE(op1,op2), result will be no. of subparms   */

   (void) SCKGETC("MID$SPEC",10,1,&m,c1);	/* get separation char. */
   savchar = *c1;				/* default is ',' */
   if ((m < 1) || (savchar == ' ')) savchar = ','; 

   m = CGN_JNDEXC(parm,',');		/* isolate 1. operand (avoid commas) */
   n1 = m - 6;
   GETOP(parm+6,n1,ires,rres,c1,dres,&sdum,gettype,MAX_TOKEN);        /* get 1. op */
   if (gettype[0] != 'C') return;

   n2 = lparm - m - 2;
   GETOP(parm+m+1,n2,ires,rres,c2,dres,&sdum,gettype,MAX_TOKEN); 
   if (gettype[0] != 'C') return;               /* not good... */

   n1 = 1;			/* param counter */
   n2 = 0;			/* offset within c1 */
   m = (int)strlen(c1);
   TOKEN[3].STR[0] = '?';		/* that's checked in DO_KEYS ... */
   MONIT.COUNT = 3;
   tp = &wbuf[800];

   while ((nr = CGN_EXTRSS(c1,m,savchar,&n2,TOKEN[2].STR,MAX_TOKEN)) > -1)
      {					/* work on keyword `op2'`n1' */
      (void) sprintf(tp,"%s%2.2d",c2,n1);

      nbra = 0;			/* used to remember this case later on */
      if (nr == 0)		/* only delimiter found... */
         {
         nbra = -1;		
         nr = 1;
         TOKEN[2].STR[0] = ' ';
         TOKEN[2].STR[1] = '\0';
         }

      TOKEN[2].LEN = nr;
      n = MID_FNDKEY(tp,gettype,&l1,&l2,&unit);	     
      if (n > -1)				/* keyword already there */
         {
         if ((gettype[0] != 'C') || (l1 != 1) || (l2 < nr))
            return;				/* bad keyword */
         TOKEN[1].LEN = CGN_COPY(TOKEN[1].STR,tp);
         n = DO_KEYS('W',wbuf);		/* update existing keyword */
         }
      else
         {
         if ((nbra != -1) && (nr < 80)) nr = 80;	/* at least 80 chars */
         (void) sprintf(TOKEN[1].STR,"%s/C/1/%d",tp,nr);
         TOKEN[1].LEN = (int) strlen(TOKEN[1].STR);
         n = DO_KEYS('L',wbuf);		/* create local keyword `op2'no */
         }

      if (n != 0) return;
      n1 ++;
      }

   *ires = n1 - 1;
   *restype = 'I';
   return;


case 27:      /* handle M$FTSET(operand) 1 or 0, if filetype given in `op1' */

   n1 = lparm - 7;
   GETOP(parm+6,n1,ires,rres,c1,dres,&sdum,gettype,MAX_TOKEN);
   if (gettype[0] != 'C') return;
 
   *restype = 'I';
   *ires = 0;

   m = (int) strlen(c1);
   for (nr=m; nr>0; nr--)
      {
      if (wbuf[nr] == FSY_DIREND)
         return;
      else if (wbuf[nr] == FSY_TYPMARK)
         {
         *ires = 1;
         return;
         }
      }
   return;


case 28:      /* handle M$STRLEN(operand) */

   if ((parm[5] != 'N') && (parm[5] == 'n')) return;

   n1 = lparm - 8;
   GETOP(parm+7,n1,ires,rres,c1,dres,&sdum,gettype,1024);
   if (gettype[0] == 'C') 
      {
      *ires = (int)strlen(c1);
      for (nr=0; nr<*ires; nr++)
         {
         if (*c1++ != ' ') goto not_empty;
         }
      *ires = 0;
   not_empty:
      *restype = 'I';
      }
   return;


case 29:      /* handle M$STRCMP(oper1,oper2) */

   *ires = -2;
   m = CGN_INDEXC(parm,',');                    /* isolate 1. operand  */
   n1 = m - 7;
   GETOP(parm+7,n1,ires,rres,c1,dres,&sdum,gettype,MAX_TOKEN);       /* get 1. op */
   if (gettype[0] != 'C') return;

   n2 = lparm - m - 2;
   GETOP(parm+m+1,n2,ires,rres,c2,dres,&sdum,gettype,MAX_TOKEN);  /* get 2. op */
   *ires = -1;
   if (gettype[0] != 'C') return;

   *restype = 'I';
   *ires = strcmp(c1,c2);
   return;


case 30:   /*  handle ISODATE() */

   *crlen = CGN_DATE(1,0,cres);		/* get date as ISO 8601 string */
   *restype = 'C';
   return;


case 31:      /* handle M$TRIM(operand) */

   n1 = lparm - 6;
   GETOP(parm+5,n1,ires,rres,c1,dres,&sdum,gettype,MAX_TOKEN);
   if (gettype[0] == 'C') 
      {
      *restype = 'C';

      m = (int) strlen(c1);
      n1 = m;
      for (nr=0; nr<m; nr++)
         {
         if (wbuf[nr] != ' ')
            {
            n1 = nr;
            break;
            }
         }

      if (n1 == m)			/* only blanks... */
         {
         n1 = 0;
         wbuf[n1++] = ' ';
         wbuf[n1] = '\0';
         }
      *crlen = CGN_COPY(cres,&wbuf[n1]);
      }
   return;


case 32:      /* handle M$REPLA(op1,op2) string op1 will be replaced by op2 */

   n1 = 6;				/* skip REPLA(  */
   n2 = CGN_EXTRSS(parm,lparm,',',&n1,c1,400);
   if (n2 > 0)
      {
      int  m1;
      char  *cp1, *cp2;

      cp1 = c1+500;
      cp2 = c2+500;

      GETOP(c1,n2,ires,rres,cp1,dres,&sdum,gettype,500);
      if (gettype[0] != 'C') return;
      (void) strcpy(cres,cp1);

      n2 =  CGN_EXTRSS(parm,lparm,',',&n1,c1,500);
      GETOP(c1,n2,ires,rres,cp1,dres,&sdum,gettype,500);
      if (gettype[0] != 'C') return;
      m1 = CGN_COPY(c1,cp1);

      n2 =  CGN_EXTRSS(parm,lparm,')',&n1,c2,500);
      GETOP(c2,n2,ires,rres,cp2,dres,&sdum,gettype,500);
      if (gettype[0] != 'C') return;

      n1 = 0;
      while ((n = CGN_INDEXS(cres+n1,c1)) > -1) 
         {
         (void) strcpy(c2,cres+n1+n+m1);	/* save part after pattern */
         (void) strcpy(cres+n1+n,cp2);		/* replace pattern */
         n1 = (int) strlen(cres);
         (void) strcpy(cres+n1,c2);		/* repaste saved part */
         }
      *crlen = (int)strlen(cres);
      *restype = 'C';
      }
   return;


case 33:      /* handle M$SYSTEM(op1) - execute HostSystem command `op1' */

   n1 = lparm - 8;				/* strip name and (,) */
   GETOP(parm+7,n1,ires,rres,c1,dres,&sdum,gettype,512);
   if (gettype[0] != 'C') return;

   *restype = 'I';
   n1 = 0;
   while ((c1[n1] == ' ') || (c1[n1] == '\t')) n1++;

#if vms
   c2[0] = '$';				 /* make sure, we begin with $ */
   (void) strcpy(&c2[1],c1+n1);
   RUN_IT(c2);			/* don't know if VMS also has `system()' */
   *ires = KIWORDS[OFF_AUX+16];		/* here the hostsys status was saved */

#else
   *ires = system(c1);

#endif
   }
}
/*

*/
 
void Replace_it(parm,lparm,maxout,ibuf,rbuf,dbuf,datatype)
 
/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  replace string "KEY(...)" with the contents of keyword KEY(...)
  and the same for string "FILE,DESCR(...)"
  and the same for string "FILE[x,y,z]"
  and the same for string "TABLE,COL,ROW"
.ALGORITHM
  read relevant element of keyword (descr) + convert it to ASCII if necessary
  or get relevant pixel element
------------------------------------------------------------------*/
 
char   *parm;		/* IO: parameter to be replaced  */
int    *lparm; 	 	/* IO: length of 'parm'  */
int    maxout;		/* I: max length of 'parm' (for character stuff) */
int    *ibuf;		/* O: integer data */
float  *rbuf;		/* O: real data */
double *dbuf;		/* O: double data */
char   *datatype;	/* O: data type, if = ' ', bad data */
 
{
int   n, nval;
register int  lr;

char	type[16], *ccp, *pntr;
char    wbuf[1024];
	
 
 
n = *lparm;
(void) strncpy(wbuf,parm,n);		/* *lparm not always length of parm */
wbuf[n] = '\0';
	

/* check, if image pixel access  */
 
nval = -1;
for (lr=1; lr<n; lr++)
   {
   if (wbuf[lr] == '[') 		/* image involved */
      {
      int  m;

      *datatype = ' ';
      m = CGN_INDEXC(wbuf,']');		/* check for A[<,<:>,>],descr */
      m++;
      if (wbuf[m] != ',')		/* it's A[..] */
         {
         if (PIXEL_ACCESS(0,wbuf,rbuf) == 0) 
            *datatype = 'R';		/* o.k., handle like real data */
         return; 				/* all done */
         }
      else				/* we have A[<,<:>,>],descr */
         {
         nval = m;
         goto next_step;
         }
      }

   else if (wbuf[lr] == ',')		/* it's a descr or a table */
      {
      nval = lr;
      break;
      }
   }

next_step: 
if (nval < 1)  				/* must be keyword...  */
   {			/*  for P1, P2, ..., P8 do a fast replacement  */
   if ( (wbuf[0] == 'P') && (lr == 2) && (wbuf[1] >= '0') && (wbuf[1] < '9') )
      {
      n = wbuf[1] - 49;			/*  'm' => m-1   */
      pntr = &KCWORDS[MONIT.POFF[n]];
      ccp = pntr + MAX_TOKEN - 1;		/* point to last elem of Pi */

      for (lr=MAX_TOKEN; lr>1; lr--)	      /*  cut off trailing blanks  */
         {
         if ((*ccp != ' ') && (*ccp != '\0'))
            {
            nval = lr;
            goto copy_it;
            }
         ccp --;
         }
      nval = 1;
 
     copy_it:
      type[0] = 'C';
      (void) strncpy(parm,pntr,nval);
      }
 
   else			/* `normal' keyword */
      {
      nval = maxout + 1;
      KEY_ACCESS(wbuf,ibuf,rbuf,parm,dbuf,type,nval);
      nval = (int)strlen(parm);		/* set to length of returned parm */
      }
   }
 
else
   {		 /* second comma will decide between descr and table option  */
   if (CGN_INDEXC(&wbuf[nval+1],',') < 1)
      {
      nval = maxout;
      DESCR_ACCESS(0,wbuf,ibuf,rbuf,parm,dbuf,type,&n,&nval);
      }
   else
      (void) TABLE_ACCESS(0,wbuf,ibuf,rbuf,parm,dbuf,type,&nval);
   }

if (type[0] == 'C') *lparm = nval;

*datatype = type[0];
}
/*

*/
 
int REPLACE(parm,lparm,maxout)
 
/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  replace string "KEY(...)" with the contents of keyword KEY(...)
  and the same for string "FILE,DESCR(...)"
  and the same for string "FILE[x,y,z]"
  and the same for string "TABLE,COL,ROW"
.ALGORITHM
  read relevant element of keyword (descr) + convert it to ASCII if necessary
  or get relevant pixel element
.RETURNS
  int value	< 0: error
  			= 0: o.k., no expansion (no blanks inside TOKEN[].STR)
  			> 0: o.k., yes expansion (blanks inside TOKEN[].STR)
------------------------------------------------------------------*/
 
char	*parm		/* IO: parameter to be replaced  */;
int   *lparm 	 	/* IO: length of 'parm'  */;
int   maxout		/* I: max length of 'parm' (for character stuff) */;
 
{
int  ibuf;
register int  loop, lr;

float rbuf;

double dbuf;

char  datatype;


lr = *lparm;
if ((lr < 1) || (lr > 2047)) return (-2);		/* bad string size */

Replace_it(parm,lparm,maxout,&ibuf,&rbuf,&dbuf,&datatype);
if (datatype == ' ') return (-1);		/* could not replace... */

if (datatype == 'C')			/* character data */
   {
   for (loop=0; loop<(*lparm); loop++)	/* look if interspersed blanks ....  */
      {
      if (parm[loop] == ' ') 
         {
         for (lr=loop+1; lr<(*lparm); lr++)
            {
            if (parm[lr] != ' ') return (1);
            }
         }
      }
   }

else				/* numeric data */
   {
   if (datatype == 'L') datatype = 'I';		/* logical => integer */
   REPFORM(datatype,&ibuf,&rbuf,&dbuf,1,parm,lparm);	/* convert one value */
   }

return (0);
}
/*

*/
 
#ifdef __STDC__
void REPFORM(char type, int *ival, float *rval, double *dval, int lv,
             char *string, int *lstr)
#else
void REPFORM(type,ival,rval,dval,lv,string,lstr)
 
/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  write binary values to ASCII string using currently active format
.ALGORITHM
  get format from PROC.FORMAT and apply it
.RETURNS
  nothing
----------------------------------------------------------------*/
	
char	type	/* IN: I or R or D, type of input values  */;
int  *ival	/* IN: integer input  */;
float	*rval	/* IN: real input  */;
double	*dval	/* IN: double prec. input  */;
int   lv	/* IN: number of input values  */;
char	*string	/* OUT: output string  */;
int   *lstr	/* OUT: length of 'string'  */;
#endif
 
{	
int   fyes, m, n, off_form, length, off;
register int  nr;
	
char   wbuf[256];	
static char   fmt[12] = "%      ";

 

off_form = MONIT.LEVEL * 15;		/* use level for getting offset */
fmt[7] = ' ';				/* make sure, there will be a blank  */
fyes = 0;
	
 
/* get currently used format + convert data accodingly */
 
if (type == 'I')		/* integer data */
   {
   fmt[1] = '0';
   (void) strncpy(&fmt[2],&PROC.FORMAT[off_form],5);
   for (nr=3; nr<7; nr++)
      {
      if (fmt[nr] == ',')
         {
         fyes = -1;
         (void) 				/* dest, src area overlap... */
         CGN_strncpy(&fmt[1],&fmt[2],3);	
         nr -- ;
         break;
         }          
      else if (fmt[nr] == ' ')
         break;
      }

   fmt[nr++] = 'd';
   fmt[nr++] = ' ';
   fmt[nr] = '\0';

   if (lv == 1)			/* single value */
      {
      if (*ival < 0)
         {
         n = - (*ival);
         (void) sprintf(string+1,fmt,n);	/* take care of minus sign */
         *string = '-';
         }
      else
         (void) sprintf(string,fmt,*ival);

      if (fyes == -1)
         *lstr = (int) strlen(string);
      else
         *lstr = CGN_INDEXC(string,' ');
      }

   else				/* we work on an integer array */
      {
      off = 0;
      for (nr=0; nr<lv; nr++)
         {
         m = *(ival+nr);
         if (m < 0)
            {
            (void) sprintf(&wbuf[1],fmt,-m);   /* take care of minus sign */
            wbuf[0] = '-';
            }
         else
            (void) sprintf(wbuf,fmt,m);
   
         if (fyes == -1)
            length = (int) strlen(wbuf);
         else
            length = CGN_INDEXC(wbuf,' ');

         (void) strncpy(string+off,wbuf,length);
         *(string+off+length) = ',';
         off += (length + 1);		/* point to position after the comma */
         }
      *lstr = off - 1;
      }
   }

else
   {
   register int mr;
   char  fc;

   if (type == 'R')
      off_form += 5;		/* move to real Format  */
   else
      off_form += 10;		/* move to double Format  */

   fc = 'f';
   fmt[1] = '-';
   (void) strncpy(&fmt[2],&PROC.FORMAT[off_form],5);
   mr = 3;
   if ((fmt[mr] >= '0') && (fmt[mr] <= '9')) mr ++;
   if (fmt[mr] == ';')          /* xx;yy is F format without trailing 0's */
      {
      fmt[mr] = '.';
      if (fmt[mr+1] != '0') fyes = 1;
      }
   else if (fmt[mr] == ',')     /* xx,yy is F format with trailing 0's */
      {
      fyes = -1;
      fmt[mr] = '.';
      (void) 				/* dest, src area overlap... */
      CGN_strncpy(&fmt[1],&fmt[2],5);	/* get rid of `-'  */
      mr --;
      }
   else                         /* xx.yy is E format */
      fc = 'E';

   mr += 2;
   if ((fmt[mr] >= '0') && (fmt[mr] <= '9')) mr ++;
   fmt[mr++] = fc;
   fmt[mr] = '\0';
 
   if (lv == 1)                 /* single value */
      {
      if (type == 'R')
         (void) sprintf(string,fmt,*rval);
      else
         (void) sprintf(string,fmt,*dval);

      *lstr = (int) strlen(string);
      if (fyes != -1)
         {
         for (mr=*lstr-1; mr>=0; mr--)		/* remove trailing blanks */
            {
            if (string[mr] != ' ')
               {
               *lstr = mr + 1;
               break;
               }
            }
         if (fyes == 1)
            {
            mr = (*lstr) - 1;
            while  ((string[mr] == '0') && (string[mr-1] != '.')) 
               string[mr--] = ' ';
            *lstr = mr + 1;
            } 
         } 
      }

   else				/* we work on a real/doubl. prec. array */
      {
      off = 0;
      for (nr=0; nr<lv; nr++)
         {
         if (type == 'R')
            (void) sprintf(wbuf,fmt,*(rval+nr));
         else
            (void) sprintf(wbuf,fmt,*(dval+nr));
    
         length = (int) strlen(wbuf);
         if (fyes != -1)
            {
            for (mr=length-1; mr>=0; mr--)         /* remove trailing blanks */
               {
               if (string[mr] != ' ')
                  {
                  length = mr + 1;
                  break;
                  }
               }
            if (fyes == 1)
               {
               mr = length - 1; 
               while  ((wbuf[mr] == '0') && (wbuf[mr-1] != '.'))
                  wbuf[mr--] = ' ';
               length = mr + 1;
               }
            }
         (void) strncpy(string+off,wbuf,length);
         *(string+off+length) = ',';
         off += (length + 1);		/* point to position after the comma */
         }
      *lstr = off - 1;
      }
   } 
}
/*

*/
 
int KEY_ACCESS(parm,ibuf,rbuf,cbuf,dbuf,type,csiz)
 
/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  return a key operand for REPLACE
.ALGORITHM
  read relevant element(s) of keyword
.RETURNS
 return status from SCKRDx calls
-----------------------------------------------------------------*/
	
char	*parm;		/* IN: keyname with \0 ...  */
int	*ibuf;		/* OUT: operand if integer  */
float	*rbuf;		/* OUT: operand if real  */
char	*cbuf;		/* OUT: operand if character  */
double  *dbuf;		/* OUT: operand if double prec.  */
char	*type;		/* OUT: type of operand, I, R, CHAR*n,D 
				= ' ', if something wrong       */
int   csiz;		/* IN: max. size of 'cbuf', including \0 ...  */

{
int  last, stat, kk, ccsiz, lc;
int  iav, bytelem, first, selem, sfirst, unit, nullo;
int *ipntr;
static int  work_size = 0;
register int  nr;

static char  *cpntr;
char	key[18], *tmppntr;
 
float	*rpntr;
 
double	*dpntr;



/* allocate only once */

if (work_size == 0)
   {
   work_size = 400;;
   cpntr = malloc((size_t)work_size);
   }
 
 
/* parse keyword string  */
 
KEY_PARSE(parm,key,type,&bytelem,&selem,&sfirst,&last);
if (*type == ' ') 
   {
   ERRORS.SYS = 84;
   return (-99);	     /* no match - return with 'type' = ' '  */
   }

/*  get operand from keywords  */
 
if (*type == 'I')
   {
   if (selem != -1)
      stat = SCKRDI(key,selem,1,&iav,ibuf,&unit,&nullo);
   else
      {
      ipntr = (int *) cpntr;
      kk = last - sfirst + 1;
      stat = SCKRDI(key,sfirst,kk,&iav,ipntr,&unit,&nullo);
      REPFORM('I',ipntr,rbuf,dbuf,kk,cbuf,&ccsiz);
      *type = 'C';		/* now, we return a character string...  */
      }
   }
 
else if (*type == 'R')
   {
   if (selem != -1)
      stat = SCKRDR(key,selem,1,&iav,rbuf,&unit,&nullo);
   else
      {
      rpntr = (float *) cpntr;
      kk = last - sfirst + 1;
      stat = SCKRDR(key,sfirst,kk,&iav,rpntr,&unit,&nullo);
      REPFORM('R',ibuf,rpntr,dbuf,kk,cbuf,&ccsiz);
      *type = 'C';		/* now, we return a character string...  */
      }
   }
 
else if (*type == 'D')
   {
   if (selem != -1)
      stat = SCKRDD(key,selem,1,&iav,dbuf,&unit,&nullo);
   else
      {
      dpntr = (double *) cpntr;
      kk = last - sfirst + 1;
      stat = SCKRDD(key,sfirst,kk,&iav,dpntr,&unit,&nullo);
      REPFORM('D',ibuf,rbuf,dpntr,kk,cbuf,&ccsiz);
      *type = 'C';		/* now, we return a character string...  */
      }
   }
	
else			/*  handle character keys specially  */
   {
   first = sfirst--;            /* first is original `sfirst' */
   if (last < 0)
      lc = -last;
   else
      lc = last;
   lc -= sfirst;
   csiz --;                             /* we need last character for '\0'  */
   if (lc > csiz) 
      {
      kk = lc;
      lc = csiz;            /* minimize...  */
      }
   else
      kk = -9;
	
   if (bytelem == 1)  					/* flat string */
      {
      stat = SCKRDC(key,1,first,lc,&iav,cbuf,&unit,&nullo);
      lc =  iav;
      }
   else
      {
      tmppntr = cpntr;
      if (lc+sfirst > bytelem) lc = bytelem - sfirst;
      if (lc > 400) lc = 400;			/* hard limit ... */
      stat = SCKRDC(key,bytelem,selem,1,&iav,tmppntr,&unit,&nullo);
      (void) strncpy(cbuf,tmppntr+sfirst,lc);
      }
   if (stat != ERR_NORMAL) return stat;

   cbuf[lc] = '\0';
   if (last < 0)			/* if no specific last index given, */
      {
      for (nr=lc-1; nr>=0; nr--)	/* cut off trailing blanks  */
         {
         if (cbuf[nr] != ' ')
            {
	    kk = nr + 1;
            cbuf[kk] = '\0';
            goto last_check;
            }
         }
      }

   last_check:
   if (kk != -9)
      {					/* length was larger ... */
      if (kk > csiz)
         {
         (void) sprintf(cpntr,
         "content of key %-8.8s > max size (%d) => truncated",
         key,csiz);
         SCTPUT(cpntr);
         }
      }
   }

return stat;		/* return status from SCKRx calls */
 
}
/*

*/
 
int GETOP(parm,lparm,ibuf,rbuf,cbuf,dbuf,sbuf,type,csiz)
 
/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  return an operand for COMPUTE/KEY or if commands
.ALGORITHM
  read relevant element of keyword or convert ASCII string to constant
.RETURNS
 return status from SCDRDx calls
--------------------------------------------------------------------*/
	
char	*parm	/* IN: "abcd" (ASCII constant) or 123.456  \
                       or any string (+ keyname)          */;
int  lparm 	/* IN: length of above  */;
int  *ibuf	/* OUT: operand if integer  */;
float	*rbuf	/* OUT: operand if real  */;
char	*cbuf	/* OUT: operand if character  */;
double	*dbuf	/* OUT: operand if double prec.  */;
size_t	*sbuf	/* OUT: operand if size_t  */;
char	*type	/* OUT: type of operand, I, R, CHAR*n, D, S  \
                        = ' ', if something wrong       */;
int   csiz	 /* IN: max. size of 'cbuf', including \0 ...  */;
 
{
int   last, it, lc, iav, unit, nullo, bytelem, first, stat;
int   sbytelem, selem, sfirst;
register int  nr;
 
char	key[18], *tmppntr1, *tpp;
register char  cr;
		

 

*type = ' ';				/* init to failure...  */
if (*parm == ' ') return (-99);
 
/* test for character constants  */
 
if (*parm == '"')  			/* character constant "xxxxx"  */
   {
   lc = lparm - 2;
   if ( (lc < 1) || (csiz <= lc ) ) return (-99);
 
   (void) strncpy(cbuf,parm+1,lc);
   cbuf[lc] = '\0';
 
   *type = 'C';
   return (0);
   }
 
 
tmppntr1 = CODE.WORK2;		/* use buffer WORK2 of size 2*MAX_TOKEN+2 */
(void) strncpy(tmppntr1,parm,lparm);
*(tmppntr1+lparm) = '\0';	/* make sure we have an end marker  */

tpp = tmppntr1;
it = 5;			/* if numerical constant, default to size_t type. */
 
/*  check, if plus/minus sign is first character  */
 
if ((*tpp == '-') || (*tpp == '+'))	/* skip leading plus/minus sign */
   {
   if (lparm < 2) return(0);			/* syntax error...  */
       
   tpp++;
   it = 1;				/* cannot be size_t anymore */
   }
 
	
/* test for numerical constants - we'll only split into integer (size_t) 
   or double  */
 
if (*tpp < 'A')  				/* numeric constant  */
   {
   if ((*tpp == '-') || (*tpp == '+')) tpp++;

   while((cr=*tpp++) != '\0')			/* scan no. string */
      {
      if ((cr == 'e') || (cr == 'E') ||
          (cr == 'd') || (cr == 'D'))
         it = 4;				/* double prec. no.  */
      else if (cr == '.') 
         it = 2;				/* real no. */
      else if ((cr == '+') || (cr == '-'))
         {
         if (it != 4)				/* only o.k. for double */
            {
            *type = ' ';
            return(0);
            }
         }
      }

   if (it == 5)
      {
      iav = CGN_xCNVT(tmppntr1,it,1,ibuf,rbuf,dbuf,sbuf);
      if (iav < 1) 
         {
         *type = ' ';			/* return with 'type' = ' '  */
         return(0);
         }
      ibuf[0] = (int)sbuf[0];
      if ((size_t)ibuf[0] != sbuf[0])
         {
         *type = 'S';
         return (0);
         }
      it = 1;			/* it's an integer no. */
      } 

   else if (it == 2)
      {				/* real data => double data */
      it = 4;
      }
   
   iav = CGN_CNVT(tmppntr1,it,1,ibuf,rbuf,dbuf);
   if (iav > 0)
      {
      if (it == 1)
         *type = 'I';
      else
         *type = 'D';
      return(0);
      }

   *type = ' ';			/* return with 'type' = ' '  */
   return(0);
   }
 
	
/*  so it's a keyword  */
	
KEY_PARSE(tmppntr1,key,type,&sbytelem,&selem,&sfirst,&last);
if (*type == ' ') return (-99);	    /* no match - return with 'type' = ' '  */

	
/*  get operand from keywords  */
 
if (*type == 'I')
   stat = SCKRDI(key,selem,1,&iav,ibuf,&unit,&nullo);
else if (*type == 'R')
   stat = SCKRDR(key,selem,1,&iav,rbuf,&unit,&nullo);
else if (*type == 'D')
   stat = SCKRDD(key,selem,1,&iav,dbuf,&unit,&nullo);
else if (*type == 'S')
   stat = SCKRDS(key,selem,1,&iav,sbuf,&unit,&nullo);
 
else		/*  handle character keys specially  */
   {
   bytelem = sbytelem;
   first = sfirst--;            /* first is original `sfirst' */
   if (last < 0)
      lc = -last;
   else
      lc = last;
   lc -= sfirst;
   csiz --;				/* we need last character for '\0'  */
   if (lc > csiz) lc = csiz;		/* minimize...  */
	
   if (sbytelem == 1)  				/* flat string  */
      {
      stat = SCKRDC(key,1,first,lc,&iav,cbuf,&unit,&nullo);
      lc = iav;
      }
   else
      {
      if (lc+sfirst > sbytelem) lc = sbytelem - sfirst;
      stat = SCKRDC(key,bytelem,selem,1,&iav,tmppntr1,&unit,&nullo);
      (void) strncpy(cbuf,tmppntr1+sfirst,lc);
      }

   if (stat == ERR_NORMAL) 
      {
      cbuf[lc] = '\0';
	
      if (last < 0)
         {
         for (nr=lc-1; nr>=0; nr--)		/* cut off trailing blanks  */
            {
            if (cbuf[nr] != ' ')
               {
               cbuf[nr+1] = '\0';
               return stat;
	       }
	    }
         }
      }
   }

return stat;
}




int KGN_INDEXS(s,t)
 
/*++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
 find position of substring in input string.

.RETURN
 returns index of substring in input string (= 0,1,2,...),
         -1 if not there
--------------------------------------------------*/
 
char *s;    /* input string  */
char *t;    /* substring */

{
register int nr;

register char  *cp, *cq, *qq, *t2;


cp = s;
t2 = t + 1;
 
for (nr=0; *cp != '\0'; nr++)
   {
   if (*cp++ == *t)			/* first char. has to match */
      {
      qq = cp;				/* points to 2. char in input string */
      for (cq=t2; *cq != '\0'; )
         {
         if (*cq++ != *qq++) continue;
         }
      return (nr);
      }
   }
 
return (-1);			/* substring not found */
}
 

