C
C write out haplotypes in nuclear family and grandparents
C
      subroutine dohaplo(wrk,wrk2,trait,iter,nloci,loc,loctyp,locpos,
     &             pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &             numloc,hset,showorig)
      integer KNOWN, MAXHAP, MAXSIZ, MAXLOC, MISS
      parameter(KNOWN=0,MAXSIZ=1000,MAXLOC=120,
     &          MAXHAP=MAXLOC/2,MISS=-9999)

      integer iter,showorig,trait,wrk,wrk2
C
C Pedigree structure
      character*10 pedigree
      integer actset, num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
      integer numloc
C
C Locus structure 
      integer nloci
      character*10 loc(MAXLOC)
      integer loctyp(MAXLOC),locpos(MAXLOC)
C
C Storage space for haplotypes
      integer hset(MAXSIZ,MAXHAP,2)
C
C Marker list
      integer nmark, mark(MAXHAP)
C 
      integer currf, currm, gene, gen2, i, j, sta
      logical last 

      nmark=0
      do 1 j=1,nloci
      if (loctyp(j).eq.1) then
        nmark=nmark+1
        mark(nmark)=j
        if (nmark.eq.MAXHAP) goto 2
      end if
    1 continue
    2 continue

      rewind(wrk)
   10 continue
       call wrkin(wrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &            numloc,last)
       if (last) goto 20

       if (actset.le.0) goto 10
C
        do 25 i=1,num
        do 25 j=1,nmark
          gene=locpos(mark(j))
          gen2=gene+1
          if (locus(i,gene).gt.KNOWN) then
            hset(i,j,1)=int(locus(i,gene))
            hset(i,j,2)=int(locus(i,gen2))
          else
            hset(i,j,1)=MISS
            hset(i,j,2)=MISS
          end if
   25   continue

        currf=fa(nfound+1)
        currm=mo(nfound+1)
        sta=nfound+1
        do 30 i=nfound+1,num
C Print results of last sibship and do parents of current sibship
          if (fa(i).ne.currf .or. mo(i).ne.currm) then
            call wrhaplo(wrk2,pedigree,currf,currm,sta,i-1,nmark,mark, 
     &            iter,trait,nloci,loc,id,fa,mo,sex,locus,hset,showorig)
            sta=i
            currf=fa(i)
            currm=mo(i)
          end if
   30   continue
        call wrhaplo(wrk2,pedigree,currf,currm,sta,num,nmark,mark, 
     &         iter,trait,nloci,loc,id,fa,mo,sex,locus,hset,showorig)
      goto 10
   20 continue

      return
      end
C end-of-dohaplo
C
C Write haplotypes for sibship, parents, and grandparents, if available
C
      subroutine wrhaplo(wrk2,pedigree,currf,currm,sta,fin,nmark,mark, 
     2             iter,trait,nloci,loc,id,fa,mo,sex,locus,
     3             hset,showorig)
      integer MAXSIZ, MAXLOC, MAXHAP, MISS, WIDE
      parameter(MAXSIZ=1000,MAXLOC=120,MAXHAP=MAXLOC/2,
     &          MISS=-9999,WIDE=12)

      integer currf, currm, fin, iter, sta, trait,wrk2
      integer showorig
C Marker list
      integer nmark, mark(MAXHAP)
C
C Pedigree structure
      character*10 pedigree
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
C
C Locus structure:
      integer nloci
      character*10 loc(MAXLOC)
C
C Storage space for haplotypes
      integer hset(MAXSIZ,MAXHAP,2)
C
C local variables
      integer i, j, eol, eop, leftm, npars, pos, nsibs
      logical gp1, gp2, use
      character*1 pchrom(4),mchrom(4)
      character*3 all
      character*7 gtp
      character*10 chid
      character*128 lin
C
C functions
      integer eow,gpsrc

      data mchrom,pchrom /'|','c','d','*','|','a','b','*'/

      if (showorig.lt.2) then
        mchrom(1)=' '
        mchrom(2)=' '
        mchrom(3)=' '
        pchrom(1)=' '
        pchrom(2)=' '
        pchrom(3)=' '
        if (showorig.lt.1) then
          mchrom(4)=' '
          pchrom(4)=' '
        end if
      end if
      eop=eow(pedigree)
C
C Check if useful to view (some typed siblings or one child plus parent)
C
      npars=0
      nsibs=0
      call usehap(currf,nmark,hset,use)
      if (use) npars=npars+1
      call usehap(currm,nmark,hset,use)
      if (use) npars=npars+1
      do 2 i=sta,fin
        call usehap(i,nmark,hset,use)
        if (use) then
          nsibs=nsibs+1 
        end if
    2 continue
    
      if (nsibs.eq.0 .or. (nsibs.eq.1 .and. npars.eq.0)) return
C
C Utility of grandparents
C
      if (fa(currf).ne.MISS) then
        call usehap(fa(currf),nmark,hset,gp1)
        if (.not.gp1) call usehap(mo(currf),nmark,hset,gp1)
      else
        gp1=.false.
      end if
      if (fa(currm).ne.MISS) then
        call usehap(fa(currm),nmark,hset,gp2)
        if (.not.gp2) call usehap(mo(currm),nmark,hset,gp2)
      else
        gp2=.false.
      end if

