C
C extract unrelated individuals with information for a criterion trait
C
      subroutine wricas(wrk,twrk,trait,pedigree,actset,
     &                  num,nfound,id,fa,mo,sex,locus,numloc)
      integer MAXSIZ,MAXLOC,MISS
      parameter (MAXSIZ=1000,MAXLOC=120,MISS=-9999)
      integer trait,wrk,twrk
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 aff(MAXSIZ)

      logical last
      integer eop, i, nuse, tuse
      character*10 fam
C functions
      integer eow
      
      tuse=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) then
          call wrkout(twrk,pedigree,actset,num,nfound,id,fa,mo,sex,
     &                locus,numloc)
          goto 10
        end if
       
        do 50 i=1, nfound
          if (locus(i,trait).ne.MISS) then
            aff(i)=2
          else
            aff(i)=1
          end if
   50   continue
        do 70 i=nfound+1, num
          if (aff(fa(i)).eq.1 .and. aff(mo(i)).eq.1) then 
            if (locus(i,trait).ne.MISS) then
              aff(i)=2
              aff(fa(i))=3
              aff(mo(i))=3
            else 
              aff(i)=1
            end if
          else 
            aff(i)=3
          end if
   70   continue

        nuse=0
        eop=eow(pedigree)
        do 100 i=1, num
        if (aff(i).eq.2) then
          nuse=nuse+1
          fam=pedigree
          call makeind(nuse,eop,fam)
          write(twrk) fam, actset, 1, 1  
          write(twrk) id(i),MISS,MISS,sex(i),(locus(i,j),j=1,numloc)
        end if
  100   continue
        tuse=tuse+nuse
      goto 10
   20 continue
      write(*,'(a,i6,a)') 'Extracted ',tuse,' cases.'
      return
      end
C end-of-getcas 
C
C convert into nuclear families, duplicating individuals as needed
C
      subroutine nuclear(wrk,twrk,pedigree,actset,num,nfound,
     &                   id,fa,mo,sex,locus,numloc,maxsibs,typ)
      integer MAXSIZ,MAXLOC
      parameter (MAXSIZ=1000,MAXLOC=120)
      integer maxsibs,wrk,twrk,typ
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)
      logical last

      integer currf, currm, eop, nuc, pos, sta

C functions
      integer eow

      maxsibs=maxsibs-1

      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 (nfound.eq.num .or. actset.le.0) then
         call wrkout(twrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &              numloc)
       else
         nuc=0
         eop=eow(pedigree)
         pos=nfound+1
         sta=pos
         currf=fa(sta)
         currm=mo(sta)
   50    continue
           if (fa(pos).ne.currf .or. mo(pos).ne.currm) 
     &     then
             nuc=nuc+1
             call onefam(twrk,pedigree,actset,num,nfound,
     2               id,fa,mo,sex,locus,numloc,maxsibs,
     3               eop, nuc, currf, currm, sta, pos-1, typ)
             sta=pos
             currf=fa(sta)
             currm=mo(sta)
           end if
           pos=pos+1
         if (pos.le.num) goto 50
C last sibship
         nuc=nuc+1
         call onefam(twrk,pedigree,actset,num,nfound,
     2           id,fa,mo,sex,locus,numloc,maxsibs,
     3           eop, nuc, currf, currm, sta, num, typ)
       end if
      goto 10
   20 continue
      return
      end
