C
C read in pedigree 
C
      subroutine pedin(strm,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)

      integer LINSIZ,MAXSIZ,MAXLOC,MAXCOL,MISS
      parameter (LINSIZ=1024,MAXSIZ=1000,MAXLOC=120,MAXCOL=MAXLOC+5,
     &           MISS=-9999)

      character*20 words(MAXCOL)
      character*(LINSIZ) lin

      integer higen, narg, nfam, nwarn, plevel, strm, wrk, wrk2
      logical addsex, famerr, last, link
C Pedigree structure
      character*10 pedigree
      integer num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ)
      integer numloc
      real locus(MAXSIZ,MAXLOC)
C Work arrays for sorting etc
      integer key1(MAXSIZ),key2(MAXSIZ),key3(MAXSIZ),ord(MAXSIZ)  
      integer set(MAXSIZ,2)

      integer col,extra,eop,i,nerr,nfields,nid,offset,pos,sexfa,sexmo
      character*8 cfa, cid, cmo
C functions
      integer eow  
      real fval

      eop=0
      extra=0
      last=.false.
      nerr=0
      nfound=0 
      nid=0
      num=0
      offset=5
      if (addsex) offset=4
      nfields=offset+numloc
      pedigree=' '

      do 2 i=1,MAXSIZ
        key2(i)=0
    2 continue
C
C Read in pedigree data
C
    5 continue
        read(strm,'(a)',end=14) lin
        narg=MAXCOL
        call args(lin,narg,words,3)
        if (words(1)(1:1).eq.'!' .or. words(1)(1:1).eq.'#') then
          if (plevel.gt.1) write(*,'(a)') lin(1:79)
        elseif (words(1).eq.' ') then
          continue
        elseif (words(1).eq.'pedigree') then
          continue
        elseif (pedigree.eq.words(1)(1:10) .or. num.eq.0) then
          if (num.eq.0) then
            pedigree=words(1)(1:10)
            eop=eow(pedigree)
          elseif (nid.ge.MAXSIZ) then
            write(*,'(/3a,i4,a/7x,a/)') 
     2        'ERROR: Number of members for pedigree ',
     3        pedigree(1:eop), ' exceeds ',MAXSIZ,
     4        ', the maximum allowed.', 'Stopping prematurely.'
            close(strm,status='keep')
            close(wrk,status='delete')
            close(wrk2,status='delete')
            stop
          end if
          if (narg.ne.nfields) then
            nwarn=nwarn+1
            if (nwarn.le.25) then
              if (narg.lt.nfields) then
                write(*,'(/a/7x,a/)') 
     2          'ERROR: Insufficient number of data fields in:',
     3                  lin(1:72)
              else
                write(*,'(/a/7x,a/)') 
     2          'NOTE:  Excessive number of data fields in:',
     3                  lin(1:72)
              end if
            end if
          end if
          num=num+1
          pedigree=words(1)(1:10)
          cid=words(2)(1:8)
          cfa=words(3)(1:8)
          cmo=words(4)(1:8)
C sex
          sex(num)=MISS
          if (words(5).eq.'f'.or.words(5).eq.'F'.or.words(5).eq.'2') 
     &    then
            sex(num)=2
          elseif (words(5).eq.'m'.or.words(5).eq.'M'.or.words(5).eq.'1')
     &    then
            sex(num)=1
          end if
C sex may also be requested as a quantitative variable
          if (addsex) then
            if (sex(num).eq.2) then
              locus(num,1)=0.0
            elseif (sex(num).eq.1) then
              locus(num,1)=1.0
            else
              locus(num,1)=0.5
            end if
          end if
C
C all other variables
          col=5-offset
          if (link) then
            do 20 j=6,narg
              col=col+1
              locus(num,col)=fval(words(j))
              if (fval(words(j)).eq.0.0) locus(num,col)=MISS
   20       continue
          else
            do 30 j=6,narg
              col=col+1
              locus(num,col)=fval(words(j))
   30       continue
          end if
C
C pad if short of data
          do 40 j=col+1,numloc
            locus(num,j)=MISS
   40     continue
