C
C Modified random walk simulation (one iteration) of pedigree 
C missing genotypes (Metropolis-Hastings algorithm) --
C proposal uses founder allele mutations propagated throughout then
C pedigree conditional on (identity by) descent, swapping ibd
C origins for heterozygotes, alternated with 
C a randomization of descent conditional on marker genotype.
C This procedure has the advantage of being quick.  It is speeded further
C for Untyped x Untyped founder matings by resimulating each mating's 
C joint genotype conditional on offspring.
C
      subroutine drop(it,pedigree,num,nfound,id,fa,mo,nummat,
     2                cntmat,untyped,numal,gfrq,set,set2,sibd,
     3                key, plevel)
      integer MAXALL, MAXG, MAXSIZ
      parameter(MAXALL=60, MAXG=MAXALL*(MAXALL+1)/2,
     &          MAXSIZ=1000)

      integer it,plevel
C pedigree structure
      character*10 pedigree
      integer num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ)
C genotypic arrays for pedigree: current, proposed; resulting ibd status
      integer set(MAXSIZ,2), set2(MAXSIZ,2)
      integer sibd(MAXSIZ,2), key(2*MAXSIZ)
C indicator of untyped individual
      logical untyped(MAXSIZ)
C allele frequencies structure
      integer numal
      double precision gfrq(MAXG)
C number of untyped matings -- used to decide number and type of mutations
      integer nummat, cntmat(MAXALL,2)
C local variables
      integer i, par1, par2, typ
      logical xmale
      double precision lr, qa 
C functions
      integer irandom, parcon

      xmale=.false.
C
C Do ibd dropping
C
      typ=irandom(1,3)
      if (plevel.gt.2) then
        write(*,*) 'Proposal type ',type
      end if
      if (typ.eq.1) then
        do 10 i=1,num
          set2(i,1)=set(i,1)
          set2(i,2)=set(i,2)
   10   continue
        call fsimped(it,pedigree,num,nfound,id,fa,mo,set2,sibd,
     &               untyped,key,plevel)
C
C Or mutate founder allele(s)
C
      elseif (typ.eq.2) then
        call simibd(2,pedigree,num,nfound,fa,mo,set,sibd)
        call mutate(numal,num,nfound,set,sibd,set2,untyped)
C
C Or switch parents of origin
C
      else
        call simibd(2,pedigree,num,nfound,fa,mo,set,sibd)
        call switch(num,nfound,fa,mo,set,sibd,set2,untyped)
      end if
C
C Untyped x Untyped founder matings can be treated specially by
C simulating these genotypes conditional on offspring.
C
      do 20 mat=1,nummat
        par1=cntmat(mat,1)
        par2=cntmat(mat,2)
        call simnuc(num,nfound,fa,mo,set2,par1,par2,numal)
   20 continue
C
C now check if the proposal is an acceptable one
C
      if (plevel.gt.2) then
        do 999 i=1,num
          write(*,*) id(i), set(i,1), set(i,2), '->',
     &      set2(i,1), set2(i,2), '{',sibd(i,1),sibd(i,2),'}'
  999   continue
      end if

      lr=1.0d0
      do 100 i=1,nfound
      if (untyped(i)) then
        lr=lr*gfrq(set2(i,2)*(set2(i,2)-1)/2+set2(i,1))/
     &        gfrq(set(i,2)*(set(i,2)-1)/2+set(i,1))
      end if
  100 continue
      do 110 i=nfound+1,num
        par2=parcon(set2(i,1),set2(i,2),set2(fa(i),1),set2(fa(i),2),
     &              set2(mo(i),1),set2(mo(i),2),xmale)
        par1=parcon(set(i,1),set(i,2),set(fa(i),1),set(fa(i),2),
     &              set(mo(i),1),set(mo(i),2),xmale)
        if (par1.ne.par2) then
          lr=lr*dfloat(par2)/dfloat(par1)
        end if
  110 continue
      qa=min(1.0d0,lr)
