C |||| SIB-PAIR: A program for simple genetic analysis
C |\/| Version : HEAD_TXT
C |/\| Author  : David L Duffy (c) 1995-2003
C ||||
C Program SIB-PAIR imputes missing parental genotypes where unequivocal
C and does TDT,APM, association and sib-pair analyses.
C Data is read from a GAS type datafile.
C
C C-Preprocessor (ifdef) statements are used to select
C platform specific features: the non-F77-standard time, date and
C iand functions.
C
C
      integer INSTRM,CSTRM,OSTR,OSTR2,WRK,WRK2,TWRK
      parameter(INSTRM=3,CSTRM=4,OSTR=7,OSTR2=8,WRK=1,WRK2=2,TWRK=8)
C
C job control indicators:
C cutoff=min cell size to use in TDT, iter=#Monte Carlo iterations,
C burnin=#prelim MCMC iterations, mincnt=min numerator for MC P-value
C fraction, imp=level of imputation missing vals, gene=col of current gene,
C plevel=print level, showorig=detail on haplotyping output,
C trait=col of current trait, wrknum=ver of workfile,
C typ=ibd or ibs for APM etc, parental contrib for TDT,
C twomark=markers for 3-pt, H-E regression, th1, th2, th12 the thetas.
C sibr the full-sib trait correlation for S&P regression
C sibm, sibv the trait mean and variance for S&P regression
C
C addsex=sex as dummy quant trait, assfnd=assoc in founders only,
C chek=check mendelisms, droperr=delete genotypes causing mendelian errors,
C famerr=error in pedigree structure, fndr=freq in founders only, 
C gt=side of threshhold, loconly=including locus information only,
C last=last pedigree, link=Linkage format, prompt=show a prompt,
C red=file read, mche=MC P-val for H-E regression,
C use2=restrict TDT to cases both parents typed, 
C xlin xlinkd=x-linked markers
C
      logical addsex, assfnd, chek, echo, famerr, filexist,
     &   gt, last, link, loconly, prompt, red, mche, xlinkd
      integer burnin, iter, mincnt
      integer cutoff, droperr, fndr, imp, gene, mapf, nwarn,
     &   plevel, prob, showorig, trait, typ, use2, wrknum, xlin
      integer twomark(2)
      real sibm, sibr, sibv, th1, th2, th12, thresh
C
C input stream (ilevel =1 stdin or =2 include file)
C workfile directory and files
C
      integer ilevel
      character*40 version
      character*72 datdir,wrkdir 
      character*144 infil,outfil,pedfil,wrkfil,wrk2fil
C
C Various counts:
C nfam=sibships in pedigree, nobs=total subjects, nped=pedigrees, 
C nships=total sibships, tfound=total founders, inconsist=problems,
C badfam=number of discarded families, badnum=number of discarded records,
C ndiscard=number of discarded genotypes (caused inconsistencies)
C imputd=imputed genotypes, typed=no. typed at marker, ntyped=no. any genotype
C tottyp=total number of genotypes in data
C biggest=size of largest ped, deepest=largest number of generations,
C totgen=accum generations per family, onemem=number of families with 
C only 1 member, onegen=number of families with only 1 generation.
C
      integer nfam,nobs,nped,nships,tfound 
      integer badfam, badnum, inconsist, imputd, ndiscard
      integer biggest,deepest,ntyped,onegen,onemem,totgen,tottyp,typed
C
C Pedigree structure:
C pedigree name; selected; size; no. of founders; individual ids & sexes; 
C pointers to parental ids; 
C trait and genotype values; number of values;
C depth (number of generations)
C
C LINSIZ=input buffer size (chars)
C MAXALL=maximum number of alleles; MAXG=maximum number of genotype
C MAXSIZ=maximum pedigree size; MAXLOC=maximum number of columns used
C by loci (so MAXLOC/2 maximum for codom markers); MISS=missing data
C point placeholder; LOT=all loci; MAXCOL=max columns for id + loci;
C HAPSIZ=haplotype array size, WRKSIZ=phenoset array size,
C MAXIBD=maximum pedigree size for relative-pairwise statistics
C IBDSIZ=maximum array size for relative-pairwise statistics
C MAXTER=maximum number of variables for regression etc
C MAXCOV=maximum size of covariance matrix of variables
C
      integer HAPSIZ, IBDSIZ, LINSIZ, MAXALL, MAXCOL, MAXCOV, MAXG,
     &        MAXHAP,  MAXIBD, MAXLOC, MAXSIZ, MAXTER, 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, MAXIBD=1000, 
     4   IBDSIZ=MAXIBD*(MAXIBD+1)/2, MAXTER=MAXIBD/2,
     5   MAXCOV=MAXTER*(MAXTER+1)/2,  WRKSIZ=MAXSIZ*MAXG*2)
C    6   WRKSIZ=HAPSIZ+7*MAXSIZ+10*MAXG+ 5*MAXALL+ 4*IBDSIZ)
     
      character*10 pedigree
      integer actset,num,nfound 
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ),mo(MAXSIZ),sex(MAXSIZ)
      integer numloc
      real locus(MAXSIZ,MAXLOC)
      integer higen
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
C position of locus on sex-averaged linkage map
C
      real map(MAXLOC)
C
C position of locus in output locus and pedigree files
C may be fewer than nloci loci for output
C
      integer nord, locord(MAXLOC)
C
C Phenoset arrays: possible genotypes for each individual in the pedigree
C
      integer ngeno,gset(MAXSIZ,MAXG,2)
C
C Storage space for haplotypes
C
      integer hset(MAXSIZ,MAXHAP,2)
C work array for quantitative values 
C notably contingency tables (equivalenced to hset)
      real vset(HAPSIZ)
C
C workspace: genotype array or list of parents or linked list...
C
      integer set(MAXSIZ,2)
C
C ibd-genotype
      integer sibd(MAXSIZ,2)
C proposed genotype array
      integer set2(MAXSIZ,2)
C list of founder alleles or sort key
C work arrays for sorting etc (equivalenced)
      integer key(2*MAXSIZ)
      integer key1(MAXSIZ), key2(MAXSIZ)
C work arrays for quantitative traits (equivalenced)
      real value(MAXSIZ)
      real valu1(MAXSIZ), valu2(MAXSIZ)
C indicate if individual typed at locus
      logical untyped(MAXSIZ)
C work arrays for sorting/listing (equivalenced) 
      integer ord(MAXSIZ)
C
C allele and genotype frequencies within entire sample for given locus 
C
      integer numal, name(MAXALL)
      double precision alfrq(MAXALL), cumfrq(MAXALL), gfrq(MAXG)
      integer numal2, name2(MAXALL)
      double precision alfrq2(MAXALL)
C
C Genotype counts: allele1,allele2, number transmitted, number not trans
C Arrays used by association and TDT analyses
C
      integer nallele,cntall(MAXG,4), ngcount,gcount(MAXG,4)
C
C mean ibd (or ibs) sharing for all relative pairs
C
      double precision ibdcount(IBDSIZ)
      double precision count2(IBDSIZ)
C
C Regression parameters and work arrays
C
      double precision x(MAXTER), r(MAXCOV), b(MAXTER), cov(MAXCOV)
C
C recode (combine alleles, adjust quant variables)
C
      integer nf
      real recto, recfro(MAXALL)
      real adjval
C
C Box-cox transformation and/or truncation of variable
C
      real divisor, hival, loval, offset, power
C
C Number of decimal digits and width in output pedigree file:
C All quantitative variables default to 9 characters
C
      integer ndec, nwid
C
C character array to initially read data into
      character*(LINSIZ) lin
      character*20 words(MAXCOL)
      character*80 bigwor(MAXCOL/4)
C
C list for evaluation of expressions (tag1,value1)...(tagNTERM,valueNTERM)
      integer nterm
      integer wtyp(MAXCOL)
      double precision expr(MAXCOL)
C
C keywords not hard coded
C
C Token name, left binding power, right binding power, operation
      integer TOKNUM
      parameter (TOKNUM=44)
      character*6 token(TOKNUM)
      integer lbp(0:TOKNUM), rbp(0:TOKNUM), op(0:TOKNUM)
C
C Environmental (automatic) variables for evaluator
      integer ENVNUM
      parameter (ENVNUM=11)
      character*6 env(ENVNUM)
C
C equivalence to reuse workspace
C Note that the reserved space may be excessive for the data type, in order
C to avoid misalignment (eg character must not force integer to start on
C an odd-byte boundary)
C
C  Array   Dimension         Type   Cumulative space (4 byt) reserved in work()
C  ------- ----------       -----   --------------------------------------------
C     gset MAXSIZ*MAXG*2    I (4)   2*MAXSIZ*MAXG
C 
C     hset MAXSIZ*MAXHAP*2  I (4)   2*MAXSIZ*MAXHAP (=HAPSIZ)
C 
C     vset MAXSIZ*MAXHAP*2  R (4)   2*MAXSIZ*MAXHAP (=HAPSIZ)
C
C     sibd 2*MAXSIZ         I (4)   HAPSIZ+2*MAXSIZ
C     set2 2*MAXSIZ         I (4)   HAPSIZ+4*MAXSIZ
C     key1 MAXSIZ           I (4)   HAPSIZ+5*MAXSIZ
C     key2 MAXSIZ           I (4)   HAPSIZ+6*MAXSIZ
C      key 2*MAXSIZ         I (4)   HAPSIZ+6*MAXSIZ
C    valu1 MAXSIZ           R (4)   HAPSIZ+5*MAXSIZ  
C    valu2 MAXSIZ           R (4)   HAPSIZ+6*MAXSIZ  
C    value MAXSIZ           R (4)   HAPSIZ+6*MAXSIZ  
C  untyped MAXSIZ           L (4)   HAPSIZ+7*MAXSIZ
C      ord MAXSIZ           I (4)   HAPSIZ+7*MAXSIZ  
C   cntall 4*MAXG           I (4)   HAPSIZ+7*MAXSIZ+ 4*MAXG
C   gcount 4*MAXG           I (4)   HAPSIZ+7*MAXSIZ+ 8*MAXG
C   recfro MAXALL           R (4)   HAPSIZ+7*MAXSIZ+ 8*MAXG+ 1*MAXALL
C    name2 MAXALL           I (4)   HAPSIZ+7*MAXSIZ+ 8*MAXG+ 1*MAXALL
C   alfrq2 MAXALL           D (8)   HAPSIZ+7*MAXSIZ+ 8*MAXG+ 3*MAXALL
C   cumfrq MAXALL           D (8)   HAPSIZ+7*MAXSIZ+ 8*MAXG+ 5*MAXALL
C     gfrq MAXG             D (8)   HAPSIZ+7*MAXSIZ+10*MAXG+ 5*MAXALL
C ibdcount IBDSIZ           D (8)   HAPSIZ+7*MAXSIZ+10*MAXG+ 5*MAXALL+ 2*IBDSIZ
C   count2 IBDSIZ           D (8)   HAPSIZ+7*MAXSIZ+10*MAXG+ 5*MAXALL+ 4*IBDSIZ 
C
C        x MAXTER           D (8)   HAPSIZ+7*MAXSIZ+10*MAXG+ 5*MAXALL+ 2*MAXTER
C        r MAXCOV           D (8)   HAPSIZ+7*MAXSIZ+10*MAXG+ 5*MAXALL+ 
C                                   2*MAXTER+2*MAXCOV
C        b MAXTER           D (8)   HAPSIZ+7*MAXSIZ+10*MAXG+ 5*MAXALL+
C                                   2*IBDSIZ+2*MAXTER
C      cov MAXCOV           D (8)   HAPSIZ+7*MAXSIZ+10*MAXG+ 5*MAXALL+
C                                   2*IBDSIZ+2*MAXTER+2*MAXCOV
C
C      lin LINSIZ           C (1)   HAPSIZ+7*MAXSIZ+10*MAXG+ 5*MAXALL+ LINSIZ
C    words 20*MAXCOL        C (1)   HAPSIZ+7*MAXSIZ+10*MAXG+ 5*MAXALL+ 
C                                   20*MAXCOL+ LINSIZ
C   bigwor 20*MAXCOL        C (1)   HAPSIZ+7*MAXSIZ+10*MAXG+ 5*MAXALL+ 
C                                   20*MAXCOL+ LINSIZ
C
      integer work(WRKSIZ)
C
      equivalence (work(1), gset(1,1,1))
      equivalence (work(1), hset(1,1,1))
      equivalence (work(1), vset(1))
C
      equivalence (work(HAPSIZ+1), sibd(1,1))
      equivalence (work(HAPSIZ+1), value(1))
      equivalence (work(HAPSIZ+2*MAXSIZ+1), set2(1,1))
      equivalence (work(HAPSIZ+4*MAXSIZ+1), key(1))
      equivalence (work(HAPSIZ+4*MAXSIZ+1), key1(1))
      equivalence (work(HAPSIZ+5*MAXSIZ+1), key2(1))
      equivalence (work(HAPSIZ+4*MAXSIZ+1), valu1(1))
      equivalence (work(HAPSIZ+5*MAXSIZ+1), valu2(1))
      equivalence (work(HAPSIZ+6*MAXSIZ+1), untyped(1))
      equivalence (work(HAPSIZ+6*MAXSIZ+1), ord(1))
      equivalence (work(HAPSIZ+7*MAXSIZ+1), cntall(1,1))
      equivalence (work(HAPSIZ+7*MAXSIZ+4*MAXG+1), gcount(1,1))
      equivalence (work(HAPSIZ+7*MAXSIZ+8*MAXG+1), recfro(1))
      equivalence (work(HAPSIZ+7*MAXSIZ+8*MAXG+1), name2(1))
      equivalence (work(HAPSIZ+7*MAXSIZ+8*MAXG+1*MAXALL+1), alfrq2(1))
      equivalence (work(HAPSIZ+7*MAXSIZ+8*MAXG+3*MAXALL+1), cumfrq(1))
      equivalence (work(HAPSIZ+7*MAXSIZ+8*MAXG+5*MAXALL+1), gfrq(1))
      equivalence (work(HAPSIZ+7*MAXSIZ+10*MAXG+5*MAXALL+1),ibdcount(1))
      equivalence (work(HAPSIZ+7*MAXSIZ+10*MAXG+5*MAXALL+2*IBDSIZ+1),
     &             count2(1))
C
      equivalence (work(HAPSIZ+7*MAXSIZ+10*MAXG+5*MAXALL+1),x(1))
      equivalence (work(HAPSIZ+7*MAXSIZ+10*MAXG+5*MAXALL+2*MAXTER+1),
     &             r(1))
      equivalence (work(HAPSIZ+7*MAXSIZ+10*MAXG+5*MAXALL+2*IBDSIZ+1),
     &             b(1))
      equivalence (work(HAPSIZ+7*MAXSIZ+10*MAXG+5*MAXALL+2*IBDSIZ+
     &             2*MAXTER+1),cov(1))
C
      equivalence (work(HAPSIZ+7*MAXSIZ+10*MAXG+5*MAXALL+1), lin)
      equivalence (work(HAPSIZ+7*MAXSIZ+10*MAXG+5*MAXALL+LINSIZ+1), 
     &             words(1))
      equivalence (work(HAPSIZ+7*MAXSIZ+10*MAXG+5*MAXALL+LINSIZ+1), 
     &             bigwor(1))
C
C time/random number generator seeds
C
C C library (DJGPP libc, GNU glibc etc):
C   time() -- date and time as sec since 1/1/1970
C   ctime() -- date and time as 24 character string
C   difftime(t0,t1) -- elapsed time
C
C f77 library (libU77):
C   time() -- date and time as sec since 1/1/1970 as integer
C   fdate() -- date and time as 24 character string 
C
      integer ix,iy,iz
      common /rndseed/ ix,iy,iz
C
C "local" counters etc
C
C actn=type of expression (arithmetic, dry run, evaluate),
C eop=length of pedigree name, gen2=position of 2nd allele, 
C length=line length, longnam=highest value of eop, nlin=line of command file, 
C nmark=marker loci found for twopoint() or other procedures
C bigped=name of largest pedigree, deeped=name of the deepest pedigree 
C h2=heritability, weight=variable containing weight for weighted H-E
C istyp=typed at any marker, maxsibs=sibship size to truncate to
C nprob=number of index individuals in pedigree, newloc=added locus,
C newtyp=added locus type, oldnam=check if already used
C nrc=number of lines per record, varlen=length of an outputted variable
C
      integer actn,eop,error,gen2,i,j,k,length,longnam,maxsibs,
     &        newloc,newtyp,nlin,nmark,nrc,varlen,weight
      logical istyp, oldnam
      character*3 keyword, keyw2
      character*8 cmark(2)
      character*10 bigped, deeped
      real candal, dist, tmp
C
C functions
      logical allmiss, alltyped, isreal
      integer eow, findwh, topall
      double precision chip

#ifdef HPUX
      character*8 timestr
      character*9 today
      integer t0

      version=VERSION // ' HPUX'

      t0=int(secnds(0.0))
      call date(today)
      call time(timestr)
      ix=int(30000*ran(t0))
      iy=int(30000*ran(t0))
      iz=int(30000*ran(t0))
 
      write(*,'(a/2a/a/4a/)')
     2  '|||| SIB-PAIR: A program for simple genetic analysis',
     3  '|\\/| Version : ',version,
     4  '|/\\| Author  : David L Duffy (c) 1995-2003',
     5  '|||| Job run : ',today,' at ',timestr
      prompt=.false.

#endif HPUX
#ifdef F2C
      external fdate
      integer time
      character*24 fdate
C stamp and initialize
      integer t0