C note the nuclear family level inconsistencies
      write(*,'(8a/)')
     2  'Sibship: ',pedigree(1:eop),'-',id(currf)(1:eow(id(currf))),
     3  ' x ',pedigree(1:eop),'-',id(currm)(1:eow(id(currm))) 
      call check2(pedigree,eop,currf,currm,sta,fin,id,
     &            nmark,mark,loc,hset)
      call maxshare(currf,currm,fa(currf),mo(currf),
     &              fa(currm),mo(currm),sta,fin,iter,nmark,hset)
      if (iter.gt.0) then
        call recmin(wrk2,currf,currm,fa(currf),mo(currf),
     &              fa(currm),mo(currm),sta,fin,iter,nmark,hset)
      end if
      lin=' '
C
C Show grandparental generation if useful and present
C
C IDs
      if (gp1 .or. gp2) then
        if (gp1) then
          call wrid('c',id(fa(currf)),chid,sex(fa(currf)))
          lin(17:26)=chid
          call wrid('c',id(mo(currf)),chid,sex(mo(currf)))
          lin(27:36)=chid
          eol=35
        end if
        if (gp2) then
          call wrid('c',id(fa(currm)),chid,sex(fa(currm)))
          lin(37:46)=chid
          call wrid('c',id(mo(currm)),chid,sex(mo(currm)))
          lin(47:56)=chid
          eol=55
        end if
        write(*,'(a)') lin(1:eol)
C trait if requested
        if (trait.ne.MISS) then
          if (gp1) then
            call wraff7(locus(fa(currf),trait),gtp)
            lin(18:24)=gtp
            call wraff7(locus(mo(currf),trait),gtp)
            lin(28:34)=gtp
            eol=34
          end if
          if (gp2) then
            call wraff7(locus(fa(currm),trait),gtp)
            lin(38:44)=gtp
            call wraff7(locus(mo(currm),trait),gtp)
            lin(48:54)=gtp
            eol=54
          end if
          write(*,'(a)') lin(1:eol)
        end if
C markers
        do 10 j=1,nmark
          lin=' '
          if (gp1) then
            call wrgtp(hset(fa(currf),j,1),
     &                 hset(fa(currf),j,2),gtp,0)
            lin(18:24)=gtp
            call wrgtp(hset(mo(currf),j,1),
     &                 hset(mo(currf),j,2),gtp,0)
            lin(28:34)=gtp
            eol=34
          end if
          if (gp2) then
            call wrgtp(hset(fa(currm),j,1),
     &                 hset(fa(currm),j,2),gtp,0)
            lin(38:44)=gtp
            call wrgtp(hset(mo(currm),j,1),
     &                 hset(mo(currm),j,2),gtp,0)
            lin(48:54)=gtp
            eol=54
          end if
          write(*,'(a)') lin(1:eol)
   10   continue
        lin=' '
        if (gp1) then
          lin(21:21)='|'
          lin(31:31)='|'
          eol=31
        end if
        if (gp2) then
          lin(41:41)='|'
          lin(51:51)='|'
          eol=51
        end if
        write(*,'(a)') lin(1:eol)
        lin=' '
        if (gp1) then
          lin(21:31)='+====+====+'
          eol=31
        end if
        if (gp2) then
          lin(41:51)='+====+====+'
          eol=51
        end if
        write(*,'(a)') lin(1:eol)
        lin=' '
        if (gp1) then
          lin(26:26)='|'
          eol=26
        end if
        if (gp2) then
          lin(46:46)='|'
          eol=46
        end if
        write(*,'(a)') lin(1:eol)
        lin=' '
      end if
C
C Now the parents of the nuclear family
C
      call wrid('c',id(currf),chid,sex(currf))
      lin(22:31)=chid
      call wrid('c',id(currm),chid,sex(currm))
      lin(42:51)=chid
      write(*,'(a)') lin(1:50)
      if (trait.ne.MISS) then
        lin=' '
        lin(11:20)=loc(trait)
        call wraff7(locus(currf,trait),gtp)
        lin(23:29)=gtp
        call wraff7(locus(currm,trait),gtp)
        lin(43:49)=gtp
        write(*,'(a)') lin(1:49)
      end if
      do 20 j=1,nmark
        lin=' '
        lin(11:20)=loc(mark(j))
        call wrgtp(hset(currf,j,1),hset(currf,j,2),gtp,0)
        lin(23:29)=gtp
        call wrgtp(hset(currm,j,1),hset(currm,j,2),gtp,0)
        lin(43:49)=gtp
        write(*,'(a)') lin(1:49)
        lin=' '
   20 continue
      write(*,'(25x,a1,19x,a1/25x,a21/35x,a1)')
     &  '|','|','+=========+=========+','|'
