C
C Create order of loci for outputting a pedigree
C  1 = as is
C  2 = LINKAGE
C  3 = GENEHUNTER
C  4 = MENDEL
C
      subroutine lorder(typ,nloci,loctyp,nord,locord)
      integer MAXLOC
      parameter(MAXLOC=120)

      integer typ
C Locus structure
      integer nloci,loctyp(MAXLOC)
C Printing order of loci
      integer nord,locord(MAXLOC)

      integer i
C
C Default is no manipulation
C
      if (typ.lt.2) then
        nord=nloci
        do 10 i=1,nloci
          locord(i)=i
   10   continue
C
C else Genehunter 2 ordering
C
      else
        nord=0
C no more than one binary trait if typ=3
        if (typ.eq.2 .or. typ.eq.3) then
          do 20 i=1,nloci
          if (loctyp(i).eq.4) then
            nord=nord+1
            locord(nord)=i
            if (typ.eq.3) goto 21
          end if
   20     continue
   21     continue
        end if
C all the markers 
        do 30 i=1,nloci
        if (loctyp(i).eq.1 .or. loctyp(i).eq.2) then
          nord=nord+1
          locord(nord)=i
        end if
   30   continue
C MENDEL factors
        if (typ.eq.4) then
          do 40 i=1,nloci
          if (loctyp(i).eq.4) then
            nord=nord+1
            locord(nord)=i
          end if
   40     continue
        end if
C then the quantitative traits
        do 50 i=1,nloci
        if (loctyp(i).eq.3) then
          nord=nord+1
          locord(nord)=i
        end if
   50   continue
      end if
      return
      end
C end-of-order
C
C Write map 
C
C 10 = table for Sib-pair output
C  0 = LINKAGE
C  1 = LINKAGE plus dummy binary trait
C  2 = GENEHUNTER plus dummy binary trait
C  3 = GENEHUNTER
C  4 = MENDEL
C  5 = ASPEX
C  6 = MERLIN
C  7 = LOKI  
C  8 = STRUCTURE
C
      subroutine wrmap(ostr,typ,mapf,nloci,loc,loctyp,nord,locord, map)
      integer MAXLOC, MISS
      parameter(MAXLOC=120,MISS=-9999)

      integer mapf, ostr, typ
C Locus structure
      integer nloci,loctyp(MAXLOC)
      character*10 loc(MAXLOC)
C Printing order of loci
      integer nord,locord(MAXLOC)
C position of locus on sex-averaged linkage map
      real map(MAXLOC)

      integer i, k
      logical frst
      character*11 tnam
      real dist
C functions
      real invmap
C show map
      dist=0.0
      frst=.true.
      if (typ.eq.10) then
        write(*,'(/a//a/a)') 'User specified marker map:',
     2    'Marker    Pos (cM)   Theta' ,
     3    '------    --------   -----' 
        do 20 i=1,nloci
        if (loctyp(i).le.2 .and. map(i).ne.MISS) then
          dist=map(i)-dist
          if (dist.lt.0.0) dist=1000.0
          write(*,'(a10,f8.2,f8.3)') loc(i),map(i),invmap(dist,mapf)
          dist=map(i)
        end if
   20   continue
        write(*,*)
C write Linkage or Genehunter locus file map
      else if (typ.ge.0 .and. typ.le.3) then
        dist=MISS
        if (typ.eq.1 .or. typ.eq.2) write(OSTR,'(a,$)') '  .000'
        do 30 k=1,nord 
        i=locord(k)
        if (loctyp(i).le.4) then
          if (frst) then
            frst=.not.frst
          elseif (dist.ne.MISS .and. map(i).ge.dist) then
            if (typ.eq.2 .or.typ.eq.3) then
              write(ostr,'(1x,f6.2,$)') max(0.01,map(i)-dist)
            else
              write(ostr,'(1x,f6.4,$)') invmap(map(i)-dist,mapf)
            end if
          else
            if (typ.eq.2 .or. typ.eq.3) then
              write(ostr,'(a,$)') ' 0.0'
            else
              write(ostr,'(a,$)') ' .4999'
            end if
          end if
          dist=map(i)
        end if
   30   continue
C MENDEL map file
      else if (typ.eq.4) then
        do 40 i=1,nloci
        if (loctyp(i).le.4) then
          if (frst) then
            frst=.not.frst
          elseif (dist.ne.MISS .and. map(i).ge.dist) then
            dist=map(i)-dist
            write(ostr,'(8x,f8.4,f8.4)') 
     &        invmap(dist,mapf), invmap(dist,mapf)
          else
            write(ostr,'(8x,f8.4,f8.4)') 0.5, 0.5
          end if
          dist=map(i)
          write(ostr,'(a8)') loc(i)
        end if
   40   continue
C ASPEX map 
      else if (typ.eq.5) then
        k=0
        write(ostr,'(a,$)') 'set dist {'
        do 50 i=1,nloci
        if (loctyp(i).le.2) then
          k=k+1
          if (map(i).ne.MISS .and. map(i).ge.dist) then
            write(ostr,'(1x,f5.3,$)') 
     &        max(0.001,0.01*(map(i)-dist))
            dist=map(i)
          elseif (dist.eq.0.0) then
            write(ostr,'(a,$)') ' 0.001'
            dist=-100.0
          else
            write(ostr,'(a,$)') ' 0.50'
            dist=-100.0
          end if
          if (k.eq.6) then
            k=0
            write(ostr,'(/a,$)') '          '
          end if
        end if
   50   continue
        write(ostr,'(a)') ' 0.01 }'
C MERLIN map file
      else if (typ.eq.6) then
        do 60 i=1,nloci
        if (loctyp(i).le.2 .and. map(i).ne.MISS) then
          write(ostr,'(a,a10,f8.2)') '1 ',loc(i),map(i)
        end if
   60   continue
C LOKI parameter file map positions
      else if (typ.eq.7) then
        write(ostr,'(a/a//a,f8.2/)') 
     &    'ITERATIONS 1000', 'START OUTPUT 50,1', 'TOTAL MAP 3600.0'
        do 80 i=1,nloci
        if (loctyp(i).eq.1 .and. map(i).ne.MISS) then
          call addlet(loc(i), tnam)
          write(ostr,'(a,a10,f8.2)') 'POSITION ',tnam,map(i)
        end if
   80   continue
