/*===========================================================================
  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 PREPC3  +++++++++++++++++++++
.LANGUAGE  C
.IDENTIFICATION	Module PREPC3
.AUTHOR		K. Banse                  ESO - Garching
.KEYWORDS
  MIDAS monitor
.COMMENTS
  holds Parse2, FRAMACC, PIXEL_ACCESS,
        CODE_ALLOC, CODE_FREE, INTERNAL,
        fixout, opti_code, is_label, opti_info, noprocess

.VERSION [1.00] 930126: pulled out from original PREPC.C

 100616		last modif
------------------------------------------------------------------------------*/
 
#include <fileexts.h>

#include <osyparms.h>
#include <monitdef.h>
#include <midback.h>
#include <fsydef.h>

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

#define CODE_INSIZE CODE_BLOCKS*OUR_BLOCK_SIZE	/* initial size of CODE.CODE */
/*

*/

int Parse2(sww,start)
/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  check for ASCII outfile + get all TOKENs
.ALGORITHM
  painfully straight forward
.RETURNS
  return no. of tokens on line
---------------------------------------------------------------------*/

int   sww;	/* IN: same switch as `sw' of PARSE */
int start;	/* IN: start index of LINE.STR */

{
int   lsave, ascout;
int   n, count, nn, snr, kk;
register int  nr;

static char   blank = ' ';
register char  sngc;



/* search for  >file  or  >>file  as last token */

ascout = -1;
for (nr=LINE.LEN-1; nr>start; nr--)		/* skip trailing blanks */
   {
   if (LINE.STR[nr] != ' ') 
      {
      LINE.LEN = nr + 1;
      LINE.STR[LINE.LEN] = '\0';
      nn = nr - 2;
      goto real_check;
      }
   }
return (0);			/* nothing there... */


real_check:
for (nr=nn; nr>start; nr--)
   {
   if (LINE.STR[nr] == ' ')			/* isolate last TOKEN */
      {
      if (LINE.STR[nr+1] == '>')
         {
         if (LINE.STR[nr+2] == '>')		/* >>file  appends */
            {
            n = 2;
            sngc = CGN_UPPER(LINE.STR[nr+3]);
            }
         else					/* >file  opens new one */
            {
            n = 1;
            sngc = CGN_UPPER(LINE.STR[nr+2]);
            }
         if ( (sngc == '/') || ((sngc >= 'A') && (sngc <= 'Z')) )
            {				/* files must begin with alpha_char */
            ascout = nr + n + 1;
            snr = nr;
            }
         }
      break;
      }
   }

if ((ascout > 0) && (sww > 0))
   {
   int  outidx, size;
   register int  mr;


   if (LINE.STR[LINE.LEN-1] == '"')	/* we are enclosed by '"' ... */
      goto do_parsing;

   if (ishostcom(LINE.STR+start) == 1)	/* ignore for host commands */
      goto do_parsing;

   if (KIWORDS[OFF_OUTFLG] != 99)		/* look for back storage */
      {
      for (nr=0; nr<5; nr++)
         {
         if (REDIRECT[nr].OUTFLAG[0] == KIWORDS[OFF_OUTFLG])
            {					   /* always update `fp' */
            REDIRECT[nr].OUTFLAG[2] = KIWORDS[OFF_OUTFLG+2];
            break;
            }
         }
      }

   outidx = -1;
   for (nr=0; nr<5; nr++)
      {
      if (REDIRECT[nr].OUTFLAG[0] == 99)
         {
         outidx = nr;
         break;
         }
      }

   if (outidx == -1)
      SCTPUT("too many redirections - this one ignored...");
   
   else
      {
      KIWORDS[OFF_OUTFLG+1] = 0;
      mr = CGN_INDEXC(&LINE.STR[ascout],'+');
      if (mr > 0) 
         {
         mr += ascout + 1;
         if ((LINE.STR[mr] == 't') || (LINE.STR[mr] == 'T'))
            {
            KIWORDS[OFF_OUTFLG+1] = 1;
            LINE.STR[mr-1] = '\0';		/* ','  =>  '\0'  */
            }
         }
      else
         {
         CGN_UPCOPY(KAUX.OUT,&LINE.STR[ascout],9);
         if (strcmp(KAUX.OUT,"TERMINAL") == 0)
            {
            LINE.LEN = snr;
            LINE.STR[snr] = '\0';
            goto do_parsing;			/* no file output */
            }
         }


      /* finally check, if replacements needed:  >{..}  */

      size = CGN_COPY(KAUX.OUT,&LINE.STR[ascout]);
      if (size > 64)			/* max. 64 chars for ASCII file */
         {
         ERRORS.SYS = 38;
         PREPERR("MIDAS",LINE.STR,KAUX.OUT);
         return (-1);
         }

     sect_2100:
      kk = CGN_INDEXC(KAUX.OUT,'{');
      if (kk >= 0)               /* if { found, look for last nestings */
         {
         char  wbuf[72];
         int   stat, left, mm;

        sect_2200:
         nn = CGN_INDEXC(&KAUX.OUT[kk+1],'{');
         if (nn >= 0)
            {
            kk += (nn + 1);
            goto sect_2200;                        /* loop...  */
            }
         (void) strcpy(wbuf,&KAUX.OUT[kk+1]);
         if ((lsave = CGN_INDEXC(wbuf,'}')) < 0) goto sect_2500;

         mm = kk + lsave + 2;	/* save offset after variable */
         left = size - mm;	/* remaining chars. in AUX.OUT */
      
         stat = REPLACE(wbuf,&lsave,64);
         size = kk + lsave + left;
         if ((stat < 0) || (size > 64))
            {
            ERRORS.SYS = 38;
            PREPERR("MIDAS",LINE.STR,KAUX.OUT);
            return (-1);
            }

         (void) strcpy(&wbuf[lsave],&KAUX.OUT[mm]);
         (void) strcpy(&KAUX.OUT[kk],wbuf);
         goto sect_2100;
         }

     sect_2500:
      (void) strcpy(&KCWORDS[OFF_OUTNAM],KAUX.OUT);
      KIWORDS[OFF_OUTFLG] = MONIT.LEVEL;
      KIWORDS[OFF_OUTFLG+2] = -1;		/* file not opened yet */
      KIWORDS[OFF_OUTFLG+3] = -n;		/* so -2 for appending */

      /* save in internal structure REDIRECT */

      for (nr=0; nr<4; nr++)
         REDIRECT[outidx].OUTFLAG[nr] = KIWORDS[OFF_OUTFLG+nr];
      (void) strcpy(REDIRECT[outidx].OUTFILE,KAUX.OUT);
      }

   LINE.LEN = snr;
   LINE.STR[snr] = '\0';
   }


/*  extract all tokens + get their length */

do_parsing:
for (n=0; n<10; n++)
   {
   TOKEN[n].LEN = 
      CGN_EXTRSS(LINE.STR,LINE.LEN,blank,&start,TOKEN[n].STR,MAX_TOKEN);
   if (TOKEN[n].LEN <= 0)                       /* end of parsing reached... */
      {
      if (TOKEN[n].LEN == -2)                   /* overflow of single token */
         {
         ERRORS.SYS = 7;
         PREPERR("MIDAS",LINE.STR,TOKEN[n].STR);
         return (-1);
         }

      count = n ;
      for (nr=count; nr<10; nr++)
         {
         TOKEN[nr].STR[0] = '?';             /* init empty TOKEN + LTOKEN  */
         TOKEN[nr].STR[1] = '\0' ;
         TOKEN[nr].LEN = 1 ;
         }
      return (count);
      }
   }

count = 10;


/*  garbage collection of more tokens...  */

nn = TOKEN[9].LEN;
while ((lsave = 
        CGN_EXTRSS(LINE.STR,LINE.LEN,blank,&start,KAUX.OUT,MAX_TOKEN)) > 0)   
   {
   if (sww == -1) return (-99);		/* in diagnostic mode flag that */

   if ((lsave+nn+1) > MAX_TOKEN)
      {
      kk = MAX_TOKEN - nn;
      lsave = 0;			/* force it to break later on */
      }
   else
      {
      TOKEN[9].STR[nn++] = ' ';
      kk = lsave;
      }
   (void) strncpy(&TOKEN[9].STR[nn],KAUX.OUT,kk);
   nn += kk;

   if (lsave <= 0) break;
   }


TOKEN[9].STR[nn] = '\0' ;
TOKEN[9].LEN = nn;

return (count);
}
/*

*/