C
C Then the children
C
      nsibs=fin-sta+1
      if (nsibs.eq.1) then
        call wrid('c',id(sta),chid,sex(sta))
        write(*,'(35x,a1/31x,a10)') '|',chid
        if (trait.ne.MISS) then
          call wraff7(locus(sta,trait),gtp)
          write(*,'(20x,a10,2x,a7)') loc(trait),gtp
        end if
        do 30 j=1,nmark
          call wrgtp(hset(sta,j,1),hset(sta,j,2),gtp,0)
          write(*,'(20x,a10,1x,a1,a7,a1)') loc(mark(j)),
     2      pchrom(gpsrc(currf,sta,1,j,hset)+1),
     3      gtp,
     4      mchrom(gpsrc(currm,sta,2,j,hset)+1)
   30   continue
        if (showorig.gt.0 .and. iter.gt.0) then
          call recnum(sta,currf,currm,nmark,hset,gtp)
          write(*,'(32x,a7)') gtp 
        end if
      elseif (nsibs.gt.WIDE) then
        do 40 i=sta,fin
          write(*,*)
          lin=' '
          pos=1
          do 41 j=1,nmark
            call wrall(hset(i,j,1),all)
            lin(pos:pos+2)=all
            pos=pos+4
   41     continue
          write(*,'(28x,a8,a)') id(i),lin(1:pos)
          lin=' '
          pos=1
          do 42 j=1,nmark
            call wrall(hset(i,j,2),all)
            lin(pos:pos+2)=all
            pos=pos+4
   42     continue
          call recnum(i,currf,currm,nmark,hset,gtp)
          write(*,'(28x,a,1x,a)') gtp,lin(1:pos)
   40   continue
      else
        leftm=max(13,38-5*nsibs)
        pos=leftm+3
        do 50 i=1,nsibs-1
          lin(pos:pos+10)='+---------+'
          pos=pos+10
   50   continue
        lin(36:36)='+'
        write(*,'(a)') lin(1:pos)
        lin=' '
        pos=leftm+3
        do 60 i=1,nsibs
          lin(pos:pos)='|'
          pos=pos+10
   60   continue
        write(*,'(a)') lin(1:pos)
        lin=' '
        pos=leftm
        do 70 i=sta,fin
          call wrid('c',id(i),chid,sex(i))
          lin(pos:pos+9)=chid
          pos=pos+11
   70   continue
        write(*,'(a)') lin(1:pos)
        if (trait.ne.MISS) then
          lin=' '
          lin(leftm-12:leftm-3)=loc(trait)
          pos=leftm
          do 75 i=sta,fin
            call wraff7(locus(i,trait),gtp)
            lin(pos:pos+6)=gtp
            pos=pos+10
   75     continue
          write(*,'(a)') lin(1:pos)
        end if
        do 80 j=1,nmark
          lin=' '
          lin(leftm-12:leftm-3)=loc(mark(j))
          pos=leftm
          do 90 i=sta,fin
            call wrgtp(hset(i,j,1),hset(i,j,2),gtp,0)
            lin(pos:pos+6)=gtp
            lin(pos-1:pos-1)=pchrom(gpsrc(currf,i,1,j,hset)+1)
            lin(pos+7:pos+7)=mchrom(gpsrc(currm,i,2,j,hset)+1)
            pos=pos+10
   90     continue
          write(*,'(a)') lin(1:pos)
   80   continue

        if (showorig.gt.0 .and. iter.gt.0) then
          lin=' '
          pos=leftm 
          do 100 i=sta,fin
            call recnum(i,currf,currm,nmark,hset,gtp)
            lin(pos:pos+6)=gtp
            pos=pos+10
  100     continue
          write(*,'(a)') lin(1:pos)
        end if
      end if
      write(*,*)

      return
      end
C end-of-wrhaplo 
C
C write out allele   
C
      subroutine wrall(iall,all)
      integer MISS,KNOWN
      parameter(MISS=-9999,KNOWN=0)
      integer iall
      character*3 all
      if (iall.eq.MISS) then 
        all='  x'
      elseif (iall.lt.KNOWN) then
        write(all,'(i3)') -iall
      else
        write(all,'(i3)') iall 
      end if
      return
      end
C end-of-wrall
C
C Search for best haplotypes based on recmin criterion
C
      subroutine recmin(wrk2,currf,currm,gran1,gran2,gran3,gran4,
     &                  sta,fin,iter,nmark,hset)
      integer KNOWN, MAXLOC, MAXHAP, MAXSIZ, MISS
      parameter(KNOWN=0, MAXLOC=120, MAXHAP=MAXLOC/2, 
     &          MAXSIZ=1000, MISS=-9999)

      integer iter, wrk2
      integer currf, currm, fin, gran1, gran2, gran3, gran4, sta
      integer nmark, hset(MAXSIZ,MAXHAP,2)

      integer nchoice, choice(MAXSIZ)

      integer i, it, kids, maxit, nerr, nrec
      integer id1, id2, id3, loc1, loc2, loc3, pos1, pos2, tmp, type
      integer oall1, oall2, whp1, whp2, whgp1, whgp2
      logical gp1, gp2, gp3, gp4, s1

      integer hicount, hicrit, minstart, nconverge, starts
      integer bestcrit, newcrit, oldcrit
      real rate, temp
C functions
      integer irandom
      logical metrop
C
C Only visit useful individuals
C
      nchoice=0
      if (gran1.ne.MISS) then
        call addhap(gran1,nmark,hset,nchoice,choice,gp1)
        call addhap(gran2,nmark,hset,nchoice,choice,gp2)
      else
        gp1=.false.
        gp2=.false.
      end if
      if (gran3.ne.MISS) then
        call addhap(gran3,nmark,hset,nchoice,choice,gp3)
        call addhap(gran4,nmark,hset,nchoice,choice,gp4)
      else
        gp3=.false.
        gp4=.false.
      end if
