
C
C Evaluate and apply simple expressions either
C
C (1) pure arithmetic, so no effect on pedigree file
C (2) Dry run, so can test if will lead to a legal effect on pedigree file
C         all variables set to MISS
C (3) Pedigree operation -- individual-wise calculation and update
C
C The parser 
C
      subroutine parser(nterm,wtyp,expr,lbp,rbp,op,error)
      integer MAXLOC, MAXCOL, MISS, TOKNUM 
      parameter (MAXLOC=120, MAXCOL=MAXLOC+5, MISS=-9999, TOKNUM=44)

      integer error, nterm
      integer wtyp(MAXCOL)
      double precision expr(MAXCOL)
      integer lbp(0:TOKNUM), rbp(0:TOKNUM), op(0:TOKNUM)

C
C To allow if-then-else, start and end of block for parsing
C
      integer fin, posif, posth, posel, sta
      logical ismis, switch
C
C Main eval loop
C
    1 continue

C
C Read tag of each token and see if compound expression
C
      call findth(nterm,wtyp,posif,posth,posel)
C simple expression
      if (posif.eq.MISS) then
C empty list
        if (nterm.le.0) then
          nterm=1
          wtyp(nterm)=1000
          expr(nterm)=MISS
C evaluate
        else
          sta=1
          fin=nterm
          call simpev(sta,fin,nterm,wtyp,expr,lbp,rbp,op,error)
        end if
C complex expression -- evaluate if clause
      else if ((posth-posif).gt.1) then
        sta=posif+1
        fin=posth-1
        call simpev(sta,fin,nterm,wtyp,expr,lbp,rbp,op,error)
C -- DEBUG
C       write(*,*) 'Condition value: ', wtyp(sta), expr(sta), 
C    &             '==', (int(expr(sta)).ne.0)
C -- DEBUG
C if successfully evaluated
        if (sta.eq.fin .and. .not.ismis(wtyp(sta))) then
          switch=(int(expr(sta)).ne.0)
          call pull(posif,3,fin,nterm,wtyp,expr)
          call findth(nterm,wtyp,posif,posth,posel)
C remove either `else' predicate
          if (switch) then
            if (posel.ne.MISS) then
              sta=posel
              fin=nterm 
              call pull(sta,fin-sta+1,fin,nterm,wtyp,expr)
            end if
C or remove `then' predicate
          else
            if (posel.ne.MISS) then
              sta=1
              fin=posel
              call pull(sta,fin-sta+1,fin,nterm,wtyp,expr)
            else
              nterm=0
            end if
          end if
          goto 1
        else 
          error=1
        end if