#ifdef __STDC__
void FRAMACC(char actio, char *filnam, int ity, int *entrx)
#else
void FRAMACC(actio,filnam,ity,entrx)
/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  open image or table and close files if necessary
.ALGORITHM
  straight forward
.RETURNS
  nothing
------------------------------------------------------------------*/

char     actio;         /* IN: 'X', close all frames in structure FRAME  
                               'C', close `filnam' + delete from FRAME  
                               'I', init structure FRAME               
                               'O', open `filnam' + add to FRAME   */
char     *filnam;       /* IN: file name */
int    ity;		/* IN: file type - 1 = image, 2 = table, 0 = unknown */
int    *entrx;		/* IN/OUT: MIDAS file id */
#endif

{
static int level_now = -1;              /* so `init' does not return */
int   stat, jent, k, nn, ibuf[9];
register int  nr;

char  kframe[MAX_TOKEN], temp[MAX_TOKEN];
register char  *fptr;



if (actio == 'O')               /*  here for opening image or table */
   {
   k = -123;			/* use as intermediate switch */
   *entrx = -1;			/* avoid complaints from purify... */
   fptr = filnam;		/* fptr -> input name */

   if (ity == 0)
      {						/* test, if image or table */
      nn = CGN_singleframe(filnam,F_IMA_TYPE,kframe);	/* check for &a, ...*/
      if (nn != 0) fptr = kframe;		/* depending upon transl. */
      stat = SCFINF(fptr,9,ibuf);
      if (stat == ERR_NORMAL)
         {
         if (ibuf[1] == F_TBL_TYPE)
            ity = 2;
         else
            {
            k = 0;
            ity = 1;
            }
         }
      else
         {
         ERRORS.SYS = 36;
         return;
         }
      }

   if (KIWORDS[OFF_AUX+15] == 1)	/* ESO-DESC_ignore_flag set? */
      nn = 1;				/* Yes => read no ESO.xyz keywds */
   else
      nn = 0;				/* No. */
   (void) SCPSET(F_FITS_PARM,&nn);

   if (ity == 1)				/* open image */
      {
      if (k < 0)
         {
         nn = CGN_singleframe(filnam,F_IMA_TYPE,kframe); /* check for &a, ...*/
         if (nn != 0) fptr = kframe;		/* depending upon transl. */
         }
      CGN_CLEANF(fptr,F_IMA_TYPE,temp,FCT_NAME_LEN,&k,&nn);
      if (nn < 0)			/* if we have a FITS extension */
         jent = -1;			/* force fresh openeing! */
      else
         jent = MID_FINDFR(temp);

      if (jent < 0)				/* not opened yet */
         stat = SCFOPN(fptr,D_R4_FORMAT,0,F_OLD_TYPE,entrx);
      else
         stat = MID_ACCFRM(temp,0,entrx,ibuf);
      }
   else if (ity == 2)				/* open table */
      {
      nn = CGN_singleframe(filnam,F_TBL_TYPE,kframe);	/* check for &a, ...*/
      if (nn != 0)				/* depending upon transl. */
         fptr = kframe;
      CGN_CLEANF(fptr,F_TBL_TYPE,temp,FCT_NAME_LEN,&k,&nn);

      jent = MID_FINDFR(temp);
      if (jent < 0)				/* not opened yet */
         {

#if vms 
         stat = TCTOPN(fptr,F_IO_MODE,entrx);
         if (stat != ERR_NORMAL)
            stat = TCTOPN(fptr,F_I_MODE,entrx);

#else
         jent = open(temp,O_RDWR);	 /* check, if READ+WRITE */
         if (jent == -1)			/* No. */
            stat = TCTOPN(fptr,F_I_MODE,entrx);
         else
            {
            close(jent); 
            stat = TCTOPN(fptr,F_IO_MODE,entrx);
            }
#endif

         }
      else		
         stat = MID_ACCFRM(temp,0,entrx,ibuf);
      }

   if (stat != ERR_NORMAL)
      {
      ERRORS.SYS = 44;
      *entrx = -1;
      return;
      }

   jent = (*entrx);

   for (nr=0; nr<MAX_FRAME; nr++)               /* check, if already there */
      {
      if (jent == FRAME[nr].ENTRY) return;
      }

                              
/* now loop through table FRAME_STRUCT + look for free entry  */

   for (nr=0; nr<MAX_FRAME; nr++)               /* search for free entry  */
      {
      if (FRAME[nr].ENTRY < 0)
         {
         k = nr;
         goto add_entry;
         }
      }


/* no free entry, so we get rid of oldest file */

   k = 0;
   nn = FRAME[0].LEVEL;
   for (nr=1; nr<MAX_FRAME; nr++)               /* search for oldest entry  */
      {
      if (FRAME[nr].LEVEL < nn)
         {
         k = nr;
         nn = FRAME[nr].LEVEL;
         }
      }

   if (FRAME[k].TYPE == 1)
      stat = SCFCLO(FRAME[k].ENTRY);
   else
      stat = TCTCLO(FRAME[k].ENTRY);
   if (stat != ERR_NORMAL)
      {
      ERRORS.SYS = 36;
      *entrx = -1;
      return;
      }

add_entry:
   FRAME[k].ENTRY = jent;
   FRAME[k].TYPE = ity;
   FRAME[k].LEVEL = level_now++;

   MONIT.FRAME_USED = 'x';
   }

else
   {
   if (level_now == 0) return;                  /* nothing to do */

   if (actio == 'X')				/* close all frames */
      {
      for (nr=0; nr<MAX_FRAME; nr++)
         {
         if (FRAME[nr].ENTRY >= 0)
            {
            if (FRAME[nr].TYPE == 1)
               stat = SCFCLO(FRAME[nr].ENTRY);
            else
               stat = TCTCLO(FRAME[nr].ENTRY);
            FRAME[nr].ENTRY = -1;
            }
         }
      }

   else if (actio == 'C')				/* close a frame */
      {
      jent =  *entrx;
      for (nr=0; nr<MAX_FRAME; nr++)
         {
         if (FRAME[nr].ENTRY == jent)
            {
            if (FRAME[nr].TYPE == 1)
               stat = SCFCLO(jent);
            else
               stat = TCTCLO(jent);
            FRAME[nr].ENTRY = -1;
            break;
            }
         }

      for (nr=0; nr<MAX_FRAME; nr++)		/* check, if any is left */
         {
         if (FRAME[nr].ENTRY >= 0) return;
         }
      }
   else						/* only INIT is left... */
      {
      for (nr=0; nr<MAX_FRAME; nr++)
         FRAME[nr].ENTRY = -1;
      }

   level_now = 0;
   MONIT.FRAME_USED = ' ';
   }

}
/*

*/