C end-of-nuclear
C
C write out current nuclear family -- with or without grandparents
C
      subroutine onefam(twrk,pedigree,actset,num,nfound,
     2                  id,fa,mo,sex,locus,numloc,maxsibs,
     3                  eop, nuc, currf, currm, sta, fin, typ)
      integer MAXSIZ,MAXLOC,MISS
      parameter (MAXSIZ=1000,MAXLOC=120,MISS=-9999)
      integer maxsibs, twrk, typ
      integer currf, currm, eop, fin, nuc, sta
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)

      character*10 fam
      integer gp1, gp2, gp3, gp4, i, j, nfou, nsibs, p1, p2

      fam=pedigree
      call makeind(nuc,eop,fam)
      nsibs=min(fin-sta,maxsibs)+1
      nfou=0
      gp1=MISS
      gp2=MISS
      gp3=MISS
      gp4=MISS
      p1=1
      p2=2
      if (typ.eq.2) then
        if (currf.gt.nfound) then
          nfou=nfou+2
          p1=p1+2
          p2=p2+2
          gp1=1
          gp2=2
        end if
        if (currm.gt.nfound) then
          nfou=nfou+2
          p1=p1+2
          p2=p2+2
          gp3=max(gp2,0)+1
          gp4=gp3+1
        end if
      end if
      write(twrk) fam, actset, nsibs+2+nfou, max(2,nfou)
C Grandparents
      if (typ.eq.2) then
        if (currf.gt.nfound) then
          write(twrk) id(fa(currf)),MISS,MISS,1, 
     &      (locus(fa(currf),j),j=1,numloc)
          write(twrk) id(mo(currf)),MISS,MISS,2, 
     &      (locus(mo(currf),j),j=1,numloc)
        end if
        if (currm.gt.nfound) then
          write(twrk) id(fa(currm)),MISS,MISS,1, 
     &      (locus(fa(currm),j),j=1,numloc)
          write(twrk) id(mo(currm)),MISS,MISS,2, 
     &      (locus(mo(currm),j),j=1,numloc)
        end if
      end if
C Parents
      write(twrk) id(currf),gp1,gp2,1, 
     &  (locus(currf,j),j=1,numloc)
      write(twrk) id(currm),gp3,gp4,2, 
     &  (locus(currm,j),j=1,numloc)
C Children
      do 55 i=sta,min(sta+maxsibs,fin)
        write(twrk) id(i),p1,p2,sex(i),
     &    (locus(i,j),j=1,numloc)
   55 continue
      return
      end
C end-of-onefam 
C
C chop into disjoint subpedigrees
C note that the pointers in set(,2) do not follow the sort order of
C the pedigree, as connect() moves both up and down the generations
C
      subroutine disjoin(wrk,twrk,pedigree,actset,num,nfound,id,fa,mo,
     &                   sex,locus,numloc,ord,set,plevel)
      integer MAXSIZ,MAXLOC,MISS
      parameter (MAXSIZ=1000,MAXLOC=120,MISS=-9999)
      integer plevel, wrk, twrk
C Pedigree structure
      character*10 pedigree
      integer actset,num,nfound 
      character*8 id(MAXSIZ) 
      integer fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ)
      integer ord(MAXSIZ), set(MAXSIZ,2)
      integer numloc
      real locus(MAXSIZ,MAXLOC)
      logical last
      integer curped, eop, maxgrp, nf, nsub, no
      character*10 fam
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) then
           call wrkout(twrk,pedigree,actset,num,nfound,id,fa,mo,sex,
     &                 locus,numloc)
           goto 10
         end if
         call connect(num,fa,mo,set,nsub,maxgrp)
         if (plevel.gt.0) then
           write(*,'(3a,i4,a)') 'Pedigree ',pedigree,' written out as ',
     &       nsub,' pedigrees.'
         end if
         if (nsub.eq.1) then
           call wrkout(twrk,pedigree,actset,num,nfound,id,fa,mo,sex,
     &                 locus,numloc)
         else
           eop=eow(pedigree)
           do 15 curped=1,nsub
             nf=0
             no=0
             do 25 i=1,nfound
             if (set(i,1).eq.curped) then
               no=no+1
               nf=nf+1
               ord(i)=no
             end if
   25        continue
             do 26 i=nfound+1,num 
             if (set(i,1).eq.curped) then
               no=no+1
               ord(i)=no
             end if
   26        continue
             fam=pedigree
             call makeind(curped,eop,fam)
             if (plevel.gt.1) then
               write(*,'(2a)') 'Created pedigree ',fam
             end if
             write(twrk) fam, actset, no, nf
             do 30 i=1,nfound
             if (set(i,1).eq.curped) then
               write(twrk) id(i),MISS,MISS,sex(i),
     &           (locus(i,j),j=1,numloc)
             end if
   30        continue
             do 31 i=nfound+1,num 
             if (set(i,1).eq.curped) then
               write(twrk) id(i),ord(fa(i)),ord(mo(i)),sex(i),
     &           (locus(i,j),j=1,numloc)
             end if
   31        continue
   15      continue
         end if
      goto 10
   20 continue
      return
      end