C
C Tabulate individual IDs, creating a pointer to the table of IDs,
C and a pointer to the position of the person
C
          call tabid(cid,nid,id,key2,1,key1(num))
          ord(key1(num))=num

          if (cfa.eq.'0'.or.cfa.eq.'X'.or.cfa.eq.'.') cfa='x'
          if (cmo.eq.'0'.or.cmo.eq.'X'.or.cmo.eq.'.') cmo='x'

          if (cid.eq.cfa .or. cid.eq.cmo) then
            write(*,'(/5a/)') 'ERROR: Person ',
     &        pedigree(1:eop),'-', cid(1:eow(cid)),' is his own parent.'
            famerr=.true.
          else if (cfa.ne.'x' .and. cfa.eq.cmo) then
            write(*,'(/7a/)') 'ERROR: Person ',
     2        pedigree(1:eop),'-', cfa(1:eow(cid)),
     3        ' is both father and mother of ', cid(1:eow(cid)),'.'
            famerr=.true.
          end if
C
C Tabulate parental IDs
C adding extra records where a parental ID is not specified
C
C nonfounder
          if (cfa.ne.'x' .and. cmo.ne.'x') then
            call tabid(cfa,nid,id,key2,0,fa(num))
            call tabid(cmo,nid,id,key2,0,mo(num))
C founder
          elseif (cfa.eq.'x' .and. cmo.eq.'x') then 
            nfound=nfound+1
            fa(num)=MISS
            mo(num)=MISS
C nonfounder with one parent not specified -- check if enough storage space
          elseif (nid.ge.MAXSIZ) then 
            write(*,'(/3a,i4,a/7x,a/)') 
     2        'ERROR: Number of members for pedigree ',
     3        pedigree(1:eop), ' will exceed ',MAXSIZ,
     4        ', the maximum allowed if a dummy record created.', 
     5        'Stopping prematurely.'
            close(strm,status='keep')
            close(wrk,status='delete')
            close(wrk2,status='delete')
            stop
C create new father
          elseif (cfa.eq.'x') then 
            call tabid(cmo,nid,id,key2,0,mo(num))
            extra=extra+1
            nid=nid+1
            fa(num)=nid
            write(cfa,'(a2,i3.3)') 'ZZ',extra
            id(nid)=cfa
            call mkdummy(num,nfound,1,addsex,fa,mo,sex,numloc,locus)
            ord(nid)=num
            key1(num)=nid
            key2(nid)=1
            if (plevel.ge.0) then
              write(*,'(/8a/)') 'NOTE:  Father of person ',
     2          pedigree(1:eop),'-',cid(1:eow(cid)),
     3          ' not specified.  Creating ',
     4          pedigree(1:eop),'-',cfa(1:eow(cfa)) 
            end if
C create new mother
          elseif (cmo.eq.'x') then 
            call tabid(cfa,nid,id,key2,0,fa(num))
            extra=extra+1
            nid=nid+1
            mo(num)=nid
            write(cmo,'(a2,i3.3)') 'ZZ',extra
            id(nid)=cmo
            call mkdummy(num,nfound,2,addsex,fa,mo,sex,numloc,locus)
            ord(nid)=num
            key1(num)=nid
            key2(nid)=1
            if (plevel.ge.0) then
              write(*,'(/8a/)') 'NOTE:  Mother of person ',
     2          pedigree(1:eop),'-',cid(1:eow(cid)),
     3          ' not specified.  Creating ',
     4          pedigree(1:eop),'-',cmo(1:eow(cmo)) 
            end if
          end if
        else
          backspace(strm)
          goto 15
        end if
        goto 5
C
C end of while loop
C
   14 last=.true.
   15 continue
C
C Check for errors 
C
      if (famerr) return
C By individual 
      do 100 i=1,nid
        if (key2(i).gt.1) then
          write(*,'(/5a/)') 'ERROR: Duplicate record for person ',
     &      pedigree(1:eop),'-',id(i)(1:eow(id(i))),'.'
          nerr=1
        elseif (key2(i).eq.0) then
          if (plevel.ge.0) then
            write(*,'(/5a/)') 'NOTE:  Creating dummy record for ',
     &        pedigree(1:eop),'-',id(i)(1:eow(id(i))),'.'
          end if
          if (num.eq.MAXSIZ) then
            write(*,'(/3a,i4,a/7x,a/)') 
     2        'ERROR: Number of members for pedigree ',
     3        pedigree(1:eop), ' will exceed ',MAXSIZ,
     4        ', the maximum allowed.', 'Stopping prematurely.'
            close(strm,status='keep')
            close(wrk,status='delete')
            close(wrk2,status='delete')
            stop
          end if
          j=MISS
          call mkdummy(num,nfound,j,addsex,fa,mo,sex,numloc,locus)
          ord(i)=num
          key1(num)=i
        end if
  100 continue
