/* GRBL2 Useful procedures
   Created by Daniel Hellerstein, April 2004

  This contains a number of utility procedures.

Usage:
      include at the top of your main program file (that implements your model):
           #include grbl2_procs.inc ;
      This assumes that grblbat1.in either in the current directory, or in GAUSS's
      path.

Full documentation:
    See GRBL2_PROCS.TXT for a complete description of these procedures.


NOte: GRBL2_BATCH uses these procedures 
*/


/** global variables (used a few places below */

clear verbose,varlist,filename ;
clear g_add_suffix_char,g_add_suffix_maxlen;
g_add_suffix_char="_"; g_add_suffix_maxlen=8;

clear grbl2_program,grbl2_errfile,grbl2_errflag ;

struct minfo_s  {
   scalar neq ;   @ # of equations, max of 10 @
   matrix names ;   @ neq x 1 vector of new varnames (up to 10, neq+1 to 10 are ignored)@
   matrix nterms ;   @ neq x 1 vector of # of terms in each equation @
   matrix vtypes ;  @ matrix of  VAR/NUM indicators, 1 row per equation ( max of 5 columns) @
   matrix vvals ;  @ matrix of indices/values, 1 row per equation @
   matrix opers ; @ matrix of +-* / operators, 1 row per equation  @
};


/************************/
@ procs to turn on screen attributes @


/*******************************/
@ Note that G_SCREEN is called by several "screen attribute" procedures.
  Ado0 contains number that conditions
  type of character display, used if aglob (character containing name of
   global matrix) is missing or non-existent @

@ colors:
   31 : red  	32_ green	33: yellow	34: blue
   35: pink	36: cyan	37: white

 1|n : bright version of above
 1:(n+10) Whiteon on bright-version-background of above
 n+10 : gray on dim-version-background of above
 7:(n+10) : above on gray background 

@

proc g_screen(aglob,ado0);
local foo,ado,alist,glist,ado1,j ;

  glist="_grnorml"|"_grbold"|"_grblue"|"_grcyan"|"_gryello"|
             "_grblink"|"_grhilit";
  alist=0|1|34|36|33|5|7 ;

  foo=0;
  do until foo eq rows(alist) or foo eq rows(glist) ;
      foo=foo+1;
      call varput(alist[foo],glist[foo]);
  endo;


@ check for global @
  foo=typecv(aglob);
  if missrv(foo,0) ne 6 ;
       ado=ado0 ;        @ none, use ado0 @
  else ;
       foo=varget(aglob);       @ valid value ? @
       if missrv(foo,-1)<0 ;   @ no @
          ado=ado0;
        else ;                @ yes, use it @
           ado=foo;
        endif;
   endif;

   for j (1,rows(ado),1) ;
   ado1=ado[j];
   if ado1<10 ;
      foo="\27[" $+  ftocv(ado1,1,0) $+"m";
   else ;
      foo="\27[" $+  ftocv(ado1,2,0) $+"m";
   endif;
   print foo ;;
   endfor ;
   retp(0);
 endp;



proc boldon ;
  call g_screen("_grbold",1);
  retp(0);
endp;

proc blinkon ;
  call g_screen("_grblink",5);
  retp(0);
endp;


proc grey_bkg ;
  call g_screen("",47);
  retp(0);
endp;

proc gray_bkg ;
  call g_screen("",47);
  retp(0);
endp;

proc gold_bkg ;
  call g_screen("",43);
  retp(0);
endp;

proc cyan_bkg ;
  call g_screen("",46);
  retp(0);
endp;

proc blue_bkg ;
  call g_screen("",44);
  retp(0);
endp;




proc blueon;            @ characters in blue @
  call g_screen("_grblue",34);
  retp(0);
endp ;

proc cyanon;            @ characters in cyan @
  call g_screen("_grcyan",36);
  retp(0);
endp ;

proc yellowon;            @ characters in cyan @
  call g_screen("_gryello",33);
  retp(0);
endp ;

proc hiliteon;          @ bold white characters on blue @
  call g_screen("",1);
  call g_screen("",44);
  retp(0);
endp ;

proc blockon;          @ characters in reverse video @
  call g_screen("",30);
  call g_screen("",47);
  retp(0);
endp ;

proc normalon;          @ normal characters @
  call g_screen("_grnorml",0);
  retp(0);
endp ;


/**********************/
@ Pause for alloted time, or until key with ascii value of intkey is hit @
@ time is in seconds. Note 27=ESC.  If intkey==0, then any key will do. @
@ Note: if ^S hit, then permanent pause ! @

  proc g_pause(atime,intkey) ;
   local d1, foo, anykey, dispit, escit, tmp, amatch, d2;
     d1=date ;
     foo=csrlin ;

     ANYKEY=not(scalmiss(INDNV(0,INTKEY)));
     DISPIT=not(scalmiss(INDNV(-1,INTKEY)));
     ESCIT=not(scalmiss(INDNV(-27,INTKEY)));
     if escit and rows(intkey)==1 ;
        intkey=32|13|10 ;   @ SPACE CR and LF @
     endif;


     if DISPIT ;
        call normalon ; call boldon ;
        " ( hit any key to continue, Ctrl-Home to hold  ... )" ;;
         call normalon ;
     elseif ESCIT ;
        call normalon ; call boldon ; " ? " ; call normalon ;
     endif;

bowwow: ;
     do until 2==1;                 @ endless loop @
       tmp=key ;
       if tmp>0 ;

@ special pause key @
         if tmp==1119 ;            @ctrl-HOME KEY MEANS WAIT FOREVER @
             tmp=key ;
             call normalon ; call boldon ;
                  "(hit any key to resume)" ;;
             call normalon ;
             tmp=0;
             do until 2==1 ;
                 tmp=key ;
                 if  tmp>0 ; tmp=key ; goto bowwow ; endif ;
             endo ;
         endif;

         amatch=missrv(indnv(tmp,intkey),0);

         if not(escit) ;
            if ANYKEY or AMATCH or DISPIT ;
                if dispit ; ? ; endif ;
                retp(1) ;
            endif;
         else ;
               if tmp==27 ;     @ ESC HIT @
                  gosub clrit ;
                  retp(1);
               elseif (missrv(AMATCH,0) ne 0) ;   @ MATCH KEY HIT @
                  gosub clrit ;
                  retp(0);
               endif;
         endif;
       endif;

       d2=date ;
       if ethsec(d1,d2)>(atime*100) ;
            if DISPIT or ESCIT ;
               gosub clrit;
            endif;
            retp(0);
       endif;  @ time out @

     endo;

clrit:;
    scroll foo|1|foo|79|0|0;
    locate foo,1 ;
    ? ;
    return;

 endp;



proc g_zapcmt(aline,cc);

  local i,nn,newl,achar,cmton,i1,i2,lenal,i0,ablock,cc2;

  if type(aline) ne 13 ;
       errorlog " %g_zapcmt: Expected string. Got a matrix.";
       stop;
  endif;

  lenal=strlen(aline);
   cc2="" $+ cc $+ cc ;

  i1=gb_sind0(aline,cc,1);


 if i1==0;   @ if no comments at all in string @
    retp(aline);
  endif;

  if i1==lenal ;  @ last character @
        errorlog  "  %g_zapcmt: Unclosed comment ";
        retp(aline);
  endif;


@ get first non comment block @
 if i1 gt 1 ;
   ablock=strsect(aline,1,i1-1);
   ablock=cvtinstr(ablock,cc2,cc);
    newl=ablock ;
 else ;
     newl=" ";
 endif;


@ find 2nd cc of first comment @
  i2=gb_sind0(aline,cc,i1+1);
  if i2==lenal;
     retp(newl);
  elseif i2== 0 ;
              errorlog  "  %g_zapcmt: Unclosed comment ";
              retp(newl);
  endif;

@ keep looking @
lookin: ;
  i0=i2+1 ;
  i1=gb_sind0(aline,cc,i0+1);        @ first cc of next comment @
  if (i1==0);               @ no more comments @

     ablock= strsect(aline,i0,1+lenal-i0);
     ablock=cvtinstr(ablock,cc2,cc);
     newl=newl $+ ablock ;
     retp(newl);
  endif;

@ else, got a new comment @
  ablock=strsect(aline,i0,i1-i0);  @append a block @
  ablock=cvtinstr(ablock,cc2,cc);
  newl=newl $+ ablock ;

  i2=gb_sind0(aline,cc,i1+1);         @ second cc @
  if (i2==0);
       errorlog  "  %g_zapcmt: Unclosed comment ";
       retp(newl);
  elseif i2==lenal ;
       retp(newl);
  endif;
  goto lookin ;

endp;

/**********/
@ looks for next occurence of non-duplicated cc. If a duplicated cc
(implying a literal), keep looking @

 proc gb_sind0(aline,cc,i0);
local i1;
aa:;
  i1=strindx(aline,cc,i0);
  if i1==0 ; retp(0); endif;
  if i1 ge strlen(aline); retp(i1) ;endif;

@ else, check if i1+1 is = cc @
  if strsect(aline,i1+1,1) $== cc ;
      i0=i1+2 ;             @keep looking @
     goto aa ;
  endif;

 retp(i1);    @ is a singleton cc @

endp;

/*************/
@ convert, within a string, occurences of cc2 to cc.  This
might change the size of the string (if len cc2 ne len cc ) @

proc cvtinstr(ablock,cc2,cc);
local i1,i0,icc2,newl ;


i1=strindx(ablock,cc2,1);
if i1== 0 ; retp(ablock) ; endif ;

icc2=strlen(cc2);

if i1==1 ;
  newl=cc ;
else ;
   newl=strsect(ablock,1,i1-1) $+ cc ;
endif;



ee: ;           @ look for more @
i0=i1+icc2;   @skip @
i1=strindx(ablock,cc2,i0);
if i1== 0 ;
    newl=newl $+ strsect(ablock,i0,strlen(ablock)-i0)  ;
    retp(newl) ;
endif ;

newl=newl $+ strsect(ablock,i0,i1-i0) $+ cc ;

goto ee ;
endp;


/* uc verstion of g_Getwrd */
proc (2) = g2getwrd(strung,iat);
local a1,a2;
 {a1,a2}=g_getwrd(strung,iat);
 if a1 $/=" " ;  a1=upper(g_strip(a1)); endif;
 retp(a1,a2);
endp;




/****************
@ get next word starting from character iat. ascii vals <= 32 delimit a word 
 also, elements in yuklist are treated the same as spaces  -- eg, ignored
whilst looking for beginning of next word, or treated as delimiters @
*/

 proc (2) = g_getwrd(strung,iat);
        local ilen,i,j,achar,yuklist;

@ this happens when multiple, unchecked, calls to g_getwrd occur @
        if iat==0;
           retp(" ",iat);
        endif;

@ use default delimiters if _g_getwrd unavailable. @
        if scalmiss(typecv("_g_getwrd"));
           yuklist=","  ;
        else;
          yuklist=varget("_g_getwrd") ;
          if scalmiss(yuklist); yuklist=","; endif;
        endif;

        ilen=strlen(strung);
        i=iat;  j=0;
        do until i>ilen;
          achar=strsect(strung,i,1);
          if vals(achar)>32 and scalmiss(indcv(achar,yuklist));
            j=i;
            do until j>ilen;
                achar=strsect(strung,j,1);
                if vals(achar)<=32 or not(scalmiss(indcv(achar,yuklist)));
                   j=j-1;               @j is last char of word @
                   goto outj;       @skip out of i loop @
                else;
                   j=j+1;
                endif;
            endo;
            j=ilen;               @ if here, at end of string @
            goto outj;
          else;
            i=i+1;
          endif;
        endo;
outj:
        if j==0;
          retp(" ",j);
        else;
           retp(strsect(strung,i,j+1-i),j);
        endif;
        endp;


/**********************************/
@ used by g_cons2 and g_cons3
  Notes: tab is treated like cursor/function key
         esc returns missing if nothing entered   @

proc (3)=g_cons1(ans0,iat,redo);
    local ir,ic,ans,gotkey,ak,tmp,anslen;
    ir=csrlin   ; format 1,8;

    if scalmiss(ans0); ans="" ;
    else ; ans="" $+ ans0 ;
    endif;

    iat=missrv(iat,0);            @ get current line @
    if iat==0; iat=csrcol ; endif;
@ to refresh ans or not to refresh! @
    if redo==0 ;
      if ans$=="" ; anslen=0; else ;anslen=strlen(ans); endif;
      ic=iat+anslen ;
      locate ir,ic ;
    else ;
      locate ir,iat ;
      if ans0$/="" ;
         $ans ;;
      else;
	     scroll ir|iat|ir|80|0|0;
      endif;
      ic=csrcol ;
    endif;

    gotkey=0;

@CASES: backspace or delete, tab & cursor, esc, CR or LF , character @
    do until gotkey==1 ;
      ak=key ;
      if ak>0 ;
       gotkey=1;
       if ak==8 or ak==1083;       @ backspace or delete -- DOESNT WORK UNDER GAUSS 5.0 @
         if ans$=="" ;
             ;                    @ nothing to delete @
         else;
           locate ir,ic-1;
           " ";;
           locate ir,ic-1;
           tmp=strlen(ans);
           if tmp>1 ;
               ans=strsect(ans,1,tmp-1);
           else;
               ans="";
           endif;
         endif ;
       elseif ak==1035 ;            @ alt-h  -- DOESNT WORK UNDER GAUSS 5.0 @
          ans="?" ; iat=0 ;         @ return a ? @
       elseif ak>255 or ak==9 ;
           locate ir,iat ;"           ";;   @ erase current ans @
           ans=ak ;  iat=0;          @ return cursor key ascii value @
       elseif ak==27 ;            @ esc key @
           if redo eq 1 ;
              scroll ir|iat|ir|80|0|0;
               locate ir,iat ;     @ erase current ans @
           endif;
           if redo<2 or ans$=="" ;
                 ans=miss(1,1) ;  iat=0;            @ return missing value @
           else;
               ans="" ;
           endif;
       elseif ak==10 or ak==13 ;        @ lf or CR @
           iat=0;
           break ;                 @ 0 signifies GOT IT @
       elseif ak==32 ;
           iat=0;
           break ;                 @ 0 signifies GOT IT @
       else ;
           ans= ans  $+ chrs(ak) ; chrs(ak) ;;
       endif ;
      endif ;           @ got a key @
    endo;               @ and return @
    retp(ans,iat,ak);
 endp ;



/******** OLD VERSION-- USE ABOVE INSTEAD
@ used by g_cons2 and g_cons3  @
  proc (3)=g_cons1(ans0,iat,redo);
    local ir,ic,ans,gotkey,ak,tmp,anslen;
    ir=csrlin   ; format 1,8;

    if scalmiss(ans0); ans="" ;
    else ; ans="" $+ ans0 ;
    endif;

    iat=missrv(iat,0);            @ get current line @
    if iat==0; iat=csrcol ; endif;
@ to refresh ans or not to refresh! @
    if redo==0 ;
      if ans$=="" ; anslen=0; else ;anslen=strlen(ans); endif;
      ic=iat+anslen ;
      locate ir,ic ;
    else ;
      locate ir,iat ;
      if ans0$/="" ;
         $ans ;;
      else;
	scroll ir|iat|ir|80|0|0;
      endif;
      ic=csrcol ;
    endif;

    gotkey=0;

@CASES: backspace or delete, cursor, esc, CR or LF , character @
    do until gotkey==1 ;
      ak=key ;
      if ak>0 ;
       gotkey=1;
       if ak==8 or ak==1083;                  @ backspace or delete @
         if ans$=="" ;
             ;                    @ nothing to delete @
         else;
           locate ir,ic-1;
           " ";;
           locate ir,ic-1;
           tmp=strlen(ans);
           if tmp>1 ;
               ans=strsect(ans,1,tmp-1);
           else;
               ans="";
           endif;
         endif ;
       elseif ak==1035 ;            @ alt-h @
          ans="?" ; iat=0 ;         @ return a ? @
       elseif ak>255 or ak==9 ;
           locate ir,iat ;"           ";;   @ erase current ans @
           ans=ak ;  iat=0;          @ return cursor key ascii value @
       elseif ak==27 ;            @ esc key @
           if redo eq 1 ;
              locate ir,iat ;" <ESC>       ";   @ erase current ans @
           endif;
	   if redo<2 or ans$=="" ;
                ans=miss(1,1) ;  iat=0;            @ return missing value @
	   endif;
       elseif ak==10 or ak==13 ;        @ lf or CR @
           iat=0;
           break ;                 @ 0 signifies GOT IT @
       else ;
           ans= ans  $+ chrs(ak) ; chrs(ak) ;;
       endif ;
      endif ;           @ got a key @
    endo;               @ and return @
    retp(ans,iat,ak);
 endp ;
**************************/


/**********************/
@ Like cons, but returns a number if one of the arrow keys, etc. is hit
   ESC with stuff in line erases input, Erase with nothing means miss(1,1) @

proc g_cons2;
local ans,iat,ak,ir;
local ic;
local oldat ;

ic=csrcol ; ir=csrlin;

t1: ;
oldat=0;

{ans,iat,ak}=g_cons1("",0,0);

 if ak==27 and oldat > 0 ;
     scroll ir|ic|ir|ic+oldat|0|0;
     locate ir,ic;
     ans="" ;
     goto t1;
elseif ak==27 ; 
    retp(miss(1,1));
endif;
oldat=1;

do until iat==0;
  {ans,iat,ak}=g_cons1(ans,iat,0);
   if ak==27 ;
     scroll ir|ic|ir|ic+oldat|0|0;
     locate ir,ic;
     ans="" ;
     goto t1;
  endif;
  oldat=oldat+1;

endo;
retp(ans);
endp ;



/**********************/
@ Special  cons.  Returns current value of a string, and then be
  ready to update it.  Also recognizes ESC and cursor keys.
  Returns string,iat
  String -- current value of input string
  Icol  -- column location in line of the beginning of string being built
  Return occurs whenever a key is hit.

 ANS is current value of string.  If "" or missing, then it is an empty
 string.
 IAT is current location of beginning of string.  If ANS0="", or IAT=0,
 then compute this.

Suggested calling:
  {ans,iat}=g_cons3("",0);
  do until iat==0;
     {ans,iat}=g_cons3(ans,iat);
  endo;
@

proc (2)=g_cons3(ans,iat);
local ak;
{ans,iat,ak}=g_cons1(ans,iat,2);
retp(ans,iat);
endp;


/*********************/
@ adaptation of indcv.  If ans not found in varlist, then see if ans
  matches a substring of varlist. If match, return index into vard;
  if no match, Missing @

 proc g_indcv2(ans,varlist);

   local ind1,nvars,iat,ith;

@ first, look for exact match @
   ind1=indcv(0 $+ ans,varlist);
   if ISmiss(ind1)/=1 ;
        retp(ind1);
   endif;

@ no exact match: search for substring match@
   nvars=rows(varlist);
   ith=0;
   do until ith==nvars;
        ith=ith+1;
        iat=strindx("" $+upper(varlist[ITH,1]),"" $+upper(ans),1) ;
        if (iat > 0 ) ;
            retp(ith);
        endif;
   endo;

@ if here, no substring match ! @
   retp(miss(0,0));

   endp;