C end-of-disjoin
C
C Edit alleles for particular gene for particular person 
C
      subroutine edit(wrk,twrk,tped,tid,gene,loc,loctyp,all1,all2,
     2                pedigree,actset,num,nfound,id,fa,mo,sex,
     3                locus,numloc)
      integer MAXSIZ,MAXLOC,MISS
      parameter (MAXSIZ=1000,MAXLOC=120,MISS=-9999)
      integer twrk,wrk
C target pedigree,id,replacement alleles
      character*8 tid
      character*10 tped,loc
      integer gene,loctyp
      real all1,all2
C Pedigree structure
      character*10 pedigree
      integer actset,num,nfound 
      character*8 id(MAXSIZ) 
      integer fa(MAXSIZ),mo(MAXSIZ),sex(MAXSIZ)
      integer numloc
      real locus(MAXSIZ,MAXLOC)
      logical last
C
      integer i,j,eop,gen2
      logical all
      real tmp
      character*1 newbin,oldbin
      character*7 newgtp,oldgtp
      character*10 chid
C functions
      integer eow

      all=(tid.eq.'all     ')
      eop=eow(tped)
      gen2=gene+1
      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.gt.0 .and. tped .eq. pedigree) then
          do 15 i=1,num
          if (all .or. tid .eq. id(i)) then
            call wrid('l',id(i),chid,0)
            if (gene .eq. MISS) then
              write(*,'(4a)') 
     2          'Deleting all data for ',
     3          pedigree(1:eop),'-',chid(1:eow(chid)) 
              do 12 j=1,numloc
                locus(i,j)=MISS
   12         continue
            elseif (loctyp .le. 2) then
              if (all1.gt.all2) then
                tmp=all1
                all1=all2
                all2=tmp
              end if
              call wrgtp(int(all1),int(all2),newgtp,1)
              call wrgtp(int(locus(i,gene)),int(locus(i,gen2)),oldgtp,1)
              write(*,'(10a)') 
     2          'Changing ',pedigree(1:eop),'-',chid(1:eow(chid)),
     3          ' at locus "',loc(1:eow(loc)), 
     4          '" from ',oldgtp, ' to ',newgtp
              locus(i,gene)=all1
              locus(i,gen2)=all2
            elseif (loctyp .eq. 3) then
              write(*,'(7a,f8.4,a,f8.4)') 
     2          'Changing ',pedigree(1:eop),'-',chid(1:eow(chid)),
     3          ' at locus "',loc(1:eow(loc)),
     4          '" from ',locus(i,gene),' to ',all1
              locus(i,gene)=all1
            elseif (loctyp .eq. 4) then
              call wraff(all1,newbin)
              call wraff(locus(i,gene),oldbin)
              write(*,'(7a,a8,a,a8)') 
     2          'Changing ',pedigree(1:eop),'-',chid(1:eow(chid)),
     3          ' at locus "',loc,
     4          '" from ', oldbin,' to ',newbin
              locus(i,gene)=all1
            end if
          end if
   15     continue
        end if
        call wrkout(twrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &              numloc)
      goto 10
   20 continue
      return
      end
C end-of-edit
C
C include or exclude a list of pedigrees
C
      subroutine selped(wrk,twrk,typ,farg,larg,words,pedigree,actset,
     &                  num, nfound,id,fa,mo,sex,locus,numloc,plevel)
      integer MAXLOC, MAXCOL, MAXSIZ, MISS
      parameter (MAXLOC=120, MAXCOL=MAXLOC+5, MAXSIZ=1000, MISS=-9999)

      integer farg,larg,plevel,twrk,typ,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)
      logical last