C STRUCTURE datafile map positions
      else if (typ.eq.8) then
        do 90 i=1,nloci
        if (loctyp(i).le.2) then
          write(ostr,'(1x,a,$)') loc(i)
        end if
   90   continue
        write(ostr,'(a)') ' '
        do 100 i=1,nloci
        if (loctyp(i).le.2) then
          if (frst) then
            frst=.not.frst
            write(ostr,'(1x,a2,$)') '-1'
          elseif (dist.ne.MISS .and. map(i).ge.dist) then
            dist=map(i)-dist
            write(ostr,'(1x,f7.2,$)') dist
          else
            write(ostr,'(1x,a2,$)') '-1'
          end if
          dist=map(i)
        end if
  100   continue
        write(ostr,*)
      end if
      return
      end
C end-of-wrmap
C
C Write out pedigree header with locus names 
C
      subroutine pedhead(longnam,nwid,nloci,loc,loctyp,locpos,lin)
      integer LINSIZ,MAXLOC
      parameter (LINSIZ=1024,MAXLOC=120)
      integer longnam,nwid
C Locus structure
      character*10 loc(MAXLOC)
      integer nloci,loctyp(MAXLOC),locpos(MAXLOC)
      character*(LINSIZ) lin
C local variables
      integer eos,i,j,pos
      character*3 sex
C functions
      integer eow
      data sex /'sex'/

      write(*,'(/a)') '!'
      do 10 i=1,2
        lin='!'
        pos=longnam+29
        lin(pos:pos)=sex(i:i)
        pos=pos+2
        do 15 j=1,nloci
        if(loctyp(j).le.2) then
           pos=pos+9
        elseif(loctyp(j).eq.3) then
           pos=pos+nwid+2
        elseif(loctyp(j).eq.4) then
           eos=max(0,3-eow(loc(j)))
           if (eos.lt.i) lin(pos:pos)=loc(j)(i-eos:i-eos)
           pos=pos+2
        end if
   15   continue
        write(*,'(a)') lin(1:pos)
   10 continue

      lin(1:longnam)='! Pedigree'
      pos=longnam+3
      lin(pos:pos+27)='Person   Father   Mother  x'
      pos=pos+28

      do 25 j=1,nloci
      if(loctyp(j).le.2) then
         eos=eow(loc(j))
         lin(pos+8-eos:pos+7)=loc(j)(1:eos)
         pos=pos+9
      elseif(loctyp(j).eq.3) then
         eos=min(nwid,eow(loc(j)))
         lin(pos+nwid-eos:pos+nwid-1)=loc(j)(1:eos)
         pos=pos+nwid+2
      elseif(loctyp(j).eq.4) then
         eos=max(0,3-eow(loc(j)))
         lin(pos:pos)=loc(j)(i-eos:i-eos)
         pos=pos+2
      end if
   25 continue
      write(*,'(a/a)') lin(1:pos),'!'
      return
      end
C end-of-pedhead
C
C Write out pedigree using GAS format
C
      subroutine pedout(wrk,strm,typ,imp,nwid,ndec,longnam,
     2             pedigree,actset,num,nfound,
     3             id,fa,mo,sex,locus,nloci,loctyp,locpos,numloc,lin)
      integer LINSIZ,KNOWN,MAXSIZ,MAXLOC,MISS
      parameter (LINSIZ=1024,KNOWN=0,MAXSIZ=1000,MAXLOC=120,MISS=-9999)
      integer imp,longnam,ndec,nwid,strm,typ,wrk
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)
C Locus structure
      integer nloci,loctyp(MAXLOC),locpos(MAXLOC)
      character*(LINSIZ) lin
C local variables
      character*1 sep
      character*2 cdec, cwid
      character*8 fdec
      character*20 loc20,miss20

      integer i,j,pos
      logical last, noimp
C functions
      integer sow
C
C quantitative variable format
  
      sep=' '
      if (typ.eq.2) sep='/'
      write(cwid,'(i2)') nwid
      write(cdec,'(i2)') ndec
      write(fdec,'(5a)') 
     &  '(f', cwid(sow(cwid):2),'.',cdec(sow(cdec):2),')'
      miss20=' '
      pos=min(nwid-ndec,19)
      miss20(pos:pos)='x'

      noimp=(imp.ne.3 .and. imp.ne.6)
      last=.false.
      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

        do 15 i=1,num
C compulsory data
          lin=' '
          lin(1:longnam)=pedigree(1:longnam)
          pos=longnam+2 
          loc20=id(i)
          call juststr('r',loc20,8)
          lin(pos:pos+7)=loc20(1:8)
          pos=pos+9
          if (fa(i).eq.MISS) then
            lin(pos:pos+17)='       x        x'
            pos=pos+18
          else
            loc20=id(fa(i))
            call juststr('r',loc20,8)
            lin(pos:pos+7)=loc20(1:8)
            pos=pos+9
            loc20=id(mo(i))
            call juststr('r',loc20,8)
            lin(pos:pos+7)=loc20(1:8)
            pos=pos+9
          end if
          if (sex(i).eq.2) then
            lin(pos:pos)='f'
          elseif (sex(i).eq.1) then
            lin(pos:pos)='m'
          else
            lin(pos:pos)='x'
          end if
          pos=pos+2
C phenotypes
          do 25 j=1,nloci
          if(loctyp(j).le.2) then
             if(locus(i,locpos(j)).eq.MISS .or. 
     &          (noimp .and. locus(i,locpos(j)).le.KNOWN)) then
               write(loc20,'(1x,a3,a1,a3)') 'x',sep,'x'
             else
               write(loc20,'(1x,i3,a1,i3)') 
     2           int(abs(locus(i,locpos(j)))),sep, 
     3           int(abs(locus(i,locpos(j)+1)))
             end if
             lin(pos:pos+7)=loc20(1:8)
             pos=pos+9
          elseif(loctyp(j).eq.3) then
             if(locus(i,locpos(j)).eq.MISS) then
               write(loc20,'(a)') miss20
             else
               write(loc20,fdec) locus(i,locpos(j))
             end if
             lin(pos:pos+nwid-1)=loc20(1:nwid)
             pos=pos+nwid+2
          elseif(loctyp(j).eq.4) then
             if (locus(i,locpos(j)).eq.MISS .or.
     &           locus(i,locpos(j)).eq.0.0) then
               lin(pos:pos)='x'
             elseif(locus(i,locpos(j)).eq.1.0) then
               lin(pos:pos)='n'
             elseif(locus(i,locpos(j)).eq.2.0) then
               lin(pos:pos)='y'
             end if
             pos=pos+2
          end if
   25     continue
          write(strm,'(a)') lin(1:pos-2)
   15   continue
      goto 10
   20 continue
      return
      end