C
      version=VERSION 

      t0=time()
      ix=mod(t0,29282)
      if (t0.gt.29282) then
        iy=mod(t0/29282,29282)
      else
        iy=mod(419*ix+6173,29282)
      end if
      iz=mod(419*iy+6173,29282)
      write(*,'(a/2a/a/2a/)')
     2  '|||| SIB-PAIR: A program for simple genetic analysis',
     3  '|\\/| Version : ',version,
     4  '|/\\| Author  : David L Duffy (c) 1995-2003',
     5  '|||| Job run : ',fdate()
#ifdef DOS
      prompt=.false.
#else
      prompt=isatty(5)
#endif
#endif F2C
#ifdef DEC
      character*8 tim
      character*9 dat
      integer t0

      version=VERSION // ' DEC'

      t0=int(secnds(0.0))
      call time(tim)
      call date(dat)
      call itime(ix,iy,iz)
      write(*,'(a/2a/a/4a/)')
     2  '|||| SIB-PAIR: A program for simple genetic analysis',
     3  '|\\/| Version : ',version,
     4  '|/\\| Author  : David L Duffy (c) 1995-2003',
     5  '|||| Job run : ',dat,' at ',tim
      prompt=.false.

#endif DEC
#ifdef SUN
      character*24 date
      integer t0
      integer it(3)

      version=VERSION // ' SUN'

      t0=int(secnds(0.0))
      call fdate(date)
      call itime(it)
      ix=it(1)
      iy=it(2)
      iz=it(3)
C
      write(*,'(a/2a/a/2a/)')
     2  '|||| SIB-PAIR: A program for simple genetic analysis',
     3  '|\\/| Version : ',version,
     4  '|/\\| Author  : David L Duffy (c) 1995-2003',
     5  '|||| Job run : ',date
      prompt=.false.

#endif SUN

C
C Initialize list of reserved words
C
C Token name, left binding power, right binding power, operation
C
C Pos Name     LBP  RBP  Op (1=unary postfix; 2=binary, infix; 3=if; 
C --- -------  ---  ---  --  10=zero-arg functions eg rand)
C   0 unbound    0    0   0
C   1 (        200    0   0
C   2 )          0    5   0
C   3 if         0   45   3
C   4 then       5   25   0
C   5 else       5   25   0
C   6 *        120  121   2
C   7 /        120  121   2
C   8 +        100  101   2
C   9 -        100  101   2
C  10 ^        139  138   2
C  11 =          0    0   2
C  12 not       70   70   1
C  13 and       65   66   2
C  14 or        60   61   2
C  15 <         80   80   2
C  16 >         80   80   2
C  17 ge        80   80   2
C  18 le        80   80   2
C  19 ne        80   80   2
C  20 eq        80   80   2
C  21 neg       138 138   1
C  22 pos       138 138   1
C  23 abs       140 140   1
C  24 sqrt      140 140   1
C  25 log       140 140   1
C  26 exp       140 140   1
C  27 sin       140 140   1
C  28 cos       140 140   1
C  29 tan       140 140   1
C  30 asin      140 140   1
C  31 acos      140 140   1
C  32 atan      140 140   1
C  33 inht      140 140   1
C  34 int       140 140   1
C  35 round     140 140   1
C  36 istyp     140 140   1
C  37 untyp     140 140   1
C  38 rand        0   0  10
C  39 rnorm       0   0  10
C  40 pi          0   0  10
C  41 y           0   0  10
C  42 n           0   0  10
C  43 x           0   0  10
C  44 NUM         0   0  10
C
      data token /'(',')','if','then','else','*','/',
     2     '+','-','^','=','not','and','or','<','>',
     3     'ge','le','ne','eq','neg','pos','abs','sqrt','log','exp',
     4     'sin','cos','tan','asin','acos','atan','inht','int','round',
     5     'istyp','untyp','rand','rnorm','pi','y','n','x','NUM'/
      data lbp /0, 200,0,0,5,5,120,120,
     2     100,100,139,0,70,65,60,80,80,
     3     80,80,80,80,138,138,140,140,140,140,
     4     140,140,140,140,140,140,140,140,140,
     5     140,140,0,0,0,0,0,0,0/
      data rbp /0, 0,5,45,25,25,121,121,
     2     101,101,138,0,70,66,61,80,80,
     3     80,80,80,80,138,138,140,140,140,140,
     4     140,140,140,140,140,140,140,140,140,
     5     140,140,0,0,0,0,0,0,0/
      data op /0, 0,0,3,0,0,2,2,
     2     2,2,2,2,1,2,2,2,2, 2,2,2,2,1,1,1,1,1,1,
     4     1,1,1,1,1,1,1,1,1, 1,1,10,10,10,10,10,10,10/
C
C And environmental (automatically defined) variables 
      data env /'female','male','isfou','isnon','num',
     &          'nfoun','anytyp','alltyp','numtyp','famnum','index'/
C
      cmark(1)='marker '
      cmark(2)='xmarker'
      burnin=100
      datdir=' '
      echo=.false.
      ilevel=1
      imp=1
      iter=200
      lin=' '
      mapf=1
      mincnt=20
      ndec=4
      nwid=9
      nlin=0
      plevel=0
      showorig=2
      wrkdir=' '
C Global restart

  999 continue

      pedfil=' '
      outfil=' '
      call uniqnam(t0,wrkfil,'wrk')
      call uniqnam(t0,wrk2fil,'tmp')
      ngeno=0
      nloci=0
      numloc=0
      wrknum=1
      addsex=.false.
      chek=.true.
      droperr=0
      fndr=0
      last=.false.
      link=.false.
      loconly=.false.
      red=.false.
      use2=2
      pedigree=' '
C
C main loop -- reads stdin, parses
C
    1 continue
        if (prompt) write(*,'(/a,$)') '>> '
        i=1
    3   continue
          if (ilevel.eq.1) then
            read(*,'(a)',end=2) lin(i:LINSIZ)
          else
            read(CSTRM,'(a)',end=2) lin(i:LINSIZ)
          end if
          nlin=nlin+1
          i=eow(lin)
        if (i.gt.1 .and. lin(i-1:i).eq.' \\') goto 3

        if (echo .or. plevel.gt.0) then
          write(*,'(/2a/)') '-> ',lin(1:75)
        end if
        narg=MAXCOL
        call args(lin,narg,words,1)
        keyword=words(1)(1:3)
        keyw2=words(2)(1:3)
C
C Locus description
        if (keyword.eq.'set' .and. keyw2.eq.'loc') then
          newloc=numloc+1
          if (words(4)(1:3).eq.'mar' .or. words(4)(1:3).eq.'nam') then
            newtyp=1
            newloc=newloc+1
          elseif (words(4)(1:3).eq.'xma') then
            newtyp=2
            newloc=newloc+1
          elseif (words(4)(1:3).eq.'aff') then
            newtyp=4
          else
            newtyp=3
            if (words(4)(1:3).ne.'qua') then
              write(*,'(3a/7x,a/)') 
     2          'ERROR: Do not recognise locus type ',words(4),'.',
     3               'Treating as quantitative trait.'
            end if
          end if
C Check if enough room and whether previously declared locus name or
C reserved word
          oldnam=.false.
          do 730 i=1, nloci
          if (loc(i).eq.words(3)(1:10)) then
            oldnam=.true.
          end if
  730     continue
          do 740 i=1, toknum
          if (token(i).eq.words(3)) then
            oldnam=.true.
          end if
  740     continue
          if (isreal(words(3))) oldnam=.true.
          if (newloc.gt.MAXLOC) then
            write(*,'(a,i3,a1/7x,3a/)') 
     2        'ERROR: Number of columns of data exceeds maximum ',
     3        MAXLOC,'.','Variable ',words(3)(1:10),' not added.'
          else
            nloci=nloci+1
            loc(nloci)=words(3)(1:10)
            if (oldnam) then
              k=min(10,eow(loc(nloci))+1)
              loc(nloci)(k:k)='_'
              write(*,'(a/7x,3a/)') 
     2        'WARNING: Locus is already declared or a reserved word.',
     3        'Changed name to "',loc(nloci)(1:k),'".'
            end if
            loctyp(nloci)=newtyp
            locpos(nloci)=numloc+1
            if (narg.gt.4) then
              map(nloci)=fval(words(5))
            else
              map(nloci)=MISS
            end if
C If pedigree workfile already exists, create a new variable
            if (red) then
              call newnam(wrknum, wrkfil)
              open(TWRK,file=wrkfil,form='unformatted')
              call addvar(WRK,TWRK,newloc,pedigree,actset,num,nfound,
     &                id,fa,mo,sex,locus,numloc)
              close(WRK,status='delete')
              close(TWRK,status='keep')
              open(WRK,file=wrkfil,form='unformatted')
            end if
            numloc=newloc
          end if
C
C Marker map 
        elseif (keyword.eq.'set' .and. keyw2.eq.'map') then
          if (words(3)(1:3).eq.'fun') then
            if (words(4)(1:3).eq.'kos') then
              write(*,'(/a/)') 'NOTE:  Using Kosambi mapping function.' 
              mapf=2
            else
              write(*,'(/a/)') 'NOTE:  Using Haldane mapping function.' 
              mapf=1
            end if
          else
            j=2
            do 710 i=1,nloci
            if (loctyp(i).le.2) then
              j=j+1
              if (j.le.narg) then
                dist=fval(words(j))
              else
                write(*,'(a/)') 
     &            'NOTE:  Ran out of user specified map positions.'
                dist=dist+100.0
              end if
              map(i)=dist
            end if
  710       continue
          end if
        elseif (keyword.eq.'set' .and. keyw2.eq.'dis') then
          j=1
          do 712 i=1,nloci
          if (loctyp(i).le.2) then
            j=j+1
            if (j.eq.2) then
              dist=0.0
            elseif (j.le.narg) then
              dist=fval(words(j))+dist
            else
              write(*,'(a/)') 
     &          'NOTE:  Ran out of user specified map distances.'
              dist=dist+100.0
            end if
            map(i)=dist
          end if
  712     continue
        elseif (keyword.eq.'sho' .and. keyw2.eq.'map') then
          call wrmap(0,10,mapf,nloci,loc,loctyp,nord,locord,map)
        elseif (keyword.eq.'rea' .and. keyw2.eq.'loc' ) then
          if (words(3)(1:3).eq.'lin') then
            inquire(file=words(4),exist=filexist)
            if (filexist) then
              open(TWRK,file=words(4),status='old')
              call rdlinloc(TWRK,lin,words,nloci,loc,  
     &                      locpos,loctyp,locord,map,numloc)
              close(TWRK)
              write(*,'(/a,i4,a/)') 'Read in names of ', nloci,
     &          ' loci from locus file.'
            else
              write(*,'(3a)') 
     &          'ERROR:  File',words(4)(1:eow(words(4))),' not found.'
            end if

          else
            write(*,'(a)') 'ERROR:  Locus file type not supported'
          end if
C
C Pedigree file to read from
        elseif (keyword.eq.'rea' .and. (keyw2.eq.'ped' 
     &          .or. keyw2.eq.'lin')) then
          call args(lin,narg,bigwor,1)
          link=(bigwor(2)(1:3).eq.'lin') 
          pedfil=bigwor(3)
C
C pedigree data may be inline: transfer data to temporary file
C following lines are pedigree data, and are terminated by a line
C starting  ";;;;".  Require exact keyword match to avoid clashes with files.
C
          if (pedfil.eq.'inl' .or. pedfil.eq.'inline') then
            pedfil='inline.ped' 
            call mknewfil(OSTR, pedfil, wrkdir)
            open(OSTR,file=pedfil)
  350       continue
              if (ilevel.eq.1) then
                read(*,'(a)',end=2) lin(1:LINSIZ)
              else
                read(CSTRM,'(a)',end=2) lin(1:LINSIZ)
              end if
              nlin=nlin+1
            if (lin(1:4).ne.';;;;') then
              write(OSTR,*) lin(1:eow(lin))
              goto 350
            end if
            close(OSTR,status='keep')
C else check if file exists
          else
            call cat(datdir,pedfil)
            inquire(file=pedfil,exist=filexist)
            if (.not.filexist) then
              write(*,'(/3a/7x,3a/)') 
     2          'NOTE:  Pedigree file "',pedfil(1:eow(pedfil)),
     3          '" does not exist.','Trying "',
     4          bigwor(3)(1:eow(bigwor(3))),'".'
              pedfil=bigwor(3)
              inquire(file=pedfil,exist=filexist)
              if (.not.filexist) then
                write(*,'(/3a/)') 
     2            'ERROR: Pedigree file "',pedfil(1:eow(pedfil)),
     3            '" does not exist.'
                pedfil=' '
              end if
            end if
          end if
C set output number of decimal points
        elseif (keyword.eq.'set' .and. keyw2.eq.'nde') then
          if (narg.gt.3) then
            nwid=ival(words(3))
            ndec=ival(words(4))
          else
            ndec=ival(words(3))
          end if
          if (nwid.le.0) then
            nwid=9
          elseif (nwid.gt.20) then
            nwid=20
          end if
          if (ndec.gt.nwid) then
            ndec=nwid
          elseif (ndec.lt.0) then
            ndec=0
          end if
          write(*,'(/a,i2,a,i2/)') 
     &      'NOTE:  Number of decimal digits w.d w=',nwid,' d=',ndec
C set output verbosity
        elseif (keyword.eq.'set' .and. 
     2          (keyw2.eq.'out'.or.keyw2.eq.'ple')) 
     3  then
          if (words(3)(1:3).eq.'ver') then
            plevel=2
          elseif (words(3).eq.'on') then
            plevel=1
          elseif (words(3)(1:3).eq.'off') then
            plevel=0
          else
            plevel=ival(words(3))
          end if
          write(*,'(/a,i2/)') 'NOTE:  Print level ',plevel
C set haplotyping output verbosity
        elseif (keyword.eq.'set' .and. keyw2.eq.'hap') then
          if (words(3)(1:3).eq.'ver') then
            showorig=2
          elseif (words(3).eq.'on') then
            showorig=1
          elseif (words(3)(1:3).eq.'off') then
            showorig=0
          else
            showorig=ival(words(3))
          end if
          write(*,'(/a,i2/)') 'NOTE:  Haplotype print level ', showorig
C set pedigree weighting formula
        elseif (keyword.eq.'set'.and.keyw2.eq.'wei') then
          if (words(3)(1:3).eq.'fou') then
            fndr=1
            write(*,'(/a/7x,a/)') 
     2        'NOTE:  Using pedigree gene frequencies',
     3        'weighted by number of founders in pedigree'
          elseif (words(3)(1:3).eq.'imp') then
            fndr=2
            write(*,'(/a,a/)') 
     2        'NOTE:  Using count of imputed alleles',
     3        ' in founders of pedigree'
          else
            fndr=0
            write(*,'(/a/)') 
     &        'NOTE:  Using unweighted sample gene frequencies'
          end if
C set name of data directory
        elseif (keyword.eq.'set' .and. 
     2          (keyw2.eq.'dir' .or. keyw2.eq.'dat')) 
     3  then
          call args(lin,narg,bigwor,1)
          datdir=bigwor(3)
          inquire(file=datdir,exist=filexist)
          if (.not.filexist) then
            write(*,'(/3a/7x,a/)') 
     2        'NOTE:  Directory "',datdir(1:eow(datdir)),
     3        '" not found.','Using ./ as data directory.'
            datdir=' '
          else
            write(*,'(/3a/)') 
     2        'NOTE:  Directory for pedigree files now "',
     3        datdir(1:eow(datdir)),'".'
          end if
C set name of workfile directory
        elseif (keyword.eq.'set'.and.keyw2.eq.'wor') then
          call args(lin,narg,bigwor,1)
          wrkdir=bigwor(3)
          inquire(file=wrkdir,exist=filexist)
          if (.not.filexist) then
            write(*,'(/3a/7x,a/)') 
     2        'NOTE:  Directory "',wrkdir(1:eow(wrkdir)),
     3        '" not found.','Using ./ as work directory.'
          else
            write(*,'(/3a/)') 
     2        'NOTE:  Directory for temporary files now "',
     3        wrkdir(1:eow(wrkdir)),'".'
            call cat(wrkdir,wrkfil)
            call cat(wrkdir,wrk2fil)
          end if
C add sex to data file as dummy quantitative trait
        elseif (keyword.eq.'set'.and.words(2).eq.'sex'.and..not.red) 
     &  then
          addsex=.true.
          do 300 i=nloci,1,-1
            gen2=i+1
            loc(gen2)=loc(i)
            loctyp(gen2)=loctyp(i)
            locpos(gen2)=locpos(i)+1
  300     continue
          loc(1)='sex'
          loctyp(1)=3
          locpos(1)=1
          nloci=nloci+1
          numloc=numloc+1
        elseif (keyword.eq.'set'.and.keyw2.eq.'ech') then
          echo=.true.
          if (words(3).eq.'off') then
            echo=.false.
          end if