C
      integer i, nfam
      logical found, ltyp

      ltyp=.not.(typ.eq.1) 

      nfam=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
        found=ltyp
        do 50 i=farg, larg
        if (actset.gt.0 .and. pedigree.eq.words(i)(1:10)) then
          found=.not.found
          goto 60
        end if
   50   continue

   60   continue
        if (found) then
          nfam=nfam+1
          if (plevel.gt.0) write(*,'(2a)') 'Selected pedigree ',pedigree
        else
          actset=-abs(actset)
        end if
        call wrkout(twrk,pedigree,actset,num,nfound,id,fa,mo,sex,
     &              locus,numloc)
      goto 10
   20 continue
      write(*,'(/a,i6,a)') 'Selected ',nfam,' pedigrees.'
      return
      end
C end-of-selped
C
C identify rare alleles at a marker locus and list for combination
C
      subroutine combine(crit,recto,nf,recfro,numal,name,alfrq)
      integer KNOWN,MAXSIZ,MAXLOC,MAXALL
      parameter (KNOWN=0,MAXSIZ=1000,MAXLOC=120,MAXALL=60)
      integer nf
      real crit,recto,recfro(MAXALL)
C allele frequencies within entire sample for given locus 
      integer numal, name(MAXALL)
      double precision alfrq(MAXALL)

      nf=0
      do 10 i=1, numal
      if (alfrq(i).le.crit) then
        nf=nf+1
        recfro(nf)=name(i)
      end if
   10 continue
C recode to 999 or nearest available allele number
      recto=1000.0
   20 continue
        recto=recto-1.0
      do 30 i=1, numal
        if (int(recto).eq.name(i)) goto 20
   30 continue
      return
      end
C end-of-combine
C
C recode alleles or values for particular locus -- 
C replace all "from" values with "to" values
C
      subroutine recode(wrk,twrk,loc,gene,typ,recto,nf,recfro,
     &             pedigree,actset,num,nfound,id,fa,mo,sex,locus,numloc)
      integer KNOWN,MAXSIZ,MAXLOC,MAXALL
      parameter (KNOWN=0,MAXSIZ=1000,MAXLOC=120,MAXALL=60)
      integer gene,nf,twrk,typ,wrk
      character*10 loc
      real recto,recfro(MAXALL)
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)
      logical last
C
      integer i,j,gen2, nchange

      write(*,'(/a,a10)') 'Recoding locus ',loc
      write(*,'(a,30(1x,f4.0):)') 'From: ',(recfro(i),i=1,nf)
      write(*,'(a,1x,f4.0/)')     'To  : ',recto

      gen2=gene+1
      nchange=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.gt.0) then
          if (typ.eq.1) then
            do 15 i=1,num
            do 15 j=1,nf
              if (abs(locus(i,gene)).eq.recfro(j)) then
                locus(i,gene)=sign(1.0,locus(i,gene))*recto
                if (locus(i,gene).gt.KNOWN) nchange=nchange+1
              end if
              if (abs(locus(i,gen2)).eq.recfro(j)) then
                locus(i,gen2)=sign(1.0,locus(i,gen2))*recto
                if (locus(i,gen2).gt.KNOWN) nchange=nchange+1
              end if
   15       continue
          else
            do 25 i=1,num
            do 25 j=1,nf
              if (locus(i,gene).eq.recfro(j)) then
                locus(i,gene)=recto
                nchange=nchange+1
              end if
   25       continue
          end if
        end if
        call wrkout(twrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &              numloc)
      goto 10
   20 continue
      write(*,'(a,i6,a)') 'Recoded ',nchange,' values.'
      return
      end
C end-of-recode
C
C Kaplan-Meier estimator of survival function and the Nelson-Aalen 
C estimator of cumulative hazard.
C The Nelson-Aalen estimator is used to produce residuals, if requested.
C These are the deviance residuals of Therneau et al Biometrika 1990:
C equivalent to a variance-stabilized transformed martingale residual.
C
C
      subroutine prodlim(wrk,twrk,trait,censor,pedigree,actset,num,
     2             nfound,id,fa,mo,sex,locus,numloc,
     3             onset,haz,set,typ,plevel)