C end-of-pedout
C
C Write out PAP pedigree
C
      subroutine wrpap(wrk,wrk2,trip,phen,pedigree,actset,num,nfound,
     2                 id,fa,mo,sex,locus,nloci,loctyp,locpos,numloc,
     3                 numal,name,alfrq)
      integer KNOWN,LINSIZ,MAXALL,MAXSIZ,MAXLOC,MISS
      parameter (KNOWN=0,LINSIZ=1024,MAXALL=60,MAXSIZ=1000,
     &           MAXLOC=120,MISS=-9999)
      integer phen,trip,wrk,wrk2
C Pedigree structure
      character*10 pedigree
      character*8 id(MAXSIZ)
      integer actset,num,nfound,fa(MAXSIZ),mo(MAXSIZ),sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
C Locus structure
      integer nloci,loctyp(MAXLOC),locpos(MAXLOC)
      character*(LINSIZ) lin
      character*8 loc1
C allele frequencies structure
      integer numal, name(MAXALL)
      double precision alfrq(MAXALL)
C local variables
      integer eop,famcnt,famno,g1,g2,i,j,pos,nfam,sx 
      logical last
C functions
      integer eow, getnam
C
C A unique ID number is obtained for each individual by adding the famno
C (which increases in multiples of famcnt, minimum 1000) to their position
C 1..num
C 
      famcnt=int(10.0**int(max(3.0,1.0+log10(float(MAXSIZ)))))
      famno=0
      nfam=0
      pedigree=' '
      last=.false.
      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

         nfam=nfam+1
         famno=famno+famcnt
         eop=eow(pedigree)
         lin=' '
         if (num.eq.nfound) then
           do 14 i=1,num
           if (sex(i).eq.1) then
             write(trip,'(4i8,4a)') 
     &       nfam,famno+i,famno+num+i,0,' # ',pedigree(1:eop),'-',id(i)
           else
             write(trip,'(4i8,4a)') 
     &       nfam,famno+num+i,famno+i,0,' # ',pedigree(1:eop),'-',id(i)
           end if
   14      continue
         end if
         do 15 i=1,num
           rewind(wrk2)
           sx=1
           if (sex(i).eq.2) sx=2
           if (fa(i).ne.MISS.and.mo(i).ne.MISS) then
             write(trip,'(4i8,9a)') 
     2       nfam,famno+fa(i),famno+mo(i),famno+i,
     3       ' # ',pedigree(1:eop),'-',id(i),
     4       ' (',id(fa(i))(1:eow(id(fa(i)))),' x ',
     5            id(mo(i))(1:eow(id(mo(i)))),')'
           end if
           write(loc1,'(i8)') famno+i
           lin(1:8)=loc1
           write(loc1,'(i8)') sx
           lin(9:16)=loc1
           pos=17
           do 17 j=1,nloci
             if (pos.gt.122) then
               write(phen,'(a)') lin(1:pos-1)
               lin(1:pos-1)=' '
               pos=1
             end if 
            if (loctyp(j).eq.1) then
              read(wrk2) numal,(name(k),k=1,numal),(alfrq(k),k=1,numal)
              if (locus(i,locpos(j)).lt.KNOWN) then
                write(loc1,'(a8)') '   -9999'
              else
                g1=getnam(locus(i,locpos(j)),numal,name)
                g2=getnam(locus(i,locpos(j)+1),numal,name)
                write(loc1,'(i8)') g2*(g2-1)/2+g1
              end if
              lin(pos:pos+7)=loc1
              pos=pos+8
            elseif (loctyp(j).eq.3) then
             if (locus(i,locpos(j)).eq.MISS) then
               write(loc1,'(a8)') '   -9999'
             else
               write(loc1,'(f8.4)') locus(i,locpos(j))
             end if
             lin(pos:pos+7)=loc1
             pos=pos+8
           elseif (loctyp(j).eq.4) then
             if (locus(i,locpos(j)).eq.MISS) then
               write(loc1,'(a8)') '   -9999'
             elseif (locus(i,locpos(j)).eq.1) then
               write(loc1,'(a8)') '1'
             elseif (locus(i,locpos(j)).eq.2) then
               write(loc1,'(a8)') '2'
             end if
             lin(pos:pos+7)=loc1
             pos=pos+8
           end if
   17      continue
           if (pos.gt.1) then
             write(phen,'(a)') lin(1:pos-1)
             lin(1:pos-1)=' '
             pos=1
           end if 
   15    continue
      goto 10
   20 continue
      return
      end
C end-of-wrpap
C
C Write out SAGE pedigree
C
      subroutine wrsage(wrk,strm,pedigree,actset,num,id,fa,mo,sex,locus,
     &                  nloci, loctyp,locpos,numloc)
      integer LINSIZ,MAXSIZ,MAXLOC,MISS
      parameter (LINSIZ=1024,MAXSIZ=1000,MAXLOC=120,MISS=-9999)
      integer strm,wrk,actset,num