C
C If accepted, update genotypes
C
      if (qa.gt.random()) then
        if (plevel.gt.2) then
          write(*,*) 'Proposal accepted'
        end if
        do 150 i=1,num
        if (untyped(i)) then
          set(i,1)=set2(i,1)
          set(i,2)=set2(i,2)
        end if
  150   continue
      end if
      if (plevel.gt.1) then
        write(*,*) 'Simulated missing genotypes for iteration ',it
        do 160 i=1,num
        if (untyped(i)) then
          write(*,'(i5,1x,a8,2(1x,i3))') it,id(i),set(i,1),set(i,2)
        end if
  160   continue
      end if
      return
      end
C end-of-drop
C 
C  Simulate parental genotypes for untyped x untyped
C  mating conditional on offspring genotypes
C  Family may be contained within larger pedigree, and
C  multiple spouses are possible
C
      subroutine simnuc(num,nfound,fa,mo,set,par1,par2,numal)
C
C  Pedigree structure
      integer MAXALL, MAXG, MAXSIZ, MISS
      parameter(MAXALL=60, MAXG=MAXALL*(MAXALL+1)/2,
     &          MAXSIZ=1000, MISS=-9999)
      integer num, nfound, fa(MAXSIZ),mo(MAXSIZ), set(MAXSIZ,2)
      integer par1, par2
C local variables
      integer fin, i, sta
      integer target, totp
C functions
      integer irandom

      sta=MISS
      fin=MISS
      do 10 i=nfound+1,num
      if (par1.eq.fa(i) .or. par2.eq.mo(i)) then
        if (sta.eq.MISS) then
          sta=i
          fin=i
        elseif (i.gt.fin) then
          fin=i
        end if
      end if
   10 continue
C
      target=MAXG*MAXG
      call nuclik(fa,mo,set,par1,par2,sta,fin,
     &            numal,target,totp)
      target=irandom(1,totp)
      call nuclik(fa,mo,set,par1,par2,sta,fin,
     &            numal,target,totp)
C
      return
      end
C end-of-simnuc
C
C Nuclik is run twice, once to calculate the total number <totp> of the
C legal genotypes (with target=MAXG*MAXG), the second time to select a 
C parental genotype.
C
      subroutine nuclik(fa,mo,set,par1,par2,sta,fin,
     &                  numal,targt,totp)
      integer MAXSIZ
      parameter(MAXSIZ=1000)
      integer targt, totp
C  Pedigree structure
      integer fa(MAXSIZ),mo(MAXSIZ), set(MAXSIZ,2)
      integer fin, mg1, mg2, par1, par2, pg1, pg2, sta
C allele frequencies structure
      integer numal

C local variables
      integer i
      logical xmale
C functions
      integer parcon
C 
      xmale=.false.
      totp=0

      do 5 mg2=1,numal
      do 5 mg1=1,mg2
      do 5 pg2=1,numal
      do 5 pg1=1,pg2
        set(par1,1)=pg1
        set(par1,2)=pg2
        set(par2,1)=mg1
        set(par2,2)=mg2
        do 10 i=sta,fin
        if ((par1.eq.fa(i) .or. par2.eq.mo(i)) .and. 
     2      parcon(set(i,1),set(i,2),set(fa(i),1),set(fa(i),2),
     3             set(mo(i),1),set(mo(i),2),xmale).eq.0) then
          goto 55
        end if
   10   continue
C
C else (if consistent) add to legal genotypes
C
          totp=totp+1
C
C check to see if have selected current parental genotypes
C
          if (totp.eq.targt) then
            return
          end if
   55   continue
    5 continue
      return
      end
C end-of-nuclik
C
C Mutate 1-4 allele in untyped founders.  Can never fail, due "backmutation".
C
C (1) mutate an allele never transmitted to a typed individual
C (2) swap parent of origin if have no offspring sharing ibd-allele
C
      subroutine mutate(numal,num,nfound,set,sibd,set2,untyped)
      integer MAXSIZ
      parameter (MAXSIZ=1000)
      integer numal