C
      integer MAXSIZ, MAXLOC, MISS
      parameter(MAXSIZ=1000, MAXLOC=120, MISS=-9999)
      integer censor, plevel, trait, twrk, typ, wrk
C  Pedigree structure
      character*10 pedigree
      integer actset, num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ)
      integer numloc
      real locus(MAXSIZ,MAXLOC)
C Age at onset, associated survival function
      integer naff, nobs, nvals, unaff
      real onset(MAXSIZ), haz(MAXSIZ)
      integer set(MAXSIZ,2)
C local variables
      integer i,j,k
      real res,x
      double precision dn, na, pl, va
      logical last

      naff=0
      nobs=0
      nvals=0
      do 1 i=1,MAXSIZ
        set(i,1)=0
        set(i,2)=0
    1 continue

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

        if (actset.gt.0) then
         do 10 i=1,num
         if (locus(i,trait).ne.MISS) then
           nobs=nobs+1
           x=locus(i,trait)
           j=0
   15      continue
             j=j+1
           if (x.gt.onset(j) .and. j.le.nvals) goto 15
           if (x.ne.onset(j)) then
             if (nvals.lt.MAXSIZ) then
               do 30 k=nvals,j,-1
                 onset(k+1)=onset(k)
                 set(k+1,1)=set(k,1)
                 set(k+1,2)=set(k,2)
   30          continue
               nvals=nvals+1
               onset(j)=x
               set(j,1)=0
               set(j,2)=0
             else
               j=nvals
             end if
           end if
           set(j,2)=set(j,2)+1
           if (locus(i,censor).eq.2) then
             naff=naff+1
             set(j,1)=set(j,1)+1
           end if
         end if
   10    continue
        end if
      goto 5
   20 continue

      if (plevel.gt.1) then
        write(*,'(2(/a))') 
     2    ' Rank  Age-at-onset  Failed     Obs',
     3    ' ----------------------------------' 
        do 50 j=1,nvals
          write(*,'(1x,i4,2x,f12.4,2i8)') j,onset(j),set(j,1),set(j,2)
   50   continue
      end if
      write(*,'(2(/a))') 
     2  ' Age-at-onset   Failed  Riskset   H(t)   S(t)    ase',
     3  ' ---------------------------------------------------' 
      na=0.0d0
      pl=1.0d0
      va=0.0d0
      unaff=nobs-naff
      do 110 j=1,nvals
        if (set(j,1).ne.0) then
          dn=dfloat(set(j,1))/dfloat(nobs)
          na=na+dn
          pl=pl*(1.0d0-dn)
          va=va+dn/dfloat(max(1,nobs-set(j,1)))
          write(*,'(1x,f12.4,2(1x,i8),3(1x,f6.4))') 
     &      onset(j),set(j,1),nobs,na,pl,pl*sqrt(va)
        end if
        haz(j)=sngl(na)
        nobs=nobs-set(j,2)
  110 continue
      write(*,'(/a/a//i5,a,i5,a)')
     2  ' H(t) = Nelson-Aalen estimator of integrated hazard',
     3  ' S(t) = Kaplan-Meier estimator of survivor function',
     4  naff,' affecteds and ',unaff,' unaffecteds used'
      if (typ.eq.1) return
C
C else replace age-at-onset with residual
C
      rewind(wrk)
  175 continue
        call wrkin(wrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &             numloc, last)
        if (last) goto 190

        if (actset.gt.0) then
         do 180 i=1,num
         if (locus(i,trait).ne.MISS) then
           x=locus(i,trait)
           j=0
  185      continue
             j=j+1
           if (x.gt.onset(j) .and. j.le.nvals) goto 185
           if (locus(i,censor).eq.2.0) then
             res=1.0-haz(j)
             locus(i,trait)=sign(1.0,res)*sqrt(-2.0*(res+log(1.0-res)))
           else
             locus(i,trait)=-sqrt(2.0*haz(j))
           end if
         end if
  180    continue
        end if
        call wrkout(twrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &              numloc)
      goto 175
  190 continue
      return
      end