int PIXEL_ACCESS(flag,string,value)
/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  return value of image frame at given coordinates
.ALGORITHM
  open frame + get to pixel in a subroutine
.RETURNS
  status: MIDAS error codes
------------------------------------------------------------------*/

int   flag;		/* IN: = 0, read pixel value     
			       = 1, write pixel value   */
char  *string;		/* IN: string with frame[x,y,z] */
float *value;		/* IN/OUT: pixel value at frame[x,y,z]  */

{
int   stat, n, nco, entrx, npix[3], unit, iav;
int   ioffz, ioffy, sublo[3], subhi[3];



for (n=0; n<3; n++)
   {
   sublo[n] = 0;
   npix[n] = 1;
   }

nco = CGN_INDEXC(string,'[');		/* split frame and coords string  */
string[nco] = '\0';
iav = CGN_singleframe(string,F_IMA_TYPE,KAUX.OUT);	
if (iav == 0) (void) strcpy(KAUX.OUT,string);	/* always fill output name */
string[nco] = '[';			/* reset string */

FRAMACC('O',KAUX.OUT,1,&entrx);		/*  open the image + get NPIX */
if (entrx < 0) goto sect_9000;

stat = SCDRDI(entrx,"NPIX",1,3,&iav,npix,&unit,&n);
if (stat != ERR_NORMAL) goto sect_9000;
 
stat = Convcoo(0,entrx,&string[nco],3,&iav,sublo,subhi);
if (stat != ERR_NORMAL) 
   {
   ERRORS.SYS = 45;
   FRAMACC('C',KAUX.OUT,1,&entrx);                    /* close file */
   return (-1);
   }

if (sublo[2] > 0)
   ioffz = npix[0] * npix[1] * sublo[2];
else
   ioffz = 0;
ioffy = npix[0] * sublo[1];
nco = ioffz + ioffy + sublo[0] + 1;

if (flag == 0)					/*  read or write value  */
   n = SCFGET(entrx,nco,1,&iav,(char *)value);
else
   n = SCFPUT(entrx,nco,1,(char *)value);
if (n == ERR_NORMAL) return (0);


sect_9000:					/*  problems, problems...   */
ERRORS.SYS = 100;
return (-1);
}
/*

*/

int CODE_ALLOC(size)