C Pedigree structure
      integer num, nfound
      integer set(MAXSIZ,2), sibd(MAXSIZ,2), set2(MAXSIZ,2)
      logical untyped(MAXSIZ)
C
C mut designates ibd-allele, prop the corresponding marker allele
      integer nmut
      integer mut(4), prop(4)
      integer g1,g2,i,j
C functions
      integer irandom

    1 continue

        nmut=irandom(1,4)
        do 5 j=1,nmut
          mut(j)=irandom(1,2*nfound)
          prop(j)=irandom(1,numal)
    5    continue
         do 10 i=1,num
           g1=set(i,1)
           g2=set(i,2)
           do 15 j=1, nmut
             if (sibd(i,1).eq.mut(j)) g1=prop(j)
             if (sibd(i,2).eq.mut(j)) g2=prop(j)
   15      continue
           call order(g1,g2)
C midloop break
      if ( .not.untyped(i) .and.
     &     (set(i,1).ne.g1 .or. set(i,2).ne.g2)) then
        goto 1
      end if
C
          call update(i,g1,g2,set2)
   10   continue
      return
      end
C end-of-mutate
C
C Do a switch of grandparent of origin of alleles = switch lineage
C
      subroutine switch(num,nfound,fa,mo,set,sibd,set2,untyped)
      integer KNOWN,MAXSIZ,MISS
      parameter (KNOWN=0,MAXSIZ=1000,MISS=-9999)
C Pedigree structure
      integer num, nfound, fa(MAXSIZ), mo(MAXSIZ)
      integer set(MAXSIZ,2), sibd(MAXSIZ,2), set2(MAXSIZ,2)
      logical untyped(MAXSIZ)
C
      integer g(2), i, idx, ntrials, par
      logical fin, xmale

C functions
      integer irandom, parcon

      xmale=.false.
      ntrials=0

    1 continue
C
      ntrials=ntrials+1
C
C give up if <num> unsuccessful trials
C
      if (ntrials.gt.num) then
        do 220 i=1,num
          set2(i,1)=set(i,1)
          set2(i,2)=set(i,2)
  220   continue
        return
      end if
C
C provide a heterozygote candidate with both parents untyped
C
      idx=irandom(nfound+1,num)

      if (set(idx,1).eq.set(idx,2) .or. 
     &     .not.untyped(fa(idx)) .or. .not.untyped(mo(idx))) then
         goto 1
      end if
C 
      do 10 i=1,num
        set2(i,1)=MISS
        set2(i,2)=MISS
   10 continue
      g(2)=set(idx,1)
      g(1)=set(idx,2)
      set2(idx,1)=1
      set2(idx,2)=2
C
C Each iteration moves as far up the pedigree as possible 
C
   15 continue
        fin=.true.
        do 100 i=nfound+1,num
        if (set2(i,1).ne.MISS) then
          par=fa(i)
          if (set2(par,1).eq.MISS .and. untyped(par)) then
            call cpibd(par,i,sibd,set2,KNOWN)
            fin=.false.
          end if
          par=mo(i)
          if (set2(par,1).eq.MISS .and. untyped(par)) then
            call cpibd(par,i,sibd,set2,KNOWN)
            fin=.false.
          end if
        end if
  100   continue
      if (.not.fin) goto 15
C
C See if reached one (loop) or two untyped founders, so swap feasible
C
      par=0
      do 110 i=1,nfound
      if (set2(i,1).gt.KNOWN .or. set2(i,2).gt.KNOWN) then
        par=par+1
      end if
  110 continue
      if (par.eq.0) then
        goto 1
      end if
C
C swap appropriate alleles of simulated genotype
C
      do 150 i=1,num
        if (set2(i,1).gt.KNOWN) set2(i,1)=g(set2(i,1))
        if (set2(i,2).gt.KNOWN) set2(i,2)=g(set2(i,2))
        if (set2(i,1).le.KNOWN) set2(i,1)=set(i,1)
        if (set2(i,2).le.KNOWN) set2(i,2)=set(i,2)
        call order(set2(i,1),set2(i,2))
        if (i.gt.nfound .and. parcon(set2(i,1),set2(i,2),
     2      set2(fa(i),1),set2(fa(i),2),set2(mo(i),1),
     3      set2(mo(i),2), xmale).eq.0) then
          goto 1
        end if
  150 continue
      return
      end