C end-of-prodlim
C
C standardization of quantitative trait overall or *within* family
C as required by the approach of Commenge 
C
      subroutine stand(wrk,twrk,trait,pedigree,actset,num,
     &             nfound,id,fa,mo,sex,locus,numloc,typ)
C
      integer MAXSIZ, MAXLOC, MISS
      parameter(MAXSIZ=1000, MAXLOC=120, MISS=-9999)
      integer wrk, twrk, trait, typ
C  Pedigree structure
      character*10 pedigree
      integer actset, num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ)
      integer numloc
      real locus(MAXSIZ,MAXLOC)
      integer i, n
      double precision mu, sd
      logical last

      last=.false.
      rewind(wrk)
      if (typ.eq.2) then
    5   continue
          call wrkin(wrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &               numloc, last)
          if (last) goto 20

          if (actset.gt.0) then
            n=0
            mu=0.0d0
            sd=0.0d0
            do 10 i=1,num
            if (locus(i,trait).ne.MISS) then
              n=n+1
              call moment(n,dble(locus(i,trait)),mu,sd)
            end if
   10       continue
C
            if (n.gt.0) then
              sd=sqrt(sd/dfloat(max(1,n-1)))
              do 30 i=1,num
              if (locus(i,trait).ne.MISS) then
                locus(i,trait)=sngl((dble(locus(i,trait))-mu)/sd)
              end if
   30         continue
            end if
          end if
          call wrkout(twrk,pedigree,actset,num,nfound,id,fa,mo,sex,
     &                locus, numloc)
        goto 5
   20   continue
      elseif (typ.eq.1) then
        n=0
        mu=0.0d0
        sd=0.0d0
   55   continue
          call wrkin(wrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &               numloc, last)
          if (last) goto 70

          if (actset.gt.0) then
            do 60 i=1,num
            if (locus(i,trait).ne.MISS) then
              n=n+1
              call moment(n,dble(locus(i,trait)),mu,sd)
            end if
   60       continue
          end if
        goto 55
   70   continue
C
        sd=sqrt(sd/dfloat(max(1,n-1)))
        rewind(wrk)
   75   continue
          call wrkin(wrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &               numloc, last)
          if (last) goto 90
          if (actset.gt.0) then
            do 80 i=1,num
            if (locus(i,trait).ne.MISS) then
              locus(i,trait)=sngl((dble(locus(i,trait))-mu)/sd)
            end if
   80       continue
          end if
          call wrkout(twrk,pedigree,actset,num,nfound,id,fa,mo,sex,
     &                locus, numloc)
        goto 75
   90   continue
      end if
      return
      end
C end-of-stand
C
C linear regression correction of quantitative trait 1 versus trait 2
C
      subroutine adjust(wrk,twrk,ytrait,xtrait,adjval,pedigree,actset,
     &                  num,nfound,id,fa,mo,sex,locus,numloc,plevel)
C
      integer MAXSIZ, MAXLOC, MISS
      parameter(MAXSIZ=1000, MAXLOC=120, MISS=-9999)
      integer wrk, twrk, ytrait, xtrait, plevel
      real adjval
C  Pedigree structure
      character*10 pedigree
      integer actset,num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ)
      integer numloc
      real locus(MAXSIZ,MAXLOC)
      integer n, i, ifail
      logical last
C regression results
      double precision x(3),r(6),b(2)
      double precision alpha,beta,mux 
      n=0
      ifail=0
      mux=0.0d0
      call inicov(3, 6, r)

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

        if (actset.gt.0) then
         do 10 i=1,num
         if (locus(i,ytrait).ne.MISS .and. locus(i,xtrait).ne.MISS) then
           n=n+1
           x(1)=1.0d0
           x(2)=dble(locus(i,xtrait))
           x(3)=dble(locus(i,ytrait))
           mux=mux+x(2)
           call givenc(r, 6, 3, x, 1.0d0, ifail)
         end if
   10    continue
        end if
      goto 5
   20 continue