/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  allocate `size' bytes memory for CODE
.ALGORITHM
  use malloc + free
.RETURNS
  return status = 0, if all o.k., = 1, if problems in allocating memory
----------------------------------------------------------------------*/

int   size;   /* IN: no. of bytes for allocation */

{
int   n, levl;


if (size <= 0) size = CODE_INSIZE;		/* default size */

levl = MONIT.LEVEL - 1;
n = TRANSLATE[levl].LEN[0];			/* get size at current level */


if (n >= size)      			/* enoguh space in CODE.CODE */
   {
   CODE.LEN = TRANSLATE[levl].LEN[0];
   CODE.CODE = TRANSLATE[levl].PNTR[0];
   KIWORDS[OFF_MONPAR+7] = size;	/* save also in key MONITPAR(8) */
   return (0);
   }


if (n > 0)				/* we need larger space, now */
   {
   free(TRANSLATE[levl].PNTR[0]);
   TRANSLATE[levl].PNTR[0] = NULL;
   TRANSLATE[levl].LEN[0] = 0;
   }

if (n < 0) 
   {
   printf("TRANSLATE[%d].LEN[0] = %d\n",levl,n);
   return (1);
   }
					/* if n = 0, nothing allocated yet */
CODE.CODE = malloc((size_t) size);
if (CODE.CODE == (char *) 0)		/* problems with memory allocation */
   {
   return (1);
   }

n = CODE_START;
memset((void *)CODE.CODE,0,(size_t)n);	/* clear header section */

TRANSLATE[levl].PNTR[0] = CODE.CODE;
TRANSLATE[levl].LEN[0] = size;
CODE.LEN = size;
KIWORDS[OFF_MONPAR+7] = size;           /* save also in key MONITPAR(8) */
return (0);
}
/*

*/

void CODE_FREE(levl,indx)

/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  clear memory which was allocated for CODE
.ALGORITHM
  use free
.RETURNS
  nothing
----------------------------------------------------------------------*/

int   levl;   /* IN: MONIT level we work on */
int   indx;   /* IN: index for TRANSLATE array,               \
			  = 0 for normal CODE, = 1 for PAUSE code */

{
register int  nr;


if (indx != 0) indx = 1;

for (nr=levl; nr<MAX_LEVEL; nr++)
   {
   if (TRANSLATE[nr].LEN[indx] != 0)
      {
      free(TRANSLATE[nr].PNTR[indx]);
      TRANSLATE[nr].LEN[indx] = 0;
      }
   }

}
/*

*/
 
int INTERNAL(action,name,nobytes)
	
/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  provide the interface to the file MID_PROC:internal.cod,
  which holds all "compiled" MIDAS (system) procedures
.ALGORITHM
  The file MID_PROC:internal.cod is organized as follows:
  first 4 records (of 512 bytes) hold the procedure names of max. 12 chars
  (without the terminating '\0'),
  the end of this area is indicated via '&&' .
  Records 5+6 hold the array of start blocks and no. of bytes for each 
  compiled procedure stored as two unsigned short int numbers,
  the end of this area is indicated via a start block of 0.
  Thus the header info is stored in the first 3072 bytes of the file.
  The following records hold the translated code for each procedure, each
  beginning at a record.
  The end of the written records is indicated by a record beginning
  with 20 blanks.

  internal.exe handles the file internal.cod within Midas, 
  whereas internal1.exe can be used in the normal host environment
  for usage info enter (in the monit dir.): ./internal1.exe ?
.RETURNS
  return status			0 = o.k., else not...!
--------------------------------------------------------------------*/
 
char  *action;	/* IN: action flag,                                    
 		       = OPEN for opening the file internal.cod, .kod  
		       = CLOSE for closing the file                   
		       = ADD for adding another entry +  code        
		       = FIND for finding an entry + reading the code */
 
char  *name;	/* IN: name of procedure, for A or F      
		       max. 12 chars. and terminator;
                       = KOD or COD for action = OPEN */
int   *nobytes;	/* IO: length of procedure, input for A, output for F */
 
{
#define BIT_0    0x1
#define head_len 3072
	/* PROC_MXLEN must be synchronised with internal.c, internal1.c ! */
#define PROC_MXLEN   12		

 
int     mm, n, flen, stat;
int     noblocks=0;
register int nr;
static unsigned short int   *rec_nos;
static int   whichopen, NoProcs;
static int   iochan = -1;

char  *cpntr;
char  fulname[PROC_MXLEN];
static char  *headrec = NULL;		/* point to header record  */
static char  **ptrarr;			/* the pointer array */
 


 
	
/*  find procedure + translated code   */

if (*action == 'F')
   {
   if (iochan == -1) return 2;

   flen = (int)strlen(name);			/* common part for both */
   if (flen > PROC_MXLEN) return(3);

   memset((void *)fulname,32,(size_t)PROC_MXLEN);
   (void) strncpy(fulname,name,flen);
	

/* file internal.cod is written once, then we only read and
   extract the relevant procedure code                       */

   cpntr = headrec;
   mm = 0;
   for (nr=0; nr<NoProcs; nr++)
      {						/* locate procedure name  */
      if (strncmp(cpntr,fulname,PROC_MXLEN) == 0) goto get_recno;
      mm += 2;
      cpntr += PROC_MXLEN;
      }
   return (1);					/* procedure not found! */
 
	
   /*  now get the start block and length   */
 
  get_recno:
   *nobytes = rec_nos[mm+1];
   cpntr = ptrarr[nr];

   if (cpntr == (char *) 0)			/* not stored in memory yet */
      {
      stat = OSY_RVB(iochan,CODE.CODE,*nobytes,rec_nos[mm]);
      if (stat != 0) return (1);	

      cpntr = (char *) malloc((size_t)*nobytes);
      if (cpntr == (char *) 0) return (-1);

      (void) memcpy(cpntr,CODE.CODE,(size_t)*nobytes);
      ptrarr[nr] = cpntr;
      }
   else
      (void) memcpy(CODE.CODE,cpntr,(size_t)*nobytes);	/* already there */

   CODE.CODE[(*nobytes)] = '\0';
   return (0);
   }
 
	
/*  add a procedure + translated code   */

if (*action == 'A')
   {
   if (iochan == -1) return 2;
	
   flen = (int)strlen(name);			/* common part for both */
   if (flen > PROC_MXLEN) return(3);

   memset((void *)fulname,32,(size_t)PROC_MXLEN);
   (void) strncpy(fulname,name,flen);
	
   /*  since we update the header, we always have to read it in first */
   if (OSY_RVB(iochan,headrec,head_len,1) != 0) return (1);

   cpntr = headrec;
   mm = 0;
   n = 0;					/* found_switch */
   for (nr=0; nr<NoProcs; nr++)
      {                                         /* locate procedure name  */
      if (strncmp(cpntr,fulname,PROC_MXLEN) == 0)
         {
         n = 1;
         break;
         }
      else if ((*cpntr == '&') && (*(cpntr+1) == '&')) break;

      mm += 2;
      cpntr += PROC_MXLEN;
      }
	
   if (n < 1) 					/*  if not found ...    */
      {
      if ((*cpntr == '&') && (*(cpntr+1) == '&')) 
         {
         (void)strncpy(cpntr,fulname,PROC_MXLEN);
         cpntr += PROC_MXLEN;
         *cpntr++ = '&';		/* insert new end marker */
         *cpntr = '&';
         }
      else
         {
         (void) printf
         ("Overflow in internal.cod, more than 100 procedures...\n");
         return (1);
         }
      }
	
   /*  now rewrite header records (1-6) and code record(s)  */
 
   n = KIWORDS[OFF_MONPAR+10];		/* MONITPAR(11) = debug flag */
   if (opti_code(nobytes,0,n) != 0)	/* optimize code for system proc. */
      {
      (void) printf("code optimization failed...\n");
      return (3);
      }

   if (*nobytes > CODE_INSIZE)
      {
      (void) printf
      ("Overflow in code, more than %d chars. in procedure\n",CODE_INSIZE);
      return (1);
      }

   noblocks = ( (*nobytes - 1) / OUR_BLOCK_SIZE ) + 1 ;
   rec_nos[mm+1] = (unsigned short int) *nobytes;
   rec_nos[mm+2] = rec_nos[mm] + (unsigned short int) noblocks;
   stat = OSY_WVB(iochan,headrec,head_len,1);
   if (stat == 0)
      stat = OSY_WVB(iochan,CODE.CODE,*nobytes,rec_nos[mm]);
   if (stat != 0)
      return (1);
   else
      return (0);
   }


/*  open file MID_PROC:internal.cod or .kod   */

if (*action == 'O')
   {
   char	file[200];

if (headrec != NULL)
   {
   free (headrec);
   }

   headrec = (char *) malloc((size_t)head_len);
   if (headrec == (char *) 0) return (-1);

   rec_nos = (unsigned short int *) (headrec+2048);
   NoProcs = 2048 / PROC_MXLEN;

   (void) OSY_TRNLOG("MID_PROC",file,200,&mm);

#if vms
   if (file[mm-1] != FSY_DISKEND)
      {
      if (file[mm-1] != FSY_DIREND) file[mm++] = FSY_DIREND;
      }
#else
   if (file[mm-1] != FSY_DIREND) file[mm++] = FSY_DIREND;
#endif

   (void)strcpy(&file[mm],"internal.cod");
   mm = (int)strlen(file);
   if (*name == 'K') 
      {
      whichopen = 2;
      file[mm-3] = 'k';		/* .kod instead of .cod */
      }
   else
      whichopen = 1;
 
   FSY_OPNFIL(file,mm,&iochan,&stat);
   if ( !(stat & BIT_0))				/* file open o.k. */
      {
      iochan = -1;
      return (2);				/*  no. some problems...  */
      }
      
   /* get header info into memory */

   if (OSY_RVB(iochan,headrec,head_len,1) != 0) return (1);

   /* get the no. of procedures and allocate memory for the
      pointer array, init them to 0 first */

   cpntr = headrec;
   for (nr=0; nr<NoProcs; nr++)
      {					/* search for end marker */
      if (strncmp(cpntr,"&&",2) == 0) 
         {
         noblocks = nr;			/* actual no. of translated procs */
         break;
         }
      cpntr += PROC_MXLEN;
      }

   if (*name == 'C')
      {					/* internal.kod for TRANSLATE/ADD */
      ptrarr = (char **) malloc((size_t)(noblocks*sizeof(char *)));
      if (ptrarr == (char **) 0) return (-1);

      for (nr=0; nr<noblocks; nr++) ptrarr[nr] = (char *) 0;
      } 
   return (0);				/*  successful  */
   }
 
	
/*  release memory + close file   */
 
if (*action == 'C')
   {
   if (iochan > -1)
      {
      (void) OSY_DASSGN(-1,iochan);
      iochan = -1;
      }

   if (whichopen == 2)
      {					/* we filled internal.kod */
      cpntr = headrec;

      for (nr=0; nr<NoProcs; nr++) 
         {                                         /* locate procedure name  */
         if ((*cpntr == '&') && (*(cpntr+1) == '&')) break;
         cpntr += PROC_MXLEN;
         }
      if (nr > 0)
         {
         (void) printf("%d procedures added\n",nr);	
         (void) printf("---------------------\n");
         }
      }
   whichopen = 0;
   return (0);
   }
 
else
   return 9;				/* invalid action */

}
/*

*/

void fixout(run,curlevl)
int  run;		/* IN: = 0. end of procedure - go back up a level
			         1, start a program */
int  curlevl;		/* IN: current procedure level (MONIT.LEVEL) */

{
int    savnr, newlevl, iolevl;
register int   fp, nr;


if (KIWORDS[OFF_OUTFLG] == 99) return;			/* nothing to do */
savnr = 0;

if (run == 0)			/* go up a level */
   {
   if (curlevl == 0)			/* we're at interactive level */
      {					/* clean up everything */
      for (nr=0; nr<5; nr++)
         {
         if (REDIRECT[nr].OUTFLAG[0] != 99)
            {
            fp = REDIRECT[nr].OUTFLAG[2];
            if ((fp > 0) && (fp < 999)) 
               (void) osaclose(fp);
            REDIRECT[nr].OUTFLAG[0] = 99;
            REDIRECT[nr].OUTFLAG[1] = 0;
            REDIRECT[nr].OUTFLAG[2] = -1;
            REDIRECT[nr].OUTFLAG[3] = -1;
            }
         }

      fp = KIWORDS[OFF_OUTFLG+2];		/* here, work on files */
      if ((fp > 0) && (fp < 999)) 		/* opened in the monitor */
         {
         (void) osaclose(fp);
         KIWORDS[OFF_OUTFLG+2] = -1;
         }

      KIWORDS[OFF_OUTFLG] = 99;
      KIWORDS[OFF_OUTFLG+1] = 0;	
      KIWORDS[OFF_OUTFLG+3] = -1;	
      return;
      }



   if (KIWORDS[OFF_OUTFLG] >= curlevl)
      {
      for (nr=0; nr<5; nr++)
         {
         iolevl = REDIRECT[nr].OUTFLAG[0];
         if ((iolevl != 99) && (iolevl >= curlevl))
            {
            fp = REDIRECT[nr].OUTFLAG[2];
            if ((fp > 0) && (fp < 999)) 
               {
               (void) osaclose(fp);
               REDIRECT[nr].OUTFLAG[2] = -1;
               REDIRECT[nr].OUTFLAG[3] = -1;
               }
            REDIRECT[nr].OUTFLAG[1] = 0;
            REDIRECT[nr].OUTFLAG[0] = 99;
            break;
            }
         }

      fp = KIWORDS[OFF_OUTFLG+2];		/* only this one set, if */
      if ((fp > 0) && (fp < 999))		/* done in monitor */
         {
         (void) osaclose(fp);
         KIWORDS[OFF_OUTFLG+2] = -1;
         KIWORDS[OFF_OUTFLG+3] = -1;
         }


      newlevl = -1;			/* look for I/O changes before */
      for (nr=0; nr<5; nr++)		/* but take the last one */
         {
         iolevl = REDIRECT[nr].OUTFLAG[0];
         if ((iolevl != 99) && (newlevl < iolevl))
            {
            savnr = nr;
            newlevl = iolevl;
            }
         }

      if (newlevl != -1)
         {				/* copy flags + file name */
         for (nr=0; nr<4; nr++)
             KIWORDS[OFF_OUTFLG+nr] = REDIRECT[savnr].OUTFLAG[nr];
         (void) strcpy(&KCWORDS[OFF_OUTNAM],REDIRECT[savnr].OUTFILE);
         /* KIWORDS[OFF_OUTFLG+3] = -2;	this caused trouble!! */
         }
      else
         {
         KIWORDS[OFF_OUTFLG] = 99;
         KIWORDS[OFF_OUTFLG+1] = 0;
         KIWORDS[OFF_OUTFLG+2] = -1;
         KIWORDS[OFF_OUTFLG+3] = -1;	
         }
      }

   else
      {
      fp = KIWORDS[OFF_OUTFLG+2];
      if ((fp > 0) && (fp < 999))	/* output file already open */
         KIWORDS[OFF_OUTFLG+3] = -2;	/* so we can append */
      }
   }


else				/* or prepare for application */
   {
   fp = KIWORDS[OFF_OUTFLG+2];
   if ((fp > 0) && (fp < 999))
      {					/* file already used in monitor */
      (void) osaclose(fp);
      KIWORDS[OFF_OUTFLG+2] = -1;
      KIWORDS[OFF_OUTFLG+3] = -2;	/* so we can append */
      }
   }
}
/*

*/

int opti_code(nb,option,dflag)
/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
  optimize the code of a compiled procedure
.ALGORITHM
.RETURNS
---------------------------------------------------------------------*/
int  *nb;               /* IN/OUT: no. of bytes of code */
int  option;		/* IN: = 0, optimize for TRANSL/ADD
			       = 1, optimize for TRANSL/PROC */
int  dflag;		/* IN: = 1, save input, output code on file,
			       = 0, no save (for debugging )	   */

{
int   jj, kk, dd, m, mm, nc, label_used;
int   retstat, lenA, lenB, offset, double_lab, offmin;

char  *cpntr, *xpntr, *opntr, *tpntr, *dpntr, *savpntr;
char  labelA[24], labelB[24], labelUp[24];
static char *fmts[6] = {"%03.3d", "%04.4d", "%05.5d", "%06.6d",
                        "%07.7d", "%08.8d"};

void opti_info();




lenA = 0;
opntr = (char *)0;
nc = (*nb - CODE_START);			/* current size of code */

offmin = 3;
if (nc > 999)
   {					/* get no. of digits needed */
   if (nc > 9999)			/* for offsets */
      {
      if (nc > 99999) 
         offmin = 6;
      else
         offmin = 5;
      }
   else
      offmin = 4;
   }


m = nc + 4;			
cpntr = (char *) malloc((size_t) m);		/* for security */
if (cpntr == (char *) NULL)
   {
   (void) printf("could not allocate memory for optimized code ...\n");
   retstat = 1;
   goto free_them;
   }
(void) memcpy(cpntr,&CODE.CODE[CODE_START],(size_t)nc);
*(cpntr+nc) = '\r';
*(cpntr+nc+1) = '\0';
savpntr = cpntr;

if (dflag == 1) opti_info(cpntr,1);


/* -------------------------- first step ------------------------- */
/* check if last command is a label                                */

start_job:
tpntr = cpntr;					/* point to start of code */
double_lab = 0;		/* if set, we have a double label in the end */
dpntr = xpntr = tpntr;
kk = 0;

read_1:				/* get a line from orig code */
m = CGN_INDEXC(tpntr,'\r');
if (m > 0) 			/* process line */
   {
   dpntr = tpntr;			/* keep last offset */
   xpntr = tpntr + m - 1; 		/* point to last char of that line */
   tpntr += (m+1);
   kk = m;				/* save length of line */
   goto read_1;
   }
    
/* m = 0 in the end of the CODE section */

if (m == 0)
   {					/* end of code reached */
   dd = is_label(dpntr,xpntr);
   if ((dd == 1) && (kk > 4)) 		/* we got a label */
      {
      lenA = kk - 1;			/* kk = length of line before */
      (void) strncpy(labelA,dpntr,lenA);	/* omit trailing ':' */
      labelA[lenA] = '\0';
      jj = noprocess(labelA,cpntr);
      if (jj == 1) goto next_job;

      (void) strcpy(labelB,"*RE");
      lenB = 3;
      *dpntr++ = '\r';			/* indicate new end */
      *dpntr++ = '\r';
      *dpntr = '\0';
      if (dflag > 0)
         (void) printf("removing last label `%s'\n",labelA);
      }
   else
      goto next_job;			/* No, do next job */
   }