C end-of-switch
C
C Copy ibd for a pair of relatives.
C Person j has a typing-genotype at sibd2, person i does not.
C The typing-allele corresponding to that shared at sibd()
C is "transmitted" to person i from person j.
C
      subroutine cpibd(i,j,sibd,sibd2,imiss)
      integer MAXSIZ, MISS
      parameter(MAXSIZ=1000,MISS=-9999)
      integer i,imiss,j
      integer sibd(MAXSIZ,2), sibd2(MAXSIZ,2)

      if (sibd(i,1).eq.sibd(j,1)) then
        sibd2(i,1)=sibd2(j,1)
      end if
      if (sibd(i,1).eq.sibd(j,2)) then
        sibd2(i,1)=sibd2(j,2)
      end if
      if (sibd(i,2).eq.sibd(j,1)) then
        sibd2(i,2)=sibd2(j,1)
      end if
      if (sibd(i,2).eq.sibd(j,2)) then
        sibd2(i,2)=sibd2(j,2)
      end if
      if (sibd2(i,1).eq.MISS) sibd2(i,1)=imiss
      return
      end
C end-of-cpibd
C
C Simulate (gene-dropping) genotypes at a single locus
C Conditioning on typed ``founder'' genotypes (true founders/marry-ins
C plus individuals without typed parents) heading informative
C chains of descent 
C
      subroutine csimped(num,nfound,fa,mo,untyped,set)
C
C  Pedigree structure
      integer MAXSIZ, MISS
      parameter(MAXSIZ=1000, MISS=-9999)
      integer num,nfound,fa(MAXSIZ),mo(MAXSIZ), set(MAXSIZ,2)
      logical untyped(MAXSIZ)
      integer i
      logical fin
      do 15 i=nfound+1,num
      if (.not.untyped(fa(i)) .and. .not.untyped(mo(i))) then
        set(i,1)=MISS
        set(i,2)=MISS
      end if
   15 continue

C
C Main loop -- only update individuals with two typed parents
C
      iter=0
   20 continue      
        iter=iter+1
        fin=.true.
        do 30 i=nfound+1,num
        if (set(i,1).eq.MISS .and. 
     &      .not.untyped(fa(i)) .and..not.untyped(mo(i))) then
          if (set(fa(i),1).ne.MISS .and. set(mo(i),1).ne.MISS) 
     &    then
            call genoff(i,fa(i),mo(i),set)
          else
            fin=.false.
          end if
        end if
   30   continue
      if (.not.fin) goto 20
      return
      end
C end-of-csimped
C
C Simulate pedigree conditional on all founders (all must be typed) and 
C typed nonfounders
C
      subroutine fsimped(it,pedigree,num,nfound,id,fa,mo,set,sibd,
     &                   untyped,key,plevel)
      integer MAXSIZ, MISS 
      parameter(MAXSIZ=1000, MISS=-9999)
      integer it, plevel
C  Pedigree structure
      character*10 pedigree
      integer num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ)
      integer set(MAXSIZ,2), sibd(MAXSIZ,2)
      integer key(2*MAXSIZ)
      logical untyped(MAXSIZ)
C local variables
      integer found, i, failid, maxtry, restart
      logical fin

      maxtry=2000
      found=0
      do 10 i=1,nfound
        found=found+1
        sibd(i,1)=found
        key(found)=set(i,1)
        found=found+1
        sibd(i,2)=found
        key(found)=set(i,2)
   10 continue
