C
C extracts narg arguments from input string s
C
C typ=1  whitespace separated
C typ=2  whitespace separated or reserved character (id by opchar())
C typ=3  whitespace or slash separated (so genotypes can be written a/b)
C
      subroutine args(s,narg,arg,typ)
      character*(*) s
      integer narg, typ
      character*(*) arg(narg)
      integer eol,i,iarg,n,sarg,sol
C functions
      integer eow, sow
      logical opchar

      do 5 i=1,narg
        arg(i)=' '
    5 continue
      sol=sow(s)
      eol=eow(s)

      n=1
      i=sol
C
C start of main loop
   30 continue

      if (i.gt.eol) goto 40
        if (typ.eq.2 .and. opchar(s(i:i))) then
          arg(n)=s(i:i)
          n=n+1
        elseif (typ.eq.3 .and. n.gt.4 .and. s(i:i).eq.'/') then
          continue
        elseif (s(i:i).eq.'"') then
          iarg=-1
          i=i+1
          sarg=i
   45     continue
          if (i.gt.eol .or. s(i:i).eq.'"') goto 60
            iarg=iarg+1
            i=i+1
          goto 45
        elseif (s(i:i).ne.' ' .and. s(i:i).ne.'\t') then
          iarg=-1
          sarg=i
   50     continue
          if (i.gt.eol .or. s(i:i).eq.' ' .or. s(i:i).eq.'\t' .or.
     2        s(i:i).eq.'"' .or. 
     3        (typ.eq.2 .and. opchar(s(i:i))) .or.
     4        (typ.eq.3 .and. s(i:i).eq.'/')) then
            i=i-1
            goto 60
          end if
            iarg=iarg+1
            i=i+1
          goto 50
   60     continue
C        
          arg(n)=s(sarg:(sarg+iarg))
          n=n+1
        end if
        i=i+1
      goto 30
   40 continue
C
C return # arguments actually found 
      narg=n-1
      return
      end 
C end-of-arg
C
C is a reserved character for primitives?  "()*+-/<=>^"
C
      logical function opchar(ch)
      character*1 ch
      integer ich
      ich=ichar(ch)
      opchar=((ich.ge.40 .and. ich.le.43) .or. ich.eq.45 .or. 
     &  ich.eq.47 .or. (ich.ge.60 .and. ich.le.62) .or. ich.eq.94)
      return
      end
C end-of-opchar
C
C character to integer conversion via internal read
C
      integer function ival(string)
      integer MISS
      parameter(MISS=-9999)
      character*20 string
      integer i
      if (string.eq.' ') then
        ival=0
      elseif (string.eq.'x' .or. string.eq.'X' .or. string.eq.'.') then
        ival=MISS
      else
        read(string,'(i20)',err=10) i
        ival=i
      end if 
      return
C error -- word is not an integer
   10 write(*,'(2a/)') 'ERROR: Unable to read integer ',string
      ival=0
      return
      end
C end-of-ival
C
C character to float conversion via internal read
C
      real function fval(string)
      integer BLANK, MISS
      parameter(BLANK=-9999,MISS=-9999)
      character*20 string
      real v

      if (string.eq.' ' .or. string.eq.'-') then
        fval=BLANK
      elseif (string.eq.'x' .or. string.eq.'X' .or. string.eq.'.') then
        fval=MISS
      elseif (string.eq.'y' .or. string.eq.'Y') then
        fval=2.0
      elseif (string.eq.'n' .or. string.eq.'N') then
        fval=1.0
      else
        read(string,'(f20.0)',err=10) v
        fval=v
      end if 
      return
C error -- word is not a number
   10 write(*,'(2a/)') 'ERROR: Unable to read real number ',string
      fval=0.0
      return
      end
C end-of-fval
C
C skip leading whitespace
C
      integer function sow(string)
      character*(*) string
      do 10 i=1,len(string)
   10   if (string(i:i).ne.' ' .and. string(i:i).ne.'\t') goto 20
   20 sow=i
      return
      end
C
C find end of string
C
      integer function eow(string)
      character*(*) string
      do 10 i=len(string),1,-1
   10   if (string(i:i).ne.' ') goto 20
   20 eow=i
      return
      end
C end-of-eow
C
C Justify a string of characters within a string
C
      subroutine juststr(just,string,length)
      integer length
      character*1 just
      character*(*) string
      integer fin,i,j,sta

      sta=0
   10 continue
        sta=sta+1
      if (string(sta:sta).eq.' '.and. sta.le.length) goto 10
      fin=length+1
   20 continue
        fin=fin-1
      if (string(fin:fin).eq.' '.and. fin.gt.0) goto 20
      
      i=length-fin+sta
      if (just.eq.'c') then
        i=(i+1)/2
      elseif (just.eq.'l') then
        i=1
      end if
      j=i+fin-sta
C This seems to be quickest
      string(i:j)=string(sta:fin)
      string(1:i-1)=' '
      string(j+1:length)=' '
      return
      end
C end-of-juststr
C
C hash an integer to a two character string 01-99,A-Z,a-z,a-z...
C append to name
C
      subroutine makeind(idx,eos,string)
      integer eos, idx
      character*10 string
      integer d1, d2, i
      character*2 ch

      if (idx.lt.100) then
        write(ch,'(i2.2)') idx
      elseif (idx.lt.776) then
        i=idx-100
        d1=65+i/26
        d2=65+mod(i,26)
        ch(1:1)=char(d1)
        ch(2:2)=char(d2)
      else
        i=idx-776
        d1=i/26
        d2=mod(i,26)
        ch(1:1)=char(97+mod(d1,26))
        ch(2:2)=char(97+mod(d2,26))
      end if