C set initial burn-in iterations for Monte-Carlo Markov Chain routines
        elseif (keyword.eq.'set'.and.keyw2.eq.'bur') then
          burnin=ival(words(3))
          write(*,'(/a,i6/)') 
     &      'NOTE:  Number of MC burn-in iterations ',burnin
        elseif (keyword.eq.'set'.and.keyw2.eq.'ite') then
          iter=ival(words(3))
          write(*,'(/a,i6/)') 
     &      'NOTE:  Number of MC iterations ',iter
        elseif (keyword.eq.'set'.and.keyw2.eq.'min') then
          mincnt=ival(words(3))
          write(*,'(/a,i6/)') 
     &      'NOTE:  Minimum numerator for MC P-values ',mincnt
        elseif (keyword.eq.'set'.and.keyw2.eq.'see') then
          if (narg.gt.2) then
            ix=ival(words(3))
            iy=ival(words(4))
            iz=ival(words(5))
            if (iy.eq.0) iy=ix
            if (iz.eq.0) iz=iy
          end if
          write(*,'(a,3(1x,i5)/)') 'Seeds for RNG (AS183)=',ix,iy,iz
        elseif (keyword.eq.'set'.and.keyw2.eq.'pro') then
          prompt=.true.
          if (words(3).eq.'off') then
            prompt=.false.
          end if
        elseif (keyword.eq.'set'.and.keyw2.eq.'che') then
          if (words(3).eq.'off') then
            chek=.false.
          elseif (words(3).eq.'on') then
            chek=.true.
          end if
        elseif (keyword.eq.'set'.and.keyw2.eq.'err') then
          if (words(3).eq.'off') then
            droperr=0
          elseif (words(3).eq.'on') then
            droperr=2
          else
            droperr=ival(words(3))
          end if
        elseif (keyword.eq.'set'.and.keyw2.eq.'tdt') then
          if (words(3)(1:3).eq.'bot') then
            use2=2
            write(*,'(/2a/)') 
     2        'NOTE:  Index may contribute to TDT only where ',
     3        'both parents typed.'
          elseif (words(3)(1:3).eq.'fir') then
            use2=3
            write(*,'(/2a/)') 
     2        'NOTE:  Only one index case per pedigree used -- ',
     3        'both parents must be typed.'
          else
            use2=1
            write(*,'(/2a/)') 
     2        'NOTE:  Index may contribute to TDT if one or ',
     3        'both parents typed.'
          end if
        elseif (keyword.eq.'set'.and.keyw2.eq.'imp') then
          if (words(3).eq.'off') then
            imp=0
          elseif (words(3).eq.'on') then
            imp=1
          else
            imp=ival(words(3))
          end if
          if (imp.gt.0) chek=.true.
        elseif (keyword.eq.'dro') then
          call loadnam(2,narg,words,nloci,loc,loctyp,locord,nmark,ord,1)
          do 301 i=1,nloci
          if (locord(i).gt.0) then
            loctyp(i)=loctyp(i)+4
          end if
  301     continue
        elseif (keyword.eq.'kee') then
          call loadnam(2,narg,words,nloci,loc,loctyp,locord,nmark,ord,1)
          do 31 i=1,nloci
          if (loctyp(i).le.4) then
            loctyp(i)=loctyp(i)+4  
          end if
   31     continue
          do 302 i=1,nloci
          if (locord(i).gt.0) then
            loctyp(i)=loctyp(i)-4
          end if
  302     continue
        elseif (keyword.eq.'und') then
          call loadnam(2,narg,words,nloci,loc,loctyp,locord,nmark,ord,2)
          do 33 i=1,nloci
          if (loctyp(i).gt.4 .and. locord(i).gt.0) then
            loctyp(i)=loctyp(i)-4
          end if
   33     continue
C
        elseif (keyword.eq.'run') then
          if (imp.eq.0) then
            write(*,'(/2a/8x,a/)') 
     2        'NOTE:  Imputation level 0.  ',
     3        'Not imputing parental genotypes',
     4        'in program step for purposes of TDT etc.'
          elseif (imp.eq.1 .or. imp.eq.4) then
            write(*,'(/a/7x,a/)') 
     2        'NOTE:  Imputation level 1.  Imputing untyped parental',
     3       ' genotypes where unequivocal.'
          elseif (imp.eq.2 .or. imp.eq.5) then
            write(*,'(/a/4(7x,a/))') 
     2        'NOTE:  Imputation level 2.  Imputing untyped parental',
     3        'genotypes where unequivocal.',
     4        'If only the joint parental genotype can be',
     5        'imputed ie {ab} x {cd} .eqv. {cd} x {ab}, then',
     6        'the father is assigned lowest (order) genotype.'
          elseif (imp.eq.3 .or. imp.eq.6) then
            write(*,'(/a/4(7x,a/))') 
     2        'NOTE:  Imputation level 3.  Imputing ALL untyped', 
     3        'genotypes as that conditionally most likely given',
     4        'both the observed genotypes and those imputed up to',
     5        'that point (sequential imputation).'
          end if
          if (plevel.gt.0) then
            call info(burnin,imp,iter,ix,iy,iz,mapf,mincnt,plevel,
     2             showorig,addsex,chek,droperr,prompt,use2,
     3             datdir,version,wrkdir)
          end if
          write(*,'(a,a/a,i5)')    
     2        'Pedigree file        = ',pedfil,
     3        'Number of loci       = ',nloci
          call listloci(nloci,loc,loctyp,locpos,1)
          if (pedfil.eq.' ') then
            write(*,'(/a/7x,a/)') 
     2        'ERROR: Pedigree file not defined yet.',
     3               'Making dummy pedigree file "inline.ped".'
            pedfil='inline.ped' 
            call mknewfil(OSTR, pedfil, wrkdir)
            open(OSTR,file=pedfil)
            do 400 i=1, 10
              write(OSTR,'(i2,1x,i2,100a:)') i,i,(' x',j=1,numloc+3)
  400       continue
            close(OSTR)
          else
            inquire(file=pedfil,exist=filexist)
            if (.not.filexist) then
              write(*,'(/3a/7x,a/)') 
     2          'ERROR: Pedigree file "',pedfil(1:eow(pedfil)),
     3          '" not found.', 'Stopping prematurely.'
              call stamp(t0)
              stop
            end if
          end if
          inquire(file=wrkfil,exist=filexist)
          if (filexist) then
            close(WRK,status='delete')
          end if
          open(INSTRM,file=pedfil,status='OLD')
          open(WRK,file=wrkfil,form='unformatted')
C
C read in pedigree file, accumulate descriptive statistics,
C do preliminary checks (resolving nonmendelisms by deleting
C problem genotypes) and write to workfile
C
          badfam=0
          badnum=0
          inconsist=0
          imputd=0
          longnam=0
          ndiscard=0
          nwarn=0
          nobs=0
          nped=0
          nships=0
          ntyped=0
          tfound=0
          tottyp=0
          bigped=' '
          biggest=0
          deeped=' '
          deepest=0
          totgen=0
          onegen=0
          onemem=0

    5     continue
            famerr=.false.
            open(WRK2,file=wrk2fil,form='unformatted')
            call pedin(INSTRM,WRK,WRK2,addsex,link,pedigree,num, nfound,
     2                 id,fa,mo,sex,locus,ord,key1,key2,set,last,higen,
     3                 numloc,lin,words,nwarn,nfam,famerr,plevel)
            close(WRK2,status='delete')
            eop=eow(pedigree)
C 
C If pedigree error, drop from further analysis
            if (famerr) then
              write(*,'(/4a/)') 
     2          'ERROR:  Too many pedigree errors. ',
     3          'Dropping pedigree ',pedigree(1:eop),'.' 
              badfam=badfam+1
              badnum=badnum+num
C
C else write to work file
            else  
              if (eop.gt.longnam) longnam=eop
              if (higen.eq.1) onegen=onegen+1
              if (num.eq.1) onemem=onemem+1
              if (num.gt.biggest) then
                biggest=num
                bigped=pedigree
              end if
              if (higen.gt.deepest) then
                deepest=higen
                deeped=pedigree
              end if
              nobs=nobs+num
              nped=nped+1
              nships=nships+nfam
              tfound=tfound+nfound
              totgen=totgen+higen
C
C order alleles in genotype, rounding as go
C count total genotyped individuals
C
              do 68 i=1,num
                istyp=.false.
                do 69 j=1,nloci
                  if (loctyp(j).le.2) then 
                    gene=locpos(j)
                    gen2=gene+1
C make males homozygotes if X-linked and second allele set to missing
                    if (loctyp(j).eq.2 .and. sex(i).eq.1 .and.
     2                locus(i,gene).ne.MISS .and. locus(i,gene).ne.0.0
     3                .and. (locus(i,gen2).eq.MISS .or.
     4                       locus(i,gen2).eq.0.0)) then
                      locus(i,gen2)=locus(i,gene)
                    end if

                    if (locus(i,gene).eq.0.0 .or. locus(i,gen2).eq.0.0
     2               .or. locus(i,gene).eq.MISS 
     3               .or. locus(i,gen2).eq.MISS) then
                      locus(i,gene)=MISS
                      locus(i,gen2)=MISS
                    elseif (locus(i,gene).gt.locus(i,gen2)) then
                      istyp=.true.
                      tmp=anint(locus(i,gen2))
                      locus(i,gen2)=anint(locus(i,gene))
                      locus(i,gene)=tmp
                    else
                      istyp=.true.
                      locus(i,gene)=anint(locus(i,gene))
                      locus(i,gen2)=anint(locus(i,gen2))
                    end if
                  else if (loctyp(j).eq.4) then
                    gene=locpos(j)
                    if (locus(i,gene).ne.1.0 .and. 
     &                  locus(i,gene).ne.2.0) then
                      locus(i,gene)=MISS
                    end if
                  end if
   69           continue
                if (istyp) ntyped=ntyped+1
   68         continue
C
              if (plevel.ge.0) then
                write(*,'(a,a10,3(1x,a,i4))') 
     2            'Pedigree: ',pedigree, 'No. members: ',num, 
     3            'No. founders: ',nfound, 'No. sibships: ',nfam
              end if
C
C Do nuclear family level Mendelian checking
C
              if (chek) then
                call check(pedigree,num,nfound,id,fa,mo,sex,locus,
     2                     nloci,loc,loctyp,locpos,set,untyped,
     3                     droperr,ndiscard,inconsist,plevel)
              end if
              actset=1
              call wrkout(WRK,pedigree,actset,num,nfound,id,fa,mo,sex,
     &                    locus,numloc)
            end if
          if (.not.last) goto 5
   10     close(INSTRM)
C
C List number of problems encountered
C
          if (droperr.gt.0) then
            write(*,'(/a/a,i5)')  
     2        'Nuclear family error checking completed.',
     3        'Number discarded genotypes = ',ndiscard 
          end if
          if (inconsist.gt.0) then
            write(*,'(/a/a,i5/a)')  
     2        'Nuclear family error checking completed.',
     3        'Number of data problems    = ',inconsist,
     4        'NOTE:  Stopping prematurely.'
            close(WRK,status='delete')
            call stamp(t0)
            stop
          end if
C
C end of 1st while loop
C now perform imputation if requested
C
          if (imp.ge.0) then

            open(WRK2,file=wrk2fil,form='unformatted')
            do 95 i=1,nloci
            if (loctyp(i).le.2) then
              xlinkd=(loctyp(i).eq.2)
              call freq(WRK,locpos(i),pedigree,actset,num,nfound,id,fa,
     &               mo,sex,locus,numloc,numal,name,fndr,alfrq,typed)
              call wrfreq(WRK2,loc(i),numal,name,alfrq,map(i),
     &                    typed,nobs,3)
              tottyp=tottyp+typed
            end if
   95       continue
            call newnam(wrknum, wrkfil)
            open(TWRK,file=wrkfil,form='unformatted')
            rewind(WRK)
            last=.false.

  100       continue
            call wrkin(WRK,pedigree,actset,num,nfound,id,fa,mo,sex,
     &                 locus, numloc,last)
            if (last) goto 200
              rewind(WRK2)
              do 120 i=1,nloci
              if (loctyp(i).le.2) then
                xlinkd=(loctyp(i).eq.2)
                read(WRK2) numal,(name(j),j=1,numal),
     &            (alfrq(j),j=1,numal)
                if (allmiss(locpos(i),num,locus)) then
                  if (numal.eq.0) name(1)=1
                  if (plevel.gt.0) then
                    write(*,'(/4a/)') 
     2                'NOTE:  All members of pedigree ',
     3                pedigree(1:eow(pedigree)),
     4                ' are untyped at locus ',loc(i)
                  end if
                  call setall(locpos(i),num,locus, -float(name(1)))
                elseif (imp.gt.0) then
                  call exclude(imp,loc(i),xlinkd,locpos(i),pedigree,
     2              num,nfound,id,fa,mo,sex,locus,numal,name,alfrq,set,
     3              ngeno,gset,inconsist,imputd,plevel)
                  if (imp.gt.3) then
                    call accum(numal,alfrq,cumfrq)
                    call start(loc(i),xlinkd,locpos(i),pedigree,num,
     &                         nfound,id,fa,mo,sex,locus,numal,name,
     3                         cumfrq,set,sibd,key,inconsist,plevel)
                  end if
                elseif (imp.eq.0.and..not.alltyped(locpos(i),num,locus))
     &          then
                  call accum(numal,alfrq,cumfrq)
                  call start(loc(i),xlinkd,locpos(i),pedigree,num,
     &                       nfound,id,fa,mo,sex,locus,numal,name,
     3                       cumfrq,set,sibd,key,inconsist,plevel)
                end if
              end if
  120         continue
              call wrkout(TWRK,pedigree,actset,num,nfound,id,fa,mo,sex,
     &                    locus, numloc)
            goto 100
  200       continue
            close(WRK2,status='delete')
            close(WRK,status='delete')
            close(TWRK,status='keep')
            open(WRK,file=wrkfil,form='unformatted')
          end if
C
C Summary statistics on families
C
          write(*,'(4(/a,i5))') 
     2      'Total number of pedigrees  = ',nped,
     3      'Number with only 1 member  = ',onemem,
     4      'Total number of sibships   = ',nships,
     5      'Total number of subjects   = ',nobs 
          write(*,'(a,i5,a,f5.1,a/a,i6)') 
     2      'Total subjects genotyped   = ',ntyped,
     3      ' (',float(100*ntyped)/float(nobs),'%)',
     4      'Total number of genotypes  = ',tottyp/2
          write(*,'(a,i5,3a/a,i5,3a)') 
     2      'Largest pedigree (members) = ',biggest,
     3      ' (Pedigree ',bigped(1:eow(bigped)),')',
     4      'Deepest pedigree (genrtns) = ',deepest,
     5      ' (Pedigree ',deeped(1:eow(deeped)),')' 
          write(*,'(/a,f7.1/a,f7.1)') 
     2      'Mean size of pedigrees     = ',dfloat(nobs)/dfloat(nped),
     3      'Mean pedigree depth        = ',dfloat(totgen)/dfloat(nped) 
          if (nped.gt.onegen) then
            write(*,'(a,f7.1/a,f7.1)') 
     2      'Mean size where >1 members = ',
     3       dfloat(nobs-onemem)/dfloat(nped-onemem),
     4      'Mean depth where >1 geners = ',
     5       dfloat(totgen-onegen)/dfloat(nped-onegen)
          end if
          write(*,'(a,i5//a,i5/a,i5)') 
     2      'Number of imputed genotypes= ',imputd,
     3      'Number of pedigree errors  = ',badfam,
     4      'Number of deleted records  = ',badnum
          if (nwarn.gt.0) then
            write(*,'(/a,i5)')  
     &      'Number of warnings         = ',nwarn
          end if
C
C Abort if persisting problems
C
          if (inconsist.gt.0) then
            write(*,'(/a,i5)') 
     &      'Number of problems         = ',inconsist 
            if (droperr.lt.2) then
              write(*,'(a)') 'NOTE:  Stopping prematurely.'
              close(WRK,status='delete')
              call stamp(t0)
              stop
            end if
          end if
          red=.true.
C If reading only locus information from included file return control
          if (loconly) goto 2
C Break into component nuclear families
        elseif (keyword.eq.'nuc' .and. red) then
          maxsibs=MAXSIZ-2
          typ=1
          do 48 i=2,narg
          if (words(i)(1:3).eq.'gra') then
            typ=2
          else
            maxsibs=ival(words(i))
          end if
   48     continue
          if (maxsibs.lt.0 .or. maxsibs.gt.(MAXSIZ-2)) maxsibs=MAXSIZ-2
          write(*,'(/a,i4,a,i4,a/a)') 
     2      'Dividing ',nped,' pedigrees into ',nships, 
     3      ' nuclear families.', 
     4      'Individuals are duplicated as necessary.'
          if (maxsibs.ne.(MAXSIZ-2)) then
            write(*,'(a,i3,a/)') 
     2        'Sibships with more than ',maxsibs,
     3        ' members are truncated.'
          else
            write(*,*)
          end if
          longnam=min(longnam+3,10)
          call newnam(wrknum, wrkfil)
          open(TWRK,file=wrkfil,form='unformatted')
          call nuclear(WRK,TWRK,pedigree,actset,num,nfound,
     &                 id,fa,mo,sex,locus,numloc,maxsibs,typ)
          close(WRK,status='delete')
          close(TWRK,status='keep')
          open(WRK,file=wrkfil,form='unformatted')
C break into unrelated cases and controls
        elseif (keyword.eq.'cas' .and. red) then
          call gettrait(words(2),10,0,nloci,loc,loctyp,trait)
          if (trait.ne.MISS) then
            write(*,'(/a/3a/)') 
     2         'Extracting unrelated cases from pedigrees.',
     3         'Subjects must be nonmissing for "',
     4         loc(trait)(1:eow(loc(trait))),'".'
            longnam=min(longnam+3,10)
            call newnam(wrknum, wrkfil)
            open(TWRK,file=wrkfil,form='unformatted')
            call wricas(WRK,TWRK,locpos(trait),pedigree,actset,
     &                  num,nfound,id,fa,mo,sex,locus,numloc)
            close(WRK,status='delete')
            close(TWRK,status='keep')
            open(WRK,file=wrkfil,form='unformatted')
          end if
C extract disjoint subpedigrees
        elseif (keyword.eq.'sub' .and. red) then
          longnam=min(longnam+3,10)
          write(*,'(/a/)') 
     &      'Dividing compound pedigrees into component pedigrees.'  
          call newnam(wrknum, wrkfil)
          open(TWRK,file=wrkfil,form='unformatted')
          call disjoin(WRK,TWRK,pedigree,actset,num,nfound,id,fa,mo,sex,
     &                 locus,numloc,ord,set,plevel)
          close(WRK,status='delete')
          close(TWRK,status='keep')
          open(WRK,file=wrkfil,form='unformatted')