C Always include parents
      nchoice=nchoice+1
      choice(nchoice)=currf
      nchoice=nchoice+1
      choice(nchoice)=currm
C
C Mark start of children's IDs in choice()
C
      kids=nchoice+1
      do 2 i=sta,fin
        call addhap(i,nmark,hset,nchoice,choice,s1)
    2 continue
C
C maxit is maximum number of iterations of SA search algorithm
C and controls the cooling schedule: rate
C
C pos1 and pos2 are the boundaries of the region currently being worked on
C (sliding window which traverses the whole region repeatedly)
C
C The stopping criterion is a failure to improve for nconverge proposals
C
C The SA algorithm is restarted a minimum of minstart occasions, since the
C solution space is multimodal, and the best criterion found in the
C 1st minstart iterations is then read back from wrk2
C
C wrk2 is the stream for the scratch file where solutions from each 
C iteration are stored.
C
      rewind(wrk2)

      bestcrit=0
      minstart=5
      maxit=iter*nmark*nchoice
      nconverge=50*nmark*nchoice
      oldcrit=0
      pos1=1
      pos2=min(nmark,5)
      rate=0.02**(2.0/float(maxit))
C
C Loop to minimize recmin criterion
C Tries minstart restarts
C
      starts=0
    4 continue

      starts=starts+1
C zero out imputed haplotypes
      call delhap(currf,nmark,hset)
      call delhap(currm,nmark,hset)
      if (gp1) call delhap(gran1,nmark,hset)
      if (gp2) call delhap(gran2,nmark,hset)
      if (gp3) call delhap(gran3,nmark,hset)
      if (gp4) call delhap(gran4,nmark,hset)

      hicount=0
      hicrit=0
      temp=20.0

      it=0
    5 continue
        it=it+1
C
C Generate proposal: either 1,2,3 switches of origin,
C or impute one or two parental alleles based on a child
C
        type=irandom(1,5)
        if (type.lt.4) then
          id1=choice(irandom(1,nchoice))
          loc1=irandom(pos1,pos2)
          call shuffhap(id1,loc1,hset)
          if (type.ge.2) then
            id2=choice(irandom(1,nchoice))
            loc2=irandom(pos1,pos2)
            call shuffhap(id2,loc2,hset)
            if (type.eq.3) then
              id3=choice(irandom(1,nchoice))
              loc3=irandom(pos1,pos2)
              call shuffhap(id3,loc3,hset)
            end if
          end if
        else
C Pick an index person with included parents
   10     continue
            id1=choice(irandom(kids-2,nchoice))
          if ((id1.eq.currf .and. .not.gp1) .or. 
     &        (id1.eq.currm .and. .not.gp3)) goto 10
          loc1=irandom(pos1,pos2)
          whp1=irandom(1,2)
          whgp1=irandom(1,2)
          if (id1.eq.currf) then
            id2=gran1
            id3=gran2
          elseif (id1.eq.currm) then
            id2=gran3
            id3=gran4
          else
            id2=currf
            id3=currm
          end if
          if (whp1.eq.2) then
            tmp=id2
            id2=id3
            id3=tmp
          end if
          oall1=hset(id2,loc1,whgp1)
          if (oall1.lt.KNOWN) then
            hset(id2,loc1,whgp1)=-abs(hset(id1,loc1,whp1))
          end if
          if (type.eq.5) then
            whp2=3-whp1
            whgp2=irandom(1,2)
            oall2=hset(id3,loc1,whgp2)
            if (oall2.lt.KNOWN) then
              hset(id3,loc1,whgp2)=-abs(hset(id1,loc1,whp2))
            end if
            if (whp1.eq.2) call shuffhap(id1,loc1,hset)
          end if 
        end if
C Calculate criterion
        newcrit=0
C grandparents v. parents
        if (gp1) then
          call scorerec(gran1,currf,1,nmark,hset,nrec,nerr,newcrit)
        end if
        if (gp2) then
          call scorerec(gran2,currf,2,nmark,hset,nrec,nerr,newcrit)
        end if
        if (gp3) then
          call scorerec(gran3,currm,1,nmark,hset,nrec,nerr,newcrit)
        end if
        if (gp4) then
          call scorerec(gran4,currm,2,nmark,hset,nrec,nerr,newcrit)
        end if
C parents v. children
        do 60 i=kids, nchoice
          call scorerec(currf,choice(i),1,nmark,hset,nrec,nerr,newcrit)
   60   continue
        do 70 i=kids, nchoice
          call scorerec(currm,choice(i),2,nmark,hset,nrec,nerr,newcrit)
   70   continue
C
C Test if (still) at a local or global minumum
C
        if (newcrit.gt.hicrit) then
          hicrit=newcrit
          hicount=1
        elseif (newcrit.eq.hicrit) then
          hicount=hicount+1
        end if