C Pedigree structure
      character*10 pedigree
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ),mo(MAXSIZ),sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
C Locus structure
      integer nloci,loctyp(MAXLOC),locpos(MAXLOC)
      character*(LINSIZ) lin
      character*9 loc1
      character*4 loc2
      character*1 sx
      integer i,j,pos,nfound,nfam
      logical last
      nfam=0
      pedigree=' '
      last=.false.
      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

         nfam=nfam+1
         pos=1
         lin=' '

         do 15 i=1,num
           sx='M'
           if (sex(i).eq.2) sx='F'
           if (fa(i).eq.MISS.and.mo(i).eq.MISS) then
             write(strm,'(a5,i5,a8,16x,a1)') 
     &          'fsp  ',nfam,id(i),sx
           else
             write(strm,'(a5,i5,3a8,a1)') 
     &          'fsp  ',nfam,id(i),id(fa(i)),id(mo(i)),sx
           end if
           do 17 j=1,nloci
             if (pos.gt.122) then
               write(strm,'(a)') lin(1:pos-1)
               lin(1:pos-1)=' '
               pos=1
             end if 
            if (loctyp(j).eq.1) then
              if (locus(i,locpos(j)).eq.MISS) then
                write(loc1,'(a9)') ' '
              else
                write(loc1,'(i4.4,a1,i4.4)') 
     &            int(locus(i,locpos(j))),'/',int(locus(i,locpos(j)+1))
              end if
              lin(pos:pos+8)=loc1
              pos=pos+9
            elseif (loctyp(j).eq.3) then
             if (locus(i,locpos(j)).eq.MISS) then
               write(loc1,'(1x,f8.4)') -99.0
             else
               write(loc1,'(1x,f8.4)') locus(i,locpos(j))
             end if
             lin(pos:pos+8)=loc1
             pos=pos+9
           elseif (loctyp(j).eq.4) then
             if (locus(i,locpos(j)).eq.MISS) then
               write(loc2,'(1x,a3)') '-99'
             elseif (locus(i,locpos(j)).eq.1) then
               write(loc2,'(1x,a3)') '1'
             elseif (locus(i,locpos(j)).eq.2) then
               write(loc2,'(1x,a3)') '2'
             end if
             lin(pos:pos+3)=loc2
             pos=pos+4
           end if
   17      continue
           if (pos.gt.1) then
             write(strm,'(a)') lin(1:pos-1)
             lin(1:pos-1)=' '
             pos=1
           end if 
   15    continue
      goto 10
   20 continue

      return
      end
C end-of-wrsage
C
C write out linkage type file
C
      subroutine wrlink(wrk,wrk2,strm,typ,nwid,ndec,pedigree,actset,
     2             num, nfound,id,fa,mo,sex,locus,nloci,loctyp,locpos,
     3             nord,locord,numloc,numal,name,alfrq)
      integer KNOWN,LINSIZ,MAXSIZ,MAXLOC,MISS,MAXALL
      parameter (KNOWN=0,LINSIZ=1024,MAXSIZ=1000,MAXLOC=120,
     &           MISS=-9999,MAXALL=60)
      integer ndec,nwid,strm,typ,wrk,wrk2
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)
C Locus structure
      integer nloci,loctyp(MAXLOC),locpos(MAXLOC)
C Printing order of loci
      integer nord,locord(MAXLOC)
C allele frequencies structure
      integer numal, name(MAXALL)
      double precision alfrq(MAXALL)
C
      character*(LINSIZ) lin
      character*2 cdec, cwid
      character*8 fdec
      character*20 loc20,miss20
      character*1 sx
      integer i,j,k,l,pos
      logical last
C functions
      integer getnam, sow
C
C quantitative variable format 
      write(cwid,'(i2)') nwid
      write(cdec,'(i2)') ndec
      write(fdec,'(5a)') 
     &  '(f', cwid(sow(cwid):2),'.',cdec(sow(cdec):2),')'
      miss20=' '
      pos=min(nwid-ndec,19)
      if (typ.eq.2 .or. typ.eq.3) then
        miss20(pos:pos)='-'
      else
        miss20(pos:pos)='0'
      end if

      pedigree=' '
      last=.false.
      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

        do 15 i=1,num
          rewind(wrk2)
          lin=' '
          sx='1'
          if (sex(i).eq.2) sx='2'
          write(loc20,'(a10,1x,a8)') pedigree,id(i)
          lin(1:19)=loc20(1:19)
          if (fa(i).eq.MISS) then
            write(loc20,'(1x,a8,1x,a8,1x,a1)') '0       ','0       ',sx
          else
            write(loc20,'(1x,a8,1x,a8,1x,a1)') id(fa(i)),id(mo(i)),sx
          end if
          lin(20:39)=loc20
          pos=41
C Add dummy binary trait when asked
          if (typ.eq.1 .or. typ.eq.2) then
            lin(41:43)=' 2 '
            pos=44
          end if
          do 25 l=1,nord
            j=locord(l)
            if (loctyp(j).le.2) then
              read(wrk2) numal,(name(k),k=1,numal),(alfrq(k),k=1,numal)
              if(locus(i,locpos(j)).le.KNOWN) then
                write(loc20,'(1x,a3,1x,a3)') '0','0'
              else
                write(loc20,'(1x,i3,1x,i3)') 
     2           getnam(locus(i,locpos(j)),numal,name),
     3           getnam(locus(i,locpos(j)+1),numal,name)
              end if
              lin(pos:pos+7)=loc20(1:8)
              pos=pos+9
            elseif (loctyp(j).eq.3) then
              if(locus(i,locpos(j)).eq.MISS) then
                write(loc20,'(a)') miss20
              elseif(locus(i,locpos(j)).eq.0.0) then
                write(loc20,'(a)') '  0.000001'
              else
                write(loc20,fdec) locus(i,locpos(j))
              end if
              lin(pos:pos+nwid-1)=loc20(1:nwid)
              pos=pos+nwid+2
            elseif (loctyp(j).eq.4) then
              if (locus(i,locpos(j)).eq.1) then
                lin(pos:pos)='1'
              elseif (locus(i,locpos(j)).eq.2.0) then
                lin(pos:pos)='2'
              else
                lin(pos:pos)='0'
              end if
              pos=pos+2
            end if
   25     continue
         write(strm,'(a)') lin(1:pos-1)
   15   continue
      goto 10
   20 continue
      return
      end
C end-of-wrlink
C
C write out CRI-MAP type file
C
      subroutine wrcri(wrk,wrk2,strm,pedigree,actset,num,id,fa,mo,sex,
     2                 locus,nloci,loctyp,locpos,numloc,
     3                 numal,name,alfrq)
      integer KNOWN,LINSIZ,MAXSIZ,MAXLOC,MISS,MAXALL
      parameter (KNOWN=0,LINSIZ=1024,MAXSIZ=1000,MAXLOC=120,
     &           MISS=-9999,MAXALL=60)
      integer strm,wrk,wrk2,actset,num