C prune pedigree to affecteds plus connectors
        elseif (keyword.eq.'pru' .and. red) then
          call getbin(2,narg,words,nloci,loc,loctyp,trait,gt,thresh)
          if (trait.ne.MISS) then
            call newnam(wrknum, wrkfil)
            open(TWRK,file=wrkfil,form='unformatted')
            call prunep(WRK,TWRK,loc(trait),locpos(trait),gt,thresh,
     2              pedigree,num,nfound,id,fa,mo,sex,locus,numloc,
     3              key,ord,set,plevel)
            close(WRK,status='delete')
            close(TWRK,status='keep')
            open(WRK,file=wrkfil,form='unformatted')
          end if
C edit <pedigree> <person> <trait> to <value1> [<value2>]
        elseif (keyword.eq.'edi' .and. red) then
          call gettrait(words(4),10,0,nloci,loc,loctyp,trait)
          if (trait.ne.MISS) then
            if (loctyp(trait).le.2) then
              all1=fval(words(narg-1))
              all2=fval(words(narg))
            else
              all1=fval(words(narg))
            end if
            call newnam(wrknum, wrkfil)
            open(TWRK,file=wrkfil,form='unformatted')
            call edit(WRK,TWRK,words(2)(1:10),words(3)(1:8),
     2                locpos(trait),loc(trait),
     3                loctyp(trait),all1,all2,
     4                pedigree,actset,num,nfound,
     5                id,fa,mo,sex,locus,numloc)
            close(WRK,status='delete')
            close(TWRK,status='keep')
            open(WRK,file=wrkfil,form='unformatted')
          end if
C delete data for <pedigree> <person> or condition
        elseif (keyword.eq.'del' .and. red) then
          typ=0
          call args(lin,narg,words,2)
          i=findwh(2, narg, narg, words)
          if (i.ne.0) then
            typ=2
            call loadnam(2,i-1,words,nloci,loc,loctyp,
     &                   locord,nmark,ord,1)
          else if (narg.eq.3) then
            typ=1
          end if
          if (typ.ne.0) then
            call newnam(wrknum, wrkfil)
            open(TWRK,file=wrkfil,form='unformatted')
            if (typ.eq.1) then
              call edit(WRK,TWRK,words(2)(1:10),words(3)(1:8),
     2                MISS,'          ',MISS,0.0,0.0,
     3                pedigree,actset,num,nfound,id,fa,mo,sex,
     4                locus,numloc)
            else
              call seldel(WRK,TWRK,nmark,ord,i+1,narg,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)
            end if
            close(WRK,status='delete')
            close(TWRK,status='keep')
            open(WRK,file=wrkfil,form='unformatted')
          end if
C standardize quantitative trait
        elseif (keyword.eq.'sta'.and.red) then
          call gettrait(words(2),3,0,nloci,loc,loctyp,trait)
          if (trait.ne.MISS) then
            typ=1
            if (words(3)(1:3).eq.'fam') then
              typ=2
              write(*,'(/3a)') 'Standardizing "',loc(trait),
     &          '" WITHIN each family to mean=0, variance=1.'
            else
              write(*,'(/3a)') 'Standardizing "',loc(trait),
     &          '" to mean=0, variance=1.'
            end if
            call newnam(wrknum, wrkfil)
            open(TWRK,file=wrkfil,form='unformatted')
            call stand(WRK,TWRK,locpos(trait),pedigree,actset,num,
     &                 nfound,id,fa,mo,sex,locus,numloc,typ)
            close(WRK,status='delete')
            close(TWRK,status='keep')
            open(WRK,file=wrkfil,form='unformatted')
          end if
C K-M survival analysis and nonparametric survivor residuals
        elseif (keyword.eq.'kap'.and.red) then
          call gettrait(words(2),3,0,nloci,loc,loctyp,trait)
          call gettrait(words(3),4,0,nloci,loc,loctyp,prob)
          if (trait.ne.MISS .and. prob.ne.MISS) then
            write(*,'(/a/a,a10,a/a/3a)')
     2       '------------------------------------------------',
     3       'Kaplan-Meier survivor function for "',loc(trait),'"',
     4       '------------------------------------------------', 
     5       '"',loc(prob)(1:eow(loc(prob))), 
     6       '" is outcome (censoring) trait.'
            typ=1
            if (words(4)(1:2).eq.'re') then
              typ=2
              write(*,'(/3a)') 'Replacing value of "',
     2          loc(trait)(1:eow(loc(trait))), 
     3          '" with nonparametric residual.'
              call newnam(wrknum, wrkfil)
              open(TWRK,file=wrkfil,form='unformatted')
              call prodlim(WRK,TWRK,locpos(trait),locpos(prob),
     2               pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     3               numloc,valu1,valu2,set,typ,plevel)
              close(WRK,status='delete')
              close(TWRK,status='keep')
              open(WRK,file=wrkfil,form='unformatted')
            else
              call prodlim(WRK,TWRK,locpos(trait),locpos(prob),
     2               pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     3               numloc,valu1,valu2,set,typ,plevel)
            end if
          end if
C linear regressive adjustment of quantitative trait
        elseif (keyword.eq.'adj'.and.words(3).eq.'on'.and.red) 
     &  then
          call gettrait(words(2),3,0,nloci,loc,loctyp,trait)
          call gettrait(words(4),10,0,nloci,loc,loctyp,gene)
          if (trait.ne.MISS .and. gene.ne.MISS) then
            write(*,'(/5a)') 
     2        'Performing regression adjustment of "',
     3        loc(trait)(1:eow(loc(trait))), '" on "', 
     4        loc(gene)(1:eow(loc(gene))),'"'
            if (words(5).eq.'to' .and. narg.eq.6) then
              if (words(6).eq.'m' .or. words(6).eq.'M') then
                adjval=1.0
                write(*,'(a/)') 'Adjusting to male expectation'
              elseif (words(6).eq.'f' .or. words(6).eq.'F') then
                adjval=0.0
                write(*,'(a/)') 'Adjusting to female expectation'
              else
                adjval=fval(words(6))
                write(*,'(3a,f12.4/)') 
     &            'Adjusting to ',loc(gene),' =',adjval
              end if
            else
              adjval=MISS
              write(*,'(3a/)') 
     &          'Adjusting to ',loc(gene),' = mean value'
            end if
            call newnam(wrknum, wrkfil)
            open(TWRK,file=wrkfil,form='unformatted')
            call adjust(WRK,TWRK,locpos(trait),locpos(gene),adjval,
     2                  pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     3                  numloc,plevel)
            close(WRK,status='delete')
            close(TWRK,status='keep')
            open(WRK,file=wrkfil,form='unformatted')
          end if
C Box-Cox transformation of quantitative trait
        elseif ((keyword.eq.'tra' .or. keyword.eq.'box')
     2          .and. red)  then
          call gettrait(words(2),3,0,nloci,loc,loctyp,trait)
          if (trait.ne.MISS) then
            divisor=fval(words(3))
            offset=fval(words(4))
            power=fval(words(5))
            loval=fval(words(6))
            hival=fval(words(7))
            if (divisor.eq.MISS .or. divisor.eq.0.0) divisor=1.0
            if (offset.eq.MISS) offset=0.0
            if (power.eq.MISS) power=1.0
            write(*,'(/3a/3(/a,f9.4))') 
     2        'Transforming locus "',loc(trait)(1:eow(loc(trait))),
     3        '" via boxcox{(x-m)/d,p}', ' Divisor d= ',divisor,
     5        ' Offset  m= ',offset, ' Power p= ',power 
            if (power.eq.1.0d0) then
              write(*,'(a)') ' boxcox{x}= x' 
            elseif (power.eq.0.0d0) then
              write(*,'(a)') ' boxcox{x}= log(x)' 
            else
              write(*,'(a)') ' boxcox{x}= (x^p-1)/p'
            end if
            if (loval.ne.MISS) then
              write(*,'(a,f9.4)') 
     &          ' Truncating transformed values < ',loval
            end if
            if (hival.ne.MISS) then
              write(*,'(a,f9.4)') 
     &          ' Truncating transformed values > ',hival
            end if
            call newnam(wrknum, wrkfil)
            open(TWRK,file=wrkfil,form='unformatted')
            call boxcox(WRK,TWRK,locpos(trait),offset,divisor,power,
     2                  loval, hival, pedigree,actset,num,nfound,
     3                  id,fa,mo,sex,locus,numloc)
            close(WRK,status='delete')
            close(TWRK,status='keep')
            open(WRK,file=wrkfil,form='unformatted')
          end if
C global recoding of trait values
        elseif(keyword.eq.'rec'.and.words(narg-1).eq.'to'.and.red) 
     &  then
          call gettrait(words(2),10,0,nloci,loc,loctyp,trait)
          recto=fval(words(narg))
          nf=narg-4
          do 49 i=1,nf
            recfro(i)=fval(words(2+i))
   49     continue
          if (trait.ne.MISS) then
            call newnam(wrknum, wrkfil)
            open(TWRK,file=wrkfil,form='unformatted')
            call recode(WRK,TWRK,loc(trait),locpos(trait),loctyp(trait),
     2              recto,nf,recfro,pedigree,actset,num,nfound,
     3              id,fa,mo,sex,locus,numloc)
            close(WRK,status='delete')
            close(TWRK,status='keep')
            open(WRK,file=wrkfil,form='unformatted')
          end if
C combine rare alleles for marker loci
        elseif(keyword.eq.'com'.and.red) then
          thresh=0.05
          if (isreal(words(narg))) then
            thresh=fval(words(narg))
            narg=narg-1
          end if
          call loadnam(2,narg,words,nloci,loc,loctyp,locord,nmark,ord,1)
          do 59 i=1,nmark
            j=ord(i)
            if (loctyp(j).eq.1 .or. loctyp(j).eq.2) then
              write(*,'(3a)') 'Combining rare alleles for ',loc(j),'.'
              call freq(WRK,locpos(j),pedigree,actset,num,nfound,id,fa,
     &                  mo,sex,locus,numloc,numal,name,fndr,alfrq,typed)
              call combine(thresh,recto,nf,recfro,numal,name,alfrq)
              if (nf.gt.1) then
                 call newnam(wrknum, wrkfil)
                 open(TWRK,file=wrkfil,form='unformatted')
                 call recode(WRK,TWRK,loc(j),locpos(j),
     2                   loctyp(j),recto,nf,recfro,pedigree,actset,
     3                   num,nfound,id,fa,mo,sex,locus,numloc)
                 close(WRK,status='delete')
                 close(TWRK,status='keep')
                 open(WRK,file=wrkfil,form='unformatted')
              end if
            end if
   59     continue
        elseif ((keyword.eq.'fac' .or. keyword.eq.'ran').and.red) 
     &  then
          call gettrait(words(2),10,0,nloci,loc,loctyp,gene)
          call gettrait(words(3),3,0,nloci,loc,loctyp,trait)
          if (trait.ne.MISS .and. gene.ne.MISS) then
            if (loctyp(gene).le.2) then
              call freq(WRK,locpos(gene),pedigree,actset,num,nfound,id,
     2                  fa,mo, sex,locus,numloc,numal,name,fndr,
     3                  alfrq,typed)
              write(*,'(/3a,i3,3a)') 
     2          'Coding genotypes at "', loc(gene)(1:eow(loc(gene))),
     3          '" to a number 1...',(numal*(numal+1))/2,' in "',
     4          loc(trait)(1:eow(loc(trait))), '".'  
            else 
              write(*,'(/5a)') 
     2          'Placing ranks at "', loc(gene)(1:eow(loc(gene))),
     3          '" in "', loc(trait)(1:eow(loc(trait))), '".'  
            end if
            call newnam(wrknum, wrkfil)
            open(TWRK,file=wrkfil,form='unformatted')
            if (loctyp(gene).le.2) then
              call factor(WRK,TWRK,locpos(trait),locpos(gene),numal,
     2               name,pedigree,actset,num,nfound,id,fa,mo,sex,
     3               locus,numloc)
            else
              call dorank(WRK,TWRK,locpos(trait),locpos(gene),pedigree,
     &               actset,num,nfound,id,fa,mo,sex,locus,numloc,
     3               value,ord)
            end if
            close(WRK,status='delete')
            close(TWRK,status='keep')
            open(WRK,file=wrkfil,form='unformatted')
          end if
C
C selection of pedigrees on name
C
        elseif (keyword.eq.'sel' .and. red .and.  keyw2.eq.'ped') then
          i=3
          typ=1
          do 66 j=3, 4
            if (words(j).eq.'not') then
              i=i+1
              typ=2
            else if (words(j).eq.'in') then
              i=i+1
            end if
   66     continue
          call newnam(wrknum, wrkfil)
          open(TWRK,file=wrkfil,form='unformatted')
          call selped(WRK,TWRK,typ,i,narg,words, pedigree,actset,num,
     &                nfound, id,fa,mo,sex,locus,numloc,plevel)
          close(WRK,status='delete')
          close(TWRK,status='keep')
          open(WRK,file=wrkfil,form='unformatted')
        elseif (keyword.eq.'pri' .and. red .and. keyw2.eq.'ped') then
          i=narg+2
          do 67 j=3, narg
          if (words(j).eq.'id') then
            i=j+1
          end if
   67     continue
          call showdata(WRK,3,i,narg,words,nloci,loc,loctyp,locpos,
     &            pedigree,actset,num,nfound,id,fa,mo,sex,locus,numloc)
C
C selection of pedigrees on logical expression 
C eg given trait value or pedigree size
C
        elseif (keyword.eq.'sel' .and. red) then
          call args(lin,narg,words,2)
          if ((keyw2.eq.'con' .or. keyw2.eq.'exa') .and.
     &        words(4)(1:3).eq.'whe') then
            typ=4
            nprob=ival(words(3))
            if (nprob.eq.0 .or. keyw2.eq.'exa') typ=typ+1
            i=5
          else
            typ=3
            nprob=1
            i=2
            if (keyw2.eq.'whe') i=i+1
          end if
          call typwords(i,narg,words,nloci,loc,loctyp,token,env,
     &                  wtyp,expr,actn)
          if (actn.eq.0) then
            write(*,'(/a)') 'ERROR: Could not parse condition.'
          else
            call newnam(wrknum, wrkfil)
            open(TWRK,file=wrkfil,form='unformatted')
            call select(WRK,TWRK,typ,nprob,i,narg,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)
            close(WRK,status='delete')
            close(TWRK,status='keep')
            open(WRK,file=wrkfil,form='unformatted')
          end if
        elseif ((keyword.eq.'uns' .or. keyword.eq.'pac').and. red) then
            typ=1
            if (keyword.eq.'pac') typ=2
            call newnam(wrknum, wrkfil)
            open(TWRK,file=wrkfil,form='unformatted')
            call unsel(WRK,TWRK,typ,pedigree,actset,num,nfound,
     &              id,fa,mo,sex,locus,numloc,nobs,plevel)
            close(WRK,status='delete')
            close(TWRK,status='keep')
            open(WRK,file=wrkfil,form='unformatted')
C count pedigrees, sibships on simple expression
        elseif ((keyword.eq.'cou' .or. keyword.eq.'pri') .and. red) then
          typ=1
          if (keyword.eq.'pri') typ=2
          call args(lin,narg,words,2)
          i=2
          if (keyw2.eq.'whe') i=i+1
          call typwords(i,narg,words,nloci,loc,loctyp,token,env,
     &                  wtyp,expr,actn)
          if (actn.eq.0) then
            write(*,'(/a)') 'ERROR: Could not parse condition.'
          else
            call docount(WRK,typ,i,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)
          end if
C recmin haplotypes
        elseif (keyword.eq.'hap' .and. red) then
          call gettrait(words(2),4,0,nloci,loc,loctyp,trait)
          write(*,'(/a/a/a)')
     2    '------------------------------------------------',
     3    'Summary of sibship haplotypes',
     4    '------------------------------------------------' 
          open(WRK2,file=wrk2fil,form='unformatted')
          call dohaplo(WRK,WRK2,trait,iter,nloci,loc,loctyp,locpos,
     2           pedigree,actset,num,nfound,id,fa,mo,sex,locus,numloc,
     3           hset,showorig)
          close(WRK2,status='delete')
C pedigree listing
        elseif (keyword.eq.'gen' .and. red) then
          call gettrait(words(2),3,0,nloci,loc,loctyp,trait)
          write(*,'(/a/a/a)')
     2    '------------------------------------------------',
     3    'Summary of structure of pedigrees',
     4    '------------------------------------------------' 
          if (trait.ne.MISS) then
            write(*,'(3a/)') 
     2        'NOTE:  Writing generation number to ',
     3        loc(trait)(1:eow(loc(trait))),'.'
            trait=locpos(trait)
            call newnam(wrknum, wrkfil)
            open(TWRK,file=wrkfil,form='unformatted')
            call dogen(WRK,TWRK,pedigree,actset,num,nfound,id,fa,mo,sex,
     &                 locus, numloc,ord,set,trait,plevel)
            close(WRK,status='delete')
            close(TWRK,status='keep')
            open(WRK,file=wrkfil,form='unformatted')
          else
            call dogen(WRK,TWRK,pedigree,actset,num,nfound,id,fa,mo,sex,
     &                 locus, numloc,ord,set,trait,plevel)
          end if
