c
c     Program to create starting Covariance Matrices
c     for genetic analyses
c     derived from phenotypic variances,
c
      Parameter (no=25, nog=((no+1)*no/2),np=26,npp=nog+np)
      Character*80 bluff
      Character*12 anim,farm

      Real*8 GG(nog),PP(nog),HH(nog),RR(nog),x,y,z,dx(np)
      Real*8 SS(npp),x1,x2,x3,x4,h2(no),rep(no),hys(no),zm
      integer iy(no),jdate,bdate,agej,ageg,judg,iam,
     x iymj,ihys,kpar,icod

      open(10,file='TYP08.d',form='formatted',status='old')
      GG=0.d0
      RR=0.d0
      PP=0.d0
      HH=0.d0
      SS=0.d0
 10   Read(10,1010,end=99)anim,iam,farm,jdate,bdate,agej,ageg,
     x judg,iymj,ihys,kpar,icod,iy
 1010 format(1x,a12,i10,1x,a12,2i9,3i5,2i8,2i3,25i3)
      if(icod.ne.28)go to 10
      dx=0.d0
       dx(1)=1.d0
      do 16 ir=1,no
         jr=ir+1
         dx(jr)=dfloat(iy(ir))
 16   continue
      m=0
      do 17 ir=1,np
         x=dx(ir)
         do 18 ic=ir,np
            m=m+1
            SS(m)=SS(m)+x*dx(ic)
 18      continue
 17   continue   
      go to 10
 99   close(10)
c make covariance matrix no x no
      z=SS(1)
      do 31 ir=2,np
         dx(ir)=SS(ir)/z
 31   continue
      zm=z-1.d0
      do 32 ir=2,np
         do 33 ic=ir,np
            m=ihmssf(ir,ic,np)
            SS(m)=(SS(m)-dx(ir)*SS(ic))/zm
 33      continue
 32   continue   
c
c  read in trait heritabilities
c   - form a diagonal GG, HH, PP, and RR=SS-GG-HH-PP
c   - force RR to be p.d.
c
      open(11,file='TRAITS.d',form='formatted',status='old')
      read(11,1102,end=102)bluff
 1102 format(1x,a80)
 11   read(11,1101,end=102)ir,x
 1101 format(1x,i3,4x,f6.3)
      h2(ir)=x
      go to 11
 102  close(11)
c
      do 23 ir=1,no
         jr=ir+1
         m=ihmssf(ir,ir,no)
         mss = ihmssf(jr,jr,np)
         GG(m)=SS(mss)*h2(ir)
         PP(m)=GG(m)*0.1d0
         HH(m)=GG(m)*0.3d0
 23   continue
      do 24 ir=1,no
         jr=ir+1
         do 25 ic=ir,no
            jc=ic+1
            mss=ihmssf(jr,jc,np)
            k=ihmssf(ir,ic,no)
         RR(k)=SS(mss)-GG(k)-PP(k)-HH(k)
 25      continue
 24   continue   
c
      call force(RR,no)
c
c     write out new file
c
      open(12,file='TTmi.d',form='formatted',status='unknown')
      write(12,1201)
 1201 format(1x,'Genetic CoVariance Matrix')
      write(12,1202)
 1202 format(1x,' Row Col',10x,'G  P  H  R')
      bluff = '(1x,2i4,4f15.7)'
      write(12,1203)bluff
 1203 format(1x,a80)
      
      m=0
      do 51 ir=1,no
         do 51 ic=ir,no
            m=m+1
            x1=GG(m)
            x2=PP(m)
            x3=HH(m)
            x4=RR(m)
            write(12,1204)ir,ic,x1,x2,x3,x4
 1204       format(1x,2i4,4f15.7)
 51      continue
c
      close(12)
      stop
      end
      include 'zforce.f'