C
      call bsub(r, 6, 3, b, 2, ifail)
      alpha=b(1)
      beta=b(2)
      mux=mux/dfloat(n) 
      if (adjval.eq.MISS) adjval=sngl(mux)
      if (plevel.gt.0) then
        write(*,'(a,f12.4/2(a,f12.4),a,i4,a/)') 
     2    'Adjusting to x-value of ',adjval,
     3    'y = ',alpha,' + ',beta,' * x  (based on ',n,' values)' 
      end if
      if (ifail.gt.0) then
        write(*,'(a/)') 'ERROR: Regression routine problem.'
        return
      end if
C
      rewind(wrk)
   25 continue
        call wrkin(wrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &             numloc, last)
        if (last) goto 40

        if (actset.gt.0) then
         do 30 i=1,num
         if (locus(i,ytrait).ne.MISS) then
           if (locus(i,xtrait).ne.MISS) then
             locus(i,ytrait)=locus(i,ytrait)+
     &                       sngl(beta*dble(adjval-locus(i,xtrait)))
           else
             locus(i,ytrait)=locus(i,ytrait)+
     &                       sngl(beta*(dble(adjval)-mux))
           end if
         end if
   30    continue
        end if
        call wrkout(twrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &              numloc)
      goto 25
   40 continue
      return
      end
C end-of-adjust
C
C transform quantitative trait value
C
C t(x) =    { (x-offset)/divisor }                    Power == 1
C t(x) = log{ (x-offset)/divisor }                    Power == 0
C t(x) =   [{ (x-offset)/divisor }**Power - 1]/Power  Power != 0 && !=1
C Resulting values can be truncated above or below
C
      subroutine boxcox(wrk,twrk,trait,offset,divisor,power,loval,hival,
     &             pedigree,actset,num,nfound,id,fa,mo,sex,locus,numloc)
      integer MAXSIZ,MAXLOC,MISS
      parameter (MAXSIZ=1000,MAXLOC=120,MISS=-9999)
      integer trait,twrk,wrk
      real divisor, hival, loval, offset, power
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)
      logical last
C
      integer i,ifault
      real x

      ifault=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.gt.0) then
        if (power.eq.1.0) then
          do 15 i=1,num
          if (locus(i,trait).ne.MISS) then
            locus(i,trait)=(locus(i,trait)-offset)/divisor
          end if
   15     continue
        elseif (power.eq.0.0) then
          do 25 i=1,num
          if (locus(i,trait).ne.MISS) then
            x=(locus(i,trait)-offset)/divisor
            if (x.le.0) then
              ifault=ifault+1
              locus(i,trait)=MISS
            else
              locus(i,trait)=log(x)
            end if
          end if
   25     continue
        else
          do 35 i=1,num
          if (locus(i,trait).ne.MISS) then
            x=(locus(i,trait)-offset)/divisor
            if ((mod(power,1.0).ne.0.0 .and. x.lt.0) .or.
     2          (power.lt.0.0 .and. x.eq.0.0))  then
              ifault=ifault+1
              locus(i,trait)=MISS
            else
              locus(i,trait)=(x**power-1.0)/power
            end if
          end if
   35     continue
        end if
        if (loval.ne.MISS) then
          do 45 i=1,num
          if (locus(i,trait).ne.MISS .and. locus(i,trait).lt.loval) then
            locus(i,trait)=loval
          end if
   45     continue
        end if
        if (hival.ne.MISS) then
          do 55 i=1,num
          if (locus(i,trait).ne.MISS .and. locus(i,trait).gt.hival) then
            locus(i,trait)=hival
          end if
   55     continue
        end if
       end if
        call wrkout(twrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &              numloc)
      goto 10
   20 continue

      if (ifault.gt.0) then
        write(*,'(/a,i5,2a/7x,a/)') 
     2    'NOTE:  There were ',ifault,' trait values that could not be',
     3    ' transformed as requested.','New values were set to missing.'
      end if
      return
      end