C HWE chi-squares
        elseif (keyword.eq.'hwe' .and. red) then
          if (keyw2.eq.'fou') then
            assfnd=.true.
          else
            assfnd=.false.
          end if

          write(*,'(/a/a/a)')
     2    '--------------------------------------------------',
     3    'Hardy-Weinberg equilibrium for all marker loci',
     4    '--------------------------------------------------'
          if (assfnd) then
            write(*,'(a/)') 
     &        'NOTE:  Analysis restricted to founders only.'
          end if
          if (plevel.lt.1) then
            write(*,'(/a/a)')
     2      'Marker     Typed  Genos  Chi-square Asy P  Emp P  Iters',
     3      '---------- ------ ------ ---------- ------ ------ ------'
          end if
          do 219 i=1,nloci
          if (loctyp(i).eq.1) then
            call freq(WRK,locpos(i),pedigree,actset,num,nfound,id,fa,mo,
     &                sex, locus,numloc,numal,name,fndr,alfrq,typed)
            call accum(numal,alfrq,cumfrq)
            open(WRK2,file=wrk2fil,form='unformatted')
            call dohwe(WRK,WRK2,loc(i),locpos(i),iter,mincnt,assfnd,
     2             pedigree,actset,num,nfound,id,fa,mo,sex,locus,numloc,
     3             numal,name,cumfrq,set,untyped,ngcount,gcount,plevel)
            close(WRK2,status='delete')
            if (plevel.gt.0) then
              call domar(WRK,locpos(i),pedigree,actset,num,nfound,id,fa,
     &                   mo,sex, locus,numloc,numal,name,alfrq,plevel)
            end if
          end if
  219     continue
C LD chi-squares
        elseif (keyword.eq.'dis' .and. red) then
          call gettrait(words(2),1,2,nloci,loc,loctyp,trait)
          call gettrait(words(3),1,2,nloci,loc,loctyp,gene)
          write(*,'(/a/a/a/)')
     2      '---------------------------------------------------',
     3      'Inter-marker allelic association analysis',
     4      '---------------------------------------------------' 
          if (plevel.lt.1) then
            write(*,'(a/a)') 
     2      'Marker 1   Marker 2      N mean D''  Chi-sq  df Asy P',
     3      '---------- ---------- ---- -------- ------ --- ------'
          end if

          if (trait.ne.MISS) then
            call freq(WRK,locpos(trait),pedigree,actset,num,nfound,id,
     2                fa,mo, sex,locus,numloc,numal,name,fndr,
     3                alfrq,typed)
            if (gene.ne.MISS .and. loctyp(trait).eq.loctyp(gene)) then
              typ=loctyp(trait)
              call freq(WRK,locpos(gene),pedigree,actset,num,nfound,id,
     2                  fa,mo, sex,locus,numloc,numal2,name2,
     3                  fndr,alfrq2,typed)
              call twold(WRK,typ,locpos(trait),loc(trait),locpos(gene),
     2             loc(gene),iter,pedigree,actset,num,nfound,id,fa,mo,
     3             sex,locus,numloc,numal,name,alfrq,numal2,name2,
     4             alfrq2,untyped,ngcount,gcount,gfrq,plevel)
            else
              do 430 i=1,nloci
              if ((loctyp(i).eq.1 .or. loctyp(i).eq.2) .and.
     &            i.ne.trait .and. loctyp(trait).eq.loctyp(gene)) then
                typ=loctyp(i)
                call freq(WRK,locpos(trait),pedigree,actset,num,nfound,
     2                    id,fa,mo,sex,locus,numloc,numal,name,fndr,
     3                    alfrq,typed)
                call freq(WRK,locpos(i),pedigree,actset,num,nfound,id,
     2                    fa,mo, sex,locus,numloc,numal2,name2,fndr,
     3                    alfrq2,typed)
                call twold(WRK,typ,locpos(trait),loc(trait),locpos(i),
     2             loc(i),iter,pedigree,actset,num,nfound,id,fa,mo,sex,
     3             locus,numloc,numal,name,alfrq,numal2,name2,alfrq2,
     4             untyped,ngcount,gcount,gfrq,plevel)
              end if
 430          continue
            end if
          else
            do 431 i=1,nloci
            if (loctyp(i).eq.1 .or. loctyp(i).eq.2) then
              typ=loctyp(i)
              if (trait.ne.MISS .and. loctyp(trait).eq.typ) then
                call freq(WRK,locpos(trait),pedigree,actset,num,nfound,
     2             id,fa,mo,sex,locus,numloc,numal,name,fndr,alfrq,
     3             typed)
                call freq(WRK,locpos(i),pedigree,actset,num,nfound,id,
     2                    fa,mo, sex,locus,numloc,numal2,name2,fndr,
     3                    alfrq2,typed)
                call twold(WRK,typ,locpos(trait),loc(trait),locpos(i),
     2             loc(i),iter,pedigree,actset,num,nfound,id,fa,mo,sex,
     3             locus,numloc,numal,name,alfrq,numal2,name2,alfrq2,
     4             untyped,ngcount,gcount,gfrq,plevel)
                trait=i
              else
                trait=i
              end if
            end if
 431        continue
          end if
C association analysis (ANOVA or chi-square)
        elseif (keyword.eq.'ass' .and. red) then
          call gettrait(words(2),3,4,nloci,loc,loctyp,trait)
          assfnd=.false.
          gt=.true.
          thresh=MISS
          typ=1
C while not end of list of keywords
          i=3
  441     if (i.gt.narg) goto 442
            keyword=words(i)(1:3)
            if (keyword.eq.'ove') then
              thresh=fval(words(i+1))
              i=i+2
            elseif (keyword.eq.'und') then
              gt=.false.
              thresh=fval(words(i+1))
              i=i+2
            elseif (keyword.eq.'gen') then
              typ=2
              i=i+1
            elseif (keyword.eq.'fou') then
              assfnd=.true.
              i=i+1
            else
              i=i+1
            end if  
            goto 441
  442     continue
          if (trait.ne.MISS) then
            write(*,'(/a/a,a10,a/a)')
     2      '--------------------------------------------------',
     3      'Allelic association testing for trait "',loc(trait),'"',
     4      '--------------------------------------------------'
            if (assfnd) then
              write(*,'(a/)') 
     &          'NOTE:  Analysis restricted to founders only.'
            end if
            if (thresh.ne.MISS) then
              if (gt) then
                write(*,'(a,f9.4/)') 
     &            'NOTE:  Proband defined as trait value > ',thresh
              else
                write(*,'(a,f9.4/)') 
     &            'NOTE:  Proband defined as trait value < ',thresh
              end if
            end if
            if (typ.eq.2) then
              write(*,'(a/)') 
     &          'NOTE:  Genotypic rather than allelic association test.'
            end if
            if (plevel.lt.1) then
              write(*,'(/a/a)')
     2      'Marker     Typed  Allels Chi-square Asy P  Emp P  Iters',
     3      '---------- ------ ------ ---------- ------ ------ ------'
            end if
            do 600 i=1,nloci
            if (loctyp(i).eq.1) then
              call freq(WRK,locpos(i),pedigree,actset,num,nfound,id,fa,
     2                  mo,sex, locus,numloc,numal,name,fndr,
     3                  alfrq,typed)
              call accum(numal,alfrq,cumfrq)
              open(WRK2,file=wrk2fil,form='unformatted')
              if (loctyp(trait).eq.3 .and. thresh.eq.MISS) then
                call doanova(WRK,WRK2,locpos(trait),loc(i),locpos(i),
     2                   iter,mincnt,assfnd,x,r,b,cov,pedigree,actset,
     3                   num,nfound,id,fa,mo,sex,locus,numloc,numal,
     4                   name,cumfrq,untyped,value,key2,set,plevel)
                close(WRK2,status='delete')
                open(WRK2,file=wrk2fil,form='unformatted')
                call qtdt(WRK,WRK2,locpos(trait),loc(i),locpos(i),
     2                iter,mincnt,x,r,b,cov,pedigree,actset,num,nfound,
     3                id,fa,mo,sex,locus,numloc,numal,name,
     4                untyped,value,key2,set,plevel)
              else
                call doassoc(WRK,WRK2,locpos(trait),loc(i),locpos(i),
     2                   iter,mincnt,assfnd,gt,thresh,pedigree,actset,
     3                   num,nfound,id,fa,mo,sex,locus, numloc,numal,
     4                   name,cntall,cumfrq,key1,untyped,set,plevel,typ)
                close(WRK2,status='delete')
                open(WRK2,file=wrk2fil,form='unformatted')
                call rctdt(WRK,WRK2,locpos(trait),loc(i),locpos(i),
     2                   iter,mincnt,gt,thresh,pedigree,actset,
     3                   num,nfound,id,fa,mo,sex,locus,numloc,numal,
     4                   name,cntall,key1,set,alfrq,cumfrq,gfrq,plevel)
              end if
              close(WRK2,status='delete')
            end if
  600       continue
          end if
C homozygosity analysis
        elseif (keyword.eq.'hom' .and. red) then
          call getbin(2,narg,words,nloci,loc,loctyp,trait,gt,thresh)
          if (trait.ne.MISS) then
            write(*,'(/a/a,a10,a/a)')
     2      '--------------------------------------------------',
     3      'Marker homozygosity in cases of trait "',loc(trait),'"',
     4      '--------------------------------------------------'
            if (thresh.ne.MISS) then
              if (gt) then
                write(*,'(a,f9.4/)') 
     &          'NOTE:  Proband defined as trait value > ',thresh
              else
                write(*,'(a,f9.4/)') 
     &          'NOTE:  Proband defined as trait value < ',thresh
              end if
            end if
            trait=locpos(trait)
          else
            write(*,'(/a/a/a)')
     2      '--------------------------------------------------',
     3      'Marker homozygosity in all typed individuals',
     4      '--------------------------------------------------'
          end if
          write(*,'(/a/a)')
     2    'Marker        N    Obs    Exp    Fis     Z  Emp P  Iters',
     3    '---------- ---- ------ ------ ------ ------ ------ ------'
          do 660 i=1,nloci
          if (loctyp(i).eq.1) then
            call freq(WRK,locpos(i),pedigree,actset,num,nfound,id,fa,mo,
     &                sex,
     2                locus,numloc,numal,name,fndr,alfrq,typed)
            call accum(numal,alfrq,cumfrq)
            open(WRK2,file=wrk2fil,form='unformatted')
            call dohomoz(WRK,WRK2,trait,loc(i),locpos(i),
     2                  iter,mincnt,gt,thresh,pedigree,actset,num,
     3                  nfound,id,fa,mo,sex,locus,numloc,numal,alfrq,
     4                  cumfrq,untyped,set,plevel)
            close(WRK2,status='delete')
          end if
  660     continue
C Schaid and Sommer
        elseif (keyword.eq.'sch' .and. red) then
          call gettrait(words(2),4,0,nloci,loc,loctyp,trait)
          call gettrait(words(3),1,0,nloci,loc,loctyp,gene)
          candal=fval(words(4))
          if (trait.ne.MISS .and. gene.ne.MISS) then
            write(*,'(/a/a,a10,a/a)')
     2      '--------------------------------------------------',
     3      'Schaid & Sommer HWE analysis of trait "',loc(trait),'"',
     4      '--------------------------------------------------'
            call freq(WRK,locpos(gene),pedigree,actset,num,nfound,id,fa,
     2                mo,sex,
     3                locus,numloc,numal,name,fndr,alfrq,typed)
            if (candal.le.0.0d0) then
              candal=float(topall(numal,name,alfrq) )
            end if
            write(*,'(a,i3,2a)') 
     &        'Versus allele ',int(candal),' of marker ',loc(gene)
            call nucseg(WRK,locpos(trait),locpos(gene),candal,
     2             x,r,b,cov,pedigree,actset,num,nfound,id,fa,mo,sex,
     3             locus, numloc, key, plevel)
          end if
C TDTs
        elseif (keyword.eq.'tdt'.and.red) then
          call getbin(2,narg,words,nloci,loc,loctyp,trait,gt,thresh)
          cutoff=0
          typ=3
C while not end of list of keywords
          i=3
  318     if (i.gt.narg) goto 319
            keyword=words(i)(1:3)
            if (keyword.eq.'cut') then
              cutoff=ival(words(i+1))
              i=i+2
            elseif (keyword.eq.'mat') then
              typ=1
              i=i+1
            elseif (keyword.eq.'pat') then
              typ=2
              i=i+1
            else
              i=i+1
            end if  
            goto 318
  319     continue
C
          if (trait.ne.MISS) then
            write(*,'(/a/a,a10,a/a/)')
     2      '------------------------------------------------',
     3      'TDT for trait "',loc(trait),'" v. all markers',
     4      '------------------------------------------------'
            if (typ.eq.1) then
                write(*,'(a/)') 'NOTE:  Maternal contributions only.'
            elseif (typ.eq.2) then
                write(*,'(a/)') 'NOTE:  Paternal contributions only.'
            end if
            if (thresh.ne.MISS) then
              if (gt) then
                write(*,'(a,f9.4/)') 
     &            'NOTE:  Proband defined as trait value > ',thresh
              else
                write(*,'(a,f9.4/)') 
     &            'NOTE:  Proband defined as trait value < ',thresh
              end if
            end if
            if (plevel.lt.1) then
              write(*,'(/a/a)')
     2        'Marker     Typed  NParam Chi-square Asy P  Emp P  Iters',
     3        '---------- ------ ------ ---------- ------ ------ ------'
            end if
            do 20 i=1,nloci
            if (loctyp(i).eq.1 .or. loctyp(i).eq.2) then
              call freq(WRK,locpos(i),pedigree,actset,num,nfound,id,fa,
     &                  mo,sex,locus,numloc,numal,name,fndr,alfrq,typed)
              open(WRK2,file=wrk2fil,form='unformatted')
              call dotdt(WRK,WRK2,locpos(trait),loc(i),locpos(i),iter,
     2               mincnt,use2,typ,cutoff,gt,thresh,pedigree,actset,
     3               num,nfound,id,fa,mo,sex,locus,numloc,numal,name,
     4               untyped,set,nallele,cntall,ngcount,gcount,plevel)
              close(WRK2,status='delete')
            end if
   20       continue
          end if
C descriptive statistics for traits
        elseif ((keyword.eq.'fre' .or. keyword.eq.'des')
     2          .and. red)  then
          call loadnam(2,narg,words,nloci,loc,loctyp,locord,nmark,ord,1)
          do 19 i=1,nmark
            j=ord(i)
            if (loctyp(j).eq.1 .or. loctyp(j).eq.2) then
              call freq(WRK,locpos(j),pedigree,actset,num,nfound,id,fa,
     &                  mo,sex,locus,numloc,numal,name,fndr,alfrq,typed)
              call wrfreq(WRK2,loc(j),numal,name,alfrq,map(i),
     &               typed,nobs,1)
            elseif (loctyp(j).eq.3) then
              call famcor(WRK,loc(j),locpos(j),pedigree,actset,num,
     &               nfound,id,fa,mo,sex, locus, numloc,plevel)
            elseif (loctyp(j).eq.4) then
              call segrat(WRK,loc(j),locpos(j),pedigree,actset,num,
     &               nfound,id,fa,mo,sex, locus, numloc)
            end if
   19     continue
C Corrected segregation ratios following Davie 1976
        elseif (keyword.eq.'dav'.and.red) then
          call gettrait(words(2),4,0,nloci,loc,loctyp,trait)
          call gettrait(words(3),4,0,nloci,loc,loctyp,prob)
          if (trait.ne.MISS) then
            if (prob.eq.MISS) prob=trait
            call davie(WRK,loc(trait),locpos(trait),loc(prob),
     2               locpos(prob),pedigree,actset,num,nfound,id,fa,mo,
     3               sex,locus,numloc,plevel)
          end if
C variance components analysis
        elseif (keyword.eq.'var' .and. red) then
          call gettrait(words(2),3,0,nloci,loc,loctyp,trait)
          if (trait.ne.MISS) then
            typ=2
            if (words(3).eq.'ae') typ=1
            open(WRK2,file=wrk2fil,form='unformatted')
            call varcom(WRK,WRK2,loc(trait),locpos(trait),
     2                  pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     3                  numloc,untyped,ibdcount,count2,plevel,typ)
            close(WRK2,status='delete')
          end if
C Test relative pair relatedness using mean IBS sharing 
        elseif (keyword.eq.'sha'.and.red) then
          typ=1
          if (keyw2.eq.'typ') typ=2
          open(WRK2,file=wrk2fil,form='unformatted')
          do 352 i=1,nloci
          if (loctyp(i).eq.1) then
            call freq(WRK,locpos(i),pedigree,actset,num,nfound,id,fa,mo,
     &                sex,locus,numloc,numal,name,fndr,alfrq,typed)
            call accum(numal,alfrq,cumfrq)
            write(WRK2) numal,(cumfrq(j),j=1,numal)
          end if
  352     continue
          call allibs(WRK,WRK2,iter,nloci,loc,loctyp,locpos,
     2           map,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     3           numloc,hset,ibdcount,count2,numal,cumfrq,typ,plevel)
          close(WRK2,status='delete')
C Test sib pair relatedness using mean IBS sharing 
        elseif (keyword.eq.'cki'.and.red) then
          open(WRK2,file=wrk2fil,form='unformatted')
          do 351 i=1,nloci
          if (loctyp(i).eq.1) then
            call freq(WRK,locpos(i),pedigree,actset,num,nfound,id,fa,mo,
     &                sex,locus,numloc,numal,name,fndr,alfrq,typed)
            call wrfreq(WRK2,loc(i),numal,name,alfrq,map(i),
     &                  typed,nobs,3)
          end if
  351     continue
          call ckibs(WRK,WRK2,pedigree,actset,num, nfound, id,fa,mo,sex,
     &               locus,numloc,nloci,loctyp,locpos,numal,name,alfrq)
          close(WRK2,status='delete')
C Test mixture of distributions for quantitative trait
        elseif ((keyword.eq.'mix'.or. keyword.eq.'his').and.red) then
          call gettrait(words(2),3,0,nloci,loc,loctyp,trait)
          if (trait.ne.MISS) then
            nmix=ival(words(3))
            if (keyword.eq.'his') then
              nmix=1
            elseif (nmix.lt.1 .or. nmix.gt.5) then
              nmix=2
            end if
            if (words(4)(1:3).eq.'nor') then
              typ=1
            elseif (words(4)(1:3).eq.'poo') then
              typ=2
            elseif (words(4)(1:3).eq.'exp') then
              typ=3
            elseif (words(4)(1:3).eq.'poi') then
              typ=4
            else
              typ=ival(words(4))
            end if
            if (typ.lt.1 .or. typ.gt.4) typ=1
            call domix(WRK,loc(trait),locpos(trait),nmix,typ,
     2             pedigree,actset,num,nfound,
     3             id,fa,mo,sex,locus,numloc,valu1,ord,plevel)
          end if