C
C Reverse proposal if worsens fit criterion, else accept new model
C
        if (metrop(newcrit,oldcrit,temp)) then
          oldcrit=newcrit
        else
          if (type.lt.4) then
            call shuffhap(id1,loc1,hset)
            if (type.ge.2) then
              call shuffhap(id2,loc2,hset)
              if (type.eq.3) call shuffhap(id3,loc3,hset)
            end if
          else
            hset(id2,loc1,whgp1)=oall1
            if (type.eq.5) then
              hset(id3,loc1,whgp2)=oall2
              if (whp1.eq.2) call shuffhap(id1,loc1,hset)
            end if
          end if
        end if

        if (mod(it,10*nchoice).eq.0) then
          pos2=pos2+1
          if (pos2.gt.nmark) then
            pos2=min(5,nmark)
            pos1=1
          else
            pos1=pos1+1
          end if
        end if

        temp=rate*temp
C
C End of while loop: stop if stuck or maximum iterations exceeded
C
      if (it.le.maxit .and. hicount.le.nconverge) goto 5

      if (oldcrit.gt.bestcrit) bestcrit=oldcrit
      write(wrk2) oldcrit, hset

      if (starts.le.minstart) goto 4

      write(*,'(a,i5,a/)') '(Recmin criterion=',bestcrit,')' 
C
C Retrieve best solution
C
      rewind(wrk2)
  100 continue
        read(wrk2) oldcrit, hset
      if (oldcrit.lt.bestcrit) goto 100

      return
      end
C end-of-recmin
C
C Metropolis crit allowing for overflow/underflow
C
      logical function metrop(new,old,temp)
      integer new, old
      real temp
      real ratio
C functions
      real random
      if (new.ge.old) then
        metrop=.true.
        return
      end if
      ratio=float(new-old)/temp
      if (ratio.gt.-8.0) then
        metrop=(random().lt.exp(ratio))
      else
        metrop=.false.
      end if
      return
      end
C end-of-metrop
C
C shuffle alleles between haplotype
C
      subroutine shuffhap(idx,target,hset)
      integer MAXLOC, MAXHAP, MAXSIZ, MISS
      parameter(MAXLOC=120, MAXHAP=MAXLOC/2, MAXSIZ=1000, MISS=-9999)

      integer idx, target
C Haplotypes
      integer hset(MAXSIZ,MAXHAP,2)
      integer tmp

      tmp=hset(idx,target,1)
      hset(idx,target,1)=hset(idx,target,2)
      hset(idx,target,2)=tmp
      return
      end
C end-of-shuffhap
C
C check if useful genotypes and add to list
C
      subroutine addhap(idx,nmark,hset,nchoice,choice,use)
      integer KNOWN, MAXLOC, MAXHAP, MAXSIZ, MISS
      parameter(KNOWN=0, MAXLOC=120, MAXHAP=MAXLOC/2, 
     &          MAXSIZ=1000, MISS=-9999)
      integer idx
C Haplotypes
      integer nmark, hset(MAXSIZ,MAXHAP,2)
      integer nchoice, choice(MAXSIZ)
      logical use

      call usehap(idx,nmark,hset,use)
      if (use) then
        nchoice=nchoice+1
        choice(nchoice)=idx
      end if
      return
      end
C end-of-addhap
C
C check if useful genotypes
C
      subroutine usehap(idx,nmark,hset,use)
      integer KNOWN, MAXLOC, MAXHAP, MAXSIZ
      parameter(KNOWN=0, MAXLOC=120, MAXHAP=MAXLOC/2, MAXSIZ=1000)
      integer idx
C Haplotypes
      integer nmark, hset(MAXSIZ,MAXHAP,2)
      logical use

      integer j

      use=.false.
      do 10 j=1,nmark
      if (hset(idx,j,1).gt.KNOWN) then
        use=.true.
        return
      end if
   10 continue

      return
      end
C end-of-usehap
C
C zero imputed haplotypes
C
      subroutine delhap(idx,nmark,hset)
      integer KNOWN, MAXLOC, MAXHAP, MAXSIZ, MISS
      parameter(KNOWN=0, MAXLOC=120, MAXHAP=MAXLOC/2, 
     &          MAXSIZ=1000, MISS=-9999)
      integer idx
C Haplotypes
      integer nmark, hset(MAXSIZ,MAXHAP,2)

      integer j

      do 10 j=1,nmark
      if (hset(idx,j,1).lt.KNOWN) then
        hset(idx,j,1)=MISS
        hset(idx,j,2)=MISS
      end if
   10 continue

      return
      end
C end-of-delhap
C
C score match of parental haplotypes to child haplotype: 
C  length of matched haplotype and number of recombinants
C
      subroutine scorerec(parent,child,orig,nmark,hset,nrec,nerr,match)
      integer KNOWN, MAXLOC, MAXHAP, MAXSIZ, MISS
      parameter(KNOWN=0, MAXLOC=120, MAXHAP=MAXLOC/2, 
     &          MAXSIZ=1000, MISS=-9999)

      integer  child, orig, nerr, nrec, parent, match 
C Haplotypes
      integer nmark, hset(MAXSIZ,MAXHAP,2)
      integer contrib, gpar, j, source
C functions
      integer gpsrc

      contrib=0
      nerr=0
      nrec=0
      source=0
      do 10 j=1,nmark
      if (hset(child,j,orig).ne.MISS) then