C
C start of loop -- terminated by either a successful simulation
C of ibd & genotypes of nonfounders, or bailout due <maxtry> iterations 
C without success
C
      restart=0
   40 continue
        found=0
        do 15 i=1,nfound
          if (untyped(i)) then
            key(found+1)=-set(i,1)
            key(found+2)=-set(i,2)
          end if
          found=found+2
   15   continue
        do 46 i=nfound+1,num
          sibd(i,1)=MISS
          sibd(i,2)=MISS
   46   continue

   50   continue
          fin=.true.
          do 70 i=nfound+1,num
          if (sibd(i,1).eq.MISS) then
            if (sibd(fa(i),1).ne.MISS .and. sibd(mo(i),1).ne.MISS) then
              call genof4(i,fa(i),mo(i),set,sibd,untyped,key,failid)
              if (failid.ne.MISS) then
                if (restart.lt.maxtry) then
                  restart=restart+1
                  goto 40
                else
                  if (plevel.gt.0) then
                    write(*,'(/a,i4,a/7x,a,a8,2a/)') 
     2 'NOTE:  In iteration ',it,' of the Metropolis algorithm, ',
     3        'simulation of ibd had to restart due to person ',
     4        id(failid),' in pedigree ',pedigree
                    if (plevel.gt.1) then
                      do 997 j=1,nfound
                        write(*,'(a8,a,2(1x,i3),a,2(1x,i3),a,l1)') 
     2                    id(j),'       x       x',set(j,1), set(j,2),
     3                    ' {', sibd(j,1),sibd(j,2), '} ',untyped(j)
  997                 continue
                      do 998 j=nfound+1,num
                        write(*,'(3a8,2(1x,i3),a,2(1x,i3),a,l1)') 
     2                    id(j),id(fa(j)),id(mo(j)), set(j,1), set(j,2),
     3                    ' {', sibd(j,1),sibd(j,2), '} ',untyped(j)
  998                 continue
                    end if
                  end if
                  call simibd(2,pedigree,num,nfound,fa,mo,set,sibd)
                  return
                end if
              end if
            else
              fin=.false.
            end if
          end if
   70     continue
      if (.not.fin) goto 50
C
      call fill2(num,set,sibd,untyped,key)
      return
      end
C end-of-fsimped
C
C  Drop ibd-alleles conditional on observed markers
C  and randomly where marker genotype not observed -- restart
C  if later generates inconsistency
C  This version assumes all founders are typed 
C 
      subroutine genof4(idx,fa,mo,set,sibd,untyped,key,failid)
      integer KNOWN, MAXSIZ, MISS
      parameter(KNOWN=0, MAXSIZ=1000, MISS=-9999)
      integer idx,fa,mo,failid
      integer set(MAXSIZ,2),sibd(MAXSIZ,2),key(2*MAXSIZ)
      logical untyped(MAXSIZ)
      integer a1,a2,first,maxtrials, second, tr1,tr2,trials
C sample without replacement from {{1,2},{1,2}}
      integer choice, i, seed, space(4)
C functions
      integer irandom

C
      failid=MISS
      maxtrials=4
      trials=0
      do 10 i=1,maxtrials
        space(i)=i
   10 continue

    1 continue

      trials=trials+1
      choice=irandom(trials, maxtrials)
      seed=space(choice)
      space(choice)=space(trials)

#ifdef F2C
      tr1=and(seed,2)/2+1
      tr2=and(seed,1)+1
#endif F2C
#ifdef HPUX
      tr2=iand(seed,2)/2+1
      tr1=iand(seed,1)+1
#endif HPUX
#ifdef DEC
      tr1=iand(seed,2)/2+1
      tr2=iand(seed,1)+1
#endif DEC
#ifdef SUN
      tr1=and(seed,2)/2+1
      tr2=and(seed,1)+1
#endif SUN

      a1=sibd(fa,tr1)
      a2=sibd(mo,tr2)