C Means and correlations for traits
        elseif ((keyword.eq.'mea' .or. keyword.eq.'cor') .and. red) then
          call loadnam(2,narg,words,nloci,loc,loctyp,locord,nmark,ord,1)
          call docov(WRK,nmark,ord,loc,loctyp,locpos,
     2             x,b,cov,pedigree,actset,num,nfound,id,fa,mo,sex,
     3             locus,numloc,plevel)
C Multiple linear or logistic regression of trait
        elseif ((keyword.eq.'reg' .or. keyword.eq.'imp' .or. 
     2           keyword.eq.'pre' .or. keyword.eq.'res') .and.
     3           narg.gt.3 .and. red) then
          nf=narg
          typ=0
          if (keyword.eq.'res') then
            typ=1
          elseif (keyword.eq.'imp') then
            typ=2
          elseif (keyword.eq.'pre') then
            typ=3
          end if
C any flags at end of line
          if (words(nf).eq.'complete') then
            typ=typ+10
            nf=nf-1
          end if
C first read the x variables
          call loadnam(4,nf,words,nloci,loc,loctyp,locord,nmark,ord,1)
C then read the y variable which is added onto the end of the list
          call gettrait(words(2),3,4,nloci,loc,loctyp,trait)
          if (trait.ne.MISS .and. nmark.gt.0) then
            if (loctyp(trait).eq.4) typ=4
            nmark=nmark+1
            ord(nmark)=trait
            if (typ.eq.0) then
              call regress(WRK,TWRK,typ,nmark,ord,loc,loctyp,locpos,
     2               x,r,b,cov,pedigree,actset,num,nfound,id,fa,mo,sex,
     3               locus,numloc,plevel)
            else if (typ.eq.4) then
              call binreg(WRK,WRK2,TWRK,nmark,ord,loc,loctyp,locpos,
     2               x,r,b,cov,pedigree,actset,num,nfound,id,fa,mo,sex,
     3               locus,numloc,plevel)
            else
              call newnam(wrknum, wrkfil)
              open(TWRK,file=wrkfil,form='unformatted')
              call regress(WRK,TWRK,typ,nmark,ord,loc,loctyp,locpos,
     2               x,r,b,cov,pedigree,actset,num,nfound,id,fa,mo,sex,
     3               locus,numloc,plevel)
              close(WRK,status='delete')
              close(TWRK,status='keep')
              open(WRK,file=wrkfil,form='unformatted')
            end if
          end if
C cross-tabulation
        elseif ((keyword.eq.'tab' .or. keyword.eq.'kru') .and. red) then
          typ=1
          if (keyword.eq.'kru' .and. narg.eq.3) then
            call gettrait(words(2),3,0,nloci,loc,loctyp,trait)
            call gettrait(words(3),10,0,nloci,loc,loctyp,gene)
            if (trait.ne.MISS .and. gene.ne.MISS) then
              typ=2
              nmark=2
              ord(1)=gene 
              ord(2)=trait
              call xtab(WRK,typ,nmark,ord,loc,locpos,loctyp,
     2                  pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     3                  numloc,value,vset,key1,key2,plevel)
            end if
          elseif (narg.gt.1) then
            call loadnam(2,narg,words,nloci,loc,loctyp,locord,
     &                   nmark,ord,1)
            call xtab(WRK,typ,nmark,ord,loc,locpos,loctyp,
     2                pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     3                numloc,value,vset,key1,key2,plevel)
          else
            nmark=1
            write(*,*)
            do 129 i=1,nloci
            if (loctyp(i).lt.5) then
              ord(1)=i 
              call xtab(WRK,typ,nmark,ord,loc,locpos,loctyp,
     2                pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     3                numloc,value,vset,key1,key2,plevel)
            end if
  129       continue
          end if
C APM analyses - IBD or IBS based
        elseif (keyword.eq.'apm'.and.red) then
          call getbin(2,narg,words,nloci,loc,loctyp,trait,gt,thresh)
          if (trait.ne.MISS .and. iter.gt.0) then
            typ=1
            if (words(3).eq.'ibd' .or.words(5).eq.'ibd') typ=2
            write(*,'(/a/a,a10,a/a/)')
     2      '------------------------------------------------',
     3      'APM for trait "',loc(trait),'" v. all markers',
     4      '------------------------------------------------'
            if (typ.eq.2) then
              write(*,'(a/)') 
     &          'NOTE:  Identity-by-descent based statistic used.'
            end if
            if (thresh.ne.MISS) then
              if (gt) then
                write(*,'(a,f9.4/)') 
     &            'NOTE:  Proband defined as trait value > ',thresh
              else
                write(*,'(a,f9.4/)') 
     &            'NOTE:  Proband defined as trait value < ',thresh
              end if
            end if
            if (plevel.lt.1) then
              write(*,'(/a/a)')
     2        'Marker     NFams  NAff   Z-value    Asy P  Emp P  Iters',
     3        '---------- ------ ------ ---------- ------ ------ ------'
            end if
            do 45 i=1,nloci
            if (loctyp(i).eq.1) then
              call freq(WRK,locpos(i),pedigree,actset,num,nfound,id,fa,
     &                  mo,sex,
     &                locus,numloc,numal,name,fndr,alfrq,typed)
              call accum(numal,alfrq,cumfrq)
              call doapm(WRK,locpos(trait),loc(i),locpos(i),typ,iter,
     2               burnin,gt,thresh,pedigree,actset,num,nfound,id,
     3               fa,mo,sex,locus,numloc,numal,name,alfrq,cumfrq,
     4               gfrq,set,set2,sibd,key,untyped,plevel)
            end if
   45       continue
          end if
C ASP analyses
        elseif (keyword.eq.'asp'.and.red) then
          call getbin(2,narg,words,nloci,loc,loctyp,trait,gt,thresh)
          if (trait.ne.MISS) then
            write(*,'(/a/a,a10,a/a/)')
     2      '------------------------------------------------',
     3      'IBS ASP for "',loc(trait),'" v. all marker loci',
     4      '------------------------------------------------'
            if (thresh.ne.MISS) then
              if (gt) then
                write(*,'(a,f9.4/)') 
     &            'NOTE:  Proband defined as trait value > ',thresh
              else
                write(*,'(a,f9.4/)') 
     &            'NOTE:  Proband defined as trait value < ',thresh
              end if
            end if
            if (plevel.lt.1) then
              write(*,'(a/a)')
     2        'Marker     NPairs mIBS   ExpIBS Asy P  mIBD   Asy P',
     3        '---------- ------ ------ ------ ------ ------ ------'
            end if
            do 230 i=1,nloci
            if (loctyp(i).eq.1) then
              call freq(WRK,locpos(i),pedigree,actset,num,nfound,id,fa,
     &                  mo,sex,
     &                  locus,numloc,numal,name,fndr,alfrq,typed)
              call doasp(WRK,locpos(trait),loc(i),locpos(i),gt,thresh,
     2                   pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     3                   numloc,numal,name,alfrq,ibdcount,untyped,set,
     4                   plevel)
            end if
 230        continue
          end if
C H-E sib-pair linkage analysis
        elseif ((keyword.eq.'sib' .or. keyword.eq.'he1' 
     2          .or. keyword.eq.'he2' .or. keyword.eq.'vis') .and. red)
     3  then
          call gettrait(words(2),3,4,nloci,loc,loctyp,trait)
          if (trait.ne.MISS) then
            typ=3
            words(1)='Sham S+D'
            if (keyword.eq.'he1') then
              typ=1
              words(1)='Standard'
            elseif (keyword.eq.'he2') then
              typ=1
              words(1)='CP-based'
            elseif (keyword.eq.'vis') then
              typ=4
              words(1)='V&H S+D '
            end if
            gene=MISS
            sibm=MISS
            sibr=MISS
            sibv=MISS
            weight=MISS
            mche=.false.
            i=3
  433       continue
              if (words(i).eq.'sim') then
                mche=.true.
              elseif (words(i).eq.'var') then
                i=i+1
                sibv=fval(words(i))
              elseif (words(i).eq.'sd') then
                i=i+1
                sibv=fval(words(i))**2
              elseif (words(i).eq.'mea') then
                i=i+1
                sibm=fval(words(i))
              elseif (words(i).eq.'cor') then
                i=i+1
                sibr=fval(words(i))
              else
                call gettrait(words(i),3,0,nloci,loc,loctyp,gene)
                if (gene.ne.MISS) weight=locpos(gene)
              end if
              i=i+1
            if (i.le.narg) goto 433

            write(*,'(/a/a8,a,a10,a/a)')
     2 '---------------------------------------------------------',
     3 words(1),' H-E for trait "',loc(trait),'" v. all markers',
     4 '---------------------------------------------------------'
            if (gene.ne.MISS) then
              write(*,'(3a,2(/7x,a))') 
     2          'NOTE:  Each pair contribution weighted by mean of "',
     3          loc(gene)(1:eow(loc(gene))),'"',
     4          'for each member. Weight is taken as proportional to',
     5          'the variance for that contribution (WLS).'
            end if
            if (sibr.ne.MISS) then
              write(*,'(a,f5.3)') 
     &          'NOTE:  Using trait sibling correlation provided: ',sibr
            end if
            if (sibm.ne.MISS) then
              write(*,'(a,f10.4,a,f10.4,a)') 
     2          'NOTE:  Using trait mean (SD) provided: ',
     3           sibm,' (',sqrt(sibv),')'
            end if
            if (plevel.lt.1) then
              write(*,'(/a/a)')
     2      'Marker     FSibs  HSibs  t-value    Asy P  Emp P  Iters',
     3      '---------- ------ ------ ---------- ------ ------ ------'
            end if
            do 30 i=1,nloci
            if (loctyp(i).eq.1) then
              call freq(WRK,locpos(i),pedigree,actset,num,nfound,id,fa,
     &                  mo,sex,
     &                  locus,numloc,numal,name,fndr,alfrq,typed)
              call accum(numal,alfrq,cumfrq)
              open(WRK2,file=wrk2fil,form='unformatted')
              call sibpair(WRK,WRK2,loc(trait),locpos(trait),
     2               loc(i),locpos(i),typ,sibm,sibr,sibv,
     3               mche,iter,mincnt,weight,pedigree,actset,num,nfound,
     4               id,fa,mo,sex,locus,numloc,numal,name,alfrq,cumfrq,
     5               ibdcount,untyped,set,plevel)
              close(WRK2,status='delete')
            end if
  30        continue
          end if
C VC QTL linkage analysis
        elseif (keyword.eq.'qtl'.and.red) then
          call gettrait(words(2),3,4,nloci,loc,loctyp,trait)
          if (trait.ne.MISS) then
            write(*,'(/a/a,a10,a/a)')
     2 '---------------------------------------------------------',
     3 'VC linkage analysis for trait "',loc(trait),'" v. all markers',
     4 '---------------------------------------------------------'
            if (plevel.lt.1) then
              write(*,'(/a/a)')
     2      'Marker     FSibs  HSibs  lod score  Asy P  Emp P  Iters',
     3      '---------- ------ ------ ---------- ------ ------ ------'
            end if
            do 130 i=1,nloci
            if (loctyp(i).eq.1) then
              call freq(WRK,locpos(i),pedigree,actset,num,nfound,id,fa,
     &                  mo,
     &                  sex,locus,numloc,numal,name,fndr,alfrq,typed)
              open(WRK2,file=wrk2fil,form='unformatted')
              call sibqtl(WRK,WRK2,loc(trait),locpos(trait),
     2               loc(i),locpos(i),pedigree,actset,num,nfound,
     3               id,fa,mo,sex,locus,numloc,numal,name,alfrq, 
     4               untyped,set,ibdcount,count2,plevel)
              close(WRK2,status='delete')
            end if
 130        continue
          end if
C sib-pair linkage between markers after Elston
        elseif (keyword.eq.'lin'.and.red) then
          write(*,'(/a/a/a//a/a)')
     2 '---------------------------------------------------',
     3 'Inter-marker sib pair linkage analysis',
     4 '---------------------------------------------------',
     5 'Marker 1   Marker 2   Sibships Sibpairs  r(IBD) Recomb',
     6 '---------- ---------- -------- --------  ------ -------'
          call gettrait(words(2),1,0,nloci,loc,loctyp,trait)
          call gettrait(words(3),1,0,nloci,loc,loctyp,gene)
          if (trait.ne.MISS) then
            call freq(WRK,locpos(trait),pedigree,actset,num,nfound,
     2             id,fa,mo,sex,locus,numloc,numal,name,fndr,alfrq,
     3             typed)
            if (gene.ne.MISS) then
              call freq(WRK,locpos(gene),pedigree,actset,num,nfound,
     2             id,fa,mo,sex,locus,numloc,numal2,name2,fndr,alfrq2,
     3             typed)
              call twopoi(WRK,locpos(trait),loc(trait),numal,name,alfrq,
     2           locpos(gene), loc(gene), numal2, name2, alfrq2,
     3           pedigree,actset,num,nfound, id, fa, mo, sex, locus,
     4           numloc, ibdcount,count2,untyped,set,set2,plevel)
            else
              do 330 i=1,nloci
              if (loctyp(i).eq.1 .and. i.ne.trait) then
                call freq(WRK,locpos(i),pedigree,actset,num,nfound,id,
     2                 fa,mo,
     3                 sex,locus,numloc,numal2,name2,fndr,alfrq2,typed)
                call twopoi(WRK,locpos(trait),loc(trait),numal,name,
     2                 alfrq,locpos(i), loc(i), numal2, name2, alfrq2,
     3                 pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     4                 numloc, ibdcount,count2,untyped,set,set2,plevel)
              end if
 330          continue
            end if
          else
            do 331 i=1,nloci
            if (loctyp(i).eq.1) then
              if (trait.ne.MISS) then
                call freq(WRK,locpos(trait),pedigree,actset,num,nfound,
     2             id,fa,mo,sex,locus,numloc,numal,name,fndr,alfrq,
     3             typed)
                call freq(WRK,locpos(i),pedigree,actset,num,nfound,id,
     &                    fa,mo,
     &               sex,locus,numloc,numal2,name2,fndr,alfrq2,typed)
                call twopoi(WRK,locpos(trait),loc(trait),numal,name,
     2               alfrq,locpos(i), loc(i), numal2, name2, alfrq2,
     3               pedigree,actset,num,nfound, id, fa, mo, sex, locus,
     4               numloc, ibdcount,count2,untyped,set,set2,plevel)
                trait=i
              else
                trait=i
              end if
            end if
 331        continue
          end if
C Interval H-E
        elseif (keyword.eq.'two'.and.red) then
          trait=MISS
          nmark=0
          do 27 i=1,nloci
          do 27 j=2,narg
          if (words(j).eq.loc(i)) then
             if (loctyp(i).eq.3 .or. loctyp(i).eq.4) then
               trait=i
             elseif (loctyp(i).eq.1 .and. nmark.lt.2) then
               nmark=nmark+1
               twomark(nmark)=i
             end if
          end if
          th12=fval(words(5))
   27     continue
          write(*,'(/a/a,a10,a,a10,a,a10,a/a/)')
     2   '------------------------------------------------------------',
     3   '2-point trait "',loc(trait),'" v. loci "',loc(twomark(1)),
     4   '", "',loc(twomark(2)),'"',
     5   '------------------------------------------------------------'
          write(*,'(3a)') 'Theta12 Theta1 Theta2   N     Pi',
     2                    '      Intcpt      Slope      t-value',
     3                    '  P-value'
          call freq(WRK,locpos(twomark(1)),pedigree,actset,num,nfound,
     2              id,fa,mo,sex,locus,numloc,numal,name,fndr,alfrq,
     3              typed)
          call freq(WRK,locpos(twomark(2)),pedigree,actset,num,nfound,
     2              id,fa,mo,sex,locus,numloc,numal2,name2,fndr,alfrq2,
     3              typed)
C
C No interference 
          do 35 i=0,5
            th1=0.2*th12*float(i)
            th2=th12-th1+2.0*th1*th12
            call twopair(WRK,locpos(trait),locpos(twomark(1)),
     2                   locpos(twomark(2)),th1, th2, th12,
     3                   pedigree,actset,num,nfound,id,fa,mo,sex,locus, 
     4                   numloc, numal,name,alfrq,numal2,name2,alfrq2)
   35     continue
C
C List individuals and matings with largest number of affected 
C descendants for each pedigree
C
        elseif (keyword.eq.'anc'.and.red) then
          call getbin(2,narg,words,nloci,loc,loctyp,trait,gt,thresh)
          if (trait.ne.MISS) then
            call ancest(WRK,loc(trait),locpos(trait),gt,thresh,pedigree,
     2             actset,num,nfound,id,fa,mo,sex,locus,numloc,ord,
     3             plevel)
          end if 
C kinship and inbreeding coefficients
        elseif (keyword.eq.'kin'.and.red) then
          typ=1
          if (keyw2.eq.'pai') typ=2
          if (keyw2.eq.'inb') typ=3
          call dokin(WRK,typ,pedigree,actset,num,nfound,id,fa,mo,sex,
     &               locus,numloc,ibdcount)