C
C score for number of known or imputed genotypes
C penalise imputed homozygous genotypes
C
        contrib=contrib+2
        if (hset(parent,j,1).ne.MISS) then
          contrib=contrib+1
          if (hset(parent,j,1).lt.KNOWN .and. 
     &        hset(parent,j,1).eq.hset(parent,j,2)) then
            contrib=contrib-1
          end if
        end if
        if (hset(parent,j,2).ne.MISS) then
          contrib=contrib+1
        end if
C
C Count recombinants and errors/mutations
C
        gpar=gpsrc(parent,child,orig,j,hset)
        if (gpar.eq.3) then
          nerr=nerr+1
        elseif (gpar.ne.0) then
          if (source.ne.0 .and. gpar.ne.source) nrec=nrec+1
          source=gpar
        end if
      end if
   10 continue
      match=match+contrib-3*nrec-10*nerr
      return
      end
C end-of-scorerec
C
C Count recombination and "mutation" events: write number as string 
C (same length as a genotype, so looks nice in output)
C
      subroutine recnum(child,currf,currm,nmark,hset,str)
      integer KNOWN, MAXLOC, MAXHAP, MAXSIZ, MISS
      parameter(KNOWN=0, MAXLOC=120, MAXHAP=MAXLOC/2, 
     &          MAXSIZ=1000, MISS=-9999)

      integer currf,currm,child
      character*7 str
      integer nmark, hset(MAXSIZ,MAXHAP,2)

      integer dum, materr, matrec, nerr, nrec, paterr, patrec
      character*1 ch

      dum=0
      call scorerec(currf,child,1,nmark,hset,patrec,paterr,dum)
      call scorerec(currm,child,2,nmark,hset,matrec,materr,dum)
      nerr=paterr+materr
      nrec=patrec+matrec
      if (nerr.gt.0) then
        ch='*'
      elseif (nrec.gt.0) then
        ch='+'
      else
        ch=' '
      end if
      write(str,'(a1,a1,i1,a1,i1,a1,a1)') ch,'[',nrec,';',nerr,']',ch

      return
      end
C end-of-recnum
C
C check for simple inconsistencies between child and parent
C
      subroutine check2(pedigree,eop,currf,currm,sta,fin,id,
     &                  nmark,mark,loc,hset)
      integer KNOWN, MAXLOC,MAXHAP,MAXSIZ,MISS
      parameter (KNOWN=0,MAXLOC=120, MAXHAP=MAXLOC/2,
     &           MAXSIZ=1000,MISS=-9999)

      integer currf, currm, eop, fin, sta
C Pedigree structure
      character*10 pedigree
      character*8 id(MAXSIZ) 
      integer hset(MAXSIZ,MAXHAP,2)
C
C Locus names and list of marker loci
      character*10 loc(MAXLOC)
      integer nmark, mark(MAXHAP)
C
C count of segregating alleles
      integer nall, allele(4)
C parental phenoset
      integer nset, p1(5,2), p2(5,2)
C other local variables
      integer c1,c2,i,j,p11,p12,p21,p22
      logical anyerr, err, thiserr, xmale
      character*7 gtp
C functions
      integer eow, parcon
      logical opcon
C
      xmale=.false.

      anyerr=.false.
      do 10 j=1,nmark
        err=.false.
        p11=hset(currf,j,1)
        p12=hset(currf,j,2)
        call order(p11,p12)
        p21=hset(currm,j,1)
        p22=hset(currm,j,2)
        call order(p21,p22)
        nall=0
        ptyped=0
        if (p11.gt.KNOWN) then
          ptyped=ptyped+1
          call addall(p11,nall,allele)
          call addall(p12,nall,allele)
        end if
        if (p21.gt.KNOWN) then
          ptyped=ptyped+2
          call addall(p21,nall,allele)
          call addall(p22,nall,allele)
        end if
Cx      if (ptyped.ne.3) then
Cx        nset=0
Cx        call initp(p1,p2)
Cx      end if
C do each typed child in the sibship
        do 20 i=sta,fin
        if (hset(i,j,1).gt.KNOWN) then
          thiserr=.false.
          c1=hset(i,j,1)
          c2=hset(i,j,2)
          call order(c1,c2)
C test for simple parent-offspring inconsistency
          if ((ptyped.eq.3 .and.
     2         parcon(c1,c2,p11,p12,p21,p22,xmale).eq.0) .or.
     3        (ptyped.eq.1 .and. .not.opcon(c1,c2,p11,p12)) .or.
     4        (ptyped.eq.2 .and. .not.opcon(c1,c2,p21,p22))) then
            thiserr=.true.
C or too many alleles segregating in sibship
          else
            call addall(c1,nall,allele)
            call addall(c2,nall,allele)
            if (nall.gt.4) then
              thiserr=.true.
C else test for more complex errors
Cx          elseif (.not.err .and. ptyped.ne.3) then
Cx            call nucheck(c1,c2,xmale,nset,p1,p2,thiserr)
            end if
          end if
C If an error, note the responsible child
          if (thiserr) then
            err=.true.
            call wrgtp(c1,c2,gtp,1)
            write(*,'(9a)') 'NOTE:  Inconsistency due child ',
     2        pedigree(1:eop),'-',id(i)(1:eow(id(i))),
     3        ' at locus ',loc(mark(j)),' {',gtp,'}'
          end if
        end if
   20   continue
        if (err) anyerr=.true.
   10 continue

      if (anyerr) write(*,*)
      return
      end