else					
   {					/* we should never come here! */
   retstat = 3;
   printf("CODE out of sync...!\n");
   goto free_them;
   }

/* we get here only if last command is a label 
   so, replace all references to that label with '*RE'  */

tpntr = cpntr;				/* reset to start of code */

read_10:	
m = CGN_INDEXC(tpntr,'\r');
if (m > 0) 
   {
   if (*tpntr == '*')			/* look for *IF, *GO only */
      {
      opntr = tpntr + 1;
      if ((strncmp(opntr,"IF",2) == 0) || (strncmp(opntr,"GO",2) == 0))
         {
         *(tpntr + m) = '\0';		/* replace \r by \0 for the moment */
         jj = CGN_JNDEXC(tpntr,' ');	/* search from the end */
         if (jj < 3)
            {
            printf("code: %20.20s\n",tpntr);
            goto errors;
            }

         xpntr = opntr + jj;		/* get to label itself */
         if (strcmp(xpntr,labelA) == 0)
            {
            double_lab = 1;
            if (*opntr == 'G')
               xpntr = tpntr;		/*  *GO label  =>  *RE  */
            (void) strcpy(xpntr,labelB);
            dpntr = xpntr + lenB;
            *dpntr++ = '\r';            /* overwrite '\0' with '\r' */
            if (lenA > lenB)
               CGN_strcpy(dpntr,tpntr+m+1);
            tpntr = dpntr;
            goto read_10;
            }
         *(tpntr + m) = '\r';		/* reset */
         }
      }
   tpntr += (m+1);				/* move on */
   goto read_10;
   }