C IBD matrices
        elseif ((keyword.eq.'ibd'.or.keyword.eq.'ibs').and.red) then
          call gettrait(words(2),1,0,nloci,loc,loctyp,gene)
          typ=1
          if (keyword.eq.'ibs') typ=typ+2
          if (words(3)(1:3).eq.'pai') typ=typ+1
          if (gene.ne.MISS .and. iter.gt.0) then
            write(*,'(/a/3a,a10,a/a)')
     2       '------------------------------------------------',
     3       'Estimated ',keyword,' sharing at locus "',loc(gene),'"',
     4       '------------------------------------------------' 
            if (mod(typ,2).eq.0) then
              write(*,'(a//a/)') 
     2          'NOTE:  Writing one relative pair per record',
     3          'Pedigree   Person-1 Person-2   ibd'
            end if
            call freq(WRK,locpos(gene),pedigree,actset,num,nfound,id,fa,
     &                mo,sex, locus,numloc,numal,name,fndr,alfrq,typed)
            call wribd(WRK,locpos(gene),iter,burnin,typ,
     2                 pedigree,actset,num,nfound,id,fa,mo,sex,locus, 
     3                 numloc,numal,name,alfrq,gfrq,untyped,
     4                 set,set2,sibd,key,ibdcount,plevel)
          end if
C
C write out locus file
        elseif (keyword.eq.'wri'.and. keyw2.eq.'loc') then
          if (words(3).eq.'gas') then
            outfil=words(4)
            open(OSTR,file=outfil)
            write(*,'(/2a)') 
     &        'Writing GAS type locus file: ',outfil
            do 60 i=1,nloci
            if (loctyp(i).eq.1) then
              call freq(WRK,locpos(i),pedigree,actset,num,nfound,id,
     &                  fa,mo,
     &                  sex,locus,numloc,numal,name,fndr,alfrq,typed)
              write(OSTR,'(1x,3a)') 'set locus ',loc(i),' named'
              call wrfreq(OSTR,loc(i),numal,name,alfrq,map(i),
     &                    typed,nobs,4)
              write(OSTR,'(a2)') ' ;'
            else if (loctyp(i).eq.3) then
              write(OSTR,'(1x,3a/1x,a/1x,a)') 
     2          'set locus ',loc(i),' quantitative',
     3          '2 eqfreq', 'nostat ;'
            else if (loctyp(i).eq.4) then
              write(OSTR,'(1x,3a/1x,a/1x,a/1x,a)') 
     2          'set locus ',loc(i),' affection',
     3          '2 eqfreq','1', '0.1 0.1 0.1 ;'
            end if
   60       continue
          elseif (words(3)(1:3).eq.'sib') then
            outfil=words(4)
            if (narg.eq.4) words(5)=pedfil
            open(OSTR,file=outfil)
            write(*,'(/2a)') 
     &        'Writing Sib-pair type script: ',outfil
            do 61 i=1,nloci
            if (loctyp(i).le.2) then
              if (map(i).ne.MISS) then
                write(OSTR,'(3(a,1x),f8.2)') 
     &            'set locus',loc(i),cmark(loctyp(i)), map(i)
              else
                write(OSTR,'(3(a,1x))') 
     &            'set locus ',loc(i),cmark(loctyp(i))
              end if
            else if (loctyp(i).eq.3) then
              write(OSTR,'(3a)') 'set locus ',loc(i),' quantitative' 
            else if (loctyp(i).eq.4) then
              write(OSTR,'(3a)') 'set locus ',loc(i),' affection' 
            end if
   61       continue
            write(OSTR,'(2a/a)') 'read pedigree ',words(5),'run'
          elseif (words(3)(1:3).eq.'mer') then
            outfil=words(4)
            open(OSTR,file=outfil)
            write(*,'(/2a)') 
     &        'Writing MERLIN locus file: ',outfil
            do 62 i=1,nloci
            if (loctyp(i).le.2) then
              write(OSTR,'(2a)') 'M ',loc(i)
            else if (loctyp(i).eq.3) then
              write(OSTR,'(2a)') 'T ',loc(i)
            else if (loctyp(i).eq.4) then
              write(OSTR,'(2a)') 'A ',loc(i)
            end if
   62       continue
          elseif (words(3)(1:3).eq.'lin' .or. words(3)(1:2).eq.'gh') 
     &    then
            outfil=words(4)
            typ=0
            if (words(5)(1:3).eq.'dum') then
              typ=1
            end if
            if (words(3)(1:2).eq.'gh') then
              typ=3-typ
            elseif (words(5)(1:2).eq.'gh') then
              typ=2
              if (words(6)(1:2).eq.'no') typ=3
            end if
            xlin=0
            if (words(5)(1:3).eq.'xli') xlin=1
            call lorder(typ,nloci,loctyp,nord,locord)
            open(OSTR,file=outfil)
            write(*,'(/2a)') 
     &        'Writing LINKAGE type locus file: ',outfil
            call cntmark(nloci,loctyp,nmark,5)
            if (typ.eq.1 .or. typ.eq.2) nmark=nmark+1

            write(OSTR,'(4i3/a/100(i3,1x):)')
     &        nmark,0,xlin,5,'0 0.0 0.0 0',(i,i=1,nmark)
            if (typ.eq.1 .or. typ.eq.2) then
              write(*,'(a)') 'First locus is a dummy binary trait.'
              write(OSTR,'(i1,1x,i5,a/2(f8.6,1x)/i5/3(f8.6,1x))') 
     2          1, 2, ' # Dummy ', 0.5, 0.5, 1, 0.5, 0.5, 0.5
              if (xlin.eq.1) then
                write(OSTR,'(2(f8.6,1x))') 0.0, 0.0
              end if
            end if
            do 65 k=1,nord 
            i=locord(k)
            if (loctyp(i).le.2) then
              call freq(WRK,locpos(i),pedigree,actset,num,nfound,id,
     &                  fa,mo,
     &                  sex,locus,numloc,numal,name,fndr,alfrq,typed)
              call wrfreq(OSTR,loc(i),numal,name,alfrq,map(i),
     &                    typed,nobs,8)
            else if (loctyp(i).eq.3) then
              write(OSTR,
     2        '(i1,1x,i5,a,a10/2(f8.6,1x)/f8.6/3(f8.6,1x)/f8.6/f8.6)')
     3          0, 2, ' # ',loc(i), 0.1, 0.9, 1.0, 
     4          1.0, 1.0, 1.0, 1.0, 1.0
            else if (loctyp(i).eq.4) then
              write(OSTR,'(i1,1x,i5,a,a10/2(f8.6,1x)/i5/3(f8.6,1x))') 
     2          1, 2, ' # ',loc(i), 0.99, 0.01, 1, 0.05, 0.5, 0.5
              if (xlin.eq.1) then
                write(OSTR,'(2(f8.6,1x))') 0.0, 0.0
              end if
            end if
   65       continue
            write(OSTR,'(a)') '0 0'
            call wrmap(OSTR,typ,mapf,nloci,loc,loctyp,nord,locord,map)
            write(OSTR,'(/a)') '0.1 0.5'
          elseif (words(3)(1:3).eq.'sag') then
            outfil=words(4)
            open(OSTR,file=outfil)
            write(*,'(/2a)') 
     &        'Writing SAGE type locus file: ',outfil
            do 70 i=1,nloci
            if (loctyp(i).eq.1) then
              call freq(WRK,locpos(i),pedigree,actset,num,nfound,id,
     2               fa,mo,sex,locus,numloc,numal,name,fndr,
     3               alfrq,typed)
              call wrfreq(OSTR,loc(i),numal,name,alfrq,map(i),
     &                    typed,nobs,5)
            end if
   70       continue
          elseif (words(3)(1:3).eq.'lok') then
            outfil=words(4)
            lin=words(5)
            if (narg.eq.4) lin=pedfil
            open(OSTR,file=outfil)
            write(*,'(/2a)') 
     &        'Writing Loki prep type control file: ',outfil
            write(OSTR,'(3a/a/a/3a,$)') 
     2        '/* Loki type control file for ', lin(1:eow(lin)),
     3        ' */','/* Written by Sib-pair */', 'MISSING "x"', 
     4        'FILE "',lin(1:eow(lin)),
     5        '", fam, id, father, mother, sx'
            trait=1
            length=80
            do 72 i=1,nloci
              call addlet(loc(i), lin)
              j=eow(lin)
              if (loctyp(i).eq.1) then
                write(OSTR,'(5a,$)') 
     &            ', ',lin(1:j),'_A, ',lin(1:j),'_B' 
                length=length+2*j+8
              elseif (loctyp(i).eq.3 .or. loctyp(i).eq.4) then
                write(OSTR,'(2a,$)') ', ',lin(1:j)
                length=length+j+2
                if (loctyp(i).gt.2 .and. trait.eq.1) trait=i
              end if
              if (length.gt.67) then
                write(OSTR,'(/a,$)') '      '
                length=6
              end if
   72       continue
            write(OSTR,'(/a)') 'PEDIGREE fam, id, father, mother'
            write(OSTR,'(/a)') 'SEX sx "m","f"'
            do 73 i=1,nloci
            if (loctyp(i).eq.1) then
              call addlet(loc(i), lin)
              j=eow(lin)
              write(OSTR,'(7a)') 'MARKER LOCUS ',lin,
     &                   '[',lin(1:j),'_A, ',lin(1:j),'_B]'
            end if
   73       continue
            write(OSTR,'(/a,$)') 'LINK "chrom A"'
            length=15
            do 74 i=1,nloci
            if (loctyp(i).eq.1) then
              call addlet(loc(i), lin)
              j=eow(lin)
              write(OSTR,'(2a,$)') ', ',lin(1:j)
              length=length+j+3
              if (length.gt.70) then
                write(OSTR,'(/a,$)') '      '
                length=6
              end if
            end if
   74       continue
            write(OSTR,*)
            if (loctyp(trait).eq.4) then
              j=eow(loc(trait))
              write(OSTR,'(2a/3a)') 'DISCRETE ',loc(trait),
     &          'AFFECTED WHERE (',loc(trait)(1:j),'="y")'
            end if
            write(OSTR,'(a/3a)') 
     &        'TRAIT LOCUS qtl','MODEL ',loc(trait),'= qtl'
          elseif (words(3).eq.'pap') then
            open(OSTR,file='header.dat')
            open(OSTR2,file='popln.dat')
            write(*,'(/a)') 
     &        'Writing PAP locus files: header.dat and popln.dat'
            gene=1
            gen2=0
            set(1,1)=1
            set(1,2)=0
            words(1)='Gender'
            do 71 i=1,nloci
            if (loctyp(i).le.2) then
              gene=gene+1
              gen2=gen2+1
              set(gene,1)=3
              set(gene,2)=gen2
              words(gene)=loc(i)
              call freq(WRK,locpos(i),pedigree,actset,num,nfound,id,
     2                  fa,mo,sex,locus,numloc,numal,name,fndr,
     3                  alfrq,typed)
              call wrfreq(OSTR2,loc(i),numal,name,alfrq,map(i),
     &                    typed,nobs,9)
            elseif (loctyp(i).eq.3) then
              gene=gene+1
              set(gene,1)=2
              set(gene,2)=0
              words(gene)=loc(i)
            elseif (loctyp(i).eq.4) then
              gene=gene+1
              gen2=gen2+1
              set(gene,1)=1
              set(gene,2)=0
              words(gene)=loc(i)
              write(OSTR2,'(a,a10/2i4,2f8.6)') 
     &          '   1     # ',loc(i),0,100,0.05,0.05
            end if
   71       continue
            if (gene.gt.39) then
              write(*,'(a)') 
     &        'ERROR: PAP phen.dat may have no more than 39 columns'
            elseif (gene.gt.0) then
              write(OSTR,'(2i4,9a8/(10a8):)') 
     &          gene,gene,(words(i),i=1,gene)
              write(OSTR,'(8x,18i4/(20i4):)') 
     &          (set(i,1),set(i,2),i=1,gene)
            end if
            write(OSTR2,*)
            close(OSTR2,status='keep')
          elseif (words(3)(1:3).eq.'men') then
            outfil=words(4)
            open(OSTR,file=outfil)
            write(*,'(/2a)') 
     &        'Writing MENDEL type locus file: ',outfil
            call lorder(4,nloci,loctyp,nord,locord)
            do 75 k=1,nord 
              i=locord(k)
              if (loctyp(i).le.2) then
                typ=7
                if (loctyp(i).eq.2) typ=10
                call freq(WRK,locpos(i),pedigree,actset,num,nfound,id,
     2                 fa,mo, sex,locus,numloc,
     3                 numal,name,fndr,alfrq,typed)
                call wrfreq(OSTR,loc(i),numal,name,alfrq,map(i),
     &                 typed,nobs,typ)
              elseif (loctyp(i).eq.4) then
                if (words(5)(1:3).eq.'tra') then
                  write(OSTR,'(2a8,2i2,i4,1x,f8.3,10(/a))') 
     2             loc(i),'AUTOSOME', 2, 2, 1, max(0.0,0.01*map(i)),
     3             '     0010.010000','     0020.990000',
     4             'AFFECTED 3','001/001','001/002','002/002',
     5             'NORMAL   3','001/001','001/002','002/002'
                else
                  write(OSTR,'(2a8,2i2,2(/a))') 
     &             loc(i),'FACTOR  ', 2, 0, 'AFFECTED  ','NORMAL    '
                end if
              end if
   75       continue
          elseif (words(3)(1:3).eq.'asp' .or. words(3)(1:3).eq.'tcl')
     &    then
            outfil=words(4)
            open(OSTR,file=outfil)
            call cntmark(nloci,loctyp,nmark,1)
            write(*,'(/2a)') 
     &        'Writing ASPEX type (tcl) locus file: ',outfil
            if (words(5)(1:3).eq.'dis') then 
              write(*,'(a)') 'Using discordant sib pairs.'
              write(OSTR,'(a)') 'set count_discordant true'
            end if
            write(OSTR,'(2(a/),a,i3,6(/a),$)')
     2    'set has_disease_data true', 'set linkage_format true',
     4    'set nloc ',nmark, 'set blank "0"', 
     5    'set discard_partial true','set truncate_sharing false',
     6    'set most_likely true', 'set show_pairs false', 'set loc {' 
            length=0
            do 85 i=1,nloci
            if (loctyp(i).le.2) then
              length=length+1
              write(OSTR,'(1x,a,$)') loc(i)(1:eow(loc(i)))
              if (length.eq.6) then
                length=0
                write(OSTR,'(/a,$)') '         '
              end if
            end if
   85       continue
            write(OSTR,'(a)') ' }'
            call wrmap(OSTR,5,mapf,nloci,loc,loctyp,nord,locord,map)
          elseif (words(3)(1:3).eq.'str') then
            if (narg.eq.4) then
              outfil='mainparams'
            else
              outfil=words(5)
            end if
            call cntmark(nloci,loctyp,nmark,1)
            write(*,'(/2a)') 
     &        'Writing STRUCTURE mainparams file to: ',outfil
            open(OSTR,file=outfil)
            write(OSTR,'(a//a/a/a)') 
     2   'mainparam written by Sib-pair.',
     3   'KEY PARAMETERS FOR THE PROGRAM structure.',
     4   'YOU WILL NEED TO SET THESE IN ORDER TO RUN THE PROGRAM.', 
     5   'VARIOUS OPTIONS CAN BE ADJUSTED IN THE FILE extraparams.'
            write(OSTR,'(a//3a/a/a,i5,a/a,i4,a)') 'Data File', 
     2   '#define INFILE ', words(4), '// (str) input data file',
     4   '#define OUTFILE results  //(str) results file',
     5   '#define NUMINDS  ', tfound ,' // (int) no. individuals',
     6   '#define NUMLOCI  ', nmark ,'  // (int) no. loci' 
            write(OSTR,'(a)') 
     2   '#define LABEL 1', '#define POPDATA 1', '#define POPFLAG 0',
     3   '#define PHENOTYPE 1','#define EXTRACOLS 0',
     4   '#define PHASEINFO 0','#define MARKOVPHASE 1',
     5   '#define MISSING -9','#define PLOIDY 2',
     6   '#define ONEROWPERIND 1', '#define MARKERNAMES 1',
     7   '#define MAPDISTANCES 1' 
            write(OSTR,'(/a/3(/a))') 'Program Parameters',
     2   '#define MAXPOPS 2 // (int) assumed no. of pops', 
     3   '#define BURNIN 2000 // (int) length of burnin period',
     4   '#define NUMREPS 2000 // (int) no. MCMC reps' 
            write(OSTR,'(/a/8(/a))') 'Command line options:',
     2   '-m mainparams', '-e extraparams', '-s stratparams', 
     3   '-K MAXPOPS', '-L NUMLOCI', '-N NUMINDS', 
     4   '-i input file','-o output file'
          elseif (words(3)(1:3).eq.'mim') then
            outfil=words(4)
            open(OSTR,file=outfil)
            write(*,'(/2a)') 
     &        'Writing header for a MIM pedigree file to: ',outfil
            call cntmark(nloci,loctyp,nmark,1)
            write(OSTR,'(2a/a/a/i5,a/i5,a)') 
     2        'MIM data file from ',pedfil,'  0.0 # missing value',
     3        '1 0.5 # genetic variance',nmark,' # number of markers',
     4         nmark-2,' # number of analyses'
            do 189 i=2,nmark-1
              write(OSTR,'(a,3(1x,i3))') '999.0 0.0 0.0',i-1,i,i+1
  189       continue
            do 190 i=1,nloci
            if (loctyp(i).eq.1) then
              call freq(WRK,locpos(i),pedigree,actset,num,nfound,id,
     &                  fa,mo,
     &                  sex,locus,numloc,numal,name,fndr,alfrq,typed)
              write(OSTR,'(a/2(f6.1,1x),i3,100(1x,f6.4):)') 
     2          loc(i),map(i),map(i),numal,(alfrq(j),j=1,numal)
            end if
  190       continue
          else
            write(*,'(a)') 'ERROR: Locus file type not supported.'
          end if
          close(OSTR,status='keep')