C end-of-check2
C
C Write a trait value as a seven-character string
C
      subroutine wraff7(value,string)
      real value
      character*7 string
      if (value.eq.1.0) then
        string='  UnA  '
      elseif (value.eq.2.0) then
        string='  Aff  '
      else
        string='   ?   '
      end if
      return
      end
C end-of-wraff7
C
C Assess grandparental origin of allele
C
      integer function gpsrc(parent,child,orig,loc,hset)
      integer MAXLOC, MAXHAP, MAXSIZ, MISS
      parameter(MAXLOC=120, MAXHAP=MAXLOC/2, MAXSIZ=1000, MISS=-9999)

      integer  child, loc, orig, parent
C Haplotypes
      integer hset(MAXSIZ,MAXHAP,2)

      integer c1, p1, p2

      gpsrc=0
      c1=abs(hset(child,loc,orig))
      if (-c1.eq.MISS) return

      p1=abs(hset(parent,loc,1))
      p2=abs(hset(parent,loc,2))
      if (c1.eq.p1 .and. c1.ne.p2) then
        gpsrc=1
      elseif (c1.eq.p2 .and. c1.ne.p1) then
        gpsrc=2
      elseif (-p1.ne.MISS .and. c1.ne.p1 .and.
     &        -p2.ne.MISS .and. c1.ne.p2) then
        gpsrc=3
      end if
      return
      end
C end-of-gpsrc
C
C Search for best haplotypes based on simple sharing criterion.
C Called either as preliminary to recmin or in own right.
C Imputes missing parental haplotypes in simple-minded fashion.
C
      subroutine maxshare(currf,currm,gran1,gran2,gran3,gran4,
     &                    sta,fin,iter,nmark,hset)
      integer KNOWN, MAXHAP, MAXLOC, MAXSIZ, MISS
      parameter(KNOWN=0, MAXLOC=120, MAXHAP=MAXLOC/2, MAXSIZ=1000, 
     &          MISS=-9999)

      integer currf, currm, fin, gran1, gran2, gran3, gran4, iter, sta
      integer nmark, hset(MAXSIZ,MAXHAP,2)

      integer nchoice, choice(MAXSIZ)

      integer i, it, j, kids, maxit, newcrit, oldcrit
      integer id1, id2, loc1, loc2, type
      logical gp1, gp2, gp3, gp4, p1, p1imp, p2, p2imp, s1
      real rate, temp
C functions
      integer irandom
      logical metrop
C
C Only visit useful individuals
C
      nchoice=0
      if (gran1.ne.MISS) then
        call addhap(gran1,nmark,hset,nchoice,choice,gp1)
        call addhap(gran2,nmark,hset,nchoice,choice,gp2)
      else
        gp1=.false.
        gp2=.false.
      end if
      if (gran3.ne.MISS) then
        call addhap(gran3,nmark,hset,nchoice,choice,gp3)
        call addhap(gran4,nmark,hset,nchoice,choice,gp4)
      else
        gp3=.false.
        gp4=.false.
      end if
      
      call addhap(currf,nmark,hset,nchoice,choice,p1)
      call addhap(currm,nmark,hset,nchoice,choice,p2)

C
C Mark start of children's IDs in choice()
C
      kids=nchoice+1
      do 2 i=sta,fin
        call addhap(i,nmark,hset,nchoice,choice,s1)
    2 continue

      maxit=max(200,iter)*nmark*nchoice/4
      oldcrit=0
      rate=0.02**(2.0/float(maxit))
      temp=100.0

      do 5 it=1,maxit
C
C Generate proposal: either a single switch or double switch of origin
C
      type=irandom(1,2)
      id1=choice(irandom(1,nchoice))
      loc1=irandom(1,nmark)
      call shuffhap(id1,loc1,hset)
      if (type.eq.2) then
        id2=choice(irandom(1,nchoice))
        loc2=irandom(1,nmark)
        call shuffhap(id2,loc2,hset)
      end if
C Calculate criterion
      newcrit=0
C grandparents v. parents
      if (gp1) then
        call hmatch(gran1,currf,1,1,4,nmark,hset,newcrit)
        call hmatch(gran1,currf,2,1,4,nmark,hset,newcrit)
        if (.not.p1) then
          do 20 i=kids, nchoice
            call hmatch(currf,choice(i),1,1,10,nmark,hset,newcrit)
            call hmatch(currf,choice(i),2,1,10,nmark,hset,newcrit)
   20     continue
        end if
      end if
      if (gp2) then
        call hmatch(gran2,currf,1,2,4,nmark,hset,newcrit)
        call hmatch(gran2,currf,2,2,4,nmark,hset,newcrit)
        if (.not.p1) then
          do 30 i=kids, nchoice
            call hmatch(currf,choice(i),1,1,10,nmark,hset,newcrit)
            call hmatch(currf,choice(i),2,1,10,nmark,hset,newcrit)
   30     continue
        end if
      end if
      if (gp3) then
        call hmatch(gran3,currm,1,1,4,nmark,hset,newcrit)
        call hmatch(gran3,currm,2,1,4,nmark,hset,newcrit)
        if (.not.p2) then
          do 40 i=kids, nchoice
            call hmatch(currf,choice(i),1,2,10,nmark,hset,newcrit)
            call hmatch(currf,choice(i),2,2,10,nmark,hset,newcrit)
   40     continue
        end if
      end if
      if (gp4) then
        call hmatch(gran4,currm,1,2,4,nmark,hset,newcrit)
        call hmatch(gran4,currm,2,2,4,nmark,hset,newcrit)
        if (.not.p2) then
          do 50 i=kids, nchoice
            call hmatch(currf,choice(i),1,2,10,nmark,hset,newcrit)
            call hmatch(currf,choice(i),2,2,10,nmark,hset,newcrit)
   50     continue
        end if
      end if