C Pedigree structure
      character*10 pedigree
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ),mo(MAXSIZ),sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
C Locus structure
      integer nloci,loctyp(MAXLOC),locpos(MAXLOC)
C allele frequencies structure
      integer numal, name(MAXALL)
      double precision alfrq(MAXALL)
C
      character*(LINSIZ) lin
      character*8 part1
      character*20 part2
      character*9 loc1
      character*1 sx
      integer i,j,pos,nfound
      logical last
C functions
      integer getnam
C
      pedigree=' '
      last=.false.
      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

        write(strm,'(1x,a10/1x,i3)') pedigree, num
        do 15 i=1,num
          rewind(wrk2)
          lin=' '
          write(part1,'(a8)') id(i)
          sx='0'
          if (sex(i).eq.2) sx='1'
          if (fa(i).eq.MISS) then
            write(part2,'(1x,a8,1x,a8,1x,a1)') '0       ','0       ',sx
          else
            write(part2,'(1x,a8,1x,a8,1x,a1)') id(fa(i)),id(mo(i)),sx
          end if
          lin(1:8)=part1
          lin(9:28)=part2
          pos=29
          do 25 j=1,nloci
          if(loctyp(j).eq.1) then
             read(wrk2) numal,(name(k),k=1,numal),(alfrq(k),k=1,numal)
             if(locus(i,locpos(j)).le.KNOWN) then
               write(loc1,'(1x,a3,1x,a3)') '0','0'
             else
               write(loc1,'(1x,i3,1x,i3)') 
     2          getnam(locus(i,locpos(j)),numal,name),
     3          getnam(locus(i,locpos(j)+1),numal,name)
             end if
             lin(pos:pos+8)=loc1
             pos=pos+9
          end if
   25     continue
         write(strm,'(a)') lin(1:pos-1)
   15   continue
      goto 10
   20 continue
      return
      end
C end-of-wrcri
C
C write out FISHER or MENDEL type pedigree file
C
      subroutine wrfish(wrk,strm,pedigree,actset,num,nfound,id,fa,mo,
     2                  sex, locus,nloci,loctyp,locpos,numloc,nord,
     3                  locord, fstyle)
      integer KNOWN,LINSIZ,MAXSIZ,MAXLOC,MISS
      parameter (KNOWN=0,LINSIZ=1024,MAXSIZ=1000,MAXLOC=120,MISS=-9999)
      integer strm,wrk,fstyle
C Pedigree structure
      character*10 pedigree
      character*8 id(MAXSIZ)
      integer actset,num,nfound,fa(MAXSIZ),mo(MAXSIZ),sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
C Locus structure
      integer nloci,loctyp(MAXLOC),locpos(MAXLOC)
C Printing order of loci
      integer nord,locord(MAXLOC)

      character*(LINSIZ) lin
      character*22 part2
      character*9 loc1
      character*1 sx
      integer i,j,k,pos,nlp
      logical last
      pedigree=' '
      last=.false.
      nlp=0
      do 1 i=1,nloci
        if(loctyp(i).le.4) nlp=nlp+1
    1 continue
      if (fstyle.eq.1) then
        write(strm,'(1x,a/1x,a,i3,a)') 
     &      '(2(i3,1x),a8)','(a8,2(1x,a8),2(1x,a1),',nlp,'(1x,a8))'
      else
        write(strm,'(1x,a/1x,a,i3,a)') 
     &      '(i3,1x,a8)','(a8,2(1x,a8),2(1x,a1),',nlp,'(1x,a8))'
      end if
      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

        if (fstyle.eq.1) then
          write(strm,'(2(i3,1x),a8)') 0,num,pedigree(1:8)
        else
          write(strm,'(i3,1x,a8)') num,pedigree(1:8)
        end if
        do 15 i=1,num
          lin=' '
          sx='M'
          if (sex(i).eq.2) sx='F'
          lin(1:8)=id(i)
          if (fa(i).eq.MISS) then
            write(part2,'(1x,a8,1x,a8,1x,a1,1x,a1)') ' ',' ',sx,' '
          else
            write(part2,'(1x,a8,1x,a8,1x,a1,1x,a1)') 
     &            id(fa(i)),id(mo(i)),sx,' '
          end if
          lin(9:30)=part2
          pos=31
          do 25 k=1,nord 
            j=locord(k)
            if (loctyp(j).le.2) then
              if (locus(i,locpos(j)).le.KNOWN) then
                write(loc1,'(1x,a8)') ' '
              else
                write(loc1,'(2x,i3.3,a1,i3.3)') 
     2            abs(int(locus(i,locpos(j)))),'/',
     3            abs(int(locus(i,locpos(j)+1)))
              end if
              lin(pos:pos+8)=loc1
              pos=pos+9
            elseif(loctyp(j).eq.3) then
              if(locus(i,locpos(j)).eq.MISS) then
                write(loc1,'(1x,a8)') ' '
              else
                write(loc1,'(1x,f8.4)') locus(i,locpos(j))
              end if
              lin(pos:pos+8)=loc1
              pos=pos+9
            elseif(loctyp(j).eq.4) then
              if(locus(i,locpos(j)).eq.1.0) then
                write(loc1,'(1x,a8)') 'NORMAL  '
              elseif(locus(i,locpos(j)).eq.2.0) then
                write(loc1,'(1x,a8)') 'AFFECTED'
              else
                write(loc1,'(1x,a8)') ' '
              end if
              lin(pos:pos+8)=loc1
              pos=pos+9
            end if
   25     continue
          write(strm,'(a)') lin(1:pos-1)
   15   continue
      goto 10
   20 continue
      return
      end
C end-of-wrfish
C
C write out Arlequin data file (haplotype data)
C
      subroutine wrarl(wrk,wrk2,strm,pedigree,actset,num,nfound,id,fa,
     2                 mo,sex, locus,nloci,loc,loctyp,locpos,numloc,
     3                 mar,hset,typ)
      integer KNOWN,MAXHAP,MAXSIZ,MAXLOC,MISS
      parameter (KNOWN=0,MAXSIZ=1000,MAXLOC=120,
     &           MAXHAP=MAXLOC/2,MISS=-9999)
      integer strm,typ,wrk,wrk2