C end-of-boxcox
C
C Convert a genotype to a quantitative trait
      subroutine factor(wrk,twrk,trget, gene, numal, name, 
     2                  pedigree,actset,num,nfound,id,fa,mo,sex, 
     3                  locus,numloc)
      integer KNOWN,MAXSIZ,MAXLOC,MAXALL,MISS
      parameter (KNOWN=0,MAXSIZ=1000,MAXLOC=120,MAXALL=60,MISS=-9999)
      integer gene,numloc,trget,twrk,wrk
C alleles at the marker
      integer numal, name(MAXALL)
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)
      logical last
C
      integer g1,g2,gen2,i
C functions
      integer getnam

      gen2=gene+1
      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.gt.0) then
          do 30 i=1,num
            locus(i,trget)=MISS
            if (locus(i,gene).gt.KNOWN) then
              g1=getnam(locus(i,gene),numal,name)
              g2=getnam(locus(i,gen2),numal,name)
              locus(i,trget)=float(numal*(g1-1)+g2)
            end if
   30     continue
        end if
        call wrkout(twrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &              numloc)
      goto 10
   20 continue
      return
      end
C end-of-factor
C
      subroutine dorank(wrk,twrk,trget,trait,pedigree,actset,num,nfound,
     &             id,fa,mo,sex,locus,numloc,value,count)
C
      integer MAXSIZ, MAXLOC, MISS
      parameter(MAXSIZ=1000,MAXLOC=120,MISS=-9999)
      integer trget, trait, twrk, wrk
C  Pedigree structure
      character*10 pedigree
      integer actset, num, nfound
      character*8 id(MAXSIZ)
      integer fa(MAXSIZ), mo(MAXSIZ), sex(MAXSIZ)
      integer numloc
      real locus(MAXSIZ,MAXLOC)
C Quantitative trait values
      integer nvals
      real value(MAXSIZ)
      integer count(MAXSIZ)
C local variables
      integer i
      logical last
C functions
      real rank
C
      nvals=0
C
C Tabulate sorted values and frequencies
      last=.false.
      rewind(wrk)
    5 continue
        call wrkin(wrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &             numloc, last)
        if (last) goto 20

        if (actset.gt.0) then
         do 10 i=1,num
         if (locus(i,trait).ne.MISS) then
           call qtab(locus(i,trait),nvals,value,count)
         end if
   10    continue
        end if
      goto 5
   20 continue
C Replace with cumulative counts
      do 100 i=2, nvals
        count(i)=count(i)+count(i-1)
  100 continue
C
C Give rank of each record
      last=.false.
      rewind(wrk)
   25 continue
        call wrkin(wrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &             numloc, last)
        if (last) goto 40

        if (actset.gt.0) then
          do 30 i=1,num
          if (locus(i,trait).ne.MISS) then
            locus(i,trget)=rank(locus(i,trait),nvals,value,count)
          end if
   30     continue
        end if
        call wrkout(twrk,pedigree,actset,num,nfound,id,fa,mo,sex,locus,
     &              numloc)
      goto 25
   40 continue
      return
      end
C end-of-dorank
C
C Binary search for closest position of value in an ascending sorted array
C Closest position
C
      real function rank(val,num,key,cumcnt)
      integer num, cumcnt(*)
      real val, key(*)
      
      integer hi, lo, pos

      hi=num
      lo=1
   10 continue
        pos=(hi+lo)/2
        if (val.gt.key(pos)) then
          lo=pos+1
        elseif (val.lt.key(pos)) then
          hi=pos-1
        else
          goto 20
        end if
      if (hi.ge.lo) goto 10
   20 continue
      lo=0
      if (pos.gt.1) lo=cumcnt(pos-1)
      rank=0.5*float(lo+cumcnt(pos)+1)
      return
      end
C end-of-rank 