C parents v. children
      if (p1) then
        do 60 i=kids, nchoice
          call hmatch(currf,choice(i),1,1,10,nmark,hset,newcrit)
          call hmatch(currf,choice(i),2,1,10,nmark,hset,newcrit)
   60   continue
      end if
      if (p2) then
        do 70 i=kids, nchoice
          call hmatch(currm,choice(i),1,2,10,nmark,hset,newcrit)
          call hmatch(currm,choice(i),2,2,10,nmark,hset,newcrit)
   70   continue
      end if
C children v. children
      do 80 i=kids, nchoice-1
      do 80 j=i+1, nchoice
        call hmatch(choice(i),choice(j),1,1,1,nmark,hset,newcrit)
        call hmatch(choice(i),choice(j),2,2,1,nmark,hset,newcrit)
   80 continue
C
C Reverse proposal if worsens fit criterion, else accept new model
C
      if (metrop(newcrit,oldcrit,temp)) then
        oldcrit=newcrit
      else
        call shuffhap(id1,loc1,hset)
        if (type.eq.2) call shuffhap(id2,loc2,hset)
      end if

      temp=rate*temp
C
    5 continue
C
C Impute missing parental genotypes where possible
C Note when there are preexisting imputed genotypes from other marriages
C
      p1imp=.false.
      p2imp=.false.
      do 100 j=1,nmark
        if (.not.p1imp .and. 
     2      (hset(currf,j,1).gt.MISS .and. hset(currf,j,1).lt.KNOWN).or.
     3      (hset(currf,j,2).gt.MISS .and. hset(currf,j,2).lt.KNOWN)) 
     4  then
          p1imp=.true.
        end if
        if (.not.p2imp .and. 
     2      (hset(currm,j,1).gt.MISS .and. hset(currm,j,1).lt.KNOWN).or.
     3      (hset(currm,j,2).gt.MISS .and. hset(currm,j,2).lt.KNOWN)) 
     4  then
          p2imp=.true.
        end if
C Impute paternal alleles based on these children
        if (hset(currf,j,1).eq.MISS .or. hset(currf,j,2).eq.MISS) then
          do 110 i=kids, nchoice
          if (hset(choice(i),j,1).ne.MISS) then
            if (hset(currf,j,1).eq.MISS) then
              hset(currf,j,1)=-hset(choice(i),j,1)
            elseif (hset(currf,j,2).eq.MISS .or. 
     &              hset(currf,j,1).eq.hset(currf,j,2)) then
              hset(currf,j,2)=-hset(choice(i),j,1)
            end if
          end if
  110     continue
        end if
C Impute maternal alleles based on these children
        if (hset(currm,j,1).eq.MISS .or. hset(currm,j,2).eq.MISS) then
          do 120 i=kids, nchoice
          if (hset(choice(i),j,2).ne.MISS) then
            if (hset(currm,j,1).eq.MISS) then
              hset(currm,j,1)=-hset(choice(i),j,2)
            elseif (hset(currm,j,2).eq.MISS .or. 
     &              hset(currm,j,1).eq.hset(currm,j,2)) then
              hset(currm,j,2)=-hset(choice(i),j,2)
            end if
          end if
  120     continue
        end if
  100 continue
C
      if (p1imp) then
        write(*,'(2a/)') 'NOTE:  Some paternal alleles were imputed ',
     &                   'via another marriage.'
      end if
      if (p2imp) then
        write(*,'(2a/)') 'NOTE:  Some maternal alleles were imputed ',
     &                   'via another marriage.'
      end if
C     
      return
      end
C end-of-maxshare
C
C score match of haplotype 1 to haplotype 2: length of match as well as
C absolute number of matches
C
      subroutine hmatch(id1,id2,orig1,orig2,mult,nmark,hset,match)
      integer MAXHAP, MAXLOC, MAXSIZ, MISS
      parameter(MAXLOC=120, MAXHAP=MAXLOC/2, MAXSIZ=1000, MISS=-9999)

      integer id1, id2, match, mult, orig1, orig2
C Haplotypes
      integer nmark, hset(MAXSIZ,MAXHAP,2)
      integer contrib, j, weight

      contrib=0
      weight=0
      do 10 j=1,nmark
      if (hset(id1,j,orig1).eq.hset(id2,j,orig2)) then
        weight=weight+1
        contrib=contrib+weight
      elseif (hset(id1,j,orig1).ne.MISS .and. 
     &        hset(id2,j,orig2).ne.MISS) then
        weight=weight/2
      end if
   10 continue
      match=match+mult*contrib
      return
      end
C end-of-hmatch