C     write(*,*) 'In GENOF4():'
C      
C     write(*,*) 'Alleles: ',key(1),key(2),key(3),key(4),key(5),key(6)
C     write(*,*) 'Person #',idx,set(idx,1),'/',set(idx,2),
C    &           ' Untyped: ',untyped(idx)
C     write(*,*) 'Father #',fa, set(fa,1),'/',set(fa,2),
C    &           ' Untyped: ',untyped(fa)
C     write(*,*) 'Mother #',mo, set(mo,1),'/',set(mo,2),
C    &           ' Untyped: ',untyped(mo)
C     write(*,*) 'Transmitting: ',a1,' [',key(a1),' ], ',
C    &                            a2,' [',key(a2),' ]'
C
      if (untyped(idx)) then
        sibd(idx,1)=a1
        sibd(idx,2)=a2
      elseif (key(a1).lt.KNOWN .and. key(a2).lt.KNOWN) then
        first=irandom(1,2)
        second=3-first
        sibd(idx,first)=a1
        sibd(idx,second)=a2
        key(a1)=set(idx,first)
        key(a2)=set(idx,second)
      elseif (key(a1).lt.KNOWN .and. set(idx,1).eq.key(a2)) then
        sibd(idx,1)=a2
        sibd(idx,2)=a1
        key(a1)=set(idx,2)
      elseif (key(a1).lt.KNOWN .and. set(idx,2).eq.key(a2)) then
        sibd(idx,1)=a1
        sibd(idx,2)=a2
        key(a1)=set(idx,1)
      elseif (key(a2).lt.KNOWN .and. set(idx,2).eq.key(a1)) then
        sibd(idx,1)=a2
        sibd(idx,2)=a1
        key(a2)=set(idx,1)
      elseif (key(a2).lt.KNOWN .and. set(idx,1).eq.key(a1)) then
        sibd(idx,1)=a1
        sibd(idx,2)=a2
        key(a2)=set(idx,2)
      elseif (set(idx,1).eq.key(a1) .and. 
     &        set(idx,2).eq.key(a2)) then
        sibd(idx,1)=a1
        sibd(idx,2)=a2
      elseif (set(idx,1).eq.key(a2) .and. 
     &        set(idx,2).eq.key(a1)) then
        sibd(idx,1)=a2
        sibd(idx,2)=a1
      elseif (trials.lt.maxtrials) then
        goto 1
      else
        failid=idx
      end if
      return
      end
C end-of-genof4
C
C infer missing genotypes based on sibd values after run of fsimped
C assume all founders are typed
C
      subroutine fill2(num,set,sibd,untyped,key)
      integer MAXSIZ
      parameter(MAXSIZ=1000)
C  Pedigree structure
      integer num, set(MAXSIZ,2), sibd(MAXSIZ,2), key(2*MAXSIZ)
      logical untyped(MAXSIZ)
C local variables
      integer g1,g2,i,tmp
C
      do 5 i=1,num
      if (untyped(i)) then
        g1=abs(key(sibd(i,1)))
        g2=abs(key(sibd(i,2)))
        if (g1.gt.g2) then
          tmp=g1
          g1=g2
          g2=tmp
          tmp=sibd(i,1)
          sibd(i,1)=sibd(i,2)
          sibd(i,2)=tmp
        end if
        set(i,1)=g1
        set(i,2)=g2
      end if
    5 continue
      return
      end
C end-of-fill2
C 
C  Simulate (gene-dropping) genotypes at a single locus
C  in a pedigree of arbitrary complexity 
C
      subroutine simped(num,nfound,fa,mo,cumfrq,set)
C
C  Pedigree structure
      integer MAXSIZ, MISS, MAXALL
      parameter(MAXSIZ=1000, MISS=-9999, MAXALL=60)
      integer num, nfound, fa(MAXSIZ),mo(MAXSIZ), set(MAXSIZ,2)
      double precision cumfrq(MAXALL)
      integer i
      logical fin
      do 10 i=1,nfound
         call found(cumfrq,set(i,1))
         call found(cumfrq,set(i,2))
         call order(set(i,1),set(i,2))
   10 continue
      do 15 i=nfound+1,num
         set(i,1)=MISS
         set(i,2)=MISS
   15 continue

   20 continue      
        fin=.true.
        do 30 i=nfound+1,num
        if (set(i,1).eq.MISS) then
          if (set(fa(i),1).ne.MISS.and.set(mo(i),1).ne.MISS) 
     &    then
            call genoff(i,fa(i),mo(i),set)
          else
            fin=.false.
          end if
        end if
   30   continue
      if (.not.fin) goto 20
      return
      end