else
   {
   if (double_lab == 0) 
      (void) printf("last label `%s' not used...\n",labelA);
   else
      goto start_job;		/* do it again */
   }


/* ------------------------- second step ------------------------- */
/* remove double labels                                            */

double_lab = 0;		/* if set, we had a double label */


next_job:
tpntr = cpntr;
mm = 0;			/* serves as previous label flag */

read_2:
m = CGN_INDEXC(tpntr,'\r');
if (m == 0) 
   {
   if (double_lab == 1)		/* once more, to also get triple labels */
      {
      double_lab = 0;
      goto next_job;
      }
   else
      {
      savpntr = cpntr;
      goto next_next_job;		/* no more double labels found */
      }
   }

xpntr = tpntr + m - 1; 		/* point to last char of that line */
dpntr = tpntr;
dd = is_label(dpntr,xpntr);
if (dd == 1)				/* we got a label */
   {
   if (mm == 1)
      {					/* second label found */
      int  n;
      char temp[24];

      lenB = m - 1;			/* size of labelB (without `:') */
      (void) strncpy(labelB,dpntr,lenB);
      labelB[lenB] = '\0';
      if (lenA < lenB)
         {				/* use shorter label as labelB */
         (void) strcpy(temp,labelB);
         (void) strcpy(labelB,labelA);
         (void) strcpy(labelA,temp);
         n = lenB;
         lenB = lenA;
         lenA = n;
         }
      CGN_UPSTR(labelA);
      CGN_UPSTR(labelB);

      /* but first we have to check, that the label is not used
         by a BRANCH (*BR) command ...                          */
      
      n = noprocess(labelA,cpntr); 
      if (n == 1)			/* Yes, so skip this one */
         dd = 0;
      else
         {
         double_lab = 1;
         (void) strcpy(opntr,labelB);	/* labelA overwritten with labelB */
         opntr += lenB;
         *opntr++ = ':';
         *opntr++ = '\r';
         CGN_strcpy(opntr,tpntr+m+1);	/* overwrite second label */
         if (dflag > 0)
            (void) printf("working on double labels `%s' + `%s'\n",
                          labelA,labelB);
         goto duplicate_labels;
         }
      }
   else
      {
      lenA = m - 1;				/* size of labelA */
      (void) strncpy(labelA,dpntr,lenA);	/* omit trailing ':' */
      labelA[lenA] = '\0';
      opntr = dpntr;			/* save offset */
      }
   }