C Pedigree structure
      character*10 pedigree
      character*8 id(MAXSIZ)
      integer actset,num,nfound,fa(MAXSIZ),mo(MAXSIZ),sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
C Locus structure
      integer nloci,loctyp(MAXLOC),locpos(MAXLOC)
      character*10 loc(MAXLOC)
C
C Storage space for haplotypes
      integer hset(MAXSIZ,MAXHAP,2)
C List of active marker loci
      integer mar(MAXLOC)
C local variables
      integer gene,gen2,i,j,k,maxid,maxinf,ninf,nlp,nsamp
      integer nt1, nt2, tr1, tr2
      character*3 all  
      logical last

      nlp=0
      do 1 j=1,nloci
      if (loctyp(j).eq.1) then
        nlp=nlp+1
        mar(nlp)=locpos(j)
      end if
    1 continue
      nsamp=0

      pedigree=' '
      last=.false.
      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
C Go through pedigree, either all member genotypes
        if (typ.eq.0) then
         do 12 i=1,num
           ninf=0
           do 13 j=1,nlp
             gene=mar(j)
             gen2=gene+1
             hset(1,j,1)=MISS
             hset(1,j,2)=MISS
             if (locus(i,gene).gt.KNOWN) then
               ninf=ninf+1
               hset(1,j,1)=int(locus(i,gene))
               hset(1,j,2)=int(locus(i,gen2))
             end if
   13      continue
           if (ninf.gt.1) then
             nsamp=nsamp+1
             write(wrk2) ((hset(1,j,k),j=1,nlp),k=1,2)
           end if
   12    continue
        else
C
C or the most useful callable haplotype per family
         maxid=0
         maxinf=0
         do 15 i=nfound+1,num
           ninf=0
           do 16 j=1,nlp
             gene=mar(j)
             gen2=gene+1
             if (locus(i,gene).gt.KNOWN .and. locus(fa(i),gene).gt.KNOWN
     2           .and. locus(mo(i),gene).gt.KNOWN) then
               ninf=ninf+1
               call trans(int(locus(fa(i),gene)),int(locus(fa(i),gen2)),
     2                    int(locus(mo(i),gene)),int(locus(mo(i),gen2)),
     3                    int(locus(i,gene)), int(locus(i,gen2)),
     4                    tr1,tr2,nt1,nt2,0)
               hset(i,j,1)=tr1
               hset(i,j,2)=tr2
               hset(mo(i),j,1)=tr1
               hset(mo(i),j,2)=nt1
               hset(fa(i),j,1)=tr2
               hset(fa(i),j,2)=nt2
             else
               hset(i,j,1)=MISS
               hset(i,j,2)=MISS
               hset(mo(i),j,1)=MISS
               hset(mo(i),j,2)=MISS
               hset(fa(i),j,1)=MISS
               hset(fa(i),j,2)=MISS
             end if
   16      continue
           if (ninf.gt.maxinf) then
             maxinf=ninf
             maxid=i
           end if
   15    continue
         if (maxinf.gt.1) then
           if (typ.eq.1) then
             nsamp=nsamp+1
             write(wrk2) ((hset(maxid,j,k),j=1,nlp),k=1,2)
           else
             nsamp=nsamp+2
             write(wrk2) ((hset(fa(maxid),j,k),j=1,nlp),k=1,2)
             write(wrk2) ((hset(mo(maxid),j,k),j=1,nlp),k=1,2)
           end if
         end if
        end if
      goto 10
   20 continue
C
C Write haplotypes
C
      write(strm,'(a/a/a/a)') 
     &  '#','# Arlequin format data written by Sib-pair','#','[Profile]' 
      if (typ.eq.0) then
        write(strm,'(3x,a)') 
     &    'Title="Genotype data: All genotyped individuals"' 
      else if (typ.eq.1) then
        write(strm,'(3x,a)') 
     &    'Title="Haplotype data: one child per family"' 
      else
        write(strm,'(3x,a)') 
     &   'Title="Haplotype data: two parents per family"' 
      end if
      write(strm,'(3x,a)') 
     2  'NbSamples=1', 'GenotypicData=1'  
      write(strm,'(3x,a,i1)') 'GameticPhase=',min(typ,1)
      write(strm,'(3x,a)') 
     2  'RecessiveData=0','DataType=STANDARD',
     3  'LocusSeparator=WHITESPACE','MissingData="x"'
      write(strm,'(a/3x,a/6x,a/6x,a,i5/6x,a)') '[Data]','[[Samples]]',
     &  'SampleName="Population 1"', 'SampleSize=',nsamp,'SampleData= {'
C
      rewind(wrk2)
      do 50 i=1,nsamp
        read(wrk2) ((hset(1,j,k),j=1,nlp),k=1,2)
        write(strm,'(i10,i3,$)') i,1 
        do 60 j=1,nlp
          call wrall(hset(1,j,1),all)
          write(strm,'(1x,a3,$)') all
   60   continue
        write(strm,'(/12x,a,$)') ' '
        do 65 j=1,nlp
          call wrall(hset(1,j,2),all)
          write(strm,'(1x,a3,$)') all
   65   continue
        write(strm,*)
   50 continue
      write(strm,'(6x,a)') '}'
      return
      end
C end-of-wrarl 
C
C write out data file used by Jonathon Pritchard's structure program
C
      subroutine wrprd(wrk,strm,trait,pedigree,actset,num,nfound,id,fa,
     &             mo,sex,locus,nloci,loc,loctyp,locpos,numloc,typ)
      integer KNOWN,LMISS,LINSIZ,MAXSIZ,MAXLOC,MISS
      parameter (KNOWN=0,LINSIZ=1024,MAXSIZ=1000,MAXLOC=120,
     &           LMISS=-9, MISS=-9999)
      integer strm,trait,wrk
      integer typ
C Pedigree structure
      character*10 pedigree
      character*8 id(MAXSIZ)
      integer actset,num,nfound,fa(MAXSIZ),mo(MAXSIZ),sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
C Locus structure
      integer nloci,loctyp(MAXLOC),locpos(MAXLOC)
      character*10 loc(MAXLOC)

      integer eop,fin,g1,g2,i,j,tval
      logical last