C
C By mating
      do 110 i=1,nid
      if (fa(i).ne.MISS .and. mo(i).ne.MISS) then
        sexfa=sex(ord(fa(i)))
        sexmo=sex(ord(mo(i)))
        if (sexfa.eq.1 .and. sexmo.eq.2) goto 110

        if ((sexfa.eq.2 .and. (sexmo.eq.1.or.sexmo.eq.MISS)) .or.
     &           (sexfa.eq.MISS .and. sexmo.eq.1)) then
          if (plevel.ge.0) then
            write(*,'(/5a/)') 'NOTE: Father and mother of person ',
     2        pedigree(1:eop),'-',id(i)(1:eow(id(i))),
     3        ' appear to be swapped around.  Reordering.'
          end if
          j=fa(i)
          fa(i)=mo(i)
          mo(i)=j
          sexfa=sex(ord(fa(i)))
          sexmo=sex(ord(mo(i)))
        elseif (sexfa.ne.MISS .and. sexfa.eq.sexmo) then
          write(*,'(/5a/)') 'ERROR: Parents of person ',
     2      pedigree(1:eop),'-',id(i)(1:eow(id(i))),
     3      ' appear to be the same sex.'
          nerr=1
        end if
C
C one reordered, fill in missing sexes
        if (sexfa.eq.1 .and. sexmo.eq.MISS) then
          if (plevel.ge.0) then
            write(*,'(/5a/7x,a)') 'NOTE:  Person ',
     2        pedigree(1:eop),'-',id(mo(i))(1:eow(id(mo(i)))),
     3        ' appears as a mother and sex was unspecified.',
     4        'Setting sex to female.'
          end if
          sex(ord(mo(i)))=2
        else if (sexfa.eq.MISS .and. sexmo.eq.2) then
          if (plevel.ge.0) then
            write(*,'(/5a/7x,a)') 'NOTE:  Person ',
     2        pedigree(1:eop),'-',id(fa(i))(1:eow(id(fa(i)))),
     3        ' appears as a father and sex was unspecified.',
     4        'Setting sex to male.'
          end if
          sex(ord(fa(i)))=1
        else if (sexfa.eq.MISS .and. sexmo.eq.MISS) then
          sex(ord(fa(i)))=1
          sex(ord(mo(i)))=2
        end if
      end if
  110 continue
      if (nerr.ne.0) then
        famerr=.true.
        return
      end if
C
C Sort the pedigree on generation number, id, and parental ID,
C returning the sorted position in ord
C
      call famsort(pedigree,num,nfound,nid,id,key1,fa,mo,key2,key3,ord,
     &             set,higen,nfam,nerr,plevel)
C
C Catch pedigree errors
      if (nerr.ne.0) then
        famerr=.true.
        return
      end if
C
C reorder the pedigree using external file
C
      do 140 i=1,num
        key2(ord(i))=i
  140 continue
      do 150 i=1,num
        pos=ord(i)
        if (fa(pos).ne.MISS) then
          write(wrk2) id(key1(pos)),key2(fa(pos)),key2(mo(pos)),
     &      sex(pos), (locus(pos,j),j=1,numloc)
        else
          write(wrk2) id(key1(pos)),MISS,MISS, sex(pos), 
     &      (locus(pos,j),j=1,numloc)
        end if
  150 continue
      rewind(wrk2)
      do 160 i=1,num
        read(wrk2) id(i),fa(i),mo(i),sex(i),(locus(i,j),j=1,numloc)
  160 continue
      return
      end