mm = dd;			/* save it */

tpntr += (m+1);			/* move to next line */
goto read_2;


duplicate_labels:
label_used = 0;
tpntr = cpntr;

read_20:
m = CGN_INDEXC(tpntr,'\r');
if (m != 0)
   {
   if (*tpntr == '*')              /* look for *IF, *GO, *INC */
      {
      opntr = tpntr + 1;
      if ((strncmp(opntr,"IF",2) == 0) ||
          (strncmp(opntr,"GO",2) == 0) ||
          (strncmp(opntr,"INC",3) == 0))
         {
         *(tpntr + m) = '\0';		/* replace \r by \0 for the moment */
         jj = CGN_JNDEXC(tpntr,' ');
         if (jj < 3)
            {
            printf("code: %20.20s\n",tpntr);
            goto errors;
            }
         xpntr = opntr + jj;		/* get to label itself */
         CGN_UPCOPY(labelUp,xpntr,24);	/* copy to uppercase */
         if (strcmp(labelUp,labelA) == 0)
            {
            label_used ++;
            (void) strcpy(xpntr,labelB);	
            dpntr = xpntr + lenB;
            *dpntr++ = '\r';		/* overwrite '\0' with '\r' */ 
            if (lenA > lenB) 		/* copy (compact) rest of CODE */
               CGN_strcpy(dpntr,tpntr+m+1); 
            tpntr = dpntr;
            goto read_20;
            }
         *(tpntr + m) = '\r';			/* reset */
         }
      }
   tpntr += (m+1);
   goto read_20;
   }

if (label_used == 0)
   (void) printf(">>>>> double label `%s' not used...\n",labelA);
goto next_job;


/* ----------------------------- third step ---------------------------- */
/* translate all labels (with size > offmin (up to 8) chars) to offsets  */

next_next_job:
tpntr = savpntr;

read_3:
label_used = 0;
m = CGN_INDEXC(tpntr,'\r');
if (m == 0) goto end_of_it;		/* no more labels found, we're done */

if ((m > offmin) && (m < 9))		/* supported length of label */
   {
   xpntr = tpntr + m - 1; 		/* point to last char of that line */
   dpntr = tpntr;
   dd = is_label(dpntr,xpntr);
   if (dd == 1)				/* we got a label */
      {
      lenA = m - 1;
      (void) strncpy(labelA,dpntr,lenA);	/* omit trailing ':' */
      labelA[lenA] = '\0';
      CGN_UPSTR(labelA);

      kk = noprocess(labelA,cpntr);	/* check that it's not from a *BR */
      if (kk == 0)			/* No, so get it's offset */
         {
         if (dflag > 0)
            (void) printf("processing label `%s'\n",labelA);
         savpntr = tpntr;			/* save position */
         offset = tpntr - cpntr + CODE_START;	/* offset of this line */
         CGN_strcpy(tpntr,tpntr+m+1);	/* copy (compact) rest CODE */

         jj = m - 4;				/* get format for offset */
         sprintf(labelB,fmts[jj],offset);	/* 1234: => fmts[1]: %04.4d */
         lenB = (int)strlen(labelB);
         goto replace_labels;
         }
      }
   }