C functions
      integer eow

      pedigree=' '
      last=.false.

      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

        eop=eow(pedigree)
        fin=num
        if (typ.eq.1) fin=nfound
        do 15 i=1,fin
          if (trait.eq.MISS) then
            tval=0
          else
            tval=int(locus(i,trait))-1
          end if
          write(strm, '(3a, 2(1x, i2),$)') 
     &      pedigree(1:eop),'-',id(i)(1:eow(id(i))), 1, tval
          do 25 j=1,nloci
          if (loctyp(j).eq.1) then
            g1=int(locus(i,locpos(j)))
            g2=int(locus(i,locpos(j)+1))
            if (g1.le.KNOWN) then
              g1=LMISS
              g2=LMISS
            end if
            write(strm,'(1x,i3,1x,i3,$)') g1,g2
          end if
   25     continue
          write(strm,*) 
   15   continue
      goto 10
   20 continue
      return
      end
C end-of-wrprd 
C
C write out Nexus gdatype data file used by GDA
C
      subroutine wrgda(wrk,strm,pedigree,actset,num,nfound,id,fa,mo,sex,
     &                 locus,nloci,loc,loctyp,locpos,numloc,typ)
      integer KNOWN,LINSIZ,MAXSIZ,MAXLOC,MISS
      parameter (KNOWN=0,LINSIZ=1024,MAXSIZ=1000,MAXLOC=120,MISS=-9999)
      integer strm,wrk
      integer typ
C Pedigree structure
      character*10 pedigree
      character*8 id(MAXSIZ)
      integer actset,num,nfound,fa(MAXSIZ),mo(MAXSIZ),sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
C Locus structure
      integer nloci,loctyp(MAXLOC),locpos(MAXLOC)
      character*10 loc(MAXLOC)
      character*(LINSIZ) lin
      character*9 loc1
      integer eop,fin,i,j,n,nlp,pos
      logical last
C functions
      integer eow

      pedigree=' '
      last=.false.
      n=0
      nlp=0
      do 1 j=1,nloci
        if(loctyp(j).eq.1) nlp=nlp+1
    1 continue
      write(strm,'(3(a/),a,i3,a,2(/a))') 
     2  '#nexus','[ Nexus gdatype format data written by Sib-pair ]',
     3  'begin gdadata;', 'dimensions nloci=',nlp,' npops=1;',
     5  'format tokens labels missing=x datapoint=standard;',
     6  'locusallelelabels'
      i=0
      do 2 j=1,nloci
      if (loctyp(j).eq.1) then
        i=i+1
        if (i.lt.nlp) then
          write(strm,'(2x,i3,1x,2a)')   i,loc(j),','
        else
          write(strm,'(2x,i3,1x,a,3(/a))') i,loc(j),';','matrix','Pop1:'
        end if
      end if
    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

        eop=eow(pedigree)
        fin=num
        if (typ.eq.1) fin=nfound
        do 15 i=1,fin
          lin=' '
          n=n+1
          write(loc1,'(1x,i8)') n
          lin(1:9)=loc1
          pos=10
          do 25 j=1,nloci
          if (loctyp(j).eq.1) then
            if (locus(i,locpos(j)).le.KNOWN) then
              write(loc1,'(1x,a8)') '   x/x  '
            else
              write(loc1,'(2x,i3.3,a1,i3.3)') 
     &          int(locus(i,locpos(j))),'/',int(locus(i,locpos(j)+1))
            end if
            lin(pos:pos+8)=loc1
            pos=pos+9
          end if
   25     continue
          lin(pos:pos+2)=' [ '
          pos=pos+3
          lin(pos:pos+eop-1)=pedigree
          pos=pos+eop
          write(loc1,'(1x,a8)') id(i)
          lin(pos:pos+8)=loc1
          lin(pos+9:pos+11)=' ] '
          write(strm,'(a)') lin(1:pos+11)
   15   continue
      goto 10
   20 continue
      write(strm,'(a/a)') ';','end;'
      return
      end
C end-of-wrgda 
C
C write out Mapmaker-Sibs phenotype file
C
      subroutine wrphe(wrk,strm,pedigree,actset,num,nfound,id,fa,mo,sex,
     &                 locus,nloci,loctyp,locpos,numloc)
      integer MAXSIZ,MAXLOC,MISS
      parameter (MAXSIZ=1000,MAXLOC=120,MISS=-9999)
      integer strm,wrk
C Pedigree structure
      character*10 pedigree
      character*8 id(MAXSIZ)
      integer actset,num,nfound,fa(MAXSIZ),mo(MAXSIZ),sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
C Locus structure
      integer nloci,loctyp(MAXLOC),locpos(MAXLOC)
      integer eop,i,j,nlp
      logical last
      character*8 chid
C functions
      integer eow

      pedigree=' '
      last=.false.
      nlp=0
      do 1 j=1,nloci
        if(loctyp(j).eq.3) nlp=nlp+1
    1 continue
      write(strm,'(i3)') nlp

      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

        eop=eow(pedigree)
        do 15 i=nfound+1,num
          call wrid('l',id(i),chid,0)
          write(strm,'(a,1x,a,$)') pedigree(1:eop),chid(1:eow(chid))
          do 25 j=1,nloci
          if (loctyp(j).eq.3) then
            if (locus(i,locpos(j)).eq.MISS) then
              write(strm,'(1x,a9,$)') '    -    '
            else
              write(strm,'(1x,f9.4,$)') locus(i,locpos(j))
            end if
          end if
   25     continue
          write(strm,*)
   15   continue
      goto 10
   20 continue
      return
      end
C end-of-wrphe 
C
C Describe pedigree using dot graphics language
C
      subroutine wrdot(wrk,strm,trait,pedigree,actset,num,nfound,
     &             id,fa,mo,sex,locus,nloci,loctyp,locpos,numloc,lin)
      integer LINSIZ,KNOWN,MAXSIZ,MAXLOC,MISS
      parameter (LINSIZ=1024,KNOWN=0,MAXSIZ=1000,MAXLOC=120,MISS=-9999)
      integer trait,strm,wrk
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)
C Locus structure
      integer nloci,loctyp(MAXLOC),locpos(MAXLOC)
      character*(LINSIZ) lin