/*****************************/
@ replace needle with new1, in haystack @
@ if all=1, then replace all occurences (Otherwise, replace 1st occurence @

proc g_replacestring(haystack,needle,new1,all);
 local a;
 a=g_rpstg2(haystack,needle,new1,all);
 retp(a);
endp;


proc g_replacestrg(haystack,needle,new1,all);
 local a;
 a=g_rpstg2(haystack,needle,new1,all);
 retp(a);
endp;

proc g_rpstg2(haystack,needle,new1,all);
local title,ih,foo;

do until 1==2;
  ih=strlen(needle);
  foo=strindx(upper(haystack),upper(needle),1);
  if foo==1 ;
     title="" $+ new1 $+ strsect(haystack,foo+ih,1+strlen(haystack)-(foo+ih));
     haystack=title;
  elseif foo>0 ;
     title=strsect(haystack,1,foo-1) $+ new1 $+
                      strsect(haystack,foo+ih,1+strlen(haystack)-(foo+ih));
     haystack=title;
  elseif foo==0 ;
       title=haystack; all=0;
  endif;

 if all ne 1; break ;endif;
endo;

retp(title);

endp;

/******************/
@ in astring,  replace $abc strings with their DEFINED values@
proc g_repstg(astring,definew,defines);
local ml,ndefines,ldefinew,ldefines,llens,llens2;
ml=0;
llens=zeros(rows(definew),1);
do until ml==rows(definew);
  ml=ml+1;
  llens[ml]=strlen(definew[ml]);
endo;
llens2=rev(sortind(llens));
ldefinew=definew[llens2];
ldefines=defines[llens2];

 ml=0 ; ndefines=rows(ldefinew);

  do until ml==ndefines;
        ml=ml+1;
        astring=g_rpstg2(astring,"$" $+ ldefinew[ml],ldefines[ml],1);
  endo;
  retp(astring);
endp;



/**********************/
@ Pause for alloted time, or until key is hit @
@ time is in seconds. Return value of key hit, or missing if time out @

  proc g_pause2(prompt,atime) ;
   local d1, foo, anykey, dispit, escit, tmp, amatch, d2;
     d1=date ;
     foo=csrlin ;
     if prompt$==""; prompt=" ( hit any key to continue ... )" ; endif;
     call normalon ; call boldon ;
     prompt;;
     call normalon;

bowwow: ;
     do until 2==1;                 @ endless loop @
       tmp=key ;
       if tmp>0 ; retp(tmp); endif;
       d2=date ;
       if ethsec(d1,d2)>(atime*100) ; retp(miss(1,1)); endif;
    endo;
 endp;



/******************/
@ get 1 variable (or a number) from batch command -- return index,name,ie @
@ Astr = Error message header
 acommand = string to read from
  ie  = start location for reading from acommand
 exactxyz = if =1 , then exact variable matches only
 vrnames = names of current variables
  numok  = input might be a number
  others = vector of "other" commands, that are legit (not vars or numbers

retp(index_into_varnames,varname_or_number,OkFlag,next_ie)
   index_into_varnames: if variable, this is the index of this variable (into vrnames)
                        if a number, this is a string containing the number
   varname_or_number : variable name, or a number
   status: 0=error, 1=variable, 2=number, 3=special command
   next_ie: used by g_getwrd to get next command 
@ 

proc (4)=g_1opt(astr,acommand,ie,exactxyz,vrnames,numok,others);

 local indx,nam,aword,foo,aval;

 {aword,ie}=g_getwrd(acommand,ie+1);
  if ie==0   ;
                call grbl2_error(" Bad input for " $+ astr,1) ;
                aword=g_stripc(acommand,chrs(10|32|13|09)) ;
                retp(miss(1,1),miss(1,1),0,ie);
  endif;

@ special word ? @
  if not(scalmiss(others));
            if not(scalmiss(indcv(aword,others))) ;
               retp(aword,aword,3,ie);
            endif;
  endif;

  if g_isnum(aword);             @ number, not a var name @
             if numok==1 ;
                 nam=aword;
                 aval=stof(aword);
                 format 1,8; $astr " : " $nam ;
                 retp(nam,aval,2,ie);
             else ;
                call grbl2_error(" Numbers not allowed as input for " $+ astr,1) ;
                aword=g_stripc(acommand,chrs(10|32|13|09)) ;
                retp(miss(1,1),miss(1,1),0,ie);
            endif;
  endif;


@ not a number or special word, maybe a variable @
 if ie > 0 ;
              if exactxyz==1 ;
                 foo=indcv(aword,vrnames);
              else;
                 foo=g_indcv2(aword,vrnames);
             endif;
           else;
                errorlog " Missing " $+ astr ;
                retp(miss(1,1),miss(1,1),0,ie);
  endif;
  format 1,8;
  if not(scalmiss(foo));             @ okay @
                indx=foo; nam=vrnames[foo] ;
                if verbose>0 ; $astr " : " $nam ; endif;
                retp(indx,nam,1,ie);
           else;
                errorlog " Can not find " $+ astr;
                retp(miss(1,1),miss(1,1),0,ie);
   endif;
 endp;

/**************************/
@ get many variables from batch  command 
Returns 4 arguments: 
  Index to variables
  names of variables
  # of variables
  pointer to end of substring (used by g_getwrd)
@

proc (4)=g_Nopts(astr,acommand,ie,exactxyz,vrnames,others);

        local tmpvar,tmpind,foo,nvs,aword ;

        tmpvar=miss(1,1); tmpind=miss(1,1);

        do until ie==0 ;
           {aword,ie}=g_getwrd(acommand,ie+1);
           if ie==0 ; continue ; endif ;

           if not(scalmiss(indcv(aword,others)));  @ a special word ? @
               tmpind=tmpind|0 ;
               tmpvar=tmpvar|aword ;
               continue;
           endif;

           if ie>0;                           @ got a name @
               if vrnames$/="*";
                 if exactxyz==1;
                     foo=indcv(aword,vrnames);
                  else;
                     foo=g_indcv2(aword,vrnames);
                  endif;
                  if scalmiss(foo);
                     print " .. Bad ";; astr  ;; ", " ;;  aword ;
                     print "Current vars: ";; format /ld 1,8;$vrnames';
                     stop;
                  endif;
                 tmpind=tmpind|foo;
                 tmpvar=tmpvar|vrnames[foo] ;
              else;
                 tmpvar=tmpvar|aword ;
              endif;
           endif;
        endo;                       @ie == 0 @

        tmpvar=packr(tmpvar); tmpind=packr(tmpind);
        if vrnames$/="*";
          if scalmiss(tmpind) or rows(tmpind) ne rows(tmpvar);
             errorlog    " No " $+ astr;
              retp(miss(1,1),miss(1,1),0,ie);
          endif;
        endif;
        nvs=rows(tmpvar);
        format 1,8; $astr  " : " $tmpvar';

        retp(tmpind,tmpvar,nvs,ie);

   endp;

/*************/
    proc g_vufile(b,prompt);
     local gee,infile,af;
      cls ;
      if filesa(b)$==""; "No such file: " $b ;
              call g_pause(5,-1); retp(0);
      endif;
      gee=getf(b,1) $+ chrs(13|10) $+ "        ";
      call cyanon ; $prompt ;; $b ; call normalon ;
      call blockon  ;" (ESC when done..)"; call normalon ;
      call g_vutext(3,22,gee,&boldon,&cyanon);
      ?;
    retp(0);
endp;



/*************************************/
/* alternate call to g_vutext */
 proc  g_DspTxt(topline,botline,astring,proc1,proc2);
 local foo; 
  foo=g_vutext(topline,botline,astring,proc1,proc2) ;
  retp(foo);
endp;

/*************************************/
@ Display a long text string, with user given ability to scroll
  back and forth in the string.
  Display area is from topline to botline.
  Display string is in astring
  Proc1 and proc2 (called as &aproc1,&bproc1) contain names of
  "display attribute" routines: such as boldon, blueon, etc.

   Example: call g_vuText(3,20,astring,&boldon,&yellowon)
@

 proc  g_vuText(topline,botline,astring,proc1,proc2);
  local proc1:proc ; local proc2:proc ;
  local
      vstring, nvs, j10s, nlines, inblock, line1, scrit, line2, atline,
      anadd, i1, i2, aline, foo, ans,tmp,toFIND,ii,ifoo,GOTM ;
  local infile,af,kchr1,cvtcase ;
  local mm,mm2,tmp1;
  tofind=""; cvtcase=0;

  topline=maxc(topline|1);
  botline=minc(22|botline);
  kchr1=1;
  INFILE=STRLEN(astring);

if strlen(astring)==0; 
   vstring=32 ;
else ;@ convert string to ascii values @
  vstring=vals(astring);
endif;

if infile>4000 ;        @zap if too large (> 1 screen of info @
  astring=0;
endif;

nvs=rows(vstring);
if nvs==0; retp(0); endif;

mm=0;
j10s=miss(1,1);
do until mm ge nvs ;
   mm=mm+1;
   mm2=minc((mm+2000)|nvs);
   tmp1=mm+g_mkindx(vstring[mm:mm2].==10)-1;
   if missrv(tmp1,0) ne 0 ;
       if scalmiss(j10s);
            j10s=tmp1;
        else;
           j10s=j10s|tmp1 ;
        endif;
   endif;
   mm=mm+2000;
endo;

@J10S=PACKR(MISS(MISSRV(INDNV(VSTRING,10),0).*SEQA(1,1,ROWS(VSTRING)),0));@

if ismiss(j10s); retp(0); endif;  @ should never happen ... @
j10s=j10s~j10s;
nlines=rows(j10s);
if nlines le 1 ;
   " Can not display .... ";
   call g_pause(5,-1);
   retp(0);
 endif;

j10s[1,1]=1 ;
j10s[2:nlines,1]=j10s[1:(nlines-1),2]+1 ;
inblock=1+botline-topline ;

goo1: ;
if nlines le inblock ;
    scroll topline|1|(botline+1)|80|0|0;
    locate topline,1 ;
    gosub doit1;
    $astring ;
    locate botline+2,5 ;
    call normalon; call blockon ;  call g_pause(10,-1);

else ;

@ Do inblock at a time @
   line1=1 ; SCRIT=0 ;

   do until line1 > nlines ;         @ for all lines in string @
      line2=minc((line1+inblock-1)|nlines) ;  @ line1,line2 refer to j10s @


      IF SCRIT eq 0 ;           @ new page @
         scroll topline|1|(botline+1)|80|0|0;   @ clear display area @
         atline=0 ; anadd=1;
      ELSEif scrit eq 1 ;                  @ down arrow @
         scroll topline|1|botline|80|SCRIT|1;   @ clear display area @
         atline=(line2-line1);anadd=1;
      ELSEif scrit eq -1 ;       @ up arrow @
         scroll topline|1|botline|80|SCRIT|1;   @ clear display area @
         atline=0; anadd=1+line2-line1;
      endif;
      gosub doit1;
@ grab lines using begin/end info in j10s @
      do until line1+atline gt line2 ;
           i1=j10s[line1+atline,1];
           i2=j10s[line1+atline,2]-2;   @ don't need 13 10 @
           if i2<i1 ;
              aline=" ";
           else ;
              aline=chrs(vstring[i1:i2]);
           endif ;
           foo=topline+atline;
           locate foo,1 ; format 4,0;
           if kchr1 > strlen(aline) ;
                 "" ;
           else ;
                 $strsect(aline,kchr1,78);;
           endif;
           atline=atline+anadd;
        endo;

     foo=topline+atline ;
     IF LINE2 == NLINES ;
         LOCATE foo,8 ;
         CALL NORMALON ; CALL BLOCKON ;
         "                                                             ";
      else ;
          scroll (botline+1)|1|(botline+1)|80|0|0 ;
      ENDIF;

@ increment line1 @
goo:  locate botline+2,2 ;
      call normalon ; call boldon ;
      if kchr1==1 ;
          format /ld 4,0; "#" line1 " of " nlines ;; format 1,8 ; 
      else ;
          format /ld 4,0; "#" line1 "," KCHR1 ;; format 1,8 ; 
      endif;
      call normalon ;  call blockon ;
  "Home,End,PgUp,Line#,<" chrs(217) "or PgDn," chrs(24) "," chrs(25)
       ",TABs,F2,ESC=Exit ";;
       ans=g_cons2 ; call normalon ;

@Search for @
      if ans$==1060 or ans$==1085 or ans$==1095 ; @f2 s-f2 c-f2 @

         if ans$==1095 ; cvtcase=1-cvtcase ;  endif;
         scroll (botline)|1|(BOTLINE+2)|80|0|0 ;
         locate botline+2,2 ;
         if cvtcase==1 ;
           CALL BOLDON ;" Case-insensitive string to find: ";;call normalon ;
         else ;
           CALL BOLDON ;" String to find: ";;call normalon ;
         endif;
         if ans$==1085 and tofind $/=""  ; $tofind ; 
         else ;
            toFIND=CONS;
         endif;
         if tofind$=="" ; continue ; endif;

         if cvtcase==1 ; tofind=upper(tofind); endif;
         ii=1; GOTM=0;
         do until line1+ii gt line2 ;
            i1=j10s[line1+ii,1];
            i2=j10s[line1+ii,2]-2;   @ don't need 13 10 @
            if i2<i1 ;                  @ skip blank lines @
                ii=ii+1;
                continue ; 
            else ;
              aline=chrs(vstring[i1:i2]);
            endif ;
            if cvtcase==1 ; aline=upper(aline) ; endif ;
            ifoo=strindx(aline,tofind,1);
            if ifoo ne 0 ;               @ match found @
                line1=line1+ii ;
                scroll (botline)|1|(BOTLINE+2)|80|0|0 ;
                locate botline+2,1 ; scrit=0;
                "  !! Match found at line "  ;; format /ld 5,0; line1 ; call g_pause(0.4,0);
                 scroll (botline)|1|(BOTLINE+2)|80|0|0 ;
                 GOTM=1;
                 BREAK ;
             endif;       @ non-usable character hit @
             II=II+1 ;
         endo;
         IF GOTM==1; CONTINUE ; ENDIF;
         scroll (botline)|1|(BOTLINE+2)|80|0|0 ;
         locate botline+2,1 ; scrit=0;
         "  Match not found " ;; call g_pause(1.4,0);
         scroll (botline)|1|(BOTLINE+2)|80|0|0 ;
          continue;
      endIF;

      if ans$==""; ans=1081 ; endif ;  @ENTER  is same as pgdn @

      if scalmiss(ans) ; break ; endif ;   @ no more @

      if type(ans) ne 6 ;    @ non cursor key hit @
        if g_isnum(ans);
            line1=mINc(mAXc(trunc(stof(ans))|1)|(nlines-1)); format /ld 5,0;
            scroll (botline)|1|(BOTLINE+2)|80|0|0 ;
            locate botline+2,1 ; scrit=0;
            " >>>   Jumping to line " line1 " ..... " ;; call g_pause(1.4,0);
            scroll (botline)|1|(BOTLINE+2)|80|0|0 ;
            continue ;
         endif;       @ non-usable character hit @
         goto goo ;
      endif ;

@ cursor type key is hit @
      SCRIT=0;
      if ans==1081 ;          @ pgdn @
         line1=minc(nlines|(line2+1)) ;
         continue ;
      elseif ans==1073 ;   @ pgup @
         line1=line1-inblock ;
         line1=maxc(1|line1);
      elseif ans==1079 ;    @ END KEY @
          LINE1=minc(nlines|(1+NLINES-INBLOCK)) ;
      elseif ans==1071 ; @ home @
         line1=1;
         KCHR1=1;
      elseif ans==1072 ;        @ arrow up @
         line1=line1-1;
         if line1==0 ;
            line1=1;
         else ;
            SCRIT=-1;
         endif;
      elseif ans==1080 ;        @ arrow down (move down a line @
         line1=minc(nlines|(line1+1)); SCRIT=1;
      elseif ans==1075   ;      @ left @
          kchr1=maxc(1|(kchr1-1));
      elseif ans==1077    ;   @ right arrow @
          kchr1=kchr1+1;
      elseif ans==9    ;   @ TAB @
          kchr1=kchr1+8;
      elseif ans==1015    ;   @  back TAB @
          kchr1=maxc((kchr1-8)|1);
      else ;
         goto goo ;
      endif;

   endo;

endif;


retp(0);

@ Turn on desired screen attributes @
doit1:;
  call normalon ;
  if &proc1 ne 0;
    call proc1 ;
  endif;
  if &proc2 ne 0;
    call proc2 ;
  endif;
  return;

endp;

/********/
@ get rid of all spaces and below in string @

proc g_eatspc(atext) ;
  local vv ;
  vv=vals(atext) ;
  vv=vv.*(vv.>32);
  vv=packr(miss(vv,0));
  if scalmiss(vv); retp(""); endif;
  retp(chrs(vv));
endp ;


/**********************/
@ strip spaces (and below) from front and back of string @
proc g_strip(atext);
  local a ,b,i,j,btext;
 
  if type(atext) ne 15 ;  @ not a string array @
     if atext$=="" ; retp(atext); endif;
     a=g_stripc(atext,"");
     retp(a);
   endif;

@ else, one at a time @
   btext=atext ;
   for i (1,rows(atext),1);
     for j (1,cols(atext),1) ;
        btext[i,j]=g_stripc(atext[i,j],"");
     endfor;
   endfor;

   retp(btext);

  endp;


/**********************/
@ strip achar  from front and back of string @
proc g_stripc(atext,achar);

   
  local vv,mm,i2,i1,iichar,at0 ;
  if atext$==""  or atext$==" " or strlen(atext)==0; retp(""); endif;
  at0="" $+ atext;
  vv=vals(at0) ;
  if strlen(achar)==0 ; achar=" "; endif;
  iichar=vals(achar);
  mm=0;i1=0;


  do until mm==rows(vv);
     mm=mm+1;
     if achar$=="" ;
        if vv[mm]>32 ; i1=mm ; break ;endif;
     else ;
        if scalmiss(indnv(vv[mm],iichar)); i1=mm ; break ;endif;
     endif;
  endo;
  if i1==0; retp(""); endif;
  mm=rows(vv);i2=0;
  do until mm==0 ;
     if achar$=="" ;
        if vv[mm]>32 ; i1=mm ; break ;endif;
     else ;
        if scalmiss(indnv(vv[mm],iichar)) ; i2=mm ; break ; endif;
     endif;
    mm=mm-1;
  endo;



  retp(chrs(vv[i1:i2]));
endp ;



/****************************************/
@ Check to see if a string is a legit number. Handles scientific notation (GAUSS's isnumber does not) @

proc g_isnum(nvar);

local c1,c2,achar,achar0 ,gotdot,gote,jj,ii ;


if type(nvar)== 6;			@ not a string @
  if scalmiss(nvar); retp(0); endif;			@ missing value NOT a number @
  if ( (abs(nvar)<1e-130) and (nvar ne 0))  or (abs(nvar)>1e130 ); 	@ wierd value, might be characters (8 or less) @
     nvar="" $+ nvar ;				@ check below @
  else;
     retp(1);				@ assume is a number @
  endif;
endif;


c1="0123456789.+-";
c2="0123456789.+-E";

nvar="" $+ nvar ;
nvar=g_strip(upper(nvar)) ;

ii=strlen(nvar);
gote=0;
gotdot=0;

achar=strsect(nvar,1,1);
if strindx(c1,achar,1) eq 0 ; retp(0); endif ; @illegal first charater @

for jj (2,ii,1);
 achar0=achar;
 achar=strsect(nvar,jj,1);
 if strindx(c2,achar,1) eq 0 ; retp(0); endif ; @illegal internal @

 if achar$=="." ;  
     if gotdot==1 ;retp(0); endif;   @ multiple decimal points is illegal @
     gotdot=1 ;
     continue;
 endif;
 if achar$=="E" ;
     if gote==1 ;  retp(0); endif;   @ multiple E are illegal @
     gote=1 ;
     continue;
 endif;
 if achar$=="+" or achar$=="-" ;
    if achar0$/="E" ; retp(0); endif;   @ internal +- not preceded by E @
 endif;
endfor;
retp(1);
endp;




/******************************/
/*  Procedure to return index to a panel (first and last rows of a panel 
     ID version */


proc g_pnlind_ID(alist);  @ a synonym @
  local a1 ;
   a1=g_pnlind(alist);
  retp(a1);
endp;

proc g_pnlind(alist);
local id1,rw1,id2,goo,this1,tlist,iarf;
if scalmiss(alist) ; retp(1~1); endif;

id1=1;
rw1=rows(alist);
id2=id1;
goo=0~0;
do while 1==1 ;
  this1=alist[id1] ;

  tlist=alist[id1:minc(rw1|(id1+25))].==this1;
  iarf=indnv(0,tlist);


  if missrv(iarf,0)==0  ;  @ look in wider range @
     tlist=alist[id1:minc(rw1|(id1+150))].==this1;
     iarf=indnv(0,tlist);
   endif;

  if missrv(iarf,0)==0  ;  @ look in wider range @
     tlist=alist[id1:minc(rw1|(id1+1000))].==this1;
     iarf=indnv(0,tlist);
     if missrv(iarf,0)==0  ;  @ even wider range @
       tlist=alist[id1:minc(rw1|(id1+10000))].==this1;
       iarf=indnv(0,tlist);
       if missrv(iarf,0)==0  ;  @ check entire list @
          tlist=alist[id1:rw1].==this1;
          iarf=indnv(0,tlist);
       endif;
    endif;
  endif;
            
  if missrv(iarf,0)==0  ;  @ must be at end of alist @
      goo=goo|(id1~rw1);
      break ;
  endif;
  id2=id1+iarf-2;
  goo=goo|(id1~id2);
  id1=id2+1;
endo;

retp(goo[2:rows(goo),.]);
endp;
  


/******************************/
/*  Procedure to return index to a panel (first and last rows of a panel  --   
    "COUNT" version */

proc g_pnlind_count(alist);

local aid,nrows,iat,tt,tt2,nct;

aid={};
nrows=rows(alist);

iat=1;
do while 1==1;
  nct=alist[iat];		@ only use counter of first row of set @
  if scalmiss(nct) ; nct=1 ; endif;
  if nct<0 ; nct=1 ; endif;    
  tt=minc(nrows|(iat+nct-1));
  tt2=iat~tt;
 
  aid=aid|tt2;
  iat=tt+1 ;
  if iat > nrows ;break ; endif;  
endo;
retp(aid);
endp;
  


/***************************/
@ Procedure to construct a matrix of indices, given a
  vector of 0s and 1s. Retp(missing) if all zeros @

  proc g_mkindex(alist);
    local a;
     a=g_mkindx(alist);
    retp(a);
  endp;

  proc g_mkindx(alist);

     if ( (cols(alist) gt 1) and (rows(alist) gt 1 ) ) ;      @vectors only @
         retp(error(1201));
     endif ;

     if (rows(alist)==1); alist=alist'; endif;  @ convert to column vector?@

     if alist==0;        @ no non-zero elements @
        retp(miss(1,1));

     elseif alist==1 ;  @ no zeros @
        retp(seqa(1,1,rows(alist))) ;
     endif;

@ else, some 0s, some 1s @

     retp(packr(miss(
           (seqa(1,1,rows(alist)).*alist)
                  ,0)
          )) ;

 endp;


/******************/
@ Replacement for GAUSS function UNION (which occassionally messes up
  a,b are vectors. Nn=1 for number, 0=character @

proc  g_UNIque(foo,nn) ;
    retp(g_union(foo,foo[1],nn));
endp;

proc g_union(a,b,nn);
    local alll,foo,candi,anew,tmp ;

@ augment anew, only adding stuff that is not on list @

    alll=a|b ;

    foo=1;
    anew=alll[1];
    do until foo==rows(alll);
        foo=foo+1;
        candi=alll[foo];
        if nn==1 ;              @ numeric @
           tmp=anew.==candi ;
        else;
           tmp=anew.$==candi ;
        endif;
        if sumc(tmp) == 0;
              anew=anew|candi ;
        endif;
     endo;

     if nn==1 ;
        retp(sortc(anew,1));
     else ;
        retp(sortcc(anew,1));
     endif;
 endp;



/**********************************/
@ Ask a No/Yes question.  If Yes, return 1, else return 0
  Prompt is displayed on screen
  DefAns is the default answer.

 Returns two arguments:
   arg1: yes/no indicator
       If yes, return 1
       If no, return 0
  arg2: Ascii Value of key hit:
        Special cases:
           ?, alt-h,  or F1 :  1
           ESC:  Miss(1,1)
           other ascii value < 32 (ENTER, etc) : 0

@

   proc (2)=g_yes_no(prompt,defans);

   local nos,yess,akey,arow,tmp ;
   let nos=NO N ;
   let yess=YES Y ;


@ what's the default ? @
   if type(defans)==6 ;       @ character input @
     tmp=defans ;
     defans=-1;
     if tmp==1 or tmp==0 ;
        defans=tmp;
     else ;
        if defans$=="YES" or  defans$=="Y" ;
            defans=1 ;
        elseif defans$=="NO" or defans$=="N";
            defans=0;
        else ;
           defans=-1;
        endif;
    endif;

   else ;

     defans=upper(defans);
     if scalmiss(indcv(defans,nos)) ;
       if scalmiss(indcv(defans,yess)) ;
           defans=-1 ;
       else;
           defans=1 ;
      endif;
     else;
       defans=0;
     endif;
  endif;
  arow=csrlin;
  gosub showit ;

@ Now get an answer ... @
ikey:
   akey=0 ;
   do until akey>0 ;
     akey=key;
     if akey==78 or akey==110 or akey==48 or akey==50 ;   @ N n 0 2 @
       if defans ne 0 ; defans=0; gosub showit ; endif;
       call g_pause(0.1,0);
       ?; retp(0,0);
     elseif akey==89 or akey==121 or akey==49;  @ Y y 1 @
       if defans ne 1 ; defans=1; gosub showit ; endif;
        call g_pause(0.1,0);
        ?; retp(1,0);
     elseif akey==1077 ;
        if defans==-1 ; defans=1 ;
        else; defans=1-defans ;
        endif;
        gosub showit ;
     elseif akey==1075 ;
        if defans==-1 ; defans=0 ;
        else; defans=1-defans ;
        endif;
        gosub showit ;

     elseif akey==63 or akey==1059 or akey==1035 ; @ f1 ? or alt-h @
         retp(defans,1);

     elseif akey<33 and akey>0 ;           @ Space, Enter, etc @
        if akey ne 27 ; akey=0 ; else ; akey=miss(1,1); endif ;
        if defans==1 ;
          gosub showit ; call g_pause(0.1,0);
           ?; retp(1,akey) ;
        elseif defans==0;
          gosub showit ; call g_pause(0.1,0);
          ? ; retp(0,akey) ;
       endif ;
     endif;
   endo;
   goto ikey ;

showit: ;                    @ subroutine to print stuff @
  locate arow,1;
  $prompt ;;
  if defans==-1 ;                   @ no default @
      call normalon ; "(Yes or No)?";;
  elseif defans==0 ;                @ default is no @
      call normalon ; "(Yes or ";;
      call boldon ; "No";;
      call normalon ; ")?";;
  else;
      call normalon ; "(";;
      call boldon ; "Yes";;
      call normalon ; " or No)?";;
  endif;
  return;

endp;


@ simple (no help) 1 parameter-returned version of g_yes_no @
   proc g_yesno(prompt,defans);            @just in case you are dyslexic@
      local a,b ;
      {a,b}=g_yes_no(prompt,defans);
     retp(a);
   endp;
   proc g_noyes(prompt,defans);            @just in case you are dyslexic@
      local a,b ;
      {a,b}=g_yes_no(prompt,defans);
     retp(a);
   endp;



/* Dummy for g_batch2 */

proc g_batch2(keywurd,acommand,ie) ;
" BASIC G_BATCH2 ";
stop;
endp;





/**************************/
/*  Display list of dummy creation instructions 
   mstruct: the "structure variable", of the kind generated by G_BATCH when  a XNEW ... keyphrase 
	   is processed.  Currently, this is G_BATCH sets the XNEWinfo variable
	   is processed.  Currently,  G_BATCH sets the DINFO variable
   Dataset: name of dataset
   noprint: if 1, do NOT print the results (just return it) 
*/

proc g_VUxnew(struct minfo_s dstruct,DATASET,noshow);


local nuline,awords,ii,p1,p2;
local aline;
local c10 ;
local damess,vnames,itt,itmp,itmp1,itmp2,itmp3,itt2 ;
if MISSrv(dstruct.neq,0)==0 ;
     damess=" No XNEW-variable definitions.";
     if noshow ne 0 ; print damess ; endif ;
     retp(damess) ;
endif;


c10="          ";

VNAMES=GETNAME(DATASET);

damess="  Number of XNEW-var equations: " $+ ftos(dstruct.neq,"%*.*lf" ,2,0)$+ chrs(10) ; 
 

@
       mstruct.neq   : 1x1 scalar, the # of equations defined
       mstruct.names : 10x1 vector, the "new variable names" to create.  
       nterms :  10x1 vector of # of terms in each equation. 
       vtypes : 10x5 matrix of  VAR/NUM indicators -- "VAR" for "variable", "NUM" for numeric value
       vvals  : 10x5 matrix of values. 
	           If "VAR" vtype, pointer to VARLIST (varlist is the list of variables in dataset)
		   If "NEWVAR", points to mstruct.names
		   IF "NUM" vtype, the actual numeric value

        opers : 10x5 matrix of "operators".
		There are 5 operators: "+", "-", "*", "/", and "=".
		The "=" operator is only used with the first value/variable -- it's really just a 
		placeholder.
@

for itt (1,dstruct.neq,1) ;
 aline="" ;
 itmp=dstruct.names[itt];
 itmp2=dstruct.vvals[itt,1];
 if dstruct.vtypes[itt,1]$=="VAR" ; 
	itmp2=vnames[itmp2];  
 elseif dstruct.vtypes[itt,1]$=="NEWVAR";
	itmp2=dstruct.names[itt];
 else ;
        itmp2=ftos(itmp2,"%*.*lf" ,8,2);
 endif;
 aline= "   "$+ strput(itmp,c10,1) $+ " =  " $+ strput(itmp2,c10,1) ;

 for itt2 (2,dstruct.nterms[itt],1) ;
     itmp2=dstruct.vvals[itt,itt2];
     if dstruct.vtypes[itt,itt2]$=="VAR" ; 
 	itmp2=strput(vnames[itmp2],c10,1); 
     elseif dstruct.vtypes[itt,itt2]$=="NEWVAR";
	itmp2=dstruct.names[itmp2]; 
     elseif dstruct.vtypes[itt,itt2]$=="FUNC";
   	 itmp2 = itmp2 $+ " ) " ;
     else ;
        itmp2=ftos(itmp2,"%*.*lf" ,10,2);
     endif;
     aline=aline $+ " " $+ dstruct.opers[itt,itt2] $+ " " $+ itmp2 ;
 endfor;

/* unpolishize aline   */    

ii=strindx(aline,"(",1) ;
if ii gt 0 ;
  p1=strindx(aline,"=",1);
  nuline=strsect(aline,1,p1) $+ "  ";
  aline=strsect(aline,p1+1,100000);

  ii=strindx(aline,"(",1) ;
  p1=strsect(aline,1,ii-1);
  aline=strsect(aline,ii+1,100000);
  {p2,aline}=token(aline);
  nuline=nuline $+ p2 $+ "(" $+ p1 $+ ") " ;
  {p2,aline}=token(aline);
  aline=nuline $+ aline ;
endif;
 
 damess=damess $+aline $+ chrs(10) ;
endfor ;

 
if noshow ne 1 ; print damess ; endif ;
retp(damess) ;
endp;



/**************************/
/*  Display list of dummy creation instructions 
   dlist  : the matrix  generated by G_BATCH when  a DUMMY ... keyphrase is processed 
	   is processed.  Currently,  G_BATCH sets the DINFO variable
   Dataset: name of dataset
   noprint: if 1, do NOT print the results (just return it) 
   long: 
         0 = variable names style (no descriptives) 
	 1 = summary style
	 2 = long style

*/
proc g_VUdum(dLIST,DATASET,noshow,long,othervars);
local damess,itt ,foo,tmp2,cmm;
local  vnames,nl,c10;
local ndums,oname,cname,mm,mm2,tmp,levs;

local foop,bname;


damess="";

if MISSrv(dLIST,0)==0 ;
     damess=" No dummy variables are defined.";
     if long==0 ; damess=miss(1,1); endif;
     if noshow ne 0 ; print damess ; endif ;
     retp(damess) ;
endif;

@            O_INDEX ~ C_INDEX ~ basename ~ NLEVELS ~  Level1 ~ ... ~ LevelN@

VNAMES=GETNAME(DATASET);

if othervars$/=" " ; vnames=vnames|othervars ; endif;

c10="          ";
ndums=rows(dlist) ;
damess="" ;
if long ne 0 ;
  damess="  Number of dummies: " $+ ftos(ndums,"%*.*lf" ,2,0)$+ chrs(10) ; 
  damess=damess $+ "    Ordinal   , Cardinal   :  #levels== .... " $+ chrs(10) ; 
else ;
  foop=miss(1,1);
endif ;


for mm (1,ndums,1);
  tmp="";
  itt=dlist[mm,1];
  
  oname=strput(vnames[itt],c10,1) ;
  itt=dlist[mm,2];
  if missrv(itt,0)==0 ;   cname=strput("0/1",c10,1) ;  
  else ;
     if itt>rows(vnames);
	"Error in cardinal variable " itt "," rows(vnames); stop; endif;
         cname=strput(vnames[itt],c10,1)   ; 
  endif ;

  bname=dlist[mm,3];
   
  nl=dlist[mm,4] ;
  levs=dlist[mm,5:(4+nl)];
  if long ne 0 ;
      cmm=ftos(mm,"*.*lf",2,0);
      if long==1 ;
        tmp= cmm $+") " $+ oname $+ ", " $+ cname $+ " : "  $+   ftos(nl,"%*.*lf" ,2,0) $+ "  == " ;
      else;
        tmp= cmm $+") " $+ oname $+ ", " $+ cname $+ " : "  $+   ftos(nl,"%*.*lf" ,2,0) $+ "  levels" ;  
      endif;
  endif;
  if long==2 ; tmp=tmp $+ chrs(10) ; endif ;
  for mm2 (1,nl,1);
     if long==1 ;		@ summary @
        tmp=tmp $+   ftos(levs[mm2],"%*.*lf" ,6,1) $+ "  ";
     elseif long==2 ;
	tmp=tmp $+ "      " $+ bname $+ ftos(mm2,"%0*.*lf",3,0);
        tmp=tmp $+ " : " $+ ftos(levs[mm2],"%*.*lf" ,6,1) $+ "  " $+ chrs(10);
     else ;		@ vector @
        tmp= bname $+ ftos(mm2,"%0*.*lf",3,0);
	tmp2=0 $+ tmp  $+ chrs(10) ;
	foop=foop|tmp ;
      endif;
   endfor;
   damess=damess $+tmp  $+ chrs(10) ;

endfor;
if long==0 ; foop=packr(foop) ; endif ;
if noshow ne 1 ;
   if long==0 ; $foop' ; else ;   print damess ; endif; 
endif;

if long==0 ;retp(foop); endif;
retp(damess); 

endp ;



/**************************/
/*  Display list of data selection criteria 
if missrv(slctlist,0)==0, use all observations.
Otherwise;
 each row of slctlist is a selection criteria
  col1: and (1) or or (2) 
  col2: Varindex (into the VARLIST variable)
  col3: Condition (1=eq  2=ne  3=ge  4=le  5=gt  6=lt ;
  col4: A numeric value

Clist: the matrix  generated by G_BATCH when  a SELECT ... keyphrase is processed 
Dataset: name of dataset
noshow: if 1, do NOT print the list (just return it)
	if noshow has 2 columns, 2nd is a suffix string (placed before each item in list.
	Typically, this is extra spaces

Always returns a string containing the messages.
 


---------- */

proc g_VUslct(CLIST,DATASET,noshow);

local numslct,slctindx,slctval,slctcond,slctand;
local IAT,kid,andor,cond,vv,vnames,condname,andornam;
local damess,tmp,suffix ;

let condname="EQ" "NE" "GE" "LE" "GT" "LT" ;
let andornam="AND" "OR" ;

suffix="  ";
if rows(noshow)>1 ;
  suffix=noshow[2]; noshow=noshow[1]; 
endif;

damess="";
 

if MISSrv(CLIST,0)==0 ;
     damess=" All non-missing observations used.";
     if noshow ne  0 ; print damess ; endif ;
     retp(damess);
endif;

@else ... @

numslct=rows(clist);
slctindx=clist[.,2];
slctval=clist[.,4];
slctcond=clist[.,3];
slctand=clist[.,1];
VNAMES=GETNAME(DATASET);
iat=1;

 do until iat>numslct;
     kid=slctindx[iat]; cond=slctcond[iat]; vv=slctval[iat];
     andor=slctand[iat];
     tmp=ftos(iat,"%*.*lf" ,2,0);
     damess=damess $+ suffix $+ tmp $+ ") ";
     format 3,3; damess=damess $+ " " $+ andor $+  "  ";
     format 8,8 ; damess=damess $+ vnames[kid,1] $+ "  " $+ cond $+ " " ; 
     tmp=ftos(vv,"%*.*lf" ,13,8);
     damess=damess $+tmp  $+ chrs(10) ;
     iat=iat+1;
 endo;

 if noshow ne 1 ; print damess ; endif; 


 retp(damess); 
 
 
endp;


/****************/
@ Procedure to create index of "retained" observations, using slctlist @

 proc g_doslct(critlist,dataset);
 local f1,fout,vnames,dta,i100,ntot,idx,i1,idxall,foo;
 
 if missrv(critlist,0)==0 ; retp(0); endif;


  open f1=^dataset;
  if f1==-1; format 8,8;
         call grbl2_error(" Error: g_doslect can not open dataset:  " $+ dataset,1) ;
         retp(miss(1,1));
  endif;

  vnames=getname(dataset);

  i100=minc(100|rowsf(f1));

i100=rowsf(f1);

  i1=0 ;
  idxall=miss(1,1);
  do until eof(f1);       @ read old data, then test it@
       dta=readr(f1,i100);

       idx= g_doslc0(dta,critlist);
       if not(scalmiss(idx)) ;  @ missing means 'none of these observations should be retained' @
          idx=idx+i1 ;
          idxall=idxall||idx;
      endif;
      i1=i1+rows(dta);
   endo;
  call close(f1); 

  retp(packr(idxall));

 endp;

/*************************/
@ This routine is used by g_doslct @

proc g_doslc0(dta,critlist);

        local arf,kid,compval,cond,andor,tmp,UHOH,foo;
        local THINGIE,NN;
        local numslct,slctand,slctindx,slctcond,slctval;

@ conditions:  eq 1 , ne 2, ge 3 , le  4 , gt 5, lt  6;
  and or    :  and 1, or 2
Depending on CONDITION,  check for whether observations should be included@

slctindx=critlist[.,2];
slctval=critlist[.,4];
slctcond=critlist[.,3];
slctand=critlist[.,1];
numslct=rows(critlist);

@  ---OLD VERSION 
slctand =critlist[.,1];
slctindx=critlist[.,2] ;
slctcond=critlist[.,3];
slctval =critlist[.,4];
---- @
 
 NN=ROWS(DTA);
 if ISMISS(DTA); UHOH=1; else; UHOH=0; endif;
 THINGIE=ZEROS(NN,1);

@  select  observations. First, satisfy or criteria @
  TMP=0;
  for arf (1,numslct,1);
     kid=slctindx[arf,1]; cond=slctcond[arf,1];
                compval=slctval[arf,1]; andor=slctand[arf,1];
      if andor$=="OR" ;
                if UHOH==1;
                   tmp=dta[.,kid] .$== miss(1,1);
                endif;
                if cond$=="EQ"   ;                         @ eq@
                   THINGIE=THINGIE+ (DTA[.,KID] .==COMPVAL);
                elseif cond$=="NE" ;                     @ne@
                   THINGIE=THINGIE+ (DTA[.,KID] ./=COMPVAL);
                elseif cond$=="GE";                   @ge@
                   THINGIE=THINGIE+ (DTA[.,KID] .>=COMPVAL);
                elseif cond$=="LE" ;                  @le@
                   THINGIE=THINGIE+ (DTA[.,KID] .<=COMPVAL);
                elseif cond$=="GT";                   @gt@
                   THINGIE=THINGIE+ (DTA[.,KID] .> COMPVAL);
                elseif cond$=="LT";                  @lt@
                   THINGIE=THINGIE+ (DTA[.,KID] .< COMPVAL);
                endif;   @ which condition@
        endif;    @ andor = or @
        THINGIE=THINGIE.*(1-TMP);
   endfor;        @ get next criteria @

@ now do and conditions @

   TMP=0;
  for arf (1,numslct,1);
       kid=slctindx[arf,1]; cond=slctcond[arf,1];
                   compval=slctval[arf,1]; andor=slctand[arf,1];

    if andor$=="AND" ;

                if UHOH==1;
                   tmp=dta[.,kid] .$== miss(1,1);
                endif;
                if cond$=="EQ"   ;                         @ eq@
                   THINGIE=THINGIE .* (DTA[.,KID] .==COMPVAL);
                elseif cond$=="NE" ;                     @ne@
                   THINGIE=THINGIE .* (DTA[.,KID] ./=COMPVAL);
                elseif cond$=="GE";                   @ge@
                   THINGIE=THINGIE .* (DTA[.,KID] .>=COMPVAL);
                elseif cond$=="LE" ;                  @le@
                   THINGIE=THINGIE .* (DTA[.,KID] .<=COMPVAL);
                elseif cond$=="GT" ;                   @gt@
                   THINGIE=THINGIE .* (DTA[.,KID] .> COMPVAL);
                elseif cond$=="LT";                  @lt@
                   THINGIE=THINGIE .* (DTA[.,KID] .< COMPVAL);
                endif;   @ which condition@
              endif;    @ andor = and @
              THINGIE=THINGIE.*(1-TMP);
    endfor;        @ get next criteria @
    thingie=thingie.>0;

    foo=seqa(1,1,rows(thingie)).*thingie;  @ convert 0/1 vector to ids of the "1" valued elements @
    foo=packr(miss(foo,0));

    retp(foo);


   endp;



/**********************************************/
/* Replicate blocks of text in a string
The string is examined, blocks are removed, and calls are
replaced with the appropriate blocks.

syntax: newstring=g_gosub0(oldstring)

The resulting string is returned.

The syntax of these blocks and calls, in the string, is:
 a) to call a block:
     CALL block_name  arg1 , arg2 ....

 b) to define a block
    i) start with STARTBLOCK block_name;
    ii) grbl type statments (ending with ;).
        These may include %1, %2, etc -- which are substituted with
        arg1, arg2, etc. from the CALL

    iii) end with ENDBLOCK ;

 c) blocks are textual substituions -- hence can be thought of as
    subroutine calls (and NOT procedure calls) -- all variables within
    a block are global

Example:
--------------------------------
   Call bname v1, also v2 ;
   ...

   stop ;

  STARTBLOCK bname  ;
     xx %1 ;
     zz %2 ;
  ENDBLOCK ;


-----------------------------------------------

*/

proc g_gosub0(commands);

local newstr,comlen,com1a,com1b,ablockon,ablock,nblocks,bargt,inndo,isp,lenb;
local acommand,word1,word,ie,ie1,bbody,nn,nth,foo,bname,word2,aa,ee;
local jnn,ablock2,nowname,foundcal,oldgword,tmp,arf;


@ 1: extract strings between STARTBLOCK and ENDBLOCK statements.@


newstr="";
comlen=strlen(commands);
com1a=1;
com1b=1;
ablockon=0;
ablock="";
nblocks=0;
let string bbody[1]= " ";
let string bname[1]= " ";
let string bargt[1]="a" ;

nowname="";
@ -------- extract BLOCKs from code @
do until com1b==0  ;

  com1b=strindx(commands,";",com1a);
  if com1b==0 ; break ; endif;
  acommand=strsect(commands,com1a,com1b-com1a) ;
  com1a=com1b+1;
  {word1,ie}=g_getwrd(acommand,1);

  word1=upper(word1);
  if word1$=="BLOCK"; word1="STARTBLOCK" ; endif;
  if ablockon==1 and word1$=="END" ; word1="ENDBLOCK" ; endif;
  if word1 $/= "STARTBLOCK" and word1 $/= "ENDBLOCK"  ;
      if ablockon==0;
           newstr=newstr $+ acommand  $+ " ; ";
      else ;
            ablock=ablock $+ acommand $+ " ; ";
      endif;
      continue ;
  endif;

  if word1 $== "ENDBLOCK" ;
     if ablockon==0 ; call grbl2_error(" Error: unexpected ENDBLOCK ",0);   continue ; endif;
@ else, save this block to bbody string array @
     nowname="";
     bbody=bbody$|ablock; ablock=""; ablockon=0;
     continue;
  endif;

@  if here, STARTBLOCK. Get block name and arguments ;@
   if ablockon==1; call grbl2_error("ERROR: nested block definition (in" $+ nowname,0) ;stop ; endif;

  {word2,ie}=g_getwrd(acommand,ie+1);
  ablockon=1 ;

  if ie==0 ;  call grbl2_error( " Warning: no block name",0); word2=" " ; endif;
  bname=bname$|upper(word2) ;nowname=word2;

endo ;

if ablockon==1;  call grbl2_error("ERROR: unclosed BLOCK (" $+nowname,0) ; stop ; endif;

@ when here, all blocks have been extracted .
  ---  now, replace GOSUB statements with appropriate blocks @

doblocka: ;

commands=newstr;
newstr="";
comlen=strlen(commands);
com1a=1;
com1b=1;
foundcal=0;
do until com1b==0  ;   @ examine the commands string @

  com1b=strindx(commands,";",com1a);
  if com1b==0 ; break ; endif;

  acommand=strsect(commands,com1a,com1b-com1a) ;
  com1a=com1b+1;
  {word1,ie}=g_getwrd(acommand,1);
  word1=upper(word1);
  if word1 $/="GOSUB" ;
    newstr=newstr $+ acommand $+ " ; " ; continue ;
  endif;

  foundcal=foundcal+1   ;   @ # of GOSUBs found @

@ found a GOSUB -- replace appropriately @
  {word1,ie}=g_getwrd(acommand,ie+1);
  word1=upper(word1);
  if ie==0 ; word1=" " ; endif;

@ else, replace with the approrpiate block @
  nn=1 ; inndo=0;
  do until nn==rows(bname);
     nn=nn+1;
     if word1$==bname[nn] ; inndo=nn ; break; endif;
  endo;

  if inndo==0 ;   call grbl2_error("Error: Calling unknown BLOCK: " $+ word1,0) ; continue ; endif ;
  ablock=bbody[inndo];    @ get the actual block @

@ parse arguments after the call blockname @
  jnn=0 ;
  let string bargt[1]="" ;
  do until jnn==5 ;  @ up to 5 arguments @
    {tmp,ie}=g_getwrd(acommand,ie+1) ;
    if ie==0; 
       break ;
     endif;
    bargt=bargt$|tmp;
  endo;
  if rows(bargt)>=2 ; bargt=bargt[2:rows(bargt)]; endif;


@ replace %n with nth argument -- if no %, skip to next command  @
  isp=strindx(ablock,"%",,1);
  if isp==0;    newstr=newstr $+ ablock; continue; endif;

@ if here, there was a % in ablock @
  ablock2="";           @ ablock2 will contain GOSUB arguments @

  do until ablock$=="" ;    @ ablock is a STARTBLOCK ... ENDBLOCK block @
     if isp>1 ;
        foo=strsect(ablock,1,isp-1);
        ablock2=ablock2 $+ foo ;
     endif;
     nth=strsect(ablock,isp+1,1);
     if nth$==" " or (g_isnumber(nth)==0) ;
         arf="%"$+nth;
     else;
        nth=stof(nth);
        if nth le rows(bargt);
           arf=bargt[nth];
        else;
            arf="";
        endif;
     endif;
     ablock2=ablock2  $+ g_stripc(arf,"' ") ;

@ get next ? @
     ablock=strsect(ablock,isp+2,strlen(ablock)-(isp+1));
     isp=strindx(ablock,"%",1);

     if isp>1 ; continue ;endif;  @ more %s, so proces again @

     ablock2=ablock2 $+ ablock;
     break;
  endo;

  newstr=newstr$+ablock2;  @newstr is the entire set of cmmands @
endo  ;  @ COMMANDS LOOP @

@ nested GOSUBS are allowed -- so check for more CALLs @
if foundcal>0 ;
   goto doblocka ;
endif;


retp(newstr);
endp;


/************************************/

@ Missing value indexer -- called  this iteratively to successivly
  remove observations with missing values in different variables
Usage:
  newindx=g_okindx(dat,nowindx,prots,no_nan)
where:
    dat: (N x K) the dat that might contain missing values
    nowindx: The "cumulative index" of non-missing value observations
             if nowindx=0, then start with this dat
             if nowindx=0 1 "dummies" vector, create an index using the 1s
		       (i.e.; use new_nowindex, new_nowindx=g_mkindx(nowindx))
      prots: 0/1 vector : 1 meaning "this obs protected from removal"
			  If scalar 0, no protection
    no_nan  : if 1, nans,etc are treated as missings
and
    newindx: new index of non-missing obervations (M x 1, M le N, index into rows of dat)

Hint: to modify an index based on a 0/1 dummy, use:
      newindx=g_okindx(miss(dum01,0),nowindx,0,0)
where dum01 is the "0=discard, 1=retain" selection dummy.
@

proc g_okindx(dat,nowindx,prots,no_nan);

local a1,a1a,a2,a3,indef,plus,minus,amiss,oi,f1 ;

if scalmiss(nowindx); retp(nowindx); endif;  @ nothing left to retain @

if cols(nowindx)>1 ; 
   if rows(nowindx)>1 ;
     call grbl2_error("G_OKINDX error: nowindex can only have 1 column ",0) ;
     stop ;
   endif;
   nowindx=nowindx' ;
endif;

if cols(nowindx)==1 and rows(nowindx)==1 ;
     if nowindx==0; nowindx=seqa(1,1,rows(dat)); endif; @ 0 means "use all"  @
endif;

if ismiss(indnv(nowindx,0|1))==0 ;  @ a vector of 0 / 1 dummies, then use as is @
   if rows(nowindx) ne rows(dat);
     call grbl2_error("G_OKINDX error: now-index is 0/1 dummies, but  # rows don't match  # data rows  ",0);
     stop;
   endif;
  f1=1;
else ;
  f1=0;
  if minc(Nowindx)<1 or maxc(nowindx)>rows(dat) ;
    print "G_OKMTX error. Nowindx has a value < 0 or > rows(data) [ ";; rows(dat);; "] ";
 
    stop;
  endif;
endif;

if scalmiss(nowindx); retp(nowindx); endif ;  @ nowindx contains no 1 dummies? @


if missrv(Prots,0)==0  ;
   prots=0 ;
else ;
   if rows(prots)==1 ; prots=prots' ; endif;
   if cols(prots)>1 ; 
      call grbl2_error("G_MKINDX error: protection matrix must be a column vector ",0);
      stop;
   endif;
   if rows(prots) ne rows(dat) ;
       call grbl2_error("G_OKINDX error: # of rows in protected-rows vector must equal rows in data ",0);
       stop ;
   endif;
   if ismiss(indnv(prots,0|1))==1  ;
       call grbl2_error("G_OKINDX error: protected-rows vector must contain only 0s and 1s ",0);
       stop;
   endif;
endif;
indef=0vfff8000000000000;     @see 2.0 maual pp 43 @
plus=0v7ff0000000000000;     @see 2.0 maual pp 43 @
minus=0vfff0000000000000;     @see 2.0 maual pp 43 @
amiss=miss(1,1) ;   

 if no_nan==1 ;
  a1=(dat .$/= indef) + (dat .$/= plus) + (dat .$/= minus) + (dat ./= amiss) ;
else ;
  a1=3 + (dat ./= amiss) ;
endif;

if f1==0;
  oi=zeros(rows(dat),1);  @ this accounts for nowindx @
  oi[nowindx]=oi[nowindx]+1 ;
  nowindx=oi;
endif;
a1a=sumc((a1.==4)').==cols(dat) ;
a2= (nowindx.==1) .and  (( prots  + a1a ) .>= 1)  ;  @ a2 is dummies for okay rows & protected rows @
a3=packr(miss(a2~seqa(1,1,rows(a2)),0));
if scalmiss(a3); retp(a3); endif;
a3=a3[.,2];


retp(a3);
endp;



/************************/
@ alternate name for g_askv1 @
 proc(2)=g_getvar(prompt,def0,varlist,helpmess,forceit,numbok);
local a1, a2;
{a1,a2}=g_askv1(prompt,def0,varlist,helpmess,forceit,numbok);
retp(a1,a2);
endp;

/************************/
@ Select a variable from a list, and its position. 
 Return missing if no match -- (ESC).

 Arguments:

    Prompt --- 1 line prompt
    Default -- Default value
    Varist -- Valid list of variables
    Help  -- 1 line help line, shown if ? or cursor key hit
    Force  -- If 1, disable ESC (force acceptance)
    numbok  -- If 1, numeric values can be input

  Returns 2 values:
   if chosen from varlist: Pointer,Varname  ( into Varlist)
   if number selected: 0, entered_Value
   if ESC: miss(1,1) ," "


@

 proc(2)=g_askv1(prompt,def0,varlist,helpmess,forceit,numbok);
     local iat,ar,ac,ac2,doget,idef0,idef,def,tdef,ans,isnum,ac3 ;
local oldat ;

def0="" $+ def0 ;

oldat=0; 
agin: ;                  @ jump here on missing, forceit=1,ect @

     if scalmiss(def0);
        def="N.A.    "; idef=0 ; idef0=miss(1,1);
     elseif def0$=="" or def0$==" ";
        def="N.A.    "; idef=0 ; idef0=miss(1,1);
     else ;
       isnum=(g_isnumber(def0)) and (upper(def0)$/="E" ) and
             (  upper(def0) $/= "PI" ) ;
       if isnum==1 ;
             def=def0 ;  idef=0; idef0=miss(1,1);
       else ;
          idef=g_indcv2(upper(def0),upper(varlist));
          if scalmiss(idef);
              def=" N.A.   "; idef=0;
              idef0=miss(1,1);
           else;
               def=varlist[idef]; idef0=idef ;
           endif ;
       endif;
     endif;
 

     ar=csrlin ; ac=csrcol ;
     call normalon ; $prompt ;;
     " ( ?, ";;
     ac2=csrcol ;
     call boldon ;  gosub writdef ; call normalon ;     " ) ";;
     ac3=csrcol ;
     iat=0;
     ans="" ;

     do until 1==0 ;               @ until an exit command @

        {ans,iat}=g_cons3(ans,iat);
        if scalmiss(ans);           @ ESC hit @
          if oldat==0 ;
             idef=-1 ;
             break ;
	  else ;
	     oldat=0;
	     ans="";
	     iat=0;
	     scroll ar|ac3|ar|80|0|0;
             locate ar,ac3;
	     continue;
          endif;
        endif;

       if type(ans)==6 ;
           doget=1 ;
       else ;          @ not cursor key @
          if ans$=="?";             @ and not ? @
              doget=1;
          elseif iat==0;
              break ;              @ note: we know idef @
          else ;
              doget=0;
             oldat=oldat+1;
          endif;
       endif;

       if doget==0;                 @ character input mode @
             if ans$=="" or ans$==" " ;         @ use default @
                locate ar,1 ;
                goto agin ;           @ get more io @
             elseif (numbok==1) and (g_isnumber(ans)==1)
                     and (upper(ans) $/="E") and ( upper(ans) $/="PI") ;
                idef=-1 ;
             elseif strlen(ans)>8 ;
                 idef=miss(1,1);
             else ;
                if numbok==0;
                   idef=g_indcv2(upper(ans),upper(varlist));
                else;
                   idef=g_indcv2(upper(ans),upper(varlist)|"#");
                   if missrv(idef,0)>rows(varlist) ; @ must be # @
                      ?;  " Enter a numeric value (. to return to var selection): ";;ans=cons ;
		     ans=g_strip(ans); 
	 	     if ans$=="." or ans$=="" or ans$==" "; goto agin ; endif;
                     if  g_isnumber(ans);
                         call normalon ; ? ;
                        retp(0,ans);
                     else;
                        " Invalid numeric entry: " ;;call blockon ;$ans;; call normalon ; " " ;
                          goto agin ;
                      endif;
                   endif;            @ varlist(idef)=# @
                endif;     @numbok=0@

             endif;
             if scalmiss(idef);       @ unintified, or a number @
                   def=" N.A.   "; idef=0; call normalon ; isnum=0;
             elseif idef<0;         @ but it's a number@
                 def=ans ;  idef=0; isnum=1 ; call boldon ;
             else;
                def=varlist[idef];  call boldon ; isnum=0 ;
             endif;
             locate ar,ac2 ;
             gosub writdef ;
             continue ;

       else ;        @ cursor key or ? @
           ?;
          if numbok==1 ;
             ans=g_askopt(helpmess,varlist|"(#)",idef,0,2,2);
          else ;
             ans=g_askopt(helpmess,varlist,idef,0,2,2);
          endif;
          if scalmiss(ans);
               idef=-1; break ;
          else;
             idef=indcv(ans,varlist) ;
             if scalmiss(idef) and numbok==1;         @ must be "(#)" @
                 ?;  " Enter a numeric value (. to return to var selection): ";;ans=cons ;
                  ans=g_strip(ans); 
	 	  if ans$=="." or ans$=="" or ans$==" "; goto agin ; endif;
                  if  g_isnumber(ans);
 	                call normalon ; ? ;
                        retp(0,ans);
                   else;
                      " Invalid numeric entry: " ;;call blockon ;$ans;; call normalon ; " " ;
                       goto agin ;
	            endif;
             endif;
          endif;
          break ;
       endif;

    endo ;


@ here when got an answer @
   ?;
   if idef==0 ;                     @ no match @
       if isnum==1 ;
         if ans$=="" ;ans=def0; endif ;
           retp(0,ans);
       else;
          " Please select a variable, or hit ESC key to exit. ";
          goto agin ;
      endif;
   elseif idef==-1 ;
     if forceit==1 ;
         " You MUST select a variable! ";
         idef=idef0;
         if scalmiss(idef);
             idef=0;
         endif;
         goto agin ;
     else;
         call normalon ; ?;
         retp(miss(1,1),"");
      endif ;
   else;                    @ got a match @
      call normalon ; ? ; retp(idef,varlist[idef]);
   endif;

@ write def @
writdef: ;
    tdef=g_padword(def,8);
     format /rd 8,8 ;
     $tdef ;;
     return;

 endp;


/***********************************/
@ display list of variables, and get selections from list (more than one selection)
 {vlist,vindex}=ask_for_vars(prompt,varlist,oldlist,helpmessage,force)
  
   prompt: prompt to display at screen top
   varlist: list of variables to chose from
   oldlist: list of variables that are already selected
   helpmessage: extra message to display
   force:  if 1, disable ESC (force acceptance)
  
   vlist : list of selected variables
   vindex :index of vlist into varlist 

Note: 8 vars per line (assuming max of 8 chars per variable
@


proc (2)=g_ask_for_vars(prompt,varlist,oldlist,helpm,force);
local maxlines,rowpos,var_lines,startrow,varlist_loc,varlist_status,ir,ic,pages,onpage,ipage,nvars;
local avar,prompt_line,tvarlist;
local ans,iat,ak,j,iat0,status_line,tans;
local trow,tcol,damatch,ngot,tmp,tmpi,tmp1,foo;
local cursor_at,dopage,perpage,s1,cursor_at_old,help_line,foo2;
local shelp_line,force_ans,antitab,page_line,outof;

if prompt$=="" ; prompt="Please select (or deselect) variables."; endif;

maxlines=19;   	 	@ 24-5 : max lines for displaying variables (per screen @
perpage=maxlines*8;
outof=0;
rowpos=seqa(1,10,8);
nvars=rows(varlist);
tvarlist=varlist;
for j (1,nvars,1);
  tvarlist[j]=upper(varlist[j]);
endfor;


@ number of lines needed (24 lines per screen):
   var-display    prompt gap entryline  statusline  just-in-case
   ceil(nvars/8) + 1  + 1 + 1 + 1 +  1
@

var_lines=ceil(nvars/8);

startrow=csrlin;

if (24-var_lines-5) < startrow ; startrow=1 ; endif;

scroll startrow|1|24|80|0|7;

prompt_line=startrow+var_lines+2;
if prompt_line>maxlines; prompt_line=maxlines+3 ; endif;
status_line=prompt_line+1;
help_line=prompt_line+2 ;
page_line=prompt_line-1;

varlist_loc=zeros(rows(varlist),3);		@ row col page @
varlist_status=zeros(rows(varlist),1);

ir=1; ic=0; pages=1 ; ipage=0;
cursor_at=0 ; ngot=0;

for j (1,nvars,1);			@ assign vars to row, col,page @
     ipage=ipage+1;
     if ipage>perpage ; ipage=1 ; pages=pages+1; ir=1 ; ic=0 ; endif;
     ic=ic+1 ;
     if ic>8 ; ir=ir+1 ; ic=1 ; endif;
     varlist_loc[j,1]=startrow+ir ; varlist_loc[j,2]=rowpos[ic] ;
     varlist_loc[j,3]=pages;
     if not(scalmiss(indcv(varlist[j],oldlist))); varlist_status[j]=1; endif;
endfor;

locate startrow,1;
if strlen(prompt)>79; prompt=strsect(prompt,1,79); endif;
if prompt$/="";   call boldon ; $Prompt;; call normalon ; endif;

STEP1: ;		@ display variables, and status @

outof=0;
onpage=1 ; gosub show_page;
damatch=0; force_ans=0; antitab=0;

ENTERIT: ;

scroll prompt_line|1|status_line|80|0|0;
locate prompt_line,1; call boldon ;
  "Variable to include/exclude (F1=help, or use cursor): ";;
iat0=csrcol;
call normalon;

if force_ans eq 0;
   {ans,iat,ak}=g_cons1("",0,2);
else ;				@ force an answer @
   ans=force_ans ; iat=0; ak=force_ans;
   force_ans=0;
endif;

do while 1==1 ;
  if ak==32 and ans$=="";  goto enterit ; endif;
  if ak==1061 ; ak=13; ans=""; iat=0; endif;  @ f3 is immediate exit @

  if ak==1059    ;     @ f1 is help @
     gosub show_help ;
     gosub show_page ;
     goto enterit ;
   endif;

   if ak==1015;  ak=9; ans=9 ; antitab=1;  endif;   @ hack used below @

   if ak>255 ;     @ cursor key hit @
    cursor_at_old=cursor_at ;
    gosub do_cursorat;

    if outof==1 ;

      gosub update_damatch ;
      cursor_at=1 ; cursor_at_old=1;
      goto step1 ;
    endif;

@ pgup pgdn special (might be set in do_cursorat @
    if ak==1073  ;      @ pgup  @
       gosub show_page ;
       gosub update_cursorat;
       goto enterit ;
    ENDIF;

    if ak==1081  ;      @ pgup  @
       gosub show_page ;
       gosub update_cursorat;
       goto enterit ;
    ENDIF;

    if cursor_at_old ne 0 ;
      damatch=cursor_at_old ;
      gosub update_damatch ;
    endif;
    if cursor_at > 0 ;
      ans=varlist[cursor_at];
      gosub update_cursorat;
    endif;
    damatch=cursor_at;
  endif;

 if iat==0 and  ans$=="*";      @ select all @
      varlist_status=(varlist_status*0)+1 ;
      goto step1 ;
 endif;
 if iat==0 and  ans$=="-*";      @ deselect all @
      varlist_status=(varlist_status*0) ;
      goto step1 ;
 endif;

 if ak==9  ;		@ tab - select to end of line, shift tab- deselect @
     if cursor_at eq 0 ; antitab=0; goto enterit ; endif;
     tmp=ceil(cursor_at/8)*8 ;tmp=minc(tmp|nvars);
     for j (cursor_at,tmp,1);
	damatch=j;
        varlist_status[damatch] = 1-antitab;
        gosub update_damatch;
     endfor;
     cursor_at=minc(nvars|damatch+1);
     gosub update_cursorat;
     damatch=0;
     antitab=0; goto enterit ;		@ get next word @
 endif;

 if ans$/="" ;  gosub do_damatch; endif;
 if damatch > 0;
        scroll status_line|1|status_line|80|0|0;
        locate status_line,1 ;
        call normalon;
	if varlist_status[damatch] == 0;
            "                        Hit Enter to select: ";;call boldon;
           format /ld 1,8;$varlist[damatch];;
	else;
           "                       Hit Enter to Deselect: ";;call boldon;
           format /ld 1,8;$varlist[damatch];;
	endif;
        locate prompt_line,iat0 ;
  else;
     scroll status_line|21|status_line|80|0|0;
  endif;

  if iat ne 0 and ak==27;	@ esc to start over @
      goto enterit ;
  endif;

  if iat==0 ;
     if ak==27 and force==1 ;		@ do not allow ESC @
         scroll status_line|1|status_line|80|0|0;
         goto enterit ;
     endif;

     if ans$=="" or scalmiss(ans)  ;	@ no answer means "done with selecting"  @
       break;
     endif;

    if ak<33;		@ tab or enter signal "end of word " @
       gosub do_damatch;
       if damatch>0;
	     varlist_status[damatch]=1-varlist_status[damatch] ;
 	     gosub update_damatch;
       endif ;
       ngot=ngot+1;
       if ak==32 ;			@ space means ENTER-right_arrow @
	   force_ans=1077 ;
       endif;
       goto enterit ;		@ get next word @
    endif;			@ got a word @

  endif;		@ iat=0 @

@ build the word ... @
  {ans,iat,ak}=g_cons1(ans,iat,2);

endo;		@ building word @
scroll status_line|1|24|80|0|0;
locate status_line,1 ;

tmp={}; tmpi={};
for j (1,nvars,1);
 if varlist_status[j]==1 ;
   tmp=tmp|varlist[j];
   tmpi=tmpi|j ;
 endif;
endfor;

retp(tmp,tmpi);

@ --------------------------------------------------------------------@
@  subroutines @
@ --------------------------------------------------------------------@


@ ------------ @
show_help:
   shelp_line=14;
     scroll help_line|1|help_line|80|0|0;
     locate help_line,1;
     call yellowon ; 
     if strlen(helpm)> 79 ; helpm=strsect(helpm,1,79); endif;
     $helpm;; call normalon ;

     if help_line< shelp_line ;
       tmp1=help_line+1;
       scroll tmp1|1|24|80|0|0;
     else;
       tmp1=shelp_line;
       scroll tmp1|1|24|80|0|0;
     endif;
     locate tmp1,1;
     call boldon ;call yellowon ;"You can select variables either by... "; call normalon;
     "  i)";; call yellowon;" entering a variable name:";; call normalon;?;
     "    - substring matches are used (to match what you type to the variable list)";
     "    - if you misttype, ESC clears the line (sorry, backspace doesn't work)";
     "    - ";;call boldon;"* ";;call normalon ; "to select all the variables,";;call boldon;" -*";;call normalon ;" to deselect.";
     " ii) ";; call yellowon;"using the cursor keys";; call normalon ;" (the arrows,home, and end keys).";
     "iii) ";; call yellowon;"space, tab, shift-tab";; call normalon ;" can be used to rapidly select/de-select.";

     "Once you have chosen a variable, hit ENTER to select (or de-select) it.";
     "When you are done selecting variables, hit F3 (or ENTER on a blank line)";
     if tmp1==shelp_line ;
        call blockon; ".. hit any key to resume variable selection";;call normalon;
        call waitc;
        scroll tmp1|1|24|80|0|0;
        locate help_line,1;
        call yellowon ; 
        if strlen(helpm)> 79 ; helpm=strsect(helpm,1,79); endif;
        $helpm;; call normalon ;
     endif;
 return;

@ ------------ @

@ add to cursor_at 
 Cursor keys:
  pgup: 1073            pgdn 1081
  home: 1071		end: 1079
  f1: 1059   f2: 1060 ....  F9: 1067
 uparrow: 1072   downarrow: 1080
 leftarrow: 1075  rightarrow: 1077
--------@

do_cursorat: ;

if ak==1073  ;      @ pgup  @
       onpage=maxc(1|(onpage-1));
       cursor_at=(perpage*(onpage-1))+1;
ENDIF;

if ak==1081  ;      @ pgdn  @
    if onpage==pages;
	cursor_at=nvars;
    else;
       onpage=minc(pages|(onpage+1));
       cursor_at=(perpage*(onpage-1))+1;
    endif;
ENDIF;

if ak==1071 ;      @ home  @
   s1=((onpage-1)*perpage)+1;
   if s1==cursor_at ;
      cursor_at=1 ;
   else;
      cursor_at=s1 ;
   endif;
   if varlist_loc[cursor_at,3] ne onpage ;
      onpage=varlist_loc[cursor_at,3];
      ak=1073 ;
   endif;   @ treat as pgup if move to next page @
endif;

if ak==1079 ;      @ end @
   s1=(onpage*perpage);
   if s1==cursor_at ;
      cursor_at=nvars ;
   else;
      cursor_at=minc(s1|nvars);
   endif;
   if varlist_loc[cursor_at,3] ne onpage ;
      onpage=varlist_loc[cursor_at,3];
      ak=1081 ;
   endif;   @ treat as pgdn if move to next page @
endif;


if ak==1072 ;      @ up  @
   if cursor_at==0 ; cursor_at=1 ; return ;endif;
   if cursor_at>8 ;
      cursor_at=cursor_at-8 ;
   endif;
   if varlist_loc[cursor_at,3] ne onpage ;
       ak=1073 ;
       onpage=varlist_loc[cursor_at,3];
   endif;   @ treat as pgup if move to next page @
   return;
endif;

if ak==1080;        @ down @
   if cursor_at==0 ; cursor_at=1 ; return ;endif;
   cursor_at=cursor_at+8 ;
   if cursor_at>nvars; cursor_at=nvars; endif;
   if varlist_loc[cursor_at,3] ne onpage ;
       onpage=varlist_loc[cursor_at,3];
       ak=1081 ;
   endif;   @ treat as pgdn if move to next page @
   return;
endif;

if ak==1075 ;      @ left @

   if cursor_at==0 ; cursor_at=1 ; return ;endif;
   cursor_at=cursor_at-1 ;
   if cursor_at<1; outof=1 ; cursor_at=1; endif;
   if varlist_loc[cursor_at,3] ne onpage ;
      onpage=varlist_loc[cursor_at,3];
      ak=1073 ;
   endif;   @ treat as pgup if move to next page @
   return;
endif;

if ak==1077 ;      @ right @
   if cursor_at==0 ; cursor_at=1 ; return ;endif;
   cursor_at=cursor_at+1 ;
   if cursor_at>nvars;outof=1; cursor_at=nvars; endif;
   if varlist_loc[cursor_at,3] ne onpage ;
      onpage=varlist_loc[cursor_at,3];
      ak=1081 ;
   endif;   @ treat as pgdn if move to next page @
   return;
endif;

return;


@ ---------------- @
@ Show a page of variables @
show_page:;
scroll startrow+1|1|prompt_line|80|0|0;
for j (1,nvars,1);
   if varlist_loc[j,3] ne onpage ; continue ; endif;
   locate varlist_loc[j,1],varlist_loc[j,2];
   if varlist_status[j]==1 ; call g_screen("",1|44) ; else; call normalon ; endif;
   avar=varlist[j]; format /ld 1,8; $avar ;;
   if varlist_status[j]==1 ; call normalon ; endif;
endfor;
if pages>1 ;
  locate page_line,1;
  call yellowon ;
  "Displaying page ";; format /ld 3,0 ; call boldon ; onpage;; call normalon; call yellowon; " of " ;; pages ;; "pages. Use PgUp and PgDn to view other pages.";;
  call normalon;
endif;
return;

@ ---------------- @
@ update (highlight off or on) a word at damatch @
update_damatch:
if damatch==0 ; return; endif;
if varlist_loc[damatch,3] ne onpage ; return; endif;
trow=varlist_loc[damatch,1]; tcol=varlist_loc[damatch,2];
locate trow,tcol;
if varlist_status[damatch]==1 ; call g_screen("",1|44) ; else; call normalon ; endif;
avar=varlist[damatch]; format /ld 1,8; $avar ;;
if varlist_status[damatch]==1 ; call normalon ; endif;
return;

@ ---------------- @
@ update (highlight off or on @
update_cursorat:;

if varlist_loc[cursor_at,3] ne onpage ; return; endif;
if cursor_at==0 ; return; endif ; @ a word at cursorat @

trow=varlist_loc[cursor_at,1]; tcol=varlist_loc[cursor_at,2];
locate trow,tcol; call normalon;
if varlist_status[cursor_at]==1 ; 
    call g_screen("",7|44) ; 
else; 
   call  g_screen("",1|47) ;
 endif;
avar=varlist[cursor_at]; format /ld 1,8; $avar ;;
call normalon ;
return;
 

@ ---------------- @
@ search for a match -- check for exact matches first, then substring matches @
do_damatch:;

  tans=upper(ans);
  damatch=0;
  if ans$=="" ; return; endif;
  for j (1,nvars,1);
    if tvarlist[j] $== tans ;
      damatch=j ;
      return;
    endif;
 endfor;
 for j (1,nvars,1);
   if strindx(tvarlist[j],tans,1) > 0;
      damatch=j;
      return;
   endif;
 endfor;
 return;
@ ---------------- @
   

endp;


/*********************/

proc g_padword(aword,isize);  
 local a;
 a=g_padwrd(aword,isize,0);
 retp(a);
endp;

@ ---------------- @

@ pad or cut a word to size isize @
    proc g_padwrd(aword,isize,front);
    local ilen,i;
    if scalmiss(aword); aword="" ; endif;
    aword=""$+ aword ;

    ilen=strlen(aword);
    if ilen<isize ;
        for i (ilen+1,isize,1);
	   if front==0 ;
              aword=aword$+" " ;
	   else;
	      aword=" "$+aword ;
	   endif;
        endfor ;
    endif;
    retp(strsect(aword,1,isize));
  endp;

/*************************************/
@ a shortcut to g_askopt2 -- ignorwe "how option chosen" argument @
 proc g_askopt(prompt,list,def,helps,c_prompt,c_help);
  local a1,a2;
  {a1,a2}=g_askopt2(prompt,list,def,helps,c_prompt,c_help);
  retp(a1);
endp;

/*************************************/
@ g_askopt2
  Prompt-- A string used as a prompt
   List -- A  L x 1 vector of names: this is the list to choose from
   def  -- The default choice (one of the values in LIST, or the numeric index of the default 
  helps -- if scalar 0, it is ignored.
           or, a  L x 1 string vector of 1 sentence help messages for each choice in the LIST vector.
  c_prompt -- Scalar: how to display prompt:   0=normal, 1=bold, 2=block, 3=bold yellow, 4=cyan, 5=white on cyan, else=normal
  c_help -- Scalar, how to display help (use same values as c_prompt)

 returns 2 vars:
    option chosen
    how chosen (keystroke used)
    
@
 proc (2)=g_askopt2(prompt,list,def,helps,c_prompt,c_help);

  local idef,i,ii,ans,arow,acol,arow0,llen,jii,t1,t2,multilin;
  local tmp1,tmp2,boldit,rowmult,olddef,ido,stmp1,stmp2,prlen ;
  local tmp,gotkey,iat,ir,oldat,alen,idefq,foo;
  local  nospace,inlist,nowline ;
  local ipage,ith1,ith2,pages,nlines,promplin,hilitecu ;
  local i2,i1,aword ;
  local VLITE,LINFO,helpline,ishelp,adtype,amess0,helprow ;
  
  inlist=rows(list);
  helprow=0; ishelp=0;
  if prompt$=="" ; prompt="Select "; endif;
  
  if type(def)==13 ;  def=0 $+ def ;  endif ;
  if type(helps)==15 ; ishelp=1 ;endif;  

 @ ignore leading spaces if _NoSpace =1    . @
  if scalmiss(typecv("_NoSpace"));
           nospace=0 ;                  @ default is NOT ignore @
        else;
          nospace=varget("_nospace") ;
          if scalmiss(nospace); nospace=0 ; endif;
          nospace= nospace==1 ;
  endif;

   def=missrv(def,0);

   multilin=0; gotkey=0;
   idef=0;                   @ find default value in list @
   for i (1,inlist,1);
        if i==def ;
            idef=i;
            break;
        elseif upper(def)$==upper(list[i]);
            idef=i;
            break;
        endif;
   endfor ;

@ set default for use below @
  if idef==0;
    def="";
  else;
    def=list[idef];
  endif;


@ number of pages @
  pages=trunc((inlist/144)+0.99999999) ;

@ # lines, and location of prompt @
  ?; arow0=csrlin ;
  if pages>1 ;
     nlines=18 ;       @ 18 * 8 = 144 @
     promplin=1 ;
  else ;
    nlines=trunc((inlist/8)+0.99999) ;
    if arow0+nlines > 21 ;   @ can't fit on current screen @
       promplin=21-nlines-1 ;
       locate promplin,1 ;
       tmp1=promplin ; tmp2=0;
       do until tmp2==tmp1 ;
          tmp1=csrlin ;
          ? ;
          tmp2=csrlin ;
       endo ;
       foo=1 ;
       do until foo ge (tmp2-promplin) ; ? ; foo=foo+1; endo ;
    else ;
       promplin=arow0;
    endif;
   endif ;

  ipage=1 ;
  ith1=1 ;
  ith2=minc((ith1+143)|inlist) ;
   hilitecu=1 ;

  gosub showem(ith1,ith2,idef);

@ Enuf variables to fit on 1 page  @
    ans=""; iat=0;
    ir=csrlin ;
    idefq=idef ;

agin: ;                         @ here to get next key @
    locate arow,acol ;                 @ g_cons3 will locate on proper column @
    {ans,iat}=g_cons3(ans,iat) ;
    if (ans $==" " and nospace==1 );
        ans=""; iat=0;
        goto agin ;
    endif ; @ ignore leading space@

@ Esc, cursor, or CR/LF key hit ? @
    if scalmiss(ans);                      @ ESC key @
          call normalon; retp(miss(1,1),27);
    elseif type(ans)==6 ;                @ cursor key hit @
       goto gotans ;
    elseif ans$=="?" and iat==0 ;
        idef=indcv("?",list);
        if scalmiss(idef);idef=idefq ; goto agin;else; goto gotans; endif;
    elseif iat==0 ;                     @ CR or LF hit @
       goto gotans ;
    endif ;

@ character key @
a1: ;                           @ hilite current default@
    if ans$=="" ;               @ refresh @
         if idef ne 0 ;
           if trunc((tmp/144)+0.99999)==ipage;
              gosub show1(idef,0,ith1);
           else ;
              gosub show1(idef,0,0);
           endif;
           idef=0 ;
         endif;
    else ;
       if strlen(ans)>8 ;
         tmp1=miss(1,1);
       else ;
           tmp1=g_indcv2(upper(ans),upper(list));
       endif;
       if scalmiss(tmp1);           @ is it a number?@
          if g_isnumber(ans)==1 ;    @ yup, set it up right @
             tmp2=missrv(trunc(stof(ans)),0);
             if tmp2>0 and tmp2 le inlist; tmp1=tmp2;  endif;
          endif;
       endif;                   @ checking for number @

      if scalmiss(tmp1);       @ no match? @
         if idef ne 0 ;
           if trunc((tmp/144)+0.99999)==ipage;
              gosub show1(idef,0,ith1);
           else ;
              gosub show1(idef,0,0);
           endif;
           idef=0 ;
         endif;                      @ else, nothing is highlighted @
      else;                    @ yes match @
         if idef ne tmp1 ;          @ changed current choice@

            tmp=trunc( (idef/144)+0.999999);
            if tmp eq ipage ;                @ rewrite page @
               gosub show1(idef,0,ith1) ;  @ unhilite prior @
            endif ;
            idef=tmp1;
            tmp=trunc( (idef/144)+0.999999);
            if tmp ne ipage ;                @ just do blue thing @
                gosub show1(idef,1,0) ;
            else ;                          @ same page @
                gosub show1(idef,1,ith1) ;
            endif ;

        endif ;        @ idef ne tmp1 @
      endif;                @ match @
     endif;                  @ ans = "" @

   goto agin ;
 @ SHOW1 @

@--------- Either got cursor key or valid answer (with pointer to! @
gotans: ;

    if type(ans)==6 ;
       olddef=idef ;
       if ans==1077 ;           @ right arrow @
           idef=idef+1 ;
       elseif ans==9;            @ tab (move over 4 @
           idef=idef+4 ;
       elseif ans==1075 ;        @ left arrow @
           idef=idef-1 ;
       elseif ans==1071 ;       @ home @
           idef=1;
       elseif ans==1079 ;        @ end @
           idef=inlist ;
       elseif ans==1081 ;            @pgdn @
           if pages>1 ;
             idef=idef+144 ;
           else ;
             idef=idef+(inlist/2);
           endif;
       elseif ans==1073 ;                 @pgup @
           if pages>1 ;
             idef=idef-144 ;
           else ;
             idef=idef-(inlist/2);
           endif;
       elseif  ans==1080;                 @ down arrow @
           idef=idef+8 ;
       elseif ans==1072;                  @ up arrow @
           idef=idef-8 ;
       elseif ans==1059 ;		@ F1 for help @
	   retp(list[idef],1059); 
       endif ;

       if idef>inlist; idef=inlist ; endif ;
       if idef<1; idef=1; endif ;


@ CHECK HERE for if ON CURRENT PAGE @
       tmp=trunc( (idef/144)+0.999999);
       if tmp ne ipage ;                @ rewrite page @
         ipage=tmp ;
         ith1=((ipage-1)*144) + 1 ;
         ith2=minc((ith1+143)|inlist) ;
         gosub showem(ith1,ith2,idef);
       else ;
           gosub show1(olddef,0,ith1) ;  @ unhilite prior @
       endif ;

        gosub show1(idef,1,ith1) ;

    else ;                  @ got an 'ans' from keyboard input @
       if idef>0 ;
        ? ; call normalon ;
          retp(list[idef],1);
       else;                    @ no entry, but no escape.. get it @
             ;
       endif;
    endif;

    goto agin ;


@ arow,acol and promptin are given @
show1:                  @ hilite on/off for 1 var @
pop tmp ; pop boldit ; pop ido ;

aword=list[ido];

if ido>0 and ido<=inlist;
    stmp1=trunc((ido-ith1+1)/8)+1; stmp2=(ido-ith1+1)%8;
    if stmp2==0 ; stmp1=stmp1-1 ; stmp2=8 ;  endif ;
    foo=promplin+stmp1;
    if foo<arow and tmp>0;
       locate foo,(stmp2-1)*9+4 ; 
       format 1,8;
      if BOLDit==1 ;
          call boldon ; $AWORD ;; call normalon;
      elseif BOLDit==-1 ;
          call blockon ;   $AWORD ;; call normalon;
      else;
          call normalon ; $AWORD ;;
      endif;
    endif ;

@ blue by SELECT message @
    if acol<61 and hilitecu==1;   
       scroll arow|(acol+10)|arow|79|0|0 ;
       locate arow,acol+10;
       if boldit==1; call normalon ;
          call blockon; call blueon ;  call boldon;
          $aword ;; call normalon;
       else;
          call normalon ;
       endif;
    endif;

@ help message line @
    if ishelp==1 and helprow>0 ;
      scroll helprow|1|helprow|80|0|0;
      if boldit==1;
        amess0=helps[ido];
        locate helprow,1 ;
        gosub doadtype(c_help);
        $amess0 ; call normalon ;
      endif ;
    endif ;
    locate arow,acol;

  else ;            @ no entry selected @

    if ishelp==1 and helprow>0 ;
      scroll helprow|1|helprow|80|0|0;
    endif ;

  endif;

return;

showem:
  pop idef ; pop i2 ; pop i1 ; hilitecu=0;
  arow=promplin+nlines+2 ; acol=1 ;
  scroll maxc((promplin-1)|1)|1|(promplin+nlines+2)|80|0|0;
  locate promplin,1 ;

@ set display according to prompt/help line display type @
  gosub doadtype(c_prompt);
  print  $prompt ;
  call normalon ;

  ii=i1 ;      nowline=promplin ; call NORMALON ;
  do until ii> i2 ;
     if (ii % 8 ) == 1 ;
         nowline=nowline+1 ;
         locate nowline,1 ;
         " : " ;;
     endif ;
     gosub show1(ii,ii==idef,ith1) ;
     ii=ii+1;
   endo ;
   hilitecu=1 ;

@ set stuff up @
  arow=nlines+promplin+1 ; acol=1 ;
  if pages>1 ;
    locate arow,acol+19 ; format /ld 3,0 ;
    if ipage==1 ;
       call blockon ; call blueon ; ipage;; call normalon ;
       call blockon ; " of " pages
       "pages. PgDn for other choices.";
    elseif ipage ne pages ;
       call blockon ; call blueon ; ipage;; call normalon ;
       call blockon ; " of " pages
       "pages. PgDn or PgUp for other choices.";
    else ;
       call blockon ;  call blueon ; ipage;; call normalon ;
       call blockon ; " of " pages
       "pages. PgUp for other choices.";
    endif ;
    arow=arow+1;
  endif ;
  if ishelp==1 ;
    scroll arow|1|arow|80|0|0;
    helprow=arow ;
    if MISSRV(IDEF,0)>0 ;
       amess0=helps[idef];
       gosub doadtype(c_help);
       locate arow,acol ;
       $amess0 ;
    endif;
    arow=arow+1;
  endif;
  locate arow,acol ;
  call normalon ;call boldon ; " Select from above ? ";;
  acol=csrcol ; call normalon ;
  return;

@ set display according to prompt/help line display type @
doadtype:;
  pop adtype ;
  call normalon ;
  if adtype==1 ; call boldon ;
  elseif adtype==2 ; call blockon ;
  elseif adtype==3 ; call boldon ; call yellowon ;
  elseif adtype==4 ; call boldon ; call cyanon ;
  elseif adtype==5 ; call cyan_bkg ; call boldon ;
  else ; call normalon ; 
  endif ;
  return;

endp;

@retp cons @


/**********************/
/******************************/
@ g_askvs  -- synonymous with of g_gtvars 
  (a simple front end to g_askvs2)
  select multiple choices from reflist, curlist is the currently chosen @
proc g_askvs(curlist,reflist);
local a,v;
{a,v}=g_askvs2(curlist,reflist,"","");
retp(v);
endp;

@---------------------------------------------- @
@ g_gtvars  -- synonymous with of g_askvs 
  (a simple front end to g_askvs2)
  select multiple choices from reflist, curlist is the currently chosen @
proc g_gtvars(curlist,reflist);
local a,v;
{a,v}=g_askvs2(curlist,reflist,"","");
retp(v);
endp;

@---------------------------------------------- @
@  g_askvs2 -- synonym for g_ask_for_vars
  select vars from REFLIST. CURLIST contains currently selected vars
  Reflist must not be empty
  Returns list of names selected. 0 if empty

    {varindx,varnames}= G_askvs2(defvars,varlist,prompt,helpmess)  -@

proc (2)=g_askvs2(curlist,reflist,prompt,helpmess);
 local vnames,vlist;
   if reflist==0;
        " No reference list ";
        retp(0,0);
   endif; ;

   {vnames,vlist}=g_ask_for_vars(prompt,reflist,curlist,helpmess,0);

   retp(vlist,vnames);

endp;


/*************************************/
@ list variables, highlighting selected subset. Returns line, column
  of first entry in table.  Seven entries per line. Each entry
  takes up 9 spaces, with 2 buffer spaces between. (retp(line,column).
  The n argument :  7= 7 per line   (eg; helpvar2
                    8= 8 per line   (eg; helpvar3
@

  proc (2)=g_helpv(varnames,HILITE,message,n);

  local ii,nvars,jn,inx,iii,ll0,cc0;

  inx=indcv(hilite,varnames); if scalmiss(inx); inx=0; endif;

  if varnames==0;
       " No variable list available.";
      retp;
  endif;

  format /rd 8,8;
  if message $/= 0 ;
          $message ;
          call hiliteon ; " Highlighted " ;;
          call normalon ; " variables have been selected.  ";
  endif;
  ?;

   nvars=rows(varnames);
   ii=1; format /rd 8,8;
   ll0=csrlin; cc0=csrcol;
   do until ii> nvars;
        jn=minc((ii+(n-1))|nvars);
        iii=ii;
        do until iii>jn;
          if not(scalmiss(indnv(iii,inx)));
              call hiliteon ;
          else;
              call normalon ;
          endif;
          $varnames[iii] ;;
          call normalon ;
          if  n==7 ; "  ";; else ; "" ;; endif;
          iii=iii+1;
        endo;
        ii=ii+n; ?;
   endo;
  retp(ll0,cc0);
endp;





/*********************************/
@ ask for values for coefficients, displaying Variable names and  old values (if available).

  bnew=g_usrset(prompt,pnames,b,mtxname,cols,change_ok,charmode)

where
       prompt = String. A descriptive prompt.
        Pnames= M x 1 Vector of names.
            b = N x 1   Vector of default values (or a matrix)
     mtxname = if 0, ignored. or, a Mx1 string vector of descriptions
     cols     = # columns to display at once, from 1 to 6.
   change_ok  = Change allowed flag. 1=Changes allowed, 0=Changes NOT allowed (not saved)
   charmode  = If 1, character mode. Otherwise, numbers.

   bnew: new values of b

Notes:

  *  if rows(pnames) < rows(b), match b to pnames, and  discard extras
     (or use the global variable, _userset, if not enough values in b)
     (or 1 if _userset is not available)
  *   User can request that several values should
      be  read from a .FMT file, or from a text file.
  *  User can compute functions [*,/,^, and + ].
@

  proc g_usrset(prompt,pnames,b,mtxname,jcols,changeok,charmode);

    local nb,np,ii,aa,bnew,ii2,aword,ntmp,btmp,foo,foo2,oldb,typename;
    local isa_strg,ncols,aname,dofileio,AMESS,LINESDO,filetype,huhline ;
    local v1,v2,aword2,ie,aword1,clearit,pages,ipage,ith1,ith2,onpage ;
    local iline,lastline,needline,tmp,ith,inow,bs,topline,ilineat,tmpid,tmpid2 ;

    dofileio=0;
    ncols=minc(jcols|6);

    TOPLINE=2; LINESDO=18 ;

    
@ avoid possible problems, return oldb if display only mode @
    oldb=b;

    $prompt;

    nb=rows(b);
@ b=missrv(b,0);@
    np=rows(pnames);
    if nb/=np;          @if not same number of coeffs as varnames @
       @ Match as many as you can @
       if np>nb;           @this section useful if change of models, same vars@
          if not(scalmiss(typecv("_userset")));
             bs=ones(np,1)*varget("_userset");   @ default is _userset  @
          else;
             bs=ones(np,1) ;   @ default is 1.0  @
          endif;

          bs[1:nb]=b;      @ except for first nb vars@
       else;
          bs=b[1:Np];      @ use first np of the b values @
        endif;
    else;
        bs=b;
    endif;
    bnew=bs ;


@ Compute how many lines will be needed @
        tmp=csrlin ;
        needline=(np/ncols)  ;
@ if many parameters, more than 1 page needed @
        if needline > LINESDO ;
            pages=trunc( (needline/LINESDO)+0.9999) ;
        else ;
            pages=1 ;
        endif ;
        ipage=1 ;
        if ( pages > 1) or (needline+tmp > LINESDO) ;              @ no room @
           gosub DOCLS ;
           iline=2 ;
        else ;
           iline=tmp ;
        endif ;

@ Display names and current values @

inow=1 ;
topline=iline ;
first1: ;

     ith1=((ipage-1)*(LINESDO*ncols))+1;
     ith2=minc((ith1+(LINESDO*ncols-1))|np) ;
    ith=1;

hopit: ;
     locate topline,1 ;
     call blueon ; call blockon  ;
     if changeok ;
       " Display and change values.  F1=Help, F3=Exit, ESC=Cancel.";
     else ;
        " Display values.  F1 for help. F3 or ESC when done.";
     endif;
     call normalon ;
     FOO=ITH1;
     do until FOO>ith2 ;
@       isa_strg=1-g_isnum(bnew[foo]);@
isa_strg=charmode ;
       ilineat=usr_set0(pnames[FOO],bnew[FOO],topline,FOO,inow,ith1, ncols,isa_strg);
       FOO=FOO+1;
     endo;

     locate ilineat+1,1 ;
     if pages==1 ;
         "              ";;call blockon;
         " ----------------------------------------- ";
         call normalon ;
     else ;
           call blockon; format /ld 4,0 ;
           " ------ Page " ;; call blueon ;
          ipage ;; call normalon ; call blockon ;
          " of " pages ;; format 1,8;
         typename="Parameters" ;
         if changeok==0; typename="Variables" ; endif ;
         if ipage==1 ;
            ".  PgDn for other " $typename " ---";
         elseif ipage==pages ;
            ".  PgUp for other " $typename " ---";
         else ;
            ".  PgUp and PgDn for other " $typename " ---";
         endif;
         call normalon ;
     endif ;

     ilineat=ilineat+2;

     clearit=0;


@  ------------   ask for input @
    do until 1==2 ;                 @ exit via ESC or return AT LAST VALUE @
        if pages>1 ;
           onpage=trunc((inow/(LINESDO*ncols))+0.999);
           if onpage ne ipage ;
             ipage=onpage ;
             ith1=((ipage-1)*(LINESDO*ncols))+1;
             ith2=minc((ith1+(LINESDO*ncols-1))|np) ;
             gosub DOCLS ;
             goto hopit ;
           endif ;
        endif ;

        if clearit==1 ; gosub DOCLS ; break ;  endif ;

        inow=minc(maxc(inow|1)|np) ;  @ keep in bounds @
        isa_strg=1-g_isnum(bnew[inow]);
        call usr_set0(pnames[inow],bnew[inow],topline,inow,inow,ith1,ncols,
                      isa_strg);
        locate ilineat,1 ;
        format 8,8;
        gosub clrline(ilineat);

eek: call boldon ;
        if mtxname$==0 ;
            format /rd 8,8 ; $pnames[inow] " = " ;;
        else ;    @ mtxname IS spedcified @

            format /rd 1,8;
            if type(mtxname) eq 15 ;         @ string @
                $mtxname[inow];;
                "[" ;; format 1,8; $pnames[inow] "] = " ;;
             else ;                  @ vector, or scalar @
                 "Matrix element: " $mtxname;;
                 "[" ;; format 1,8; $pnames[inow] "] = " ;;
             endif;   @ string mtxname @
         endif;     @ mtxname exists @

         if isa_strg==1 ;
            format /ld 8,8 ; $bnew[inow] ;;
         else ;
             format /lz 20,14 ; bnew[inow];;
         endif;
         if changeok ;
            "?";;
         endif ;

@ Get USER INPUT   ========================= @
        aword=upper(g_cons2());

@ EXit ??????  @
doexit: ;
         if scalmiss(aword);              @ ESC @
              if changeok==1 ;
                   " Values Not Changed. ";
               else ;
                   " <ESC>  ";
               endif;
               retp(oldb);      @ cancel @
         else ;
              if type(aword)==6 ;            @ cursor key @
                 if aword==1045 or aword==1061 ;      @ alt-x or f3 @
                    ? ;
                    if changeok ; retp(bnew); else; retp(oldb); endif ;
                endif;
              else ;
                   ? ;
              endif ;
         endif ;

@ Convert ? to help query-code @
         if isa_strg==0 and aword$=="?";
             aword=1059 ;
         endif ;

        if aword$==""; aword=13 ; endif ;  @ convert CR to ASCII  @

        gosub clrline(ilineat+1);
        call normalon ;

awordgot: ;
@ is it non-ascii I/o ?????????????? @
         if type(aword)==6 ;            @ cursor key @
            ith=inow ;
            if aword==1072 ;          @  up @
               inow=inow-ncols ;
            elseif aword==1080 ;        @ down @
               inow=inow+ncols ;
            elseif aword==1071 ;       @ home @
               inow=1 ;
            elseif aword==1079 ;        @ end @
                inow=np;
            elseif aword==1077 ;        @ right @
               inow=inow+1 ;
            elseif aword eq 1081 ;      @pgdn @
               if inow==np ;            @ currently at end @
                   ?;
                   gosub alldone;
               endif;
               if pages==1 ;
                   inow=inow+LINESDO ;
               else;
                   inow=inow+(LINESDO*ncols) ;
               endif ;
           elseif aword eq  1073 ;      @ pgup @
               if pages==1 ;
                   inow=inow-LINESDO ;
               else;
                   inow=inow-(LINESDO*ncols) ;
               endif ;
               inow=inow+1 ;
            elseif aword==13 ;        @ enter @
               inow=inow+1 ;
               if INOW > NP ;
                   gosub alldone;
               endif ;

            elseif aword==1075  ;      @ left @
               inow=inow-1 ;


            elseif aword==1067 ;     @ f9 for refresh to original value@
               if changeok ;  bnew[inow]=bs[inow]; endif ;


            elseif aword==1059 ;        @F1 = help (also ALT-H or ? ) @
                ?;
                 locate ilineat+2,1 ;
                format 1,8;
               if changeok==1 ;
          " Display and change values.  Options: ";
          "      ESC        :: Exit WITHOUT changing values. ";
          "     F3 or ALT-X :: Accept all values as displayed.";
               else ;
          "  Display values.  Options: ";
          "     F3, ESC or ALT-X :: Done with examining values.";
               endif ;
          " Cursor keys      :: Select variable(s)";;
               if changeok==1 ;
                 if isa_strg==1 ;
                    ", then enter character strings(s). ";
                 else ;
                    ", then enter numeric value(s). ";
                 endif;
               else ;
                    "." ;
               endif;
          " VarName or F2 :: Select variable by name. ";
               if changeok==1 ;
          "            F9 :: Reset  to default value";
               endif;
               if changeok==1 and isa_strg==0;
           "           .     :: Set to Missing ";
           "           F8 :: Read values from a file";
           "     func n aval :: Compute value. 'func n' to apply n to default.";
           "          func can be: ";; call boldon ;
                " ** " ;; call normalon ; " (aval^n), ";; call boldon ;
                " *   " ;; call normalon ; ",";; call boldon ;
                " /   " ;; call normalon ; " (aval/n), or ";; call boldon ;
                " +   "; call normalon ;
               endif ;

               if type(mtxname) ne 6 ;         @ string @
                        ;
               else ;                  @ vector, or scalar @
@ might be a string list @
                  if rows(mtxname) gt 1 and COLS(MTXNAME)==1;
                     foo=0;
                     do until foo==rows(pnames);
                        foo=foo+1;
                         format /rd 8,8 ; $pnames[foo] " = " ;;
                         foo2=mtxname[foo];
                         $foo2 ;
                         if (foo % 16 ) == 0 ; call g_pause(12,-1); endif;
                     endo ;
                endif ;
             endif;
             call g_pause(62,-1);
             gosub DOCLS ;
             goto first1 ;


            elseif aword==1066     ;   @ f8 for file io @
getftype:;
               gosub clrlines(ilineat+1);
                locate ilineat+1,1 ;
               filetype=g_askopt(" Select type of file I/O (ESC to cancel)",
                                   "GAUSS"|"ASCII"|"GRBL2"|"?","?",0,3,3);

                if scalmiss(filetype);
                     dofileio=0;
                     goto wowsa ;

                elseif filetype$=="?";

"  Enter name of file containing values.  Three kinds of files can be read:";
call boldon ;
"           GAUSS ";; call normalon ;
              " matrix files (.FMT files created by the SAVE command)";
"           Text ";; call boldon ; " (ASCII) ";; call normalon ; " files.";
call boldon ;
"           GRBL2 ";; call normalon ;
    "'result' files (special .FMT files created by GRBL programs) ";
"
   for GAUSS and ASCII files, values are assigned in the order they appear
   in the file.  for GRBL2 files, values are assigned by name (the file
   contains both values, coefficient names, and VC matrix).";
                    call g_pause(15,-1);
                    goto getftype ;
                endif;

                "   Enter " ;; call boldon ;
                $Filetype ;; call normalon ; " file-name: " ;; aword=g_cons2() ; ? ;
                if type(AWORD)==6;         @ ESC to cancel @
                     DOFILEIO=0  ;
                     gosub clrlines(ilineat+1);
                     continue ;
                else ;
                  if aword$=="" ;
                     DOFILEIO=0  ;
                     gosub clrlines(ilineat+1);
                     continue ;
                  elseif filetype$=="ASCII"  ;
                      dofileio=1 ;
                     " Enter # of values to read from file:";;ntmp=con(1,1);
                  elseif filetype$=="GAUSS" ;
                      dofileio=2;
                  elseif filetype$=="GRBLá" ;
                      dofileio=3;
                  endif ;
             endif;
wowsa: ;
             foo2=csrlin ;
             if foo2 ne ilineat+1 ;
                    clearit=1 ;
             endif ;
             gosub clrlines(1);
             if DOFILEIO gt 0 ;
                goto ataword ;
            else ;
                CONTINUE ;
            endif ;

            elseif aword==1060 ;   @ f2 to select @
               gosub clrline(ilineat+1);
                locate ilineat+1,1 ;
                {foo,foo2}=g_askv1(
                "       ---  Select a parameter to change:",pnames[inow],
                           pnames,"   ... Current parameters are ..  ",0,0);
               foo2=csrlin ;
               if foo2 ne ilineat+1 ;
                    clearit=1 ;
               endif ;
               gosub clrlines(ilineat+1);
               if scalmiss(foo);
                  continue ;
               elseif foo>0 ;
                  inow=foo;
               endif;
            endif;

           isa_strg=1-g_isnum(bnew[ith]);
            call usr_set0(pnames[ith],bnew[ith],topline,ith,0,ith1,ncols,
                           isa_strg);
            inow=minc(maxc(inow|1)|np) ;  @ keep in bounds @
            ith=inow ;
            if inow ge ith1 and inow le ith2 ;
               call
                  usr_set0(pnames[ith],bnew[ith],topline,ith,inow,ith1,ncols,
                           isa_strg);
            endif ;
            continue ;

         endif;                 @ type=6 @

@ if here, normal ascii input.  if string input okay, then treat i/o as a string
  else, several other options @
       isa_strg=1-g_isnum(bnew[inow]);
       if isa_strg==1 and changeok==1  ;
           bnew[inow]=aword;
           call usr_set0(pnames[inow],bnew[inow],topline,inow,0,ith1,ncols,
                            isa_strg);
           inow=inow+1;
           continue ;
        endif ;

@ When here, non-string I/O with ascii aword (or F8 success).
  Note: exit via ESC @
ataword:;
    if dofileio==1 ;                    @ ASCII IO @
           dofileio=0;
           if changeok==0 ; continue; endif ;
           if filesa(AWORD) $== "" ;
                gosub clrline2(ilineat+1);
                locate ilineat+1,1 ;
                " NO SUCH TEXT FILE: " $aword;
                 call g_pause(5,0);
                gosub clrline2(ilineat+1);
                 dofileio=0;
                 break ;
            endif;
            loadm btmp[ntmp,1]=^aword ;
            if (inow-1)+ntmp > np ;
                   ntmp=np-(inow-1);
                   btmp=btmp[1:ntmp] ;
             endif;
             bnew[inow:(inow+ntmp-1)]=btmp;
             gosub clrline2(ilineat+1);
             dofileio=0;
             break ;


@ might be a .FMT file !! @
     elseif dofileio > 1  ;

           if changeok==0 ; continue; endif ;
           foo2=aword $+ ".FMT ";
           foo=filesa(foo) ;

           if foo $=="" ;
                gosub clrline2(ilineat+1);
                locate ilineat+1,1 ;
                " NO SUCH " $filetype " FILE:" $aword  ".FMT" ;
                 call g_pause(5,0);
                 gosub clrline2(ilineat+1);
                 dofileio=0; break ;
            endif ;

@ if here, read GAUSS or GRBLB file @
            LOADM Btmp=^AWORD ;
            if (dofileio==2 and cols(btmp) ne 1) ;
                  btmp=vec(btmp);

            elseif (dofileio==3 and (cols(btmp) ne 2+rows(btmp))) ; @ bad type @
                   gosub clrline2(ilineat+1);
                    locate ilineat+1,1 ;
                   " A Bad " $filetype " FILE:" $aword  ".FMT" ;
                    call g_pause(5,0);
                   gosub clrline2(ilineat+1);
                   dofileio=0;
             endif;

@ if here, got a legit file @
            if dofileio==2 ;
                 ntmp=rows(bTMP);
                 if (inow-1)+ntmp > np ;
                     ntmp=np-(inow-1);
                     btmp=btmp[1:ntmp] ;
                  endif;
                  bnew[inow:(inow+ntmp-1)]=btmp;
                  gosub clrline2(ilineat+1);
              elseif dofileio==3 ;
                 tmp=btmp[.,1];
                 tmpid=indcv(tmp,pnames);
                 tmpid2=seqa(1,1,rows(tmpid));
                 tmpid=packr(tmpid~tmpid2);
                 bnew[tmpid[.,1]]=btmp[tmpid[.,2],2];
              endif;
              dofileio=0 ;
              break ;
@ Note that GRBLá files consist of PARNAMES~BETA~VC.  Here, we ignore VC @


     elseif aword$=="." or aword$==" ." ;     @ set to missing @
            if changeok ;    bnew[inow]=miss(1,1); endif ;
            continue ;

     elseif g_isnumber(aword) or aword$=="E" or aword$=="PI" ;
           if changeok ;
              if aword$=="E";
                 bnew[inow]=exp(1) ;
              elseif aword$=="PI" ;
                bnew[inow]=pi ;
              else ;
                bnew[inow]=stof(aword);
              endif ;
              isa_strg=1-g_isnum(bnew[inow]);
              call usr_set0(pnames[inow],bnew[inow],topline,inow,0,ith1,
                            ncols,isa_strg);
              inow=inow+1;
            endif;          @ changeok @
            continue ;

       elseif (strindx(aword,"POWER ",1)> 0 )
            or ( strindx(aword,"DIV ",1)> 0)
            or   ( strindx(aword,"PLUS ",1)> 0)
            or   ( strindx(aword,"ADD ",1)> 0)
            or   ( strindx(aword,"/ ",1)> 0)
            or   ( strindx(aword,"^ ",1)> 0)
            or   ( strindx(aword,"** ",1)> 0)
            or   ( strindx(aword,"- ",1)> 0)
            or   ( strindx(aword,"+ ",1)> 0)
            or   ( strindx(aword,"* ",1)> 0)
            or   ( strindx(aword,"MULT ",1)> 0) ;   @ a function ? @

             if changeok==0; continue; endif ;  @ no changes allowed @

             {aword1,ie}=g_getwrd(aword,1);
             {aword2,ie}=g_getwrd(aword,ie+1);
             if g_isnumber(aword2);
                  v1=stof(aword2);
              else;
                  continue ;   @ error @
              endif;
              {aword2,ie}=g_getwrd(aword,ie+1);
              if g_isnumber(aword2);
                 v2=stof(aword2);
              else;
                  v2=bnew[inow] ;
              endif;
              format /lz 15,9 ;
              if aword1$=="POWER" or aword1$=="^" or aword1$=="**";
                 foo=v2^v1 ;
                 locate ilineat+1,1 ;
                 "                   " v2 " ^ " v1 " = " foo;
              elseif aword1$=="DIV" or aword1$=="/";
                 foo=v2/v1 ;
                 locate ilineat+1,1 ;
                 "                  " v2 " / " v1 " = " foo;
              elseif aword1$=="MULT" or aword1$=="*";
                  foo=v2*v1 ;
                 locate ilineat+1,1 ;
                 "                  " v2 " * " v1 " = " foo;
              elseif aword1$=="ADD" or aword1$=="PLUS" or aword1$=="MINUS"
                 or aword1$=="-" or aword1$=="+"  ;
                 if aword1$=="MINUS" or aword1$=="-";
                     v1=-v1 ;
                 endif ;
                 foo=v2+v1 ;
                 locate ilineat+1,1 ;
                 "                  " v2 " + " v1 " = " foo;
              else ;
                  continue ;
              endif;
              bnew[inow]=foo ;
              continue ;



       elseif NOT(SCALMISS(g_INDCV2(AWORD,PNAMES)));
            FOO=g_INDCV2(AWORD,PNAMES);
            call usr_set0(pnames[INOW],bnew[INOW],topline,INOW,0,ith1,ncols,
                           isa_strg);
            INOW=FOO;
            inow=minc(maxc(inow|1)|np) ;  @ keep in bounds @
            ith=inow ;
            if inow ge ith1 and inow le ith2 ;
               call
                  usr_set0(pnames[ith],bnew[ith],topline,ith,inow,ith1,ncols,
                           isa_strg);
            endif ;
            CONTINUE ;
       endif;


    endo;

   goto first1 ;

@ clear, WRITE MESSAGE ON FIRST LINE @
DOCLS:;
 CLS ;
 LOCATE TOPLINE-1,1 ;
 call BOLDON;  $prompt ; call NORMALON ;
return;


alldone:;
  " SPACE or ENTER to accept values, ESC if more changes desired";;
   foo=g_pause(8,-27);
   if FOO==1 ;
       INOW=NP;
    else ;
       if changeok ; retp(bnew); else; retp(oldb); endif ;
    endif ;
return;

clrline:;
  pop huhline ;
  scroll huhline|1|huhline|80|0|0;
  return;

clrline2:;
  pop huhline ;
  scroll huhline|1|(huhline+1)|80|0|0;
  return;

clrlines: ;
  pop huhline ;
  scroll huhline|1|25|80|0|0;
  return;
endp;



@ isa_st @

/*****************************/
@ display at a particular spot. used by userset0 @
    proc usr_set0(anam,ab,topline,ith0,inow,i1,ncol,isa_strg);
    local ic,ilineat,ith,starts,wlen,wlen2,foo;
    ith=ith0+1-i1 ;
    ilineat=ceil(ith/ncol)+topline ;
    ic=int(ith % ncol + .1 ) ;
    if ic==0 ; ic=ncol ; endif ;

    if ncol==1 ;
      starts=5 ; wlen=30 ;wlen2=15 ;
    elseif ncol==2 ;
      let starts=5 35 ; wlen=17 ;wlen2=10 ;
    elseif ncol==3 ;
      let starts=2 27 52 ; wlen=12 ;wlen2=6 ;
    elseif ncol==4 ;
      let starts=1 21 41 61 ; wlen=8 ;wlen2=3 ;
    elseif ncol==5 ;
      let starts=1 16 31 46 61 ; wlen=11; wlen2=6 ;
    elseif ncol==6 ;
      let starts=1 14 27 40 53 66 ; wlen=10; wlen2=5 ;
    endif ;


      locate ilineat,starts[ic] ;
       if ic ne 1 ;
          call blockon ;
          "|" ;; call normalon ;
       endif ;
       if ncol le 4 ;
           if ith0==inow ; call boldon ; endif ;
           format /rd 8,8 ; $anam ;
          if ncol le 3 ;foo=1; else; foo=0; endif;
          locate ilineat, starts[ic]+8+foo+(ic ne 1) ; "=";;
          locate ilineat, starts[ic]+9+(2*foo)+(ic ne 1) ;
       else ;
          if ith0==inow ; call boldon ; endif ;
          locate ilineat, starts[ic]+1;
       endif ;
       if isa_strg==1 ;
          format /ld 8,8; $ab ;
       else ;
         format /lz wlen,wlen2 ; ab;
       endif ;
    call normalon ;
    retp(ilineat);
    endp;



proc(2)=g_getval(prompt,defval0) ;
local a1,a2 ;
{a1,a2}=g_askval(prompt,defval0);
retp(a1,a2);
endp;

/***********************************************/
@ RETURN VALUE, AND INDICIATOR OF SUCCESS (IARG). IF IARG=0, VALUE RETURNED,
  ELSE SOME KIND OF FUNCTION KEY HIT
defval0 is default value (if scalar)
else, is defaultvalue|field|precision
{newvalue,istat}=g_askval(prompt,defval or defval|field|precision)

@

  proc(2)=g_askval(prompt,defval0) ;

        local astr,defval,j1,j2,isld,iarg ;
         IARG=0;

       defval=defval0[1];

       if rows(defval0)==1 ;
             j1=12; j2=8;  isld=0;
       elseif rows(defval0)==2 ;
             j1=defval0[2];j2=0; isld=1;
       else ;
             j1=defval0[2];j2=defval0[3]; isld=0;
       endif;

         local comma ; comma=vals(",") ;

   format /ld 1,8;     $prompt ;;
    if isld==1 ;
         format /ld j1,j2 ;
    else;
         format /lo j1,j2 ;
    endif;
   " (Default=";; defval;; ") : ";;
getval:        astr=upper(g_cons2); ? ;


        if type(astr)==6 ; @ NON-ASCII HIT .. @
           IARG=ASTR ;
           astr="";
        elseif astr$=="?" ;
           iarg=1059;
           astr="";
        endif ;

        if astr$=="" ;
            retp(defval,iarg);
        elseif astr$=="M" or astr$=="." ;
            retp(miss(1,1),27);
        elseif astr$=="PI";
            retp(pi,32);
        elseif astr$=="E";
            retp(exp(1),32);

        else ;
            astr=vals(astr);        @nice feature, removes commas @
            astr=packr(miss(astr,comma));
            astr=chrs(astr);
            if g_isnumber(astr);
                retp(stof(astr),iarg);
            else;
                " Bad value, Reenter :: ";;
                goto getval ;
            endif;
        endif;
       endp;
 

/************/
/* g_fspec2 shortcut: no support for alternative path (use current path) */
proc g_fspec(toget,fname);
local vv;
vv=g_fspec2(toget,fname,"");
retp(vv);
endp;


/********************/
@ Returns drive, path, name, or name w/o extension, of provided name
info=g_fspec('A/D/P/N/F/DP',fname)
All, Drive, Path, Name, Name w/o extension
  If no name provided, same as getpath("")
  If relative filename, drive and path are based on current value of getpath
@
proc g_fspec2(toget,fname0,altdir);

local ldir,lname,ldrive,lname0,sl2,fname ;
local bslash,fslash,aname,adrive,apath,aname2,f2,ff,ipp,ifs,ibs;

fname0=g_strip(fname0) ; fname=fname0 ;
altdir=g_strip(altdir);
if strsect(altdir,2,2) $/=":\\" and fname$/=".." ; altdir="" ;endif;

bslash=vals("\\");  fslash=vals("/");

@ valid request? @
toget=upper(g_strip(toget));
if toget$=="" ; retp(miss(1,1)); endif ;
if toget$/="DP";   toget=strsect(toget,1,1); endif;
f2=strindx("DPNFA",toget,1);
if f2==0;   retp(miss(1,1)); endif;

if fname$=="" ; 
  if altdir $=="" ;
    fname=getpath(""); 
  else;
    fname=altdir ;
  endif;
endif;

@ special case: ".." @
if fname$==".." and altdir$/="" ;

   ipp=strrindx(altdir,".",-1) ;       @ drop any file name that may be in altpath @
    if ipp>0 ;
      ibs=strrindx(altdir,"\\",-1) ;
      ifs=strrindx(altdir,"/",-1) ;
      if ipp>ibs and ipp>ifs ;
 	  ipp=maxc(ibs|ifs);
	  altdir=strsect(altdir,1,ipp);
       endif;

    endif;

    f2=strsect(altdir,strlen(altdir),1);
    if f2 $=="\\" or f2$=="/" ;
     f2=strsect(altdir,1,strlen(altdir)-1) ;
   else ;
      f2=altdir;
   endif;
   ff=strrindx(f2,"\\",-1);
   if ff==0 ;  f2=strsect(f2,1,1)$+":\\"; 
   else ; f2=strsect(f2,1,ff);
   endif;
   fname=f2 ;
   if strsect(fname,strlen(fname),1) $/="\\" ; fname=fname$+"\\"; endif;
   altdir="";
endif;
   
 

@ convert / to \ @
f2=vals(fname);
f2=substute(f2,f2.==fslash,bslash);
fname=chrs(f2);

@ get drive, possibly prepend current path @
if strindx(fname,":",1)==0 ;  @ no drive letter @
   if altdir$=="" ; ff=getpath(""); else ; ff=altdir ;endif;
    sl2=strsect(ff,strlen(ff),1) ;
    if sl2 $/="\\"  and sl2 $/="/" ; ff=ff $+ "\\" ; endif;

    if strsect(ff,2,3) $==":\\/"; 
     ff=strsect(ff,1,1)$+":\\"; 
   endif;

   f2=vals(ff);
   f2=substute(f2,f2.==fslash,bslash);
   ff=chrs(f2);

   ldrive=upper(strsect(ff,1,1));

   if strsect(fname,1,1) $/= "\\" ; 
     fname=ff $+ fname; 
   else;
      fname=ldrive $+ ":" $+  fname ;
    endif;

else ;
   ldrive=upper(strsect(fname,1,1));
   sl2=strindx(fname,"\\",1);
   if sl2>3  or sl2==0 ; fname=strsect(fname,1,2) $+ "\\" $+ strsect(fname,3,100000); endif;
endif;
if  toget$=="A"; retp(fname); endif;

if toget$=="D"; retp(ldrive) ;endif;

sl2=strrindx(fname,"\\",-1);
if toget$=="P" or toget$=="DP" ; 
  apath=strsect(fname,3,1+sl2-3);
  if toget$=="P" ; retp(apath); endif;
  retp(ldrive $+":" $+ apath) ;
endif;  

aname=strsect(fname,sl2+1,100000);
if toget$=="N";   retp(aname); endif;

if toget$=="F";
   ipp=strrindx(aname,".",-1);
   if ipp==0 ;
	aname2=aname;
   else;
     aname2=strsect(aname,1,ipp-1);
   endif;
   retp(aname2);
endif;

endp;



/***********/
@ check if this is a legit directory. Returns dir name if it is, "" if it is not 
  return "" 
  Uses a gauss hack 
@

proc g_is_dir(adir);
local aold,b,foo,a1; 

aold=getpath("");
b=changedir(adir);
foo=changedir(aold);

if b$==""; retp(""); endif;

a1=strsect(b,strlen(b),1);
if a1 $/="\\" and a1$/="/" ; b=b$+"\\" ;endif;
retp(b);

endp;

/***********/
@ check if this is a legit directory. Returns dir name if it is, "" if it is not 
  return "" . If check=1 , don't bother checking (just return proper directory name)
  Uses a gauss hack 
@

proc g_as_dir(fname,icheck);
local aold,b,foo,a1,f2; 
local fslash,bslash ;

if icheck==1 ; b=g_is_dir(fname) ; retp(b); endif;

if fname$=="" ; fname=getpath(""); endif;

bslash=vals("\\");  fslash=vals("/");

f2=vals(fname);
f2=substute(f2,f2.==fslash,bslash);
fname=chrs(f2);

a1=strsect(fname,strlen(fname),1);
if a1 $/="\\" and a1$/="/" ; fname=fname$+"\\" ;endif;
retp(fname);

endp;


/***********/
@ return 4 lists (files, file sizes, file last mod dates, and subdirectories) under a given directory
  dirlist="" if none.
  dirlist=miss(1,1) if bad directory
 @

proc (4)= g_dirlst(adir);		@ shortcut, using *.* filter @
 local a,b,c,d;
 {a,b,c,d}=g_dirlst2(adir,"*.*");
 retp(a,b,c,d);
endp;

proc (4)= g_dirlst2(adir,filter);
local filelist,dirlist,foo,foo1,foo2,i1,it1a;
local t1,t2,a,b,t1a,t2a,foo2a,ok;
local t1new,t2new ,i,j,a1,a2 ,inew,rootdir,fbytes,fdates;

if filter$==""  ; filter="*.*" ; endif;

rootdir=g_is_dir(adir);
if rootdir$=="" ; retp(miss(1,1),0,0,miss(1,1)) ;endif;


foo2=rootdir $+ "*.*" ;

it1a=-1; 
{t1,t2}=fileinfo(foo2);

if filter$/="*.*";
  foo2a=rootdir $+  filter ;
  {t1a,t2a}=fileinfo(foo2a);		@ should be just file names, no directories @
  it1a=rows(t1a);
endif;
  

if t2==0 ; retp("",0,0,"");endif;
 
filelist="" ; fbytes=0 ; fdates=0;
dirlist="" ;

inew=0;
for i (1,rows(t1),1) ;
  a1=t1[i];
  if strindx(a1,".",1) gt 0 ;    @ this is a file @
  if it1a>-1 ;		@ check if its matches filtered list @
     ok=0;
     if it1a==0 ; continue; endif;	@ no matches possible in this dir @
     for i1 (1,it1a,1);
	 if a1$==t1a[i1] ; ok=1; break ; endif;  @ got match @
     endfor;
     if ok==0 ; continue; endif;  @ no match, so skip @
   endif;
   if a1$/="." and a1$/="..";  
       filelist=filelist $| a1 ; 
       fbytes=fbytes|t2[i,8]; 
       fdates=fdates|t2[i,10] ;
    endif;
  else;
     foo=rootdir $+ a1   ;  @ buggy gauss work around @
     foo1=g_is_dir(foo);
     if foo1 $/="" ; 
       dirlist=dirlist$|a1 ;  
     else ;
       filelist=filelist $| a1 ; 
       fbytes=fbytes|t2[i,8]; 
       fdates=fdates|t2[i,10] ;
     endif;  
  endif;
endfor ;
if rows(filelist)>1 ; 
  filelist=filelist[2:rows(filelist)];
  fbytes=fbytes[2:rows(fbytes)];
  fdates=fdates[2:rows(fdates)];
endif;
if rows(dirlist)>1 ; dirlist=dirlist[2:rows(dirlist)]; endif;

retp(filelist,fbytes,fdates,dirlist);

endp;
 
@ t2 t1a@

/***********/
@ returns fully qualified filename for this file, if it exists.
  If altdir ne "", and aname not fully qualified, aname is relative to altdir
  If not, returns "" @

proc g_exists2(aname,altdir,altdir2);

local aa;
 
aa=g_exists(aname,altdir);
if aa$=="" and altdir$/=altdir2 ;
  aa=g_exists(aname,altdir2);
endif;
if aa$=="" and (altdir2$/="") and (altdir$/="")  ;
  aa=g_exists(aname,"");
endif;

retp(aa);
endp;
 

/***********/
@ returns fully qualified filename for this file, if it exists.
  If altdir ne "", and aname not fully qualified, aname is relative to altdir
  If not, returns "" @

proc g_exists(aname,altdir);

local bname,f1,f2,t1,t2;
 
bname=g_fspec2("A",aname,altdir);

t2=strsect(bname,strlen(bname),1);
if t2 $/="\\";
  f1=filesa(bname);
  if f1$=="" ; retp(""); endif;
  retp(bname);
endif;
 

@ else, check for directory @
t1=bname$+ "." ;

f1=filesa(bname);


if f1$=="" ; retp(""); endif;
retp(bname);

endp;


/**************/
/* return 1 if this is a number */

proc g_isnumber(char);
 retp(g_isnum(char)) ;
endp;


/**************/
/* Create "nest identifier" matrices :NEST_CT and NEST_IDS
  These are used to identify "NESTS" within a "PANEL".
  A "PANEL" is a set of adjacent rows in a dataset.
  Typically, these rows belong to a single "individual".
  Each PANEL can have several "NESTS", where a a NEST is a subset of
  these rows. Rows belonging to a given NEST do NOT need to be adjacent.

  Syntax:
       {nest_ct,nest_ids}=g_make_nests(panels,id2);
  or
       {nest_ct,nest_ids}=g_make_nests_b(npanels,n_nests,in_nest);

   panels: a P x 2 matrix of panel indices, into the dataset
	     panels[i,1] is first obs in panel i
	     panels[i,2] is last obs in panel i  
	   where P is the total number of panels
   id2   : a Nx1 matrix of "nest ids".
  	    Each value in ID2 should be a "nest id" for the row.  
	    Obviously, several rows (within a panel) can have the same id2 value.
	    Note that "nest ids" are unique to the panel. Thus, you 
	    can use the same set of id2 values within each of the "panels"
   or
	  npanels: # of panels
	  n_nests: # of nests per panel
	  in_nest: # of rows per nest

	For balanced designs, rows in a nest must be adjacent (and each nest must have the
	same number of rows.		
  
    nest_ct: Px2 matrix of nest-info correspondint to PANELS 
	    -- # of nests in this panel,  pointer to nest_ids
    nest_ids: Qx1 matrix of nest identifiers. Q is an arbitray number.
	      nest_ids contains info on # rows in each nest, and pointers to the dataset 
	      (these pointers are grouped by nest)
	      

    Although you can use NEST_CT and NEST_IDS to find the nests for a panel, we 
    recommend using the G_LIST_NEST procedure.

	 nestlist=g_list_nest(ith_panel,nest_ct,nest_ids)
     
      nestlist will be a N_nests x max_in_nest matrix of nest identifiers for
      the ith_panel.  For unbalanced panels, the nests with fewer then 
      max_in_nest rows will contain missing values.

      Example of usage:

          panels=g_pnlind(id1);
	  {nest_ct,nest_ids}=g_make_nests(panels,id2);
	  for j (1,rows(panels),1) ;
	      nestlist=g_list_nest(j,nest_ct,nest_ids)
	     "Observation " j " has " ;; rows(nestlist);; " nests: ";
	      for k (1,rows(nestlist),1);
		  anest=packr(nestlist[k,.]);
		  "Nest # " k " has ";; cols(anest) ;;  " rows: ";; anest;
	      endfor;
	  endfor;


 Syntax of NEST_CT:
   2 columns. Each row corresponds to an observation (to the corresponding row in PANELS 
    REF_IN_NEST_IDS ~ n_nests
       REF_IN_NEST_IDS: row, of NEST_IDS, where info on this observations nests, starts
       N_NESTS: # of nests for this observation
   
  Syntax of NEST_IDS
     1 column, organized in blocks. The first several values in a block are the # of observations
     for each nest. In particular, the first N_NESTS (as recorded in NEST_CT) values are the
     # of observation for each nest. 
     So, for N_NESTS=3
	NESTCT1
	NESTCT2
	NESTCT3
         nest1_1 pointer
		..
	 nest1_nestct1  pointer
         nest2_1 pointer
		..
	 nest2_nestct2  pointer
         nest3_1 pointer
		..
	 nest3_nestct3  pointer
      The pointers refer to the nth row of the dataset (i.e.; nth row of X)
      For example,if nest1_2 = 37, means "the 2nd alternative in nest 1 can be found in row 37 of the data"
      ... that is, the 37th row of the X, Y, etc matrices.

      Example:
        if observation 4 has 3 nests, with 2,3, and 2 alternatives,
        and the last row of obseration 3 information is as row 40 of nest_ids
        and the nest ids for these 7 alternatives are:
	   12 12 14 51 14 51 14   (two alts for nest id=12, 3 for nest id=14, two for nest id=51)
        and the first alternative of observation 4 is at row 31 of the dataset

        Nest_ct[4,.] = 3~41

        nest_ids[41]=2		# alts in nest1
        nest_ids[42]=3	        # alts in nest2
        nest_ids[43]=2          # alts in nest3
        nest_ids[44]=31     - row 31 of data is  in nest 1
        nest_ids[45]=32     - row 32 of data is in nest 1
        nest_ids[46]=33     - row 33 of data is in nest 2
        nest_ids[47]=35     - row 35 of data is in nest 2
        nest_ids[48]=37     - row 37 of data is in nest 2
        nest_ids[49]=34     - row 34 of data is in nest 3
        nest_ids[50]=36     - row 36 of data is in nest 3

    NOtes:
          * NEST_CT[5,2] will be 51.
          * The order of the "pointers", within a subset, doesn't matter.
	    For example:
                nest_ids[46]=33 
                nest_ids[47]=35 
                nest_ids[48]=37 
	    and
                nest_ids[46]=37 
                nest_ids[47]=33 
                nest_ids[48]=35 
	    are equivalent.

*/

proc(2)=g_make_nests(panels,id2);

local tmp,rbot,tmp2,i,tmp4,tmp3,innest,nest_ct,nest_ids;

for i (1,rows(panels),1);
     tmp=id2[panels[i,1]:panels[i,2]];
     rbot=seqa(panels[i,1],1,1+panels[i,2]-panels[i,1]);
     tmp2=unique(tmp,1);
     if i==1 ;		@ start nest_ct and nest_ids @
        nest_ct=1~rows(tmp2);
     else;
	 nest_ct=nest_ct|( (1+rows(nest_ids))~rows(tmp2) ) ;
     endif;
     tmp4=miss(1,1);
     for i2 (1,rows(tmp2),1);
	   tmp3= tmp.==tmp2[i2] ;
	   innest=sumc(tmp3);
	   if i==1 and i2==1 ;
		nest_ids=innest;
	   else;
		nest_ids=nest_ids|innest ;
	   endif;
	   tmp4=tmp4|selif(rbot,tmp3) ;
     endfor;
     nest_ids=nest_ids|tmp4[2:rows(Tmp4)] ;
endfor;

retp(nest_ct,nest_ids);

endp;


proc(2)=g_make_nests_b(npanels,nnests,innest);

local i,nest_ct,nest_ids,acum,prows;
prows=nnests*innest ;
for i (1,npanels,1);
if i==1 ;		@ start nest_ct and nest_ids @
   nest_ct=1~nnests ;
   nest_ids=ones(nnests,1)*innest ;
   nest_ids=nest_ids|seqa(1,1,prows);
   acum=prows;
else;
   nest_ct=nest_ct|((1+rows(nest_ids))~nnests);
   nest_ids=nest_ids|(ones(nnests,1)*innest) ;
   nest_ids=nest_ids|(acum+seqa(1,1,prows));
   acum=acum+prows ;
endif;
endfor;

retp(nest_ct,nest_ids);
endp;


proc g_list_nest(ith,nest_ct,nest_ids);

local jat,numnests,iat,iat2,cts,mmax,nestinfo;

@	NESTCT1
	NESTCT2
	NESTCT3
         nest1_1 pointer
		..
	 nest1_nestct1  pointer
         nest2_1 pointer
		..
	 nest2_nestct2  pointer
         nest3_1 pointer
		..
	 nest3_nestct3  pointer
@

if ith gt rows(nest_ct);
   call grbl2_error("ERROR: panel number (" $+ g_ftos2(ith) $+ " > # of panels " g_ftos2(rows(nest_ct)),0);
  stop;
endif;


numnests=nest_ct[ith,2];
iat=nest_ct[ith,1];
iat2=iat+numnests-1 ;
cts=nest_ids[iat:iat2];
mmax=maxc(cts);
nestinfo=miss(zeros(numnests,mmax),0);

jat=iat2+1 ;
for i (1,numnests,1);
 
   nestinfo[i,1:cts[i]]=nest_ids[jat:jat+cts[i]-1]';
   jat=jat+cts[i];
endfor;

retp(nestinfo);
endp;



/*************************/
@ substitute rows of avec, that have 1's in correstponding row of indvec, with newvals value 
  (newvals can be a constant) @
proc g_substute(avec,inds,newvals);

local goo;

if rows(avec)>1 and cols(avec)>1 ; call grbl2_error("G_SUBSTUTE error: avec is not a vector ",0) ; stop ;endif;
if rows(inds)>1 and cols(inds)>1 ;  call grbl2_error("G_SUBSTUTE error: inds is not a vector ",0) ; stop ;endif;
if rows(newvals)>1 and cols(newvals)>1 ;  call grbl2_error("G_SUBSTUTE error: newvals is not a vector ",0) ; stop ;endif;


if cols(avec)>1 ; avec=avec'; endif;
if cols(inds)>1 ; inds=inds' ; endif;
if cols(newvals)>1 ; newvals=newvals' ; endif;

if inds==0; retp(avec); endif;

if rows(inds) ne rows(avec) ;  call grbl2_error("G_SUBSTUTE error: rows(avec) <> rows(inds) ",0) ; stop ; endif;
if sumc(inds.==0)+sumc(inds.==1) ne rows(inds);  call grbl2_error("G_SUBSTUTE error: inds is not a 0/1 vector ",0); stop ; endif;
if rows(newvals)==1 ; newvals=ones(rows(avec),1)*newvals; endif;

if inds==1 ; retp(newvals); endif;

goo=g_mkindx(inds);
avec[goo]=newvals[goo];
retp(avec);
endp;





/*******************************************/
/* Append, to bottom, the newmtx to the oldmtx. Returns the combined result
   If oldmtx = . of 0, returns newmtx
   If cols(oldmtx) <> cols(newmtx), then concatenate columns containing
   missing values to the matrix with fewer columns
  example:  matrix2=g_addrows(0,mymtx1);
            matrix2=g_addrows(matrix2,mymtx2);
                ...
            matrix2=g_addrows(matrix,mymtxn);

 

*/

proc g_addrows(oldmtx,newmtx);
local iarf,goo;
if scalmiss(oldmtx); retp(newmtx); endif;
if rows(oldmtx)==1 and oldmtx==0 ; retp(newmtx); endif;

if cols(oldmtx)==cols(newmtx); retp(oldmtx|newmtx); endif;

if cols(oldmtx)>cols(newmtx);
   iarf=cols(oldmtx)-cols(newmtx);
   goo=miss(zeros(rows(newmtx),iarf),0);
   newmtx=newmtx~goo ;
   retp(oldmtx|newmtx);
endif;

if cols(oldmtx)<cols(newmtx);
   iarf=cols(newmtx)-cols(oldmtx);
   goo=miss(zeros(rows(oldmtx),iarf),0);
   oldmtx=oldmtx~goo ;
   retp(oldmtx|newmtx);
endif;

endp;


/* Same as g_addrow, but also returns a vector indicating number of legit
   columns in each row of oldmtx. This requires an additional argument: oldcols
  Oldcols will also be appended to, adding the number of columns in newmtx.

  example:  {matrix2,cols2}=g_addrows(0,mymtx1,0);
            {matrix2,cols2}=g_addrows(matrix2,mymtx2,cols2);
                ...
            {matrix2,cols2}=g_addrows(matrix,mymtxn,cols2);

*/

proc(2)=g_addrows2(oldmtx,newmtx,oldcols);
local newcols,iarf,goo;
newcols=cols(newmtx).*ones(rows(newmtx),1);
if scalmiss(oldmtx); 
   retp(newmtx,newcols);
 endif;
if rows(oldmtx)==1 and oldmtx==0 ; 
   retp(newmtx,newcols);
endif;

if cols(oldmtx)==cols(newmtx); retp(oldmtx|newmtx,oldcols|newcols); endif;

if cols(oldmtx)>cols(newmtx);
   iarf=cols(oldmtx)-cols(newmtx);
   goo=miss(zeros(rows(newmtx),iarf),0);
   newmtx=newmtx~goo ;
   retp(oldmtx|newmtx,oldcols|newcols);
endif;

if cols(oldmtx)<cols(newmtx);
   iarf=cols(newmtx)-cols(oldmtx);
   goo=miss(zeros(rows(oldmtx),iarf),0);
   oldmtx=oldmtx~goo ;
   retp(oldmtx|newmtx,oldcols|newcols);
endif;

endp;

/********************************************************************/
/***************************************/
@ Create  XVC -- a concatenated set of variance covariance matrices

The notion is:
    i )  Given a Kx1  vector of X variables for N observations (Xn)
   ii )  Given information on each of the N observation-specific variance/covariance matrices (VCn)
   iii) Create a XVC: a (M*K)xK matrix containing  these VCn
  	  M is less than or equal to N (it can be 1)
    iv) And create XVC_IND: a Nx1 vector of pointers into XVC

Syntax:
     {XVC,XVC_IND}=g_mkxvc(xvcfile,xname,classids,class_name);

  where:
	xvcfile: name of a grbl-style VCI  file (described below)
        xname: Kx1 vector of names of the X variables in the main gauss dataset.
	       More specifically, the X variables you will be using in your regression
	classids: Nx1 vector of "class" identifiers -- each observation in the "main" gauss
		  dataset has a class identifier. However, it need not be unique -- several, or
		  even all, of the N observations can have the save value for classids
        class_name: The name. in XVCFILE. of the class-identifier variable. Values in classids will
		    be matched to values of this variable in xvcfile.

   If xvcfile does not exist, or there is no class_name (or _NAME_) variable in the xvcfile, a fatal
   error will occur.

The XVCFILE -- a special "grbl2 style" variance-covariance-information (VCI) file. 

  XVCFILE should contain variable names that are identical to the variable names
  in your main gauss dataset. In addition, two other variables must be present:

   * The class ID (the class_name variable). This identifies the "class" this row belongs.
     If there are KX variables, there will be KX rows with the same class ID.
     These will be matched to class IDS in the main gauss dataset.

       Important note: different observations in the main gauss dataset can share the 
       same class identifiers !!

       In fact, every single observation (every single row) in the main gauss dataset 
       can have the same value for this "class" identifier.

	  Thus, if a set of observations have different "observed" values of X, but the 
	  same variance/covariance (say, the same noisiness features), one should
	  use the same "class" identifer value for each observation.


   * A _NAME_ variable (must have a name of "_NAME_").
	    
  Example:
 	        CLSID    _NAME_     X1  X12   X5  X4 ;
		   1	  X1        20    1    5   -3
		   1	  X12        1   51   -3    6 	
	           1      X5         5   -3   22   12 
		   1      X4   	    -3   12    6    8 
		   2	  X1        23    2    0   -13
		   2	  X12        2   31    0    12
		   2      X4   	   -13   12    0    2 

   Notes:
	        *  Symmetry should be maintained: the value of row XA and column XB should match that
		   of row XB column XA. GRBL2 programs will enforce symmetry, but not necessarily in a way you
		   intend.
                *  Note that the X5 row is missing for CLSID=2 -- value of 0 are used (as reflected in the
		   X5 column for CLSID=2)
  	         * If a model uses the  X variables: X1 Z1  X12 X4, 
		   then the variance/covariance matrix used for CLSID=1 will be
			   20  0  1  -3
	                   0   0  0   0
		           1   0 51   6
		           -3  0  6   8
		   Note that since Z1 is not specified in either columns are rows, 0s are used.


		  
@
proc (2)=g_mkxvc(xfcfile,xname,id3,id3name);


local f34,xrname,ixrid3,ixr_name,iixname,xrbig;
local xrid3,xrnames,xrx,xvc_use,alt_ids,iats,oldat,hackadd ;
local altids,ii,xadd,xt,nmt,ii2,umat,lmat,ul,t,tt,tt2,foo;
local nxuse ;


nxuse=rows(xname);

open f34=^xfcfile ;
    if f34 le 0 ;
	 call grbl2_error("ERROR: unable to open X-variance file " $+ xfcfile,0);
	stop ;
    endif;

xrname=getname(xfcfile);

ixrid3=indcv(id3name,xrname);	@ column of the "alternative" identifier @
ixr_name=indcv("_NAME_",xrname);    @ column of the "_NAME_" varable @
if ismiss(ixrid3);
	  call grbl2_error("Error: no alternative-id name (" $+ id3name $+ ") " $+ xfcfile,0) ;
	  stop;
endif;
if ismiss(ixr_name);
	  call grbl2_error("Error: no _NAME_, variable in " $+ xfcfile,0) ;
	  stop;
endif;

iixname=indcv(xname,xrname);    @ columns containing variance data for X's used in this regression @
				    @ missing value if no such column in xfcfile @

xrbig=readr(f34,rowsf(f34));

f34=close(f34) ;

xrbig=xrbig~zeros(Rows(xrbig),1);    @ hack -- for non identified variables @
iixname=missrv(iixname,cols(xrbig));   @ missing vars now point to the above specified "zeros" columns @

xrid3=xrbig[.,ixrid3];		@ identifies which "class" this row belongs to (this row is a row of the vc matrix for this class @
xrnames=xrbig[.,ixr_name];     @ identifies row (using a name rule @


@Note: id3 identifies which "class" (which variance class) each row of the actual data belongs to @

altids=sortc(unique(xrid3,0),1);    @ the set of unique identifiers -- # of classes == rows(altids) @

@clearg hoyalt ; hoyalt=altids;@

iats=seqa(1,nxuse,rows(altids)) ;
xvc_use=zeros(rows(altids)*nxuse,nxuse);
oldat=0;

@hackadd=eye(nxuse)*0.0000000001 ; @


@ for each of the alt-ids, extract rows with matching alt-id (xrid3) value, than extract rows with names that
  match XNAME, then the columns, then form the vc matrix (with zeros where necessary  @

  for ii (1,rows(altids),1);
       xadd=zeros(nxuse,nxuse);
@       "==== ";; ii altids[ii];@
       xt=selif(xrbig,xrid3.==altids[ii]);
       nmt=selif(xrnames,xrid3.==altids[ii]);
       tt=indcv(xname,nmt);
       for ii2 (1,nxuse,1);
	  tt2=tt[ii2];        @ for this xname, what row of xt has its data @
	  if scalmiss(tt2) ; continue ;endif;    @ no row for this XNAME variable @
          xadd[ii2,.]=xt[tt2,iixname];
       endfor;
       umat=upmat(xadd); lmat=lowmat(xadd)';		@ the next 3 rows impose symettry @
       umat=missrv(umat,lmat); lmat=missrv(lmat,umat);
       ul=(umat+lmat)/2; xadd=diagrv(ul+ul',diag(xadd));
       xvc_Use[(oldat+1):(oldat+nxuse),.]=xadd ;
       oldat=oldat+nxuse;
     endfor;
    t=missrv(indnv(id3,altids),0);
@    clearg hoyt ; hoyt=t;@
    alt_ids=((t-1)*nxuse ) + 1 ;
    alt_ids=alt_Ids.*(alt_ids.>0);

retp(xvc_use,alt_ids);


endp;




/**********************************/
@ Procedure to write a vector of character strings in a pretty format.
  Syntax:
     foo=g_showvec(cvector,columns,indent,amessage)
  where
	
     cvector: an Nx1 (N can be any value) vector of character strings.  Each element contains an 8 character of less
	      string.
     columns: number of columns to use when displaying. Each column uses 8 characters, plus 1 pad character.
     indent : number of columns to indent (From left)
    message: message to display in the indented area. Message will be broken at word boundaries.
	     If a word is longer than the indent, that row will ONLY have the message 
@


proc g_showvec(cvector,ccols,indent,amessage) ;
local aa,aindent,i2,i,aword,pad,i1,toadd;

if missrv(ccols,0)<1 ; ccols= 4 ; endif;

if ccols>9 ; ccols=9; endif ;

if missrv(indent,0)<1 ; indent =1 ; endif;
if indent>70 ; indent=70 ; endif;

aa=ones(indent,1)*32 ;
aindent=chrs(aa);

i2=0;

for i (1,rows(cvector),ccols);
   if amessage$=="" ;
	aindent;; 
   else;
      toadd="";
      do while 1==1 ;
        {aword,amessage}=token(amessage);
        aword=g_strip(aword);
        if strlen(aword)> indent-1 ;
	    $toadd;; " " ;; $aword ;
	    toadd="";
	    continue ;
         else;
            if strlen(toadd$+aword) > indent-1 ;
	       toadd=g_strip(toadd);
	       $toadd;;
               pad=strsect(aindent,1,indent-strlen(toadd));
	       $pad;;
	       toadd="";
	       amessage=aword $+ " " $+ amessage ;
	       break;
	    else;
	       toadd=toadd$+" " $+ aword;
	    endif;
   	    if amessage$=="" ; 
	       $toadd;;
               pad=strsect(aindent,1,indent-strlen(toadd));
	       $pad;;
               break;
	    endif;

         endif;
       endo;
   endif;
   i2=minc(rows(cvector)|(i+ccols-1));
   format /ld 8,8 ; $cvector[i:i2]' ;
 
endfor;

if amessage$/="" ;
    $amessage ; 
endif;
retp(0);

endp;



/***************************/
@GET_COPT -- extract an option from a line of text. Typically, the line of text is a command from
            the command file.

 This procedure looks, in aline, for sub strings of the form:
      ANOPT=Opt_value
 You can have spaces on either side of the = sign.
 if you want to have spaces in "opt_value", you MUST include Opt_value between " " characters
 
 Syntax:  
	thevalue=get_copt(aline,anopt,errmess)
  where;
        aline: a line of text
       anopt : an option to look for. or, a vector of "synonyms" 
                Note that if anopt ends with *, then a "prefix" match will occur.
		Note that anopt of "" means "if no match, just take first word or string"
        Or, it can look for "flags" of the form:
             -anopt
	 or
	     .anopt

     errmess : if not "",, and if anopt not found, then write errmess and stop the program
                 thevalue: value of the option. 

Notes:
  * The ANOPT must be preceded by a space (or be at the beginning of the command line)
  *  if a "wildcard match", a two row string vector -- 
			first row is value of option,
			second row is value of "suffix" (what the * wildcard matches)
  *  If anopt not found, return a "". or, if errmess <> "", print errmess and exit.
  *  if anopts="", return a vector of the "options".


 Example of an aline:
    TYPE=XB  file=D:\DATA\FOO  HEADER = "This is my model" 

  Examples of anopt:
		anopt="TYPE"
		anopt="TYPE"|"TYPES"|"ATYPE"
		anopt="VAL"|"VAL_*";
		anopt="VAR"|"";
		anopt="VAR"|"-PRICE";


@

proc get_copt(aline,anopt,errmess) ;

local taline,tanopt,aword,taword,davalue,i1,i2,m,otype,ndo;
local wildmatch,postfix,tt,t;

local aa,mm,tanopt_ast,gotmatch,iast,optlist,dofirst,foo,aline00,aline0;
local anopt_dash,word_dash,word_dot,anopt_dot ;
aline=vals(aline);
tt=(aline.==9)+(aline.==10)+(aline.==13);
aline=recode(aline,tt.>0,32);
aline=chrs(aline);
aline=g_strip(aline);
aline00=aline;
anopt_dash={} ; anopt_dot=anopt_dash;
word_dash={};
word_dot=word_dash ;
jump1: ;			@ jump here if dofirst=1 and no match @

if anopt$=="";			@ take second word, or quoted string after first word @

 {aword,aline}=token(aline);	@ remove first word @
 aline=g_strIP(aline);
 if strsect(aline,1,1)$=="\""  ;
    i1=strindx(aline,"\"",2);
    if i1==0 ;   i1=111111 ; endif;	@ a hack -- use entire line @
    aword=strsect(aline,2,i1-2);
 else;
    {aword,aline}=token(aline);	
 endif;
 aword=g_strip(aword);
 retp(aword);

else;
  dofirst=0; 		@ flag-- if no match, take first word @
  foo={};
  for i1 (1,rows(anopt),1);
     if anopt[i1]$=="" ;
        dofirst=1 ;
     else;
	if type(anopt)< 10 ;
           foo=foo|anopt[i1];
	else;
           foo=foo$|anopt[i1];
        endif;
     endif;
  endfor;
  anopt=foo;
  ndo=rows(anopt); 
  tanopt_ast=zeros(ndo,1);
  
endif;

aline=" " $+ aline $+ " " ;


if ndo==0;
  optlist="";
elseif ndo== 1;
  tanopt="" $+ anopt;
else;
  tanopt="" $+ anopt[1];
  for t (2,ndo,1);
    tanopt=tanopt$|("" $+ anopt[t]);
  endfor;
endif;
	
for m (1,ndo,1);			@ tanopt is a string array @
    tanopt[m]=upper(g_strip(anopt[m]));
    tanopt_ast[m]=strindx(tanopt[m],"*",1);
    if strsect(tanopt[m],1,1)$=="-" ;
      anopt_dash=anopt_dash$|tanopt[m] ;
    endif;
    if strsect(anopt[m],1,1)$==" " ;
      anopt_dot=anopt_dot$|tanopt[m] ;
    endif;
endfor;


davalue="" ; postfix="";wildmatch=0;
gotmatch=0;

do while 1==1;			@ scan through aline for match to options in tanopt @


 if aline$=="" ; break ; endif;	 @ nothing left to search. leave loop @
 {aword,aline}=token(aline);	@ extract x portion of  x = y "option" @

  i2=strindx(aword,"=",1) ;   @ if x=y syntax, break off the =y part @
  if i2 > 1 ;
      taword=strsect(aword,1,i2-1);
      aline=" = " $+ strsect(aword,i2+1,100000) $+ " " $+ aline;
      aword=taword;
  else;
      if strsect(aline,1,1)$=="=";    @ check for x =abc syntax @
	 aline=" = " $+ strsect(aline,2,100000) ;
      endif;
  endif;
  taword=upper(g_strip(aword));	@ a candidate option @
  {aa,aline0}=token(aline);   @ check for an = sign @
  if g_strip(aa) $/= "=" ; 	@ not a x=y option, store it for 2ndary check, then skip it @
        if strsect(taword,1,1)$=="-";     
	   word_dash=word_dash $| taword ;
        else ;
	    word_dot=word_dot $| taword ;
	endif;
	continue ;
  else;
      aline=aline0;
  endif;


 {aword,aline}=token(aline);	@ get the value of the option (after an = sign @
 aword=g_strip(aword);

 if strsect(aword,1,1)$/="\"";
     davalue=aword;
 elseif strsect(aword,1,1)$=="\"" and strsect(aword,strlen(aword),1)$=="\"" ;
    davalue=strsect(aword,2,strlen(aword)-2);

 else;
   aword=strsect(aword,2,strlen(aword));
    i1=strindx(aline,"\"",1);
    if i1==0 ;
	 call grbl2_error("ERROR: unclosed \" in: "  $+ aline,0) ;
	stop;
    endif;
    if i1 ==1 ; 
	 davalue="";
     else;
        davalue=strsect(aline,1,i1-1);
     endif;
     davalue=g_strip(aword $+" " $+ davalue) ;
     aline=strsect(aline,i1+1,1000000);
 endif;


@ now compare the candidate option (TAWORD) agains the list of options (possibly using wildcards @
  gotmatch=0; wildmatch=0;
   for mm (1,ndo,1) ;
     if tanopt_ast[mm]==0;	@ exact match @
         if taword$==tanopt[mm] ; 
             gotmatch=1; break ;
	 endif;
     else;
	 if strsect(taword,1,tanopt_ast[mm]-1)$== strsect(tanopt[mm],1,tanopt_ast[mm]-1); 
              postfix=strsect(taword,tanopt_ast[mm],100000);
              gotmatch=1; wildmatch=1 ;break ;
	 endif;
     endif;
  endfor;	@ search list of synonyms @
  if gotmatch==1 ; break ; endif;

endo;


if gotmatch==0 ;


  if rows(anopt_dash)>0 and rows(word_dash)>0	 ;		@ look for -options @
      for j (1,rows(anopt_dash),1);
        for jj (1,rows(word_dash),1);
	   if anopt_dash[j] $== word_dash[jj] ;
             retp(anopt_dash[j]);
	   endif;
       endfor;
    endfor;
  endif;

  if rows(anopt_dot)>0 and rows(word_dot)>0	 ;		@ look for " xx" options @
      for j (1,rows(anopt_dot),1);
        for jj (1,rows(word_dot),1);
	   if anopt_dot[j] $== word_dot[jj] ;
             retp(anopt_dot[j]);
	   endif;
       endfor;
    endfor;
  endif;


  if dofirst==1 ;		@ use first word? @
    aline=aline00;  anopt="" ; goto jump1 ;
  endif;

  if errmess $/="" and errmess $/=" " ;
     call grbl2_error("ERROR: " $+ errmess $+ " :  " $+ aline,0);
     stop;
   endif;
   davalue="" ;postfix="";
endif;

if wildmatch==1 ;
  retp(davalue $|postfix);
else ;
  retp(davalue);
endif;
endp; 


/***************************/
@ version of get_copt that returns 2 values: the match, and index in a list @

proc (2)= get_copt_match(aline,anopt,errmess,vlist) ;
local tval,j,davalue;

davalue=get_copt(aline,anopt,errmess);
if davalue[1]$=="" ; retp(davalue,miss(1,1)); endif;    @ no match @
tval=upper(davalue);

for j (1,rows(vlist),1);
   if tval$==upper(vlist[j]);
      retp(davalue,j);
   endif;
endfor;
if errmess $/="" and errmess $/=" " ;
     call grbl2_error("ERROR: "  $+ errmess,0) ;
     stop;
endif;
retp(davalue,miss(1,1));
endp;




/***************************/
@ add a prefix of suffix to variables names in a vector 
 newlist=g_add_suffix(varlist,addit)
 
   varlist: list of variables to add suffix, or prefix, to
   addit: A code indicating what to add
           A value: add _, then the value (i.e.;  1)
           .   : Add _, then a sequential number (. means missing)

        Option: if addit is a two row vector, add addit[2]=1...
                then instead of adding number, add characters (A,B,..)
                
           
  Examples:
     varlist=g_add_suffix("JOE"|"DAN"|"ALAN",""))
        would yield: JOE_1 DAN_2 ALAN_3
     varlist=g_add_suffix("JOE"|"DAN"|"ALAN",2)
        would yield: JOE_2 DAN_2 ALAN_2

Globals:
  * g_add_suffix_char
    g_add_suffix_char variable can be used to change the
        seperator character from "_" to something else.
        Examples:
            g_add_suffix_char=""  -- NO seperator (JOE2 instead of JOE_2)
            g_add_suffic_char=":"  -- would yield JOE:2)
  * G_ADD_SUFFIX_PADLEN
     G_ADD_SUFFIX_MAXLEN tells how long the resulting elements in
     newlist can be.  By default, the max is 8 characters long.
     You can change this to any size.
     Note: if varlist is an array (not a string array), then maxlen can
            not be greater then 8 (g_add_suffix will impose this).     

@

proc g_add_suffix(varlist,addit);

local achar,newvs,i,addme,ichar,maxlen,laddme,v1,ilen,uselen,dolet;
if type(addit)>10 ; addit=0 $+ addit; endif;

achar=g_add_suffix_char;
newvs=varlist;
if addit[1]$=="";  
  addit[1]=miss(1,1); 
endif;

dolet=0;
if rows(addit)>1 ;
  if addit[2]==1 ;
    dolet=1;
  endif;
  addit=addit[1];
endif;
maxlen=g_add_suffix_maxlen ;    
if missrv(maxlen,0) le 0 ; maxlen=10000; endif;

if type(varlist)<10 ; maxlen=minc(maxlen|8); endif;  @ not string type, maxlen of 8 @

for i (1,rows(varlist),1);
   if scalmiss(addit) ;
      if dolet==1 ;
          ichar=chrs(i+64);
       else;
          ichar=ftos(i,"%*.*lf",1,0);
       endif;
  else;
      if dolet==1 ;
        ichar=chrs(addit+64);
      else;
        ichar=ftos(addit,"%*.*lf",1,0);
      endif;
  endif;

  if achar$/="" ;
        addme=achar $+ ichar;
  else;
       addme=ichar;
  endif;
  addme=g_strip(addme);
  laddme=strlen(addme);
  v1=g_strip(varlist[i]);
 
  ilen=strlen(v1);

  if ilen+laddme> maxlen;
      uselen=maxlen-laddme;
      v1=strsect(v1,1,uselen);
  endif;
  v1=g_strip(v1);
  newvs[i]=v1$+addme;
endfor;
retp(newvs);
endp;   

  

/******************************/
@ parse a long string into a string vector, one line per row.
  Return this array, with apend added to front of each line.
  Apend can be a vector, so that what is added to the front of the line
  depends on the row of apend @

proc g_parse_title(atitle,apend);

local a,b,tmps,irow ;

a={} ;

if type(atitle)==6 ; atitle="" $+ atitle ; endif;

if atitle$=="" ; retp(atitle) ;endif;

b=vals(atitle); 
if rows(apend) gt 1 ;
  tmps="" $+ apend[1];
else ;
  tmps="" $+ apend;
endif;
irow=1;
for j (1,rows(b),1);
  if b[j]==10 ; continue; endif;	@ ignore lf @
  if b[j]==13 ;  
      a=a$|tmps; 
      irow=irow+1;
      if rows(apend) gt 1 ;
          if irow le rows(apend) ;
              tmps="" $+ apend[irow];
	  endif;		@ else, nothing appended to front @
      else ;
           tmps="" $+ apend;
      endif;
      continue; 
  endif;
  tmps=tmps$+chrs(b[j]);
endfor;
a=a$|tmps;
 
retp(a);
endp;



/********/
@ add commas to a number, returns a string.
 Idec is number of decimal places.
   eg: addcomma(1245121.12354,3)
  will return 1,245,121.123
@

PROC g_ADDCOMMA(AVAL,IDEC0);
local aa,iaa,stmp,ido,i3,idec,isminus,igoo;
idec=idec0;
if idec==0; idec=1; endif;
if aval<0 ; isminus=1; else ; isminus=0; endif;

aval=abs(aval);
if aval<10 ;
  stmp=(FTOS(AVAL,"%*.*lf",1+idec,idec));
elseif aval<100 ;
  stmp=(FTOS(AVAL,"%*.*lf",2+idec,idec));
elseif aval<1000 ;
  stmp=(FTOS(AVAL,"%*.*lf",3+idec,idec));

else;
  stmp="";
  aa=FTOS(AVAL,"%*.*lf",40,idec);

  iaa=vals(aa);
  if idec gt 0 ;
    stmp=chrs(iaa[(40-idec):40]);
  endif;

  ido=40 -idec; i3=0;
  do until ido==1 ;
    ido=ido-1;
    if iaa[ido]==32 ; break ; endif;
    i3=i3+1;
    if i3 ==4 ;
      stmp="," $+ stmp ;
      i3=1;
    endif;
    stmp=chrs(iaa[ido]) $+ stmp;
  endo;
endif;
if idec0==0 ;
  igoo=strindx(stmp,".",1);
  stmp=strsect(stmp,1,igoo-1);
endif;

if isminus ; stmp= "-"$+stmp; endif;
retp(stmp);
endp;


/**********************/
@ Make a number into a string, determines best format.
  If isint0=1, make into an integer
  Or, ir isint0 is two rows:
    row 1 = 0/1 "integer" dummy
    row 2 = length of string (spaces added)

   Examples:
	 a=g_ftos2(16.36,1);  ==> "16"
	 a=g_ftos2(16.36,0);  ==> "16.36"
	 a=g_ftos2(16.36,0|7);  ==> "   16.36"

@

proc g_ftos2(aval,isint0);
local tmp,i,k,aval1,a1,crlf;
tmp="";
if cols(aval) ==1 ; aval=aval'; endif;
crlf=chrs(10|13);
for i (1,rows(aval),1);
 for k (1,cols(aval),1);
    a1=g_ftos2a(aval[i,k],isint0);
    tmp=tmp$+a1;
    if k ne cols(aval) ; tmp=tmp$+" " ; endif;
 endfor;
 if i ne rows(aval) ; tmp=tmp$+crlf ; endif;
endfor;
retp(tmp);
endp;

proc g_ftos2a(aval,isint0);

 local atext,arf1;
 local vv,mm,i2,i1,at0 ;
 local padlen,isint,tmp;
 local p1,p2,arf;

 if rows(isint0)>1 ;
    isint=isint0[1];
    padlen=isint0[2];
 else;
    isint=isint0;
    padlen=0;
 endif;
 arf1=0;
 IF SCALMISS(AVAL);
   ATEXT=".";
   if padlen==0;
       RETP(ATEXT);
   else;
     RETP(g_padwrd(ATEXT,padlen,1));
   endif;
 ELSE;
   if isint ne 1 ;
      if abs(aval)>1e10 ;
          atext=ftos(aval,"%*.*lE",15,8);
      elseif abs(aval)<1e-7 and aval ne 0 ;
          atext=ftos(aval,"%*.*lE",15,8);
          arf1=1;
      else;
         atext=ftos(aval,"%*.*lf",19,7);
      endif;
   else;
     atext=ftos(aval,"%*.*lf",19,0);
   endif;
 ENDIF;
 if isint==1;
   atext=g_strip(atext);
   if padlen==0;
      retp(atext);
   else;
      RETP(g_padwrd(ATEXT,padlen,1));
   endif;
 endif;
 at0="" $+ atext;
 vv=vals(at0) ;
  mm=0;i1=0;
  do until mm==rows(vv);
     mm=mm+1;
     if vv[mm]>32 ; i1=mm ; break ;endif;
  endo;
  if i1==0; 
    if padlen==0;
        retp(""); 
     else;
        RETP(g_padwrd(" ",padlen,1));
      endif;
  endif;
  mm=rows(vv);i2=0;
  do until mm==0 ;
     if vv[mm]>32 and vv[mm] ne 48 ; i2=mm ; break ;endif;
     mm=mm-1;
  endo;
  if vv[i2]==46 ; i2=i2+1 ; endif;
  if padlen==0;
      retp(chrs(vv[i1:i2]));

  else ;
    atext=chrs(vv[i1:i2]);
    if arf1==1 ;			@ sci notation @
       if padlen<6;
	   atext="~0";
       else;
         i1=strrindx(atext,"E",-1);
         if i1>0;
	   p2=g_strip(strsect(atext,i1,1000));
	   i2=padlen-strlen(p2);
	   p1=strsect(atext,1,i2);
	   atext=p1$+p2;
         endif;
       endif;
    endif;
    RETP(g_padwrd(ATEXT,padlen,1));
  endif;

endp;


/*******/
@ parse a "mime like" file, return a string-vector of field names, and a string-vector of values
 for these fields @

proc(2)=g_parsemime(filename);

local foo,alines,aline,vfields,vvalues,v1,p1,ip,ij;

foo=fopen(filename,"r");
if foo==0;
  retp("","");
endif;

alines=fgetsat(foo,1000);
foo=close(foo) ;

let string vfields="" ;
let string vvalues="";

for ij (1,rows(alines),1);
  aline=g_strip(alines[ij]);
  if strlen(aline)==0; continue; endif;
  if strsect(aline,1,1)$=="@"; continue ; endif;
  ip=strindx(aline,":",1);
  if ip<2 ; continue ; endif;
  p1=upper(g_strip(strsect(aline,1,ip-1)));
  v1=g_strip(strsect(aline,ip+1,1000000));
  vfields=vfields$|p1 ;
  vvalues=vvalues$|v1;
endfor;
if rows(vfields)>1 ;
   vfields=vfields[2:rows(vfields)];
   vvalues=vvalues[2:rows(vvalues)];
endif;
retp(vfields,vvalues);
endp;


/*********************************/
@ see if arg1 is an abbrevation of arg2. REturn 1 if yes, 0 if no. Case insensitive @
proc g_abbrev(arg1,arg2);
local aa,j;
arg1=upper(arg1);
arg2=g_strip(upper(arg2));
if type(arg1) ne 15 ;
   aa=g_strip(arg1);
  if strindx(arg2,aa,1) ==1 ; retp(1); else ; retp(0); endif;
else;
  for j (1,rows(arg1),1) ;
    aa=g_strip(arg1[j]);
    if strindx(arg2,aa,1) ==1 ; retp(1); endif;
  endfor;
endif;
retp(0);
endp; 


/*********************************/
@ write an error message to the GRBL2.ERR file (if called by a GRBL2 program).

If called by a grbl2 program (if the GRBL2_PROGRAM global variable has been defined),
then error information is written to GRBL2_ERRFILE, and a GRBL2_ERRFLAG is augmented.
If GRBL2_ERRFILE is defined, use it as the GRBL2.ERR file.
Otherwise, write to gauss50dir\GRBL2.ERR (gauss50dir is the result of sysstate(2))
In any case... output to screen and/or to current output file

Arguments:
     message: message to display (and save to grbl2.err)
     doout: where to display.
            0= screen only
            1= screen and output file (output on)
           i|j = (2x1 vector): i = 0/1 to screen,  j=0/1 to output file (0=no, 1=yes)

  Returns # of lines written to GRBL2.ERR
  Also, if called by GRBL2 program, adds 1 (or sets to 1) the GRBL2_ERRFLAG variable

  You can also set three variables:

    GRBL2_PROGRAM (the name of the grbl2 program)
         a=grbl2_error("MY_PROGRAM","PROGRAM");
         a=grbl2_error(0,"PROGRAM");    -- (this will suppress recording of data to grbl2_errfile)

    GRBL2_ERRFILE:
         a=grbl2_error("F:\TEMP\ERRORS.TXT","ERRFILE") ;
         a=grbl2_error(0,"ERRFILE");    -- (use GRBL2.ERR in GAUSS directory)

    GRBL2_ERRFLAG:
         a=grbl2_error(0,"ERRORS") ;    -- reset flag to 0



 @
proc grbl2_error(message,doout);
local foo,fout,a1,dd,adir,efile,ii,isgrbl2,doscreen,dooutput,dagrbl,arf;


if upper(doout)$=="PROGRAM";
   foo=varput(message,"grbl2_program");
   retp(1);
endif;

if upper(doout)$=="ERRFILE";
   foo=varput(message,"grbl2_errfile");
   retp(1);
endif;

if upper(doout)$=="ERRORS";
   foo=varput(message,"grbl2_flag");
   retp(1);
endif;



@ being called by is this a "grbl2" program @

isgrbl2=0; dagrbl="";
if missrv(grbl2_program,0) ne 0 ;
   dagrbl=grbl2_program;
   isgrbl2=1;
endif;

doscreen=1 ; dooutput=0;
if rows(doout)==1 ;
   if doout==1 ; dooutput=1 ; endif;
else ;
    doscreen=doout[1] ; dooutput=doout[2];
endif;

if doscreen==0 ; screen off ; else ; screen on ; endif;
if dooutput==0 ; output off ; else ; output on  ; endif;
?;$message ;
output off ; screen on ;

if isgrbl2==0 ; retp(0); endif;

adir=sysstate(2,0);
efile=adir$+"GRBL2.ERR";

if missrv(grbl2_errfile,0) ne 0;
   efile=grbl2_errfile;
endif;

fout=fopen(efile,"a");
if fout==0;
   call grbl2_error("ERROR: Unable to open error-file (" $+ efile,0);
   call g_pause(10,1);
   stop;
endif;

a1="";
a1=a1$| "=================================================";
dd=datestr(0) $+ "  " $+ timestr(0) ;
a1=a1$|dd;
dd=" Error while running: "  $+ dagrbl ; a1=a1$|dd ;
a1=a1$|"" ;
a1=a1$|message;


foo=fputst(fout,a1);
foo=close(fout);

ii=typecv("GRBL2_ERRFLAG");
if not(scalmiss(ii)); 
   arf=varget("GRBL2_ERRFLAG");  
   arf=arf+1;
   foo=varput(arf,"grbl2_errflag");
endif;


retp(foo);
endp;


/*********************************/
@ Return the grbl2_current.in file, if one is fresh.
 GRBL2_CURRENT.IN will be located in the GAUSS root directory.
 It is created by GRBL2.GCG, when the "use script" option is selected.
 If no GRBL2_CURRENT.IN file is available, or if there is one but it is
 more than 10 seconds old, return ""
 @

proc grbl2_autostart()  ;
local adir,efile,nowtime,finfo,fnames,elap;

adir=sysstate(2,0);
efile=adir$+"GRBL2_CURRENT.IN";
{fnames,finfo}=fileinfo(efile);
if fnames$=="" ; retp(""); endif;  @ no current.in file, so no autostart @

nowtime=timeutc   ;
elap=nowtime-finfo[10] ;
if elap>10 ; retp(""); endif;  @ not "fresh", so do not use @
retp(efile);
endp;


/******************************/
@ return nth word in a string. If nth=0, return number of words 
  Words are seperate by spaces, tabs, commas, and crlfs @
proc g_word(nth,astring);
local aa,ischar,pchange,we,wb,ischar1,j,vs,nth0,aw;

 aa=vals(astring);
 ischar=( (aa.<33) + (aa.==44) + (aa.==59) + (aa.==46)  +
          (aa.==39) + (aa.==34) + (aa==63) + (aa.==58)  + (aa.==33) ).==0;
 ischar1=0|ischar|0;
 pchange=ischar1[2:rows(ischar1)]-ischar1[1:rows(ischar1)-1];
 wb=packr(miss(seqa(1,1,rows(pchange)).*(pchange.==1),0));
 we=packr(miss(seqa(1,1,rows(pchange)).*(pchange.==-1),0));

 if rows(nth)==1 and nth==-1 ; nth=seqa(1,1,rows(wb)); endif;

 if rows(nth)==1 ;
   if nth==0 ; retp(rows(wb)); endif;
   if nth>rows(wb) ;retp(""); endif;
   if nth<1 ; retp("") ; endif;
   retp(strsect(astring,wb[nth],we[nth]-wb[nth]));
 else ;
   let string vs="" ;
   for j (1,rows(nth),1);
     nth0=nth[j];
     if nth0>rows(wb) or nth0<1 ;
        aw="";
     else;
       aw=strsect(astring,wb[nth0],we[nth0]-wb[nth0]);
     endif;
     if j==1 ;
         vs[1]=aw;
     else;
         vs=vs$|aw;
     endif;
   endfor;
   retp(vs);
 endif;
endp;