C add sibship number to pedigree name if short enough
      if (eos.lt.8) then
        string(eos+1:eos+1)='_'
        string(eos+2:eos+3)=ch
      else
C check if danger of nonunique new name
        if (string(8:8).eq.'_' .and. eos.eq.10) then
          d1=1
          do 10 i=2,10
            d1=mod(d1*ichar(string(i:i)),1048576)
   10     continue
          write(string,'(i10.10)') d1
        end if
        string(3:3)='_'
        string(1:2)=ch
      end if

      return
      end
C end-of-makeind
C
C write id as justified (l,c,r) string, possibly indicating sex
C as male [101] or female (102)
C
      subroutine wrid(just,id,chid,sx)
      integer sx
      character*8 id
      character*1 just
      character*10 chid
C local variables
      integer i
      character*1 left(2),right(2)
C functions
      integer eow

      data left(1),left(2),right(1),right(2) /'[','(',']',')'/

      chid=' '
      if (sx.eq.1 .or. sx.eq.2) then
        i=eow(id)
        chid(1:1)=left(sx)
        chid(2:i+1)=id
        chid(i+2:i+2)=right(sx)
      else
        chid=id
      end if
      call juststr(just,chid,10)
      return
      end
C end-of-wrid
C
C write out genotype 
C
      subroutine wrgtp(all1,all2,gtp,sep)
      integer MISS,KNOWN
      parameter(MISS=-9999,KNOWN=0)
      integer all1,all2,sep
      character*(*) gtp
      character*3 all

      integer isep, mid

      isep=0
      mid=len(gtp)/2+1
      gtp=' '
      if (all1.eq.MISS) then 
        all='  x'
      elseif (all1.eq.KNOWN) then
        all='  -'
      elseif (all1.lt.KNOWN) then
        isep=2
        write(all,'(i3)') -all1
      else
        write(all,'(i3)') all1
      end if
      gtp(mid-3:mid-1)=all

      if (all2.eq.MISS) then 
        all='x  '
      elseif (all2.eq.KNOWN) then
        all='-  '
      elseif (all2.lt.KNOWN) then
        isep=2
        write(all,'(i3)') -all2
      else
        write(all,'(i3)') all2
      end if
      call juststr('l',all,3)
      gtp(mid+1:mid+3)=all

      if (sep.eq.1) then
        gtp(mid:mid)='/'
      elseif (isep.ne.0) then
        gtp(mid:mid)=':'
      end if

      return
      end
C end-of-wrgtp
C
C write out trait value to a string
C
      subroutine wrtrait(value,str,typ)
      integer typ
      real value
      character*10 str
      if (typ.eq.1 .or. typ.eq.2) then
        call wrgtp(int(value)/1000,mod(int(value),1000),str,1)
      else if (typ.eq.4) then
        str='     y'
        if (value.eq.1.0) str='     n'
      else
        write(str,'(f10.4)') value
      end if
      return
      end
C end-of-wrtrait
C
C binary trait as character
C
      subroutine wraff(value,ch)
      real value
      character*1 ch
      ch='x'
      if (value .eq. 1.0) then
        ch='n'
      elseif (value .eq. 2.0) then
        ch='y'
      end if
      return
      end
C end-of-wraff
C
C write P-values as a histogram: . + * ** ***
C
      subroutine phist(pval1, pval2, histo)
      double precision pval1, pval2
      character*3 histo
      double precision pval

      pval=min(pval1, pval2)
      histo='.  '
      if (pval.lt.0.0001d0) then
        histo='***'
      elseif (pval.lt.0.001d0) then
        histo='**'
      elseif (pval.lt.0.01d0) then
        histo='*'
      elseif (pval.lt.0.1d0) then
        histo='+'
      end if
      return
      end
C end-of-phist
C 
C write a string with leading "x" if starts with an integer
C Loki and R for example do not allow variable names that start with a digit
C
      subroutine addlet(old, new)
      character*(*) old, new
      character*1 ch
      ch=old(1:1)
      if (ichar(ch).ge.48 .and. ichar(ch).le.57) then
        new='x' // old
      else
        new=old
      end if
      return
      end
C end-of-addlet 
C
C concatenate directory to existing filename
C
      subroutine cat(dirnam,filnam)
      character*(*) dirnam, filnam
      integer len1,len2
C functions
      integer eow

      len1=eow(dirnam)
      if (len1.gt.0) then
        call slash(dirnam,len1)
        len2=eow(filnam)
        if ((len1+len2).gt.len(filnam)) then
          write(*,'(a,i3,a/7x,3a/)') 
     2      'ERROR: Path name exceeds ',len(filnam),' characters.',
     3      'File path remains "',filnam(1:len2),'".'
        else      
          filnam(len1+1:len1+len2+1)=filnam(1:len2)
          filnam(1:len1)=dirnam(1:len1)
        end if
      end if
      return
      end 