C local variables
      character*8 marriage, shape, shade
      integer currf, currm, i,nfam
      logical last
C functions
      integer eow
C
      last=.false.
      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

        write(strm,'(3a/a/a/a/3a/a/)') 
     2    'digraph Ped_', pedigree, ' {',
     3    '# page = "8.2677165,11.692913" ;', 'ratio = "auto" ;',
     4    'mincross = 2.0 ;', 'label = "Pedigree ', 
     5    pedigree(1:eow(pedigree)), '" ;','rotate = 90 ;'
        do 15 i=1,num
          if (sex(i).eq.1) then
            shape='circle'
          elseif (sex(i).eq.2) then
            shape='box'
          else
            shape='diamond'
          end if
          if (trait.ne.MISS .and. locus(i,trait).eq.2) then
            shade='grey'
          else
            shade='white'
          end if
          write(strm,'(7a)') '"',id(i)(1:eow(id(i))),'" [shape=',shape,
     &      ', regular=1,style=filled,fillcolor=',shade,'] ;'
   15   continue
        nfam=0
        currf=MISS   
        currm=MISS   
        do 25 i=nfound+1, num
          if (fa(i).ne.currf .or. mo(i).ne.currm) then
            nfam=nfam+1
            write(marriage,'(a4,i4.4)') 'marr',nfam
            currf=fa(i)
            currm=mo(i)
            write(strm,'(4a/5a/5a)') '"', marriage,'" [shape=diamond,',
     2        'style=filled,label="",height=.1,width=.1] ;',
     3        '"',id(currf)(1:eow(id(currf))),'" -> "', marriage,
     4        '" [dir=none,weight=1] ;',  
     5        '"',id(currm)(1:eow(id(currm))),'" -> "', marriage,
     6        '" [dir=none,weight=1] ;'
          end if
          write(strm,'(5a)') '"', marriage,'" -> "',id(i)(1:eow(id(i))),
     &     '" [dir=none, weight=2] ;'
   25   continue
        write(strm,'(a)')  '}'
      goto 10
   20 continue
      return
      end
C end-of-wrdot 
C
C Write out data for particular pedigree or particular person 
C
      subroutine showdata(wrk,fped,fid,larg,words,
     2              nloci,loc,loctyp,locpos, pedigree,
     3              actset,num,nfound,id,fa,mo,sex,locus, numloc)
      integer MAXLOC, MAXCOL, MAXSIZ, MISS
      parameter (MAXLOC=120, MAXCOL=MAXLOC+5, MAXSIZ=1000, MISS=-9999)

      integer fid,fped,larg,wrk
      character*20 words(MAXCOL)
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)
C Locus structure
      character*10 loc(MAXLOC)
      integer nloci,loctyp(MAXLOC),locpos(MAXLOC)
C
      integer i, j, nrec
      logical found, last

      nrec=0
      last=.false.
      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

        found=.false.
        do 50 j=fped, fid-2
        if (pedigree.eq.words(j)(1:10)) then
          found=.not.found
          goto 60
        end if
   50   continue
   60   continue
        if (found) then
          if (fid.gt.larg) then
            do 70 i=1, num
              call wrind(i,pedigree,id,fa,mo,sex,
     &                   locus,nloci,loc,loctyp,locpos)
   70       continue
            nrec=nrec+num
          else
            do 75 i=1, num
              do 80 j=fid, larg 
              if (id(i).eq.words(j)(1:8)) then
                call wrind(i,pedigree,id,fa,mo,sex,
     &                     locus,nloci,loc,loctyp,locpos)
                nrec=nrec+1
                goto 75
              end if
   80         continue
   75       continue
          end if
        end if
      goto 10
   20 continue
      write(*,'(/a,i6,a)') 'Printed ',nrec,' records.'
      return
      end
C end-of-showdata
C
C write out data for an individual
C
      subroutine wrind(idx,pedigree,id,fa,mo,sex,
     &                 locus,nloci,loc,loctyp,locpos)
      integer KNOWN,MAXSIZ,MAXLOC,MISS
      parameter (KNOWN=0,MAXSIZ=1000,MAXLOC=120,MISS=-9999)
      integer idx
C Pedigree structure
      character*10 pedigree
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ),mo(MAXSIZ),sex(MAXSIZ)
      real locus(MAXSIZ,MAXLOC)
C Locus structure
      character*10 loc(MAXLOC)
      integer nloci,loctyp(MAXLOC),locpos(MAXLOC)
C local variables
      integer j, lpos
      character*1 ch
      character*7 gtp
      character*10 curloc, cval
C functions
      integer eow

      ch='x'
      if (sex(idx).eq.1) then
        ch='m'
      else if (sex(idx).eq.2) then
        ch='f'
      end if

      write(*,'(6a,1x,$)') 'id=', pedigree(1:eow(pedigree)),'-',
     &                    id(idx)(1:eow(id(idx))),' sex=',ch
      do 25 j=1,nloci
      if (loctyp(j).le.4) then
        lpos=locpos(j)
        curloc=loc(j)
        if (locus(idx,lpos).eq.MISS) then
          write(*,'(1x,2a,1x,$)') curloc(1:eow(curloc)), '=x'
        else if (loctyp(j).le.2) then
          if (locus(idx,lpos).le.KNOWN) then
            write(*,'(1x,2a,1x,$)') curloc(1:eow(curloc)), '=x'
          else
            call wrgtp(int(locus(idx,lpos)), 
     &                 int(locus(idx,lpos+1)),gtp,1)
            call juststr('l',gtp,7)
            write(*,'(1x,3a,1x,$)') 
     &         curloc(1:eow(curloc)), '=', gtp(1:eow(gtp))
          end if
        else if (loctyp(j).eq.4) then
          call wraff(locus(idx,lpos),ch)
          write(*,'(1x,3a,1x,$)') curloc(1:eow(curloc)), '=', ch
        else 
          call wrtrait(locus(idx,lpos),cval,3)
          call juststr('l',cval,10)
          write(*,'(1x,3a,1x,$)') 
     &        curloc(1:eow(curloc)), '=', cval(1:eow(cval))
        end if
      end if
   25 continue
      write(*,*)
      return
      end
C end-of-wrind 