tpntr += (m+1);			/* move to next line */
goto read_3;


replace_labels:
tpntr = cpntr;

read_30:
m = CGN_INDEXC(tpntr,'\r');
if (m != 0)
   {
   if (*tpntr == '*')			/* look for *IF, *GO, *INC */
      {
      opntr = tpntr + 1;
      if ((strncmp(opntr,"IF",2) == 0) ||
          (strncmp(opntr,"GO",2) == 0) ||
          (strncmp(opntr,"INC",3) == 0))
         {
         *(tpntr + m) = '\0';			/* move \r to \0 for now */
         jj = CGN_JNDEXC(tpntr,' ');
         if (jj < 3)
            {
            printf("code: %20.20s\n",tpntr);
            goto errors;
            }

         xpntr = opntr + jj;		/* get to label itself */
         CGN_UPCOPY(labelUp,xpntr,24);
         if (strcmp(labelUp,labelA) == 0)
            {
            label_used ++;
            *opntr = 'J';		/* *GO/ *IF/ *INC  =>  *JO/ *JF/ *JNC */
            (void) strcpy(xpntr,labelB);
            dpntr = xpntr + lenB;
            }
         *(tpntr + m) = '\r';			/* reset */
         }
      }
   tpntr += (m+1);
   goto read_30;
   }

if (label_used == 0)
   (void) printf(">>>>> label `%s' not used...\n",labelA);
goto next_next_job;				/* look for next label */


/* ------------------------- fourth step ------------------------- */

end_of_it:		
*(tpntr+1) = '\0';
mm = nc;
nc = (int) strlen(cpntr);			/* new size of code */

if (option == 1)			/* TRANSLATE/PROC procedure */
   {
   opti_info(cpntr,0);			/* set counter to 0 -> unique name */
   dflag = 1;
   }

if (dflag == 1)
   opti_info(cpntr,2);

*nb = CODE_START + nc;				/* update length */
CGN_strcpy(&CODE.CODE[CODE_START],cpntr);
retstat = 0;
goto free_them;


errors:
SCTPUT("parsing problems in *IF/*GO line");
retstat = 2;


free_them:
free(cpntr);
return retstat;
} 

/*

*/

int is_label(pntra,pntrb)
char   *pntra, *pntrb;

{
int  jj;

register char  cc;


cc = *pntrb;
if (cc != ':') return (0);

*pntrb = '\0';
jj = CGN_INDEXC(pntra,' ');
*pntrb = cc;

if (jj < 1)
   return (1);
else
   return (0);
}
/*

*/

void opti_info(kpntr,flag)
char  *kpntr;
int  flag;

{
int  fid, m;
static int deb_count = 0;

char  *pntr, temp[20];



pntr = kpntr;			/* leave kpntr unchanged */

if (flag == 0)
   {
   deb_count = 0;		/* so we have a fixed output name... */
   return;
   }

if (flag == 1)
   (void) sprintf(temp,"input%d.cprg",deb_count);
else
   (void) sprintf(temp,"output%d.cprg",deb_count++);

fid = osaopen(temp,1);               /* open for writing */
if (fid < 0)
   printf("Could not open ASCII file `input.cprg' ...\n");
    
else
   {
  debug_read:
   m = CGN_INDEXC(pntr,'\r');
   if (m == 0)
      {
      osaclose(fid);
      return;
      }
   else if (m < 0)
      {
      osaclose(fid);
      (void) printf("opti_info: flag = %d, m = -1 ...!\n",flag);
      return;
      }
   else
      {
      *(pntr+m) = '\0';
      (void) osawrite(fid,pntr,(int)strlen(pntr));
       *(pntr+m) = '\r';
      pntr += (m+1);
      goto debug_read;
      }
   }
}
/*

*/

int noprocess(label,kpntr)
/* ++++++++++++++++++++++++++++++++++++++++++++++++++++

if a label is used in a BRANCH (*BR) or STORE/FRAME command
it cannot be removed

++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
char   *label, *kpntr;

{
char  *tpntr, *xpntr;
char  cbuf[24];

int  m, jj, start, ln;



tpntr = kpntr;

read:
m = CGN_INDEXC(tpntr,'\r');
if (m != 0)
   {
   if (*tpntr == '*')			/* look for *BR test_str label_str */
      {
      *(tpntr + m) = '\0';		/* replace \r by \0 for the moment */
      if ((*(tpntr+1) == 'B') && (*(tpntr+2) == 'R'))
         {
         jj = CGN_JNDEXC(tpntr,' ');	/* go backwards */
         xpntr = tpntr + jj + 1;	/* get to label string */
         ln = (int) strlen(xpntr);
         start = 0;			/* extract each label */
         while (CGN_EXTRSS(xpntr,ln,',',&start,cbuf,24) > 0)
            {
            CGN_UPSTR(cbuf);		/* label is UpperCase! */
            if (strcmp(label,cbuf) == 0) 
               {
               (void) 
               printf("label `%s' used in BRANCH -> not processed\n",label);
               *(tpntr + m) = '\r';	/* reset */
               return 1;		/* Yes, label is used in *BR command */
               }
            }
         }
      *(tpntr + m) = '\r';                 /* reset */
      }

   else if (strncmp(tpntr,"STOR",4) == 0)
      {					/* look for STORE/FRAME . . . label */
      *(tpntr + m) = '\0';              /* replace \r by \0 for the moment */
      ln = CGN_INDEXC(tpntr,'/');
      if ((ln > 0) && (*(tpntr+ln+1) == 'F'))
         {
         jj = CGN_JNDEXC(tpntr,' ');	/* go backwards */
         xpntr = tpntr + jj + 1;		/* get to label string */
         ln = (int) strlen(xpntr);
         CGN_UPCOPY(cbuf,xpntr,ln+1);
         if (strcmp(label,cbuf) == 0) 
            {
            (void)
            printf("label `%s' used in STORE/FRAME -> not processed\n",label);
            *(tpntr + m) = '\r';	/* reset */
            return 1;		/* Yes, label is used in *BR command */
            }
         }
      *(tpntr + m) = '\r';                 /* reset */
      }

   tpntr += (m+1);
   goto read;
   }

return 0;
}