C end-of-cat
C
C test what character used to separate directories
C
      subroutine slash(dirnam,lend)
      character*(*) dirnam
      integer lend
      integer i
      character*1 sla

      sla='\\'
      do 10 i=1,lend
      if (dirnam(i:i).eq.'/') then
        sla='/'
        goto 11
      end if
   10 continue
   11 continue
      if (dirnam(lend:lend).ne.sla) then
        lend=lend+1
        dirnam(lend:lend)=sla
      end if
      return
      end
C end-of-slash
C
C create workfile name 8.3 prefix '.' suffix
C
      subroutine uniqnam(seed, filnam, suffix)
      integer seed
      character*(*) filnam
      character*3 suffix
      integer i,j
      j=seed
      filnam='sp------'
      if (len(filnam).lt.12) return
      do 10 i=4,8
        filnam(i:i)=char(97+mod(j,26))
        j=j/26
   10 continue
      filnam(9:9)='.'
      filnam(10:12)=suffix
      return
      end
C end-of-uniqnam
C
C create new workfile name
C
      subroutine newnam(wrknum, wrkfil)
      integer wrknum
      character*(*) wrkfil
      integer j
C functions
      integer eow
      wrknum=wrknum+1
      if (wrknum.eq.10) wrknum=1
      j=eow(wrkfil)
      wrkfil(j:j)=char(48+wrknum)
      return
      end