C end-of-pedin
C
C Tabulate alphanumeric IDs in order of appearance
C
      subroutine tabid(curid,nid,id,count,inc,pos)
      integer MAXSIZ, MISS
      parameter (MAXSIZ=1000,MISS=-9999)

      integer nid, pos
      character*8 curid  

      character*8 id(MAXSIZ)
      integer count(MAXSIZ)

      do 10 pos=1,nid
      if (id(pos).eq.curid) then
        count(pos)=count(pos)+inc
        return 
      end if
   10 continue

      if (nid.lt.MAXSIZ) then
        nid=nid+1
        pos=nid
        id(pos)=curid
        count(pos)=inc
      else
        pos=MISS
        write(*,'(a,i5,a/)') 'ERROR: More than ',MAXSIZ,' IDs in family'
      end if
      return
      end
C end-of-tabid
C
C Work out generation number ord(), then sort family on 
C founder status, generation number, parental ID, 
C and personal ID giving their position in ord().
C Returns the ranking in ord(), and the depth of the pedigree in higen
C
      subroutine famsort(pedigree,num,nfound,nid,id,pid,fa,mo,
     &                   key1,key2,ord,set,higen,nfam,nerr,plevel)
      integer MAXSIZ, MISS
      parameter (MAXSIZ=1000,MISS=-9999)
      integer higen, nerr, nfam, plevel
C Pedigree structure
      character*10 pedigree 
      character*8 id(MAXSIZ)
      integer num,nfound,pid(MAXSIZ),fa(MAXSIZ),mo(MAXSIZ)
      integer key1(MAXSIZ), key2(MAXSIZ), ord(MAXSIZ), set(MAXSIZ,2)
C
      integer curkey1, curkey2, i, maxgrp, nsub, stratum
C
C nsub=number of disjoint subpedigrees within "pedigree"; higen=number of
C generations in family; subped no. 1 largest, size maxgrp
C
C first change the parental ID pointer from id table position 
C to file position as required by connect() and gener()
C
      do 15 i=1,num
      if (fa(i).ne.MISS) then
        fa(i)=ord(fa(i))
        mo(i)=ord(mo(i))
      end if
   15 continue
C
C determine collating order of IDs in table
C
      call ascend(nid, key1)
      call csort(nid, id, key1)
C
C create reverse index from sorted table to original records
C so that the multiple key sort can be performed
C
      call ascend(nid, ord)
      call isort(1, nid, key1, ord, 2)
      do 20 i=1,num
        pid(i)=ord(pid(i))
   20 continue
C
C determine if one or more subpedigrees are present
C
      call connect(num,fa,mo,set,nsub,maxgrp)
C
C list any subpedigrees
C
      if (nsub.gt.1) then
        call wrsubped(pedigree,num,id,pid,set,nsub,maxgrp,plevel)
      end if
C
C get the generation number
C
      call gener(pedigree,num,fa,mo,nsub,set,key1,higen,nerr,plevel)
C
C and sort on generation number and foundership
C
      do 60 i=1,num
      if (fa(i).ne.MISS) then
        key1(i)=higen+key1(i)
      end if
   60 continue
      call ascend(num,ord)
      call isort(1,num,key1,ord,2)
C now on paternal ID
      do 160 i=nfound+1,num
        key2(i)=pid(fa(ord(i)))
  160 continue
      call msdsort(nfound+1,num,key1,key2,ord)
C now on maternal ID
      stratum=0
      curkey1=MISS
      curkey2=MISS
      do 260 i=nfound+1,num
        if (key1(i).ne.curkey1 .or. 
     &      key1(i).eq.curkey1 .and. key2(i).ne.curkey2) then
          stratum=stratum+1
          curkey1=key1(i)
          curkey2=key2(i)
        end if
        key2(i)=stratum
        key1(i)=pid(mo(ord(i)))
  260 continue
      call msdsort(nfound+1,num,key2,key1,ord)
C now on ID
      do 360 i=1,nfound
        key1(i)=0
        key2(i)=pid(ord(i))
  360 continue
      stratum=0
      curkey1=MISS
      curkey2=MISS
      do 370 i=nfound+1,num
        if (key2(i).ne.curkey1 .or. key1(i).ne.curkey2) then
          stratum=stratum+1
          curkey1=key2(i)
          curkey2=key1(i)
        end if
        key1(i)=stratum
        key2(i)=pid(ord(i))
  370 continue
      call isort(1, nfound, key2, ord, 2)
      call msdsort(nfound+1,num,key1,key2,ord)
      nfam=stratum
      return
      end