C
C Write map file
        elseif (keyword.eq.'wri' .and. keyw2.eq.'map') then
          if (words(3)(1:3).eq.'men') then
            outfil=words(4)
            open(OSTR,file=outfil)
            write(*,'(/2a)') 
     &        'Writing MENDEL type map file: ',outfil
            call wrmap(OSTR,4,mapf,nloci,loc,loctyp,nord,locord, map)
            close(OSTR,status='keep')
          else if (words(3)(1:3).eq.'mer') then
            outfil=words(4)
            open(OSTR,file=outfil)
            write(*,'(/2a)') 
     &        'Writing MERLIN type map file: ',outfil
            call wrmap(OSTR,6,mapf,nloci,loc,loctyp,nord,locord, map)
            close(OSTR,status='keep')
          else if (words(3)(1:3).eq.'lok') then
            outfil=words(4)
            open(OSTR,file=outfil)
            write(*,'(/2a)') 
     &        'Writing LOKI type parameter file: ',outfil
            call wrmap(OSTR,7,mapf,nloci,loc,loctyp,nord,locord, map)
            close(OSTR,status='keep')
          else
            write(*,'(a)') 'ERROR: Map file type not supported.'
          end if
          close(OSTR,status='keep')
C
C write pedigree file
        elseif (keyword.eq.'wri'.and.red) then
          if (narg.eq.1) then
            call pedhead(longnam,nwid,nloci,loc,loctyp,locpos,lin)
            call pedout(WRK,6,2,imp,nwid,ndec,longnam,
     2            pedigree,actset,num,nfound,
     3            id,fa,mo,sex,locus,nloci,loctyp,locpos,numloc,lin)
          elseif ((narg.eq.2 .and. words(2).ne.'pap') .or. 
     &        keyw2.eq.'ped' .or. words(2).eq.'gas') then
            if (narg.eq.2) then
              outfil=words(2)
            else
              outfil=words(3)
            end if
            open(OSTR,file=outfil,status='unknown')
            write(*,'(/2a)') 
     &        'Writing GAS type pedigree file: ',outfil
            call pedout(WRK,OSTR,1,imp,nwid,ndec,longnam,
     2            pedigree,actset,num,nfound,
     3            id,fa,mo,sex,locus,nloci,loctyp,locpos,numloc,lin)
          elseif (keyw2.eq.'fis') then
            outfil=words(3)
            open(OSTR,file=outfil)
            write(*,'(/2a)') 
     &        'Writing FISHER type pedigree file: ',outfil
            call lorder(4,nloci,loctyp,nord,locord)
            call wrfish(WRK,OSTR,pedigree,actset,num,nfound,id,fa,mo,
     &             sex,locus,nloci,loctyp,locpos,numloc,nord,locord,1)
          elseif (keyw2.eq.'cri') then
            outfil=words(3)
            open(OSTR,file=outfil,status='unknown')
            open(WRK2,file=wrk2fil,form='unformatted')
            call cntmark(nloci,loctyp,nmark,1)
            write(*,'(/2a)') 
     &        'Writing CRIMAP type pedigree file: ',outfil
            write(OSTR,'(2(1x,i3))') nped,nmark
            do 246 i=1,nloci
            if (loctyp(i).eq.1) then
              write(OSTR,'(a10)') loc(i)
              call freq(WRK,locpos(i),pedigree,actset,num,nfound,id,fa,
     &                  mo,sex,locus,numloc,numal,name,fndr,alfrq,typed)
              call wrfreq(WRK2,loc(i),numal,name,alfrq,map(i),
     &                    typed,nobs,3)
            end if
  246       continue
            call wrcri(WRK,WRK2,OSTR,pedigree,actset,num,id,fa,mo,sex,
     2                  locus,nloci,loctyp,locpos,numloc,
     3                  numal,name,alfrq)
            close(WRK2,status='delete')
          elseif (keyw2.eq.'men') then
            outfil=words(3)
            open(OSTR,file=outfil,status='unknown')
            write(*,'(/2a)') 
     &        'Writing MENDEL type pedigree file: ',outfil
            call lorder(4,nloci,loctyp,nord,locord)
            call wrfish(WRK,OSTR,pedigree,actset,num,nfound,id,fa,mo,
     &             sex,locus,nloci,loctyp,locpos,numloc,nord,locord,2)
          elseif (keyw2.eq.'dot') then
            outfil=words(3)
            call gettrait(words(4),4,0,nloci,loc,loctyp,trait)
            if (trait.ne.MISS) trait=locpos(trait)
            open(OSTR,file=outfil,status='unknown')
            write(*,'(/2a)') 
     &        'Writing pedigree drawing for dot: ',outfil
            call wrdot(WRK,OSTR,trait,pedigree,actset,num,nfound,
     &             id,fa,mo,sex,locus,nloci,loctyp,locpos,numloc,lin)
          elseif (keyw2.eq.'lin' .or.keyw2.eq.'asp'.or.
     &            keyw2.eq.'tcl' .or.words(2)(1:2).eq.'gh') then
            outfil=words(3)
            typ=0
            if (words(4)(1:3).eq.'dum') then
              typ=1
            end if
            if (words(2)(1:2).eq.'gh') then
              typ=3-typ
            elseif (words(4)(1:2).eq.'gh') then
              typ=2
              if (words(5)(1:2).eq.'no') typ=3
            end if
            call lorder(typ,nloci,loctyp,nord,locord)
            open(OSTR,file=outfil,status='unknown')
            open(WRK2,file=wrk2fil,form='unformatted')
            if (keyw2.eq.'lin' .or. words(2)(1:2).eq.'gh') then
              write(*,'(/2a)') 
     &          'Writing LINKAGE type pedigree file: ',outfil
              do 50 i=1,nloci
              if (loctyp(i).le.2) then
                call freq(WRK,locpos(i),pedigree,actset,num,nfound,id,
     &                    fa,mo,
     &                  sex,locus,numloc,numal,name,fndr,alfrq,typed)
                call wrfreq(WRK2,loc(i),numal,name,alfrq,map(i),
     &                  typed,nobs,3)
              end if
   50         continue
            else
              write(*,'(/2a)') 
     &          'Writing ASPEX type pedigree file: ',outfil
              do 51 i=1,nloci
              if (loctyp(i).le.2) then
                write(OSTR,'(2a,$)') loc(i)(1:eow(loc(i))),' '
                call freq(WRK,locpos(i),pedigree,actset,num,nfound,id,
     &                    fa,mo,
     &                    sex,locus,numloc,numal,name,fndr,alfrq,typed)
                call wrfreq(WRK2,loc(i),numal,name,alfrq,map(i),
     &                      typed,nobs,3)
              end if
   51         continue
              write(OSTR,*)
            end if
            if (typ.eq.1 .or. typ.eq.2) then
              write(*,'(a)') 'Position 6 is a dummy binary trait.'
            end if
            call wrlink(WRK,WRK2,OSTR,typ,nwid,ndec,pedigree,actset,num,
     2                  nfound,id,fa,mo,sex,locus,nloci,loctyp,locpos,
     3                  nord,locord,numloc,numal,name,alfrq)
            close(WRK2,status='delete')
          elseif (keyw2.eq.'sag') then
            outfil=words(3)
            open(OSTR,file=outfil,status='unknown')
            length=0
            nrc=2
            write(*,'(/2a,7(/a))') 
     2       'Writing FSP type pedigree file: ',outfil,
     3       'Record 1:','  Pedigree     6- 10','  ID          11- 18',
     4       '  Father ID   19- 26','  Mother ID   27- 34', 
     5       '  Sex         35- 35','Record 2:'
            do 80 i=1,nloci
              if (length.gt.122) then
                nrc=nrc+1
                length=0
                write(*,'(a,i2,a1)') 'Record',nrc,':'
              end if
              if (loctyp(i).lt.5) then
                varlen=9
                if (loctyp(i).eq.4) varlen=4
                write(*,'(2x,a10,1x,i3,a1,i3)') 
     &            loc(i),length+1,'-',length+varlen
                length=length+varlen
              end if
   80       continue
C write an fsp control file then the fsp pedigree file
            open(OSTR2,file='fsp.par')
            write(OSTR2,'(a,i2,a/5i5,a2/a)') 
     2        'FSP input parameters -- ',nrc,' records per person',
     3        1,0,0,0,nrc,'MF','(a5,i5,3a8,a1)'
            close(OSTR2,status='keep')
            call wrsage(WRK,OSTR,pedigree,actset,num,id,fa,mo,sex,
     &                  locus,nloci,loctyp,locpos,numloc)
          elseif (words(2).eq.'pap') then
            open(OSTR,file='trip.dat')
            open(OSTR2,file='phen.dat')
            open(WRK2,file=wrk2fil,form='unformatted')
            do 250 i=1,nloci
            if (loctyp(i).eq.1) then
              call freq(WRK,locpos(i),pedigree,actset,num,nfound,id,fa,
     &                  mo,
     &                  sex,locus,numloc,numal,name,fndr,alfrq,typed)
              call wrfreq(WRK2,loc(i),numal,name,alfrq,map(i),
     7                    typed,nobs,3)
            end if
  250       continue
            write(*,'(/a)') 
     &        'Writing PAP type pedigree files: phen.dat and trip.dat'
            call wrpap(WRK,WRK2,OSTR,OSTR2,pedigree,actset,num,nfound,
     2                 id,fa,mo,sex,locus,nloci,loctyp,locpos,numloc,
     3                 numal,name,alfrq)
            close(WRK2,status='delete')
            close(OSTR2,status='keep')
          elseif (keyw2.eq.'gda') then
            outfil=words(3)
            open(OSTR,file=outfil)
            typ=1
            if (words(4)(1:3).eq.'all') typ=2
            write(*,'(/2a)') 
     &        'Writing GDA (gdatype) data file: ',outfil
            call wrgda(WRK,OSTR,pedigree,actset,num,nfound,id,fa,mo,sex,
     &                 locus,nloci,loc,loctyp,locpos,numloc,typ)
          elseif (keyw2.eq.'str') then
            outfil=words(3)
            call gettrait(words(4),4,0,nloci,loc,loctyp,trait)
            if (trait.ne.MISS) then
              trait=locpos(trait)
            end if
            typ=1
            if (words(narg).eq.'all') typ=2
            write(*,'(/2a)') 
     &        'Writing structure data file: ',outfil
            open(OSTR,file=outfil)
            call wrmap(OSTR,8,mapf,nloci,loc,loctyp,nord,locord, map)
            call wrprd(WRK,OSTR,trait,pedigree,actset,num,nfound,id,fa,
     &             mo,sex,locus,nloci,loc,loctyp,locpos,numloc,typ)
          elseif (keyw2.eq.'arl') then
            outfil=words(3)
            open(OSTR,file=outfil)
            open(WRK2,file=wrk2fil,form='unformatted')
            if (words(4)(1:3).eq.'par') then 
              typ=2
              write(*,'(a/2a)') 'Writing 4 longest parental haplotypes',
     &        ' per family to Arlequin data file: ',outfil
            else if (words(4)(1:3).eq.'all') then 
              typ=0
              write(*,'(2a)') 
     &        'Writing all genotypes to Arlequin data file: ',outfil
            else
              typ=1
              write(*,'(a/2a)') 'Writing 2 longest haplotypes',
     &        ' per family to Arlequin data file: ',outfil
            end if
            call wrarl(WRK,WRK2,OSTR,pedigree,actset,num,nfound,id,fa,
     &                 mo,sex,
     2                 locus,nloci,loc,loctyp,locpos,numloc,
     3                 locord,hset,typ)
            close(WRK2,status='delete')
          elseif (keyw2.eq.'phe') then
            outfil=words(3)
            open(OSTR,file=outfil)
            write(*,'(/2a)') 
     &        'Writing Mapmaker-Sibs phenotype data file: ',outfil
            call wrphe(WRK,OSTR,pedigree,actset,num,nfound,id,fa,mo,sex,
     &                 locus,nloci,loctyp,locpos,numloc)
          else
            write(*,'(a)') 'ERROR: Pedigree file type not supported.'
          end if
          close(OSTR,status='keep')
C
C SML predicted recurrence risks, ibd sharing etc
        elseif (keyword.eq.'grr') then
          if (narg.ge.4) then
            write(*,'(3(/a))')
     2        '------------------------------------------------',
     3        'Single Major Locus Recurrence Risk Calculation',
     4        '------------------------------------------------'
            call grrpen(words(5)(1:3),dble(fval(words(2))),
     &                  dble(fval(words(3))),dble(fval(words(4))))
          end if
        elseif (keyword.eq.'sml') then
          typ=1
          do 195  i=2, narg
            expr(i-1)=dble(fval(words(i)))
            if (expr(i-1).gt.1.0d0) typ=2
  195     continue
          do 196  i=narg+1,8
            expr(i-1)=0.0d0
  196     continue
          if (narg.gt.5) typ=2
          if (typ.eq.2 .and. narg.ge.5 .and. narg.lt.8) then
            j=max(5,narg-1)
            do 197  i=narg+1, 8
              expr(i-1)=expr(j)
  197       continue
          end if
          if (typ.eq.1 .and. narg.ge.2) then
            write(*,'(3(/a))')
     2      '------------------------------------------------',
     3      'Single Major Locus Recurrence Risk Calculation',
     4      '------------------------------------------------'
            call recrisk(expr(1), expr(2), expr(3), expr(4))
          else if (typ.eq.2 .and. narg.ge.2) then
            write(*,'(3(/a))')
     2      '------------------------------------------------',
     3      'Quantitative Trait SML Expectations',
     4      '------------------------------------------------'
            call qtlpars(expr(1), expr(2), expr(3), expr(4),
     &                   expr(5), expr(6), expr(7))
          end if
        elseif (keyword.eq.'pro') then
          i=ival(words(2))
          j=ival(words(3))
          tmp=fval(words(4))
          call propci(i,j,tmp)
        elseif (keyword.eq.'pch') then
          tmp=fval(words(2))
          i=ival(words(3))
          write(*,*) chip(dble(tmp),i)
        elseif (keyword.eq.'lis') then
          call listloci(nloci,loc,loctyp,locpos,1)
        elseif (keyword.eq.'ls') then
          call listloci(nloci,loc,loctyp,locpos,2)
        elseif (keyword.eq.'inf') then
          call info(burnin,imp,iter,ix,iy,iz,mapf,mincnt,plevel,
     2              showorig,addsex,chek,droperr,prompt,use2,
     3              datdir,version,wrkdir)
        elseif (keyword.eq.'hel' .or. keyword.eq.'?') then
          typ=5
          if (keyw2.eq.'all') then
            typ=1
          elseif (keyw2.eq.'glo') then
            typ=2
          elseif (keyw2.eq.'dat') then
            typ=3
          elseif (keyw2.eq.'ana') then
            typ=4
          end if
          call help(typ)
        elseif (keyword.eq.'tim') then
          call stamp(t0)
        elseif (keyword(1:1).eq.'!' .or. keyword(1:1).eq.'#') then
          write(*,'(a)') lin(1:79)
        elseif ((keyword(1:1).eq.'%'.or.keyword(1:1).eq.'$') .and.
     &          eow(lin).gt.1) then
          call shell(lin)
        elseif ((keyword.eq.'inc' .or. keyword.eq.'loc') .and.
     &          ilevel.eq.1) then
          call args(lin,narg,bigwor,1)
          infil=bigwor(2)
          inquire(file=infil,exist=filexist)
          if (filexist) then
            write(*,'(/3a)') 
     &        'Reading commands from "', infil(1:eow(infil)),'".'
            ilevel=ilevel+1
            open(CSTRM,file=infil,status='unknown')
            loconly=(keyword.eq.'loc')
          else
            write(*,'(/3a/)') 
     &        'ERROR:  Unable to open "', infil(1:eow(infil)),'".'
          end if
        elseif (keyword.eq.'cle') then
          close(WRK,status='delete')
          goto 999
        elseif (keyword(1:1).eq.' ') then
          continue
        elseif (keyword.eq.'sto' .or. keyword.eq.'qui' .or.
     &          keyword.eq.'exi' .or.keyword(1:2).eq.'by') then
          goto 2
C
C Maybe an expression?
        else
          call args(lin,narg,words,2)
          nterm=narg
          call typwords(1,nterm,words,nloci,loc,loctyp,token,env,
     &                  wtyp,expr,actn)
          if (actn.eq.0) then
            error=1
          else
            if (actn.eq.2) call dryrun(1,nterm,wtyp)
            call parser(nterm,wtyp,expr,lbp,rbp,op,error)
C Write answer
            if (error.gt.0 .or. nterm.gt.1) then
              error=1
            else if (actn.eq.1) then 
              if (wtyp(1).eq.1000) then
                write(*,*) '=> ',expr(1)
              else
                write(*,'(a)') '=> MISS'
              end if
            else if (red) then
              write(*,'(a/)') 'Operating on pedigree file' 

              call newnam(wrknum, wrkfil)
              open(TWRK,file=wrkfil,form='unformatted')
              call 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)
              close(WRK,status='delete')
              close(TWRK,status='keep')
              open(WRK,file=wrkfil,form='unformatted')
            else 
              error=1
            end if
          end if
          if (error.eq.1) then
            write(*,'(a,i3,a/7x,a/)')   
     &        'ERROR: problematic input at line ',nlin,':',lin(1:72)
            if (.not.red) write(*,'(a/7x,a/)')
     2        'NOTE:  data set has not yet been read in.',
     3        'Most procedures require a preceding "run" statement.'
          end if
        end if
      goto 1
    2 continue   
      if (ilevel.gt.1) then
        write(*,'(/3a/)') 
     &    'Closing include file "',infil(1:eow(infil)),'".'
        ilevel=ilevel-1
        close(CSTRM,status='keep')
        goto 1
      end if
C
C end of main loop
C
      close(WRK,status='delete')
      call stamp(t0)
      end
C end-of-main