C end-of-simped
C
C founder frequency
C
      subroutine found(cumfrq,allele)
      integer MAXALL
      parameter(MAXALL=60)
      integer allele
      double precision cumfrq(MAXALL)
      real x
C functions
      real random
      x=random()
      allele=0
   10 continue
        allele=allele+1
      if (x.gt.cumfrq(allele)) goto 10
      return
      end
C end-of-found
C
C transmit genes from parents to child
C 
      subroutine genoff(idx,fa,mo,set)
      integer MAXSIZ
      parameter(MAXSIZ=1000)
      integer idx,fa,mo,set(MAXSIZ,2),a1,a2
      real random
      if (random().gt.0.5) then
        a1=set(fa,1)
      else
        a1=set(fa,2)
      end if
      if (random().gt.0.5) then
        a2=set(mo,1)
      else
        a2=set(mo,2)
      end if
      if (a1.gt.a2) then
        set(idx,1)=a2
        set(idx,2)=a1
      else
        set(idx,1)=a1
        set(idx,2)=a2
      end if
      return
      end
C end-of-genoff
C 
C  Given genotypes at a single locus in a pedigree of arbitrary complexity, 
C  generate ibd by gene dropping a perfectly informative marker a la
C  John Blangero.
C  Type=1 unconditional, =2, conditional on observed markers
C
      subroutine simibd(typ,pedigree,num,nfound,fa,mo,set,sibd)
C
C  Pedigree structure
      integer MAXSIZ, MISS
      parameter(MAXSIZ=1000, MISS=-9999)
      character*10 pedigree
      integer typ, num, nfound, fa(MAXSIZ),mo(MAXSIZ)
      integer set(MAXSIZ,2), sibd(MAXSIZ,2)
      integer i, found
      logical fin
      found=0
      do 10 i=1,nfound
        found=found+1
        sibd(i,1)=found
        found=found+1
        sibd(i,2)=found
   10 continue
      do 15 i=nfound+1,num
        sibd(i,1)=MISS
        sibd(i,2)=MISS
   15 continue
C
      if (typ.eq.1) then
   20   continue      
          fin=.true.
          do 30 i=nfound+1,num
          if (sibd(i,1).eq.MISS) then
            if (sibd(fa(i),1).ne.MISS.and.sibd(mo(i),1).ne.MISS) 
     &      then
              call genoff(i,fa(i),mo(i),sibd)
             else
              fin=.false.
            end if
          end if
   30     continue
        if (.not.fin) goto 20
      elseif (typ.eq.2) then
   50   continue      
          fin=.true.
          do 60 i=nfound+1,num
          if (sibd(i,1).eq.MISS) then
            if (sibd(fa(i),1).ne.MISS.and.sibd(mo(i),1).ne.MISS) 
     &      then
              call genof2(pedigree,i,fa(i),mo(i),set,sibd)
            else
              fin=.false.
            end if
          end if
   60     continue
        if (.not.fin) goto 50
      end if
      return
      end
C end-of-simibd
C
C transmit ibd-marker from parents to child, 
C test if consistent with observed marker
C In this version 12/99, the sibd pairs are ordered by the collating
C order of the marker alleles they represent and
C not the collating order of the sibd allele.
C 
      subroutine genof2(pedigree,idx,fa,mo,set,sibd)
      integer MAXSIZ
      parameter(MAXSIZ=1000)
      character*10 pedigree
      integer idx,fa,mo,set(MAXSIZ,2),sibd(MAXSIZ,2)
      integer c1, c2, maxtrials, par1, par2, tr1, tr2, trials
C sample without replacement from {{1,2},{1,2}}
      integer choice, i, seed, space(4)