C end-of-newnam
C
C Create a new file (deleting old instances of that name
C
      subroutine mknewfil(str, filnam, wrkdir)
      integer str
      character*(*) filnam, wrkdir
      logical filexist

      call cat(wrkdir,filnam)
      inquire(file=filnam,exist=filexist)
      if (filexist) then
        open(str,file=filnam)
        close(str,status='delete')
      end if
      return
      end
C end-of-mknewfil
C
C Write out program information
C
      subroutine info(burnin,imp,iter,ix,iy,iz,mapf,mincnt,plevel,
     2             showorig,addsex,chek,droperr,prompt,use2,
     3             datdir,version,wrkdir)
      integer HAPSIZ, IBDSIZ, LINSIZ, MAXALL, MAXG, MAXHAP,  
     &        MAXIBD, MAXSIZ, MAXLOC, MISS, WRKSIZ
      parameter(LINSIZ=1024, MAXALL=60, MAXG=MAXALL*(MAXALL+1)/2, 
     2   MAXSIZ=1000, MAXLOC=120, MAXHAP=MAXLOC/2, MISS=-9999, 
     3   MAXCOL=MAXLOC+5, HAPSIZ=MAXSIZ*MAXLOC,WRKSIZ=MAXSIZ*MAXG*2,
     4   MAXIBD=1000, IBDSIZ=MAXIBD*(MAXIBD+1)/2)
      integer burnin, droperr, imp, iter, ix, iy, iz, mapf, 
     &        mincnt, plevel, showorig, use2, wrkspace
      logical addsex, chek, prompt
      character*40 version
      character*40 datdir,wrkdir 
      character*7 map(2)

      data map(1)/'Haldane'/,map(2)/'Kosambi'/

      wrkspace=max(WRKSIZ, HAPSIZ+7*MAXSIZ+10*MAXG+5*MAXALL+3*IBDSIZ)
     &         +MAXSIZ*(MAXLOC+4)
      write(*,'(2a/)') 
     &        'Program version      = ',version
      write(*,'(6(a,i5/))') 
     2        'Maximum record length= ',LINSIZ,
     3        'Maximum pedigree size= ',MAXSIZ,
     4        'Maximum # phenotypes = ',MAXLOC,
     5        'Maximum # alleles    = ',MAXALL,
     6        'Maximum # genotypes  = ',MAXG,
     7        'Maximum # haplotypes = ',MAXHAP
      write(*,'(3(a,i5/))')
     2        'Imputation level     = ',imp,
     3        'Simple Mendel checks = ',chek,
     4        'Drop incon. genotypes= ',droperr
      write(*,'(4(a,i5/),a,3(1x,i5)/)') 
     2        'No. parents for TDT >= ',use2,
     3        'Maximum MC iterations= ',iter,
     4        'Min numerator P-value= ',mincnt,
     5        'Burn-in MC iterations= ',burnin,
     6        'Seeds for RNG (AS183)=',ix,iy,iz
      write(*,'(a,i5,a/)')    
     2        'Main workspace size  = ', wrkspace/256,' kB'
      write(*,'(a,l5/a,l5/a,i5/a,i5/)')    
     2        'Add dummy var for sex= ',addsex,
     3        'Show prompt string   = ',prompt,
     4        'Output detail level  = ',plevel,
     5        'Haplotype detail lvl = ',showorig
      write(*,'(2(2a/))')    
     2        'Data file directory  = ',datdir,
     3        'Work file directory  = ',wrkdir
      write(*,'(2a/)') 
     &        'Map function         = ',map(mapf)
      return
      end
C end-of-info
C
C brief online help
C
      subroutine help(type)
      integer type
C
      if (type.eq.5) then
        write(*,'(a/a//a//a//a)')
     2  'Keywords can be shortened to the first 3 letters.',
     3  'Help prints a brief summary of all commands:',
     4  '  help [all | globals | data | analysis]',
     5  'For full online help:',
     6  '  $ your_favourite_HTML_browser sib-pair.html'
        return
      end if
      if (type.eq.1 .or. type.eq.2) then
        write(*,'(a)') 
     2  '*Globals*','!|# {comment}', '%|$ {shell command}', 
     3  'hel [all|glo|dat|ana] {help}','qui|bye {exit}','cle {reset}',
     4  'inc|loc <fil> {include commands}','lis [mar|tra] {list loci}',
     5  'sho map {show current marker map}',
     6  'inf {program info}','tim {total elapsed time}' 
       write(*,'(a)') 
     2  'set pro [on|off] {display prompt}','set ech [on|off] {echo}',
     3  'set out|ple -1|0|1|2|ver|on|off {output verbosity}',
     4  'set hap 0|1|2|ver|on|off {haplotype detail}',
     5  'set nde [<nwid>] <ndec> {output pedigree decimal digits}',
     6  'set wei fou {weight allele frequencies}' 
       write(*,'(a)') 
     2  'set ite|bur <it> {maximum iters | burn-in iters}',
     3  'set min <num> {required numerator approximate P-values}',
     4  'set see <s1> <s2> <s3> {RNG seeds}', 
     5  'set err [on|off] {remove nuclear family mendelian errors}', 
     6  'set tdt both|one|fir {parents typed for TDT}' 
       write(*,'(a)') 
     2  'set map fun kos|hal {set mapping function}',
     3  'pch <x2> <df> {Chi-square P-value}',
     4  'pro <num> <den> <width> {CI for proportion}',
     5  'sml <pA> <penAA> <penAB> <penBB> {recurrence risks}',
     6  'grr <prev> <pA> <GRR> [<add|dom|rec>] {recurrence risks}' 
        write(*,'(a)') '*Operators/functions*',
     2  '( ) if then else * / + - ^ = not and or < > ge le ne eq',
     3  '>= <= ^= == neg pos abs sqrt log exp sin cos tan asin acos',
     4  ' atan inht int round istyp untyp rand rnorm pi y n',
     5  'female male isfou isnon num nfoun',
     6  'anytyp alltyp numtyp famnum index'
      end if
      if (type.eq.1 .or. type.eq.3) then
        write(*,'(a)') 
     2  '*Data*','set dat|wor <path> {data | work directory}',
     3  'set imp 0|1|2|3|off|on {impute unmeasured genotypes}',
     4  'set loc <nam> mar|xma|qua|aff {declare locus position,type}',
     5  'rea ped <fil>|inline {declare pedigree file}',
     6  'rea lin <fil>|inline {declare pedigree file Linkage type}'  
        write(*,'(a)') 
     2  'rea loc lin <fil> {read Linkage locus position,type,map}',
     3  'set map <pos1>...<posN> {set marker map positions}',
     4  'set dis <dis12> <dis23>...<disN-1N> {set map distances (cM)}' 
        write(*,'(a)') 
     2  'set sex on {add dummy variable}',
     3  'run {read in pedigree data}',
     4  'kee <loc1>.[to]..<locN> [$m|$q|$a] {retain loci in analysis}',
     5  'dro <loc1>.[to]..<locN> [$m|$q|$a] {drop loci from analysis}',
     6  'und [<loc1>.[to]..<locN> [$m|$q|$a]] {return loci to analysis}'
        write(*,'(a)')
     2  'sel [con <npro> whe] <expr> {select pedigrees for analysis}',
     3  'sel ped [not [in]] <ped1>...<pedN> {select on pedigree name}',
     4  'uns {return pedigrees to analysis}',
     5  'pac {delete unselected pedigrees}' 
        write(*,'(a)')
     2  'rec <loc> <val1>...<valN> to <new> {recode old values to new}',
     3  'com <mar1>...<marN> [<thr>] {recode rare alleles}',
     4  'tra <loc> <div> <sub> <pow> <lo> <hi> {power transform}',
     5  'ran <tra> <rank> {rank trait values}',
     6  'kap <tra> <cen> [res] {survivor function estimate}'  
        write(*,'(a)')
     2  'adj <tra> on <loc1> [to <xval>|m|f] {linear regress adjust}' ,
     3  'res <tra> on <loc1>...<locN> [com] {linear regress resid}',
     4  'pre <tra> on <loc1>...<locN> [com] {linear regress predicted}',
     5  'imp <tra> on <loc1>...<locN> [com] {linear regress imputation}'
        write(*,'(a)')
     2  'edi <ped> <per>|all <loc> [to] <val1> [<val2>] {edit data}',
     3  'del <ped> <per>|all {set all data missing for person or}',
     4  'del [<loc1>...<locN>] whe <expr> {set selected data missing}',
     5  'sta <loc> [fam] {standardize trait value}' 
        write(*,'(a)')
     2  'nuc [<maxsibs>] [gra] {convert to (trimmed) nuclear families}',
     3  'sub {divide into subpedigrees (if compound)}', 
     4  'pru <tra> {prune unaffecteds}' ,
     5  'cas <tra> {divide into unrelated cases}' 
        write(*,'(a)')
     2  'pri ped <ped1>...<pedN> [id <id1>...<idN>] {print data}',
     3  'wri {print data}',
     4  'wri <fil> {write gas type ped file}'
        write(*,'(2a)')
     2  'wri arl [par|all]|asp|cri|dot|fis|gas|gda|gh [dum]|lin [dum]',
     3  '|men|mim|ped|phe|sag|tcl <fil> {write ped file}' 
        write(*,'(a/2a)')
     2 'wri pap {write PAP trip.dat and phen.dat}',
     3 'wri loc asp|fis|gas|gh [dum]|lin [dum]|lok|men|mer|sag|tcl',
     4 ' <fil> {write locus file}'  
        write(*,'(a)')
     5 'wri loc sib <fil> [<pedfil>] {write Sib-pair script}',
     5 'wri loc pap {write PAP header.dat and popln.dat}' ,
     6 'wri map men|mer|lok <fil> {write MENDEL or MERLIN map file}' 
      end if
      if (type.eq.1 .or. type.eq.4) then
        write(*,'(a)')
     2  '*Analysis*','gen [<ped>] {summarize pedigree(s)}',
     3  'cou|pri [whe] <expr> {count or print where expression true}',
     4  'hap [<bin tra>] {show sibship haplotypes}',
     5  'anc <tra> [ove|und <thr>] {common ancestor of most probands}',
     6  'fre|des [<loc>] {descriptive statistics}',
     7  'his <qua tra> {histogram and normality test}'  
        write(*,'(a)')
     2  'mea|cor [<loc1>..<locN>] {phenotypic means and correlations}',
     3  'tab <tr1> [<tr2>...<trN>] {contingency table}', 
     4  'kru <qua tra> <loc> {Kruskall-Wallis test}', 
     6  'reg <tra> on <loc1>.[to]..<locN> {linear/logist regression}',
     7  'mix <qua tra> [[<num>] [nor|poo|exp|poi]] {test admixture}' 
       write(*,'(a)')
     2  'hwe [fou] {test HWE}',
     3  'dis <loc1> <loc2> {intragametic association}',
     4  'hom [<tra> [ove|und <thr>]] {marker homozygosity}'  
       write(*,'(a)')
     2  'dav <tra> <pro> {segregation ratios under ascertainment}',
     3  'kin [pai|inb] {kinship/inbreeding coeffs}',
     4  'ib[s|d] <loc> [pai] {relative pair ibs/ibd sharing at marker}',
     5  'cki {sib pair ibs sharing at multiple markers}', 
     6  'sha {rel pair ibs sharing at multiple markers}', 
     7  'ass <tra> [ove|und <thr>] [fou] [gen] {allelic association}' 
       write(*,'(a)')
     2  'tdt <tra> [ove|und <thr>] [pat|mat] {several TDTs}',
     3  'sch <tra> <mar> [<all>] {Schaid & Sommer HWE test}',
     4  'asp <tra> [ove|und <thr>] {affected sib-pair IBS}', 
     5  'apm <tra> [ove|und <thr>] [ibd|ibs] {IBS or IBD APM}' 
       write(*,'(2a/a/a/a)')
     2  'sib <tra> [<wei>] [sim] [cor <r> [mea <m>]',
     3  ' [sd|var <v>]] {S&P QTL linkage}',
     4  'vis <tra> [<wei>] [sim] {V&H H-E regression}',
     5  'he1 <tra> [<wei>] [sim] {Trad H-E regression}',
     6  'he2 <tra> [<wei>] [sim] {Cross-product H-E regression}' 
       write(*,'(a)')
     4  'two <tra> <loc1> <loc2> <theta> {two-point Haseman-Elston}',
     5  'qtl <tra> {Variance components sib-pair linkage}',
     6  'var <tra> {Variance components trait analysis }' 
      end if
C     write(*,*)
      return
      end
C end-of-help
C pass line to shell -- requires existence of fairly 
C                       standard routine system()
C
      subroutine shell(lin)
      character*(*) lin
      integer sta,fin
      external system
      sta=0
    5 continue
        sta=sta+1
      if (lin(sta:sta).ne.'$' .and. lin(sta:sta).ne.'%') goto 5
    7 continue
        sta=sta+1
      if (lin(sta:sta).eq.' ') goto 7
      fin=len(lin)
   10 continue
        fin=fin-1
      if (lin(fin:fin).eq.' ') goto 10
      write(*,'(a/3a/a)') '!','! "',lin(sta:min(fin,75)),'"','!'
      call system(lin(sta:fin))
      return
      end
C end-of-shell
C
C write elapsed time since last asked
C
      subroutine stamp(t0)
      integer elapsed, t0
C functions
#ifdef F2C
      integer time
      elapsed=time()-t0
#else
      real secnds
      elapsed=int(secnds(float(t0)))
#endif F2C
      if (elapsed.lt.120) then
        write(*,'(/a,i5,a)') 
     &    'This job took ',elapsed,' seconds'
      elseif (elapsed.lt.7200) then
        write(*,'(/a,f5.1,a)') 
     &    'This job took ',float(elapsed)/60.0,' minutes'
      else
        write(*,'(/a,f5.1,a)') 
     &    'This job took ',float(elapsed)/3600.0,' hours'
      end if
      return
      end
C end-of-stamp
C
C determine if index person is affected or unaffected
C
      real function isaff(val,thresh,gt)
      integer MISS
      parameter(MISS=-9999)
      real val, thresh
      logical gt

      isaff=val
      if (thresh.ne.MISS .and. isaff.ne.MISS) then
        if ((gt .and. isaff.gt.thresh) .or.
     &     (.not.gt .and. isaff.lt.thresh)) then
          isaff=2.0
        else
          isaff=1.0
        end if
      end if
      return
      end
C end-of-isaff
C
C swap alleles so ordered consistently
C      
      subroutine order(all1,all2)
      integer all1,all2,swp
      if (all1.gt.all2) then
         swp=all1
         all1=all2
         all2=swp
      end if
      return
      end
C end-of-order
C
C swap alleles
C      
      subroutine swap(all1,all2)
      integer all1,all2,swp
      swp=all1
      all1=all2
      all2=swp
      return
      end
C end-of-swap 
C
C determine if word is name of a trait locus
C typ1=10, any locus type
C typ1,typ2=1..5, that locus type only
C
      subroutine gettrait(name,typ1,typ2,nloci,loc,loctyp,trait)
      integer MAXLOC, MISS
      parameter(MAXLOC=120, MISS=-9999)
      character*10 name
      integer nloci, trait, typ1, typ2
      character*10 loc(MAXLOC)
      integer loctyp(MAXLOC)
C functions
      integer eow

      trait=MISS
      if (name.eq.' ') return
      do 5 i=1,nloci
      if (name.eq.loc(i) .and. 
     2    (loctyp(i).eq.typ1 .or. loctyp(i).eq.typ2 .or. typ1.eq.10)) 
     3 then
        trait=i
        return
       end if
    5 continue
      write(*,'(/3a/)') 'NOTE:  Unable to find requested variable "', 
     &                   name(1:eow(name)),'".'
      return  
      end
C end-of-gettrait
C
C Get a single binary trait or dichotomized quantitative trait
C
      subroutine getbin(sta,fin,words,nloci,loc,loctyp,
     &                  trait,gt,thresh)
      integer MAXLOC, MISS
      parameter(MAXLOC=120, MISS=-9999)
      integer fin, nloci, sta, trait
      character*20 words(fin)  
      logical gt
      real thresh
      character*10 loc(MAXLOC)
      integer loctyp(MAXLOC)

      call gettrait(words(sta),3,4,nloci,loc,loctyp,trait)

      gt=.true.
      thresh=MISS
      do 10 i=sta+1, fin-1
        if (words(i)(1:3).eq.'ove') then
          thresh=fval(words(i+1))
        elseif (words(i)(1:3).eq.'und') then
          gt=.false.
          thresh=fval(words(i+1))
        end if  
   10 continue
      if (trait.ne.MISS .and. thresh.eq.MISS .and. 
     &    loctyp(trait).eq.3) then
        trait=MISS
      end if
      return
      end
C end-of-getbin
C
C load list of traits into an array
C
      subroutine loadnam(sta,fin,words,nloci,loc,loctyp,chosen,
     &                   nterms,terms,typ)
      integer MAXLOC
      parameter(MAXLOC=120)

      integer fin, nloci, sta, typ
      integer nterms, terms(*)
      character*20 words(fin)  
      character*10 loc(MAXLOC)
      integer chosen(MAXLOC), loctyp(MAXLOC)
C local variables
      integer i, locnum, offset, pos, span

      do 1 locnum=1, nloci
        chosen(locnum)=0
    1 continue
      nterms=0
C empty list is all loci
      if (sta.gt.fin) then
        if (typ.eq.1) then
          do 5 locnum=1,nloci
          if (loctyp(locnum).le.4) then
            nterms=nterms+1
            chosen(locnum)=nterms
          end if
    5     continue
        else
          do 6 locnum=1,nloci
          if (loctyp(locnum).ge.5) then
            nterms=nterms+1
            chosen(locnum)=nterms
          end if
    6     continue
        end if
      end if

      pos=sta
      i=0
      locnum=1
      offset=0
      if (typ.eq.2) offset=3
   10 continue
      if (pos.gt.fin) goto 40
        if (words(pos)(1:1).eq.'$') then
          if (words(pos)(2:2).eq.'m') then
            i=1
          elseif (words(pos)(2:2).eq.'x') then
            i=2
          elseif (words(pos)(2:2).eq.'q') then
            i=3
          elseif (words(pos)(2:2).eq.'a') then
            i=4
          end if
          i=i+offset
          do 20 locnum=1,nloci
          if (loctyp(locnum).eq.i .and. chosen(locnum).eq.0) then
            nterms=nterms+1
            chosen(locnum)=nterms
          end if
   20     continue
          locnum=1
          pos=pos+1
        else
          span=0
          if (words(pos).eq.'to' .or. words(pos).eq.'--') then
            span=locnum
            pos=pos+1
          end if
          if (pos.le.fin) then
            locnum=isinenv(words(pos)(1:10),nloci,loc)
          else
            locnum=nloci
          end if
          if (locnum.eq.0) then
            write(*,'(2a/)') 'ERROR: Unable to find locus ',words(pos)
          else     
            if (span.eq.0) span=locnum
            call order(span,locnum)
            if (typ.eq.1) then
              do 30 i=span,locnum
              if (loctyp(i).le.4 .and. chosen(i).eq.0) then
                nterms=nterms+1
                chosen(i)=nterms
              end if
   30         continue
            else
              do 31 i=span,locnum
              if (loctyp(i).ge.5 .and. chosen(i).eq.0) then
                nterms=nterms+1
                chosen(i)=nterms
              end if
   31         continue
            end if
          end if
          pos=pos+1
        end if
      goto 10
   40 continue

      do 50 locnum=1,nloci
      if (chosen(locnum).gt.0) then
        terms(chosen(locnum))=locnum
      end if
   50 continue
      return
      end
C end-of-loadnam
C
C List of active loci
C
      subroutine listloci(nloci,loc,loctyp,locpos,typ)
      integer MAXLOC
      parameter (MAXLOC=120)
      integer typ
C
C Locus structure:
C
      integer nloci
      character*10 loc(MAXLOC)
      integer loctyp(MAXLOC),locpos(MAXLOC)
      character*1 typloc(8)

      integer i,eon,nmark,pos
C functions
      integer eow
      double precision bonf

      data typloc/'m','x','q','a','d','d','d','d'/

      if (typ.eq.1) then
        nmark=0
        write(*,'(2(/a10,1x,a4,1x,a8))') 
     2    'Locus     ','Type','Position', 
     3    '----------','----','--------'
        do 5 i=1,nloci
        if (loctyp(i).le.2) then
          nmark=nmark+1
          write(*,'(a10,2x,a1,3x,i3,a2,i3)') 
     &      loc(i),typloc(loctyp(i)),locpos(i)+5,'--',locpos(i)+6
        else
          write(*,'(a10,2x,a1,3x,i3)') 
     &      loc(i),typloc(loctyp(i)),locpos(i)+5
        end if
    5   continue
        write(*,'(/a,i4,3(/a,3x,f8.6)/)') 
     2    'Number of marker loci= ',nmark,
     3    'Bonferroni corr. 5%  = ',bonf(nmark,0.05d0),
     4    'Bonferroni corr. 1%  = ',bonf(nmark,0.01d0),
     5    'Bonferroni corr. 0.1%= ',bonf(nmark,0.001d0)
      elseif (typ.eq.2) then
        pos=0
        do 15 i=1,nloci
          eon=eow(loc(i))
          pos=pos+eon+1
          if (loctyp(i).eq.3 .or. loctyp(i).eq.4) then
            pos=pos+1
            call newlin(78,pos,eon+2)
            write(*,'(2a,$)') loc(i)(1:eon),'* '
          else if (loctyp(i).le.2) then
            call newlin(78,pos,eon+2)
            write(*,'(2a,$)') loc(i)(1:eon),' '
          else
            pos=pos+2
            call newlin(78,pos,eon+2)
            write(*,'(3a,$)') '(',loc(i)(1:eon),') '
          end if
   15   continue
        write(*,*)
      end if
      return
      end
C end-of-listloci
C 
      subroutine newlin(eol,pos,newpos)
      integer eol, newpos, pos
      if (pos.gt.eol) then
        pos=newpos
        write(*,*)
      end if
      return
      end
C end-of-newlin
C
C Count active codominant markers or active loci
C
      subroutine cntmark(nloci,loctyp,nmark,typ)
      integer MAXLOC
      parameter(MAXLOC=120)
      integer nloci, nmark, loctyp(MAXLOC), typ
      integer i

      nmark=0
      if (typ.eq.1) then
        do 10 i=1,nloci
          if (loctyp(i).le.2) nmark=nmark+1
   10   continue
      else
        do 20 i=1,nloci
          if (loctyp(i).le.4) nmark=nmark+1
   20   continue
      end if
      return
      end
C end-of-cntmark
C 
C test if all genotypes missing for this locus at this pedigree
C
      logical function allmiss(gene,num,locus)
      integer MAXSIZ,MAXLOC,MISS
      parameter (MAXSIZ=1000,MAXLOC=120,MISS=-9999)
      integer gene, num
      real locus(MAXSIZ,MAXLOC)
      integer i
      allmiss=.true.
      do 150 i=1,num
      if (locus(i,gene).ne.MISS) then
        allmiss=.false.
        goto 151
      end if
  150 continue
  151 continue
      return
      end
C end-of-allmiss
C 
C test if all genotypes nonmissing for this locus at this pedigree
C
      logical function alltyped(gene,num,locus)
      integer MAXSIZ,MAXLOC,MISS
      parameter (MAXSIZ=1000,MAXLOC=120,MISS=-9999)
      integer gene, num
      real locus(MAXSIZ,MAXLOC)
      integer i
      alltyped=.true.
      do 150 i=1,num
      if (locus(i,gene).eq.MISS) then
        alltyped=.false.
        goto 151
      end if
  150 continue
  151 continue
      return
      end
C end-of-alltyped
C
C Get a line from the stream
      subroutine getlin(strm,narg,words,lin,skipbl)
      integer LINSIZ, MAXLOC, MAXCOL
      parameter (LINSIZ=1024, MAXLOC=120, MAXCOL=MAXLOC+5)
      integer narg, skipbl, strm
C character array to initially read data into
      character*(LINSIZ) lin
      character*20 words(MAXCOL)
   10 continue
        narg=0
        read(strm,'(a)',end=20) lin(1:LINSIZ)
        narg=MAXCOL
        call args(lin,narg,words,1)
      if (skipbl.eq.1 .and. narg.eq.0) goto 10
   20 continue
      return
      end
C end-of-getlin
C
C Read a Linkage locus file
C
      subroutine rdlinloc(strm,lin,words,nloci,loc,
     &                    locpos,loctyp,locord,map,numloc)
      integer LINSIZ, MAXLOC, MAXCOL
      parameter (LINSIZ=1024, MAXLOC=120, MAXCOL=MAXLOC+5)
      integer nloci, numloc, strm
      character*10 loc(MAXLOC)
      integer loctyp(MAXLOC), locpos(MAXLOC)
      real map(MAXLOC)
      integer locord(MAXLOC)
C character array to initially read data into
      character*(LINSIZ) lin
      character*20 words(MAXCOL)
C local variables
      integer nlocl, nmark, ntrait, i, i1, i2, j, lpos, pos, typ, xlink
      logical err, iscm
      real r1, r2
C functions
      integer eow, ival

      err=.false.
      read(strm,*) nlocl, i1, xlink, i2
      if (nlocl.gt.MAXLOC) then
        write(*,'(a/7x,2a,i3,a/)') 
     2    'ERROR: Maximum number of declared loci exceeded.',
     3           'Since locus types not yet read in, ',
     4           'only the first ', MAXLOC/2 ,' loci will be read in.'
        err=.true.
        nlocl=MAXLOC/2
      end if
      read(strm,*) i1, r1, r2, i2
      read(strm,*) (locord(i), i=1, nlocl)
      if (err) then
        call ascend(nlocl, locpos)
        call isort(1, nlocl, locord, locpos, 2)
        call copy(nlocl, locpos, locord)
      end if
      nloci=nlocl
      nmark=0
      ntrait=0
      pos=0
      do 10 i=1, nlocl
        pos=pos+1
        call getlin(strm,narg,words,lin,1)
        typ=ival(words(1))
        lpos=locord(pos)
        if (narg.eq.4) loc(lpos)=words(4)

        if (typ.eq.3) then
          nmark=nmark+1
          if (narg.ne.4) then
            write(loc(lpos),'(a,i3.3)') 'mar', nmark
          end if
          read(strm,*) 
          loctyp(lpos)=1
          if (xlink.eq.1) loctyp(lpos)=2
        elseif (typ.eq.1 .or. typ.eq.0) then
          ntrait=ntrait+1
          if (narg.ne.4) then
            write(loc(lpos),'(a,i3.3)') 'trait', ntrait
          end if
          read(strm,*) 
          if (typ.eq.1) then
            loctyp(lpos)=4
            read(strm,*) i1
C add in liability class as quantitative trait if necessary
            if (i1.gt.1) then
              nloci=nloci+1
              if (nloci.lt.MAXLOC) then
                write(*,'(/3a)') 
     2 'NOTE:  Liability class for "',loc(lpos)(1:eow(loc(lpos))),
     3 '" added as quantitative variable.'
                call insloc(pos,lpos,nloci,loc,loctyp,locpos,map,locord)
                loc(lpos+1)=loc(lpos)(1:min(eow(loc(lpos)), 8)) // '_l'
                loctyp(lpos+1)=3
                pos=pos+1
              end if
            end if
            do 30 j=1, i1
              read(strm,*)
   30       continue
          else
            loctyp(lpos)=3
            do 40 j=1,4
              read(strm,*)
   40       continue
          end if
        end if
   10 continue

      numloc=1
      do 15 i=1, nloci
        locpos(i)=numloc
        numloc=numloc+1
        if (loctyp(i).eq.1 .or. loctyp(i).eq.2) numloc=numloc+1
   15 continue
      numloc=numloc-1
      read(strm,*) i1, i2
      narg=nlocl-1
      call getlin(strm,narg,words,lin,1)
      iscm=.false.
      do 50 i=1, nlocl-1
      if (fval(words(i)).gt.0.5) then
        iscm=.true.
        goto 51
      end if
   50 continue
   51 continue
      dist=0.0
      map(1)=dist
      if (iscm) then
        do 60 i=2, nlocl-1
          map(i)=dist+fval(words(i))
          dist=map(i)
   60   continue
      else
        do 70 i=2, nlocl-1
          map(i)=dist-0.5*log(1.0-fval(words(i)))
          dist=map(i)
   70   continue
      end if
      return
      end
C end-of-rdlinloc
C 
C insert a locus into the locus list
C locord is rewritten such that the inserted locus's locord is locord(pos)+1
C other details of the slot are left blank
C
      subroutine insloc(pos,lpos,nloci,loc,loctyp,locpos,map,locord)
      integer MAXLOC, MAXCOL
      parameter (MAXLOC=120, MAXCOL=MAXLOC+5)
      integer lpos, nloci, pos
      character*10 loc(MAXLOC)
      integer loctyp(MAXLOC), locpos(MAXLOC), locord(MAXLOC)
      real map(MAXLOC)
      integer i

      if (nloci.gt.MAXLOC) then
        write(*,'(a,7x,a,i3,a)') 
     2    'ERROR: Maximum number of declared loci exceeded.' ,
     3    'An additional locus cannot be inserted at ',pos,'.'
        return
      end if
      do 10 i=lpos+1, nloci-1
        loc(i+1)=loc(i)
        loctyp(i+1)=loctyp(i)
        locpos(i+1)=locpos(i)
        map(i+1)=map(i)
   10 continue
      do 15 i=pos+1, nloci-1
        locord(i+1)=locord(i)
   15 continue
      do 20 i=1,nloci 
        if (locord(i).gt.lpos) locord(i)=locord(i)+1
   20 continue
      locord(pos+1)=lpos+1
      return
      end
C end-of-insloc
C
C Find the start of a "where" clause
      integer function findwh(farg, larg, narg, args)
      integer farg, larg, narg
      character*(*) args(narg)
      integer i
      do 10 i=farg, larg  
        if (args(i).eq.'whe' .or. args(i).eq.'where') then
          findwh=i
          return
        end if
   10 continue
      findwh=0
      return
      end
C end-of-findwh
C