C no `then'
      else 
        error=1
      end if
      return
      end
C end-of-parser
C
C The non-compound evaluator
C
      subroutine simpev(sta,fin,nterm,wtyp,expr,lbp,rbp,op,error)
      integer MAXLOC, MAXCOL, MISS, TOKNUM 
      parameter (MAXLOC=120, MAXCOL=MAXLOC+5, MISS=-9999, TOKNUM=44)

      integer error, fin, nterm, sta
      integer wtyp(MAXCOL)
      double precision expr(MAXCOL)
      integer lbp(0:TOKNUM), rbp(0:TOKNUM), op(0:TOKNUM)

      logical change, done, three
      integer adh1, adh2, adh3, adh4, cand1, cand2, cand3,
     &        iter, pos
C functions
      logical isdata, isop
C -- DEBUG
C     logical isenv
C     integer eow
C     parameter (ENVNUM=11)
C     character*6 env(ENVNUM), token(TOKNUM)
C     data token /'(',')','if','then','else','*','/',
C    2     '+','-','^','=','not','and','or','<','>',
C    3     'ge','le','ne','eq','neg','pos','abs','sqrt','log','exp',
C    4     'sin','cos','tan','asin','acos','atan','inht','int','round',
C    5     'istyp','untyp','rand','rnorm','pi','y','n','x','NUM'/
C     data env /'female','male','isfou','isnon',
C    &       'num','nfoun','anytyp','alltyp','numtyp','famnum','index'/
C -- DEBUG
C
C First convert compound operators (==,^=,<=,>=) to equivalent token
C
      pos=fin
   10 continue
        if (wtyp(pos).eq.11 .and. pos.gt.sta) then
          cand2=wtyp(pos-1)
          if (cand2.eq.11 .or. cand2.eq.10 .or.
     &        cand2.eq.15 .or. cand2.eq.16) then
            call compop(pos-1,sta,fin,nterm,wtyp,expr,error)
            pos=pos-1
          end if
        end if
        pos=pos-1
      if (pos.gt.sta) goto 10
C
C Then main eval loop
C
      change=.false.
      iter=0
      pos=sta-1
  100 continue
        iter=iter+1
        call incpos(pos,sta,fin)
        done=.false.
        error=0
C -- DEBUG
C       do kk=sta,fin
C       if (isenv(wtyp(kk))) then
C         write(*,'(a,$)') env(3000-wtyp(kk))(1:eow(env(3000-wtyp(kk))))
C       else if (isop(wtyp(kk))) then
C         write(*,'(a,$)') token(wtyp(kk))(1:eow(token(wtyp(kk))))
C       else if (wtyp(kk).eq.1000) then
C         write(*,'(a,f5.1,a,$)') ' ',expr(kk),' '
C       else if (isdata(wtyp(kk))) then
C         if (expr(kk).eq.MISS) then
C           write(*,'(a,$)') ' {x} '
C         else
C           write(*,'(a,f12.4,a,$)') ' {',expr(kk),'} '
C         end if
C       end if
C       end do
C       write(*,*)
C -- DEBUG
C
C an answer?
        if (sta.eq.fin) then
          if (isdata(wtyp(sta))) then
            done=.true.
          elseif (isop(wtyp(sta)) .and. op(wtyp(pos)).eq.10) then
            call zerop(pos,sta,fin,nterm,wtyp,expr,error)
            done=.true.
          elseif (error.ne.0) then
            done=.true.
          end if
        else 
C
C check next token and its neighbours (lookahead 1 and lookback 1)
C
          cand1=-1
          cand2=wtyp(pos)
          cand3=-1
          adh1=0
          adh2=0
          adh3=0
          adh4=0
          if (isop(cand2)) then
            adh2=lbp(cand2)
            adh3=rbp(cand2)
          end if
          if (pos.gt.sta) then
            cand1=wtyp(pos-1)
            if (isop(cand1)) then
              adh2=rbp(cand1)
            end if
          end if
          if (pos.gt.(sta+1) .and. isop(wtyp(pos-2))) then
            adh1=rbp(wtyp(pos-2))
          end if
          if (pos.lt.fin) then
            cand3=wtyp(pos+1)
            if (isop(cand3)) then
              adh3=lbp(cand3)
            end if
          end if
          if (pos.lt.(fin-1) .and. isop(wtyp(pos+2))) then
            adh4=lbp(wtyp(pos+2))
          end if
C
C Cases:   v v v, v v o, v o o, o v v, o o o     illegal
C          v o v, u o v                          binary operation
C          o v o                                 unary operation, brackets
C          o o v                                 unary
C
          three=((pos-sta).gt.0 .and. (fin-pos).gt.0)
C Zero function operation
          if (isop(cand2) .and. op(cand2).eq.10) then
            call zerop(pos,sta,fin,nterm,wtyp,expr,error)
            pos=pos-1
            change=.true.
C Brackets
          elseif (three .and. cand1.eq.1 .and. .not.isop(cand2) .and. 
     &        cand3.eq.2) then
            expr(pos-1)=expr(pos)
            wtyp(pos-1)=wtyp(pos)
            call pull(pos,2,fin,nterm,wtyp,expr)
            pos=pos-1
            change=.true.
C Unary minus or plus
          else if ((cand1.eq.-1 .or. 
     2       (three .and. isop(cand1) .and. cand1.ne.2)) .and. 
     3       (cand2.eq.8 .or. cand2.eq.9) .and. isdata(cand3)) then
            if (cand2.eq.9) then
              wtyp(pos)=21
            else
              wtyp(pos)=22
            end if
            pos=pos-1
            change=.true.
C Binary operation
          else if (three .and. .not.isop(cand1) .and. 
     2             isop(cand2) .and. .not.isop(cand3) .and.
     3             op(cand2).eq.2 .and.
     4             adh2.ge.adh1 .and. adh3.ge.adh4) then
            call binop(pos,sta,fin,nterm,wtyp,expr,error)
            pos=pos-1
            change=.true.
C Unary operation
          else if (isop(cand2) .and. isdata(cand3) .and.
     &             op(cand2).eq.1 .and. adh3.ge.adh4) then
            call unop(pos,sta,fin,nterm,wtyp,expr,error)
            pos=pos-1
            change=.true.
          end if
          if (error.ne.0) then
            done=.true.
          end if
        end if
C
C test if expression unevaluable: a complete scan without any operations
C
        if (pos.eq.fin) then
          if (change) then
            change=.false.
          else if (.not.done) then
            done=.true.
            error=1
          end if
        end if
 
      if (.not.done .and. iter.lt.5000) goto 100
      return
      end
C end-of-simpev
C
C Is a number, variable or operator
C
      logical function isdata(idx)
      integer idx
      isdata=(idx.ge.1000)
      return
      end
C end-of-isdata
C     logical function isnum(idx)
C     integer idx
C     isnum=(idx.eq.1000)
C     return
C     end
C end-of-isnum
      logical function isenv(idx)
      integer idx
      isenv=(idx.gt.3000 .and. idx.lt.4000)
      return
      end
C end-of-isenv
      logical function isvar(idx)
      integer idx
      isvar=((idx.gt.2000 .and. idx.lt.3000) .or. 
     &       (idx.gt.4000 .and. idx.lt.5000))
      return
      end
C end-of-isvar
      logical function isop(idx)
      integer idx
      isop=(idx.gt.0 .and. idx.lt.1000)
      return
      end
C end-of-isop
      logical function ismis(idx)
      integer idx
      ismis=(idx.ge.4000 .and. idx.lt.5000)
      return
      end
C end-of-ismis
C
C compound operators eg <= >= == ^=
C
      subroutine compop(pos,sta,fin,nterm,wtyp,expr,error)
      integer MAXLOC, MAXCOL, MISS
      parameter (MAXLOC=120, MAXCOL=MAXLOC+5, MISS=-9999) 
      integer error, fin, nterm, pos, sta
      integer wtyp(MAXCOL)
      double precision expr(MAXCOL)

      integer newop, op1, op2

      if (pos.eq.fin) then
        error=1
        return
      end if
      error=0
      op1=wtyp(pos)
      op2=wtyp(pos+1)
      newop=MISS
      if (op2.eq.11) then
        if (op1.eq.11) then
          newop=20
        elseif (op1.eq.15) then
          newop=18
        elseif (op1.eq.16) then
          newop=17
        elseif (op1.eq.10) then
          newop=19
        end if
      else
        error=1
        return
      end if
      wtyp(pos)=newop
      call pull(pos+1,1,fin,nterm,wtyp,expr)
      return
      end
C end-of-compop
C
C zero argument functions 
C
      subroutine zerop(pos,sta,fin,nterm,wtyp,expr,error)
      integer MAXLOC, MAXCOL, MISS
      parameter (MAXLOC=120, MAXCOL=MAXLOC+5, MISS=-9999) 
      integer error, fin, nterm, pos, sta
      integer wtyp(MAXCOL)
      double precision expr(MAXCOL)

      integer curr, restyp
      double precision res

      error=0
      curr=wtyp(pos)
      if (curr.eq.38) then
        res=dble(random())
        restyp=1000
      elseif (curr.eq.39) then
        res=dble(randn())
        restyp=1000
      elseif (curr.eq.40) then
        res=3.141592653590d0
        restyp=1000
      elseif (curr.eq.41) then
        res=1.0d0
        restyp=1000
      elseif (curr.eq.42) then
        res=0.0d0
        restyp=1000
      elseif (curr.eq.43) then
        res=MISS 
        restyp=4000
      elseif (curr.eq.44) then
        res=MISS 
        restyp=5000
      else
        res=MISS 
        restyp=4000
        error=1
      end if
      wtyp(pos)=restyp
      expr(pos)=res
      return
      end
C end-of-zerop
C
C unary operators
C
      subroutine unop(pos,sta,fin,nterm,wtyp,expr,error)
      integer MAXLOC, MAXCOL, MISS
      parameter (MAXLOC=120, MAXCOL=MAXLOC+5, MISS=-9999) 
      integer error, fin, nterm, pos, sta
      integer wtyp(MAXCOL)
      double precision expr(MAXCOL)

      integer curr, restyp
      double precision res, x

      restyp=1000
      res=MISS 
      if (pos.eq.fin) then
        error=1
        return
      end if
      error=0
      x=expr(pos+1)
      curr=wtyp(pos)
      if (wtyp(pos+1).ge.4000) then
        if (curr.eq.36) then
          res=0.0d0
        elseif (curr.eq.37) then
          res=1.0d0
        else
          res=MISS
          restyp=wtyp(pos+1)
        end if
      elseif (curr.eq.12) then
        if (x.eq.0.0d0) then 
          res=1.0d0
        else
          res=0.0d0
        end if
      elseif (curr.eq.24) then
        if (x.ge.0.0d0) then
          res=sqrt(x)
        else
          res=MISS 
          restyp=5000
        end if
      elseif (curr.eq.21) then
        res=-1.0d0*x
      elseif (curr.eq.23) then
        res=abs(x)
      elseif (curr.eq.25) then
        if (x.gt.0.0d0) then
          res=log(x)
        else
          res=MISS 
          restyp=5000
        end if
      elseif (curr.eq.26) then
        res=exp(x)
      elseif (curr.eq.27) then
        res=sin(x)
      elseif (curr.eq.28) then
        res=cos(x)
      elseif (curr.eq.29) then
        res=tan(x)
      elseif (curr.eq.30) then
        res=asin(x)
      elseif (curr.eq.31) then
        res=acos(x)
      elseif (curr.eq.32) then
        res=atan(x)
      elseif (curr.eq.33) then
        res=0.5d0*log((1.0d0+abs(x))/(1.0d0-abs(x)))
      elseif (curr.eq.34) then
        res=int(x)
      elseif (curr.eq.35) then
        res=anint(x)
      elseif (curr.eq.36 .or. curr.eq.37) then
        if (x.gt.0.0d0) then
          res=1.0d0
        else
          res=0.0d0
        end if
        if (curr.eq.37) res=1.0d0-res
      elseif (curr.eq.22) then
        res=x
      else
        restyp=5000
        res=MISS
        error=1
      end if
      wtyp(pos)=restyp
      expr(pos)=res
      call pull(pos+1,1,fin,nterm,wtyp,expr)
      return
      end
C end-of-unop
C
C binary operators
C
      subroutine binop(pos,sta,fin,nterm,wtyp,expr,error)
      integer MAXLOC, MAXCOL, MISS
      parameter (MAXLOC=120, MAXCOL=MAXLOC+5, MISS=-9999) 
      integer error, fin, nterm, pos, sta
      integer wtyp(MAXCOL)
      double precision expr(MAXCOL)

      integer curr, restyp, wx, wy
      double precision result, x, y
C functions
      logical ismis, isvar

      if (pos.eq.sta .or. pos.eq.fin) then
        error=1
        return
      end if

      restyp=1000
      result=MISS 
      error=0
      x=expr(pos-1)
      y=expr(pos+1)
      wx=wtyp(pos-1)
      wy=wtyp(pos+1)
      curr=wtyp(pos)
C
C Generic number NUM: NUM <- NUM op <any>  (used for detecting parse error)
      if ((wtyp(pos-1).eq.5000 .or. wtyp(pos+1).eq.5000)) then
        result=MISS
        restyp=5000
C
C Assignment:  <var> <- MISS  or  <var> <- <const>
C note var wtyp=2000+offset, missing var wtyp=4000+offset
      elseif (curr.eq.11) then
        if (ismis(wy)) then
          result=MISS
          restyp=4000
          if (isvar(wx) .and. .not.ismis(wx)) restyp=wx+2000
        else
          result=y
          restyp=wx
          if (isvar(wx) .and. ismis(wx)) restyp=wx-2000
        end if
C
C Equality or inequality: allows comparison with missing values
      elseif (curr.eq.19 .or. curr.eq.20) then
        if (x.eq.y) then
          result=1.0d0
        else
          result=0.0d0
        end if
        if (curr.eq.19) then
          result=1.0d0-result
        end if
C
C AND and OR allows (lazy) combination with missing values
C (T && x) = x   (T || x) = T    (F && x) = F   (F || x) = x
C
      elseif (curr.eq.13) then
        result=1.0d0
        if (x .eq.0.0d0 .or. y.eq.0.0d0) then
          result=0.0d0
        elseif (ismis(wx) .or. ismis(wy)) then 
          result=MISS
          restyp=4000
        end if
      elseif (curr.eq.14) then
        result=0.0d0
        if (x .eq.1.0d0 .or. y.eq.1.0d0) then
          result=1.0d0
        elseif (ismis(wx) .or. ismis(wy)) then 
          result=MISS
          restyp=4000
        end if
C
C All other operations with missing values lead to MISS as outcome
      elseif (ismis(wx) .or. ismis(wy)) then 
        result=MISS
        restyp=4000
C
C All other operations 
      elseif (curr.eq.6) then
        result=x*y
      elseif (curr.eq.7) then
        if (y.eq.0) then
          expr(pos-1)=MISS
          return
        else
          result=x/y
        end if
      elseif (curr.eq.8) then
        result=x+y
      elseif (curr.eq.9) then
        result=x-y
      elseif (curr.eq.10) then
        result=x**y
      elseif (curr.eq.16) then
        if (x.gt.y) then
          result=1.0d0
        else
          result=0.0d0
        end if
      elseif (curr.eq.15) then
        if (x.lt.y) then
          result=1.0d0
        else
          result=0.0d0
        end if
      elseif (curr.eq.17) then
        if (x.ge.y) then
          result=1.0d0
        else
          result=0.0d0
        end if
      elseif (curr.eq.18) then
        if (x.le.y) then
          result=1.0d0
        else
          result=0.0d0
        end if
      else
        error=1
        return
      end if
      wtyp(pos-1)=restyp
      expr(pos-1)=result
      call pull(pos,2,fin,nterm,wtyp,expr)
      return
      end
C end-of-binop
C
C Evaluate type of each term in expression word(farg...larg) and actn
C actn=0 error  =1 purely arithmetic  =2 legal
C
C Types are:   wtyp                 expr
C              -----------------    --------
C tokens       0    + 0...TOKNUM    -
C constant     1000                 value
C data         2000 + 1...NLOCI    (value)
C env          3000 + 1...ENVNUM   (value)
C              
C MISS         4000                 MISS  
C missing data 4000 + 1...NLOCI     MISS
C NUM          5000                 -   
C
      subroutine typwords(farg,larg,words,nloci,loc,loctyp,token,env,
     &                    wtyp,expr,actn)
      integer ENVNUM, KNOWN, MAXLOC, MAXCOL, MISS, TOKNUM 
      parameter (ENVNUM=11, KNOWN=0, MAXLOC=120, MAXCOL=MAXLOC+5, 
     &           MISS=-9999, TOKNUM=44)
      integer actn, farg, larg
      character*20 words(MAXCOL)
      integer nloci, loctyp(MAXLOC)
      character*10 loc(MAXLOC)
      character*6 env(ENVNUM), token(TOKNUM)
      integer wtyp(MAXCOL)
      double precision expr(MAXCOL)

      integer i, ienv, ilok, itok
C functions
      logical ismiss, isreal
      integer eow, isinenv
      real fval

      actn=1
      do 10 i=farg, larg
        expr(i)=MISS
        ienv=isinenv(words(i),ENVNUM,env)
        itok=isinenv(words(i),TOKNUM,token)
        ilok=isinenv(words(i),nloci,loc)
        if (itok.gt.0) then
          wtyp(i)=itok
        else if (ilok.gt.0) then
          wtyp(i)=2000+ilok
          actn=2
        else if (ienv.gt.0) then
          wtyp(i)=3000+ienv
        else if (ismiss(words(i))) then
          wtyp(i)=4001
        else if (isreal(words(i))) then
          wtyp(i)=1000
          expr(i)=dble(fval(words(i)))
        else
          actn=0
          write(*,'(3a)') 'ERROR: token "',words(i)(1:eow(words(i))),
     &                    '" not recognised.'
          return
        end if
   10 continue
      return
      end
C end-of-typwords
C
C If checking arguments via dry run of parser, 
C replace variable values with (generic) NUM
C
      subroutine dryrun(farg,larg,wtyp)

      integer MAXLOC, MAXCOL
      parameter (MAXLOC=120, MAXCOL=MAXLOC+5) 

      integer farg, larg, wtyp(MAXCOL)
      integer i

      do 10 i=farg, larg
      if (wtyp(i).gt.2000 .and. wtyp(i).lt.3000) then
        wtyp(i)=5000
      end if
   10 continue
      return
      end
C end-of-dryrun
C
C Pull up expr
C
      subroutine pull(pos,dec,fin,nterm,typ,expr)
      integer MAXLOC, MAXCOL
      parameter (MAXLOC=120, MAXCOL=MAXLOC+5) 
      integer dec, fin, nterm, pos
      integer typ(MAXCOL)
      double precision expr(MAXCOL)
      integer i

      do 10 i=pos,nterm-dec
        typ(i)=typ(i+dec)
        expr(i)=expr(i+dec)
   10 continue
      nterm=nterm-dec
      if (fin.ge.pos) fin=fin-dec
      return
      end
C end-of-pull
C
C  See if a string is a missing value
C
      logical function ismiss(string)
      character*(*) string
      ismiss=(string.eq.'x' .or. string.eq.'X' .or. string.eq.'.')
      return
      end
C end-of-ismiss
C
C  See if a string is a valid real number
C
      logical function isreal(string)
      character*20 string
      real v

      if (string.eq.'x' .or. string.eq.'X' .or. string.eq.'.' .or.
     2    string.eq.'y' .or. string.eq.'Y' .or. string.eq.' ' .or.
     3    string.eq.'n' .or. string.eq.'N') then
        isreal=.true.
      else
        read(string,'(f20.0)',err=10) v
        isreal=.true.
      end if 
      return
C error -- word is not a number
   10 continue
        isreal=.false.
      return
      end
C end-of-isreal
C
C Is a bound environmental variable? and if so where?
C
      integer function isinenv(word,nvar,envnam)
      integer nvar
      character*(*) word, envnam(*)

      do 10 isinenv=1, nvar
      if (envnam(isinenv).eq.word) then
        return
      end if
   10 continue
      isinenv=0
      return
      end
C end-of-isinenv
C 
C Is a reserved word
C
C     integer function istoken(word,toknum,token)
C     integer toknum
C     character*(*) word, token(toknum)

C     do 10 istoken=1, toknum
C     if (word.eq.token(istoken)) then
C       return
C     end if
C  10 continue
C     istoken=0
C     return
C     end
C end-of-istoken
C
C Increment counter mod maxpos
C
      subroutine incpos(pos,minpos,maxpos)
      integer maxpos, pos
      if (pos.ge.maxpos) then
        pos=minpos
      else
        pos=pos+1
      end if
      return
      end
C end-of-incpos
C
C Evaluate expression for each pedigree member
C
      subroutine evalped(wrk,twrk,narg,words,nloci,loc,loctyp,locpos,
     2             token,env,lbp,rbp,op,wtyp,expr,pedigree,actset,
     3             num,nfound,id,fa,mo,sex,locus,numloc,plevel)
      integer ENVNUM, MAXLOC, MAXCOL, MAXSIZ, MISS, TOKNUM 
      parameter (ENVNUM=11, MAXLOC=120, MAXCOL=MAXLOC+5, 
     &           MAXSIZ=1000, MISS=-9999, TOKNUM=44)
      integer numloc,narg,plevel,twrk,wrk

      character*20 words(MAXCOL)
      character*6 env(ENVNUM), token(TOKNUM)
      integer lbp(0:TOKNUM), rbp(0:TOKNUM), op(0:TOKNUM)
      integer wtyp(MAXCOL)
      double precision expr(MAXCOL)
C
C Locus structure:
C number of loci, locus name, locus type, and locus position in file
C loctyp 1=marker 2=x-marker 3=quant 4=affection 5-8=deleted
C
      integer nloci
      character*10 loc(MAXLOC)
      integer loctyp(MAXLOC),locpos(MAXLOC)

C Pedigree structure
      character*10 pedigree
      integer actset, num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
      logical last
C
      integer actn, eop, error, i, nchange, 
     &        nev, nerr, nmark, nmiss, nped, nterm, trget, tarpos
      real tmp, x1, x2
C functions
      integer eow
      logical ismis, isvar

      call cntmark(nloci,loctyp,nmark,1)

      last=.false.
      nchange=0
      nerr=0
      nev=0
      nmiss=0
      nped=0
      rewind(wrk)
   10 continue
       call wrkin(wrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &            numloc, last)
       if (last) goto 20
         if (actset.le.0) then
           call wrkout(twrk,pedigree,actset,num,nfound,id,fa,mo,sex,
     &                 locus,numloc)
           goto 10
         end if
C evaluate for each member of pedigree
        nped=nped+1
        eop=eow(pedigree)
        do 15 i=1, num
          nterm=narg
          call typwords(1,nterm,words,nloci,loc,loctyp,token,env,
     &                  wtyp,expr,actn)
C
C init variables in expr with value from locus() or environment
C
          call loadvar(i,1,nmark,nloci,loctyp,locpos,nev,nped,num,
     &                 nfound,sex, locus,1,nterm,wtyp,expr)
          call parser(nterm,wtyp,expr,lbp,rbp,op,error)
C Update pedigree value if appropriate
          if (nterm.eq.1 .and. error.eq.0) then
            if (.not.isvar(wtyp(1))) then
              if (plevel.gt.0) then
                write(*,*) pedigree(1:eow(pedigree)),'-',
     &                     id(i)(1:eow(id(i))),' => ',expr(1)
              end if
            else
              if (ismis(wtyp(1))) then 
                trget=wtyp(1)-4000
              else
                trget=wtyp(1)-2000
                if (expr(1).eq.MISS) expr(1)= -9999.001d0
              end if
              tarpos=locpos(trget)
              x1=sngl(expr(1))
              if (loctyp(trget).eq.4 .and. x1.ne.MISS) then
                if (x1.le.0.0) then
                  x1=1.0
                else
                  x1=2.0
                end if
              end if
              if (locus(i,tarpos).ne.MISS .and. x1.eq.MISS) then
                nmiss=nmiss+1
              end if
              nchange=nchange+1
C If result is a trait, set to new value
              if (loctyp(trget).eq.3 .or. loctyp(trget).eq.4) then
                if (plevel.gt.1) then
                   write(*,'(7a,f12.4,a,f12.4)') 
     2             'Recoded ',pedigree(1:eop),'-',id(i)(1:eow(id(i))),
     3             ' at "',loc(trget), '" from ',
     4             locus(i,tarpos),' to ',x1
                end if
                locus(i,tarpos)=x1
C
C else if result of evaluation is a marker, then repeat evaluation for 
C second allele, using second allele of all markers in expression
C
              else
                if (x1.ne.MISS) then
                  nterm=narg
                  call typwords(1,nterm,words,nloci,loc,loctyp,token,
     &                          env,wtyp,expr,actn)
                  call loadvar(i,2,nmark,nloci,loctyp,locpos,nev,nped,
     &                         num,nfound,sex,locus,1,nterm,wtyp,expr)
                  call parser(nterm,wtyp,expr,lbp,rbp,op,error)
                  x2=sngl(expr(1))
                  if (x2.eq.MISS) x1=MISS
                else
                  x2=MISS
                end if
                if (x1.gt.x2) then
                  tmp=x2
                  x2=x1
                  x1=tmp
                end if
                if (plevel.gt.1) then
                   write(*,'(6a,4(a,f4.0))') 
     2             'Recoded ',pedigree(1:eop),'-',id(i)(1:eow(id(i))),
     3             ' at "',loc(trget), '" from ',
     4             locus(i,tarpos),'/',locus(i,tarpos+1),' to ',
     5             x1,'/',x2
                end if
                locus(i,tarpos)=x1
                locus(i,tarpos+1)=x2
              end if
            end if
          else 
            nerr=nerr+1
            if (plevel.gt.0) then
              write(*,'(5a)') 
     2         'NOTE:  Could not evaluate expression for ',
     3         pedigree(1:eow(pedigree)),'-',id(i),'.'
            end if
          end if
   15   continue
        call wrkout(twrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &              numloc)
        nev=nev+num
      goto 10
   20 continue
      write(*,'(a,i6,a)') 'Recoded ',nchange,' values.'
      if (nmiss.gt.0) then
        write(*,'(a,i6,a)') 'Including ',nmiss,' values to missing.'
      end if
      if (nerr.gt.0) then
        write(*,'(a,i6,a,f5.1,a)') 
     2    'Could not evaluate expression for ',nerr,' records (',
     3    dfloat(100*nerr)/dfloat(nev),'%), which are left unchanged.' 
      end if
      return
      end
C end-of-evalped
C
C Find if/then/else
C
      subroutine findth(nterm,wtyp,posif,posth,posel)
      integer MISS
      parameter (MISS=-9999)
      integer nterm, posel, posif, posth, wtyp(nterm)
      integer i
      posif=MISS
      posth=MISS
      posel=MISS
      do 10 i=1, nterm
        if (wtyp(i).eq.3 .and. posif.eq.MISS) then
          posif=i
        else if (wtyp(i).eq.4 .and. posth.eq.MISS) then
          posth=i
        else if (wtyp(i).eq.5 .and. posel.eq.MISS) then
          posel=i
        end if
   10 continue
      return
      end
C end-of-findth
C
C Load variable values for ith individual
C code y and n as 1 and 0
C load whall'th allele value for a marker
C tot records number of records evaluated to date
C
      subroutine loadvar(idx,whall,nmark,nloci,loctyp,locpos,tot,nped,
     &                   num,nfound, sex,locus,sta,fin,wtyp,expr)
      integer  KNOWN, MAXCOL, MAXLOC, MAXSIZ, MISS
      parameter (KNOWN=0, MAXLOC=120, MAXCOL=MAXLOC+5, 
     &           MAXSIZ=1000, MISS=-9999)
      integer fin, idx, nloci, nmark, nped, sta, tot, whall

      integer wtyp(MAXCOL)
      double precision expr(MAXCOL)
      integer loctyp(MAXLOC),locpos(MAXLOC)

C Pedigree structure
      integer num, nfound
      integer sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)

      integer curr, i, j, iloc
C
C functions
      logical isenv, isvar

      do 10 j=sta,fin
        curr=wtyp(j)
C automatic/environmental variables
        if (isenv(curr)) then
          curr=curr-3000
          expr(j)=MISS
          wtyp(j)=1000
C female male
          if (curr.lt.3) then
            if (sex(idx).eq.MISS) then
              wtyp(j)=4000
            else
              expr(j)=dfloat(abs(sex(idx)-curr))
            end if
C isfou
          elseif (curr.eq.3) then
            expr(j)=0.0d0
            if (idx.le.nfound) expr(j)=1.0d0
C isnon 
          elseif (curr.eq.4) then
            expr(j)=0.0d0
            if (idx.gt.nfound) expr(j)=1.0d0
C num
          elseif (curr.eq.5) then
            expr(j)=dfloat(num)
C nfoun
          elseif (curr.eq.6) then
            expr(j)=dfloat(nfound)
C famnum
          elseif (curr.eq.10) then
            expr(j)=dfloat(nped)
C index
          elseif (curr.eq.11) then
            expr(j)=dfloat(tot+idx)
C anytyp alltyp numtyp 
          else
            iloc=0
            do 50 i=1, nloci
              if (loctyp(i).le.2 .and. locus(idx,locpos(i)).gt.KNOWN)
     &        then
                iloc=iloc+1
              end if
   50       continue
            expr(j)=0.0d0
            if (curr.eq.7) then
              if (iloc.gt.0) expr(j)=1.0d0
            else if (curr.eq.8) then
              if (iloc.eq.nmark) expr(j)=1.0d0
            else if (curr.eq.9) then
              expr(j)=dfloat(iloc)
            end if
          end if
C user defined variables
        elseif (isvar(curr)) then
          curr=curr-2000
          if (loctyp(curr).eq.4 .and. 
     &        locus(idx,locpos(curr)).ge.1) then
            expr(j)=dble(locus(idx,locpos(curr))-1.0)
          elseif (loctyp(curr).le.2 .and. whall.eq.2) then
            expr(j)=dble(locus(idx,locpos(curr)+1))
          else
            expr(j)=dble(locus(idx,locpos(curr)))
          end if
          if (expr(j).eq.MISS) wtyp(j)=4000+curr
        end if
   10 continue
      return
      end
C end-of-loadvar 
C
C Select pedigrees where probands meet a given criterion v2
C
      subroutine select(wrk,twrk,typ,nprob,farg,larg,words,nloci,loc,
     2             loctyp,locpos,token,env,lbp,rbp,op,wtyp,expr,
     3             pedigree,actset,num,nfound,id,fa,mo,sex,locus,numloc,
     4             nobs,plevel)
      integer ENVNUM, MAXLOC, MAXCOL, MAXSIZ, MISS, TOKNUM 
      parameter (ENVNUM=11, MAXLOC=120, MAXCOL=MAXLOC+5, 
     &           MAXSIZ=1000, MISS=-9999, TOKNUM=44)
      integer farg,larg,nobs,nprob,numloc,plevel,twrk,typ,wrk

      character*20 words(MAXCOL)
      character*6 env(ENVNUM), token(TOKNUM)
      integer lbp(0:TOKNUM), rbp(0:TOKNUM), op(0:TOKNUM)
      integer wtyp(MAXCOL)
      double precision expr(MAXCOL)
C
C Locus structure:
C number of loci, locus name, locus type, and locus position in file
C loctyp 1=marker 2=x-marker 3=quant 4=affection 5-8=deleted
C
      integer nloci
      character*10 loc(MAXLOC)
      integer loctyp(MAXLOC),locpos(MAXLOC)

C Pedigree structure
      character*10 pedigree
      integer actset, num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
      logical last
C
C
      integer actn, error, fin, idx, nmark, nped, nuse, sta, tot, uped
      logical useful
C functions
      integer eow

      call prexpr(typ, nprob, farg, larg, words)

      call cntmark(nloci,loctyp,nmark,1)
      nped=0
      uped=0
      nobs=0
      tot=0
      last=.false.
      rewind(wrk)
   10 continue
       call wrkin(wrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &            numloc, last)
       if (last) goto 20
 
       if (actset.gt.0) then
        useful=.false.
        nped=nped+1
        nuse=0
        eop=eow(pedigree)
        do 15 idx=1, num
          sta=farg
          fin=larg 
          nterm=larg
          call typwords(sta,fin,words,nloci,loc,loctyp,token,env,
     &                  wtyp,expr,actn)
C init variables in expr with value from locus() or environment
          call loadvar(idx,1,nmark,nloci,loctyp,locpos,tot,nped,
     &                 num,nfound,sex,locus,sta,fin,wtyp,expr)
          call simpev(sta,fin,nterm,wtyp,expr,lbp,rbp,op,error)
C test if condition true
          if (sta.eq.fin .and. error.eq.0 .and.
     &        expr(sta).ne.MISS .and. expr(sta).ne.0.0d0) then
             nuse=nuse+1
             if (typ.ne.5 .and. nuse .ge. nprob) then
               useful=.true.
               goto 100
             end if
          end if
   15   continue

        if (typ.eq.5 .and. nuse.eq.nprob) useful=.true.

  100   continue
        if (useful) then
          uped=uped+1
          nobs=nobs+num
          if (plevel.gt.1) then
            write(*,'(3a,a8)') 
     2      'Pedigree ',pedigree(1:eow(pedigree)),
     3      ' selected via person ',id(idx)
          end if
        else
          actset=-abs(actset)
        end if
        tot=tot+num
       end if
          call wrkout(twrk,pedigree,actset,num,nfound,id,fa,mo,sex,
     &                locus,numloc)
      goto 10
   20 continue

      write(*,'(/a,i5,a,i5,a/)') 
     &  'Number of pedigrees selected=',uped,' (',nobs,' individuals)'
      return
      end
C end-of-select
C 
C unselect or pack
      subroutine unsel(wrk,twrk,typ,pedigree,actset,num,nfound,
     &             id,fa,mo,sex,locus,numloc,nobs,plevel)
      integer ENVNUM, MAXLOC, MAXCOL, MAXSIZ, MISS, TOKNUM 
      parameter (ENVNUM=11, MAXLOC=120, MAXCOL=MAXLOC+5, 
     &           MAXSIZ=1000, MISS=-9999, TOKNUM=44)
      integer plevel,twrk,typ,wrk
C Pedigree structure
      character*10 pedigree
      integer actset, num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
      logical last

      integer nped, nobs, dped, dobs
C
      nped=0
      nobs=0
      dped=0
      dobs=0
      last=.false.
      rewind(wrk)
      if (typ.eq.1) then
   10   continue
         call wrkin(wrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &              numloc, last)
         if (last) goto 20
            nped=nped+1
            nobs=nobs+num
            actset=1
            call wrkout(twrk,pedigree,actset,num,nfound,id,fa,mo,sex,
     &                  locus,numloc)
        goto 10
   20   continue
      else
   30   continue
         call wrkin(wrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &              numloc, last)
         if (last) goto 40
          if (actset.gt.0) then  
            nped=nped+1
            nobs=nobs+num
            call wrkout(twrk,pedigree,actset,num,nfound,id,fa,mo,sex,
     &                  locus,numloc)
          else
            if (plevel.gt.1) then
              write(*,'(2a)') 'Deleting pedigree ', pedigree
            end if
            dped=dped+1
            dobs=dobs+num
          end if
        goto 30
   40   continue
      end if
      write(*,'(/a,i5,a,i5,a/)') 
     &  'Number of active pedigrees=',nped,' (',nobs,' individuals)'
      if (dped.gt.0) then
        write(*,'(/a,i5,a,i5,a/)') 
     &  'Permanently deleted ',dped,' pedigrees (',dobs,' individuals)'
      end if
      return
      end
C end-of-unsel
C
C Count or print individuals per pedigree fulfilling criterion
C 
      subroutine docount(wrk,typ,farg,larg,words,nloci,loc,
     2             loctyp,locpos,token,env,lbp,rbp,op,wtyp,expr,
     3             pedigree,actset,num,nfound,id,fa,mo,sex,
     4             locus,numloc,plevel)
      integer ENVNUM,MAXLOC,MAXCOL,MAXSIZ,MISS,TOKNUM 
      parameter (ENVNUM=11, MAXLOC=120, MAXCOL=MAXLOC+5, 
     &           MAXSIZ=1000, MISS=-9999, TOKNUM=44)
      integer farg,larg,numloc,plevel,typ,wrk

      character*20 words(MAXCOL)
      character*6 env(ENVNUM), token(TOKNUM)
      integer lbp(0:TOKNUM), rbp(0:TOKNUM), op(0:TOKNUM)
      integer wtyp(MAXCOL)
      double precision expr(MAXCOL)
C
C Locus structure:
C number of loci, locus name, locus type, and locus position in file
C loctyp 1=marker 2=x-marker 3=quant 4=affection 5-8=deleted
C
      integer nloci
      character*10 loc(MAXLOC)
      integer loctyp(MAXLOC),locpos(MAXLOC)

C Pedigree structure
      character*10 pedigree
      integer actset, num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
      logical last
C Local variables
      integer actn,arg1,argn,currf,currm,contrib,error,fin,idx,k,nmark
      integer naff,nped,nasp,nast,nasq,nuse,taff,tasp,tast,tasq,tot

      call prexpr(typ, 1, farg, larg, words)

      if (typ.eq.1) then
        write(*,'(a/a)') 'Pedigree   Con=T   Num  ASPs Trios    4+',
     &                   '---------- ----- ----- ----- ----- -----'
      end if
      call cntmark(nloci,loctyp,nmark,1)
      nped=0
      nuse=0
      taff=0
      tasp=0
      tast=0
      tasq=0
      tot=0
      last=.false.
      rewind(wrk)
   10 continue
       call wrkin(wrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &            numloc, last)
       if (last) goto 20
 
       if (actset.le.0) goto 10

        naff=0
        nasp=0
        nast=0
        nasq=0

        nped=nped+1
C founders
        do 95 idx=1,nfound
          arg1=farg
          argn=larg 
          nterm=larg
          call typwords(arg1,argn,words,nloci,loc,loctyp,token,env,
     &           wtyp,expr,actn)
          call loadvar(idx,1,nmark,nloci,loctyp,locpos,tot,nped,
     &                 num,nfound,sex, locus,arg1,argn,wtyp,expr)
          call simpev(arg1,argn,nterm,wtyp,expr,lbp,rbp,op,error)
          if (arg1.eq.argn .and. error.eq.0 .and.
     &         expr(arg1).ne.MISS .and. expr(arg1).ne.0.0d0) then
            naff=naff+1
            if (typ.eq.2) then
              call wrind(idx,pedigree,id,fa,mo,sex,
     &                   locus,nloci,loc,loctyp,locpos)
            end if
          end if
   95   continue
C nonfounders
        fin=num
        currf=fa(num)
        currm=mo(num)
        do 90 k=num-1,nfound,-1
          if (fa(k).ne.currf .or. mo(k).ne.currm) then
            nfam=nfam+1
            contrib=0
            do 92 idx=k+1,fin
              arg1=farg
              argn=larg 
              nterm=larg
              call typwords(arg1,argn,words,nloci,loc,loctyp,token,env,
     &               wtyp,expr,actn)
C init variables in expr with value from locus() or environment
              call loadvar(idx,1,nmark,nloci,loctyp,locpos,tot,nped,
     &               num,nfound,sex,locus,arg1,argn,wtyp,expr)
              call simpev(arg1,argn,nterm,wtyp,expr,lbp,rbp,op,error)
C test if condition true
              if (arg1.eq.argn .and. error.eq.0 .and.
     &         expr(arg1).ne.MISS .and. expr(arg1).ne.0.0d0) then
                naff=naff+1
                contrib=contrib+1
                if (typ.eq.2) then
                  call wrind(idx,pedigree,id,fa,mo,sex,
     &                       locus,nloci,loc,loctyp,locpos)
                end if
              end if
   92       continue
C Now update to next sibship
            if (contrib.eq.2) then
              nasp=nasp+1
            else if (contrib.eq.3) then
              nast=nast+1
            else if (contrib.gt.3) then
              nasq=nasq+1
            end if
            fin=k
            currf=fa(fin)
            currm=mo(fin)
          end if
   90   continue
        if (typ.eq.1 .and. plevel.ge.0 .and. naff.gt.0) then
          write(*,'(a,5(1x,i5))') pedigree, naff, num, nasp, nast, nasq
        end if
        taff=taff+naff
        tasp=tasp+nasp
        tast=tast+nast
        tasq=tasq+nasq
        tot=tot+num
        if (naff.gt.0) then
          nuse=nuse+1
        end if
      goto 10
   20 continue
      if (typ.eq.1) then
        write(*,'(a10,5(1x,i5))') 
     &    'Total     ',taff, tot, tasp, tast, tasq 
      end if
      write(*,'(/2(/a,i5,a,i5,a,f5.1,a))') 
     2  'Number of matched persons   =',taff,' out of ',tot,
     3   ' (',100.0d0*dfloat(taff)/dfloat(tot),'%)',
     4  'Number of matched pedigrees =',nuse,' out of ', nped,
     5   ' (',100.0d0*dfloat(nuse)/dfloat(nped),'%)' 
      return
      end
C end-of-docount 
C
C Delete data for individuals fulfilling criterion
C 
      subroutine seldel(wrk,twrk,nord,ord,farg,larg,words,nloci,loc,
     2             loctyp,locpos,token,env,lbp,rbp,op,wtyp,expr,
     3             pedigree,actset,num,nfound,id,fa,mo,sex,
     4             locus,numloc,plevel)
      integer ENVNUM,KNOWN,MAXLOC,MAXCOL,MAXSIZ,MISS,TOKNUM 
      parameter (ENVNUM=11, KNOWN=0, MAXLOC=120, MAXCOL=MAXLOC+5, 
     &           MAXSIZ=1000, MISS=-9999, TOKNUM=44)
      integer farg,larg,numloc,plevel,twrk,wrk
      integer nord, ord(MAXSIZ)

      character*20 words(MAXCOL)
      character*6 env(ENVNUM), token(TOKNUM)
      integer lbp(0:TOKNUM), rbp(0:TOKNUM), op(0:TOKNUM)
      integer wtyp(MAXCOL)
      double precision expr(MAXCOL)
C
C Locus structure:
C number of loci, locus name, locus type, and locus position in file
C loctyp 1=marker 2=x-marker 3=quant 4=affection 5-8=deleted
C
      integer nloci
      character*10 loc(MAXLOC)
      integer loctyp(MAXLOC),locpos(MAXLOC)

C Pedigree structure
      character*10 pedigree
      integer actset, num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
      logical last
C Local variables
      integer actn,arg1,argn,error,idx,k,nmark
      integer ndel,nped,tot
C functions
      integer eow

      call prexpr(6, nord, farg, larg, words)

      ndel=0
      nped=0
      tot=0
      last=.false.
      rewind(wrk)
   10 continue
       call wrkin(wrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &            numloc, last)
       if (last) goto 20
 
       if (actset.gt.0) then
         nped=nped+1
         do 95 idx=1,num
           arg1=farg
           argn=larg 
           nterm=larg
           call typwords(arg1,argn,words,nloci,loc,loctyp,token,env,
     &            wtyp,expr,actn)
           call loadvar(idx,1,nmark,nloci,loctyp,locpos,tot,nped,
     &                  num,nfound,sex, locus,arg1,argn,wtyp,expr)
           call simpev(arg1,argn,nterm,wtyp,expr,lbp,rbp,op,error)
           if (arg1.eq.argn .and. error.eq.0 .and.
     &          expr(arg1).ne.MISS .and. expr(arg1).ne.0.0d0) then
             ndel=ndel+1
             if (plevel.gt.1) then
               write(*,'(4a)') 
     &           'Deleting ', pedigree(1:eow(pedigree)), '-', id
             end if
             do 50 j=1, nord
               k=ord(j)
               pos=locpos(k)
               if ((loctyp(k).eq.1 .or. loctyp(k).eq.2) .and.
     &             locus(idx,pos).ge.KNOWN) then
                 locus(idx,pos)=-locus(idx,pos)
                 locus(idx,pos+1)=-locus(idx,pos+1)
               else if (loctyp(k).eq.3 .or. loctyp(k).eq.4) then
                 locus(idx,pos)=MISS
               end if
   50        continue
           end if
   95    continue
         tot=tot+num
       end if
        call wrkout(twrk,pedigree,actset,num,nfound,id,fa,mo,sex,
     &              locus,numloc)
      goto 10
   20 continue
      write(*,'(/2(/a,i5,a,i5,a,f5.1,a))') 
     2  'Number of deleted records   =',ndel,' out of ',tot,
     3   ' (',100.0d0*dfloat(ndel)/dfloat(tot),'%)' 
      return
      end
C end-of-seldel  
C
C
C Echo action to be performed
C
      subroutine prexpr(typ, nprob, farg, larg, words)
      integer MAXLOC,MAXCOL
      parameter (MAXLOC=120, MAXCOL=MAXLOC+5) 

      integer farg,larg,nprob,typ

      character*20 words(MAXCOL)
C Local variables
      integer k
C functions
      integer eow

      if (typ.eq.1) then
        write(*,'(/2a,$)') 
     &    'Count where "', words(farg)(1:eow(words(farg)))
      else if (typ.eq.2) then
        write(*,'(/2a,$)') 
     &    'Print where "', words(farg)(1:eow(words(farg)))
      else if (typ.eq.3) then
        write(*,'(/2a,$)') 
     &    'Selecting pedigrees where "', words(farg)(1:eow(words(farg)))
      else if (typ.eq.4) then
        write(*,'(/a,i3,2a,$)') 
     2    'Selecting pedigrees to contain ',nprob, 
     3    ' or more individuals where "',words(farg)(1:eow(words(farg)))
      else if (typ.eq.5) then
        write(*,'(/a,i3,2a,$)') 
     2  'Selecting pedigrees to contain exactly ',
     3  nprob,' individuals where "', words(farg)(1:eow(words(farg)))
      else if (typ.eq.6) then
        write(*,'(/a,i3,2a,$)') 
     2    'Zeroing ',nprob,' variables in each record where "', 
     3    words(farg)(1:eow(words(farg)))
      end if
      do 1 k=farg+1, larg
        write(*,'(1x,a,$)') words(k)(1:eow(words(k)))
    1 continue
      write(*,'(a/)') '":'
      return
      end
C end-of-prexpr