C functions
      integer irandom
C
      maxtrials=4
      trials=0
      do 10 i=1,maxtrials
        space(i)=i
   10 continue

      c1=set(idx,1)
      c2=set(idx,2)
    1 continue
        trials=trials+1
        choice=irandom(trials, maxtrials)
        seed=space(choice)
        space(choice)=space(trials)

#ifdef F2C
        tr1=and(seed,2)/2+1
        tr2=and(seed,1)+1
#endif F2C
#ifdef HPUX
        tr2=iand(seed,2)/2+1
        tr1=iand(seed,1)+1
#endif HPUX
#ifdef DEC
        tr1=iand(seed,2)/2+1
        tr2=iand(seed,1)+1
#endif DEC
#ifdef SUN
        tr1=and(seed,2)/2+1
        tr2=and(seed,1)+1
#endif SUN

        par1=set(fa,tr1)
        par2=set(mo,tr2)
C
C     write(*,*) 'Prop: ',trials,' choice:',choice,
C    2   ' space: ',(space(i),i=1,4),
C    3   ' seed: ',seed,'-> ',tr1,tr2
      if (c1.eq.par1 .and. c2.eq.par2) then
        sibd(idx,1)=sibd(fa,tr1)
        sibd(idx,2)=sibd(mo,tr2)
      elseif (c1.eq.par2.and.c2.eq.par1) then
        sibd(idx,1)=sibd(mo,tr2)
        sibd(idx,2)=sibd(fa,tr1)
      elseif (trials.lt.maxtrials) then
        goto 1
      else 
        write(*,'(a/7x,a/a/)') 
     2    'ERROR: Probable mendelian inconsistency encountered',
     3    'performing ibd simulation.  Stopping prematurely.'
        write(*,*) 'In pedigree ',pedigree,', index person #',idx,
     2    ' has genotype: ',c1,c2,' Parental genotypes: ',
     3    set(fa,1),set(fa,2),' & ',set(mo,1),set(mo,2)
        stop
      end if
      return
      end
C end-of-genof2
C
C count the untyped founder x founder matings for use by Metropolis algs
C
      subroutine tabmat(num,nfound,fa,mo,untyped,nummat,cntmat)
      integer MAXALL, MAXSIZ
      parameter(MAXALL=60, MAXSIZ=1000)
      integer num,nfound,fa(MAXSIZ),mo(MAXSIZ)
      logical untyped(MAXSIZ)
      integer nummat, cntmat(MAXALL,2)
C local variables
      integer i

      nummat=0
      do 5 i=1,MAXALL
        cntmat(i,1)=0
        cntmat(i,2)=0
    5 continue
      do 10 i=nfound+1,num
      if (untyped(fa(i)) .and. untyped(mo(i)) .and.
     &    fa(i).le.nfound .and. mo(i).le.nfound) then
        call mattab(fa(i),mo(i),nummat,cntmat)
      end if
   10 continue 
      return
      end
C end-of-tabmat
C
C update list of matings -- simple insertion sort
C
      subroutine mattab(key1,key2,num,cnt)
      integer MAXALL
      parameter(MAXALL=60)
      integer key1, key2, num, cnt(MAXALL,2)
      integer i,pos
      pos=0
    1 continue 
        pos=pos+1
      if (pos.le.num .and. (key1.gt.cnt(pos,1) .or.
     &    (key1.eq.cnt(pos,1) .and. key2.gt.cnt(pos,2)))) goto 1
      if (pos.gt.num .or. key2.ne.cnt(pos,2)) then
        if (num.gt.MAXALL) then
          write(*,'(a,i2,a/)') 
     &      'ERROR: More than ',MAXALL,' UnT x UnT founder matings.'
        else
          do 2 i=num,pos,-1
            cnt(i+1,1)=cnt(i,1)
            cnt(i+1,2)=cnt(i,2)
    2     continue
          num=num+1
          cnt(pos,1)=key1
          cnt(pos,2)=key2
        end if
      end if
      return
      end
C end-of-mattab