C end-of-famsort
C
C MSD radix sort key1, key2
C
      subroutine msdsort(bot,top,key1,key2,ord)
      integer MAXSIZ
      parameter(MAXSIZ=1000)
      integer bot, top
      integer key1(MAXSIZ),key2(MAXSIZ),ord(MAXSIZ)
      integer curkey,fin,i,sta

      curkey=key1(bot)
      sta=bot
      fin=bot
      do 197 i=bot+1,top
        if (key1(i).eq.curkey) then
          fin=i
        else
          call isort(sta, fin, key2, ord, 2)
          sta=i
          fin=i
          curkey=key1(sta)
        end if
  197 continue
      call isort(sta, fin, key2, ord, 2)
      return
      end
C end-of-msdsort
C
C Create dummy records for added individals
C
      subroutine mkdummy(num,nfound,sx,addsex,fa,mo,sex,numloc,locus)
      integer MAXLOC, MAXSIZ, MISS
      parameter (MAXLOC=120,MAXSIZ=1000,MISS=-9999)

      integer nfound,num,numloc,sx
      logical addsex
      integer fa(MAXSIZ),mo(MAXSIZ),sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
      integer j

      num=num+1
      nfound=nfound+1
      fa(num)=MISS
      mo(num)=MISS
      sex(num)=sx
      do 15 j=1,numloc
        locus(num,j)=MISS
   15 continue
      if (addsex) then
        if (sex(num).eq.2) then
          locus(num,1)=0.0
        elseif (sex(num).eq.1) then
          locus(num,1)=1.0
        else
          locus(num,1)=0.5
        end if
      end if
      return
      end
C end-of-mkdummy
C
C Read pedigree from work file
C
      subroutine wrkin(wrk,pedigree,actset, num,nfound,id,fa,mo,sex,
     &                 locus,numloc,last)
      integer MAXSIZ,MAXLOC
      parameter (MAXSIZ=1000,MAXLOC=120)
C Pedigree structure
      character*10 pedigree
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ)
      integer actset,num,nfound,numloc,wrk
      real locus(MAXSIZ,MAXLOC)
      logical last
      integer i,j
      last=.false.
      read(wrk,end=30) pedigree,actset,num,nfound
      do 20 i=1,num
        read(wrk) id(i),fa(i),mo(i),sex(i),(locus(i,j),j=1,numloc)
   20 continue
      return
C
   30 last=.true.
      return
      end
C end-of-wrkin
C
C Write pedigree to work file
C
      subroutine wrkout(wrk,pedigree,actset,num,nfound,id,fa,mo,sex,
     &                  locus,numloc)
      integer MAXSIZ,MAXLOC
      parameter (MAXSIZ=1000,MAXLOC=120)
C Pedigree structure
      character*10 pedigree
      integer actset, num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ)
      integer numloc,wrk
      real locus(MAXSIZ,MAXLOC)
      integer i

      write(wrk) pedigree, actset, num, nfound
      do 10 i=1,num
        write(wrk) id(i),fa(i),mo(i),sex(i),(locus(i,j),j=1,numloc)
   10 continue
      return
      end
C end-of-wrkout
C
C Add extra blank columns to the dataset
C
      subroutine addvar(wrk,twrk,newloc,pedigree,actset,num,nfound,
     &                  id,fa,mo,sex,locus,numloc)
      integer MAXSIZ, MAXLOC, MISS
      parameter(MAXSIZ=1000, MAXLOC=120, MISS=-9999)

      integer newloc, wrk, twrk

      character*10 pedigree
      integer num,nfound 
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ),mo(MAXSIZ),sex(MAXSIZ)
      integer numloc
      real locus(MAXSIZ,MAXLOC)
C
      integer actset,i,j
      logical last

      last=.false.
      rewind(wrk)
   10 continue
       call wrkin(wrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &            numloc,last)
       if (last) goto 20
        do 15 i=1,num
        do 15 j=numloc+1,newloc
          locus(i,j)=MISS
   15   continue
        call wrkout(twrk,pedigree,actset,num,nfound,id,fa,mo,sex,
     &              locus,newloc)
      goto 10
   20 continue
      return
      end
C end-of-addvar

