module kinds
  ! From Ignacy Misztal BLUPF90 distribution 
  integer, parameter :: single = SELECTED_REAL_KIND( 6, 37 )
  integer, parameter :: double = SELECTED_REAL_KIND( 15, 307 )
  integer, parameter :: extended = SELECTED_REAL_KIND( 18, 4931 )
  integer, parameter :: r4 = SELECTED_REAL_KIND( 6, 37 )
  integer, parameter :: r8 = SELECTED_REAL_KIND( 15, 307 )
  integer, parameter :: r16 = SELECTED_REAL_KIND( 18, 4931 )

  ! current precison for hash storage
  integer, parameter :: rh=r8
end module kinds

!This is a collection of modules useful for bootstrapping

MODULE Ecuyer_random
  ! L'Ecuyer's 1996 random number generator.
  ! Fortran version by Alan.Miller @ vic.cmis.csiro.au
  ! N.B. This version is compatible with Lahey's ELF90
  ! http://www.ozemail.com.au/~milleraj
  ! Latest revision - 30 March 1999

  use kinds
  IMPLICIT NONE
  !INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(15, 307) !=real(8) con DVF

  ! These are unsigned integers in the C version
  INTEGER, SAVE :: s1 = 1234, s2 = -4567, s3 = 7890

CONTAINS

  SUBROUTINE init_seeds(i1, i2, i3)
    IMPLICIT NONE

    INTEGER, INTENT(IN) :: i1, i2, i3

    s1 = i1
    s2 = i2
    s3 = i3
    IF (IAND(s1,-2) == 0) s1 = i1 - 1023
    IF (IAND(s2,-8) == 0) s2 = i2 - 1023
    IF (IAND(s3,-16) == 0) s3 = i3 - 1023

    RETURN
  END SUBROUTINE init_seeds

  subroutine get_clock_seeds()
    ! set random seeds according to time
    implicit none
    integer:: v(8)
    call date_and_time(values=v)
    call init_seeds(v(6),v(7),v(8))
  end subroutine get_clock_seeds

  subroutine get_keyb_seeds()
    ! set  seeds from the keyboard
    ! needs THREE seeds
    implicit none
    integer:: v(3)
!!$    character(100)::in
    print *,'random seeds?'
    read (*,*)v

    call init_seeds(v(1),v(2),v(3))
  end subroutine get_keyb_seeds


  FUNCTION taus88() RESULT(random_numb)
    ! Generates a random number between 0 and 1.  Translated from C function in:
    ! Reference:
    ! L'Ecuyer, P. (1996) `Maximally equidistributed combined Tausworthe
    ! generators', Math. of Comput., 65, 203-213.

    ! The cycle length is claimed to be about 2^(88) or about 3E+26.
    ! Actually - (2^31 - 1).(2^29 - 1).(2^28 - 1).

    IMPLICIT NONE
    REAL (r8) :: random_numb

    INTEGER   :: b

    ! N.B. ISHFT(i,j) is a bitwise (non-circular) shift operation;
    !      to the left if j > 0, otherwise to the right.

    b  = ISHFT( IEOR( ISHFT(s1,13), s1), -19)
    s1 = IEOR( ISHFT( IAND(s1,-2), 12), b)
    b  = ISHFT( IEOR( ISHFT(s2,2), s2), -25)
    s2 = IEOR( ISHFT( IAND(s2,-8), 4), b)
    b  = ISHFT( IEOR( ISHFT(s3,3), s3), -11)
    s3 = IEOR( ISHFT( IAND(s3,-16), 17), b)
    !random_numb = IEOR( IEOR(s1,s2), s3) * 2.3283064365E-10_dp + 0.5_dp
    random_numb = IEOR( IEOR(s1,s2), s3) * 2.3283064365E-10_r8 + 0.5_r8

    RETURN
  END FUNCTION taus88

END MODULE Ecuyer_random
!----------------------!

module random
  use Ecuyer_random
  use kinds
CONTAINS

  function normal01() RESULT(z)
    !     z -> n(0,1)
    implicit none
    real(r8):: z,u1,u2
    u1=unif()
    u2=unif()
    z=((-2.d0*log(u1))**0.5d0)*cos(2.d0*3.1416d0*u2)
  end function normal01

  function normal(mean,var) RESULT(z)
    !     normal z -> n(mean,var)
    implicit none      
    real(r8):: z,var,mean
    z=normal01()*sqrt(var)+mean
  end function normal

  function unif() result(u)
    ! Unif(0-1)
    implicit none
    real(r8) :: u
    u=taus88()
  end function unif

  function unifint(bound1,bound2) result(u)
    ! integer between bound1 and bound2
    implicit none
    integer :: bound1,bound2,u
    ! assuming bound1<bound2
    u=int(unif()*(bound2-bound1+1))+bound1
  end function unifint

  subroutine unifint_v(a,b,y)
    !vectorial extension for random integer FY
    implicit none
    integer :: a, b, y(:)
    integer :: i

    do i=1,size(y)
       ! print *,i
       y(i)=unifint(a, b)
    enddo
  end subroutine unifint_v


  subroutine random_gamma_v(s,b,fn_val)
    !vectorial extension for random gamma AL
    IMPLICIT NONE
    INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60) !double precision or r8

    REAL (dp), INTENT(IN)  :: s, b
    REAL (dp)              :: fn_val(:)
    integer :: i

    do i=1,size(fn_val)
       ! print *,i
       fn_val(i)=random_gamma(s, b)
    enddo

  end subroutine random_gamma_v

  FUNCTION random_gamma(s, b) RESULT(fn_val)

    ! Adapted from Fortran 77 code from the book:
    !     Dagpunar, J. 'Principles of random variate generation'
    !     Clarendon Press, Oxford, 1988.   ISBN 0-19-852202-9

    !     N.B. This version is in `double precision' and includes scaling

    !     FUNCTION GENERATES A RANDOM GAMMA VARIATE.
    !     CALLS EITHER random_gamma1 (S > 1.0)
    !     OR random_exponential (S = 1.0)
    !     OR random_gamma2 (S < 1.0).

    !     S = SHAPE PARAMETER OF DISTRIBUTION (0 < REAL).
    !     B = Scale parameter

    !AL from http://users.bigpond.net.au/amiller/random.html
    ! modified to include s==1 and to remove first, which is not practical

    IMPLICIT NONE
    INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60) !double precision or r8

    REAL (dp), INTENT(IN)  :: s, b
    REAL (dp)              :: fn_val

    ! Local parameters
    REAL (dp), PARAMETER  :: one = 1.0_dp, zero = 0.0_dp

    IF (s <= zero) THEN
       WRITE(*, *) 'SHAPE PARAMETER VALUE MUST BE POSITIVE'
       STOP
    END IF

    IF (s==one) then
       fn_val = random_exponential()
    elseif (s > one) THEN
       fn_val = random_gamma1(s)
    ELSE IF (s < one) THEN
       fn_val = random_gamma2(s)
    END IF

    ! Now scale the random variable
    fn_val = b * fn_val
    RETURN

  CONTAINS


    FUNCTION random_gamma1(s) RESULT(fn_val)

      ! Adapted from Fortran 77 code from the book:
      !     Dagpunar, J. 'Principles of random variate generation'
      !     Clarendon Press, Oxford, 1988.   ISBN 0-19-852202-9

      ! FUNCTION GENERATES A RANDOM VARIATE IN [0,INFINITY) FROM
      ! A GAMMA DISTRIBUTION WITH DENSITY PROPORTIONAL TO GAMMA**(S-1)*EXP(-GAMMA),
      ! BASED UPON BEST'S T DISTRIBUTION METHOD

      !     S = SHAPE PARAMETER OF DISTRIBUTION
      !          (1.0 < REAL)

      REAL (dp), INTENT(IN)  :: s
      REAL (dp)              :: fn_val

      !     Local variables
      REAL (dp)             :: d, r, g, f, x
      REAL (dp), SAVE       :: b, h
      REAL (dp), PARAMETER  :: sixty4 = 64.0_dp, three = 3.0_dp, pt75 = 0.75_dp,  &
           two = 2.0_dp, half = 0.5_dp

      IF (s <= one) THEN
         WRITE(*, *) 'IMPERMISSIBLE SHAPE PARAMETER VALUE'
         STOP
      END IF

      b = s - one
      h = SQRT(three*s - pt75)


      DO
         !  CALL RANDOM_NUMBER(r)
         r=unif()
         g = r - r*r
         IF (g <= zero) CYCLE
         f = (r - half)*h/SQRT(g)
         x = b + f
         IF (x <= zero) CYCLE
         !  CALL RANDOM_NUMBER(r)
         r=unif()
         d = sixty4*g*(r*g)**2
         IF (d <= zero) EXIT
         IF (d*x < x - two*f*f) EXIT
         IF (LOG(d) < two*(b*LOG(x/b) - f)) EXIT
      END DO
      fn_val = x

      RETURN
    END FUNCTION random_gamma1



    FUNCTION random_gamma2(s) RESULT(fn_val)

      ! Adapted from Fortran 77 code from the book:
      !     Dagpunar, J. 'Principles of random variate generation'
      !     Clarendon Press, Oxford, 1988.   ISBN 0-19-852202-9

      ! FUNCTION GENERATES A RANDOM VARIATE IN [0,INFINITY) FROM
      ! A GAMMA DISTRIBUTION WITH DENSITY PROPORTIONAL TO
      ! GAMMA2**(S-1) * EXP(-GAMMA2),
      ! USING A SWITCHING METHOD.

      !    S = SHAPE PARAMETER OF DISTRIBUTION
      !          (REAL < 1.0)

      REAL (dp), INTENT(IN)  :: s
      REAL (dp)              :: fn_val

      !     Local variables
      REAL (dp)             :: r, x, w
      REAL (dp), SAVE       :: a, p, c, uf, vr, d
      REAL (dp), PARAMETER  :: vsmall = EPSILON(one)

      IF (s <= zero .OR. s >= one) THEN
         WRITE(*, *) 'SHAPE PARAMETER VALUE OUTSIDE PERMITTED RANGE'
         STOP
      END IF

      a = one - s
      p = a/(a + s*EXP(-a))
      IF (s < vsmall) THEN
         WRITE(*, *) 'SHAPE PARAMETER VALUE TOO SMALL'
         STOP
      END IF
      c = one/s
      uf = p*(vsmall/a)**s
      vr = one - vsmall
      d = a*LOG(a)

      DO
         !  CALL RANDOM_NUMBER(r)
         r=unif()
         IF (r >= vr) THEN
            CYCLE
         ELSE IF (r > p) THEN
            x = a - LOG((one - r)/(one - p))
            w = a*LOG(x)-d
         ELSE IF (r > uf) THEN
            x = a*(r/p)**c
            w = x
         ELSE
            fn_val = zero
            RETURN
         END IF

         !  CALL RANDOM_NUMBER(r)
         r=unif()
         IF (one-r <= w .AND. r > zero) THEN
            IF (r*(w + one) >= one) CYCLE
            IF (-LOG(r) <= w) CYCLE
         END IF
         EXIT
      END DO

      fn_val = x
      RETURN

    END FUNCTION random_gamma2


  END FUNCTION random_gamma


  FUNCTION random_exponential() RESULT(ran_exp)


    ! Adapted from Fortran 77 code from the book:
    !     Dagpunar, J. 'Principles of random variate generation'
    !     Clarendon Press, Oxford, 1988.   ISBN 0-19-852202-9

    ! FUNCTION GENERATES A RANDOM VARIATE IN [0,INFINITY) FROM
    ! A NEGATIVE EXPONENTIAL DISTRIBUTION WlTH DENSITY PROPORTIONAL
    ! TO EXP(-random_exponential), USING INVERSION.

    IMPLICIT NONE
    INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60) !double precision or r8
    REAL (dp), PARAMETER  :: zero = 0.0_dp
    REAL (dp) :: ran_exp

    !     Local variable
    REAL  :: r

    DO
       !  CALL RANDOM_NUMBER(r)
       r=unif()
       IF (r > zero) EXIT
    END DO

    ran_exp = -LOG(r)
    RETURN

  END FUNCTION random_exponential

  subroutine random_Poisson_v(mu,first,fn_val)
    !vectorial extension for random gamma AL
    IMPLICIT NONE
    INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60) !double precision or r8

    REAL (dp), INTENT(IN)  :: mu
    INTEGER                :: fn_val(:)
    LOGICAL                :: first
    integer :: i

    do i=1,size(fn_val)
       ! print *,i
       fn_val(i)=random_Poisson(mu,first)
    enddo

  end subroutine random_Poisson_v

  FUNCTION random_Poisson(mu, first) RESULT(ival)
    !**********************************************************************
    !     Translated to Fortran 90 by Alan Miller from:
    !                           RANLIB
    !
    !     Library of Fortran Routines for Random Number Generation
    !
    !                    Compiled and Written by:
    !
    !                         Barry W. Brown
    !                          James Lovato
    !
    !             Department of Biomathematics, Box 237
    !             The University of Texas, M.D. Anderson Cancer Center
    !             1515 Holcombe Boulevard
    !             Houston, TX      77030
    !
    ! This work was supported by grant CA-16672 from the National Cancer Institute.

    !                    GENerate POIsson random deviate

    !                            Function

    ! Generates a single random deviate from a Poisson distribution with mean mu.

    !                            Arguments

    !     mu --> The mean of the Poisson distribution from which
    !            a random deviate is to be generated.
    !                              REAL mu

    !                              Method

    !     For details see:

    !               Ahrens, J.H. and Dieter, U.
    !               Computer Generation of Poisson Deviates
    !               From Modified Normal Distributions.
    !               ACM Trans. Math. Software, 8, 2
    !               (June 1982),163-179

    !     TABLES: COEFFICIENTS A0-A7 FOR STEP F. FACTORIALS FACT
    !     COEFFICIENTS A(K) - FOR PX = FK*V*V*SUM(A(K)*V**K)-DEL

    !     SEPARATION OF CASES A AND B

    IMPLICIT NONE
    INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60) !double precision or r8


    !     .. Scalar Arguments ..
    REAL(dp), INTENT(IN)    :: mu
    LOGICAL, INTENT(IN) :: first
    INTEGER             :: ival
    !     ..
    !     .. Local Scalars ..
    REAL(dp)          :: b1, b2, c, c0, c1, c2, c3, del, difmuk, e, fk, fx, fy, g,  &
         omega, px, py, t, u, v, x, xx
    REAL(dp), SAVE    :: s, d, p, q, p0
    INTEGER       :: j, k, kflag
    LOGICAL, SAVE :: full_init
    INTEGER, SAVE :: l, m
    !     ..
    !     .. Local Arrays ..
    REAL(dp), SAVE    :: pp(35)
    !     ..
    !     .. Data statements ..
    REAL(dp), PARAMETER :: a0 = -.5, a1 = .3333333, a2 = -.2500068, a3 = .2000118,  &
         a4 = -.1661269, a5 = .1421878, a6 = -.1384794,   &
         a7 = .1250060

    REAL(dp), PARAMETER :: fact(10) = (/ 1., 1., 2., 6., 24., 120., 720., 5040.,  &
         40320., 362880. /)

    !     ..
    !     .. Executable Statements ..
    IF (mu > 10.0) THEN
       !     C A S E  A. (RECALCULATION OF S, D, L IF MU HAS CHANGED)

       IF (first) THEN
          s = SQRT(mu)
          d = 6.0*mu*mu

          !             THE POISSON PROBABILITIES PK EXCEED THE DISCRETE NORMAL
          !             PROBABILITIES FK WHENEVER K >= M(MU). L=IFIX(MU-1.1484)
          !             IS AN UPPER BOUND TO M(MU) FOR ALL MU >= 10 .

          l = mu - 1.1484
          full_init = .false.
       END IF


       !     STEP N. NORMAL SAMPLE - random_normal() FOR STANDARD NORMAL DEVIATE

       g = mu + s*normal01()
       IF (g > 0.0) THEN
          ival = g

          !     STEP I. IMMEDIATE ACCEPTANCE IF ival IS LARGE ENOUGH

          IF (ival>=l) RETURN

          !     STEP S. SQUEEZE ACCEPTANCE - SAMPLE U

          fk = ival
          difmuk = mu - fk
          !CALL RANDOM_NUMBER(u)
          u = unif()
          IF (d*u >= difmuk*difmuk*difmuk) RETURN
       END IF

       !     STEP P. PREPARATIONS FOR STEPS Q AND H.
       !             (RECALCULATIONS OF PARAMETERS IF NECESSARY)
       !             .3989423=(2*PI)**(-.5)  .416667E-1=1./24.  .1428571=1./7.
       !             THE QUANTITIES B1, B2, C3, C2, C1, C0 ARE FOR THE HERMITE
       !             APPROXIMATIONS TO THE DISCRETE NORMAL PROBABILITIES FK.
       !             C=.1069/MU GUARANTEES MAJORIZATION BY THE 'HAT'-FUNCTION.

       IF (.NOT. full_init) THEN
          omega = .3989423/s
          b1 = .4166667E-1/mu
          b2 = .3*b1*b1
          c3 = .1428571*b1*b2
          c2 = b2 - 15.*c3
          c1 = b1 - 6.*b2 + 45.*c3
          c0 = 1. - b1 + 3.*b2 - 15.*c3
          c = .1069/mu
          full_init = .true.
       END IF

       IF (g < 0.0) GO TO 50

       !             'SUBROUTINE' F IS CALLED (KFLAG=0 FOR CORRECT RETURN)

       kflag = 0
       GO TO 70

       !     STEP Q. QUOTIENT ACCEPTANCE (RARE CASE)

40     IF (fy-u*fy <= py*EXP(px-fx)) RETURN

       !     STEP E. EXPONENTIAL SAMPLE - random_exponential() FOR STANDARD EXPONENTIAL
       !             DEVIATE E AND SAMPLE T FROM THE LAPLACE 'HAT'
       !             (IF T <= -.6744 THEN PK < FK FOR ALL MU >= 10.)

50     e = random_exponential()
       !CALL RANDOM_NUMBER(u)
       u = unif()
       u = u + u - 1.0
       t = 1.8 + SIGN(e, u)
       IF (t <= (-.6744)) GO TO 50
       ival = mu + s*t
       fk = ival
       difmuk = mu - fk

       !             'SUBROUTINE' F IS CALLED (KFLAG=1 FOR CORRECT RETURN)

       kflag = 1
       GO TO 70

       !     STEP H. HAT ACCEPTANCE (E IS REPEATED ON REJECTION)

60     IF (c*ABS(u) > py*EXP(px+e) - fy*EXP(fx+e)) GO TO 50
       RETURN

       !     STEP F. 'SUBROUTINE' F. CALCULATION OF PX, PY, FX, FY.
       !             CASE ival < 10 USES FACTORIALS FROM TABLE FACT

70     IF (ival>=10) GO TO 80
       px = -mu
       py = mu**ival/fact(ival+1)
       GO TO 110

       !             CASE ival >= 10 USES POLYNOMIAL APPROXIMATION
       !             A0-A7 FOR ACCURACY WHEN ADVISABLE
       !             .8333333E-1=1./12.  .3989423=(2*PI)**(-.5)

80     del = .8333333E-1/fk
       del = del - 4.8*del*del*del
       v = difmuk/fk
       IF (ABS(v)>0.25) THEN
          px = fk*LOG(1.0 + v) - difmuk - del
       ELSE
          px = fk*v*v* (((((((a7*v+a6)*v+a5)*v+a4)*v+a3)*v+a2)*v+a1)*v+a0) - del
       END IF
       py = .3989423/SQRT(fk)
110    x = (0.5 - difmuk)/s
       xx = x*x
       fx = -0.5*xx
       fy = omega* (((c3*xx + c2)*xx + c1)*xx + c0)
       IF (kflag <= 0) GO TO 40
       GO TO 60

       !---------------------------------------------------------------------------
       !     C A S E  B.    mu < 10
       !     START NEW TABLE AND CALCULATE P0 IF NECESSARY

    ELSE

       IF (first) THEN
          m = MAX(1, INT(mu))
          l = 0
          p = EXP(-mu)
          q = p
          p0 = p
       END IF

       !     STEP U. UNIFORM SAMPLE FOR INVERSION METHOD

       DO
          !CALL RANDOM_NUMBER(u)
          u=unif()
          ival = 0
          IF (u <= p0) RETURN

          !     STEP T. TABLE COMPARISON UNTIL THE END PP(L) OF THE
          !             PP-TABLE OF CUMULATIVE POISSON PROBABILITIES
          !             (0.458=PP(9) FOR MU=10)

          IF (l == 0) GO TO 150
          j = 1
          IF (u > 0.458) j = MIN(l, m)
          DO k = j, l
             IF (u <= pp(k)) GO TO 180
          END DO
          IF (l == 35) CYCLE

          !     STEP C. CREATION OF NEW POISSON PROBABILITIES P
          !             AND THEIR CUMULATIVES Q=PP(K)

150       l = l + 1
          DO k = l, 35
             p = p*mu / k
             q = q + p
             pp(k) = q
             IF (u <= q) GO TO 170
          END DO
          l = 35
       END DO

170    l = k
180    ival = k
       RETURN
    END IF

    RETURN
  END FUNCTION random_Poisson

  FUNCTION random_binomial1(n, p, first) RESULT(ival)

    ! FUNCTION GENERATES A RANDOM BINOMIAL VARIATE USING C.D.Kemp's method.
    ! This algorithm is suitable when many random variates are required
    ! with the SAME parameter values for n & p.

    !    P = BERNOULLI SUCCESS PROBABILITY
    !           (0 <= REAL <= 1)
    !    N = NUMBER OF BERNOULLI TRIALS
    !           (1 <= INTEGER)
    !    FIRST = .TRUE. for the first call using the current parameter values
    !          = .FALSE. if the values of (n,p) are unchanged from last call

    ! Reference: Kemp, C.D. (1986). `A modal method for generating binomial
    !            variables', Commun. Statist. - Theor. Meth. 15(3), 805-813.
    INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60) 
    INTEGER, INTENT(IN) :: n
    REAL(dp), INTENT(IN)    :: p
    LOGICAL, INTENT(IN) :: first
    INTEGER             :: ival

    !     Local variables

    INTEGER         :: ru, rd
    INTEGER, SAVE   :: r0
    REAL            :: u, pd, pu
    REAL, SAVE      :: odds_ratio, p_r
    REAL, PARAMETER :: zero = 0.0, one = 1.0

    IF (first) THEN
       r0 = (n+1)*p
       p_r = bin_prob(n, p, r0)
       odds_ratio = p / (one - p)
    END IF

    CALL RANDOM_NUMBER(u)
    u = u - p_r
    IF (u < zero) THEN
       ival = r0
       RETURN
    END IF

    pu = p_r
    ru = r0
    pd = p_r
    rd = r0
    DO
       rd = rd - 1
       IF (rd >= 0) THEN
          pd = pd * (rd+1) / (odds_ratio * (n-rd))
          u = u - pd
          IF (u < zero) THEN
             ival = rd
             RETURN
          END IF
       END IF

       ru = ru + 1
       IF (ru <= n) THEN
          pu = pu * (n-ru+1) * odds_ratio / ru
          u = u - pu
          IF (u < zero) THEN
             ival = ru
             RETURN
          END IF
       END IF
    END DO

    !     This point should not be reached, but just in case:

    ival = r0
    RETURN

  END FUNCTION random_binomial1



  FUNCTION bin_prob(n, p, r) RESULT(fn_val)
    !     Calculate a binomial probability
    INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60) 
    INTEGER, INTENT(IN) :: n, r
    REAL(dp), INTENT(IN)    :: p
    REAL                :: fn_val

    !     Local variable
    REAL                :: one = 1.0

    fn_val = EXP( lngamma(DBLE(n+1)) - lngamma(DBLE(r+1)) - lngamma(DBLE(n-r+1)) &
         + r*LOG(p) + (n-r)*LOG(one - p) )
    RETURN

  END FUNCTION bin_prob



  FUNCTION lngamma(x) RESULT(fn_val)

    ! Logarithm to base e of the gamma function.
    !
    ! Accurate to about 1.e-14.
    ! Programmer: Alan Miller

    ! Latest revision of Fortran 77 version - 28 February 1988
    INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60) 
    REAL (dp), INTENT(IN) :: x
    REAL (dp)             :: fn_val

    !       Local variables

    REAL (dp) :: a1 = -4.166666666554424D-02, a2 = 2.430554511376954D-03,  &
         a3 = -7.685928044064347D-04, a4 = 5.660478426014386D-04,  &
         temp, arg, product, lnrt2pi = 9.189385332046727D-1,       &
         pi = 3.141592653589793D0
    LOGICAL   :: reflect

    !       lngamma is not defined if x = 0 or a negative integer.

    IF (x > 0.d0) GO TO 10
    IF (x /= INT(x)) GO TO 10
    fn_val = 0.d0
    RETURN

    !       If x < 0, use the reflection formula:
    !               gamma(x) * gamma(1-x) = pi * cosec(pi.x)

10  reflect = (x < 0.d0)
    IF (reflect) THEN
       arg = 1.d0 - x
    ELSE
       arg = x
    END IF

    !       Increase the argument, if necessary, to make it > 10.

    product = 1.d0
20  IF (arg <= 10.d0) THEN
       product = product * arg
       arg = arg + 1.d0
       GO TO 20
    END IF

    !  Use a polynomial approximation to Stirling's formula.
    !  N.B. The real Stirling's formula is used here, not the simpler, but less
    !       accurate formula given by De Moivre in a letter to Stirling, which
    !       is the one usually quoted.

    arg = arg - 0.5D0
    temp = 1.d0/arg**2
    fn_val = lnrt2pi + arg * (LOG(arg) - 1.d0 + &
         (((a4*temp + a3)*temp + a2)*temp + a1)*temp) - LOG(product)
    IF (reflect) THEN
       temp = SIN(pi * x)
       fn_val = LOG(pi/temp) - fn_val
    END IF
    RETURN
  END FUNCTION lngamma



  FUNCTION random_binomial2(n, pp, first) RESULT(ival)
    !**********************************************************************
    !     Translated to Fortran 90 by Alan Miller from:
    !                              RANLIB
    !
    !     Library of Fortran Routines for Random Number Generation
    !
    !                      Compiled and Written by:
    !
    !                           Barry W. Brown
    !                            James Lovato
    !
    !               Department of Biomathematics, Box 237
    !               The University of Texas, M.D. Anderson Cancer Center
    !               1515 Holcombe Boulevard
    !               Houston, TX      77030
    !
    ! This work was supported by grant CA-16672 from the National Cancer Institute.

    !                    GENerate BINomial random deviate

    !                              Function

    !     Generates a single random deviate from a binomial
    !     distribution whose number of trials is N and whose
    !     probability of an event in each trial is P.

    !                              Arguments

    !     N  --> The number of trials in the binomial distribution
    !            from which a random deviate is to be generated.
    !                              INTEGER N

    !     P  --> The probability of an event in each trial of the
    !            binomial distribution from which a random deviate
    !            is to be generated.
    !                              REAL P

    !     FIRST --> Set FIRST = .TRUE. for the first call to perform initialization
    !               the set FIRST = .FALSE. for further calls using the same pair
    !               of parameter values (N, P).
    !                              LOGICAL FIRST

    !     random_binomial2 <-- A random deviate yielding the number of events
    !                from N independent trials, each of which has
    !                a probability of event P.
    !                              INTEGER random_binomial

    !                              Method

    !     This is algorithm BTPE from:

    !         Kachitvichyanukul, V. and Schmeiser, B. W.
    !         Binomial Random Variate Generation.
    !         Communications of the ACM, 31, 2 (February, 1988) 216.

    !**********************************************************************

    !*****DETERMINE APPROPRIATE ALGORITHM AND WHETHER SETUP IS NECESSARY

    !     ..
    !     .. Scalar Arguments ..
    INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60) 
    REAL(dp), INTENT(IN)    :: pp
    INTEGER, INTENT(IN) :: n
    LOGICAL, INTENT(IN) :: first
    INTEGER             :: ival
    !     ..
    !     .. Local Scalars ..
    REAL            :: alv, amaxp, f, f1, f2, u, v, w, w2, x, x1, x2, ynorm, z, z2
    REAL, PARAMETER :: zero = 0.0, half = 0.5, one = 1.0
    INTEGER         :: i, ix, ix1, k, mp
    INTEGER, SAVE   :: m
    REAL, SAVE      :: p, q, xnp, ffm, fm, xnpq, p1, xm, xl, xr, c, al, xll,  &
         xlr, p2, p3, p4, qn, r, g

    !     ..
    !     .. Executable Statements ..

    !*****SETUP, PERFORM ONLY WHEN PARAMETERS CHANGE

    IF (first) THEN
       p = MIN(pp, one-pp)
       q = one - p
       xnp = n * p
    END IF

    IF (xnp > 30.) THEN
       IF (first) THEN
          ffm = xnp + p
          m = ffm
          fm = m
          xnpq = xnp * q
          p1 = INT(2.195*SQRT(xnpq) - 4.6*q) + half
          xm = fm + half
          xl = xm - p1
          xr = xm + p1
          c = 0.134 + 20.5 / (15.3 + fm)
          al = (ffm-xl) / (ffm - xl*p)
          xll = al * (one + half*al)
          al = (xr - ffm) / (xr*q)
          xlr = al * (one + half*al)
          p2 = p1 * (one + c + c)
          p3 = p2 + c / xll
          p4 = p3 + c / xlr
       END IF

       !*****GENERATE VARIATE, Binomial mean at least 30.

20     CALL RANDOM_NUMBER(u)
       u = u * p4
       CALL RANDOM_NUMBER(v)

       !     TRIANGULAR REGION

       IF (u <= p1) THEN
          ix = xm - p1 * v + u
          GO TO 110
       END IF

       !     PARALLELOGRAM REGION

       IF (u <= p2) THEN
          x = xl + (u-p1) / c
          v = v * c + one - ABS(xm-x) / p1
          IF (v > one .OR. v <= zero) GO TO 20
          ix = x
       ELSE

          !     LEFT TAIL

          IF (u <= p3) THEN
             ix = xl + LOG(v) / xll
             IF (ix < 0) GO TO 20
             v = v * (u-p2) * xll
          ELSE

             !     RIGHT TAIL

             ix = xr - LOG(v) / xlr
             IF (ix > n) GO TO 20
             v = v * (u-p3) * xlr
          END IF
       END IF

       !*****DETERMINE APPROPRIATE WAY TO PERFORM ACCEPT/REJECT TEST

       k = ABS(ix-m)
       IF (k <= 20 .OR. k >= xnpq/2-1) THEN

          !     EXPLICIT EVALUATION

          f = one
          r = p / q
          g = (n+1) * r
          IF (m < ix) THEN
             mp = m + 1
             DO i = mp, ix
                f = f * (g/i-r)
             END DO

          ELSE IF (m > ix) THEN
             ix1 = ix + 1
             DO i = ix1, m
                f = f / (g/i-r)
             END DO
          END IF

          IF (v > f) THEN
             GO TO 20
          ELSE
             GO TO 110
          END IF
       END IF

       !     SQUEEZING USING UPPER AND LOWER BOUNDS ON LOG(F(X))

       amaxp = (k/xnpq) * ((k*(k/3. + .625) + .1666666666666)/xnpq + half)
       ynorm = -k * k / (2.*xnpq)
       alv = LOG(v)
       IF (alv<ynorm - amaxp) GO TO 110
       IF (alv>ynorm + amaxp) GO TO 20

       !     STIRLING'S (actually de Moivre's) FORMULA TO MACHINE ACCURACY FOR
       !     THE FINAL ACCEPTANCE/REJECTION TEST

       x1 = ix + 1
       f1 = fm + one
       z = n + 1 - fm
       w = n - ix + one
       z2 = z * z
       x2 = x1 * x1
       f2 = f1 * f1
       w2 = w * w
       IF (alv - (xm*LOG(f1/x1) + (n-m+half)*LOG(z/w) + (ix-m)*LOG(w*p/(x1*q)) +    &
            (13860.-(462.-(132.-(99.-140./f2)/f2)/f2)/f2)/f1/166320. +               &
            (13860.-(462.-(132.-(99.-140./z2)/z2)/z2)/z2)/z/166320. +                &
            (13860.-(462.-(132.-(99.-140./x2)/x2)/x2)/x2)/x1/166320. +               &
            (13860.-(462.-(132.-(99.-140./w2)/w2)/w2)/w2)/w/166320.) > zero) THEN
          GO TO 20
       ELSE
          GO TO 110
       END IF

    ELSE
       !     INVERSE CDF LOGIC FOR MEAN LESS THAN 30
       IF (first) THEN
          qn = q ** n
          r = p / q
          g = r * (n+1)
       END IF

90     ix = 0
       f = qn
       CALL RANDOM_NUMBER(u)

100    IF (u >= f) THEN
          IF (ix > 110) GO TO 90
          u = u - f
          ix = ix + 1
          f = f * (g/ix - r)
          GO TO 100
       END IF
    END IF

110 IF (pp > half) ix = n - ix
    ival = ix
    RETURN

  END FUNCTION random_binomial2


end module random
!---------------!

module replaceNAG
  use random
  use kinds
  implicit none
  ! This module is a wrapping to replace NAG random number subroutines AL 27/7/06
contains

  function G05CAF(x) result(y) !unif~0-1
    real(r8):: y,x
    y=unif()
  end function G05CAF

  subroutine G05CBF(I) !set one of the three seeds in Taus88
    integer ::i
    call init_seeds(i,-4567,7890) 
  end subroutine G05CBF

  function G05DDF(a,b) result(y) !N~(a,b**2)  
    real(r8)::a,b,y
    y=normal(a,b**2)
  end function G05DDF

  function G05DYF(a,b) result(y) !unif~(a-b, a<b)  
    integer::a,b,y
    y=unifint(a,b)
  end function G05DYF

  subroutine G05DYF2(a,b,n,y) !unif~(a-b, a<b)  
    integer::a,b,n,y(n)
    call unifint_v(a,b,y)
  end subroutine G05DYF2

  subroutine G05FFF(a,b,n,x) !gamma(a,b)
    integer :: n
    real(r8):: x(n),a,b
    call random_gamma_v(a,b,x)
  end subroutine G05FFF

  subroutine G01BKC(a,n,test,x)
    integer :: n, x(n)
    real(r8):: a
    logical :: test
    call random_Poisson_v(a,test,x)
  end subroutine G01BKC

  function G01BJC1(n,p,test) result(y)
    integer :: n,y
    real(r8):: p
    logical :: test
    y=random_binomial1(n,p,test)
  end function G01BJC1

  function G01BJC2(n,p,test) result(y)
    integer :: n,y
    real(r8):: p
    logical :: test
    y=random_binomial2(n,p,test)
  end function G01BJC2

end module replaceNAG
!----------


! *************************************************
module sort
  implicit none

contains 
  subroutine search_best(x,n,ndx,k)
    integer, intent(in) :: n, k
    real(8), dimension(n), intent(in) :: x
    integer, dimension(k), intent(out) :: ndx
    integer :: i
    !
    do i=1,k
!!$       print*,'BCLE PRINCIPALE',i
       call insert(i, i)                !Die ersten k Werte werden immer aufgenommen, ...
!!$       print*,(ndx(j),j=1,i)
!!$       print*,(x(ndx(j)),j=1,i)
    end do
    do i=k+1,n
!!$       print*,'BCLE PRINCIPALE',i
       if(x(i) .gt. x(ndx(k))) then
          call insert(i, k)             !... ein weiterer nur, wenn er größer als 
       end if                            !der bisher kleinste ist.
    end do
    !
  contains
    !
    subroutine insert(i, m)               !Füge den Index i an der richtigen Stelle in die Bestenliste
      implicit none                     !der Länge m ein.
      integer, intent(in) :: i, m
      integer :: j
      !
      do j=1,m-1    
!!$print*,shape(x),i,shape(ndx),j,ndx(j),m                    !Suche die Stelle j, an die x(i) gehört.
         if(x(i) .gt. x(ndx(j))) then
            ndx(j+1:m) = ndx(j:m-1)   !Platz machen ... (der kleinste der Großen an der Stelle m fällt weg.)
            ndx(j) = i                !... und eintragen.
            return
         endif
      end do
      ndx(m) = i
    end subroutine insert

  end subroutine search_best

end module sort

! *************************************************

module BLUP

  use kinds
!!$  use dge
!!$  use sparseop
  implicit none


contains


  ! No fixed effects, only the mean
  ! Animal model
  ! Polygenic variance known (sigma_u), as well as environmental one (sigma_e)


  ! First compute the A-1 matrix

  subroutine computeBLUP(pedigree,nInd,polygene,perf,alpha,ther)
    implicit none
    integer:: i, k, j, m, gene, io, ii, iii, apos, nn, nullty, ifault, siz
    integer, intent(in) :: nInd, pedigree(:,:), ther(:,:)
    integer, allocatable :: X(:,:), Z(:,:), Xt(:,:)
    real(kind=4):: setup_i,setup_f,setupt
    real(kind=8), intent(in):: perf(:), alpha
    real(kind=8):: polygene(:,:)
    real(kind=4), allocatable :: u(:), l(:,:), D(:), A_inv(:,:), LHS(:,:), RHS(:,:), LHS_inv(:,:)
    real(kind=8), allocatable :: y(:,:), uu(:)
    logical:: test


    ! Inbreeding coefficients
    allocate(u(nInd),l(nInd,nInd))
    l=0; u=0
    do i=1,nInd
       if(pedigree(i,2)==0.and.pedigree(i,3)==0) l(i,i)=1
       if(pedigree(i,2)==0.and.pedigree(i,3)/=0) l(i,i)=sqrt(1-0.25*u(pedigree(i,3)))
       if(pedigree(i,2)/=0.and.pedigree(i,3)==0) l(i,i)=sqrt(1-0.25*u(pedigree(i,2)))
       if(pedigree(i,2)/=0.and.pedigree(i,3)/=0) l(i,i)=sqrt(1-0.25*(u(pedigree(i,2))+u(pedigree(i,3))))
       do k=i+1,nInd
          if(pedigree(i,2)==0.and.pedigree(i,3)/=0) l(i,k)=0.5*l(pedigree(i,3),k)
          if(pedigree(i,2)/=0.and.pedigree(i,3)==0) l(i,k)=0.5*l(pedigree(i,2),k)
          if(pedigree(i,2)/=0.and.pedigree(i,3)/=0) l(i,k)=0.5*(l(pedigree(i,3),k)+l(pedigree(i,2),k))
          u(i)=l(i,k)**2+u(i)
       enddo
    enddo
    deallocate(l)
    do i=1,nInd
       if(u(i)>1) u(i)=u(i)-1 ! u contains the inbreeding coefficients
    enddo
!!$    print*,u(1:nInd)
!!$    do i=1,nInd
!!$       print*,pedigree(i,:)
!!$    enddo

    allocate(D(nInd))
    D=0.
    do i=1,nInd
       if(pedigree(i,2)==0.and.pedigree(i,3)==0) D(i)=1.
       if(pedigree(i,2)/=0.and.pedigree(i,3)==0) D(i)=0.75-u(pedigree(i,2))
       if(pedigree(i,2)==0.and.pedigree(i,3)/=0) D(i)=0.75-u(pedigree(i,3))
       if(pedigree(i,2)/=0.and.pedigree(i,3)/=0) D(i)=0.5-0.25*(u(pedigree(i,3))+u(pedigree(i,2)))
    enddo
!!$if(gene==2) print*,'u',u
    deallocate(u)
!!$    print*,'D',D(1:nInd)

    allocate(A_inv(nInd,nInd))
    A_inv=0
    do i=1,nInd
       if(pedigree(i,2)==0.and.pedigree(i,3)==0) A_inv(i,i)=A_inv(i,i)+1./D(i)
       if(pedigree(i,2)/=0.and.pedigree(i,3)==0) then
          A_inv(i,i)=A_inv(i,i)+1./D(i)
          A_inv(i,pedigree(i,2))=A_inv(i,pedigree(i,2))-1./(2*D(i))
          A_inv(pedigree(i,2),i)=A_inv(pedigree(i,2),i)-1./(2*D(i))
          A_inv(pedigree(i,2),pedigree(i,2))=A_inv(pedigree(i,2),pedigree(i,2))+1./(4.*D(i))
       endif
       if(pedigree(i,3)/=0.and.pedigree(i,2)==0) then
          A_inv(i,i)=A_inv(i,i)+1./D(i)
          A_inv(i,pedigree(i,3))=A_inv(i,pedigree(i,3))-1./(2*D(i))
          A_inv(pedigree(i,3),i)=A_inv(pedigree(i,3),i)-1./(2*D(i))
          A_inv(pedigree(i,3),pedigree(i,3))=A_inv(pedigree(i,3),pedigree(i,3))+1./(4*D(i))
       endif
       if(pedigree(i,2)/=0.and.pedigree(i,3)/=0) then
          A_inv(i,i)=A_inv(i,i)+1./D(i)
          A_inv(i,pedigree(i,2))=A_inv(i,pedigree(i,2))-1./(2*D(i))
          A_inv(pedigree(i,2),i)=A_inv(pedigree(i,2),i)-1./(2*D(i))
          A_inv(i,pedigree(i,3))=A_inv(i,pedigree(i,3))-1./(2*D(i))
          A_inv(pedigree(i,3),i)=A_inv(pedigree(i,3),i)-1./(2*D(i))
          A_inv(pedigree(i,2),pedigree(i,2))=A_inv(pedigree(i,2),pedigree(i,2))+1./(4*D(i))
          A_inv(pedigree(i,2),pedigree(i,3))=A_inv(pedigree(i,2),pedigree(i,3))+1./(4*D(i))
          A_inv(pedigree(i,3),pedigree(i,2))=A_inv(pedigree(i,3),pedigree(i,2))+1./(4*D(i))
          A_inv(pedigree(i,3),pedigree(i,3))=A_inv(pedigree(i,3),pedigree(i,3))+1./(4*D(i))
       endif
    enddo
!!$if(gene==2) then
!!$print*,'D',D
!!$    do i=1,nInd
!!$       print*,i,_inv',A_inv(i,:)
!!$    enddo
!!$endif
    deallocate(D)


    allocate(Z(nInd,nInd),X(nInd,1),Xt(1,nInd),y(nInd,1))
    k=0; Z=0; X=0
    do i=1,nInd
       do j=1,size(ther,1)
          if(ther(j,1)==pedigree(i,1)) then
             k=k+1
             y(k,1)=perf(i)
             Z(k,k)=1.
             X(k,1)=1.
!!$          print*,i,k,'perf',y(k,1)
          endif
       enddo
    enddo
    siz=k
!!$    print*,'y',y
    do i=1,nInd
       Xt(1,i)=X(i,1)
    enddo
    allocate(RHS(k,k))
    RHS=0.; ii=0
    do i=1,nInd
       do k=1,size(ther,1)
          if(ther(k,1)==pedigree(i,1)) then
             ii=ii+1
!!$          write(102,*)i,ii,ther(i,2:3)
             m=0
             do j=1,nInd
                do iii=1,size(ther,1)
                   if(ther(iii,1)==pedigree(j,1)) then
                      m=m+1
!!$print*,ii,m,i,j
                      RHS(ii,m)=A_inv(i,j)
                   endif
                enddo
             enddo
          endif
       enddo
    enddo

    allocate(LHS(siz+1,siz+1))
    LHS=0.
    LHS(1,1)=siz
    LHS(1,2:siz+1)=matmul(Xt(1,1:siz),Z(1:siz,1:siz))
    LHS(2:siz+1,1)=matmul(transpose(Z(1:siz,1:siz)),X(1:siz,1))
    LHS(2:siz+1,2:siz+1)=matmul(transpose(Z(1:siz,1:siz)),Z(1:siz,1:siz))+alpha*RHS(1:siz,1:siz)
!!$do i=1,k+1
!!$write(101,*)gene,LHS(i,:)
!!$enddo
    deallocate(RHS)
    allocate(RHS(siz+1,1))
    RHS(1,1)=sum(y(1:siz,1))
    RHS(2:siz+1,1)=matmul(transpose(Z(1:siz,1:siz)),y(1:siz,1))
!!$do i=1,k+1
!!$write(103,*)gene,RHS(i,1)
!!$enddo
!!$do i=1,k
!!$write(102,*)gene,y(i,1)
!!$enddo
    deallocate(y)

    nn=nint((siz+1)*(siz+2)/2.)
    allocate(uu(nn))
    uu=0.
    ii=0
!!$    print*,shape(LHS)
    do i=1,siz+1
       do j=1,i
          ii=ii+1
!!$          print*,k,i,j
          uu(ii)=LHS(i,j) ! u is the vector of the triangular inferior LHS matrix
       enddo
    enddo
    deallocate(LHS)

!!$    call cpu_time(setup_i)
!!$    !
!!$    print *,' '
!!$    print *,'    TIME TO SET UP NORMAL EQUATIONS '
!!$    print *,'    =============================== '
!!$    !
    print *,' '
    print *,'    Applying Cholesky decomposition...  '
    print *,' '
    !
    nullty=0; ifault=0
    call chol (uu,siz,nn,nullty,ifault)
    !
    print *,' '
    print *,'    Solving triangular systems...  '
    print *,' '
    !
    !     First we solve a*y=RHS
    !
    allocate(y(siz+1,1))
    do i=1,siz+1
       apos=i*(i+1)/2
       y(i,1)=dble(RHS(i,1))/uu(apos)
       do j=i+1,siz+1
          apos=j*(j-1)/2+i
          RHS(j,1)=dble(RHS(j,1))-uu(apos)*y(i,1)
       end do
    end do
    !
     print *,'     Then we solve aT*sol=z'
    !
    do i=siz+1,1,-1
       apos=i*(i+1)/2
       polygene(i,1)=y(i,1)/uu(apos)
       do j=i-1,1,-1
          apos=apos-1
          y(j,1)=y(j,1)-uu(apos)*polygene(i,1)
       end do
    end do
!!$    print*,'out',polygene
    
    deallocate(uu,y,RHS)
    return

  end subroutine computeBLUP

!
!     ------------------------------------------------------------------
!     ------------------------------------------------------------------
!
      subroutine chol (a,n,nn,nullty,ifault)
      integer, intent(in) :: n,nn
      integer, intent(out) :: nullty,ifault
      real(8), intent(inout) :: a(:)
! 
!     Algorithm AS6, Applied Statistics, vol.17, (1968)
!     Available from StatLib at http://lib.stat.cmu.edu/apstat/
! 
!     Given a symmetric matrix of order n as lower triangle in a( )
!     calculates an upper triangle, u( ), such that uprime * u = a.
!     a must be positive semi-definite.  eta is set to multiplying
!     factor determining effective zero for pivot.
! 
!     Arguments:
!     a()    = input, a +ve definite matrix in lower-triangular form
!     n      = input, the order of a
!     nn     = input, the size of the a and u arrays      n*(n+1)/2
!     u()    = output, a lower triangular matrix such that u*u' = a.
!              a & u may occupy the same locations.
!     nullty = output, the rank deficiency of a.
!     ifault = output, error indicator
!                     = 1 if n < 1
!                     = 2 if a is not +ve semi-definite
!                     = 3 if nn < n*(n+1)/2
!                     = 0 otherwise
! 
!     ------------------------------------------------------------------
! 
      double precision eta,eta2,x,w,zero
      integer :: i,j,k,l,m,ii,icol,irow,kk
! 
!     The value of eta will depend on the word-length of the
!     computer being used.  See introductory text.
! 
      data eta,zero/1.d-9,0.0d0/
! 
      ifault=1
      if (n.le.0) return
      ifault=3
      if (nn.lt.n*(n+1)/2) return
      ifault=2
      nullty=0
      j=1
      k=0
      eta2=eta*eta
      ii=0
! 
!     Factorize column by column, icol = column no.
! 
      do 80 icol=1,n
        ii=ii+icol
        x=eta2*a(ii)
        l=0
        kk=0
! 
!       irow = row number within column icol
! 
        do 40 irow=1,icol
          kk=kk+irow
          k=k+1
          w=a(k)
          m=j
          do 10 i=1,irow
            l=l+1
            if (i.eq.irow) go to 20
            w=w-a(l)*a(m)
            m=m+1
 10       continue
 20       if (irow.eq.icol) go to 50
          if (a(l).eq.zero) go to 30
          a(k)=w/a(l)
          go to 40
 30       if (w*w.gt.abs(x*a(kk))) return
          a(k)=zero
 40     continue
 50     if (abs(w).le.abs(eta*a(k))) go to 60
        if (w.lt.zero) return
        a(k)=sqrt(w)
        go to 70
 60     a(k)=zero
        nullty=nullty+1
 70     j=j+icol
 80   continue
      ifault=0
      return
      end subroutine chol

end module BLUP

! **************************************************

module lecture

  use kinds
  implicit none

contains

  subroutine read_geno_nocop(nb_ind,nlocus,tab,hap_file)
    implicit none
    integer:: nb_ind, nlocus, i, j, k, l
    integer, dimension(:,:,:) :: tab
    character*26:: hap_file

    open(108,file=hap_file)
    l=0
    do i=1,2*nb_ind
       if(mod(i,2)==1) l=l+1
       read(108,*) j,k,tab(1:nlocus,l,k)
    enddo
    close(108)

  end subroutine read_geno_nocop

  subroutine read_geno_cop(nb_ind,nlocus,tab,tab2,hap_file,cop_file)
    implicit none
    integer:: nb_ind, nlocus, i, j, k, l
    integer, dimension(:,:,:) :: tab, tab2
    character*26:: hap_file,cop_file

    open(108,file=hap_file)
    open(109,file=cop_file)
    l=0
    do i=1,2*nb_ind
       if(mod(i,2)==1) l=l+1
       read(108,*) j,k,tab(1:nlocus,l,k)
       read(109,*) j,k,tab2(1:nlocus,l,k)
    enddo
    close(108)
    close(109)

  end subroutine read_geno_cop


  subroutine read_pheno(nb_ind,per,gan,pop,fic_perf)
    implicit none
    integer:: i, j, nb_ind, pop
    real(r8),dimension(:,:) :: per, gan
    character*15 :: fic_perf
    open(256,file=fic_perf)
    do i=1,nb_ind
       read(256,*) j, per(i,pop),gan(i,pop)
    enddo
    close(256)

  end subroutine read_pheno


  subroutine read_nrm(nb_ind,nrm,fic_app)
    implicit none
    integer:: i, nb_ind
    real(r8), dimension(:,:) :: nrm
    character*15 :: fic_app
    open(257,file=fic_app)
    do i=1,nb_ind-1
       read(257,*) nrm(i,i:nb_ind)
       nrm(i:nb_ind,i)=nrm(i,i:nb_ind)
    enddo
    close(257)

  end subroutine read_nrm

  subroutine read_map(nmq,nqtl,tab,chr_Q,nlo,nba,allef,eff_do,eff_q,posq,indi,pos_lo,f_map,f_eff,chr_lo)
    implicit none
    integer :: nmq, nqtl, ii, m, i, j, k, l, nn
    integer, dimension(:):: chr_Q, nlo, allef, posq, indi, chr_lo
    integer, dimension(:,:) :: tab, nba ! typ_loc
    real(r8), dimension(:):: eff_do
    real(r8), dimension(:,:):: eff_q, pos_lo
    character*15:: f_map, f_eff
    open(214,file=f_map)
    open(222,file=f_eff)
    j=0
    nlo=0
    do i=1,nmq+nqtl
       read(214,*) ii,k,l,pos_lo(l,k),tab(l,k)
       chr_lo(i)=k
       nlo(k)=nlo(k)+1
       if(tab(i,k)==1) then
          j=j+1
          chr_Q(j)=k
          read(222,*) (eff_q(j,m),m=1,nba(nmq+j,1)), eff_do(j)
          posq(j)=l
          indi(i)=1
          do m=1,nba(nmq+j,1)
             if(eff_q(j,m)==maxval(eff_q(j,:))) ii=m
          enddo
          allef(j)=ii
       endif
    enddo
    close(214)
    close(222)
  end subroutine read_map

  subroutine intera_mute(pos_assoc,nqtl,muted_qtl,pop,inter_mute)
    implicit none
    integer:: nqtl,i,j,k,pop
    integer, dimension(:,:):: pos_assoc, muted_qtl
    character*26:: inter_mute
    open(137,file=inter_mute)
    j=0
    do i=1,nqtl
       read(137,*)pos_assoc(i,:),k
       if(k==1) then
          j=j+1
          muted_qtl(j,pop)=i
       endif
    enddo
    close(137)

  end subroutine intera_mute

  subroutine read_ped(nb_ind,ped,fic_pedi)
    implicit none
    integer::i,j,nb_ind
    integer, dimension(:,:) :: ped
    character*15:: fic_pedi
    open(277,file=fic_pedi)
    do i=1,nb_ind
       read(277,*) ped(i,:)
    enddo
    close(277)

  end subroutine read_ped


end module lecture
! *******************************************



program simulateur
  use replaceNAG
  use kinds
  use sort
  use lecture
  use BLUP
  implicit none

  integer ::nmq,trois
  integer  ::ii,m,id,nb_hc,nb_infusion,infus,nt,nf, io, lgth_chr
  integer  ::rac,rac1,i,j,k,l,zero,un,iv,tps,nb_h,rac2
  integer :: limite,tail_port,id2
  integer :: pop,tail,toto,ifail,time,time2,deseq
  integer :: nbpop,deux,typ_pop,nn,ngpm, direct_fin
  integer :: iii,maxcal,gene,bott,max_pop1,max_pop2
  integer :: nb_bott,nb_bott2,maxim,demi2,out_nrm
  integer :: outfiles, max_gener_eval, nqtl, dis,maxloc, store_cop
  integer :: nb_h_init, nb_hc_init, nchrom, model, nanc, nr, orig
  integer :: typ_map, typ_mk, max_loc, typ_density, evenly, all_frq, n_interac1
  integer :: ncpl_qtl_interac, n_qtl_dom, altern, hh, nb_recomb, v, vi, typ_interac
  integer :: DamSire, constant, constant2, constant3, uniformity, anc1, anc2, OffSire
  integer :: gene_ped, gene_typ, gene_perf, cross, anc3, anc4, nb_introg, nt1, nt2, pedig, nbport
  integer :: nsires, ntotped1, ntotanc1, lect, nt_hs, nfmin_hs, nfmax_hs, ndmin_hs, ndmax_hs
  integer :: nt_hf2,nfmin_hf2,nfmax_hf2,ndmin_hf2,ndmax_hf2, mm, lll, nfp, ndn
  integer :: typing_err, all_fix, ll, further_use, lect_map, lect_gen, last_ind,last_gen
  ! Lines for the part with a real pedigree
  integer:: nbgeno, maxall, nbped, cpt, cpt1, nbfond, boolped, nbpere, nbmere, nbtemp
  integer:: bool, k1, h1, h, nbgeno2, nbind, hp, hm, boolcpt
  integer, allocatable  :: all(:,:,:),all2(:,:,:),all3(:,:,:) ! alleles pour marqueurs-individus-gametes
  integer, allocatable :: n(:,:), alleff(:), posqtl(:),pmax(:),nIndiv(:,:), indPed(:)
  integer, allocatable :: pmaxk(:), n_all(:), n_allk(:), n_allq(:), pos_assoc(:,:)
  integer, allocatable  :: allp2(:,:,:), chr_loc(:),tot_pop_fin(:)
  integer, allocatable  :: mut(:),nball(:,:),cop2(:,:,:),schon(:)
  integer, allocatable :: verif(:),soud(:),soud1(:),n1(:),n2(:),t1(:),t2(:)
  integer, allocatable :: cop(:,:,:),copp2(:,:,:),typ(:), nbporteur(:,:,:)
  integer, allocatable :: nalmax(:),htz(:),indic_2(:),indic(:), corres(:,:), corresp(:,:)
  integer, allocatable  :: parent(:,:),par(:,:,:),maxcop(:,:),remain(:,:),remain2(:,:)
  integer, allocatable  :: ncopmax(:),time_introg(:),ped_p1(:,:),ped_p2(:,:)
  integer, allocatable:: indic_1(:),introg(:),indic_in(:),gener_eval(:,:), rang(:), rang2(:)
  integer, allocatable:: parent2(:,:), rang3(:),old_ped(:),ped3(:,:)
  integer, allocatable:: coprest(:), nb_seg(:,:,:), all4(:,:,:)
  integer, allocatable:: nloc(:), typ_loc(:,:), typ_inter(:), herk(:)
  integer, allocatable:: deb(:,:,:,:), fin(:,:,:,:), cop3(:,:,:), cop4(:,:,:)
  integer, allocatable:: chr_QTL(:), verif_print(:), dom(:,:), lect_nrm(:)
  integer, allocatable:: cop_alef(:,:), qtl_mute(:), muted_qtl(:,:), mode_sel(:,:)
  integer, allocatable:: pair_interac(:), p_a_temp(:,:), geneIntrog(:), indIntrog(:)
  integer, allocatable:: damPerSire(:,:,:), damToSire(:), offspPerSire(:,:,:),offspPerDam(:)
  integer, allocatable:: all1(:,:,:), indp(:,:), indm(:,:), sires(:), dams(:), mat(:,:), ind(:)

  ! Lines for the part with a real pedigree
  integer, allocatable, dimension(:,:) :: geno, cop_ped, ped_start, pednew, ped, ped2, geno_pere, tempped
  integer, allocatable, dimension(:,:) :: geno_mere, cop_pere, cop_mere, geno2, cop_ped2, effqtltemp, geno_temp
  integer, allocatable, dimension(:,:) :: geno_temp2, cop_temp, cop_temp2
  integer, allocatable, dimension(:) :: chromosome, location, position, indgeno_pere, indgeno_mere, fond
  real(r8) :: mend, envir, polyg, polyg2, polyg3, envir2, mendel
  real(r8) ::distance,alpha,beta
  real(r8) ::pr,sc_dist,tol,qtl_fq,mu,add,res_var,lambda 
  real(r8) ::tmutSNP,tmutMST,r,p,q,b,tot_length, poid,tmutQTL, miss_genot
  real(r8) ::prop_h, prop_hc, env, valqtl, m_inbr, epis, errSNP, errMST
  ! Line for the part with a real pedigree
  real(r8) :: men, envi, gindnew, perform, bin
  real(r8), allocatable :: re(:), cart(:), gani(:,:), gind(:,:), perf(:,:), eff(:)
  real(r8), allocatable :: dist(:), reco(:), a(:)
  real(r8), allocatable :: reserv(:), freq(:,:), d_prim(:,:), eff_qtl(:,:)
  real(r8), allocatable :: fqall(:,:), khi2prim(:,:), perf_temp(:)
  real(r8), allocatable :: fqcop(:,:), pic(:), consmoy(:), eff_dom(:)
  real(r8), allocatable :: varcons(:), fqall2(:,:), EBV(:,:)
  real(r8), allocatable :: selection(:,:,:), sel(:,:,:),lg_chrom(:), pos_loc(:,:), QTL_place(:)
  real(r8), allocatable :: seg_ibd(:,:,:,:), seg_qtl(:,:,:), gind2(:,:)
  real(r8), allocatable :: pos_QTL(:), ord(:), dij(:,:,:,:), pos(:), pos2(:)
  real(r8), allocatable :: devun(:), devunk(:), dpmax(:), dkmax(:), fq_init(:,:,:)
  real(r8), allocatable :: nrmat(:,:), nrmat2(:,:), nrmat3(:,:), nrmat_f(:,:), nrmat_fin(:,:)
  real(r8), allocatable :: pos_recomb(:), pos_recomb2(:), h2(:), ratio_polQTL(:), accur(:,:)
  real(r8), allocatable :: perfp(:), perfm(:), perf_t(:), gindp(:), gindm(:), gind_t(:)
  ! Lines for the part with a real pedigree
  real(r8), allocatable, dimension(:) :: gind_ped, gind_pere, gind_mere, perf_ped2, gind_temp, gind_ped2
  real(r8), allocatable, dimension(:,:) :: allqtl, effqtl
  character*26, allocatable, dimension(:) :: haplo_file, copy_file, inter_mute
  character*15, allocatable, dimension(:) ::  app_file, perf_file, fic_ped
  character*126 :: datafile8, datafile9, datafile10, datafile11
  character*126 :: file8, file9, file10, file11
  character*15:: file_map, file_eff
  character*2 ::f_dl,f_dlq,f_ibd,f_ibdq,f_csg
  character*2 ::f_hPIC,f_fqall,f_fqcop,f_dl_sum
  logical :: aux_test,test, test2, essai
  !  integer ::G05DYF
  !  real(r8) ::G05DDF,G05CAF
  !  external ::G05DDF,G05DYF,G05CBF,G05CAF,G05FFF

  open(5,file='param')  ! racines pour les générateurs aléatoires - 1 pour chaque population
  read(5,*)rac, rac1, rac2
  close(5)
  write(*,*)'1'

  un=1
  deux=2
  trois=3

  ! fichier général
  open(2,file='general') ! Informations communes aux deux populations
  read(2,*)tot_length, nchrom
  read(2,*)nmq    ! Total number of loci
  read(2,*)nqtl
  ! For this program, nmq = # of markers (the QTL being no markers)
  read(2,*) model        ! 1 if gamma distribution of the QTL effects, 0 else
  read(2,*) n_qtl_dom, ncpl_qtl_interac
  read(2,*) store_cop ! =1 if the founder origin of each allele should be stored 

  ! New 17/06/11
  read(2,*) lect_map, lect_gen, further_use
  if(lect_map==0) then
     if(model==1) then 
        read(2,*) alpha, beta
     else
        allocate(eff(nqtl),eff_dom(nqtl))
        eff_dom=0
        eff=0
        if(n_qtl_dom>0) then
           do i=1,nqtl
              read(2,*) eff(i),eff_dom(i)
           enddo
        else
           do i=1,nqtl
              read(2,*) eff(i)
           enddo
        endif
     endif
     if(ncpl_qtl_interac>0) then
        allocate(typ_inter(ncpl_qtl_interac))
        typ_inter=0
        read(2,*) typ_interac
        if(typ_interac==0) then
           call G05DYF2(1,2,ncpl_qtl_interac,typ_inter)
        else if(typ_interac==1) then
           allocate(parent(ncpl_qtl_interac,1))
           parent=0
           read(2,*)n_interac1
           if(n_interac1>floor(real(nqtl/2.))) then
              print*,'ERROR: TOO MANY PAIRS OF QTL WISHED WITH EPISTATIC EFFECTS'
              stop 1
           endif
           if(n_interac1 >0 .and. n_interac1<ncpl_qtl_interac) then 
              call G05DYF2(1,2,n_interac1,typ_inter)
              parent(:,1)=typ_inter(:)
              if(count(any(parent .eq. 1, 1)) /= n_interac1) then
                 k=count(any(parent .eq. 1, 1)) - n_interac1
                 do while (k<0)
                    m=G05DYF(1,ncpl_qtl_interac)
                    if(parent(m,1)==2) then
                       parent(m,1)=1
                       k=k+1
                    endif
                 enddo
                 do while (k>0)
                    m=G05DYF(1,ncpl_qtl_interac)
                    if(parent(m,1)==1) then
                       parent(m,1)=2
                       k=k-1
                    endif
                 enddo
              endif
              typ_inter(:)=parent(:,1)
              deallocate(parent)
           else if(n_interac1 == ncpl_qtl_interac) then
              typ_interac=1
           else if(n_interac1 == 0) then
              typ_interac=2
           endif
        else
           do i=1,ncpl_qtl_interac
              read(2,*) typ_inter(i)
           enddo
        endif
     endif
     read(2,*)typ_map     ! 1 if the map is random, 2 if the positions  of all loci should be predetermined
!!$  print*,'Type of map ',typ_map
     allocate(chr_QTL(nqtl),pos_QTL(nqtl),nloc(nchrom))
     if(typ_map==2) then
        read(2,*)max_loc
        allocate(pos_loc(max_loc,nchrom),typ_loc(max_loc,nchrom))
        pos_loc=0
        typ_loc=0
        allocate(lg_chrom(nchrom))
        do i=1,nchrom
           read(2,*) nloc(i)
           do k=1,nloc(i)
              read(2,*) pos_loc(k,i), typ_loc(k,i)
              !  print*,'Locus ',k,' kind of locus ',typ_loc(k,i),' at position ',pos_loc(k,i) pi
           enddo
           lg_chrom(i)=maxval(pos_loc(:,i))-minval(pos_loc(:,i))
        enddo
     else if(typ_map==1) then
        read(2,*) lgth_chr
        allocate(lg_chrom(nchrom))
        if(lgth_chr==2) then
           read(2,*) lg_chrom(1:nchrom)
        else
           do i=1,nchrom
              lg_chrom(i)=tot_length/real(nchrom)
           enddo
        endif
        read(2,*) typ_density   ! 1 if same number of markers on each chromosome, 2 else
        if (typ_density==2) then
           nloc=0
           do i=1,nchrom
              read(2,*) nloc(i)
           enddo
        else
           nloc=anint(real(nmq)/real(nchrom))
           if(sum(nloc)/=nmq) then
              i=abs(sum(nloc)-nmq)
              do j=1,i
                 k=G05DYF(1,nchrom)
                 if(sum(nloc)-nmq>0) then
                    nloc(k)=nloc(k)-1
                 else
                    nloc(k)=nloc(k)+1
                 endif
              enddo
           endif
           print*,'LENGTH OF THE CHROMOSOMES:',lg_chrom(:),&
                ' NUMBER OF MARKER ON EACH CHROMOSOME:',nloc(:)
        endif
        read(2,*)evenly ! 1 if markers are evenly spaced on the chromosome, 2 else
!!$     print*,'EVENLY',evenly
     endif
     read(2,*) typ_mk      ! 1 if all markers are SNP, 2 else
  else
     typ_map=2
     read(2,*) typ_mk      ! 1 if all markers are SNP, 2 else
     read(2,*) file_map, file_eff
     read(2,*) max_loc   
  endif

  ! End of the changes

!!$  print*,'TYP_MK',typ_mk
  read(2,*) tmutSNP, tmutMST, tmutQTL
  read(2,*) deseq ! Kind of initial LD   ! 01/22/2009 deseq==2 inactivated
  read(2,*) typing_err
!!$print*,'typing err',typing_err,deseq,tmutQTL
  errSNP=0; errMST=0; miss_genot=0
  if(typing_err==1) read(2,*) errSNP, errMST, miss_genot
!!$  print*,errSNP, errMST, miss_genot,typing_err


  ! File population 1 & 2
  open(3,file='pop1')
  read(3,*)nbpop
  if(nbpop==1) then
     read(3,*) nb_bott ! Number of bottlenecks
     nb_bott2=0
  else
     read(3,*) nb_bott, nb_bott2
  endif
  allocate(n1(0:nb_bott),t1(0:nb_bott),soud1(0:nb_bott))
  allocate(nball(nmq+nqtl,nbpop+1),nalmax(nbpop+1),mut(nmq+nqtl))
  nball=0
  nalmax=0
  allocate(sel(0:max(nb_bott,nb_bott2),nbpop,2))
  n1=0;t1=0;soud1=0
  read(3,*) n1(0),t1(0),sel(0,1,:) ! initial population size and number of generations before the first bottleneck
  do i=1,nb_bott
     read(3,*) n1(i),t1(i),soud1(i),sel(i,1,:) ! new population sizes fo each botteleneck,number of the last generation 
     ! and type of botteleneck
  enddo
  max_pop1=maxval(n1(:))
  allocate(qtl_mute(nbpop))
  read(3,*) qtl_mute(1:nbpop) ! qtl_mute=0 -> mute QTL are pre-defined; set to 0 if typ_map=2
!!$print*,'NB QTL FIXED',qtl_mute(1:nbpop)
  if(minval(qtl_mute(:))>0) read(3,*) altern   ! altern=0 if the fixed QTL should be chosen completely at random
  ! altern=1 if the QTL should be fixed in the divergent directions in the 2 pops
  ! altern=2 if the same QTL should be fixed in the divergent directions in the 2 pops
  ! altern=3 if the same QTL should be fixed in the same direction in the 2 pops
  if(maxval(qtl_mute(:))>nqtl) then
     print*,'ERROR: TOO MANY FIXED QTL'
     stop 1
  endif

  if(typ_mk==1) then
     if(typ_map==2) then
        do i=1,nmq
           nball(i,1)=2
           read(3,*) mut(i)
        enddo
     else
        read(3,*) mut(1)
        nball(1,1)=2
        do i=2,nmq
           nball(i,1)=2
           mut(i)=mut(1)
        enddo
     endif
  else
     if(typ_map==2) then
        do j=1,nmq
           read(3,*) nball(j,1), mut(j)
        enddo
     else
        read(3,*) mut(1)
        do i=2,nmq
           mut(i)=mut(1)
        enddo
     endif
  endif
  do i=1,nqtl
     read(3,*) nball(nmq+i,1),mut(nmq+i)
  enddo
  nalmax(1)=maxval(nball(:,1))
  allocate(h2(nbpop),ratio_polQTL(nbpop))
  if(nbpop==1) then
     read(3,*) h2(1)
     read(3,*) ratio_polQTL(1)
  else
     read(3,*) h2(1:nbpop)
     read(3,*) ratio_polQTL(1:nbpop)
  endif
  polyg=-1.
  polyg2=-1
  polyg3=-1
  envir=-1
  envir2=-1

  if(nbpop==2) then        ! if 2 populations are required
     allocate(n2(0:nb_bott2),t2(0:nb_bott2),soud(0:nb_bott2))
     n2=0;t2=0;soud=0
     read(3,*) n2(0),t2(0),sel(0,2,:)        ! initial population size of the second population
     do i=1,nb_bott2
        read(3,*) n2(i),t2(i),soud(i),sel(i,2,:)! new population sizes fo each botteleneck, number of the last generation 
        ! and type of botteleneck
     enddo
     max_pop2=maxval(n2(:))
     read(3,*) nb_infusion
     if(nb_infusion/=0) then
        allocate(introg(nb_infusion),time_introg(nb_infusion))
        do i=1,nb_infusion
           read(3,*) introg(i),time_introg(i) ! number of individuals to introgress and generation number
        enddo
        if(time_introg(nb_infusion)>sum(t1(:)).or.time_introg(nb_infusion)>sum(t2(:))) &
             print*,' Problem in the generations counts'
     endif
     if(typ_mk==1) then
        do i=1,nmq
           nball(i,2)=2
        enddo
     else
        do i=1,nmq
           read(3,*) nball(i,2)
        enddo
     endif
     do i=1,nqtl
        read(3,*) nball(nmq+i,2)
     enddo
     nalmax(2)=maxval(nball(:,2))
  endif

  if(lect_gen==0) then
     ! Changed on January 3rd 2011 - FYT
     ! Allele frequencies provided by the user in the case where they are not equifrequent
     read(3,*) all_frq
     allocate(fq_init(nmq+nqtl,maxval(nalmax(:)),nbpop))
     fq_init=0.
     do j=1,nbpop
        if(all_frq==0) then ! All alleles for one locus are equifrequent
           do i=1,nmq+nqtl
              fq_init(i,1:nball(i,j),j)=1./real(nball(i,j))
           enddo
        else if(all_frq==1) then ! Allele frequencies provided by the user
           read(3,*) all_fix
           if(all_fix/=0) then
              do i=1,nmq
                 read(3,*) (fq_init(i,k,j),k=1,nball(i,j)-1)
                 fq_init(i,nball(i,j),j)=1-sum(fq_init(i,1:nball(i,j)-1,j))
                 if(sum(fq_init(i,:,j))/=1) then
                    print*,'ERROR IN THE ALLELE FREQUENCIES FOR MARKER', i
                    stop 1
                 endif
              enddo
              do i=nmq+1,nmq+nqtl
                 read(3,*) (fq_init(i,k,j),k=1,nball(i,j)-1)
                 fq_init(i,nball(i,j),j)=1-sum(fq_init(i,1:nball(i,j)-1,j))
                 if(sum(fq_init(i,:,j))/=1) then
                    print*,'ERROR IN THE ALLELE FREQUENCIES FOR QTL', i-nmq
                    stop 1
                 endif
              enddo
           else
              do i=1,nmq
                 l=G05DYF(1,nball(i,j))
                 fq_init(i,l,j)=1.
              enddo
              do i=1,nqtl
                 l=G05DYF(1,nball(i+nmq,j))
                 fq_init(i+nmq,l,j)=1.
              enddo
           endif
        else
           ! Allele frequencies drawn at random from a uniform distribution
           do i=1,nmq+nqtl
              do k=1,nball(i,j)
                 r=G05CAF(r)
                 fq_init(i,k,j)=r
              enddo
              if(j==1) then
                 m=n1(0)
              else
                 m=n2(0)
              endif
              fq_init(i,:,j)=nint(fq_init(i,:,j)*2*m)
              if(sum(fq_init(i,:,j))/=2*m) then
                 k=2*m-sum(fq_init(i,:,j))
                 do l=1,abs(k)
                    ii=G05DYF(1,nball(i,j))
                    do while(fq_init(i,ii,j)<1)
                       ii=G05DYF(1,nball(i,j))
                    enddo
                    if(k<0) then
                       fq_init(i,ii,j)=fq_init(i,ii,j)-1
                    else
                       fq_init(i,ii,j)=fq_init(i,ii,j)+1
                    endif
                 enddo
              endif
              allocate(parent(nball(i,j),1))
              parent(1:nball(i,j),1)=fq_init(i,1:nball(i,j),j)
              do while(count(any(parent.eq.0,1))>0)
                 ii=G05DYF(1,nball(i,j))
                 if(parent(ii,1)>1) then
                    k=1
                    do while(parent(k,1)>0)
                       k=k+1
                    enddo
                    parent(k,1)=parent(k,1)+1
                    parent(ii,1)=parent(ii,1)-1
                 endif
              enddo
              fq_init(i,1:nball(i,j),j)=parent(1:nball(i,j),1)
              deallocate(parent)
              fq_init(i,:,j)=fq_init(i,:,j)/(2*m)
!!$           print*,'INITIAL FREQUENCIES AT LOCUS',i,'ARE:',fq_init(i,:,j)
           enddo
           if(deseq==1) then
              ii=G05DYF(1,nqtl)
              i=G05DYF(1,nball(ii,j))
              l=G05DYF(1,nball(ii,j))
              test=.FALSE.
              if(l==i) test=.true.
              do while(test)
                 l=G05DYF(1,nball(ii,j))
                 test=.FALSE.
                 if(l==i) test=.true.
              enddo
              if(j==1) then
                 m=n1(0)
              else
                 m=n2(0)
              endif
              fq_init(ii,l,j)=fq_init(ii,l,j)+fq_init(ii,i,j)-1/real(2*m)
              fq_init(ii,i,j)=1/real(2*m)
           endif
        endif
     enddo

     if(deseq==1) then
        toto=maxval(nball(nmq+1:nmq+nqtl,nbpop))
        allocate(nbporteur(nqtl,toto,nbpop))
        do i=1,nqtl
           do k=1,nball(nmq+i,1)
              nbporteur(i,k,1)=fq_init(i,k,1)*n1(0)
           enddo
        enddo
        if(nbpop==2) then
           do i=1,nqtl
              do k=1,nball(nmq+i,2)
                 nbporteur(i,k,2)=fq_init(i,k,2)*n2(0)
              enddo
           enddo
        endif
     endif
  endif
  allocate(typ(nmq+nqtl))
  do i=1,nmq+nqtl
     if(maxval(nball(i,:))==2) then
        typ(i)=1
     else
        typ(i)=2
     endif
  enddo

  read(3,*) direct_fin
  if(direct_fin>0) then
     allocate(old_ped(nbpop))
     old_ped=0
     read(3,*) old_ped(1:nbpop)
     if(minval(old_ped)>0) then
        allocate(fic_ped(nbpop),indPed(nbpop))
        read(3,*)fic_ped(1:nbpop),indPed(1:nbpop)
        read(3,*) last_ind
     endif
  else
     last_ind=0
  endif
  close(3)
  if(lect_map==1) then
     allocate(inter_mute(nbpop))
     do i=1,nbpop
        read(2,*) inter_mute(i)
     enddo
  endif

  if(lect_gen==1) then
     if(store_cop==1) then
        allocate(haplo_file(nbpop), copy_file(nbpop), perf_file(nbpop), app_file(1),lect_nrm(nbpop))
        read(2,*) haplo_file(1), copy_file(1), perf_file(1), lect_nrm(1)
        if(lect_nrm(1)==1) read(2,*) app_file(1)
     else
        allocate(haplo_file(nbpop), perf_file(nbpop), app_file(nbpop))
        read(2,*) haplo_file(1), perf_file(1), lect_nrm(1)
        if(lect_nrm(1)==1) read(2,*) app_file(1)
     endif
     if(nbpop==2) then
        if(store_cop==1) then
           read(2,*) haplo_file(2), copy_file(2), perf_file(2)
           if(lect_nrm(1)==1) read(2,*)  app_file(2)
        else
           read(2,*) haplo_file(2), perf_file(2)
           if(lect_nrm(2)==1) read(2,*)  app_file(2)
        endif
     endif
  endif
  close(2)
  print*,'general read'

  print*,'pop1 read'

  !New 17/06/11

  call G05CBF(rac)
  toto=maxval(nalmax(:))   !! Maximum number of alleles
!!$  print*,'NB QTL FIXED',qtl_mute(1:nbpop)
  if(lect_gen==1) then
     if(allocated(all)) deallocate(all)
     allocate(all(nmq+nqtl,n1(0),2))
     if(store_cop==1) then
        if(allocated(cop)) deallocate(cop)
        allocate(cop(nmq+nqtl,n1(0),2))
        call read_geno_cop(n1(0),nmq+nqtl,all,cop,haplo_file(1),copy_file(1))
     else
        call read_geno_nocop(n1(0),nmq+nqtl,all,haplo_file(1))
     endif

     if(nbpop==2) then
        if(allocated(allp2)) deallocate(allp2)
        allocate(allp2(nmq+nqtl,n1(0),2))
        if(store_cop==1) then
           if(allocated(copp2)) deallocate(copp2)
           allocate(copp2(nmq+nqtl,n1(0),2))
           call read_geno_cop(n2(0),nmq+nqtl,allp2,copp2,haplo_file(2),copy_file(2))
        else
           call read_geno_nocop(n2(0),nmq+nqtl,allp2,haplo_file(2))
        endif
     endif
  endif

  if(lect_map==0) then
     ! QTL that are mute at the beginning of the simulation
     if(minval(qtl_mute(:))>0) then
        allocate(muted_qtl(maxval(qtl_mute(:)),nbpop))
        muted_qtl=0
        allocate(verif(2))
        verif=0
        if(all_frq==1) then
           do l=1,nbpop
              do j=1,nqtl
                 do k=1,nball(nmq+j,l)
                    if(fq_init(nmq+j,k,l)==1.) then
                       verif(l)=verif(l)+1
                       muted_qtl(verif(l),l)=j
                    endif
                 enddo
              enddo
              if(verif(l)>qtl_mute(l)) print*,'MORE FIXED QTL THAN SPECIFIED::',verif(l),' INSTEAD OF',&
                   qtl_mute(l),' IN POPULATION',l
           enddo
        endif
        if(altern<2) then
           do j=1,nbpop
              allocate(rang(qtl_mute(j)-verif(j)))
              call G05DYF2(1,nqtl,qtl_mute(j)-verif(j),rang)
              allocate(parent(qtl_mute(j),1))
              k=0
              do i=1,qtl_mute(j)
                 if(muted_qtl(i,j)/=0) then
                    parent(i,1)=muted_qtl(i,j)
                 else
                    k=k+1
                    parent(i,1)=rang(k)
                 endif
              enddo
              deallocate(rang)
              do i=1,qtl_mute(j)
                 if(muted_qtl(i,j)==0) then
                    do while(count(any(parent .eq. parent(i,1),1))>1) 
                       parent(:,1)=G05DYF(1,nqtl)
                    enddo
                 endif
              enddo
              muted_qtl(:,j)=parent(:,1)
              deallocate(parent)
           enddo
        else
           if(nbpop/=2) then
              print*,'ERROR: ONLY ONE POPULATION SIMULATED. ALTERNATED QTL ARE IMPOSSIBLE'
              stop 1
           endif
           if(qtl_mute(1)/=qtl_mute(2).and.nbpop==2) then
              print*,'ALTERNATE QTL IMPOSSIBLE: ',&
                   'NOT THE SAME NUMBER OF FIXED QTL IN BOTH POPULATIONS'
              stop 1
           endif
           k=0
           do i=1,qtl_mute(1)
              if(muted_qtl(i,1)==0.and.muted_qtl(i,2)/=0) then
                 k=k+1
              endif
              if(muted_qtl(i,1)/=0.and.muted_qtl(i,2)==0) then
                 k=k+1
              endif
           enddo
           if(k>qtl_mute(2)-verif(1).or.k>qtl_mute(1)-verif(2)) then
              print*,'ALTERNATE QTL IMPOSSIBLE: ',&
                   'CANNOT HAVE THE SAME NUMBER OF FIXED QTL IN BOTH POPULATIONS'
              stop 1
           endif
           if(qtl_mute(1)==qtl_mute(2).and.nbpop==2) then
              ll=0
              do i=1,nqtl
                 do k=1,qtl_mute(1)
                    ! search for the QTL already identified in both populations as fixed
                    if(muted_qtl(k,1)==i) l=1
                    if(muted_qtl(k,2)==i) m=1
                 enddo
                 if(l==1.and.m==1) then
                    rang(i)=i
                    ll=ll+1
                 endif
              enddo
              allocate(rang2(qtl_mute(1)-ll))
              call G05DYF2(1,nqtl,qtl_mute(1)-ll,rang2)
              allocate(parent(qtl_mute(1),1))
              k=0
              do i=1,qtl_mute(1)
                 if(muted_qtl(i,1)/=0) then
                    parent(i,1)=muted_qtl(i,1)
                 else
                    k=k+1
                    parent(i,1)=rang2(k)
                 endif
              enddo
              deallocate(rang2)
              do i=1,qtl_mute(1)
                 if(muted_qtl(i,1)==0) then
                    do while(count(any(parent .eq. parent(i,1),1))>1) 
                       parent(:,1)=G05DYF(1,nqtl)
                    enddo
                 endif
              enddo
              muted_qtl(:,1)=parent(:,1)
              deallocate(parent)
              muted_qtl(:,2)=muted_qtl(:,1)
           endif
        endif
        deallocate(verif)
        print*,'LECT MAP DONE'
     endif

     ! Constitution of the genetic map when QTL placed at random
     if(typ_map==1) then
        allocate(QTL_place(nqtl))
        do i=1,nqtl
           r=G05CAF(r)
           QTL_place(i)=r*tot_length
        enddo
        r=0
        ! Determine the chromosome and the position on the chromosome of each QTL
        do i=1,nchrom
           do j=1,nqtl
              if(QTL_place(j)<r+lg_chrom(i).and.QTL_place(j)>r) then
                 pos_QTL(j)=QTL_place(j)-r
                 chr_QTL(j)=i
              endif
           enddo
           r=r+lg_chrom(i)
        enddo
!!$     do i=1,nqtl
!!$        print*,QTL_place(i),chr_QTL(i),pos_QTL(i)
!!$     enddo
        deallocate(QTL_place)

        do i=1,nqtl
           do j=1,nchrom
              if(chr_QTL(i)==j) nloc(j)=nloc(j)+1
           enddo
        enddo

        i=maxval(nloc(:))
        allocate(typ_loc(i,nchrom),ord(nqtl),pos_loc(i,nchrom))
        ord=0
        do i=1,nchrom
           id=0
           do k=1,nqtl
              if(chr_QTL(k)==i) id=id+1
           enddo
           distance=lg_chrom(i)/real(nloc(i)-1-id)
           if(evenly==1) then
              r=0
              typ_loc(1,i)=0
              pos_loc(1,i)=0.
              j=2
              do while(j<=nloc(i))
                 ii=0
                 test=.false.
                 do k=1,nqtl
                    if(chr_QTL(k)==i) then
                       if(pos_QTL(k)<r+distance.and.pos_QTL(k)>r) then
                          test=.true.
                          ii=ii+1
                          if(ii==1) ord(ii)=pos_QTL(k)
                          if(ii==2) then
                             if(pos_QTL(l)<pos_QTL(k)) then
                                ord(1)=pos_QTL(l)
                                ord(2)=pos_QTL(k)
                             else
                                ord(1)=pos_QTL(k)
                                ord(2)=pos_QTL(l)
                             endif
                          else if(ii>2) then
                             do iv=ii-1,2,-1
                                if(pos_QTL(k)>ord(iv)) then
                                   iii=ii
                                   exit
                                endif
                                if(pos_QTL(k)<ord(iv).and.pos_QTL(k)>ord(iv-1)) iii=iv
                                if(pos_QTL(k)<ord(iv-1)) iii=iv-1
                             enddo
                             do iv=ii-1,iii,-1
                                ord(iii+1)=ord(iii)
                             enddo
                             ord(iii)=pos_QTL(k)
                          endif
                       endif
                    endif
                    l=k
                 enddo
                 if(test) then
                    do k=1,ii
                       typ_loc(j+k-1,i)=1
                       pos_loc(j+k-1,i)=ord(k)
                       typ_loc(j+ii,i)=0
                       pos_loc(j+ii,i)=r+distance
                    enddo
                    j=j+ii
                 else
                    typ_loc(j,i)=0
                    pos_loc(j,i)=r+distance
                 endif
                 r=r+distance
                 j=j+1
              enddo
           else
              r=0
              k=0
              do l=1,nqtl
                 if(chr_QTL(l)==i) k=k+1 ! Number of QTL on chromosome i
              enddo
              typ_loc(1,i)=0
              pos_loc(1,i)=0.
              typ_loc(nloc(i)-k,i)=0
              pos_loc(nloc(i)-k,i)=lg_chrom(i)
!!$           print*,'CHROM',i,k,pos_loc(nloc(i)-k,i)
              ! Positioning the markers at random
              allocate(pos2(nloc(i)-k),rang(nloc(i)-k),pos(nloc(i)-k))
              pos2(1)=0
              pos2(nloc(i)-k)=lg_chrom(i)
              rang=0
              pos=0
              do j=2,nloc(i)-k-1
                 r=G05CAF(r)
                 pos2(j)=r*lg_chrom(i)
              enddo
              call search_best(-pos2,nloc(i)-k,rang,nloc(i)-k)
              do j=1,nloc(i)-k
                 pos(j)=pos2(rang(j))
              enddo
              deallocate(pos2,rang)
              j=2      
              id=0
              id2=0
              do while(j<=nloc(i))
                 test=.false.
                 ii=0
                 do k=1,nqtl
                    if(chr_QTL(k)==i) then
!!$                    print*,k,pos_QTL(k),pos(j-id),pos(j-1-id),j,id
                       if(pos_QTL(k)<pos(j-id2).and.pos_QTL(k)>pos(j-1-id2)) then
!!$                        print*,'E2',k,i,pos_QTL(k),pos(j-id2),pos(j-1-id2),j-id2,j-1-id2,id,ii
                          test=.true.
                          id=id+1 ! Number of QTL located in total
                          ii=ii+1 ! Number of QTL found so far in the interval
!!$                       print*,'IN',k,pos_QTL(k),pos(j-id+1),pos(j-id),id,ii
                          if(ii==1) ord(ii)=pos_QTL(k)
                          if(ii==2) then
!!$ print*,'E4',l,k,pos_QTL(l),pos_QTL(k)
                             if(pos_QTL(l)<pos_QTL(k)) then
                                ord(1)=pos_QTL(l)
                                ord(2)=pos_QTL(k)
                             else
                                ord(1)=pos_QTL(k)
                                ord(2)=pos_QTL(l)
                             endif
                          else if(ii>2) then
                             do iv=ii-1,2,-1
                                if(pos_QTL(k)>ord(iv)) then
                                   iii=ii ! The new candidate for this region is further than the previous ones
                                   exit
                                endif
                                if(pos_QTL(k)<ord(iv).and.pos_QTL(k)>ord(iv-1)) iii=iv
                                if(pos_QTL(k)<ord(iv-1)) iii=iv-1
                             enddo
                             do iv=ii-1,iii,-1
                                ord(iii+1)=ord(iii)
                             enddo
                             ord(iii)=pos_QTL(k)
                          endif
                          l=k
                       endif
                    endif
                 enddo
!!$               if(ii>=2) print*,'E3',ord(1:ii)
                 id2=id
                 if(test) then
                    do k=1,ii
                       typ_loc(j+k-1,i)=1
                       pos_loc(j+k-1,i)=ord(k)
                    enddo
                    typ_loc(j+ii,i)=0
                    pos_loc(j+ii,i)=pos(j-id+1)
                    j=j+ii
                 else
                    typ_loc(j,i)=0
                    pos_loc(j,i)=pos(j-id)
                 endif
                 j=j+1
              enddo
              deallocate(pos)
           endif
        enddo
     endif
     if(allocated(ord)) deallocate(ord)
     if(allocated(pos_QTL)) deallocate(pos_QTL)
     if(allocated(chr_QTL)) deallocate(chr_QTL)

     ! Attribution of the effects to each QTL
     k=maxval(nball((nmq+1):(nmq+nqtl),:))
     allocate(eff_qtl(nqtl,k),alleff(nqtl))
     eff_qtl=0
     if(model==0) then 
        if(deseq==0) then
           !! aléatoire si pas de déséquilibre initial
           do j=1,nqtl
              if(nbpop==1) then
                 k=nball(nmq+j,1)
              else
                 k=minval(nball(nmq+j,1:2))
              endif
              alleff(j)=G05DYF(1,k)
              eff_qtl(j,alleff(j))=eff(j)
              l=G05DYF(1,k)
              do while(l==alleff(j))
                 l=G05DYF(1,k)
              enddo
              eff_qtl(j,l)=-eff(j)
           enddo
        else if (deseq==1) then  !! l'allèle présent en une seule copie si hypothèse de DL lié à une mutation
           do j=1,nqtl
              if(minval(nbporteur(:,j,:))==1) then
                 l=maxval(nball(nmq+j,:))
                 do k=1,l
                    if(minval(nbporteur(j,k,:))==1) then
                       alleff(j)=k
                       eff_qtl(j,alleff(j))=eff(j)
                    endif
                 enddo
              else
                 if(nbpop==1) then
                    k=nball(nmq+j,1)
                 else
                    k=minval(nball(nmq+j,1:2))
                 endif
                 l=G05DYF(1,k)
                 alleff(j)=l
                 eff_qtl(j,alleff(j))=eff(j)
              endif
              if(nbpop==1) then
                 k=nball(nmq+j,1)
              else
                 k=minval(nball(nmq+j,1:2))
              endif
              l=G05DYF(1,k)
              do while(l==alleff(j))
                 l=G05DYF(1,k)
              enddo
              eff_qtl(j,l)=-eff(j)
           enddo
           deallocate(eff)
        endif
     else
        ifail=0
        allocate(re(k))
        do j=1,nqtl
           re=0
           tol=0
           call G05FFF(alpha,beta,toto,re)
           l=maxval(nball(nmq+j,:))
           do i=1,l-1
              eff_qtl(j,i)=re(i)
              if(i==1) then
                 r=eff_qtl(j,i)
                 k=1
              else
                 if(eff_qtl(j,i)>r) then
                    r=eff_qtl(j,i)
                    k=j
                 endif
              endif
              tol=tol+eff_qtl(j,i)
           enddo
           eff_qtl(j,l)=-tol
           alleff(j)=k
        enddo
        deallocate(re)
     endif

     allocate(chr_QTL(nqtl),chr_loc(nmq+nqtl))
     l=0
     do i=1,nchrom
        do j=1,nloc(i)
           if(typ_loc(j,i)==1) then
              l=l+1
              chr_QTL(l)=i
           endif
           chr_loc(sum(nloc(1:i-1))+j)=i
        enddo
     enddo

     ! epistatic effects if required
     ! Choosing the marker loci becoming the QTL
     allocate(pos_assoc(nqtl,7))
     ! Description of the elements for each QTL j:
     ! (j,1) --> position of the QTL on the total genome for the allelic tables
     ! (j,2) --> chromosome on which the QTL is located
     ! (j,3) --> is the QTL associated to another one for epistatic effects, if yes, number of the associated QTL
     ! (j,4) --> position of the associated QTL on the total genome for the allelic tables
     ! (j,5) --> chromosome on which the associated QTL is located
     ! (j,6) --> kind of interaction
     ! (j,7) --> dominance effect (if=1)
     pos_assoc=0
     allocate(dist(nmq+nqtl-1),indic(nmq+nqtl),posqtl(nqtl))
     k=0
     r=0
     l=0
     posqtl=0
     indic=0
     do i=1,nchrom
!!$     print*,nloc(i),k
        do j=1,nloc(i)-1
           dist(k+j)=pos_loc(j+1,i)-pos_loc(j,i)
           if(typ_loc(j,i)==1) then
              !           print*,k+j,l
              l=l+1
              indic(k+j)=1
              posqtl(l)=k+j
              pos_assoc(l,1)=posqtl(l)
              pos_assoc(l,2)=i
           endif
        enddo
        if(i/=nchrom) dist(k+nloc(i))=100
        if(typ_loc(nloc(i),i)==1) then
           !           print*,k+j,l
           l=l+1
           indic(k+nloc(i))=1
           posqtl(l)=k+nloc(i)
           pos_assoc(l,1)=posqtl(l)
           pos_assoc(l,2)=i
        endif
        k=k+nloc(i)
     enddo
     print*,'QTL position(s)',posqtl(:)

     maxloc=maxval(nloc(:))

     allocate(pair_interac(nqtl),verif(nqtl))
     verif=0
     pair_interac=0
     do i=1,ncpl_qtl_interac
        test=.false.
        test2=.false.
        j=G05DYF(1,nqtl)
        do while(verif(j)/=0)
           j=G05DYF(1,nqtl)
        enddo
!!$     print*,'INTERAC 1',i
        verif(j)=1
        pair_interac(j)=G05DYF(1,nqtl)
        if(pair_interac(j)==j) test=.true.
        if(verif(pair_interac(j))/=0) test2=.true.
        do while(test.or.test2)
           test=.false.
           test2=.false.
           pair_interac(j)=G05DYF(1,nqtl)
           if(pair_interac(j)==j) test=.true.
           if(verif(pair_interac(j))/=0) test2=.true.
        enddo
!!$     print*,'INTERAC 2',i
        pos_assoc(j,3)=pair_interac(j)
        pos_assoc(j,4)=pos_assoc(pair_interac(j),1)
        pos_assoc(j,5)=pos_assoc(pair_interac(j),2)
        pos_assoc(pair_interac(j),3)=j
        pos_assoc(pair_interac(j),4)=pos_assoc(j,1)
        pos_assoc(pair_interac(j),5)=pos_assoc(j,2)
        verif(pair_interac(j))=1
        pos_assoc(j,6)=typ_inter(i)
        pos_assoc(pair_interac(j),6)=typ_inter(i)
     enddo
     if(allocated(typ_inter)) deallocate(typ_inter)


     allocate(dom(nqtl,1))
     dom=0
     if(n_qtl_dom>0.and.typ_map==1) then
        call G05DYF2(1,nqtl,n_qtl_dom,dom)
        do i=1,n_qtl_dom
           test=.false.
           if(pos_assoc(dom(i,1),3)/=0) test=.true.
           if(count(any(dom .eq. dom(i,1),1))>1) test=.true.
           do while (test)
              test=.false.
              dom(i,1)=G05DYF(1,nqtl)
              if(pos_assoc(dom(i,1),3)/=0) test=.true.
              if(count(any(dom .eq. dom(i,1),1))>1) test=.true.
           enddo
        enddo
        j=0
        allocate(reserv(nqtl))
        do i=1,nqtl
           select case (any(dom(:,1) .eq. i))
           case(.true.)
              j=j+1
              pos_assoc(i,7)=1
              hh=G05DYF(1,2)
              if(model/=1) then
                 reserv(i)=eff_dom(j)
              else
                 ! Dominance effects comprised between 5 and 150% of the additive effect of the QTL
                 r=G05DYF(5,150)
                 if(hh==1) then
                    reserv(i)=-r*maxval(2*eff_qtl(i,:))/100
                 else
                    reserv(i)=r*maxval(2*eff_qtl(i,:))/100
                 endif
              endif
           end select
        enddo
        if(.not.allocated(eff_dom)) allocate(eff_dom(nqtl))
        eff_dom=reserv(:)
        deallocate(dom,reserv)
     endif
     deallocate(pair_interac,verif)
     if(.not.allocated(eff_dom)) then
        allocate(eff_dom(nqtl))
        eff_dom=0.
     endif
     print*,'DOMINANCE AND EPISTATIC EFFECTS: DONE'

     allocate(perf_temp(nqtl),rang(nqtl))
     perf_temp=-pos_assoc(:,1)
     rang=0
     call search_best(perf_temp,nqtl,rang,nqtl)
     deallocate(perf_temp)
     allocate(p_a_temp(nqtl,7))
     do i=1,nqtl
        p_a_temp(i,:)=pos_assoc(rang(i),:)
     enddo
     pos_assoc=p_a_temp
     deallocate(p_a_temp,rang)


     open(122,file='map')
     open(222,file='effects')
     k=0
     l=0
     do i=1,nchrom
        do j=1,nloc(i)
           write(122,*)l+j,i,j,pos_loc(j,i),typ_loc(j,i)
           if(typ_loc(j,i)==1) then
              k=k+1
              write(222,*)eff_qtl(k,1:maxval(nball(nmq+i,:))),eff_dom(k)
           endif
        enddo
        l=l+nloc(i)
     enddo
     close(122)
     close(222)

     if(further_use==1) then
        open(137,file='epis+silent')
        do i=1,nqtl
           test=.false.
           do j=1,qtl_mute(1)
              if(muted_qtl(j,1)==i) test=.true.
           enddo
           k=0
           if(test) k=1
           write(137,*) pos_assoc(i,:),k
        enddo
     endif

  else

     allocate(pos_loc(max_loc,nchrom),typ_loc(max_loc,nchrom))
     pos_loc=0; typ_loc=0
     allocate(nloc(nchrom),chr_QTL(nqtl))
     allocate(alleff(nqtl),eff_dom(nqtl),eff_qtl(nqtl,maxval(nball(:,:))),posqtl(nqtl),indic(nqtl+nmq))
     allocate(chr_loc(nmq+nqtl))
     indic=0
     call read_map(nmq,nqtl,typ_loc,chr_QTL,nloc,nball,alleff,eff_dom,eff_qtl,posqtl,indic,pos_loc,&
          file_map,file_eff,chr_loc)
     allocate(lg_chrom(nchrom))
     do k=1,nchrom
        lg_chrom(k)=pos_loc(nloc(k),k)-pos_loc(1,k)
     enddo
     if(maxval(qtl_mute)>0.or.ncpl_qtl_interac/=0) then
        allocate(pos_assoc(nqtl,7),muted_qtl(maxval(qtl_mute),2))
        do i=1,nbpop
           call intera_mute(pos_assoc,nqtl,muted_qtl,i,inter_mute(i))
        enddo
     endif
     print*,'MAP READ'
  endif
  ! End of the changes

  open(7,file='files')  !! Choice of the output files
  read(7,*) max_gener_eval, outfiles
  if(outfiles/=0) then
     allocate(gener_eval(10,max_gener_eval))
     gener_eval=-1
     read(7,*)f_dl  !! simld
!!$print*,'f_dl',f_dl
     if(f_dl=="y") then
        read(7,*)j,(gener_eval(1,k),k=1,j)
        open(11,file='simld')
     endif
     read(7,*)f_dlq  !! simld
     if(f_dlq=="y") then
        read(7,*)j,(gener_eval(10,k),k=1,j)
        open(111,file='simldq')
     endif
     read(7,*)f_dl_sum  !! simld_sum
!!$print*,'f_dl',f_dl
     if(f_dl_sum=="y") then
        read(7,*)j,(gener_eval(8,k),k=1,j),bin
        open(112,file='simld_sum')
     endif
     read(7,*)f_ibd  !! ibd
     if(f_ibd=="y") then
        read(7,*)j,(gener_eval(2,k),k=1,j)
        open(21,file='ibd')
     endif
     read(7,*)f_ibdq   !! ibdqtl
     if(f_ibdq=="y") then
        read(7,*)j,(gener_eval(3,k),k=1,j)
        open(22,file='ibdqtl')
     endif
     read(7,*)f_csg  !! consang
     if(f_csg=="y") then
        read(7,*)j,(gener_eval(4,k),k=1,j)
        open(23,file='consang')
     endif
     read(7,*)f_hPIC  !! haplo-PIC
!!$print*,'f_hPIC',f_hPIC
     if(f_hPIC=="y") then
        read(7,*)j,(gener_eval(5,k),k=1,j)
        open(13,file='haplo-PIC')
     endif
     read(7,*)f_fqall   !! simfqall
!!$print*,'f_fqall',f_fqall
     if(f_fqall=="y") then
!!$        print*,'HERE'
        read(7,*)j,(gener_eval(6,k),k=1,j)
        open(10,file='simfqall')
     endif
     read(7,*)f_fqcop   !! simfqcop
!!$print*,'f_fqcop',f_fqcop
     if(f_fqcop=="y") then
        read(7,*)j,(gener_eval(7,k),k=1,j)
        open(19,file='simfqcop')
     endif
  else
     allocate(gener_eval(10,1))
     gener_eval=-1
  endif
  close(7)
!!$  deallocate(nloc)

  pop=1

  if(nbpop==2) then
     maxim=max(max_pop1,max_pop2)
  else
     maxim=max_pop1
  endif
  if(lect_gen==0) allocate(all(nmq+nqtl,max_pop1,2))

  i=maxim
  allocate(gind(i,nbpop+1),gani(i,nbpop+1))
  gind=0;gani=0
  allocate(perf(i,nbpop+1))
  perf=0   

  call G05CBF(rac1)

  ! CREATION OF THE FOUNDER(s) POPULATION(S)

  if(lect_gen==0) then
!!! CREATION OF THE FIRST POPULATION
     print*,'CREATION OF THE FIRST POPULATION'

     r=1/(real(2*n1(0)))
     allocate(freq(nmq+nqtl,maxval(nalmax(:))))
     freq=0
     if(qtl_mute(1)>0) then
        allocate(rang(nqtl))
        rang=0
        do i=1,nqtl
           rang(i)=G05DYF(1,nball(nmq+i,1))
           test=.FALSE.
           if(eff_qtl(i,rang(i))==maxval(eff_qtl(i,:))) test=.TRUE.
           do while(test)
              rang(i)=G05DYF(1,maxval(nball(nmq+i,:)))
              test=.FALSE.
              if(eff_qtl(i,rang(i))==maxval(eff_qtl(i,:))) test=.TRUE.
           enddo
        enddo
     endif
     l=0
     m=0
     r=1/(2*real(n1(0)))
     do j=1,nmq+nqtl
!!$     print*,'LOCUS',j,'INITIAL FREQUENCIES',fq_init(j,:,1)
        if(indic(j)==1) then
           l=l+1
           do i=1,n1(0) !! alleles and correspondance with the copy numbers
              if(qtl_mute(1)==0) then
                 do k=1,2
                    all(j,i,k)=G05DYF(1,nball(nmq+l,1))
                    do while (nint(freq(nmq+l,all(j,i,k))*2*n1(0))>=nint(fq_init(nmq+l,all(j,i,k),1)*2*n1(0)))
                       all(j,i,k)=G05DYF(1,nball(nmq+l,1))
                    enddo
                    freq(nmq+l,all(j,i,k))=freq(nmq+l,all(j,i,k))+r
!!$                 print*,'HERE',i,k,j,all(j,i,k),freq(nmq+l,all(j,i,k))
                 enddo
              else
                 allocate(parent(qtl_mute(1),1))
                 parent(:,1)=muted_qtl(:,1)
                 if(count(any(parent==l,1))==0) then
                    do k=1,2
                       all(j,i,k)=G05DYF(1,nball(nmq+l,1))
                       do while (nint(freq(nmq+l,all(j,i,k))*2*n1(0))>=nint(fq_init(nmq+l,&
                            all(j,i,k),1)*2*n1(0)))
                          all(j,i,k)=G05DYF(1,nball(nmq+l,1))
                       enddo
                       freq(nmq+l,all(j,i,k))=freq(nmq+l,all(j,i,k))+r
!!$                 print*,'THERE',i,k,j,all(j,i,k),freq(nmq+l,all(j,i,k))
                    enddo
                 else
                    all(j,i,:)=rang(l)
                 endif
                 deallocate(parent)
              endif
           enddo
        else
           m=m+1
           do i=1,n1(0) !! alleles and correspondance with the copy numbers
              do k=1,2
                 all(j,i,k)=G05DYF(1,nball(m,1))
                 do while (nint(freq(m,all(j,i,k))*2*n1(0))>=nint(fq_init(m,all(j,i,k),1)*2*n1(0)))
                    all(j,i,k)=G05DYF(1,nball(m,1))
                 enddo
                 freq(m,all(j,i,k))=freq(m,all(j,i,k))+r
!!$              print*,'FURTHER',i,k,j,all(j,i,k),freq(m,all(j,i,k))
              enddo
           enddo
        endif
     enddo
     deallocate(freq)
     if(allocated(rang)) deallocate(rang)

     if(store_cop==1) then
        allocate(cop(nmq+nqtl,max_pop1,2))
        do i=1,n1(0)   !! copy numbers
           do j=1,nmq+nqtl
              do k=1,2
                 cop(j,i,k)=(i-1)*2+k
              enddo
           enddo
        enddo
     endif

!!!                   CREATION OF THE 2ND POPULATION
     if(nbpop==2) then

        print*,'CREATION OF THE SECOND POPULATION'
        pop=2
        allocate(allp2(nmq+nqtl,max_pop2,2))
        allp2=0

        ! CREATION OF THE FOUNDER POPULATION
        r=1/(real(2*n2(0)))
        allocate(freq(nmq+nqtl,maxval(nalmax(:))))
        freq=0.
        if(altern<2.and.qtl_mute(2)>0) then
           allocate(rang(nqtl))
           do i=1,nqtl
              rang=G05DYF(1,nball(nmq+i,2))
              test=.FALSE.
              if(eff_qtl(i,rang(i))==maxval(eff_qtl(i,:))) test=.TRUE.
              do while(test)
                 rang=G05DYF(1,nball(nmq+i,2))
                 test=.FALSE.
                 if(eff_qtl(i,rang(i))==maxval(eff_qtl(i,:))) test=.TRUE.
              enddo
           enddo
        endif
        l=0
        m=0
        r=1/(2*real(n2(0)))
        do j=1,nmq+nqtl
!!$        print*,'ALLELE FREQUENCIES IN POPULATION 2 AT LOCUS',j,':',fq_init(j,:,2)
           if(indic(j)==1) then
              l=l+1
              do i=1,n2(0) !! alleles and correspondance with the copy numbers
                 if(qtl_mute(2)==0) then
                    do k=1,2
                       allp2(j,i,k)=G05DYF(1,nball(nmq+l,2))
!!$                   print*,'HERE',i,fq_init(nmq+l,:,2),freq(nmq+l,:),nball(nmq+l,:)
                       do while (nint(freq(nmq+l,allp2(j,i,k))*2*n2(0))>=nint(fq_init(nmq+l,allp2(j,i,k),2)*2*n2(0)))
                          allp2(j,i,k)=G05DYF(1,nball(nmq+l,2))
!!$                       print*,allp2(j,i,k),r,nint(freq(nmq+l,all(j,i,k))*2*n2(0)),nint(fq_init(nmq+l,allp2(j,i,k),2)*2*n2(0))
                       enddo
                       freq(nmq+l,allp2(j,i,k))=freq(nmq+l,allp2(j,i,k))+r
                    enddo
                 else 
                    allocate(parent(qtl_mute(2),1))
                    parent(:,1)=muted_qtl(:,2)
                    if(count(any(parent==l,1))==0) then
                       do k=1,2
                          allp2(j,i,k)=G05DYF(1,nball(nmq+l,2))
!!$                       print*,'HERE2',nint(freq(nmq+l,allp2(j,i,k))*2*n2(0)),nint(fq_init(nmq+l,allp2(j,i,k),&
!!$                            2)*2*n2(0))

                          do while (nint(freq(nmq+l,allp2(j,i,k))*2*n2(0))>=nint(fq_init(nmq+l,allp2(j,i,k),&
                               2)*2*n2(0)))
                             allp2(j,i,k)=G05DYF(1,nball(nmq+l,2))
                          enddo
                          freq(nmq+l,allp2(j,i,k))=freq(nmq+l,allp2(j,i,k))+r
                       enddo
                    else
                       if(altern==2) then
                          do k=1,maxval(nball(nmq+l,:))
                             if(eff_qtl(l,k)==maxval(eff_qtl(l,:))) then
                                allp2(j,i,:)=k
                                exit
                             endif
                          enddo
                       else 
                          allp2(j,i,:)=rang(l)
                       endif
                    endif
                    deallocate(parent)
                 endif
              enddo
           else
              m=m+1
!!$          print*,'THERE',m,fq_init(m,:,2)
              do i=1,n2(0)
                 do k=1,2
                    allp2(j,i,k)=G05DYF(1,nball(m,2))
                    do while (nint(freq(m,allp2(j,i,k))*2*n2(0))>=nint(fq_init(m,allp2(j,i,k),2)*2*n2(0)))
                       allp2(j,i,k)=G05DYF(1,nball(m,2))
                    enddo
                    freq(m,allp2(j,i,k))=freq(m,allp2(j,i,k))+r
                 enddo
              enddo
           endif
        enddo
        deallocate(freq,fq_init)
        if(allocated(rang)) deallocate(rang)

        if(store_cop==1) then
           allocate(copp2(nmq+nqtl,max_pop2,2))
           do i=1,n2(0)   !! copy numbers
              do j=1,nmq+nqtl
                 do k=1,2
                    copp2(j,i,k)=(i-1)*2+k+2*n1(0)
                 enddo
              enddo
           enddo
        endif
     endif

     if(minval(qtl_mute(:))>0) deallocate(qtl_mute,muted_qtl)
  endif

  time=sum(t1(:))
  allocate(selection(0:time,nbpop,2),n(0:time,nbpop))
  time=0; n=0
  do i=0,t1(0)
     n(i,1)=n1(0)
     selection(i,1,:)=sel(0,1,:)
  enddo
  time=t1(0)
  do bott=1,nb_bott
     if(soud1(bott)==2) then
        b=(n1(bott)-n1(bott-1))/t1(bott)
        allocate(a(t1(bott)+1))
        do j=1,t1(bott)-1
           a(j)=b*j+n1(bott-1)
           n(time+j,1)=nint(a(j))
        enddo
        n(time+t1(bott),1)=n1(bott)
        deallocate(a)
     else if(soud1(bott)==1) then
!!$        print*,time+t1(bott),bott,time
        n(time+1:time+t1(bott),1)=n1(bott)
     endif
     do i=1,t1(bott)
        selection(time+i,1,:)=sel(bott,1,:)
     enddo
     time=time+t1(bott)
  enddo
  if(nbpop==1) deallocate(sel)

  if(nbpop==2) then
     do i=0,t2(0)
        n(i,2)=n2(0)
        selection(i,2,:)=sel(0,2,:)
     enddo
     time=t2(0)
     do bott=1,nb_bott2
        if(soud(bott)==2) then
           b=(n2(bott)-n2(bott-1))/t2(bott)
           allocate(a(t2(bott)+1))
           do j=1,t2(bott)-1
              a(j)=b*j+n2(bott-1)
              n(time+j,2)=nint(a(j))
           enddo
           n(time+t2(bott),2)=n2(bott)
           deallocate(a)
        else if(soud(bott)==1) then
           n(time+1:time+t2(bott),2)=n2(bott)
        endif
        do i=1,t2(bott)
           selection(time+i,2,:)=sel(bott,2,:)
        enddo
        time=time+t2(bott)
     enddo
     deallocate(sel)
  endif

  ! Change 17/06/2011
  if(lect_gen==1) then
     time=sum(t1(:))
     write(*,*)'Sizes population 1',n(:,1)
     if(nbpop==2) write(*,*)'Sizes population 2',n(:,2)
     if(store_cop==1) then
        allocate(maxcop(nmq+nqtl,nbpop+1))
        do i=1,nmq+nqtl
           if(nbpop==2) then
              maxcop(i,2)=max(maxval(cop(i,:,:)),maxval(copp2(i,:,:)))
           else
              maxcop(i,1)=maxval(cop(i,:,:))
           endif
        enddo
        allocate(ncopmax(nbpop+1))
        ncopmax=0
        ncopmax(1)=maxval(maxcop(:,1))
        if(nbpop==2) then
           ncopmax(2)=maxval(maxcop(:,1))
        endif
     endif

  else
     time=sum(t1(:))
     write(*,*)'Sizes population 1',n(:,1)
     if(nbpop==2) write(*,*)'Sizes population 2',n(:,2)
     if(store_cop==1) then
        allocate(maxcop(nmq+nqtl,nbpop+1))
        maxcop(:,1)=2*n(0,1)
        if(nbpop==2) then
           maxcop(:,2)=2*n(0,2)+2*n(0,1)
        endif
        allocate(ncopmax(nbpop+1))
        ncopmax=0
        ncopmax(1)=2*n(0,1)
        if(nbpop==2) then
           ncopmax(2)=2*n(0,2)+2*n(0,1)
        endif
     endif
  endif
  ! End of the changes

  time=sum(t1(:))
  allocate(indic_1(time))
  if(nbpop==2) allocate(indic_2(time),indic_in(time))
  indic_1=0
  if(nbpop==2) then
     indic_2=0
     indic_in=0
  endif
  do i=1,nb_bott
     if(soud1(i)==1) indic_1(t1(i))=soud1(i)
  enddo
  if(nbpop==2) then
     do i=1,nb_bott2
        if(soud(i)==1) indic_2(t2(i))=soud(i)
     enddo
     if(nb_infusion/=0) then
        do i=1,nb_infusion
           indic_in(time_introg(i))=1
        enddo
     else 
        indic_in=0
     endif
  endif
  if(direct_fin==0) then
     deallocate(n1,t1,soud1)
     if (nbpop==2) then
        time2=sum(t2(:))
        deallocate(n2,t2,soud)
        if(allocated(time_introg)) deallocate(time_introg)
     endif
  else
     deallocate(t1,soud1)
     if (nbpop==2) then
        time2=sum(t2(:))
        deallocate(t2,soud)
        if(allocated(time_introg)) deallocate(time_introg)
     endif
  endif

  allocate(fqall2(nmq+nqtl,nbpop+1))
  fqall2=0
  k=0
  do i=1,nmq+nqtl
     if(indic(i)==1) then
        k=k+1
        fqall2(i,:)=nball(nmq+k,:)
     else
        fqall2(i,:)=nball(i-k,:)
     endif
  enddo
  nball=nint(fqall2)
  deallocate(fqall2)

  ! Attribution of the additive genetic values

  if(lect_gen==0) then
     if(minval(selection(0,1,:))<1) then
        allocate(fqall(nmq+nqtl,maxval(nball(:,:))),fqall2(nmq+nqtl,maxval(nball(:,:))))
        fqall=0; fqall2=0
        call stat_freq_1(1,n(0,1),all,nball,fqall)
        l=0
        do k=1,nchrom
           do j=1,nloc(k)
              if(typ_loc(j,k)==1) then
                 l=l+1
                 if(pos_assoc(l,3)/=0) then
                    if(pos_assoc(l,1)<pos_assoc(l,4)) then
                       if(pos_assoc(l,6)==1) then
                          do i=1,n(0,1)
                             if(all(pos_assoc(l,1),i,1)==all(pos_assoc(l,1),i,2).and.all(pos_assoc(l,4),i,1)==&
                                  all(pos_assoc(l,4),i,2)) then
                                if (all(pos_assoc(l,1),i,1)==1.and.all(pos_assoc(l,4),i,1)==1) fqall2(l,1)=&
                                     fqall2(l,1)+1 ! both locus homozygote for the same allele 
                                if (all(pos_assoc(l,1),i,1)==2.and.all(pos_assoc(l,4),i,1)==2) fqall2(l,1)=&
                                     fqall2(l,1)+1 ! both locus homozygote for the same allele
                                if (all(pos_assoc(l,1),i,1)==1.and.all(pos_assoc(l,4),i,1)==2) fqall2(l,2)=&
                                     fqall2(l,2)+1 ! both locus homozygote for different alleles
                                if (all(pos_assoc(l,1),i,1)==2.and.all(pos_assoc(l,4),i,1)==1) fqall2(l,2)=&
                                     fqall2(l,2)+1 ! both locus homozygote for different alleles
                             endif
                          enddo
                          fqall2(l,:)=fqall2(l,:)/(real(n(0,1)))
                       else
                          do i=1,n(0,1)
                             test=.false.
                             if(eff_QTL(l,all(pos_assoc(l,1),i,1))==maxval(eff_QTL(l,:))) test=.true.
                             if(eff_QTL(l,all(pos_assoc(l,1),i,2))==maxval(eff_QTL(l,:))) test=.true.
                             if (test) then
                                if(all(pos_assoc(l,4),i,1)==1.and.all(pos_assoc(l,4),i,2)==1) fqall2(l,1)=fqall2(l,1)+1
                                if(all(pos_assoc(l,4),i,1)==2.and.all(pos_assoc(l,4),i,2)==2) fqall2(l,2)=fqall2(l,2)+1
                             endif
                          enddo
                          fqall2(l,:)=fqall2(l,:)/(real(n(0,1)))
                       endif
                    endif
                 endif
              endif
           enddo
        enddo
        call create_pheno(gind,1,nqtl,eff_qtl,eff_dom,envir,polyg,n(0,1),pos_assoc,perf,all,nmq,fqall,&
             fqall2,nball,h2,ratio_polQTL,indic)
        deallocate(fqall,fqall2)
     endif

     if(nbpop==2) then
        ! Attribution of the additive genetic values
        if(minval(selection(0,2,:))<1) then
           allocate(fqall(nmq+nqtl,maxval(nball(:,:))),fqall2(nmq+nqtl,maxval(nball(:,:))))
           fqall=0; fqall2=0
           call stat_freq_1(1,n(0,2),allp2,nball,fqall)
           l=0
           do k=1,nchrom
              do j=1,nloc(k)
                 if(typ_loc(j,k)==1) then
                    l=l+1
                    if(pos_assoc(l,3)/=0) then
                       if(pos_assoc(l,1)<pos_assoc(l,4)) then
                          if(pos_assoc(l,6)==1) then
                             do i=1,n(0,2)
                                if(all(pos_assoc(l,1),i,1)==allp2(pos_assoc(l,1),i,2).and.allp2(pos_assoc(l,4),i,1)==&
                                     allp2(pos_assoc(l,4),i,2)) then
                                   if (allp2(pos_assoc(l,1),i,1)==1.and.allp2(pos_assoc(l,4),i,1)==1) fqall2(l,1)=&
                                        fqall2(l,1)+1 ! both locus homozygote for the same allele 
                                   if (allp2(pos_assoc(l,1),i,1)==2.and.allp2(pos_assoc(l,4),i,1)==2) fqall2(l,1)=&
                                        fqall2(l,1)+1 ! both locus homozygote for the same allele
                                   if (allp2(pos_assoc(l,1),i,1)==1.and.allp2(pos_assoc(l,4),i,1)==2) fqall2(l,2)=&
                                        fqall2(l,2)+1 ! both locus homozygote for different alleles
                                   if (allp2(pos_assoc(l,1),i,1)==2.and.allp2(pos_assoc(l,4),i,1)==1) fqall2(l,2)=&
                                        fqall2(l,2)+1 ! both locus homozygote for different alleles
                                endif
                             enddo
                             fqall2(l,:)=fqall2(l,:)/(real(n(0,2)))
                          else
                             do i=1,n(0,2)
                                test=.false.
                                if(eff_QTL(l,allp2(pos_assoc(l,1),i,1))==maxval(eff_QTL(l,:))) test=.true.
                                if(eff_QTL(l,allp2(pos_assoc(l,1),i,2))==maxval(eff_QTL(l,:))) test=.true.
                                if (test) then
                                   if(allp2(pos_assoc(l,4),i,1)==1.and.allp2(pos_assoc(l,4),i,2)==1) fqall2(l,1)=fqall2(l,1)+1
                                   if(allp2(pos_assoc(l,4),i,1)==2.and.allp2(pos_assoc(l,4),i,2)==2) fqall2(l,2)=fqall2(l,2)+1
                                endif
                             enddo
                             fqall2(l,:)=fqall2(l,:)/(real(n(0,2)))
                          endif
                       endif
                    endif
                 endif
              enddo
           enddo
           call create_pheno(gind,2,nqtl,eff_qtl,eff_dom,envir2,polyg2,n(0,2),pos_assoc,perf,allp2,nmq,fqall,&
                fqall2,nball,h2,ratio_polQTL,indic)
           deallocate(fqall,fqall2)
        endif
     endif
  else

     call read_pheno(n(0,1),perf,gind,1,perf_file(1))
     if(nbpop==2) call read_pheno(n(0,2),perf,gind,2,perf_file(2))

  endif

  allocate(verif_print(10))
  verif_print=0
  if(outfiles/=0) then
     do j=1,10
        if(gener_eval(j,1)==0) verif_print(j)=1
     enddo
  endif


  allocate(fqall(nmq+nqtl,maxval(nalmax(:))))
  fqall=0
  call stat_freq_1(1,n(0,1),all,nball,fqall)
  if(gener_eval(6,1)==0) then
     do i=1,nmq+nqtl
        do j=1,nball(i,1)
           write(10,*)i,j,fqall(i,j),n(0,1),zero
        enddo
     enddo
  endif

  if(gener_eval(1,1)==0.or.gener_eval(10,1)==0) then
     call LD(lg_chrom,bin,nchrom,nball,nmq,nqtl,n(0,1),all,fqall,verif_print,1,chr_loc,nloc,pos_loc,zero)
  endif

  aux_test=.false.
  if(f_hPIC=='y') aux_test=.true.
  if(gener_eval(5,1)==0.or.aux_test) then  !! Valeur du PIC au QTL et proportions d'haplotypes conservés
     allocate(pic(nmq+nqtl))
     call eval_pic(1,nball,nmq+nqtl,pic)
     call nbhaplotypes(n(0,1),all,indic,nmq,nqtl)
     nb_h_init=nb_h
     nb_hc_init=nb_hc
     if(gener_eval(5,1)==0) then
        prop_h=real(nb_h)/real(nb_h_init)
        prop_hc=real(nb_hc)/real(nb_hc_init)
        do i=1,nqtl+nmq
           write(13,'(i8,1x,3(i4,1x),f4.2,1x,i4,1x,f4.2,1x,i2,1x,f10.6)')n(0,1),&
                zero,i,nb_h,prop_h,nb_hc,prop_hc,indic(i),pic(i)
        enddo
     endif
  endif


  deallocate(fqall,verif_print)

  allocate(all2(nmq+nqtl,maxim,2),cop2(nmq+nqtl,maxim,2))
  allocate(parent(maxim,2))
  parent=0
  if(selection(0,1,1)/=1.or.selection(0,1,2)/=1) then
     allocate(rang(n(0,1)))
     allocate(perf_temp(n(0,1)))
     perf_temp(1:nint(real(n(0,1))/2))=perf(1:nint(real(n(0,1))/2),1)
     call search_best(perf_temp,nint(real(n(0,1))/2),rang,nint(real(n(0,1))/2))
     perf_temp(1:nint(real(n(0,1))/2))=perf(1+nint(real(n(0,1))/2):n(0,1),1)
     call search_best(perf_temp,n(0,1)-nint(real(n(0,1))/2),rang(1+nint(real(n(0,1))/2):n(0,1)),&
          n(0,1)-nint(real(n(0,1))/2))
     rang(1+nint(real(n(0,1))/2):n(0,1))=rang(1+nint(real(n(0,1))/2):n(0,1))+nint(real(n(0,1))/2)
     do j=1,n(0,1)
        perf(j,1)=perf_temp(rang(j))
        all2(:,j,:)=all(:,rang(j),:)
        if(store_cop==1) cop2(:,j,:)=cop(:,rang(j),:)
        gani(j,nbpop+1)=gind(rang(j),1)
     enddo
     do i=1,n(0,1)
        all(:,i,:)=all2(:,i,:)
        if(store_cop==1) cop(:,i,:)=cop2(:,i,:)
        gind(i,1)=gani(i,nbpop+1)
     enddo
     all2=0
     if(store_cop==1) cop2=0
     deallocate(perf_temp,rang)
  endif


  if(nbpop==2) then
     if(selection(0,2,1)/=1.or.selection(0,2,2)/=1) then
        allocate(rang(n(0,2)))
        allocate(perf_temp(n(0,2)))
        perf_temp(1:nint(real(n(0,2))/2))=perf(1:nint(real(n(0,2))/2),2)
        call search_best(perf_temp,nint(real(n(0,2))/2),rang,nint(real(n(0,2))/2))
        perf_temp(1:nint(real(n(0,2))/2))=perf(1+nint(real(n(0,2))/2):n(0,2),2)
        call search_best(perf_temp,n(0,2)-nint(real(n(0,2))/2),rang(1+nint(real(n(0,2))/2):n(0,2)),&
             n(0,2)-nint(real(n(0,2))/2))
        rang(1+nint(real(n(0,2))/2):n(0,2))=rang(1+nint(real(n(0,2))/2):n(0,2))+nint(real(n(0,2))/2)
        do j=1,n(0,2)
           perf(j,2)=perf_temp(rang(j))
           all2(:,j,:)=allp2(:,rang(j),:)
           if(store_cop==1)  cop2(:,j,:)=copp2(:,rang(j),:)
           gani(j,nbpop+1)=gind(rang(j),2)
        enddo
        do j=1,n(0,2)
           allp2(:,j,:)=all2(:,j,:)
           if(store_cop==1) copp2(:,j,:)=cop2(:,j,:)
           gind(j,2)=gani(j,nbpop+1)
        enddo
        all2=0
        if(store_cop==1) cop2=0
        deallocate(perf_temp,rang)
     endif
  endif

  allocate(nrmat(maxval(n(:,1)),maxval(n(:,1))))
  if(nbpop==2) then
     allocate(nrmat3(maxval(n(:,2)),maxval(n(:,2))))
     if(maxval(indic_in(:)) /=0) then
        allocate(nrmat2(maxval(n(:,1)),maxval(n(:,2))))
        nrmat2=0
     endif
  endif
  if(lect_gen==0) then
     nrmat=0
     do i=1,n(0,1)
        nrmat(i,i)=1
     enddo
     if(nbpop==2) then
        do i=1,n(0,2)
           nrmat3(i,i)=1
        enddo
     endif
  else
     if(lect_nrm(1)==0) then
        nrmat=0
        do i=1,n(0,1)
           nrmat(i,i)=1
        enddo
        if(nbpop==2) then
           do i=1,n(0,2)
              nrmat3(i,i)=1
           enddo
        endif
     else
        call read_nrm(n(0,1),nrmat,app_file(1))
        if(nbpop==2) call read_nrm(n(0,2),nrmat3,app_file(2))
     endif
  endif


  !***************************************************************************************!
  !                           Evolution of the population(s)
  !***************************************************************************************!

  infus=0
!!!!  

  if(direct_fin==0) then
     do gene=1,time
        print*,'GENERATION',gene

        !  print*,'Generation',gene pi
        if(indic_1(gene)==1) then
           if(store_cop==1) then
              call choix_surv(n(gene-1,1),n(gene,1),all,all2,cop,cop2)
           else
              call choix_surv_noCop(n(gene-1,1),n(gene,1),all,all2)
           endif
        endif
        if(nbpop==2) then
           if(gene<=time2) then
              if(indic_2(gene)==1) then
                 if(store_cop==1) then
                    call choix_surv(n(gene-1,2),n(gene,2),allp2,all2,copp2,cop2)
                 else
                    call choix_surv_noCop(n(gene-1,2),n(gene,2),allp2,all2)
                 endif
              endif
              if(indic_in(gene)==1) then
                 parent=0
                 infus=infus+1
                 print*,'INFUS',introg(infus)
!!!! Admixed individuals
                 ! Choice of the parents within each population
                 i=nint(real(n(gene-1,2))*selection(gene,2,2)/2.) ! Number of males selected in the 2nd population
                 j=nint((n(gene-1,1)-nint(real(n(gene-1,1))/2))*selection(gene,2,1))! Number of females selected in the 1st population
                 ii=nint(real(n(gene-1,1))/2.)! Number of males in the 1st population
                 call mating_adm(introg(infus),i,j,n(gene,1),ii,parent)
!!! pure bred animals
                 k=nint(real(n(gene-1,1)*selection(gene-1,1,1)/2.)) ! Number of males selected in the 1st population
                 l=nint((n(gene-1,1)-nint(real(n(gene-1,1))/2))*selection(gene-1,1,2)) ! Number of females selected in the 1st population
                 m=nint(real(n(gene-1,1)/2.))
                 h=nint(real(n(gene,1))/2.)
                 nn=nint(real(introg(infus))/2)+1
                 call mating(h,nn,k,l,m,parent)
                 call mating_adm(introg(infus),i,j,n(gene,1),ii,parent)
                 nn=h+introg(infus)-nint(real(introg(infus))/2)+1
                 call mating(n(gene,1),nn,k,l,m,parent)
                 if(store_cop==1) then
                    call transm_adm(n(gene,1),introg(infus),h,nchrom,nloc,all2,all,parent,pos_loc,allp2,cop2,cop,copp2)
                    call mutat(1,n(gene,1),1,all,all2,cop2,cop) 
                 else
                    call transm_adm_noCop(n(gene,1),introg(infus),h,nchrom,nloc,all2,all,parent,pos_loc,allp2)
                    call mutat_noCop(1,n(gene,1),all,all2) 
                 endif

                 test2=.FALSE.
                 if(minval(selection(1:gene,:,:))/=1) test2=.TRUE.
                 if(minval(selection(1:gene,:,:))==1.and.gene==time) test2=.TRUE.
                 if(test2) then
                    if(minval(selection(1:gene-1,:,:))==1) then
                       ! None of both parental populations has any phenotype so far
                       print*,'P1 CREATION PHENO adm',gene
                       allocate(fqall(nmq+nqtl,maxval(nball(:,:))),fqall2(nmq+nqtl,maxval(nball(:,:))))
                       fqall=0
                       do k=1,nmq+nqtl
                          do l=1,2
                             do i=1,h-nn
                                j=all(k,i,l)
                                fqall(k,j)=fqall(k,j)+1
                             enddo
                             do i=1+h,n(gene,1)-2*nn
                                j=all(k,i,l)
                                fqall(k,j)=fqall(k,j)+1
                             enddo
                          enddo
                       enddo
                       fqall2=0
                       l=0
                       do k=1,nchrom
                          do j=1,nloc(k)
                             if(typ_loc(j,k)==1) then
                                l=l+1
                                if(pos_assoc(l,3)/=0) then
                                   if(pos_assoc(l,1)<pos_assoc(l,4)) then
                                      if(pos_assoc(l,6)==1) then
                                         do i=1,h-nn
                                            if(all(pos_assoc(l,1),i,1)==all(pos_assoc(l,1),i,2).and.all(pos_assoc(l,4),i,1)==&
                                                 all(pos_assoc(l,4),i,2)) then
                                               if (all(pos_assoc(l,1),i,1)==1.and.all(pos_assoc(l,4),i,1)==1) fqall2(l,1)=&
                                                    fqall2(l,1)+1 ! both locus homozygote for the same allele 
                                               if (all(pos_assoc(l,1),i,1)==2.and.all(pos_assoc(l,4),i,1)==2) fqall2(l,1)=&
                                                    fqall2(l,1)+1 ! both locus homozygote for the same allele
                                               if (all(pos_assoc(l,1),i,1)==1.and.all(pos_assoc(l,4),i,1)==2) fqall2(l,2)=&
                                                    fqall2(l,2)+1 ! both locus homozygote for different alleles
                                               if (all(pos_assoc(l,1),i,1)==2.and.all(pos_assoc(l,4),i,1)==1) fqall2(l,2)=&
                                                    fqall2(l,2)+1 ! both locus homozygote for different alleles
                                            endif
                                         enddo
                                         do i=h+1,n(gene-1,1)-2*nn
                                            if(all(pos_assoc(l,1),i,1)==all(pos_assoc(l,1),i,2).and.all(pos_assoc(l,4),i,1)==&
                                                 all(pos_assoc(l,4),i,2)) then
                                               if (all(pos_assoc(l,1),i,1)==1.and.all(pos_assoc(l,4),i,1)==1) fqall2(l,1)=&
                                                    fqall2(l,1)+1 ! both locus homozygote for the same allele 
                                               if (all(pos_assoc(l,1),i,1)==2.and.all(pos_assoc(l,4),i,1)==2) fqall2(l,1)=&
                                                    fqall2(l,1)+1 ! both locus homozygote for the same allele
                                               if (all(pos_assoc(l,1),i,1)==1.and.all(pos_assoc(l,4),i,1)==2) fqall2(l,2)=&
                                                    fqall2(l,2)+1 ! both locus homozygote for different alleles
                                               if (all(pos_assoc(l,1),i,1)==2.and.all(pos_assoc(l,4),i,1)==1) fqall2(l,2)=&
                                                    fqall2(l,2)+1 ! both locus homozygote for different alleles
                                            endif
                                         enddo
                                         fqall2(l,:)=fqall2(l,:)/(real(n(gene,1)-2*nn))
                                      else
                                         do i=1,h-nn
                                            test=.false.
                                            if(eff_QTL(l,all(pos_assoc(l,1),i,1))==maxval(eff_QTL(l,:))) test=.true.
                                            if(eff_QTL(l,all(pos_assoc(l,1),i,2))==maxval(eff_QTL(l,:))) test=.true.
                                            if (test) then
                                               if(all(pos_assoc(l,4),i,1)==1.and.all(pos_assoc(l,4),i,2)==1) fqall2(l,1)=&
                                                    fqall2(l,1)+1
                                               if(all(pos_assoc(l,4),i,1)==2.and.all(pos_assoc(l,4),i,2)==2) fqall2(l,2)=&
                                                    fqall2(l,2)+1
                                            endif
                                         enddo
                                         do i=h+1,n(gene,1)-2*nn
                                            test=.false.
                                            if(eff_QTL(l,all(pos_assoc(l,1),i,1))==maxval(eff_QTL(l,:))) test=.true.
                                            if(eff_QTL(l,all(pos_assoc(l,1),i,2))==maxval(eff_QTL(l,:))) test=.true.
                                            if (test) then
                                               if(all(pos_assoc(l,4),i,1)==1.and.all(pos_assoc(l,4),i,2)==1) fqall2(l,1)=&
                                                    fqall2(l,1)+1
                                               if(all(pos_assoc(l,4),i,1)==2.and.all(pos_assoc(l,4),i,2)==2) fqall2(l,2)=&
                                                    fqall2(l,2)+1
                                            endif
                                         enddo
                                         fqall2(l,:)=fqall2(l,:)/(real(n(gene,1)))
                                      endif
                                   endif
                                endif
                             endif
                          enddo
                       enddo
                       call create_pheno(gind,1,nqtl,eff_qtl,eff_dom,envir,polyg,n(gene,1),pos_assoc,perf,all,nmq,fqall,&
                            fqall2,nball,h2,ratio_polQTL,indic)
                       deallocate(fqall2,fqall)
                    else if(minval(selection(1:gene-1,1,:))/=1.and.minval(selection(1:gene-1,2,:))==1) then
                       gind(:,2)=0
                       call pheno_adm(parent,gind,n(gene,1),nqtl,polyg,sqrt(0.75*polyg),gani,introg(infus),envir,perf,all,eff_qtl,&
                            nrmat,nrmat2,pos_assoc,posqtl,eff_dom)
                    else if(minval(selection(1:gene-1,1,:))==1.and.minval(selection(1:gene-1,2,:))/=1) then
                       gind(:,1)=0
                       allocate(fqall(nmq+nqtl,maxval(nball(:,:))),fqall2(nmq+nqtl,maxval(nball(:,:))))
                       fqall=0
                       do k=1,nmq+nqtl
                          do l=1,2
                             do i=1,h-nn
                                j=all(k,i,l)
                                fqall(k,j)=fqall(k,j)+1
                             enddo
                             do i=1+h,n(gene,1)-2*nn
                                j=all(k,i,l)
                                fqall(k,j)=fqall(k,j)+1
                             enddo
                          enddo
                       enddo
                       fqall2=0
                       l=0
                       do k=1,nchrom
                          do j=1,nloc(k)
                             if(typ_loc(j,k)==1) then
                                l=l+1
                                if(pos_assoc(l,3)/=0) then
                                   if(pos_assoc(l,1)<pos_assoc(l,4)) then
                                      if(pos_assoc(l,6)==1) then
                                         do i=1,h-nn
                                            if(all(pos_assoc(l,1),i,1)==all(pos_assoc(l,1),i,2).and.all(pos_assoc(l,4),i,1)==&
                                                 all(pos_assoc(l,4),i,2)) then
                                               if (all(pos_assoc(l,1),i,1)==1.and.all(pos_assoc(l,4),i,1)==1) fqall2(l,1)=&
                                                    fqall2(l,1)+1 ! both locus homozygote for the same allele 
                                               if (all(pos_assoc(l,1),i,1)==2.and.all(pos_assoc(l,4),i,1)==2) fqall2(l,1)=&
                                                    fqall2(l,1)+1 ! both locus homozygote for the same allele
                                               if (all(pos_assoc(l,1),i,1)==1.and.all(pos_assoc(l,4),i,1)==2) fqall2(l,2)=&
                                                    fqall2(l,2)+1 ! both locus homozygote for different alleles
                                               if (all(pos_assoc(l,1),i,1)==2.and.all(pos_assoc(l,4),i,1)==1) fqall2(l,2)=&
                                                    fqall2(l,2)+1 ! both locus homozygote for different alleles
                                            endif
                                         enddo
                                         do i=h+1,n(gene-1,1)-2*nn
                                            if(all(pos_assoc(l,1),i,1)==all(pos_assoc(l,1),i,2).and.all(pos_assoc(l,4),i,1)==&
                                                 all(pos_assoc(l,4),i,2)) then
                                               if (all(pos_assoc(l,1),i,1)==1.and.all(pos_assoc(l,4),i,1)==1) fqall2(l,1)=&
                                                    fqall2(l,1)+1 ! both locus homozygote for the same allele 
                                               if (all(pos_assoc(l,1),i,1)==2.and.all(pos_assoc(l,4),i,1)==2) fqall2(l,1)=&
                                                    fqall2(l,1)+1 ! both locus homozygote for the same allele
                                               if (all(pos_assoc(l,1),i,1)==1.and.all(pos_assoc(l,4),i,1)==2) fqall2(l,2)=&
                                                    fqall2(l,2)+1 ! both locus homozygote for different alleles
                                               if (all(pos_assoc(l,1),i,1)==2.and.all(pos_assoc(l,4),i,1)==1) fqall2(l,2)=&
                                                    fqall2(l,2)+1 ! both locus homozygote for different alleles
                                            endif
                                         enddo
                                         fqall2(l,:)=fqall2(l,:)/(real(n(gene,1)-2*nn))
                                      else
                                         do i=1,h-nn
                                            test=.false.
                                            if(eff_QTL(l,all(pos_assoc(l,1),i,1))==maxval(eff_QTL(l,:))) test=.true.
                                            if(eff_QTL(l,all(pos_assoc(l,1),i,2))==maxval(eff_QTL(l,:))) test=.true.
                                            if (test) then
                                               if(all(pos_assoc(l,4),i,1)==1.and.all(pos_assoc(l,4),i,2)==1) fqall2(l,1)=&
                                                    fqall2(l,1)+1
                                               if(all(pos_assoc(l,4),i,1)==2.and.all(pos_assoc(l,4),i,2)==2) fqall2(l,2)=&
                                                    fqall2(l,2)+1
                                            endif
                                         enddo
                                         do i=h+1,n(gene,1)-2*nn
                                            test=.false.
                                            if(eff_QTL(l,all(pos_assoc(l,1),i,1))==maxval(eff_QTL(l,:))) test=.true.
                                            if(eff_QTL(l,all(pos_assoc(l,1),i,2))==maxval(eff_QTL(l,:))) test=.true.
                                            if (test) then
                                               if(all(pos_assoc(l,4),i,1)==1.and.all(pos_assoc(l,4),i,2)==1) fqall2(l,1)=&
                                                    fqall2(l,1)+1
                                               if(all(pos_assoc(l,4),i,1)==2.and.all(pos_assoc(l,4),i,2)==2) fqall2(l,2)=&
                                                    fqall2(l,2)+1
                                            endif
                                         enddo
                                         fqall2(l,:)=fqall2(l,:)/(real(n(gene,1)))
                                      endif
                                   endif
                                endif
                             endif
                          enddo
                       enddo
                       call create_pheno(gind,1,nqtl,eff_qtl,eff_dom,envir,polyg,n(gene,1),pos_assoc,perf,all,nmq,fqall,&
                            fqall2,nball,h2,ratio_polQTL,indic)
                       call pheno_adm(parent,gind,n(gene,1),nqtl,polyg,polyg2,gani,introg(infus),envir,perf,all,eff_qtl,&
                            nrmat,nrmat3,pos_assoc,posqtl,eff_dom)
                       deallocate(fqall, fqall2)
                    else if(minval(selection(1:gene-1,1,:))/=1.and.minval(selection(1:gene-1,2,:))/=1) then
!!$                    polyg3=(sum(gind(1:n(gene-1,1),1)**2)+sum(gind(1:n(gene-1,2),2)**2))/(real(n(gene-1,1)+n(gene-1,2)))-&
!!$                         (sum(gind(1:n(gene-1,1),1))+sum(gind(1:n(gene-1,2),2)))**2/(real(n(gene-1,1)+n(gene-1,2)))**2
                       call pheno_adm(parent,gind,n(gene,1),nqtl,polyg,polyg3,gani,introg(infus),envir,perf,all,eff_qtl,&
                            nrmat,nrmat3,pos_assoc,posqtl,eff_dom)
                    endif
                 endif
                 if(minval(selection(1:gene,1,:))/=1.) then 
                    allocate(perf_temp(n(gene,1)),rang(n(gene,1)))
                    perf_temp(1:nint(real(n(gene,1)/2)))=perf(1:nint(real(n(gene,1)/2)),1)
                    call search_best(perf_temp,nint(real(n(gene,1)/2)),rang,nint(real(n(gene,1)/2)))
                    perf_temp(1:nint(real(n(gene,1)/2)))=perf(1+nint(real(n(gene,1)/2)):n(gene,1),1)
                    call search_best(perf_temp,n(gene,1)-nint(real(n(gene,1)/2)),rang(1+nint(real(n(gene,1)/2)):n(gene,1)),&
                         n(gene,1)-nint(real(n(gene,1)/2)))
                    rang(1+nint(real(n(gene,1)/2)):n(gene,1))=rang(1+nint(real(n(gene,1)/2)):n(gene,1))+nint(real(n(gene,1)/2))
                    do i=1,n(gene,1)
                       perf(i,1)=perf_temp(rang(i))
                       all2(:,i,:)=all(:,rang(i),:)
                       if(store_cop==1) cop2(:,i,:)=cop(:,rang(i),:)
                       gani(i,nbpop+1)=gind(rang(i),1)
                    enddo
                    do i=1,n(gene,1)
                       all(:,i,:)=all2(:,i,:)
                       if(store_cop==1) cop(:,i,:)=cop2(:,i,:)
                       gind(i,1)=gani(i,nbpop+1)
                    enddo
                    all2=0
                    if(store_cop==1) cop2=0
                    deallocate(perf_temp)
                 endif

              else if(indic_in(gene)==0) then
                 print*,'NO INFUSION'
                 k=nint(real(n(gene-1,1)*selection(gene-1,1,1)/2.)) ! Number of males selected
                 l=nint((n(gene-1,1)-nint(real(n(gene-1,1))/2))*selection(gene-1,1,2)) ! Number of females selected
                 m=nint(real(n(gene-1,1)/2.))
                 call mating(n(gene,1),1,k,l,m,parent)
                 if(store_cop==1) then
                    call transm(n(gene,1),nchrom,nloc,all2,all,parent,pos_loc,cop2,cop)
                    call mutat(1,n(gene,1),1,all,all2,cop,cop2)
                 else
                    call transm_noCop(n(gene,1),nchrom,nloc,all2,all,parent,pos_loc)
                    call mutat_noCop(1,n(gene,1),all,all2) !,cop,cop2)
                 endif
                 test2=.FALSE.
                 if(minval(selection(1:gene,1,:))/=1) test2=.TRUE.
                 if(minval(selection(1:gene,1,:))==1.and.gene==time)  test2=.TRUE.
                 if(test2) then
                    if(minval(selection(1:gene-1,1,:))==1) then
                       print*,'CREATE PHENO P1'
                       if(polyg==-1) then
                          allocate(fqall(nmq+nqtl,maxval(nball(:,:))),fqall2(nmq+nqtl,maxval(nball(:,:))))
                          fqall=0; fqall2=0
                          call stat_freq_1(1,n(gene,1),all,nball,fqall)
                          l=0
                          do k=1,nchrom
                             do j=1,nloc(k)
                                if(typ_loc(j,k)==1) then
                                   l=l+1
                                   if(pos_assoc(l,3)/=0) then
                                      if(pos_assoc(l,1)<pos_assoc(l,4)) then
                                         if(pos_assoc(l,6)==1) then
                                            do i=1,n(gene,1)
                                               if(all(pos_assoc(l,1),i,1)==all(pos_assoc(l,1),i,2).and.all(pos_assoc(l,4),i,1)==&
                                                    all(pos_assoc(l,4),i,2)) then
                                                  if (all(pos_assoc(l,1),i,1)==1.and.all(pos_assoc(l,4),i,1)==1) fqall2(l,1)=&
                                                       fqall2(l,1)+1 ! both locus homozygote for the same allele 
                                                  if (all(pos_assoc(l,1),i,1)==2.and.all(pos_assoc(l,4),i,1)==2) fqall2(l,1)=&
                                                       fqall2(l,1)+1 ! both locus homozygote for the same allele
                                                  if (all(pos_assoc(l,1),i,1)==1.and.all(pos_assoc(l,4),i,1)==2) fqall2(l,2)=&
                                                       fqall2(l,2)+1 ! both locus homozygote for different alleles
                                                  if (all(pos_assoc(l,1),i,1)==2.and.all(pos_assoc(l,4),i,1)==1) fqall2(l,2)=&
                                                       fqall2(l,2)+1 ! both locus homozygote for different alleles
                                               endif
                                            enddo
                                            fqall2(l,:)=fqall2(l,:)/(real(n(gene,1)))
                                         else
                                            do i=1,n(gene,1)
                                               test=.false.
                                               if(eff_QTL(l,all(pos_assoc(l,1),i,1))==maxval(eff_QTL(l,:))) test=.true.
                                               if(eff_QTL(l,all(pos_assoc(l,1),i,2))==maxval(eff_QTL(l,:))) test=.true.
                                               if (test) then
                                                  if(all(pos_assoc(l,4),i,1)==1.and.all(pos_assoc(l,4),i,2)==1) fqall2(l,1)=&
                                                       fqall2(l,1)+1
                                                  if(all(pos_assoc(l,4),i,1)==2.and.all(pos_assoc(l,4),i,2)==2) fqall2(l,2)=&
                                                       fqall2(l,2)+1
                                               endif
                                            enddo
                                            fqall2(l,:)=fqall2(l,:)/(real(n(gene,1)))
                                         endif
                                      endif
                                   endif
                                endif
                             enddo
                          enddo
                          call create_pheno(gind,1,nqtl,eff_qtl,eff_dom,envir,polyg,n(gene,1),pos_assoc,perf,all,nmq,fqall,&
                               fqall2,nball,h2,ratio_polQTL,indic)
                          deallocate(fqall,fqall2)
                       else
                          call create_pheno_adm(gind,1,nqtl,eff_qtl,eff_dom,envir,polyg,n(gene,1),pos_assoc,perf,all)
                       endif
                    else 
                       call pheno(parent,gind,n(gene,1),1,polyg,gani,1,envir,perf,all,eff_qtl,nqtl,posqtl,pos_assoc,&
                            nrmat,eff_dom)
                    endif
                 endif
                 if(minval(selection(1:gene,1,:))/=1) then
!!$                 print*,n(gene,1)
                    allocate(perf_temp(n(gene,1)),rang(n(gene,1)))
                    perf_temp(1:nint(real(n(gene,1))/2))=perf(1:nint(real(n(gene,1))/2),1)
                    call search_best(perf_temp,nint(real(n(gene,1))/2),rang,nint(real(n(gene,1))/2))
                    perf_temp(1+nint(real(n(gene,1))/2):n(gene,1))=perf(1+nint(real(n(gene,1))/2):n(gene,1),1)
                    call search_best(perf_temp,n(gene,1)-nint(real(n(gene,1))/2),rang(1+nint(real(n(gene,1))/2):n(gene,1)),&
                         n(gene,1)-nint(real(n(gene,1))/2))
                    rang(1+nint(real(n(gene,1))/2):n(gene,1))=rang(1+nint(real(n(gene,1))/2):n(gene,1))+nint(real(n(gene,1))/2)
                    do i=1,n(gene,1)
                       perf(i,1)=perf_temp(rang(i))
                       all2(:,i,:)=all(:,rang(i),:)
                       if(store_cop==1) cop2(:,i,:)=cop(:,rang(i),:)
                       gani(i,nbpop+1)=gind(rang(i),1)
                    enddo
                    do i=1,n(gene,1)
                       all(:,i,:)=all2(:,i,:)
                       if(store_cop==1) cop(:,i,:)=cop2(:,i,:)
                       gind(i,1)=gani(i,nbpop+1)
                    enddo
                    all2=0
                    if(store_cop==1)  cop2=0
                    deallocate(perf_temp)
                 else
                    allocate(rang(n(gene,1)))
                    do i=1,n(gene,1)
                       rang(i)=i
                    enddo
                 endif
              endif

              print*,'POP 2'
              allocate(parent2(n(gene,2),2))
              k=nint(real(n(gene-1,2)*selection(gene-1,2,1)/2.)) ! Number of males selected
              l=nint((n(gene-1,2)-nint(real(n(gene-1,2))/2))*selection(gene-1,2,2)) ! Number of females selected
              m=nint(real(n(gene-1,2)/2.))
              call mating(n(gene,2),1,k,l,m,parent2)
              if(store_cop==1) then
                 call transm(n(gene,2),nchrom,nloc,all2,allp2,parent2,pos_loc,cop2,copp2)
                 call mutat(1,n(gene,2),1,allp2,all2,copp2,cop2)
              else
                 call transm_noCop(n(gene,2),nchrom,nloc,all2,allp2,parent2,pos_loc)
                 call mutat_noCop(1,n(gene,2),allp2,all2) !,copp2,cop2)
              endif

              test2=.FALSE.
              if(minval(selection(1:gene,2,:))/=1) test2=.TRUE.
              if(minval(selection(1:gene,2,:))==1.and.time==gene) test2=.TRUE.
              if(test2) then
                 if(minval(selection(1:gene-1,2,:))==1) then
                    print*,'CREATE PHENO P2',gene
                    allocate(fqall(nmq+nqtl,maxval(nball(:,:))),fqall2(nmq+nqtl,maxval(nball(:,:))))
                    fqall=0; fqall2=0
                    call stat_freq_1(1,n(gene,2),allp2,nball,fqall)
                    l=0
                    do k=1,nchrom
                       do j=1,nloc(k)
                          if(typ_loc(j,k)==1) then
                             l=l+1
                             if(pos_assoc(l,3)/=0) then
                                if(pos_assoc(l,1)<pos_assoc(l,4)) then
                                   if(pos_assoc(l,6)==1) then
                                      do i=1,n(gene,2)
                                         if(allp2(pos_assoc(l,1),i,1)==allp2(pos_assoc(l,1),i,2).and.allp2(pos_assoc(l,4),i,1)==&
                                              allp2(pos_assoc(l,4),i,2)) then
                                            if (allp2(pos_assoc(l,1),i,1)==1.and.allp2(pos_assoc(l,4),i,1)==1) fqall2(l,1)=&
                                                 fqall2(l,1)+1 ! both locus homozygote for the same allele 
                                            if (allp2(pos_assoc(l,1),i,1)==2.and.allp2(pos_assoc(l,4),i,1)==2) fqall2(l,1)=&
                                                 fqall2(l,1)+1 ! both locus homozygote for the same allele
                                            if (allp2(pos_assoc(l,1),i,1)==1.and.allp2(pos_assoc(l,4),i,1)==2) fqall2(l,2)=&
                                                 fqall2(l,2)+1 ! both locus homozygote for different alleles
                                            if (allp2(pos_assoc(l,1),i,1)==2.and.allp2(pos_assoc(l,4),i,1)==1) fqall2(l,2)=&
                                                 fqall2(l,2)+1 ! both locus homozygote for different alleles
                                         endif
                                      enddo
                                      fqall2(l,:)=fqall2(l,:)/(real(n(gene,2)))
                                   else
                                      do i=1,n(gene,2)
                                         test=.false.
                                         if(eff_QTL(l,allp2(pos_assoc(l,1),i,1))==maxval(eff_QTL(l,:))) test=.true.
                                         if(eff_QTL(l,allp2(pos_assoc(l,1),i,2))==maxval(eff_QTL(l,:))) test=.true.
                                         if (test) then
                                            if(allp2(pos_assoc(l,4),i,1)==1.and.allp2(pos_assoc(l,4),i,2)==1) fqall2(l,1)=&
                                                 fqall2(l,1)+1
                                            if(allp2(pos_assoc(l,4),i,1)==2.and.allp2(pos_assoc(l,4),i,2)==2) fqall2(l,2)=&
                                                 fqall2(l,2)+1
                                         endif
                                      enddo
                                      fqall2(l,:)=fqall2(l,:)/(real(n(gene,2)))
                                   endif
                                endif
                             endif
                          endif
                       enddo
                    enddo
                    call create_pheno(gind,2,nqtl,eff_qtl,eff_dom,envir2,polyg2,n(gene,2),pos_assoc,perf,allp2,nmq,fqall,&
                         fqall2,nball,h2,ratio_polQTL,indic)
                    deallocate(fqall,fqall2)
                 else 
                    call pheno(parent2,gind,n(gene,2),2,polyg2,gani,1,envir,perf,allp2,eff_qtl,nqtl,posqtl,&
                         pos_assoc,nrmat3,eff_dom)
                 endif
              endif

              if(maxval(indic_in(:))==0) then       
                 call nrm_2pop_sep(parent,parent2,n(gene,1),n(gene,2),n(gene-1,1),n(gene-1,2),nrmat,nrmat3)
              else
                 if(indic_in(gene)==1) then
                    call nrm_2pop_inf(parent,parent2,n(gene,1),n(gene,2),n(gene-1,1),n(gene-1,2),nrmat,nrmat2,nrmat3,introg(infus))
                 else
                    call nrm_2pop_inf(parent,parent2,n(gene,1),n(gene,2),n(gene-1,1),n(gene-1,2),nrmat,nrmat2,nrmat3,0)
                 endif
              endif

              allocate(rang2(n(gene,2)))
              if(minval(selection(1:gene,2,:))==1) then
                 do i=1,n(gene,2)
                    rang2(i)=i
                 enddo
              else
                 allocate(perf_temp(n(gene,2)))
                 perf_temp(1:nint(real(n(gene,2))/2))=perf(1:nint(real(n(gene,2))/2),2)
                 call search_best(perf_temp,nint(real(n(gene,2))/2),rang2,nint(real(n(gene,2))/2))
                 perf_temp(1:nint(real(n(gene,2))/2))=perf(1+nint(real(n(gene,2))/2):n(gene,2),2)
                 call search_best(perf_temp,nint(real(n(gene,2))/2),rang2(1+nint(real(n(gene,2))/2):n(gene,2)),&
                      nint(real(n(gene,2))/2))
                 rang2(1+nint(real(n(gene,2))/2):n(gene,2))=rang2(1+nint(real(n(gene,2))/2):n(gene,2))+&
                      nint(real(n(gene,2))/2)
!!$              print*,'RANG BIS',minval(selection(1:gene,2,:))
                 do i=1,n(gene,2)
                    perf(i,2)=perf_temp(rang2(i))
                    all2(:,i,:)=allp2(:,rang2(i),:)
                    if(store_cop==1) cop2(:,i,:)=copp2(:,rang2(i),:)
                    gani(i,nbpop+1)=gind(rang2(i),2)
                 enddo
                 do i=1,n(gene,2)
                    allp2(:,i,:)=all2(:,i,:)
                    if(store_cop==1) copp2(:,i,:)=cop2(:,i,:)
                    gind(i,2)=gani(i,nbpop+1)
                 enddo
                 deallocate(perf_temp)
              endif

              all2=0
              if(store_cop==1)  cop2=0
              if(minval(selection(1:gene,:,:))/=1) then
                 allocate(nrmat_f(n(gene,1),n(gene,1)))
                 do i=1,n(gene,1)
                    do j=1,n(gene,1)
                       nrmat_f(i,j)=nrmat(rang(i),rang(j))
                       nrmat_f(j,i)=nrmat(i,j)
                    enddo
                 enddo
                 nrmat(1:n(gene,1),1:n(gene,1))=nrmat_f(1:n(gene,1),1:n(gene,1))
                 deallocate(nrmat_f)
                 allocate(nrmat_f(n(gene,2),n(gene,2)))
                 do i=1,n(gene,2)
                    do j=1,n(gene,2)
                       nrmat_f(i,j)=nrmat3(rang2(i),rang2(j))
                       nrmat_f(j,i)=nrmat_f(i,j)
                    enddo
                 enddo
                 nrmat3(1:n(gene,2),1:n(gene,2))=nrmat_f(1:n(gene,2),1:n(gene,2))
                 deallocate(nrmat_f)
                 allocate(nrmat_f(n(gene,1),n(gene,2)))
                 do i=1,n(gene,1)
                    do j=1,n(gene,2)
                       nrmat_f(i,j)=nrmat2(rang(i),rang2(j))
                    enddo
                 enddo
                 nrmat2(1:n(gene,1),1:n(gene,2))=nrmat_f(1:n(gene,1),1:n(gene,2))
                 deallocate(nrmat_f)
              endif
              if(allocated(rang)) deallocate(rang)
              if(allocated(rang2)) deallocate(rang2)
              deallocate(parent2)

           else if (gene>time2) then
              k=nint(real(n(gene-1,1)*selection(gene-1,1,1)/2.)) ! Number of males selected
              l=nint((n(gene-1,1)-nint(real(n(gene-1,1))/2))*selection(gene-1,1,2)) ! Number of females selected
              m=nint(real(n(gene-1,1)/2.))
              call mating(n(gene,1),1,k,l,m,parent)
              if(store_cop==1) then
                 call transm(n(gene,1),nchrom,nloc,all2,all,parent,pos_loc,cop2,cop)
                 call mutat(1,n(gene,1),1,all,all2,cop,cop2)
              else
                 call transm_noCop(n(gene,1),nchrom,nloc,all2,all,parent,pos_loc)
                 call mutat_noCop(1,n(gene,1),all,all2) !,cop,cop2)
              endif
              if(minval(selection(1:gene,1,:))/=1) then
                 if(minval(selection(1:gene-1,1,:))==1) then
                    print*,'CREATION PHENO',gene
                    allocate(fqall(nmq+nqtl,maxval(nball(:,:))),fqall2(nmq+nqtl,maxval(nball(:,:))))
                    fqall=0; fqall2=0
                    call stat_freq_1(1,n(gene,1),all,nball,fqall)
                    l=0
                    do k=1,nchrom
                       do j=1,nloc(k)
                          if(typ_loc(j,k)==1) then
                             l=l+1
                             if(pos_assoc(l,3)/=0) then
                                if(pos_assoc(l,1)<pos_assoc(l,4)) then
                                   if(pos_assoc(l,6)==1) then
                                      do i=1,n(gene,1)
                                         if(all(pos_assoc(l,1),i,1)==all(pos_assoc(l,1),i,2).and.all(pos_assoc(l,4),i,1)==&
                                              all(pos_assoc(l,4),i,2)) then
                                            if (all(pos_assoc(l,1),i,1)==1.and.all(pos_assoc(l,4),i,1)==1) fqall2(l,1)=&
                                                 fqall2(l,1)+1 ! both locus homozygote for the same allele 
                                            if (all(pos_assoc(l,1),i,1)==2.and.all(pos_assoc(l,4),i,1)==2) fqall2(l,1)=&
                                                 fqall2(l,1)+1 ! both locus homozygote for the same allele
                                            if (all(pos_assoc(l,1),i,1)==1.and.all(pos_assoc(l,4),i,1)==2) fqall2(l,2)=&
                                                 fqall2(l,2)+1 ! both locus homozygote for different alleles
                                            if (all(pos_assoc(l,1),i,1)==2.and.all(pos_assoc(l,4),i,1)==1) fqall2(l,2)=&
                                                 fqall2(l,2)+1 ! both locus homozygote for different alleles
                                         endif
                                      enddo
                                      fqall2(l,:)=fqall2(l,:)/(real(n(gene,1)))
                                   else
                                      do i=1,n(gene,1)
                                         test=.false.
                                         if(eff_QTL(l,all(pos_assoc(l,1),i,1))==maxval(eff_QTL(l,:))) test=.true.
                                         if(eff_QTL(l,all(pos_assoc(l,1),i,2))==maxval(eff_QTL(l,:))) test=.true.
                                         if (test) then
                                            if(all(pos_assoc(l,4),i,1)==1.and.all(pos_assoc(l,4),i,2)==1) fqall2(l,1)=fqall2(l,1)+1
                                            if(all(pos_assoc(l,4),i,1)==2.and.all(pos_assoc(l,4),i,2)==2) fqall2(l,2)=fqall2(l,2)+1
                                         endif
                                      enddo
                                      fqall2(l,:)=fqall2(l,:)/(real(n(gene,1)))
                                   endif
                                endif
                             endif
                          endif
                       enddo
                    enddo
                    call create_pheno(gind,1,nqtl,eff_qtl,eff_dom,envir,polyg,n(gene,1),pos_assoc,perf,all,nmq,fqall,&
                         fqall2,nball,h2,ratio_polQTL,indic)
                    deallocate(fqall,fqall2)
                 else 
                    call pheno(parent,gind,n(gene,1),1,polyg,gani,1,envir,perf,all,eff_qtl,nqtl,posqtl,pos_assoc,&
                         nrmat,eff_dom)
                 endif
              endif
              if(minval(selection(1:gene,1,:))==1.and.gene==time) then
                 print*,'CREATION PHENO',gene
                 allocate(fqall(nmq+nqtl,maxval(nball(:,:))),fqall2(nmq+nqtl,maxval(nball(:,:))))
                 fqall=0; fqall2=0
                 call stat_freq_1(1,n(gene,1),all,nball,fqall)
                 l=0
                 do k=1,nchrom
                    do j=1,nloc(k)
                       if(typ_loc(j,k)==1) then
                          l=l+1
                          if(pos_assoc(l,3)/=0) then
                             if(pos_assoc(l,1)<pos_assoc(l,4)) then
                                if(pos_assoc(l,6)==1) then
                                   do i=1,n(gene,1)
                                      if(all(pos_assoc(l,1),i,1)==all(pos_assoc(l,1),i,2).and.all(pos_assoc(l,4),i,1)==&
                                           all(pos_assoc(l,4),i,2)) then
                                         if (all(pos_assoc(l,1),i,1)==1.and.all(pos_assoc(l,4),i,1)==1) fqall2(l,1)=&
                                              fqall2(l,1)+1 ! both locus homozygote for the same allele 
                                         if (all(pos_assoc(l,1),i,1)==2.and.all(pos_assoc(l,4),i,1)==2) fqall2(l,1)=&
                                              fqall2(l,1)+1 ! both locus homozygote for the same allele
                                         if (all(pos_assoc(l,1),i,1)==1.and.all(pos_assoc(l,4),i,1)==2) fqall2(l,2)=&
                                              fqall2(l,2)+1 ! both locus homozygote for different alleles
                                         if (all(pos_assoc(l,1),i,1)==2.and.all(pos_assoc(l,4),i,1)==1) fqall2(l,2)=&
                                              fqall2(l,2)+1 ! both locus homozygote for different alleles
                                      endif
                                   enddo
                                   fqall2(l,:)=fqall2(l,:)/(real(n(gene,1)))
                                else
                                   do i=1,n(gene,1)
                                      test=.false.
                                      if(eff_QTL(l,all(pos_assoc(l,1),i,1))==maxval(eff_QTL(l,:))) test=.true.
                                      if(eff_QTL(l,all(pos_assoc(l,1),i,2))==maxval(eff_QTL(l,:))) test=.true.
                                      if (test) then
                                         if(all(pos_assoc(l,4),i,1)==1.and.all(pos_assoc(l,4),i,2)==1) fqall2(l,1)=fqall2(l,1)+1
                                         if(all(pos_assoc(l,4),i,1)==2.and.all(pos_assoc(l,4),i,2)==2) fqall2(l,2)=fqall2(l,2)+1
                                      endif
                                   enddo
                                   fqall2(l,:)=fqall2(l,:)/(real(n(gene,1)))
                                endif
                             endif
                          endif
                       endif
                    enddo
                 enddo
                 call create_pheno(gind,1,nqtl,eff_qtl,eff_dom,envir,polyg,n(gene,1),pos_assoc,perf,all,nmq,fqall,&
                      fqall2,nball,h2,ratio_polQTL,indic)
                 deallocate(fqall,fqall2)
              endif

              if(minval(selection(1:gene,1,:))/=1) then
                 allocate(perf_temp(n(gene,1)),rang(n(gene,1)))
                 perf_temp(1:nint(real(n(gene,1))/2))=perf(1:nint(real(n(gene,1))/2),1)
                 call search_best(perf_temp,nint(real(n(gene,1))/2),rang,nint(real(n(gene,1))/2))
                 perf_temp(1:nint(real(n(gene,1))/2))=perf(1+nint(real(n(gene,1))/2):n(gene,1),1)
                 call search_best(perf_temp,nint(real(n(gene,1))/2),rang(1+nint(real(n(gene,1))/2):n(gene,1)),&
                      nint(real(n(gene,1))/2))
                 rang(1+nint(real(n(gene,1))/2):n(gene,1))=rang(1+nint(real(n(gene,1))/2):n(gene,1))+nint(real(n(gene,1))/2)
                 do i=1,n(gene,1)
                    perf(i,1)=perf_temp(rang(i))
                    all2(:,i,:)=all(:,rang(i),:)
                    if(store_cop==1) cop2(:,i,:)=cop(:,rang(i),:)
                    gani(i,nbpop+1)=gind(rang(i),1)
                 enddo
                 do i=1,n(gene,1)
                    all(:,i,:)=all2(:,i,:)
                    if(store_cop==1) cop(:,i,:)=cop(:,i,:)
                    gind(i,1)=gani(i,nbpop+1)
                 enddo
                 all2=0
                 if(store_cop==1)  cop2=0
                 deallocate(perf_temp)
                 allocate(nrmat_f(n(gene,1),n(gene,1)))
                 do i=1,n(gene,1)
                    do j=1,n(gene,1)
                       nrmat_f(i,j)=nrmat(rang(i),rang(j))
                       nrmat_f(j,i)=nrmat(i,j)
                    enddo
                 enddo
                 nrmat(1:n(gene,1),1:n(gene,1))=nrmat_f(1:n(gene,1),1:n(gene,1))
                 deallocate(nrmat_f,rang)
                 call nrm_1pop(parent,n(gene,1),n(gene-1,1),nrmat)
              endif
           endif

        else
           ! One simulated population
           k=nint(real(n(gene-1,1)*selection(gene-1,1,1)/2.)) ! Number of males selected
           l=nint((n(gene-1,1)-nint(real(n(gene-1,1))/2))*selection(gene-1,1,2)) ! Number of females selected
           m=nint(real(n(gene-1,1)/2.))
           call mating(n(gene,1),1,k,l,m,parent)
           if(store_cop==1) then
              call transm(n(gene,1),nchrom,nloc,all2,all,parent,pos_loc,cop2,cop)
              call mutat(1,n(gene,1),1,all,all2,cop,cop2)
           else
              call transm_noCop(n(gene,1),nchrom,nloc,all2,all,parent,pos_loc)
              call mutat_noCop(1,n(gene,1),all,all2) !,cop,cop2)
           endif

           if(minval(selection(1:gene,1,:))/=1) then
              if(minval(selection(1:gene-1,1,:))==1) then
                 print*,'CREATION PHENO',gene
                 allocate(fqall(nmq+nqtl,maxval(nball(:,:))),fqall2(nmq+nqtl,maxval(nball(:,:))))
                 fqall=0; fqall2=0
                 call stat_freq_1(1,n(gene,1),all,nball,fqall)
                 l=0
                 do k=1,nchrom
                    do j=1,nloc(k)
                       if(typ_loc(j,k)==1) then
                          l=l+1
                          if(pos_assoc(l,3)/=0) then
                             if(pos_assoc(l,1)<pos_assoc(l,4)) then
                                if(pos_assoc(l,6)==1) then
                                   do i=1,n(gene,1)
                                      if(all(pos_assoc(l,1),i,1)==all(pos_assoc(l,1),i,2).and.all(pos_assoc(l,4),i,1)==&
                                           all(pos_assoc(l,4),i,2)) then
                                         if (all(pos_assoc(l,1),i,1)==1.and.all(pos_assoc(l,4),i,1)==1) fqall2(l,1)=&
                                              fqall2(l,1)+1 ! both locus homozygote for the same allele 
                                         if (all(pos_assoc(l,1),i,1)==2.and.all(pos_assoc(l,4),i,1)==2) fqall2(l,1)=&
                                              fqall2(l,1)+1 ! both locus homozygote for the same allele
                                         if (all(pos_assoc(l,1),i,1)==1.and.all(pos_assoc(l,4),i,1)==2) fqall2(l,2)=&
                                              fqall2(l,2)+1 ! both locus homozygote for different alleles
                                         if (all(pos_assoc(l,1),i,1)==2.and.all(pos_assoc(l,4),i,1)==1) fqall2(l,2)=&
                                              fqall2(l,2)+1 ! both locus homozygote for different alleles
                                      endif
                                   enddo
                                   fqall2(l,:)=fqall2(l,:)/(real(n(gene,1)))
                                else
                                   do i=1,n(gene,1)
                                      test=.false.
                                      if(eff_QTL(l,all(pos_assoc(l,1),i,1))==maxval(eff_QTL(l,:))) test=.true.
                                      if(eff_QTL(l,all(pos_assoc(l,1),i,2))==maxval(eff_QTL(l,:))) test=.true.
                                      if (test) then
                                         if(all(pos_assoc(l,4),i,1)==1.and.all(pos_assoc(l,4),i,2)==1) fqall2(l,1)=&
                                              fqall2(l,1)+1
                                         if(all(pos_assoc(l,4),i,1)==2.and.all(pos_assoc(l,4),i,2)==2) fqall2(l,2)=&
                                              fqall2(l,2)+1
                                      endif
                                   enddo
                                   fqall2(l,:)=fqall2(l,:)/(real(n(gene,1)))
                                endif
                             endif
                          endif
                       endif
                    enddo
                 enddo
                 call create_pheno(gind,1,nqtl,eff_qtl,eff_dom,envir,polyg,n(gene,1),pos_assoc,perf,all,nmq,fqall,&
                      fqall2,nball,h2,ratio_polQTL,indic)
                 deallocate(fqall,fqall2)
              else 
                 call pheno(parent,gind,n(gene,1),1,polyg,gani,1,envir,perf,all,eff_qtl,nqtl,posqtl,pos_assoc,&
                      nrmat,eff_dom)
!!$        print*,'kkkkk'
              endif
           endif
           if(minval(selection(1:gene,1,:))==1.and.gene==time) then
              print*,'CREATION PHENO',gene
              allocate(fqall(nmq+nqtl,maxval(nball(:,:))),fqall2(nmq+nqtl,maxval(nball(:,:))))
              fqall=0; fqall2=0
              call stat_freq_1(1,n(gene,1),all,nball,fqall)
              l=0
              do k=1,nchrom
                 do j=1,nloc(k)
                    if(typ_loc(j,k)==1) then
                       l=l+1
                       if(pos_assoc(l,3)/=0) then
                          if(pos_assoc(l,1)<pos_assoc(l,4)) then
                             if(pos_assoc(l,6)==1) then
                                do i=1,n(gene,1)
                                   if(all(pos_assoc(l,1),i,1)==all(pos_assoc(l,1),i,2).and.all(pos_assoc(l,4),i,1)==&
                                        all(pos_assoc(l,4),i,2)) then
                                      if (all(pos_assoc(l,1),i,1)==1.and.all(pos_assoc(l,4),i,1)==1) fqall2(l,1)=&
                                           fqall2(l,1)+1 ! both locus homozygote for the same allele 
                                      if (all(pos_assoc(l,1),i,1)==2.and.all(pos_assoc(l,4),i,1)==2) fqall2(l,1)=&
                                           fqall2(l,1)+1 ! both locus homozygote for the same allele
                                      if (all(pos_assoc(l,1),i,1)==1.and.all(pos_assoc(l,4),i,1)==2) fqall2(l,2)=&
                                           fqall2(l,2)+1 ! both locus homozygote for different alleles
                                      if (all(pos_assoc(l,1),i,1)==2.and.all(pos_assoc(l,4),i,1)==1) fqall2(l,2)=&
                                           fqall2(l,2)+1 ! both locus homozygote for different alleles
                                   endif
                                enddo
                                fqall2(l,:)=fqall2(l,:)/(real(n(gene,1)))
                             else
                                do i=1,n(gene,1)
                                   test=.false.
                                   if(eff_QTL(l,all(pos_assoc(l,1),i,1))==maxval(eff_QTL(l,:))) test=.true.
                                   if(eff_QTL(l,all(pos_assoc(l,1),i,2))==maxval(eff_QTL(l,:))) test=.true.
                                   if (test) then
                                      if(all(pos_assoc(l,4),i,1)==1.and.all(pos_assoc(l,4),i,2)==1) fqall2(l,1)=&
                                           fqall2(l,1)+1
                                      if(all(pos_assoc(l,4),i,1)==2.and.all(pos_assoc(l,4),i,2)==2) fqall2(l,2)=&
                                           fqall2(l,2)+1
                                   endif
                                enddo
                                fqall2(l,:)=fqall2(l,:)/(real(n(gene,1)))
                             endif
                          endif
                       endif
                    endif
                 enddo
              enddo
              call create_pheno(gind,1,nqtl,eff_qtl,eff_dom,envir,polyg,n(gene,1),pos_assoc,perf,all,nmq,fqall,&
                   fqall2,nball,h2,ratio_polQTL,indic)
              deallocate(fqall,fqall2)
           endif
!!$        print*,'kkkkkk'
           if(minval(selection(1:gene,1,:))/=1) then
              allocate(perf_temp(n(gene,1)),rang(n(gene,1)))
              perf_temp(1:nint(real(n(gene,1))/2))=perf(1:nint(real(n(gene,1))/2),1)
              call search_best(perf_temp,nint(real(n(gene,1))/2),rang,nint(real(n(gene,1))/2))
              perf_temp(1:nint(real(n(gene,1))/2))=perf(1+nint(real(n(gene,1))/2):n(gene,1),1)
              call search_best(perf_temp,nint(real(n(gene,1))/2),rang(1+nint(real(n(gene,1))/2):n(gene,1)),&
                   nint(real(n(gene,1))/2))
              rang(1+nint(real(n(gene,1))/2):n(gene,1))=rang(1+nint(real(n(gene,1))/2):n(gene,1))+nint(real(n(gene,1))/2)
              do j=1,n(gene,1)
                 perf(j,1)=perf_temp(rang(j))
                 all2(:,j,:)=all(:,rang(j),:)
                 if(store_cop==1) cop2(:,j,:)=cop(:,rang(j),:)
                 gani(j,1)=gind(rang(j),1)
              enddo
              all=all2
              if(store_cop==1) cop=cop2
              gind=gani
              all2=0
              if(store_cop==1) cop2=0
              gani=0
              deallocate(perf_temp)
              allocate(nrmat_f(n(gene,1),n(gene,1)))
              do i=1,n(gene,1)
                 do j=1,n(gene,1)
                    nrmat_f(i,j)=nrmat(rang(i),rang(j))
                    nrmat_f(j,i)=nrmat(i,j)
                 enddo
              enddo
              nrmat(1:n(gene,1),1:n(gene,1))=nrmat_f(1:n(gene,1),1:n(gene,1))
              deallocate(nrmat_f,rang)
              call nrm_1pop(parent,n(gene,1),n(gene-1,1),nrmat)
           endif
        endif

        ! output files
        allocate(verif_print(10))
        verif_print=0
        if(outfiles/=0) then
           do j=1,10
              do k=1,max_gener_eval
                 if(gener_eval(j,k)==gene) verif_print(j)=1
              enddo
           enddo
        endif

        allocate(fqall(nmq+nqtl,maxval(nalmax(:))))
        fqall=0
        call stat_freq_1(1,n(gene,1),all,nball,fqall)

        zero=0
        if(verif_print(6)==1) then
!!$        print*,'IN'
           do l=1,nmq+nqtl
              do j=1,nball(l,1)
                 write(10,*)l,j,fqall(l,j),n(gene,1),gene
              enddo
           enddo
        endif

        if(store_cop==1) then
           if(verif_print(7)==1) then  !! Calcul de la fréquence de chaque copie après t1 générations
              if(nbpop==1) then
                 allocate(fqcop(nmq+nqtl,ncopmax(1)))
              else
                 allocate(fqcop(nmq+nqtl,ncopmax(1)+ncopmax(2)))
              endif
              fqcop=0
              call stat_freq_1(1,n(gene,1),cop,maxcop,fqcop)
              if(nbpop==1) then
                 allocate(cop_alef(nmq+nqtl,ncopmax(1)))
              else
                 allocate(cop_alef(nmq+nqtl,ncopmax(1)+ncopmax(2)))
              endif
              cop_alef=0
              do ii=1,n(gene,1)
                 do j=1,2
                    do k=1,nmq+nqtl
                       do l=1,nqtl
                          if(k==posqtl(l).and.all(k,ii,j)==alleff(l)) cop_alef(k,cop(k,ii,j))=cop_alef(k,cop(k,ii,j))+1 ! number of each copy corresponding to the favourable QTL allele
                       enddo
                    enddo
                 enddo
              enddo
              allocate(coprest(nmq+nqtl))
              coprest=0
              do ii=1,nmq+nqtl
                 do j=1,maxcop(ii,1)
                    if(fqcop(ii,j)/=0) coprest(ii)=coprest(ii)+1
                 enddo
              enddo
              do ii=1,nmq+nqtl
                 do j=1,maxcop(ii,1)
                    if(indic(ii)==1) then
                       if(fqcop(ii,j)>0.0001) write(19,'(3(i6,1x),f8.6,1x,i6,1x,i8,1x,i4)')ii,j,&
                            coprest(ii),fqcop(ii,j),cop_alef(ii,j),n(gene,1),gene
                    else
                       if(fqcop(ii,j)>0.0001) write(19,'(3(i6,1x),f8.6,1x,i6,1x,i8,1x,i4)')ii,j,&
                            coprest(ii),fqcop(ii,j),zero,n(gene,1),gene
                    endif
                 enddo
              enddo
              deallocate(fqcop,cop_alef,coprest)
           endif
        endif

        if(verif_print(5)==1) then
           if(.not.allocated(pic)) allocate(pic(nmq+nqtl))
           call eval_pic(1,nball,nmq+nqtl,pic)
           call nbhaplotypes(n(gene,1),all,indic,nmq,nqtl)
           prop_h=real(nb_h)/real(nb_h_init)
           prop_hc=real(nb_hc)/real(nb_hc_init)
           do i=1,nqtl+nmq
              write(13,'(i8,1x,3(i4,1x),f4.2,1x,i4,1x,f4.2,1x,i2,1x,f10.6)')n(gene,1),&
                   gene,i,nb_h,prop_h,nb_hc,prop_hc,indic(i),pic(i)
           enddo
        endif

        if(verif_print(1)==1.or.verif_print(10)==1) then
           call LD(lg_chrom,bin,nchrom,nball,nmq,nqtl,n(gene,1),all,fqall,verif_print,1,chr_loc,nloc,pos_loc,gene)
           print*,'F1'
        endif

        if(store_cop==1) then
           if(verif_print(2)==1.or.verif_print(3)==1) then !! Longueur des segments hérités des fondateurs
              allocate(seg_ibd(maxloc,nchrom,n(gene,1),2),deb(maxloc,nchrom,n(gene,1),2))
              allocate(fin(maxloc,nchrom,n(gene,1),2))
              allocate(seg_qtl(nqtl,n(gene,1),2),nb_seg(n(gene,1),2,nchrom))
              call long_seg(1,n(gene,1),nmq,nqtl,posqtl,cop,seg_ibd,deb,fin,seg_qtl,nb_seg,lg_chrom,chr_QTL,nchrom,dist)
              do ii=1,n(gene,1)
                 do j=1,2
                    if(verif_print(2)==1) then
                       do l=1,nchrom
                          do k=1,maxloc
                             if(seg_ibd(k,l,ii,j)>0) then
                                write(21,*)ii,j,k,seg_ibd(k,l,ii,j)
                             endif
                          enddo
                       enddo
                    endif
                    if(verif_print(3)==1) then
                       do k=1,nqtl
                          write(22,'(3(i4,1x),f12.7,1x,f6.4,1x,i6)')i,j,k,seg_qtl(k,i,j),&
                               fqall(posqtl(k),alleff(k)),gene
                       enddo
                    endif
                 enddo
              enddo
              deallocate(seg_qtl,seg_ibd)
              deallocate(nb_seg,deb,fin)
              print*,'F2'
           endif

           if(verif_print(4)==1) then  !! Consanguinité moyenne et variance à chaque locus
              allocate(consmoy(nmq+nqtl),varcons(nmq+nqtl))
              call consang(1,n(gene,1),nmq,nqtl,cop,consmoy,varcons)
              do j=1,nmq+nqtl
                 write(23,*)j,consmoy(j),varcons(j),n(gene,1),gene
              enddo
              print*,'F4'
           endif
        endif

        deallocate(verif_print)
        if(allocated(pic)) deallocate(pic)
        if(allocated(consmoy)) deallocate(consmoy,varcons)
        deallocate(fqall)

        if(gene==time) polyg=sqrt((sum(gind(:,1)**2)/real(n(gene,1)))-((sum(gind(:,1))/real(n(gene,1)))**2))
     enddo
     print*,'End of historical generations'

  else

     deallocate(n)
     if(old_ped(1)==1) then
        allocate(ped(indPed(1),6))
        call read_ped(indPed(1),ped,fic_ped(1))
     endif
     if(nbpop==2) then
        if(old_ped(2)==1) then
           allocate(ped2(indPed(2),6)) ! Fourth column is the generation number
           call read_ped(indPed(2),ped2,fic_ped(2))
        endif
     endif

  endif

  allocate(verif_print(10))
  verif_print=0
  if(f_dl=="y") verif_print(1)=1
  if(f_dlq=="y") verif_print(10)=1
  if(f_dl_sum=="y") verif_print(8)=1

  deallocate(all2,selection,parent)
  if(store_cop==1) deallocate(cop2)




  !********************************************************************************!
  !                        Generations with pedigree                               !
  !********************************************************************************!
  call G05CBF(rac2)
  ! File descripting the final population
  open(60,file='popfin')
  read(60,*)typ_pop
  read(60,*) out_nrm
  if(direct_fin==0) then
     if(nbpop==2) then
        anc1=n(time,1)
        anc2=n(time,2)
     else
        anc2=0
        anc1=n(time,1)
     endif
     deallocate(n)
  else if(typ_pop==1) then
     anc1=sum(ped(:,5))
  endif
  if(typ_pop==0.or.typ_pop==2) then
     read(60,*) time2
     if(nbpop==2) read(60,*) cross
     read(60,*) gene_ped, gene_typ, gene_perf
!!$     print*,'output',gene_ped, gene_typ, gene_perf
     if(gene_ped>time2+1) then
        print*,'ERROR: Too many generations with pedigree are wished'
        stop 1
     endif
     if(gene_typ>time2+1) then
        print*,'ERROR: Too many generations with genotypes are wished'
        stop 1
     endif
     if(gene_perf>time2+1) then
        print*,'ERROR: Too many generations with phenotypes are wished'
        stop 1
     endif
  endif
  if(typ_pop==0) then

     allocate(n(2,0:time2),sel(2,0:time2,1))

     if(direct_fin==0) then
        if(nbpop==2) then
           anc3=nint(real(anc2)/2.)
           anc4=anc2-anc3
           k=anc1
           anc1=nint(real(anc1)/2)
           anc2=k-anc1
!!$print*,'N',n(:,0),anc1,anc2
           read(60,*) orig
           if(orig==0) then ! Fn population
              if(cross==0) then
                 n(1,0)=anc1
                 n(2,0)=anc4
              else
                 n(1,0)=anc3
                 n(2,0)=anc2
              endif
           else
              ! Random mating
              n(1,0)=anc1+anc3
              n(2,0)=anc2+anc4
           endif
        else
           k=anc1
           anc1=nint(real(anc1)/2.)
           anc2=k-anc1
           n(1,0)=anc1
           n(2,0)=anc2
        endif
     else
        if(nbpop==2) then
           read(60,*) orig
           n=0
           if(orig==0) then
              if(cross==0) then
                 do i=1,size(ped,1)
                    if(ped(i,5)==1.and.ped(i,6)==2) n(2,0)=n(2,0)+1
                 enddo
                 do i=1,size(ped2,1)
                    if(ped2(i,5)==1.and.ped2(i,6)==1) n(1,0)=n(1,0)+1
                 enddo
              else
                 do i=1,size(ped,1)
                    if(ped(i,5)==1.and.ped(i,6)==1) n(1,0)=n(1,0)+1
                 enddo
                 do i=1,size(ped2,1)
                    if(ped2(i,5)==1.and.ped2(i,6)==2) n(2,0)=n(2,0)+1
                 enddo
              endif
           else
              do i=1,size(ped,1)
                 if(ped(i,5)==1) then
                    if(ped(i,6)==2) then
                       n(2,0)=n(2,0)+1
                    else
                       n(1,0)=n(1,0)+1
                    endif
                 endif
              enddo
              do i=1,size(ped2,1)
                 if(ped2(i,5)==1) then
                    if(ped2(i,6)==1) then
                       n(1,0)=n(1,0)+1
                    else
                       n(2,0)=n(2,0)+1
                    endif
                 endif
              enddo
           endif
        else
           n=0
           do i=1,size(ped,1)
              if(ped(i,5)==1) then
                 if(ped(i,6)==2) then
                    n(2,0)=n(2,0)+1
                 else
                    n(1,0)=n(1,0)+1
                 endif
              endif
           enddo
        endif
     endif

     allocate(mode_sel(0:time2,2)) ! one mode per population
     mode_sel=0
     read(60,*) sel(:,0,1), mode_sel(0,:)
     do i=1,time2
        read(60,*) n(:,i), sel(:,i,1), mode_sel(i,:) ! n(1,i)=number of males in generation i
     enddo
     ! Modes sel:
     ! -0: phenotypic sel
     ! -1: EBV with given accuracy --> 1 for TBV
     ! -2: GBLUP

     if(any(mode_sel(:,1)==1).or.any(mode_sel(:,2)==1)) then
        allocate(accur(0:time2,2))
        accur=0
        do i=0,time2
           if(mode_sel(i,1)==1.or.mode_sel(i,2)==1) read(60,*) accur(i,:) ! one accuracy per sex within each pop
        enddo
     endif

     ! Total size of the pedigree at the end
     allocate(tot_pop_fin(1))
     if(direct_fin==0) then
        tot_pop_fin(1)=sum(n)
     else
        if(nbpop==2) then
           tot_pop_fin(1)=sum(ped(:,5))+sum(ped2(:,5))+sum(n(:,1:time2))
        else
           tot_pop_fin(1)=sum(ped(:,5))+sum(n(:,1:time2))
        endif
     endif

     read(60,*) DamSire ! Attribution of the number of dams per sire
     k=0
     do i=0,time2
        k=max(k,n(1,i))
     enddo
     allocate(damPerSire(k,time2,1))
     damPerSire=0
     if(DamSire==0) then ! All parameters concerning the number of dams per sire are provided by the user
        read(60,*) evenly, constant
        if(constant==0) then ! The number of dams per sire is kept constant over the generations
           if(evenly==0) then ! All sires have the same number of dams
              read(60,*) damPerSire(1,1,1)
              do i=2,time2
                 damPerSire(1,i,1)=damPerSire(1,1,1)
              enddo
           else
              nt=nint(n(1,0)*sel(1,0,1))
              read(60,*) damPerSire(1:nt,1,1)
              do i=2,time2
                 damPerSire(:,i,1)=damPerSire(:,1,1)
              enddo
           endif
        else
           do i=1,time2
              if(evenly==0) then
                 read(60,*) damPerSire(1,i,1)
              else
                 nt=nint(n(1,i)*sel(1,i,1))
                 read(60,*) damPerSire(1:nt,i,1)
              endif
           enddo
        endif
     endif

     read(60,*) OffSire
!!$     print*,OffSire,uniformity, constant2
     allocate(offspPerSire(maxval(n(1,:)),time2,1))
     offspPerSire=0
     if(OffSire==0) then ! All parameters concerning the number of offsrping per sire are provided by the user
        read(60,*) uniformity, constant2
        if(constant2==0) then ! The number of offsp. per sire is kept constant over the generations
           if(uniformity==0) then ! All sires have the same number of offspring
              read(60,*) offspPerSire(1,1,1)
              do i=2,time2
                 offspPerSire(1,i,1)=offspPerSire(1,1,1)
              enddo
           else
              nt=nint(n(1,0)*sel(1,0,1))
              read(60,*) offspPerSire(1:nt,1,1)
              do i=2,time2
                 offspPerSire(:,i,1)=offspPerSire(:,1,1)
              enddo
           endif
        else
           do i=1,time2
              if(uniformity==0) then
                 read(60,*) offspPerSire(1,i,1)
              else
                 nt=nint(n(1,i)*sel(1,i,1))
                 read(60,*) offspPerSire(1:nt,i,1)
              endif
           enddo
        endif
        read(60,*) constant3 ! the number of offspring per dam is constant within a sire
     endif

  else if(typ_pop==2) then
     call G05CBF(rac2)
     ! repetitive introgression of the second population in the first one (also BC)

     anc3=nint(real(anc2)/2.)
     anc4=anc2-anc3
     k=anc1
     anc1=nint(real(anc1)/2)
     anc2=k-anc1
     allocate(n(4,0:time2),sel(5,0:time2,1))
     n=0
     if(direct_fin==0) then
        n(1,0)=anc1
        n(2,0)=anc2
        n(3,0)=anc3
        n(4,0)=anc4
     else
        if(cross==0) then
           do i=1,size(ped,1)
              if(ped(i,5)==1) then
                 if(ped(i,6)==2) then
                    n(2,0)=n(2,0)+1
                 else
                    n(1,0)=n(1,0)+1
                 endif
              endif
           enddo
           do i=1,size(ped2,1)
              if(ped2(i,5)==1) then
                 if(ped2(i,6)==1) then
                    n(3,0)=n(3,0)+1
                 else
                    n(4,0)=n(4,0)+1
                 endif
              endif
           enddo
        else
           do i=1,size(ped,1)
              if(ped(i,5)==1) then
                 if(ped(i,6)==2) then
                    n(4,0)=n(4,0)+1
                 else
                    n(3,0)=n(3,0)+1
                 endif
              endif
           enddo
           do i=1,size(ped2,1)
              if(ped2(i,5)==1) then
                 if(ped2(i,6)==1) then
                    n(2,0)=n(2,0)+1
                 else
                    n(1,0)=n(1,0)+1
                 endif
              endif
           enddo
        endif
     endif

     allocate(mode_sel(0:time2,4)) ! one mode per sex
     read(60,*) sel(:,0,1), mode_sel(0,:)
     do i=1,time2
        read(60,*) n(:,i), sel(:,i,1), mode_sel(i,:)  ! n(1,i)=number of males in generation i
     enddo
     ! Modes sel:
     ! -0: phenotypic sel
     ! -1: EBV with given accuracy --> 1 for TBV

     if(any(mode_sel(:,:)==1)) then
        allocate(accur(0:time2,4))
        do i=0,time2
           if(any(mode_sel(i,:)==1)) read(60,*) accur(i,:) ! one accuracy per sex within each pop
        enddo
     endif

     ! Total size of the pedigree at the end
     allocate(tot_pop_fin(2))
     if(direct_fin==0) then
        tot_pop_fin(1)=sum(n(1:2,:))
        tot_pop_fin(2)=sum(n(3:4,:))
     else
        tot_pop_fin(1)=n1(0)+sum(n(1:2,:))
        tot_pop_fin(2)=n2(0)+sum(n(3:4,:))
     endif

     read(60,*) nb_introg
     allocate(geneIntrog(nb_introg),indIntrog(time2))
     indIntrog=0
     do i=1,nb_introg
        read(60,*) geneIntrog(i), indIntrog(geneIntrog(i))
     enddo

     read(60,*) DamSire ! Attribution of the number of dams per sire
     k=0
     do i=0,time2
        k=max(k,maxval(n(1,:))+maxval(n(3,:)))
     enddo
     allocate(damPerSire(k,time2,2))
     damPerSire=0
     if(DamSire==0) then ! All parameters concerning the number of dams per sire are provided by the user
        read(60,*) evenly, constant
        if(constant==0) then ! The number of dams per sire is kept constant over the generations
           if(evenly==0) then ! All sires have the same number of dams
              read(60,*) damPerSire(1,1,1),damPerSire(1,1,2)
!!$              print*,'S', damPerSire(1,1,1),damPerSire(1,1,2)
              do i=2,time2
                 damPerSire(1,i,1)=damPerSire(1,1,1)
                 damPerSire(1,i,2)=damPerSire(1,1,2)
              enddo
           else
              read(60,*) damPerSire(:,1,1),damPerSire(:,1,2)
              do i=2,time2
                 damPerSire(:,i,1)=damPerSire(:,1,1)
                 damPerSire(:,i,2)=damPerSire(:,1,2)
              enddo
           endif
        else
           do i=1,time2
              if(evenly==0) then
                 read(60,*) damPerSire(1,i,1),damPerSire(1,i,2)
              else
                 read(60,*) damPerSire(:,i,1),damPerSire(:,i,2)
              endif
           enddo
        endif
     endif

     read(60,*) OffSire
     k=0
     do i=0,time2
        k=max(k,n(1,i)+n(3,i))
     enddo
     allocate(offspPerSire(k,time2,2))
     offspPerSire=0
     if(OffSire==0) then ! All parameters concerning the number of offsrping per sire are provided by the user
        read(60,*) uniformity, constant2
        if(constant2==0) then ! The number of offsp. per sire is kept constant over the generations
           if(uniformity==0) then ! All sires have the same number of offspring
              read(60,*) offspPerSire(1,1,1),offspPerSire(1,1,2)
              do i=2,time2
                 offspPerSire(1,i,1)=offspPerSire(1,1,1)
                 offspPerSire(1,i,2)=offspPerSire(1,1,2)
              enddo
           else
              read(60,*) offspPerSire(:,1,1),offspPerSire(:,1,2)
              do i=2,time2
                 offspPerSire(:,i,1)=offspPerSire(:,1,1)
                 offspPerSire(:,i,2)=offspPerSire(:,1,2)
              enddo
           endif
        else
           do i=1,time2
              if(uniformity==0) then
                 read(60,*) offspPerSire(1,i,1),offspPerSire(1,i,2)
              else
                 read(60,*) offspPerSire(:,i,1),offspPerSire(:,i,2)
              endif
           enddo
        endif
        read(60,*) constant3 ! the number of offspring per dam is constant within a sire
     endif

  else if(typ_pop==1) then
     read(60,*)ngpm
     read(60,*)nt
     read(60,*)nf
     allocate(selection(1,1,2))
     read(60,*)selection(1,1,:)
     if(minval(selection(1,1,:))/=1.) then
        allocate(mode_sel(1,2))
        read(60,*) mode_sel(1,:)
        ! 0--> phenotypic
        ! 1 --> given accuracy
        if(mode_sel(1,1)==1.or.mode_sel(1,2)==1) then
           allocate(accur(1,2))
           read(60,*) accur(1,:)
        endif
     endif
     ! Total size of the pedigree at the end
     allocate(tot_pop_fin(1))
     if(direct_fin==0) then
        tot_pop_fin(1)=nt*(2*nf+1)+anc1
     else
        tot_pop_fin(1)=size(ped,1)+nt*(2*nf+1)
     endif


  else if(typ_pop==4) then

     read(60,*)pedig
     if(pedig==1) then   ! => on produit de familles
        read(60,*)lect      
        if(lect==1.or.lect==2)then  ! si lect==1 => on prend males du popuation simulée avec 1° partie (LDSO tout court) et females parmis les individus d'un certain pedigrée donnée 
           ntotanc1=anc1
           read(60,*)datafile8
           read(60,*)datafile9
           read(60,*)datafile10
           read(60,*)datafile11
           file8=trim(datafile8)
           file9=trim(datafile9)
           file10=trim(datafile10)
           file11=trim(datafile11)
           read(60,*)ntotped1
           read(60,*)nbport
           if(nbport==1) then  ! chaque couple male-female aurait 1 seul descendant (cet à dire, sont HSibs)
              read(60,*)nt_hs,nfmin_hs,nfmax_hs
              read(60,*)ndmin_hs,ndmax_hs
           else if(nbport==2) then! une female aurait plusieurs descendants avec nt_hf2 males (FS entre famillies)
              read(60,*)nt_hf2,nfmin_hf2,nfmax_hf2
              read(60,*)ndmin_hf2, ndmax_hf2       
           endif

        else if(lect==3)then  ! take males and females from the real pedigree
           read(60,*)datafile8
           read(60,*)datafile9
           read(60,*)datafile10
           read(60,*)datafile11
           file8=trim(datafile8)
           file9=trim(datafile9)
           file10=trim(datafile10)
           file11=trim(datafile11)
           read(60,*)ntotped1
           read(60,*)nbport
           if(nbport==1) then  ! each female is only mated to one male (FS)
              read(60,*)nt_hs,nfmin_hs,nfmax_hs
              read(60,*)ndmin_hs,ndmax_hs
              if(ndMiN_hs==1.AND.ndmax_hs==1)then
              else if(ndMiN_hs/=1.AND.ndmax_hs/=1)then
              endif
           else if(nbport==2) then ! each female can be mated to several males (HS) 
              read(60,*)nt_hf2,nfmin_hf2,nfmax_hf2
              read(60,*)ndmin_hf2,ndmax_hf2       
           endif

        else if(lect==4)then  ! take males and females from the last simulated generation 
           ntotanc1=anc1
           read(60,*)nbport
           IF(nbport==1)THEN  ! each female is only mated to one male (FS)
              read(60,*)nt_hs,nfmin_hs,nfmax_hs
              read(60,*)ndmin_hs,ndmax_hs
              if(ndMiN_hs==1.AND.ndmax_hs==1)then
              else if(ndMiN_hs/=1.AND.ndmax_hs/=1)then
              endif
           ELSE IF(nbport==2)THEN ! each female can be mated to several males (HS) 
              read(60,*)nt_hf2,nfmin_hf2,nfmax_hf2
              read(60,*)ndmin_hf2,ndmax_hf2       
           ENDIF
        endif

     ELSE IF(pedig==2)THEN   ! on augmente la taille de familles de pedigree
        read(60,*)lect
        if(lect==1)then     ! females chosen out of the last historical generation 
           read(60,*)nsires
           read(60,*)datafile8
           read(60,*)datafile9
           read(60,*)datafile10
           read(60,*)datafile11
           file8=trim(datafile8)
           file9=trim(datafile9)
           file10=trim(datafile10)
           file11=trim(datafile11)
           read(60,*)ntotanc1 ! ? ntotped1?
           read(60,*)nbport
           IF(nbport==1)THEN  ! each female is only mated to one male (FS)
              read(60,*)nt_hs,nfmin_hs,nfmax_hs
              read(60,*)ndmin_hs,ndmax_hs
              if(ndMiN_hs==1.AND.ndmax_hs==1)then
              else if(ndMiN_hs/=1.AND.ndmax_hs/=1)then
              endif
           ELSE IF(nbport==2)THEN ! each female can be mated to several males (HS) 
              read(60,*)nt_hf2,nfmin_hf2,nfmax_hf2
              read(60,*)ndmin_hf2,ndmax_hf2       
           ENDIF
!!$print*,ntotanc1,nbport

        else if(lect==2)then ! select the females that will be mated to males from the real pedigree
           read(60,*)nsires
           read(60,*)datafile8
           read(60,*)datafile9
           read(60,*)datafile10
           read(60,*)datafile11
           file8=trim(datafile8)
           file9=trim(datafile9)
           file10=trim(datafile10)
           file11=trim(datafile11)
           read(60,*)ntotped1
           read(60,*)nbport
           IF(nbport==1)THEN  ! each female is only mated to one male (FS)
              read(60,*)nt_hs,nfmin_hs,nfmax_hs
              read(60,*)ndmin_hs,ndmax_hs
              if(ndMiN_hs==1.AND.ndmax_hs==1)then
              else if(ndMiN_hs/=1.AND.ndmax_hs/=1)then
              endif
           ELSE IF(nbport==2)THEN ! each female can be mated to several males (HS)
              read(60,*)nt_hf2,nfmin_hf2,nfmax_hf2
              read(60,*)ndmin_hf2,ndmax_hf2       
           ENDIF
        endif
     endif

  endif

  close(60)
  print*,'POPFIN READ'

  last_gen=0

  if(direct_fin==1) then

     if(lect_nrm(1)==0) then
        if(allocated(nrmat)) deallocate(nrmat)
        if(allocated(nrmat2)) deallocate(nrmat2)
        if(allocated(nrmat3)) deallocate(nrmat3)
     endif

     if(.not.allocated(pos_assoc)) then
        allocate(pos_assoc(nqtl,7))
        pos_assoc=0
     endif
     allocate(fqall(nmq+nqtl,maxval(nball(:,1))),fqall2(nmq+nqtl,maxval(nball(:,:))))
     call stat_freq_1(1,n1(0),all,nball,fqall)
     l=0
     do k=1,nchrom
        do j=1,nloc(k)
           if(typ_loc(j,k)==1) then
              l=l+1
              if(pos_assoc(l,3)/=0) then
                 if(pos_assoc(l,1)<pos_assoc(l,4)) then
                    if(pos_assoc(l,6)==1) then
                       do i=1,n1(0)
                          if(all(pos_assoc(l,1),i,1)==all(pos_assoc(l,1),i,2).and.all(pos_assoc(l,4),i,1)==&
                               all(pos_assoc(l,4),i,2)) then
                             if (all(pos_assoc(l,1),i,1)==1.and.all(pos_assoc(l,4),i,1)==1) fqall2(l,1)=&
                                  fqall2(l,1)+1 ! both locus homozygote for the same allele 
                             if (all(pos_assoc(l,1),i,1)==2.and.all(pos_assoc(l,4),i,1)==2) fqall2(l,1)=&
                                  fqall2(l,1)+1 ! both locus homozygote for the same allele
                             if (all(pos_assoc(l,1),i,1)==1.and.all(pos_assoc(l,4),i,1)==2) fqall2(l,2)=&
                                  fqall2(l,2)+1 ! both locus homozygote for different alleles
                             if (all(pos_assoc(l,1),i,1)==2.and.all(pos_assoc(l,4),i,1)==1) fqall2(l,2)=&
                                  fqall2(l,2)+1 ! both locus homozygote for different alleles
                          endif
                       enddo
                       fqall2(l,:)=fqall2(l,:)/(real(n1(0)))
                    else
                       do i=1,n1(0)
                          test=.false.
                          if(eff_QTL(l,all(pos_assoc(l,1),i,1))==maxval(eff_QTL(l,:))) test=.true.
                          if(eff_QTL(l,all(pos_assoc(l,1),i,2))==maxval(eff_QTL(l,:))) test=.true.
                          if (test) then
                             if(all(pos_assoc(l,4),i,1)==1.and.all(pos_assoc(l,4),i,2)==1) fqall2(l,1)=fqall2(l,1)+1
                             if(all(pos_assoc(l,4),i,1)==2.and.all(pos_assoc(l,4),i,2)==2) fqall2(l,2)=fqall2(l,2)+1
                          endif
                       enddo
                       fqall2(l,:)=fqall2(l,:)/(real(n1(0)))
                    endif
                 endif
              endif
           endif
        enddo
     enddo
     call variances(1,nqtl,eff_qtl,eff_dom,envir,polyg,pos_assoc,all,nmq,fqall,fqall2,nball,h2,ratio_polQTL,indic)

     if(nbpop==2) then
        call stat_freq_1(1,n2(0),allp2,nball,fqall)
        l=0
        do k=1,nchrom
           do j=1,nloc(k)
              if(typ_loc(j,k)==1) then
                 l=l+1
                 if(pos_assoc(l,3)/=0) then
                    if(pos_assoc(l,1)<pos_assoc(l,4)) then
                       if(pos_assoc(l,6)==1) then
                          do i=1,n2(0)
                             if(all(pos_assoc(l,1),i,1)==all(pos_assoc(l,1),i,2).and.all(pos_assoc(l,4),i,1)==&
                                  all(pos_assoc(l,4),i,2)) then
                                if (all(pos_assoc(l,1),i,1)==1.and.all(pos_assoc(l,4),i,1)==1) fqall2(l,1)=&
                                     fqall2(l,1)+1 ! both locus homozygote for the same allele 
                                if (all(pos_assoc(l,1),i,1)==2.and.all(pos_assoc(l,4),i,1)==2) fqall2(l,1)=&
                                     fqall2(l,1)+1 ! both locus homozygote for the same allele
                                if (all(pos_assoc(l,1),i,1)==1.and.all(pos_assoc(l,4),i,1)==2) fqall2(l,2)=&
                                     fqall2(l,2)+1 ! both locus homozygote for different alleles
                                if (all(pos_assoc(l,1),i,1)==2.and.all(pos_assoc(l,4),i,1)==1) fqall2(l,2)=&
                                     fqall2(l,2)+1 ! both locus homozygote for different alleles
                             endif
                          enddo
                          fqall2(l,:)=fqall2(l,:)/(real(n2(0)))
                       else
                          do i=1,n2(0)
                             test=.false.
                             if(eff_QTL(l,all(pos_assoc(l,1),i,1))==maxval(eff_QTL(l,:))) test=.true.
                             if(eff_QTL(l,all(pos_assoc(l,1),i,2))==maxval(eff_QTL(l,:))) test=.true.
                             if (test) then
                                if(all(pos_assoc(l,4),i,1)==1.and.all(pos_assoc(l,4),i,2)==1) fqall2(l,1)=fqall2(l,1)+1
                                if(all(pos_assoc(l,4),i,1)==2.and.all(pos_assoc(l,4),i,2)==2) fqall2(l,2)=fqall2(l,2)+1
                             endif
                          enddo
                          fqall2(l,:)=fqall2(l,:)/(real(n2(0)))
                       endif
                    endif
                 endif
              endif
           enddo
        enddo
        call variances(2,nqtl,eff_qtl,eff_dom,envir2,polyg2,pos_assoc,all,nmq,fqall,fqall2,nball,h2,ratio_polQTL,indic)
     endif
     deallocate(fqall,fqall2)

     n1(0)=indPed(1)
     if(nbpop==2) n2(0)=indPed(2)
     ! Distinguish the structure of the nrm depending on the kind of final population wished
     if(nbpop==2) then

        if(typ_pop==0.and.orig==1) then ! Random admixture

           tail=n1(0)+n2(0)
           allocate(ped3(tail,7))
           ped3(1:n1(0),1:3)=ped(1:n1(0),1:3)
           ped3(1:n1(0),5:7)=ped(1:n1(0),4:6)
           anc1=0; anc2=0; anc3=0; anc4=0
           do i=1,n1(0)
              if(ped(i,5)==1) then
                 if(ped(i,6)==1) anc1=anc1+1 ! Number of males in the 1st population
                 if(ped(i,6)==2) anc2=anc2+1 ! Number of females in the 1st population
              endif
           enddo
           deallocate(ped)
           ped3(1+n1(0):n1(0)+n2(0),1:3)=ped2(1:n2(0),1:3)
           ped3(1+n1(0):n1(0)+n2(0),5:7)=ped2(1:n2(0),4:6)
           do i=1,n2(0)
              if(ped2(i,5)==1) then
                 if(ped2(i,6)==1) anc3=anc3+1 ! Number of males in the 2nd population
                 if(ped2(i,6)==2) anc4=anc4+1 ! Number of females in the 2nd population
              endif
           enddo
           deallocate(ped2)
           allocate(ped(tail,6))
           ! In the next steps, individuals common to both populations are made unique
           j=0
           allocate(verif(tail))
           verif=0
           do i=1,tail
              m=100000
              if(ped3(i,2)==0.and.ped3(i,3)==0) then
                 do k=1,i-1
                    if(ped3(i,1)==ped3(k,1)) then
                       verif(i)=1
                       l=min(ped3(i,5),ped3(k,5))
                       m=min(m,k)
                    endif
                 enddo
                 if(verif(i)==0) then
                    ! Looking for all unique founders and put them in the complete pedigree
                    j=j+1
                    ped(j,1:3)=ped3(i,1:3) 
                    ped(j,4:6)=ped3(i,5:7) 
                 else
                    ped3(m,5)=l
                 endif
                 ped3(i,4)=999
              endif
           enddo
           l=minval(ped3(:,4))
           do i=1,tail
              if(ped3(i,4)==999) ped3(i,4)=-1
           enddo
           k=maxval(ped3(:,4))
           do ii=1,tail
              iv=100000
              if(ped3(ii,4)/=-1) then
                 do m=1,ii-1
                    if(ped3(ii,1)==ped3(m,1)) then
                       verif(ii)=1
                       l=min(ped3(ii,5),ped3(m,5))
                       iv=min(iv,m)
                    endif
                 enddo
                 if(verif(ii)==0) then
                    j=j+1
                    ped(j,1:3)=ped3(ii,1:3) ! non-founder individuals
                    ped(j,4:6)=ped3(ii,5:7)
                 else
                    ped(iv,4)=l
                 endif
              endif
           enddo
           deallocate(ped3,verif)
           ! Sort the individuals by generation
           allocate(rang(size(ped,1)))
           call search_best(dble(ped(:,4)),size(ped,1),rang,size(ped,1))
           allocate(ped3(size(ped,1),size(ped,2)))
           do i=1,size(ped,1)
              ped3(i,:)=ped(rang(i),:)
           enddo
           ped=ped3
           deallocate(ped3)

           allocate(ped_p1(tot_pop_fin(1),3))
           ped_p1=0
           allocate(remain(sum(ped(:,5))+sum(n),2))
           j=0; k=0; l=0
           do i=1,size(ped,1)
              if(ped(i,5)==1) then
                 j=j+1
                 remain(j,1)=ped(i,1)
                 remain(j,2)=ped(i,6)
                 ped_p1(j,:)=ped(i,1:3)
                 if(ped(i,6)==1) k=k+1
                 if(ped(i,6)==2) l=l+1
              endif
           enddo
           last_gen=maxval(ped(:,4))
           n(1,0)=k
           n(2,0)=l

           if(lect_nrm(1)==0) then

              ! Recode the pedigree to compute the nrm
              allocate(corres(size(ped,1),4))
              call recode(size(ped,1),ped,corres)
              deallocate(ped)
              allocate(corresp(size(ped,1),3))
              corresp(:,1)=corres(:,1)
              corresp(:,2:3)=corres(:,3:4)
              deallocate(corres)

              if(allocated(nrmat_fin)) deallocate(nrmat_fin)
              allocate(nrmat_fin(tail,tail))
              nrmat_fin=0
              ! tabular method on the pedigree(s)
              j=0
              do i=1,tail
                 if(corresp(i,2)==0.and.corresp(i,3)==0) then
                    nrmat_fin(i,i)=1
                    j=j+1
                 endif
              enddo
              do i=1,j
                 do k=j+1,tail
                    if(ped(k,2)==0) then
                       nrmat_fin(i,k)=0.5*nrmat_fin(i,corresp(k,3))
                    else if (ped(k,3)==0) then
                       nrmat_fin(i,k)=0.5*nrmat_fin(i,corresp(k,2))
                    else
                       nrmat_fin(i,k)=0.5*(nrmat_fin(i,corresp(k,2))+nrmat_fin(i,corresp(k,3)))
                    endif
                    nrmat_fin(k,i)=nrmat_fin(i,k)
                 enddo
              enddo

              do i=j+1,tail
                 if(corresp(i,2)/=0.and.corresp(i,3)/=0) then
                    nrmat_fin(i,i)=1+0.5*(nrmat_fin(corresp(i,2),corresp(i,3)))
                 else
                    nrmat_fin(i,i)=1
                 endif
                 do k=i+1,tail
                    if(corresp(k,2)==0) then
                       nrmat_fin(i,k)=0.5*nrmat_fin(i,corresp(k,3))
                    else if (ped(k,3)==0) then
                       nrmat_fin(i,k)=0.5*nrmat_fin(i,corresp(k,2))
                    else
                       nrmat_fin(i,k)=0.5*(nrmat_fin(i,corresp(k,2))+nrmat_fin(i,corresp(k,3)))
                    endif
                    nrmat_fin(k,i)=nrmat_fin(i,k)
                 enddo
              enddo

              ! Count how many individuals can be used to create the next generation
              l=sum(ped(:,5))
              if(allocated(nrmat_f)) deallocate(nrmat_f)
              allocate(nrmat_f(l,l))
              k=0
              do i=1,tail
                 do m=1,size(ped_p1,1)
                    if(ped_p1(m,5)==corresp(i,1)) then
                       k=k+1
                       l=0
                       do j=1,tail
                          do ii=1,size(ped_p1,1)
                             if(ped_p1(ii,5)==corresp(j,1)) then
                                l=l+1
                                nrmat_f(k,l)=nrmat_fin(i,j)
                             endif
                          enddo
                       enddo
                    endif
                 enddo
              enddo
              deallocate(nrmat_fin)
              allocate(nrmat_fin(l,l))
              nrmat_fin=nrmat_f
              deallocate(nrmat_fin,corresp)
           endif

        else

           if(lect_nrm(1)==0) then
              allocate(corres(size(ped,1),4))
              call recode(size(ped,1),ped,corres)
              allocate(corresp(size(ped,1),3))
              corresp(:,1)=corres(:,1)
              corresp(:,2:3)=corres(:,3:4)
              deallocate(corres)

              ! Fn or BC: both populations remain at first separated
              ! Suppose that the individuals are already sorted
              if(allocated(nrmat)) deallocate(nrmat)
              allocate(nrmat(n1(0),n1(0)))
              nrmat=0
              j=0
              do i=1,n1(0)
                 if(corresp(i,2)==0.and.corresp(i,3)==0) then
                    nrmat(i,i)=1
                    j=j+1
                 endif
              enddo
              do i=1,j
                 do k=j+1,n1(0)
                    if(corresp(k,2)==0) then
                       nrmat(i,k)=0.5*nrmat(i,corresp(k,3))
                    else if(corresp(k,3)==0) then
                       nrmat(i,k)=0.5*nrmat(i,corresp(k,2))
                    else
                       nrmat(i,k)=0.5*(nrmat(i,corresp(k,2))+nrmat(i,corresp(k,3)))
                    endif
                    nrmat(k,i)=nrmat(i,k)
                 enddo
              enddo
              do i=j+1,n1(0)
                 if(corresp(i,2)/=0.and.corresp(i,3)/=0) then
                    nrmat(i,i)=1+0.5*nrmat(corresp(i,2),corresp(i,3))
                 else
                    nrmat(i,i)=1
                 endif
                 do k=i+1,n1(0)
                    if(corresp(k,2)==0) then
                       nrmat(i,k)=0.5*nrmat(i,corresp(k,3))
                    else if(corresp(k,3)==0) then
                       nrmat(i,k)=0.5*nrmat(i,corresp(k,2))
                    else
                       nrmat(i,k)=0.5*(nrmat(i,corresp(k,2))+nrmat(i,corresp(k,3)))
                    endif
                    nrmat(k,i)=nrmat(i,k)
                 enddo
              enddo
              deallocate(corresp)

              ! Count how many individuals can be used to create the next generation
              l=sum(ped(:,5))
              if(allocated(nrmat_f)) deallocate(nrmat_f)
              allocate(nrmat_f(l,l))
              k=0
              do i=1,n1(0)
                 if(ped(i,5)==1) then
                    k=k+1
                    l=0
                    do j=1,n1(0)
                       if(ped(j,5)==1) then
                          l=l+1
                          nrmat_f(k,l)=nrmat(i,j)
                       endif
                    enddo
                 endif
              enddo
              deallocate(nrmat)
              allocate(nrmat(l,l))
              nrmat=nrmat_f
              deallocate(nrmat_f)

              ! 2nd pop
              allocate(corres(size(ped2,1),4))
              call recode(size(ped2,1),ped2,corres)
              allocate(corresp(size(ped2,1),3))
              corresp(:,1)=corres(:,1)
              corresp(:,2:3)=corres(:,3:4)
              deallocate(corres)

              if(allocated(nrmat3)) deallocate(nrmat3)
              allocate(nrmat3(n2(0),n2(0)))
              nrmat3=0
              j=0
              do i=1,n2(0)
                 if(corresp(i,2)==0.and.corresp(i,3)==0) then
                    nrmat3(i,i)=1
                    j=j+1
                 endif
              enddo
              do i=1,j
                 do k=j+1,n2(0)
                    if(corresp(k,2)==0) then
                       nrmat3(i,k)=0.5*nrmat3(i,corresp(k,3))
                    else if(ped2(k,3)==0) then
                       nrmat3(i,k)=0.5*nrmat3(i,corresp(k,2))
                    else
                       nrmat3(i,k)=0.5*(nrmat3(i,corresp(k,2))+nrmat3(i,corresp(k,3)))
                    endif
                    nrmat3(k,i)=nrmat3(i,k)
                 enddo
              enddo
              do i=j+1,n2(0)
                 if(corresp(i,2)/=0.and.corresp(i,3)/=0) then
                    nrmat3(i,i)=1+0.5*nrmat3(corresp(i,2),corresp(i,3))
                 else
                    nrmat3(i,i)=1
                 endif
                 do k=i+1,n2(0)
                    if(corresp(k,2)==0) then
                       nrmat3(i,k)=0.5*nrmat3(i,corresp(k,3))
                    else if(ped2(k,3)==0) then
                       nrmat3(i,k)=0.5*nrmat3(i,corresp(k,2))
                    else
                       nrmat3(i,k)=0.5*(nrmat3(i,corresp(k,2))+nrmat3(i,corresp(k,3)))
                    endif
                    nrmat3(k,i)=nrmat3(i,k)
                 enddo
              enddo
              deallocate(corresp)

              ! Count how many individuals can be used to create the next generation
              l=sum(ped2(:,5))
              allocate(nrmat_f(l,l))
              k=0
              do i=1,n2(0)
                 if(ped2(i,5)==1) then
                    k=k+1
                    l=0
                    do j=1,n2(0)
                       if(ped2(j,5)==1) then
                          l=l+1
                          nrmat_f(k,l)=nrmat3(i,j)
                       endif
                    enddo
                 endif
              enddo
              deallocate(nrmat3)
              allocate(nrmat3(l,l))
              nrmat3=nrmat_f
              deallocate(nrmat_f)

              ! check if individuals are common to the two populations
              allocate(parent(n1(0)+n2(0),2))
              parent=0
              tail=n1(0)+n2(0)
              parent(1:n1(0),1)=ped(1:n1(0),1)
              parent(1+n1(0):tail,1)=ped2(1:n2(0),1)
              do i=1,tail
                 do j=i+1,tail
                    if(parent(i,1)==parent(j,1)) then
                       parent(i,2)=1
                       parent(j,2)=1
                    endif
                 enddo
              enddo
              if(maxval(parent)==1) then
                 allocate(rang(n1(0)+n2(0)))
                 rang=parent(:,2)
              endif

              iv=maxval(parent(:,2))
              deallocate(parent)
              if(iv==1) then ! If so, then both pedigrees used to compute the NRM
                 allocate(ped3(n1(0)+n2(0),6))
                 ii=0
                 allocate(nrmat_f(n1(0)+n2(0),n1(0)+n2(0)))
                 nrmat_f=0
                 do j=1,n1(0)
                    if(ped(j,2)==0.and.ped(j,3)==0) then
                       ii=ii+1
                       ped3(ii,1:5)=ped(j,1:5)
                       ped3(ii,6)=1
                       nrmat_f(ii,ii)=1
                    endif
                 enddo
                 do j=1,n2(0)
                    if(ped2(j,2)==0.and.ped2(j,3)==0) then
                       ii=ii+1
                       ped3(ii,1:5)=ped2(j,1:5)
                       ped3(ii,6)=2
                       nrmat_f(ii,ii)=1
                    endif
                 enddo
                 m=ii
                 do i=1,max(maxval(ped(:,5)),maxval(ped2(:,5)))
                    do j=1,n1(0)
                       if(ped(j,5)==i) then
                          if(ped(j,2)/=0.or.ped(j,3)/=0) then
                             ii=ii+1
                             ped3(ii,1:5)=ped(j,1:5)
                             ped3(ii,6)=2
                          endif
                       endif
                    enddo
                    do j=1,n2(0)
                       if(ped2(j,5)==i) then
                          if(ped2(j,2)/=0.or.ped2(j,3)/=0) then
                             ii=ii+1
                             ped3(ii,1:5)=ped2(j,1:5)
                             ped3(ii,6)=2
                          endif
                       endif
                    enddo
                 enddo
                 allocate(corres(n1(0)+n2(0),4))
                 call recode(n1(0)+n2(0),corres,ped3)
                 allocate(corresp(n1(0)+n2(0),3))
                 corresp(:,i)=corres(:,i)
                 corresp(:,2:3)=corres(:,3:4)
                 deallocate(corres)

                 ! then compute all relationships
                 nrmat_f=0
                 tail=n1(0)+n2(0)
                 j=0
                 do i=1,m
                    do j=m+1,tail
                       if(corresp(j,2)==0) then
                          nrmat_f(i,j)=0.5*nrmat_f(i,corresp(j,3))
                       else if(ped3(j,3)==0) then
                          nrmat_f(i,j)=0.5*nrmat_f(i,corresp(j,2))
                       else
                          nrmat_f(i,j)=0.5*(nrmat_f(i,corresp(j,2))+nrmat_f(i,corresp(j,3)))
                       endif
                       nrmat_f(k,i)=nrmat_f(i,k)
                    enddo
                 enddo
                 do i=m+1,tail
                    if(corresp(i,2)/=0.and.corresp(i,3)/=0) then
                       nrmat_f(i,i)=1+0.5*nrmat_f(corresp(i,2),corresp(i,3))
                    else
                       nrmat_f(i,i)=1
                    endif
                    do j=i+1,tail
                       if(corresp(j,2)==0) then
                          nrmat_f(i,j)=0.5*nrmat_f(i,corresp(j,3))
                       else if(corresp(j,3)==0) then
                          nrmat_f(i,j)=0.5*nrmat_f(i,corresp(j,2))
                       else
                          nrmat_f(i,j)=0.5*(nrmat_f(i,corresp(j,2))+nrmat_f(i,corresp(j,3)))
                       endif
                       nrmat_f(k,i)=nrmat_f(i,k)
                    enddo
                 enddo
                 deallocate(corresp)

                 k=sum(ped(:,5))
                 l=sum(ped2(:,5))
                 if(allocated(nrmat2)) deallocate(nrmat2)
                 allocate(nrmat2(k,l))
                 nrmat2=0
                 k=0
                 do i=1,tail
                    if(ped3(i,6)==1.and.ped3(i,5)==1) then
                       k=k+1
                       l=0
                       do j=1,tail
                          if(ped3(j,6)==2.and.ped3(j,5)==1) then
                             l=l+1
                             nrmat2(k,l)=nrmat_f(i,j)
                          endif
                       enddo
                    endif
                 enddo
                 deallocate(nrmat_f,ped3)
              else
                 k=sum(ped(:,5))
                 l=sum(ped2(:,5))
                 allocate(nrmat2(k,l))
                 nrmat2=0
              endif
           endif

           if(typ_pop==2) then 
              allocate(ped_p1(tot_pop_fin(1)+n2(0),3))
              allocate(remain(sum(ped(:,5))+sum(n(:,1:time2)),2))
              j=0;k=0;l=0
              do i=1,n1(0)
                 if(ped(i,5)==1) then
                    j=j+1
                    remain(j,1)=ped(i,1)
                    remain(j,2)=ped(i,6)
                    ped_p1(j,:)=ped(i,1:3)
                    if(ped(i,6)==1) k=k+1
                    if(ped(i,6)==2) l=l+1
                 endif
              enddo
              n(1,0)=k
              anc1=k
              n(2,0)=l
              anc2=l
              last_gen=max(maxval(ped(:,4)),maxval(ped2(:,4)))
              deallocate(ped)
              allocate(remain2(sum(ped2(:,5))+sum(n(:,1:time2)),2))
              j=0; k=0; l=0
              do i=1,n2(0)
                 if(ped2(i,5)==1) then
                    j=j+1
                    remain2(j,1)=ped2(i,1)
                    remain2(j,2)=ped2(i,6)
                    ped_p1(j+sum(ped2(:,5)),:)=ped2(i,1:3)
                    if(ped2(i,6)==1) k=k+1
                    if(ped2(i,6)==2) l=l+1
                 endif
              enddo
              n(3,0)=k
              anc3=k
              n(4,0)=l
              anc4=l
              allocate(ped_p2(tot_pop_fin(2),3))
              k=0
              do i=1,n2(0)
                 if(ped2(i,5)==1) then
                    k=k+1
                    ped_p2(k,1:3)=ped2(i,1:3)
                 endif
              enddo
              deallocate(ped2)

           else
              allocate(ped_p1(tot_pop_fin(1)+sum(ped2(:,5)),3))
              allocate(remain(sum(ped(:,5))+sum(ped2(:,5))+sum(n(:,1:time2)),2))
              if(cross==0) then
                 ! females from pop1, males from pop2
                 j=0;k=0;l=0
                 do i=1,n2(0)
                    if(ped2(i,5)==1.and.ped2(i,6)==1) then
                       j=j+1
                       remain(j,1)=ped2(i,1)
                       remain(j,2)=ped2(i,6)
                       ped_p1(j,:)=ped2(i,1:3)
                       k=k+1
                    endif
                 enddo
                 do i=1,n1(0)
                    if(ped(i,5)==1.and.ped(i,6)==2) then
                       j=j+1
                       remain(j,1)=ped(i,1)
                       remain(j,2)=ped(i,6)
                       ped_p1(j,:)=ped(i,1:3)
                       l=l+1
                    endif
                 enddo
                 last_gen=max(maxval(ped(:,4)),maxval(ped2(:,4)))
                 deallocate(ped,ped2)
                 n(1,0)=k
                 n(2,0)=l
              else
                 ! females from pop2, males from pop1
                 j=0;k=0;l=0
                 do i=1,n1(0)
                    if(ped(i,5)==1.and.ped(i,6)==1) then
                       j=j+1
                       remain(j,1)=ped(i,1)
                       remain(j,2)=ped(i,6)
                       ped_p1(j,:)=ped(i,1:3)
                       k=k+1
                    endif
                 enddo
                 do i=1,n2(0)
                    if(ped2(i,5)==1.and.ped2(i,6)==2) then
                       j=j+1
                       remain(j,1)=ped2(i,1)
                       remain(j,2)=ped2(i,6)
                       ped_p1(j,:)=ped2(i,1:3)
                       l=l+1
                    endif
                 enddo
                 last_gen=max(maxval(ped(:,4)),maxval(ped2(:,4)))
                 deallocate(ped,ped2)
                 n(1,0)=k
                 n(2,0)=l
              endif

           endif
        endif

     else

        if(lect_nrm(1)==0) then
           allocate(corres(size(ped,1),4))
           call recode(size(ped,1),ped,corres)
           allocate(corresp(size(ped,1),3))
           corresp(:,1)=corres(:,1)
           corresp(:,2:3)=corres(:,3:4)
           deallocate(corres)

           if(allocated(nrmat)) deallocate(nrmat)
           allocate(nrmat(n1(0),n1(0)))
           nrmat=0
           j=0
           do i=1,n1(0)
              if(corresp(i,2)==0.and.corresp(i,3)==0) then
                 nrmat(i,i)=1
                 j=j+1
              endif
           enddo
           do i=1,j
              do k=j+1,n1(0)
                 if(corresp(k,2)==0) then
                    nrmat(i,k)=0.5*nrmat(i,corresp(k,3))
                 else if(ped(k,3)==0) then
                    nrmat(i,k)=0.5*nrmat(i,corresp(k,2))
                 else
                    nrmat(i,k)=0.5*(nrmat(i,corresp(k,2))+nrmat(i,corresp(k,3)))
                 endif
                 nrmat(k,i)=nrmat(i,k)
              enddo
           enddo
           do i=j+1,n1(0)
              if(corresp(i,2)/=0.and.corresp(i,3)/=0) then
                 nrmat(i,i)=1+0.5*nrmat(corresp(i,2),corresp(i,3))
              else
                 nrmat(i,i)=1
              endif
              do k=i+1,n1(0)
                 if(corresp(k,2)==0) then
                    nrmat(i,k)=0.5*nrmat(i,corresp(k,3))
                 else if(ped(k,3)==0) then
                    nrmat(i,k)=0.5*nrmat(i,corresp(k,2))
                 else
                    nrmat(i,k)=0.5*(nrmat(i,corresp(k,2))+nrmat(i,corresp(k,3)))
                 endif
                 nrmat(k,i)=nrmat(i,k)
              enddo
           enddo
           deallocate(corresp)
        ! Count how many individuals can be used to create the next generation
        l=sum(ped(:,5))
        if(allocated(nrmat_f)) deallocate(nrmat_f)
        allocate(nrmat_f(l,l))
        k=0
        do i=1,n1(0)
           if(ped(i,5)==1) then
              k=k+1
              l=0
              do j=1,n1(0)
                 if(ped(j,5)==1) then
                    l=l+1
                    nrmat_f(k,l)=nrmat(i,j)
                 endif
              enddo
           endif
        enddo
        deallocate(nrmat)
        allocate(nrmat(sum(ped(:,5)),sum(ped(:,5))))
        nrmat=nrmat_f
        deallocate(nrmat_f)
        endif

        allocate(ped_p1(tot_pop_fin(1),3))
        k=0
        do i=1,n1(0)
           if(ped(i,5)==1) then
              k=k+1
              ped_p1(k,1:3)=ped(i,1:3)
           endif
        enddo
        if(typ_pop==1) then
           allocate(remain(sum(ped(:,5)),2))
        else
           allocate(remain(sum(ped(:,5))+sum(n),2))
        endif

        j=0
        do i=1,n1(0)
           if(ped(i,5)==1) then
              j=j+1
              remain(j,1)=i
              remain(j,2)=ped(i,6)
           endif
        enddo
        last_gen=maxval(ped(:,4))
        deallocate(ped)
     endif
     deallocate(n1)
     if(allocated(n2)) deallocate(n2)
  endif



  ! Begining of the pedigree known generations

  if (typ_pop==0) then

     if(nbpop==2) then

        if(orig==0) then 
           ! F-cross
           if(cross==0) then
              if(direct_fin==0) then
                 n(1,0)=anc1
                 n(2,0)=anc4
              else
                 anc1=n(1,0)
                 anc4=n(2,0)
              endif
              allocate(all3(nmq+nqtl,anc1+anc4,2),gind2(anc1+anc4,2)) ! Males from the first population and females from the 2nd
              if(store_cop==1) allocate(cop3(nmq+nqtl,anc1+anc4,2))
              do i=1,anc1
                 all3(:,i,:)=all(:,i,:)
                 if(store_cop==1) cop3(:,i,:)=cop(:,i,:)
                 gind2(i,1)=gind(i,1) ! Save the polygenic breeding values
                 gind2(i,2)=perf(i,1) ! Save the phenotypes
              enddo
              do i=1,anc4
                 all3(:,anc1+i,:)=allp2(:,anc3+i,:)
                 if(store_cop==1) cop3(:,anc1+i,:)=copp2(:,anc3+i,:)
                 gind2(anc1+i,1)=gind(anc3+i,2)
                 gind2(anc1+i,2)=perf(anc3+i,2)
              enddo
              allocate(nrmat_fin(anc1+anc4,anc1+anc4))
              do i=1,anc1
                 nrmat_fin(i,1:anc1)=nrmat(i,1:anc1)
                 nrmat_fin(i,1+anc1:anc1+anc4)=nrmat2(i,anc3+1:anc3+anc4)
              enddo
              do i=anc1+1,anc1+anc4
                 nrmat_fin(i,1:anc1)=nrmat2(1:anc1,i+anc3-anc1)
                 nrmat_fin(i,1+anc1:anc1+anc4)=nrmat3(i+anc3-anc1,anc3+1:anc3+anc4)
              enddo
              deallocate(nrmat,nrmat2,nrmat3)
           else
              if(direct_fin==0) then
                 n(1,0)=anc3
                 n(2,0)=anc2
              else
                 anc3=n(1,0)
                 anc2=n(2,0)
              endif
              allocate(all3(nmq+nqtl,anc2+anc3,2),gind2(anc2+anc3,2)) ! Males from the 2nd population and females from the 1st
              if(store_cop==1) allocate(cop3(nmq+nqtl,anc2+anc3,2))
              do i=1,anc3
                 all3(:,i,:)=allp2(:,i,:)
                 if(store_cop==1) cop3(:,i,:)=copp2(:,i,:)
                 gind2(i,1)=gind(i,2) ! Save the polygenic breeding values
                 gind2(i,2)=perf(i,2) ! Save the phenotypes
              enddo
              do i=1,anc2
                 all3(:,anc3+i,:)=all(:,anc1+i,:)
                 if(store_cop==1) cop3(:,anc3+i,:)=cop(:,anc1+i,:)
                 gind2(anc3+i,1)=gind(anc1+i,1)
                 gind2(anc3+i,2)=perf(anc1+i,1)
              enddo
              allocate(nrmat_fin(anc2+anc3,anc2+anc3))
              do i=1,anc3
                 nrmat_fin(i,1:anc3)=nrmat3(i,1:anc3)
                 nrmat_fin(i,1+anc3:anc2+anc3)=nrmat2(anc1+1:anc1+anc2,i)
              enddo
              do i=anc3+1,anc3+anc2
                 nrmat_fin(i,1:anc3)=nrmat2(1:anc3,i-anc3+anc1)
                 nrmat_fin(i,1+anc3:anc3+anc2)=nrmat(i-anc3+anc1,anc1+1:anc1+anc2)
              enddo
              deallocate(nrmat,nrmat2,nrmat3)
           endif

        else
           ! Random mating
           if(direct_fin==0) then
              n(1,0)=anc1+anc3
              n(2,0)=anc4+anc2
           endif
           allocate(all3(nmq+nqtl,anc1+anc2+anc3+anc4,2),gind2(anc1+anc2+anc3+anc4,2)) ! Males from the 2nd population and females from the 1st
           if(store_cop==1) allocate(cop3(nmq+nqtl,anc1+anc2+anc3+anc4,2))
           do i=1,anc1
              all3(:,i,:)=all(:,i,:)
              if(store_cop==1) cop3(:,i,:)=cop(:,i,:)
              gind2(i,1)=gind(i,1) ! Save the polygenic breeding values
              gind2(i,2)=perf(i,1) ! Save the phenotypes
           enddo
           do i=1,anc3
              all3(:,anc1+i,:)=allp2(:,i,:)
              if(store_cop==1) cop3(:,anc1+i,:)=copp2(:,i,:)
              gind2(anc1+i,1)=gind(i,2) ! Save the polygenic breeding values
              gind2(anc1+i,2)=perf(i,2) ! Save the phenotypes
           enddo
           do i=1,anc2
              all3(:,anc1+anc3+i,:)=all(:,anc1+i,:)
              if(store_cop==1) cop3(:,anc1+anc3+i,:)=cop(:,anc1+i,:)
              gind2(anc1+anc3+i,1)=gind(anc1+i,1) ! Save the polygenic breeding values
              gind2(anc1+anc3+i,2)=perf(anc1+i,1) ! Save the phenotypes
           enddo
           do i=1,anc4
              all3(:,anc1+anc3+anc2+i,:)=allp2(:,anc3+i,:)
              if(store_cop==1) cop3(:,anc1+anc3+anc2+i,:)=cop(:,anc3+i,:)
              gind2(anc1+anc3+anc2+i,1)=gind(anc3+i,2)
              gind2(anc1+anc3+anc2+i,2)=perf(anc3+i,2)
           enddo

           j=anc1+anc2+anc3+anc4
           do i=1,time2
              j=max(j,sum(n(:,i)))
           enddo
           allocate(nrmat_fin(j,j))
           if(direct_fin==0) then
              do i=1,anc1
                 nrmat_fin(i,1:anc1)=nrmat(i,1:anc1)
                 nrmat_fin(i,anc1+1:anc1+anc3)=nrmat2(i,1:anc3)
                 nrmat_fin(i,anc1+anc3+1:anc1+anc3+anc2)=nrmat(i,anc1+1:anc1+anc2)
                 nrmat_fin(i,1+anc1+anc3+anc2:anc1+anc3+anc2+anc4)=nrmat2(i,anc3+1:anc3+anc4)
              enddo
              do i=anc1+1,anc1+anc3
                 nrmat_fin(i,1:anc1)=nrmat2(1:anc1,i-anc1)
                 nrmat_fin(i,1+anc1:anc1+anc3)=nrmat3(i-anc1,1:anc3)
                 nrmat_fin(i,1+anc1+anc3:anc1+anc3+anc2)=nrmat2(anc1+1:anc1+anc2,i-anc1+anc3)
                 nrmat_fin(i,1+anc1+anc3+anc2:anc1+anc3+anc2+anc4)=nrmat3(i-anc1,anc3+1:anc3+anc4)
              enddo
              do i=anc1+anc3+1,anc1+anc3+anc2
                 nrmat_fin(i,1:anc1)=nrmat(i-anc3,1:anc1)
                 nrmat_fin(i,1+anc1:anc1+anc3)=nrmat2(i-anc3,1:anc3)
                 nrmat_fin(i,1+anc1+anc3:anc1+anc3+anc2)=nrmat(i-anc3,anc1+1:anc1+anc2)
                 nrmat_fin(i,1+anc1+anc3+anc2:anc1+anc3+anc2+anc4)=nrmat2(i-anc3,anc3+1:anc3+anc4)
              enddo
              do i=anc1+anc3+anc2+1,anc1+anc3+anc2+anc4
                 nrmat_fin(i,1:anc1)=nrmat2(1:anc1,i-anc1-anc2)
                 nrmat_fin(i,1+anc1:anc1+anc3)=nrmat3(i-anc2-anc1,1:anc3)
                 nrmat_fin(i,1+anc1+anc3:anc1+anc3+anc2)=nrmat2(anc1+1:anc1+anc2,i-anc2-anc1)
                 nrmat_fin(i,1+anc1+anc3+anc2:anc1+anc3+anc2+anc4)=nrmat3(i-anc2-anc1,anc3+1:anc3+anc4)
              enddo
              deallocate(nrmat,nrmat2,nrmat3)
           else
              nrmat_fin=nrmat_f
              deallocate(nrmat_f)
           endif
        endif
        deallocate(perf,gind,all,allp2)
        if(allocated(cop)) deallocate(cop,copp2)

     else

        if(direct_fin==0) then
           n(1,0)=anc1
           n(2,0)=anc2
        else
           anc1=n(1,0)
           anc2=n(2,0)
        endif
        allocate(all3(nmq+nqtl,anc1+anc2,2),gind2(anc1+anc2,2)) ! Males from the first population and females from the 2nd
        if(store_cop==1) allocate(cop3(nmq+nqtl,anc1+anc2,2))
        do i=1,anc1+anc2
           all3(:,i,:)=all(:,i,:)
           if(store_cop==1) cop3(:,i,:)=cop(:,i,:)
           gind2(i,1)=gind(i,1) ! Save the polygenic breeding values
           gind2(i,2)=perf(i,1) ! Save the phenotypes
        enddo

        j=anc1+anc2
        do i=1,time2
           j=max(j,sum(n(:,i)))
        enddo
        allocate(nrmat_fin(j,j))
        nrmat_fin(1:anc1+anc2,1:anc1+anc2)=nrmat(1:anc1+anc2,1:anc1+anc2)
        deallocate(perf,gind,all)
        if(allocated(cop)) deallocate(cop)
        n(1,0)=anc1
        n(2,0)=anc2
        deallocate(nrmat)
     endif

     nbpop=1
     if(allocated(gani)) deallocate(gani)
     i=0
     do k=0,time2
        i=max(i,sum(n(:,k)))
     enddo
     allocate(perf(i,2))
     allocate(gind(i,2))
     allocate(gani(i,2))
     perf(1:sum(n(:,0)),1)=gind2(1:sum(n(:,0)),1)
     gind(1:sum(n(:,0)),1)=gind2(1:sum(n(:,0)),2)
     deallocate(gind2)

     open(48,file='simhaploNoQTL')
     open(41,file='simhaplo')
     open(220,file='simped')
     open(24,file='simperf')
     open(78,file='genotyp_err')
     if(store_cop==1) then
        open(50,file='simcop')
        open(51,file='simcopNoQTL')
     endif
     id=0; id2=0
     ! Outputs of the last historical generation if required
     if(direct_fin==0) then
        if(gene_ped==time2+1) then
           do i=1,n(1,0)
              write(220,*)last_ind+i,' 0     0     ',last_gen+1,'       0    1'
           enddo
           do i=1+n(1,0),sum(n(1:2,0))
              write(220,*)last_ind+i,' 0     0     ',last_gen+1,'       0    2'
           enddo
        endif
        if(gene_perf==time2+1) then
           do i=1,sum(n(:,0))
              write(24,*)last_ind+i,perf(i,nbpop+1),gind(i,nbpop+1)
           enddo
        endif
        if(gene_typ==time2+1) then
           allocate(all(nmq+nqtl,sum(n(:,0)),2))
           all=all3
           if(typing_err==1) call genot_err(1,sum(n(:,0)),all3,all,errSNP,errMST,miss_genot)
           allocate(all2(nmq,sum(n(:,0)),2))
           if(store_cop==1) allocate(cop2(nmq,sum(n(:,0)),2))
           l=0
           do i=1,nmq+nqtl
              if(indic(i)==1) then
                 l=l+1
              else
                 all2(i-l,:,:)=all(i,:,:) 
                 if(store_cop==1) cop2(i-l,:,:)=cop3(i,:,:) 
              endif
           enddo
           do i=1,sum(n(:,0))
              do k=1,2
                 write(41,*)last_ind+i,k,all(:,i,k)
                 write(48,*)last_ind+i,k,all2(:,i,k)
                 if(store_cop==1) then
                    write(50,*)last_ind+i,k,cop3(:,i,k)
                    write(51,*)last_ind+i,k,cop2(:,i,k)  
                 endif
              enddo
           enddo
           deallocate(all2,all)
           if(allocated(cop2)) deallocate(cop2)
        endif
        if(gene_typ==time2+1.or.gene_perf==time2+1.or.gene_ped==time2+1) id=id+sum(n(:,0))
     else
        if(gene_ped==time2+1) then
           do i=1,n(1,0)
              write(220,*)remain(i,1),ped_p1(remain(i,1),2:3),last_gen+1,'       0    1'
           enddo
           do i=1+n(1,0),sum(n(:,0))
              write(220,*)remain(i,1),ped_p1(remain(i,1),2:3),last_gen+1,'       0    2'
           enddo
        endif
        if(gene_perf==time2+1) then
           do i=1,sum(n(:,0))
              write(24,*)remain(i,1),perf(i,nbpop+1),gind(i,nbpop+1)
           enddo
        endif
        if(gene_typ==time2+1) then
           allocate(all(nmq+nqtl,sum(n(:,0)),2))
           all=all3
           if(typing_err==1) call genot_err(1,sum(n(:,0)),all3,all,errSNP,errMST,miss_genot)
           allocate(all2(nmq,sum(n(:,0)),2))
           if(store_cop==1) allocate(cop2(nmq,sum(n(:,0)),2))
           l=0
           do i=1,nmq+nqtl
              if(indic(i)==1) then
                 l=l+1
              else
                 all2(i-l,:,:)=all(i,:,:) 
                 if(store_cop==1) cop2(i-l,:,:)=cop3(i,:,:) 
              endif
           enddo
           do i=1,sum(n(:,0))
              do k=1,2
                 write(41,*)remain(i,1),k,all(:,i,k)
                 write(48,*)remain(i,1),k,all2(:,i,k)
                 if(store_cop==1) then
                    write(50,*)remain(i,1),k,cop3(:,i,k)
                    write(51,*)remain(i,1),k,cop2(:,i,k)  
                 endif
              enddo
           enddo
           deallocate(all2,all)
           if(allocated(cop2)) deallocate(cop2)
        endif
        if(gene_typ==time2+1.or.gene_perf==time2+1.or.gene_ped==time2+1) id=last_ind
     endif
!!$print*,'HERE',n(:,0),anc1,anc2,anc3,anc4

     i=0
     do k=0,time2
        i=max(i,sum(n(:,k)))
     enddo
     allocate(all(nmq+nqtl,i,2))
!!$     print*,'SHAPE',shape(all)
     if(store_cop==1) allocate(cop(nmq+nqtl,i,2))
     do i=1,sum(n(:,0))
        all(:,i,:)=all3(:,i,:)
        if(store_cop==1) cop(:,i,:)=cop3(:,i,:)
     enddo
     deallocate(all3)
     if(store_cop==1) deallocate(cop3)

     if(allocated(parent)) deallocate(parent)
     if(.not.allocated(ped_p1)) then
        allocate(ped_p1(sum(n(:,:)),3))
        allocate(remain(sum(n(:,:)),2))
        ped_p1=0
        do i=1,sum(n(:,0))
           ped_p1(i,1)=i
           remain(i,1)=i
        enddo
        remain(1:n(1,0),2)=1
        remain(1+n(1,0):sum(n(:,0)),2)=2
        last_ind=0
     endif

     ! Evolution of the populations in the part typ_pop==0
     if(nbpop==2) then
        if(polyg3/=0) then
           polyg=polyg3
        else
           polyg=polyg2+polyg
        endif
     endif

     j=0
     do i=0,time2
        j=max(j,sum(n(1:2,i)))
     enddo
     allocate(parent(j,2))
     allocate(all2(nmq+nqtl,j,2))
     if(store_cop==1) allocate(cop2(nmq+nqtl,j,2))

     if(direct_fin==1) then
        allocate(verif(sum(n(:,0))),rang(sum(n(:,0))),rang2(sum(n(:,0))))
        k=0; l=0
        do i=1,sum(n(:,0))
           if(remain(i,2)==1) then
              k=k+1
              verif(k)=remain(i,1)
              rang(k)=ped_p1(i,2)
              rang2(k)=ped_p1(i,3)
           else
              l=l+1
              verif(l+n(1,0))=remain(i,1)
              rang(l+n(1,0))=ped_p1(i,2)
              rang2(l+n(1,0))=ped_p1(i,3)
           endif
        enddo
        remain(1:sum(n(:,0)),1)=verif(1:sum(n(:,0)))
        ped_p1(1:sum(n(:,0)),2)=rang(1:sum(n(:,0)))
        ped_p1(1:sum(n(:,0)),3)=rang2(1:sum(n(:,0)))
        deallocate(verif,rang,rang2)
        remain(1:n(1,0),2)=1
        remain(1+n(1,0):sum(n(:,0)),2)=2
     endif

     do i=sum(n(:,0))+1,sum(n)
        ped_p1(i,1)=last_ind+i
     enddo


     do gene=1,time2

        print*,'GENE',gene

        polyg=sqrt(sum(gind(1:sum(n(1:2,gene-1)),1)**2)/real(sum(n(1:2,gene-1)))-&
             (sum(gind(1:sum(n(1:2,gene-1)),1))/real(sum(n(1:2,gene-1))))**2)
        ! SETTING UP THE PARAMETERS FOR EACH GENERATION
        ! Compute the number and females allowed to reproduce

        nt=nint(n(1,gene-1)*sel(1,gene-1,1))
!!$        print*,n(2,gene-1)
        nf=nint(n(2,gene-1)*sel(2,gene-1,1))
!!$ print*,nt,n(1,gene-1),sel(1,gene-1,1),nf,n(2,gene-1),sel(2,gene-1,1),gene-1
!!$        print*,'INDIVIDUALS SELECTED:',nt,nf,n(1,gene-1),n(2,gene-1)

        ! Number of offspring per sire
        if(offSire==0) then
           if(uniformity==0) then
              do i=2,nt
                 offspPerSire(i,gene,1)=offspPerSire(1,gene,1)
              enddo
           endif
        else ! The number of offspring per sire is random
           call G05DYF2(1,sum(n(:,gene)),nt,offspPerSire(:,gene,1))
           k=sum(offspPerSire(:,gene,1))
!!$print*,'NB OFFSP',k,minval(offspPerSire(:,gene,1)),maxval(offspPerSire(:,gene,1)),nt,sum(n(:,gene)),nf
           do while(k/=sum(n(:,gene))) 
              l=G05DYF(1,nt)
              test=.TRUE.
              if(offspPerSire(l,gene,1)==0) test=.FALSE.
              if(offspPerSire(l,gene,1)==1.and.nt/=n(1,gene-1)) test=.FALSE.
              if(test) then
                 if(k<sum(n(:,gene))) then
                    offspPerSire(l,gene,1)=offspPerSire(l,gene,1)+1
                 else
                    offspPerSire(l,gene,1)=offspPerSire(l,gene,1)-1
                 endif
              endif
              k=sum(offspPerSire(:,gene,1))
!!$              print*,'NB OFFSP',k,minval(offspPerSire(:,gene,1)),maxval(offspPerSire(:,gene,1))
           enddo
!!$           print*,'offsperSire',offspPerSire(:,gene)
!!$              print*,'k',k,l,offspPerSire(l,gene)
        endif
!!$        print*,'offspPerSire'!,offspPerSire(:,gene,1),sum(offspPerSire(:,gene,1))

        allocate(damToSire(nf))
        damToSire=0
        if(DamSire==0) then
           if(evenly==0) then
              do i=2,nt
                 damPerSire(i,gene,1)=damPerSire(1,gene,1)
              enddo
           else
              if(sum(damPerSire(nt+1:n(1,gene),gene,1))/=0) then
                 print*,'ERROR: SIRES THAT ARE NOT SELECTIBLE SHOULD BE PARENT'
                 stop 1
              endif
           endif
           do i=1,nt
              damToSire(sum(damPerSire(1:i-1,gene,1))+1:sum(damPerSire(1:i,gene,1)))=i
           enddo
        else
           ! The number of dams per sire is chosen randomly
!!$           print*,nt,nf
           damPerSire(:,gene,1)=0
           allocate(rang(nt))
           j=0
           do i=1,nt
              if(offspPerSire(i,gene,1)/=0) then
                 j=j+1 ! Counting the number of sires with offspring
                 rang(j)=i
              endif
           enddo
           call G05DYF2(1,j,nf,damToSire)
           do i=1,nf
              damToSire(i)=rang(damToSire(i))
           enddo
           do i=1,nt
              l=0
              do ii=1,nf
                 if(damToSire(ii)==i) l=l+1
              enddo
              damPerSire(i,gene,1)=l
           enddo

           do i=1,nt
!!$              print*,'SIRE',i,offspPerSire(i,gene,1),damPerSire(i,gene,1)
              do while (damPerSire(i,gene,1)>offspPerSire(i,gene,1))
                 k=G05DYF(1,j)
                 test=.FALSE.
                 if(offspPerSire(rang(k),gene,1)>damPerSire(rang(k),gene,1)) test=.TRUE.
                 if(test) then
!!$                    print*,'TO CHANGE',i,k,rang(k),damPerSire(i,gene,1),offspPerSire(rang(k),gene,1),&
!!$                         damPerSire(rang(k),gene,1),offspPerSire(i,gene,1)
                    damPerSire(i,gene,1)=damPerSire(i,gene,1)-1
                    allocate(rang2(nf))
                    ii=0
                    do l=1,nf
                       if(damToSire(l)==i) then
                          ii=ii+1
                          rang2(ii)=l
                       endif
                    enddo
                    m=G05DYF(1,ii)
!!$                    print*,m,k,rang2(m),rang(k)
                    damToSire(rang2(m))=rang(k)
                    damPerSire(rang(k),gene,1)=damPerSire(rang(k),gene,1)+1
!!$                    print*,'CHANGED',i,k,m,ii,rang(k),rang2(m),damPerSire(i,gene,1),damToSire(rang2(m)),&
!!$                         damPerSire(rang(k),gene,1)
                    deallocate(rang2)
                 endif
              enddo
!!$              print*,'B',i,offspPerSire(i,gene,1),damPerSire(i,gene,1)
              do while(damPerSire(i,gene,1)==0.and.offspPerSire(i,gene,1)/=0)
!!$                 print*,'HERE',i,damPerSire(i,gene,1),offspPerSire(i,gene,1)
                 k=G05DYF(1,nf)
                 test=.FALSE.
                 if(damPerSire(damToSire(k),gene,1)/=1) test=.TRUE.
                 if(test) then
                    damPerSire(damToSire(k),gene,1)=damPerSire(damToSire(k),gene,1)-1
                    damToSire(k)=i
                    damPerSire(i,gene,1)=damPerSire(i,gene,1)+1
                 endif
              enddo
!!$              print*,'C',i,offspPerSire(i,gene,1),damPerSire(i,gene,1)
           enddo
           deallocate(rang)
        endif
!!$        print*,'DPS',damPerSire(:,gene,1)
!!$        print*,'DTS',damToSire(:)
!!$        print*,'DAMS'

        allocate(offspPerDam(nf))
        if(offSire==0) then
           if(constant3==0) then
              do i=1,nf
                 offspPerDam(i)=nint(real(offspPerSire(damToSire(i),gene,1))/&
                      real(damPerSire(damToSire(i),gene,1)))
              enddo
           else
              do i=1,nt
                 l=0
                 m=0
                 if(damPerSire(i,gene,1)==1) then
                    do j=1,nf
                       if(damToSire(j)==i) exit
                    enddo
                    offspPerDam(j)=offspPerSire(i,gene,1)
                 else
                    do j=1,nf
                       if(damToSire(j)==i) then
                          l=l+1
                          if(l<damPerSire(i,gene,1)) then
                             k=damPerSire(i,gene,1)-l ! Number of dams remaining for sire i after dam j
                             offspPerDam(j)=G05DYF(1,offspPerSire(i,gene,1)-m-k)
                             m=m+offspPerDam(j)
                          else
                             offspPerDam(j)=offspPerSire(i,gene,1)-m-k+1
                          endif
                       endif
                    enddo
                 endif
              enddo
           endif
        else
           do i=1,nt 
              l=0
              m=0
              if(damPerSire(i,gene,1)==1) then
                 do j=1,nf
                    if(damToSire(j)==i) exit
                 enddo
                 offspPerDam(j)=offspPerSire(i,gene,1)
              else
                 do j=1,nf
                    if(damToSire(j)==i) then
                       l=l+1
                       if(l<damPerSire(i,gene,1)) then
                          k=damPerSire(i,gene,1)-l ! Number of dams remaining for sire i after dam j
                          offspPerDam(j)=G05DYF(1,offspPerSire(i,gene,1)-m-k)
                          m=m+offspPerDam(j)
                       else
                          offspPerDam(j)=offspPerSire(i,gene,1)-m-k+1
                       endif
                    endif
                 enddo
              endif
           enddo
        endif
!!$        print*,'OFFSP'
!!$        do i=1,nf
!!$           print*,'OUT',damToSire(i),'   ',offspPerDam(i)
!!$        enddo

        ! If selection, ordering the individuals
        allocate(rang(n(1,gene-1)),rang2(n(2,gene-1)))
        allocate(reserv(sum(n(:,gene-1))))
        if(minval(sel(:,gene-1,1))/=1.) then
           if(maxval(mode_sel(gene-1,:))==2) then
              k=sum(n(:,gene-1))
              r=sum(perf(1:k,1)**2)/k-(sum(perf(1:k,1))/k)**2
              alpha=(sum(gind(1:k,1)**2)/k-(sum(gind(1:k,1))/k)**2)/r
           endif
           allocate(perf_temp(sum(n(:,gene-1))))
           if(mode_sel(gene-1,1)==1) then
              call given_accur(gind,accur(gene-1,1),accur(gene-1,2),reserv,1,n(1,gene-1),&
                   sum(n(:,gene-1)),all,pos_assoc,nqtl,eff_qtl,posqtl)
              k=0; l=0
              do i=1,sum(n(:,gene-1))
                 if(remain(i+sum(n(:,0:gene-2)),2)==1) then
                    k=k+1
                    perf_temp(k)=reserv(i)
                 endif
                 if(remain(i+sum(n(:,0:gene-2)),2)==2) then
                    l=l+1
                    perf_temp(n(1,gene)+l)=reserv(i)
                 endif
              enddo
              if(mode_sel(gene-1,2)==0) then
                 k=0
                 do i=1,sum(n(:,gene-1))
                    if(remain(i+sum(n(:,0:gene-2)),2)==2) then
                       k=k+1
                       perf_temp(k+n(1,gene-1))=perf(i,1)
                    endif
                 enddo
              else if(mode_sel(gene-1,2)==2) then
                 allocate(EBV(sum(n(:,gene-1))+1,1))
                 call computeBLUP(ped_p1(1:sum(n(:,1:gene-1)),:),sum(n(:,gene-1)),EBV,&
                      perf(:,1),alpha,remain)
                 k=0
                 do i=1,sum(n(:,gene-1))
                    if(remain(sum(n(:,gene-2))+i,2)==2) then
                       k=k+1
                       perf_temp(n(1,gene-1)+k)=EBV(1+i,1)
                    endif
                 enddo
                 deallocate(EBV)
              endif
           else if(mode_sel(gene-1,1)==2) then
              allocate(EBV(sum(n(:,gene-1))+1,1))
              call computeBLUP(ped_p1(1:sum(n(:,1:gene-1)),:),sum(n(:,gene-1)),EBV,&
                   perf(:,1),alpha,remain)
              j=0;k=0
              ! Only the EBV of the individuals that are still alive are computed
              do i=1,sum(n(:,gene-1))
                 if(remain(sum(n(:,gene-2))+i,2)==1) then
                    j=j+1
                    perf_temp(j)=EBV(i+1,1)
                 else if(remain(sum(n(:,gene-2))+i,2)==2.and.mode_sel(gene-1,2)==2) then
                    k=k+1
                    perf_temp(n(1,gene-1)+k)=EBV(1+i,1)
                 endif
              enddo
              deallocate(EBV)
              if(mode_sel(gene-1,2)==0) then
                 k=0
                 do i=1,sum(n(:,gene-1))
                    if(remain(i+sum(n(:,0:gene-2)),2)==2) then
                       k=k+1
                       perf_temp(k+n(1,gene-1))=perf(i,1)
                    endif
                 enddo
              else
                 call given_accur(gani,accur(gene-1,1),accur(gene-1,2),reserv,1,n(1,gene-1),&
                      n(2,gene-1),all,pos_assoc,nqtl,eff_qtl,posqtl)
                 k=0
                 do i=1,sum(n(:,gene-1))
                    if(remain(i+sum(n(:,0:gene-2)),2)==2) then
                       k=k+1
                       perf_temp(k+n(1,gene-1))=perf(i,1)
                    endif
                 enddo
              endif
           else
              k=0;l=0
              do i=1,sum(n(:,gene-1))
                 if(remain(i+sum(n(:,0:gene-2)),2)==1) then
                    k=k+1
                    perf_temp(k)=perf(i,1)
                 endif
                 if(mode_sel(gene-1,2)==0.and.remain(i+sum(n(:,0:gene-2)),2)==2) then
                    l=l+1
                    perf_temp(k+n(1,gene-1))=perf(i,1)
                 endif
              enddo
              if(mode_sel(gene-1,2)==1) then
                 call given_accur(gani,accur(gene-1,1),accur(gene-1,2),reserv,1,n(1,gene-1),&
                      n(2,gene-1),all,pos_assoc,nqtl,eff_qtl,posqtl)
                 k=0
                 do i=1,sum(n(:,gene-1))
                    if(remain(i+sum(n(:,0:gene-2)),2)==2) then
                       k=k+1
                       perf_temp(k+n(1,gene-1))=reserv(i)
                    endif
                 enddo
              else if(mode_sel(gene-1,2)==2) then
                 allocate(EBV(sum(n(:,gene-1))+1,1))
                 call computeBLUP(ped_p1(1:sum(n(1:gene-1,:)),:),sum(n(:,gene-1)),EBV,&
                      perf(:,1),alpha,remain)
                 k=0
                 do i=1,sum(n(:,gene-1))
                    if(remain(sum(n(:,gene-2))+i,2)==2) then
                       k=k+1
                       perf_temp(n(1,gene-1)+k)=EBV(1+i,1)
                    endif
                 enddo
                 deallocate(EBV)
              endif
           endif
           call search_best(perf_temp(1:n(1,gene-1)),n(1,gene-1),rang(1:n(1,gene-1)),n(1,gene-1))
           call search_best(perf_temp(1+n(1,gene-1):sum(n(:,gene-1))),n(2,gene-1),&
                rang2(1:n(2,gene-1)),n(2,gene-1))
           deallocate(perf_temp)
        endif
        deallocate(reserv)
        if(sel(1,gene-1,1)==1) then
           do i=1,n(1,gene-1)
              rang(i)=i
           enddo
        endif

        if(sel(2,gene-1,1)==1) then
           do i=1,n(2,gene-1)
              rang2(i)=i
           enddo
        endif

        if(direct_fin==1.and.gene==1) then
           ! Sort the individuals who are potential parents according to their sex
           k=0; l=0
           do i=1,sum(n(:,gene-1))
              if(remain(i,2)==1) then
                 k=k+1
                 all2(:,k,:)=all(:,i,:)
                 gani(k,nbpop+1)=gani(i,1)
                 if(store_cop==1) cop2(:,k,:)=cop(:,i,:)
              else
                 l=l+1
                 all2(:,n(1,0)+l,:)=all(:,i,:)
                 gani(n(1,0)+l,nbpop+1)=gani(i,1)
                 if(store_cop==1) cop2(:,n(1,0)+l,:)=cop(:,i,:)
              endif
           enddo
           all=all2
           gani(1:sum(n(:,0)),1)=gani(1:sum(n(:,0)),nbpop+1)
           if(store_cop==1) cop=cop2
        endif

!!$                print*,'PARENTS SORTED'
        ! Creation of the new generation
        parent=0
        ! Choose the sires
        do i=1,nt
           allocate(verif(offspPerSire(i,gene,1)))
           call G05DYF2(1,sum(n(:,gene)),offspPerSire(i,gene,1),verif)
           do j=1,offspPerSire(i,gene,1)
              if(parent(verif(j),1)==0) then
                 parent(verif(j),1)=rang(i)
                 ped_p1(verif(j)+sum(n(:,0:gene-1)),2)=remain(rang(i)+sum(n(:,0:gene-2)),1)
              else
                 do while (parent(verif(j),1)/=0)
                    verif(j)=G05DYF(1,sum(n(:,gene)))
                 enddo
                 parent(verif(j),1)=rang(i)
                 ped_p1(verif(j)+sum(n(:,0:gene-1)),2)=remain(rang(i)+sum(n(:,0:gene-2)),1)
              endif
           enddo
           deallocate(verif)
        enddo
!!$        print*,'PED_P1 M'!,ped_p1(sum(n(:,0:gene-1))+1:sum(n(:,0:gene)),2)

        ! Choose the dams
!!$        print*,sum(offspPerDam(:)) 
        do i=1,nt
           allocate(schon(offspPerSire(i,gene,1)))
           l=0
           do k=1,sum(n(:,gene))
!!$              print*,'MALE PARENT',k,parent(k,1)
              if(parent(k,1)==rang(i)) then
                 l=l+1
                 schon(l)=k ! storing the number of the offspring of the sire i
              endif
           enddo
           if(damPerSire(i,gene,1)==1) then
              do j=1,nf
                 if(damToSire(j)==i) exit
              enddo
              do k=1,l
                 parent(schon(k),2)=n(1,gene-1)+rang2(j)
                 ped_p1(schon(k)+sum(n(:,0:gene-1)),3)=remain(n(1,gene-1)+rang2(j)+sum(n(:,0:gene-2)),1)
              enddo
           else
              do j=1,nf
                 if(damToSire(j)==i) then
                    allocate(verif(offspPerDam(j)))
!!$                    print*,'FEMALE PARENT',i,j,offspPerDam(j),l
                    verif=0
                    call G05DYF2(1,l,offspPerDam(j),verif) ! choose the offspring of sire i that are also from dam j
!!$                    print*,'VERIF',verif,'   ',i,j,offspPerDam(j),size(verif)
                    do k=1,offspPerDam(j)
!!$                       print*,schon(verif(k)),k,verif(k),rang2(j)
                       if(parent(schon(verif(k)),2)==0) then
                          parent(schon(verif(k)),2)=n(1,gene-1)+rang2(j)
                          ped_p1(schon(verif(k))+sum(n(:,0:gene-1)),3)=remain(n(1,gene-1)+&
                               rang2(j)+sum(n(:,0:gene-2)),1)
                       else
                          do while (parent(schon(verif(k)),2)/=0)
                             verif(k)=G05DYF(1,l)
                          enddo
                          parent(schon(verif(k)),2)=n(1,gene-1)+rang2(j)
                          ped_p1(schon(verif(k))+sum(n(:,0:gene-1)),3)=remain(n(1,gene-1)+&
                               rang2(j)+sum(n(:,0:gene-2)),1)
                       endif
!!$                       print*,'LOOP2',rang(i),nt,j,nf,parent(schon(verif(k)),2),n(1,gene-1)+rang2(j)
                    enddo
                    deallocate(verif)
                 endif
              enddo
           endif
           deallocate(schon)
        enddo
        deallocate(rang,rang2)
        deallocate(offspPerDam,damToSire)
!!$print*,'PED_P1 F'!,ped_p1(sum(n(:,0:gene-1))+1:sum(n(:,0:gene)),3)

        do i=1+sum(n(:,0:gene-1)),sum(n(:,0:gene))
           remain(i,1)=last_ind+i
           if(i<=sum(n(:,0:gene-1))+n(1,gene)) then
              remain(i,2)=1
           else
              remain(i,2)=2
           endif
        enddo
!!$        print*,'PARENT'

        ! Transmitting the genetic material
        if(store_cop==1) then
           call transm(sum(n(:,gene)),nchrom,nloc,all2,all,parent,pos_loc,cop2,cop)
           call mutat(1,sum(n(:,gene)),1,all,all2,cop,cop2)
        else
           call transm_noCop(sum(n(:,gene)),nchrom,nloc,all2,all,parent,pos_loc)
           call mutat_noCop(1,sum(n(:,gene)),all,all2)
        endif
!!$        print*,'MATERIAL TRANSMITTED'
!!$        print*,shape(gind),'    ',shape(gani),'  ', shape(parent)

        call pheno(parent,gind,sum(n(:,gene)),1,polyg,gani,1,envir,perf,all,eff_qtl,nqtl,posqtl,&
             pos_assoc,nrmat_fin,eff_dom)
!!$        print*,'PHENO'
!!$        print*,shape(nrmat_fin),'N',sum(n(:,gene-1)),'N',sum(n(:,gene)),maxval(parent)
        allocate(nrmat(sum(n(:,gene-1)),sum(n(:,gene))))
        allocate(rang(sum(n(:,gene))))
        do i=1,sum(n(:,gene))
           rang(i)=1+0.5*(nrmat_fin(parent(i,1),parent(i,2)))
        enddo
        do i=1,sum(n(:,gene-1))
           do j=1,sum(n(:,gene))
              nrmat(i,j)=0.5*(nrmat_fin(i,parent(j,1))+nrmat_fin(i,parent(j,2)))
           enddo
        enddo

        do i=1,sum(n(:,gene))
           do j=1,sum(n(:,gene))
              nrmat_fin(i,j)=0.5*(nrmat(parent(i,1),j)+nrmat(parent(i,2),j))
              nrmat_fin(j,i)=nrmat_fin(i,j)
           enddo
           nrmat_fin(i,i)=rang(i)
        enddo
        deallocate(rang,nrmat)
!!$print*,'NMAT NEW'

        ! Then the outputs
        test=.FALSE.
        if(gene>time2-gene_ped+1.and.gene<time2) then
!!$           print*,last_ind,id
           do i=1,n(1,gene)
              write(220,*)remain(sum(n(:,0:gene-1))+i,1),ped_p1(sum(n(:,0:gene-1))+i,2:3),last_gen+gene+1,'     0       1'
           enddo
           do i=1+n(1,gene),sum(n(:,gene))
              write(220,*)remain(sum(n(:,0:gene-1))+i,1),ped_p1(sum(n(:,0:gene-1))+i,2:3),last_gen+gene+1,'     0       2'
           enddo
           test=.TRUE.
        else if(gene==time2-gene_ped+1.and.gene/=time2) then
           if(direct_fin==0) then
              do i=1,n(1,gene)
                 write(220,*)remain(sum(n(:,0:gene-1))+i,1),'0               0',last_gen+gene+1,'     0      1'
              enddo
              do i=1+n(1,gene),sum(n(:,gene))
                 write(220,*)remain(sum(n(:,0:gene-1))+i,1),'0               0',last_gen+gene+1,'     0      2'
              enddo
           else
              do i=1,n(1,gene)
                 write(220,*)remain(sum(n(:,0:gene-1))+i,1),ped_p1(sum(n(:,0:gene-1))+i,2:3),last_gen+gene+1,'     0      1'
              enddo
              do i=1+n(1,gene),sum(n(:,gene))
                 write(220,*)remain(sum(n(:,0:gene-1))+i,1),ped_p1(sum(n(:,0:gene-1))+i,2:3),last_gen+gene+1,'     0      2'
              enddo
           endif
           test=.TRUE.
        else if(gene==time2) then
           do i=1,n(1,gene)
              write(220,*)remain(sum(n(:,0:gene-1))+i,1),ped_p1(sum(n(:,0:gene-1))+i,2:3), last_gen+gene+1, '1      1'
           enddo
           do i=1+n(1,gene),sum(n(1:2,gene))
              write(220,*)remain(sum(n(:,0:gene-1))+i,1),ped_p1(sum(n(:,0:gene-1))+i,2:3), last_gen+gene+1, '1      2'
           enddo
           test=.TRUE.
        endif

        if(gene>=time2-gene_perf+1) then
           do i=1,sum(n(1:2,gene))
              write(24,*)remain(sum(n(:,0:gene-1))+i,1), perf(i,1),gind(i,1)
           enddo
           test=.TRUE.
        endif

        if(gene>=time2-gene_typ+1) then
           all2(:,1:sum(n(1:2,gene)),:)=all(:,1:sum(n(1:2,gene)),:)
           if(typing_err==1) call genot_err(1,sum(n(1:2,gene)),all,all2,errSNP,errMST,miss_genot)
           allocate(all4(nmq,sum(n(1:2,gene)),2))
           if(store_cop==1) allocate(cop4(nmq,sum(n(1:2,gene)),2))
           l=0
           do i=1,nmq+nqtl
              if(indic(i)==0) then
                 l=l+1
                 all4(l,1:sum(n(1:2,gene)),:)=all2(i,1:sum(n(1:2,gene)),:)
                 if(store_cop==1) cop4(l,1:sum(n(1:2,gene)),:)=cop(i,1:sum(n(1:2,gene)),:)
              endif
           enddo
           do i=1,sum(n(1:2,gene))
              do k=1,2
                 write(41,*)remain(sum(n(:,0:gene-1))+i,1),k,(all2(j,i,k),j=1,nmq+nqtl)
                 write(48,*)remain(sum(n(:,0:gene-1))+i,1),k,all4(1:nmq,i,k)
                 if(store_cop==1) then
                    write(50,*) remain(sum(n(:,0:gene-1))+i,1),k,cop(1:nmq+nqtl,i,k)
                    write(51,*) remain(sum(n(:,0:gene-1))+i,1),k,cop4(1:nmq,i,k)
                 endif
              enddo
           enddo
           deallocate(all4)
           if(allocated(cop4)) deallocate(cop4)
           test=.TRUE.
        endif
        if(test) then
           id2=id
           id=id+sum(n(1:2,gene))
        endif

        remain(1:sum(n(:,gene-1)),1)=0

     enddo

     if(out_nrm==1) then
        open(778,file='out_nrm')
        do i=1,sum(n(1:2,time2))-1
           write(778,*) nrmat_fin(i,i:sum(n(1:2,time2)))
        enddo
        close(778)
     endif

     allocate(fqall(nmq+nqtl,maxval(nalmax(:))))
     fqall=0
     call stat_freq_1(1,sum(n(1:2,time2)),all,nball,fqall)

     if(f_fqall=='y') then
        do i=1,nmq+nqtl
           do j=1,nball(i,nbpop+1)
              write(10,*)i,j,fqall(i,j),sum(n(1:2,time2))
           enddo
        enddo
     endif

     if(f_fqcop=='y'.and.store_cop==1) then
        allocate(fqcop(nmq+nqtl,ncopmax(1)))
        fqcop=0
        call stat_freq_1(1,sum(n(1:2,time2)),cop,maxcop,fqcop)
        allocate(cop_alef(nmq+nqtl,maxcop(nmq+nqtl,1)))
        cop_alef=0
        do i=1,sum(n(1:2,time2))
           do j=1,2
              do k=1,nmq+nqtl
                 do l=1,nqtl
                    if(k==posqtl(l).and.allp2(k,i,j)==alleff(l)) cop_alef(k,cop(k,i,j))=cop_alef(k,cop(k,i,j))+1
                 enddo
              enddo
           enddo
        enddo
        allocate(coprest(nmq+nqtl))
        coprest=0
        do i=1,nmq+nqtl
           do j=1,maxcop(i,1)
              if(fqcop(i,j)/=0) coprest(i)=coprest(i)+1
           enddo
        enddo
        do ii=1,nmq+nqtl
           do j=1,maxcop(ii,1)
              if(indic(ii)==1) then
                 if(fqcop(ii,j)>0.0001) write(19,'(3(i6,1x),f8.6,1x,i6,1x,i8,1x,i4)')ii,j,&
                      coprest(ii),fqcop(ii,j),cop_alef(ii,j),sum(n(1:2,time2))
              else
                 if(fqcop(ii,j)>0.0001) write(19,'(3(i6,1x),f8.6,1x,i6,1x,i8,1x,i4)')ii,j,&
                      coprest(ii),fqcop(ii,j),zero,sum(n(1:2,time2))
              endif
           enddo
        enddo
        deallocate(fqcop,cop_alef,coprest)
     endif

     if(f_hPIC=='y') then
        allocate(pic(nmq+nqtl))
        call eval_pic(nbpop+1,nball,nmq+nqtl,pic)
        call nbhaplotypes(sum(n(1:2,time2)),all,indic,nmq,nqtl)
        prop_h=real(nb_h)/real(nb_h_init)
        prop_hc=real(nb_hc)/real(nb_hc_init)
        do i=1,nqtl+nmq
           write(13,'(i8,1x,3(i4,1x),f4.2,1x,i4,1x,f4.2,1x,i2,1x,f10.6)')sum(n(1:2,time2)),&
                time+time2,i,nb_h,prop_h,nb_hc,prop_hc,indic(i),pic(i)
        enddo
     endif

     if(f_dl=='y'.or.f_dlq=='y') call LD(lg_chrom,bin,nchrom,nball,nmq,nqtl,&
          sum(n(1:2,time2)),all,fqall,verif_print,1,chr_loc,nloc,pos_loc,time+time2)

     if(f_ibd=='y'.or.f_ibdq=='y') then
        if(store_cop==1) then
           allocate(seg_ibd(maxloc,nchrom,sum(n(1:2,time2)),2),deb(maxloc,nchrom,sum(n(1:2,time2)),2))
           allocate(fin(maxloc,nchrom,sum(n(1:2,time2)),2))
           allocate(seg_qtl(nqtl,sum(n(1:2,time2)),2),nb_seg(sum(n(1:2,time2)),2,nchrom))
           call long_seg(1,sum(n(1:2,time2)),nmq,nqtl,posqtl,cop,seg_ibd,deb,fin,seg_qtl,nb_seg,lg_chrom,chr_QTL,nchrom,dist)
           do i=1,sum(n(1:2,time2))
              do j=1,2
                 if(f_ibd=='y') then
                    do l=1,nchrom
                       do k=1,maxloc
                          if(seg_ibd(k,l,i,j)>0) then
                             write(21,*)last_ind+i,j,k,seg_ibd(k,l,i,j)
                          endif
                       enddo
                    enddo
                 endif
                 if(f_ibdq=='y') then
                    do k=1,nqtl
                       write(22,'(3(i4,1x),f12.7,1x,f6.4,1x,i6)')last_ind+i,j,k,seg_qtl(k,i,j),&
                            fqall(posqtl(k),alleff(k)),time+time2
                    enddo
                 endif
              enddo
           enddo
           deallocate(seg_qtl,seg_ibd,chr_QTL)
           deallocate(nb_seg,deb,fin)
        endif
     endif

     if(f_csg=='y'.and.store_cop==1) then
        allocate(consmoy(nmq+nqtl),varcons(nmq+nqtl))
        call consang(1,sum(n(1:2,time2)),nmq,nqtl,cop,consmoy,varcons)
        do j=1,nmq
           write(23,*)j,consmoy(j),varcons(j),sum(n(1:2,time2)),time+time2
        enddo
     endif


     stop

  else if(typ_pop==3) then

     ! Read a known pedigree for the last generations


     ! Programed by S. Teyssedre and integrated in Ldso by F. Ytournel
     ! Fichier génotype, performance et valeur polygénique
     ! Adapted Fyt
     if(allocated(cop2)) deallocate(cop2)
     if(allocated(all2)) deallocate(all2)
     if(allocated(all4)) deallocate(all4)
     if(allocated(cop4)) deallocate(cop4)

     allocate(reco(nmq+nqtl-1))
     reco=0.
     do i=1,nmq+nqtl-1
        reco(i)=fdinv(dist(i))      ! recombination rates
     enddo

     allocate(nrmat_f(anc1+anc2,anc1+anc2))
     nrmat_f=0
     do i=1,anc1
        nrmat_f(i,1:anc1)=nrmat(i,anc1)
        if(nbpop==2) nrmat_f(i,1+anc1:anc1+anc2)=nrmat2(i,1:anc2)
     enddo
     if(nbpop==2) then
        do i=1,anc2
           nrmat_f(anc1+i,anc1+1:anc1+anc2)=nrmat3(i,1:anc2)
           nrmat_f(anc1+i,1:anc1)=nrmat2(1:anc1,i)
        enddo
     endif
     deallocate(nrmat)
     if(allocated(nrmat2)) deallocate(nrmat2,nrmat3)

!!$     print*,anc1,anc2
     nbgeno=anc1+anc2
     allocate(geno(2*nbgeno,nmq+nqtl))
     if(store_cop==1) allocate(cop_ped(2*nbgeno,nmq+nqtl))
     do i=1,anc1
        do k=1,2
           if(k==1) then
              geno((2*i)-1,:)=all(:,i,k) !Ligne impaire
              if(store_cop==1) cop_ped((2*i)-1,:)=cop(:,i,k)
           else
              geno((2*i),:)=all(:,i,k) !Ligne paire
              if(store_cop==1) cop_ped((2*i),:)=cop(:,i,k)
           endif
        enddo
     enddo
     do i=1,anc2
        do k=1,2
           if(k==1) then
              geno(2*anc1+(2*i)-1,:)=allp2(:,i,k) !Ligne impaire
              if(store_cop==1) cop_ped(2*anc1+(2*i)-1,:)=copp2(:,i,k)
           else
              geno(2*anc1+(2*i),:)=allp2(:,i,k) !Ligne paire
              if(store_cop==1) cop_ped(2*anc1+(2*i),:)=copp2(:,i,k)
           endif
        enddo
     enddo
     deallocate(all)
     if(allocated(allp2)) deallocate(allp2)
     if(allocated(cop)) deallocate(cop)
     if(allocated(copp2)) deallocate(copp2)
!!$print*,geno

     allocate(gind_ped(nbgeno))
     if(nbpop==1) then
        gind_ped(1:nbgeno)=gind(1:nbgeno,1)
     else
        gind_ped(1:anc1)=gind(1:anc1,1)
        gind_ped(1+anc1:nbgeno)=gind(1:anc2,2)
     endif
     deallocate(gind)
     if(allocated(gani)) deallocate(gani)


     ! Fichier autres
     maxall=0
     do i=1,nmq+nqtl
        if(indic(i)==1) maxall=max(maxval(nball(i,:)),maxall) ! Nombre maximal d'allèles au(x) QTL(s)
     enddo
     ! Added Fyt
     deallocate(h2,ratio_polQTL)

     ! Fichier pedigree
     open(2,file='pedig')
     nbped=0
     do
        read(2,*,iostat=io)
        if(io/=0)exit
        nbped=nbped+1
     enddo
     print*,'****** Read pedig file'
     print*,'nbped=',nbped
     nbind=nbped
     ! ----- Création d'un tableau ped(i,j) i=ind j={1,2,3} avec 1=Numéro ind, 2=pere et 3=mere
     rewind(2) ! On revient au début du fichier
     allocate(ped_start(nbped,3))
     do i=1,nbped
        read(2,*) ped_start(i,:)
     enddo
     close(2)
     allocate(ped(nbped,3))
     ped=ped_start

     men=polyg**2
     envi=envir**2
     print*,'Maximum number of alleles at the QTL, maxall=',maxall
!!$     do i=1,nqtl
!!$        print*,'Position QTL ',i,':',posqtl(i)
!!$     enddo
     print*,'mendel=',men
     print*,'envir=',envi

     allocate(allqtl(nqtl,maxall))
     do i=1,nqtl
        allqtl(i,:)=eff_qtl(i,:)
     enddo
     deallocate(eff_qtl)

     allocate(position(nmq+nqtl))
     allocate(chromosome(nmq+nqtl))
     allocate(location(nmq+nqtl))
     k=0
     l=0
     do i=1,nchrom
        do j=1,nloc(i)
           if(typ_loc(j,i)==1) then
              k=k+1
              chromosome(k)=i
              location(k)=j
              position(k)=pos_loc(j,i)
           endif
        enddo
        l=l+nloc(i)
     enddo
     deallocate(typ_loc)

     ! -----------------------------------------------------------------------------------------
     ! ---------------------------------     Programme principal    ----------------------------
     ! -----------------------------------------------------------------------------------------
     print*,'----------  Initialisation ------------------------------------------'
     !Affichage du pedigree
     !print*,'Pedigree :'
     !call affiche(ped,nbped,3)
     ! ----- Stockage fondateur dans le vecteur fond
     cpt1=1
     allocate(fond(nbped),rang2(nbped))
     ! Initialisation de fond à 0
     fond=0
     ! Incrémentation de fond
     do i=1,nbped
        cpt=0
        do j=2,3
           if(ped(i,j)==0) then
              cpt=cpt+1
           endif
        enddo
        if(cpt==2) then
           fond(cpt1)=ped(i,1)
           rang2(cpt1)=1
           cpt1=cpt1+1
        endif
     enddo
     nbfond=cpt1-1
     print*, 'Number of pedigree founders found:', cpt1-1

     !print*, 'Vecteur des individus fondateurs:'
     !call affiche(fond,nbped,1)
     ! ----- Modification du tableau ped, on enleve les lignes des fondateurs
!!$     print*, 'Modification du tableau pedigree (on enlève les fondateurs):'
     cpt=1
     allocate(pednew(nbped-nbfond,3))
     do i=1,nbped
        boolped=0
        do j=1,nbfond
           if(fond(j)==ped(i,1)) then
              boolped=boolped+1
           endif
        enddo
        if(boolped==0) then
           pednew(cpt,:)=ped(i,:)
           cpt=cpt+1
        endif
     enddo
     deallocate(ped)
     allocate(ped(nbped-nbfond,3))
     ped=pednew
     deallocate(pednew)
     ! On recalcule le nbped
     nbped=size(ped(:,1))
     !print*,'Pedigree :'
     !call affiche(ped,nbped,3)
     ! ----- Création d'un fichier ped2 qui prépare les descendants des fondateurs, génération suivante
!!$     print*,'Préparation du fichier pedigree pour la génération suivante: '
     allocate(ped2(nbped,3))
     ped2=ped
     ! Calcul nombre d'éléments de nbfond (différents de 0)
     cpt=0
     i=0
     do while(i==0)
        if(fond(cpt+1)/=0) then
           cpt=cpt+1
        else
           i=1
        endif
     enddo
     nbfond=cpt
     !print*,'nbfond= ',nbfond
     ! Création de ped2
     do i=1,nbfond
        do h=1,nbped
           do j=2,3
              if(ped(h,j)==fond(i)) then 
                 ped2(h,j)=0
              endif
           enddo
        enddo
     enddo
     !call affiche(ped2,nbped,3)
     ! --------------- Partage du fichier geno et gind en deux parties (moitié geno_père et moitié geno_mère)
     print*,'Number of historical genotypes:',nbgeno
     nbpere=nbgeno/2
     !print*,'nbpere=',nbpere
     nbmere=nbgeno-nbpere
     !print*,'nbmere=',nbmere
     ! Partie génotype
     allocate(geno_pere(2*nbpere,nmq+nqtl))
     allocate(geno_mere(2*nbmere,nmq+nqtl))
     if(store_cop==1) then
        allocate(cop_pere(2*nbpere,nmq+nqtl))
        allocate(cop_mere(2*nbmere,nmq+nqtl))
     endif
     do i=1,(2*nbpere)
        geno_pere(i,:)=geno(i,:)
        if(store_cop==1) cop_pere(i,:)=cop_ped(i,:)
     enddo
     do i=1,(2*nbmere)
        geno_mere(i,:)=geno(i+(2*nbpere),:)
        if(store_cop==1) cop_mere(i,:)=cop_ped(i+(2*nbpere),:)
     enddo
     ! Partie valeur polygénique gind
     allocate(gind_pere(nbpere))
     allocate(gind_mere(nbmere))
     do i=1,nbpere
        gind_pere(i)=gind_ped(i)
     enddo
     do i=1,nbmere
        gind_mere(i)=gind_ped(i+nbpere)
     enddo

     ! --------------- Création des indices aléatoires pour associer des génotypes aux fondateurs
!!$print*,nbfond
     allocate(indgeno_pere(nbfond))
     allocate(indgeno_mere(nbfond))
     ! modified Fyt
     call G05DYF2(1,nbpere,nbfond,indgeno_pere)
     call G05DYF2(1,nbmere,nbfond,indgeno_mere)
     ped_start(1:nbfond,2)=indgeno_pere(1:nbfond)
     ped_start(1:nbfond,3)=indgeno_mere(1:nbfond)
!!$           do i=1,nbfond
!!$              indgeno_pere(i)=G05DYF(1,nbpere)
!!$              indgeno_mere(i)=G05DYF(1,nbmere)
!!$           enddo

     ! --------------- On associe des génotypes à nos fondateurs (dans geno2)
     allocate(geno2(2*nbfond,nmq+nqtl))
     if(store_cop==1) allocate(cop_ped2(2*nbfond,nmq+nqtl))
     do i=1,nbfond
        ! Tirage aléatoire de l'haplotype 1 ou 2
        hp=G05DYF(1,2)
        hm=G05DYF(1,2)
        !print*,'indgeno_pere(i)=',indgeno_pere(i)
        !print*,'Haplotype père choisi :',hp
        !print*,'indgeno_mere(i)=',indgeno_mere(i)
        !print*,'Haplotype mère choisi :',hm
        ! D'abord pour l'haplotype reçu du père
        if(hp==1) then !haplotype paternel
           geno2((2*i)-1,:)=geno_pere((2*indgeno_pere(i))-1,:)
           if(store_cop==1) cop_ped2((2*i)-1,:)=cop_pere((2*indgeno_pere(i))-1,:)
        else !haplotype maternel
           geno2((2*i)-1,:)=geno_pere((2*indgeno_pere(i)),:)
           if(store_cop==1) cop_ped2((2*i)-1,:)=cop_pere((2*indgeno_pere(i)),:)
        endif
        ! Puis celui de la mère
        if(hm==1) then !haplotype paternel
           geno2((2*i),:)=geno_mere((2*indgeno_mere(i))-1,:)
           if(store_cop==1) cop_ped2((2*i),:)=cop_mere((2*indgeno_mere(i))-1,:)
        else !haplotype maternel
           geno2((2*i),:)=geno_mere((2*indgeno_mere(i)),:)
           if(store_cop==1) cop_ped2((2*i),:)=cop_mere((2*indgeno_mere(i)),:)
        endif
     enddo
     print*,'Haplotypes of the pedigree founders: OK '

     !---------- Création du tableau effqtl (2*nbind,nqtl) à partir de geno2
     allocate(effqtltemp(2*nbfond,nqtl))
     allocate(effqtl(2*(nbped+nbfond),nqtl))
     effqtl=0
     ! On crée un fichier avec 2n lignes et nqtl colonnes contenant les allèles pour chq ind et chq haplo
     do i=1,nqtl
        effqtltemp(:,i)=geno2(:,posqtl(i))
     enddo
     ! Maintenant on transforme les allèles en effet QTL à partir du tableau allqtl
     do i=1,(2*nbfond)
        do j=1,nqtl
           k=effqtltemp(i,j)
           effqtl(i,j)=allqtl(j,k)
        enddo
     enddo
     deallocate(effqtltemp)

     ! Step to compute the whole relationship matrix
     print*,'Computing the whole relationship matrix'
     print*,'If the individuals were not sorted, there may be problems!'
     allocate(nrmat_fin(nbind+nbgeno,nbind+nbgeno))
     nrmat_fin=-1
     do i=1,nbfond
        do j=i+1,nbfond
           nrmat_fin(i,j)=nrmat_f(i,j)
           nrmat_fin(j,i)=nrmat_fin(i,j)
        enddo
     enddo
     deallocate(nrmat_f)

     ! ------------ On peut alors calculer les performances des individus fondateurs
     ! A l'aide de gind_pere et gind_mere pour calculer les gind2 (cad les gind fondateurs)
     ! Plus à l'aide de effqtl (effet QTL des fondateurs)  
     allocate(perf_ped2(nbped+nbfond))
     allocate(gind_ped2(nbped+nbfond))
     perf_ped2=0
     gind_ped2=0
     do i=1,nbfond
        ! Création de gind_temp (stocke les valeurs polygéniques des parents de i)
        allocate(gind_temp(2))
        gind_temp(1)=gind_pere(indgeno_pere(i))
        gind_temp(2)=gind_mere(indgeno_mere(i))
        ! Calcul du phénotype du descendant
        gindnew=0.0
        perform=0.0
        call pheno_ped(i,effqtl,gind_temp,men,envi,nqtl,gindnew,perform,nrmat_fin,&
             allqtl,geno,eff_dom,pos_assoc,indgeno_pere(i),indgeno_mere(i)+nbpere,i)
        ! Récupération des sorties de la fonction phéno
        perf_ped2(i)=perform
        gind_ped2(i)=gindnew
        deallocate(gind_temp)
     enddo
!!$     print*,'Performances des fondateurs : OK !'
!!$     print*,'Valeurs polygéniques des fondateurs : OK !'
     deallocate(indgeno_pere,indgeno_mere,geno)


     id=max(nbfond,nbgeno); id2=nbfond
!!$     print*,nbfond
     ! Test si le fichier est vide
     if (size(ped(:,1))==0) then
        print*,'Pedigree file now completely treated' !Le fichier pedigree est maintenant vide'
!!$        print*,'ICI JE DOIS CREER LA SORTIE POUR CE CAS LA'
        bool=1
     else
        print*,'There are individuals remanining in the pedigree: iterative process starts' !Il reste des individus dans le fichier pedigree, on lance un processus itératif'
        bool=0
     endif


     ! ************************  Fin étape initialisation
!!$     print*,'----------  Fin étape initialisation --------------------------------------'
!!$     print*,''
!!$     print*,''
!!$     print*,'----------  Etape itérative -----------------------------------------------'
     ! ***** Tant qu'il reste des individus
     do while(bool==0)
        print*,'------- iteration : ',boolcpt,id,size(ped(:,1))
        ! Calcul nbped
        nbped=size(ped(:,1))
        print*,'Number of individuals remaining in the pedigree: ',nbped
        ! ----- Stockage des descendants de la génération connue dans le tableau temp
        ! Calcul de nbtemp
        cpt=1
        nbtemp=0
        do i=1,nbped
           cpt1=0
           do j=2,3
              if(ped2(i,j)==0) cpt1=cpt1+1
           enddo
!!$           print*,i,cpt1
           if(cpt1==2) nbtemp=nbtemp+1  !Cas où i est un descendant de la géné d'avant (i.e. nouveau fondateur)
        enddo
!!$        print*,'Nombre de nouveaux Fondateurs :',nbtemp
        ! Allocation nbtemp
        allocate(tempped(nbtemp,3))
        ! Remplissage de nbtemp
        do i=1,nbped
           cpt1=0
           do j=2,3
              if(ped2(i,j)==0)then
                 cpt1=cpt1+1
              endif
           enddo
           if(cpt1==2) then
              !Cas où i est un descendant
              tempped(cpt,:)=ped(i,:)
              cpt=cpt+1
           endif
        enddo
!!$        print*,'Nombre de nouveaux Fondateurs :',nbtemp
        !print*,'La génération suivante est composée des individus :'
        !call affiche(tempped,nbtemp,3)
        ! Boucle principale de cette étape, qui calcule les transmissions des individus de tempped
        do i=1,nbtemp
           ! Allocation des génotypes parentaux, 2 parents et 2 haplotypes donc 4 lignes dans le fichier
           allocate(geno_temp(4,nmq+nqtl))
           if(store_cop==1) allocate(cop_temp(4,nmq+nqtl))
           allocate(gind_temp(2))
           do j=2,3 !Boucle sur père=2, mère=3
              k=tempped(i,j)
              !print*,'j=',j
              !print*,'tempped(i,j)=k=',k
              if(k==0)then ! Non présent (fondateur)
                 k1=0 
              else ! Cas ou l'individu est disponible
                 !Prend l'élément tq fond(k1)=k
                 cpt=0
                 cpt1=1
                 do while (cpt==0)
                    if(fond(cpt1)==k) then
                       cpt=1 !Sortie de boucle
                    else
                       cpt1=cpt1+1 !Passage élément suivant de la liste des fondateurs
                    endif
                 enddo
                 k1=cpt1
                 !print*,'fond(k1)=k donc k1=',k1
              endif
              if(j==2)then !Pere de l'individu temp(i)
                 if(k1==0)then !Cas où le père est un 0
                    h1=G05DYF(1,nbpere)
                    ped_start(id2+i,2)=h1
!!$print*,'PARENT INCONNU',id,i,h1,ped_start(id+i,2)
                    !print*,'Tirage aléatoire du génotype père numéro =',h1
                    ! Stockage du génotype de l'individu h1 dans geno_temp (individu 1 donc ligne 1-2)
                    geno_temp(1,:)=geno_pere((2*h1)-1,:)
                    geno_temp(2,:)=geno_pere((2*h1),:)
                    if(store_cop==1) then
                       cop_temp(1,:)=cop_pere((2*h1)-1,:)
                       cop_temp(2,:)=cop_pere((2*h1),:)
                    endif
                    gind_temp(1)=gind_pere(h1)
                 else ! Cas où le père est connu
                    ! On va chercher le geno dans geno2
                    geno_temp(1,:)=geno2((2*k1)-1,:)
                    geno_temp(2,:)=geno2((2*k1),:)
                    if(store_cop==1) then
                       cop_temp(1,:)=cop_ped2((2*k1)-1,:)
                       cop_temp(2,:)=cop_ped2((2*k1),:)
                    endif
                    gind_temp(1)=gind_ped2(k1)
                 endif
              else ! Mere de l'individu temp(i)
                 if(k1==0)then !Cas où la mère est un 0
                    h1=G05DYF(1,nbmere)
                    ped_start(id2+i,3)=h1
!!$print*,'PARENT INCONNU',id,i,h1
                    !print*,'Tirage aléatoire du génotype mère numéro =',h1
                    ! Stockage du génotype de l'individu h1 dans geno_temp (individu 2 donc ligne 3-4)
                    geno_temp(3,:)=geno_mere((2*h1)-1,:)
                    geno_temp(4,:)=geno_mere((2*h1),:)
                    if(store_cop==1) then
                       cop_temp(3,:)=geno_mere((2*h1)-1,:)
                       cop_temp(4,:)=geno_mere((2*h1),:)
                    endif
                    gind_temp(2)=gind_mere(h1)
                 else ! Cas où la mère est connue
                    ! On va chercher le geno dans geno2
                    geno_temp(3,:)=geno2((2*k1)-1,:)
                    geno_temp(4,:)=geno2((2*k1),:)
                    if(store_cop==1) then
                       cop_temp(3,:)=cop_ped2((2*k1)-1,:)
                       cop_temp(4,:)=cop_ped2((2*k1),:)
                    endif
                    gind_temp(2)=gind_ped2(k1)
                 endif
              endif
           enddo
!!$           print*,i,geno_temp
           do k=1,id+i
              j=id+i
              l=id2+i
!!$              print*,k,j,shape(nrmat_fin),shape(ped_start),l
              nrmat_fin(k,j)=0.5*(nrmat_fin(k,ped_start(l,2))+nrmat_fin(k,ped_start(l,3)))
              nrmat_fin(j,k)=nrmat_fin(k,j)
           enddo
           nrmat_fin(id+i,id+i)=nrmat_fin(ped_start(id2+i,2),ped_start(id2+i,3))/2+1
           do j=1,i-1
              nrmat_fin(id+i,id+j)=0.5*(nrmat_fin(id+i,ped_start(id2+j,2))+&
                   nrmat_fin(id+i,ped_start(id2+j,3)))
              nrmat_fin(id+j,id+i)=nrmat_fin(id+i,id+j)
           enddo
!!$           do j=1,i-1
!!$              if(nrmat_fin(id2+i,id2+j)==-1) print*,'-1',id2+i,id2+j,ped_start(id2+i,:),&
!!$                   ped_start(id2+j,:)
!!$           enddo

           allocate(geno_temp2(2,nmq+nqtl))
           if(store_cop==1) allocate(cop_temp2(2,nmq+nqtl))
           ! -- Transmission entre les 2 parents et le descendant et stockage résultat dans geno_temp2
           if(store_cop==1) then
              call transm1(geno_temp,geno_temp2,cop_temp,cop_temp2)
           else
              call transm1_noCop(geno_temp,geno_temp2)
           endif
!!$           print*,geno_temp2
           ! -- Incrémentation du descendant comme un nouveau fondateur dans fond et geno2
           ! Calcul nbgeno et nbfond
           nbgeno2=size(geno2(:,1))/2
           ! Calcul nombre d'éléments de nbfond (différents de 0)
           cpt=0
           cpt1=0
           do while(cpt1==0)
              if(fond(cpt+1)/=0) then
                 cpt=cpt+1
              else
                 cpt1=1
              endif
           enddo
           nbfond=cpt
           !print*,'nbfond=',nbfond
           ! Incrémentation
           deallocate(geno_temp)
           if(store_cop==1) deallocate(cop_temp)
           allocate(geno_temp(2*nbgeno2,nmq+nqtl))
           if(store_cop==1) allocate(cop_temp(2*nbgeno2,nmq+nqtl))
           geno_temp=geno2
           if(store_cop==1) cop_temp=cop_ped2
           deallocate(geno2)
           if(store_cop==1) deallocate(cop_ped2)
           allocate(geno2(2*(nbgeno2+1),nmq+nqtl))
           if(store_cop==1) allocate(cop_ped2(2*(nbgeno2+1),nmq+nqtl))
           do j=1,nbgeno2
              geno2((2*j)-1,:)=geno_temp((2*j)-1,:)
              geno2((2*j),:)=geno_temp((2*j),:)
              if(store_cop==1) then
                 cop_ped2((2*j)-1,:)=cop_temp((2*j)-1,:)
                 cop_ped2((2*j),:)=cop_temp((2*j),:)
              endif
           enddo
           geno2((2*(nbgeno2+1))-1,:)=geno_temp2(1,:)
           geno2((2*(nbgeno2+1)),:)=geno_temp2(2,:)
           if(store_cop==1) then
              cop_ped2((2*(nbgeno2+1))-1,:)=cop_temp2(1,:)
              cop_ped2((2*(nbgeno2+1)),:)=cop_temp2(2,:)
           endif
           fond(nbfond+1)=tempped(i,1)
           rang2(nbfond+1)=boolcpt+2
           nbfond=nbfond+1
           ! ----- Calcul de l'effet des QTLs sur le descendant et stockage dans effqtl
           allocate(effqtltemp(2,nqtl))
           ! On crée un fichier avec 2n lignes et nqtl colonnes contenant les allèles pour chq ind et chq haplo
           do j=1,nqtl
              effqtltemp(:,j)=geno_temp2(:,posqtl(j))
!!$              print*,geno_temp2(:,posqtl(j)),j
           enddo
           ! Maintenant on transforme les allèles en effet QTL à partir du tableau allqtl
           do j=1,2
              do k=1,nqtl
                 cpt=effqtltemp(j,k)
                 if(j==1) then
                    effqtl((2*nbfond)-1,k)=allqtl(k,cpt)
                 else !j==2
!!$                    print*,k,cpt,j
                    effqtl((2*nbfond),k)=allqtl(k,cpt)
                 endif
              enddo
           enddo
           ! ------ Calcul du phénotype du descendant et stockage dans perf2
           gindnew=0.0
           perform=0.0
           m=nbgeno2+1
           call pheno_ped(id2+i,effqtl,gind_temp,men,envi,nqtl,gindnew,perform,nrmat_fin,&
                allqtl,geno2,eff_dom,pos_assoc,ped_start(id2+i,2),ped_start(id2+i,3),m)
           ! Récupération des sorties de la fonction phéno
           perf_ped2(nbfond)=perform !Car nbfond a été incrémenté
           gind_ped2(nbfond)=gindnew !Car nbfond a été incrémenté
           !Desallocation pour étape suivante
           deallocate(geno_temp,geno_temp2,gind_temp,effqtltemp)
           if(allocated(cop_temp)) deallocate(cop_temp,cop_temp2)
        enddo
        id2=id2+nbped ; id=id+nbped

        ! ---- Modification de ped et création de ped2
        ! Modification de ped
!!$        print*,'Performances des nouveaux fondateurs : OK !'
!!$        print*,'Valeurs polygéniques des nouveaux fondateurs : OK !'
        cpt=1
        allocate(pednew(nbped-nbtemp,3))
        do h=1,nbped
           boolped=0
           do j=1,nbfond
              if(fond(j)==ped(h,1)) then
                 boolped=boolped+1
              endif
           enddo
           if(boolped==0) then
              pednew(cpt,:)=ped(h,:)
              cpt=cpt+1
           endif
        enddo
        deallocate(ped,ped2)
        allocate(ped(nbped-nbtemp,3))
        allocate(ped2(nbped-nbtemp,3))
        ped=pednew
        ped2=ped
        deallocate(pednew)
        nbped=size(ped(:,1))
        !Création de ped2
        do cpt=1,nbfond
           do h=1,nbped
              do j=2,3
                 if(ped(h,j)==fond(cpt)) then 
                    ped2(h,j)=0
                 endif
              enddo
           enddo
        enddo
        ! Affichage
        !if(nbped/=0)then
        ! print*,'Pedigree:'
        ! call affiche(ped,nbped,3)
        ! print*,'Pedigree pour génération suivante:'
        ! call affiche(ped2,nbped,3)
        !endif
        ! ----- Test si ped est vide
!!$        print*,size(ped(:,1))
        if (size(ped(:,1))==0) then
           print*,'The pedigree file is now completely treated' !Le fichier pedigree est maintenant vide'
           bool=1
        else
           boolcpt=boolcpt+1
           bool=0
        endif
        id2=id2-size(ped(:,1))
        id=id-size(ped(:,1))
!!$print*,ped
!!$print*,bool,boolcpt,id,nbped
        ! Deallocation pour génération suivante
        deallocate(tempped)
!!$        print*,'---------------------------------------------------------'
     enddo

     ! ---- Affichage 
     !print*,'Valeur polygénique :'
     !call affiche_r(gind2,nbind,1)
     !print*,'Performances :'
     !call affiche_r(perf2,nbind,1)
     !print*,'Effet qtl :'
     !call affiche_r(effqtl,(2*nbind),nqtl)
     ! Les génotypes sont stockés dans geno2
     ! Ecriture de geno dans test1
     nbgeno2=size(geno2(:,1))/2
     !print*,'Nombre individus genotypés, nbgeno2=',nbgeno2

     !********* Fin de mon programme principal
!!$     print*,'----------  Fin étape itérative -------------------------------------------'
!!$     print*,''
!!$     print*,'----------  Début sortie fichiers -----------------------------------------------'

     open(48,file='simhaploNoQTL')
     open(41,file='simhaplo')
     open(220,file='simped')
     open(24,file='simperf')
     open(78,file='genotyp_err')
     if(store_cop==1) then
        open(50,file='simcop')
        open(51,file='simcopNoQTL')
     endif

     allocate(all(nmq+nqtl,nbind,2))
     if(store_cop==1) allocate(cop(nmq+nqtl,nbind,2))
     j=0
     do i=1,nbind
        do k=1,2
           j=j+1
           all(:,i,k)=geno2(j,:)
           if(store_cop==1) cop(:,i,k)=cop_ped2(j,:)
        enddo
     enddo
     allocate(all2(nmq+nqtl,nbind,2))
     allocate(allp2(nmq+nqtl,nbind,2))
     allp2=all
     if(typing_err/=0) call genot_err(1,nbind,all2,all,errSNP,errMST,miss_genot)
     deallocate(all2)
     if(store_cop==1) allocate(cop2(nmq,nbind,2))
     allocate(all2(nmq,nbind,2))
     j=0
     do i=1,nmq+nqtl
        if(indic(i)==1) then
           j=j+1
        else
           all2(i-j,:,:)=all(i,:,:)
           if(store_cop==1) cop2(i-j,:,:)=cop(i,:,:)
        endif
     enddo

     do i=1,nbind
        if(rang2(i)==boolcpt+1) then
           write(220,*) ped_start(fond(i),:),rang2(i), '1'
        else
           write(220,*) ped_start(fond(i),:),rang2(i), '0'
        endif
        write(24,*) fond(i), perf_ped2(i), gind_ped2(i)
        do k=1,2
           write(41,*) fond(i),k, all(:,i,k)
           write(48,*) fond(i),k, all2(:,i,k)
           if(store_cop==1) then
              write(50,*) fond(i),k, cop(:,i,k)
              write(51,*) fond(i), cop2(:,i,k)
           endif
        enddo
     enddo

     allocate(fqall(nmq+nqtl,maxval(nalmax(:))))
     fqall=0
     call stat_freq_1(1,nbind,allp2,nball,fqall)

     if(f_fqall=='y') then
        do i=1,nmq+nqtl
           do j=1,nball(i,nbpop+1)
              write(10,*)i,j,fqall(i,j),nbind,'REAL PEDIGREE'
           enddo
        enddo
     endif

     if(f_fqcop=='y'.and.store_cop==1) then
        allocate(fqcop(nmq+nqtl,ncopmax(1)))
        fqcop=0
        call stat_freq_1(1,nbind,cop,maxcop,fqcop)
        allocate(cop_alef(nmq+nqtl,maxcop(nmq+nqtl,1)))
        cop_alef=0
        do i=1,nbind
           do j=1,2
              do k=1,nmq+nqtl
                 do l=1,nqtl
                    if(k==posqtl(l).and.allp2(k,i,j)==alleff(l)) cop_alef(k,cop(k,i,j))=cop_alef(k,cop(k,i,j))+1
                 enddo
              enddo
           enddo
        enddo
        allocate(coprest(nmq+nqtl))
        coprest=0
        do i=1,nmq+nqtl
           do j=1,maxcop(i,1)
              if(fqcop(i,j)/=0) coprest(i)=coprest(i)+1
           enddo
        enddo
        do ii=1,nmq+nqtl
           do j=1,maxcop(ii,1)
              if(indic(ii)==1) then
                 if(fqcop(ii,j)>0.0001) write(19,'(3(i6,1x),f8.6,1x,i6,1x,i8,1x,i4)')ii,j,&
                      coprest(ii),fqcop(ii,j),cop_alef(ii,j),nbind,'REAL PEDIGREE'
              else
                 if(fqcop(ii,j)>0.0001) write(19,'(3(i6,1x),f8.6,1x,i6,1x,i8,1x,i4)')ii,j,&
                      coprest(ii),fqcop(ii,j),zero,nbind,'REAL PEDIGREE'
              endif
           enddo
        enddo
        deallocate(fqcop,cop_alef,coprest)
     endif

     if(f_hPIC=='y') then
        allocate(pic(nmq+nqtl))
        call eval_pic(nbpop+1,nball,nmq+nqtl,pic)
        call nbhaplotypes(nbind,allp2,indic,nmq,nqtl)
        prop_h=real(nb_h)/real(nb_h_init)
        prop_hc=real(nb_hc)/real(nb_hc_init)
        do i=1,nqtl+nmq
           write(13,'(i8,1x,3(i4,1x),f4.2,1x,i4,1x,f4.2,1x,i2,1x,f10.6)')nbind,&
                time+boolcpt,i,nb_h,prop_h,nb_hc,prop_hc,indic(i),pic(i)
        enddo
     endif

     if(f_dl=='y'.or.f_dlq=='y') call LD(lg_chrom,bin,nchrom,nball,nmq,nqtl,&
          nbind,allp2,fqall,verif_print,1,chr_loc,nloc,pos_loc,time+boolcpt)

     if(f_ibd=='y'.or.f_ibdq=='y') then
        if(store_cop==1) then
           allocate(seg_ibd(maxloc,nchrom,nbind,2),deb(maxloc,nchrom,nbind,2),fin(maxloc,nchrom,nbind,2))
           allocate(seg_qtl(nqtl,nbind,2),nb_seg(nbind,2,nchrom))
           call long_seg(1,nbind,nmq,nqtl,posqtl,cop,seg_ibd,deb,fin,seg_qtl,nb_seg,lg_chrom,chr_QTL,nchrom,dist)
           do i=1,nbind
              do j=1,2
                 if(f_ibd=='y') then
                    do l=1,nchrom
                       do k=1,maxloc
                          if(seg_ibd(k,l,i,j)>0) then
                             write(21,*)i,j,k,seg_ibd(k,l,i,j)
                          endif
                       enddo
                    enddo
                 endif
                 if(f_ibdq=='y') then
                    do k=1,nqtl
                       write(22,'(3(i4,1x),f12.7,1x,f6.4,1x,i6)')k,seg_qtl(k,i,j),&
                            fqall(posqtl(k),alleff(k)),time+boolcpt
                    enddo
                 endif
              enddo
           enddo
           deallocate(seg_qtl,seg_ibd,chr_QTL)
           deallocate(nb_seg,deb,fin)
        endif
     endif

     if(f_csg=='y'.and.store_cop==1) then
        allocate(consmoy(nmq+nqtl),varcons(nmq+nqtl))
        call consang(1,nbind,nmq,nqtl,cop,consmoy,varcons)
        do j=1,nmq
           write(23,*)j,consmoy(j),varcons(j),nbind,time+boolcpt
        enddo
     endif

     stop

  else if(typ_pop==1) then

     nanc=anc1
     anc2=0
     tail=max(nanc,4*nt,2*nf*nt)
     allocate(all2(nmq+nqtl,nanc+3*nt+2*nf*nt,2),all3(nmq+nqtl,nanc+3*nt+2*nf*nt,2))
     if(store_cop==1) allocate(cop3(nmq+nqtl,nanc+3*nt+2*nt*nf,2),&
          cop2(nmq+nqtl,nanc+3*nt+2*nf*nt,2))
     do i=1,nmq+nqtl
        nball(i,nbpop+1)=nball(i,1)
        if(store_cop==1) maxcop(i,nbpop+1)=maxcop(i,1)
        if(store_cop==1) ncopmax(nbpop+1)=ncopmax(nbpop)
        nalmax(nbpop+1)=maxval(nball(:,nbpop+1))
     enddo
     toto=nalmax(nbpop+1)
     deallocate(gani)
     allocate(gani(tail,nbpop+1))
     gani=0
     polyg=sqrt(sum(gind(1:nanc,1)**2)/real(nanc)-&
          (sum(gind(1:nanc,1))/real(nanc))**2)

     do i=1,nanc
        all3(:,i,:)=all(:,i,:)
        if(store_cop==1) cop3(:,i,:)=cop(:,i,:)
        gani(i,1)=gind(i,1)
     enddo
     deallocate(all)
     if(store_cop==1) deallocate(cop)

!!$     polyg=sqrt((sum(gani(:,1)**2)-(sum(gani(:,1)))**2/real(nanc))/real(nanc))
     allocate(nrmat_fin(nanc,nanc))
     nrmat_fin=0
     nrmat_fin(1:nanc,1:nanc)=nrmat(1:nanc,1:nanc)
     deallocate(nrmat)

     allocate(fqall(nmq+nqtl,nalmax(nbpop+1)))
     fqall=0
     call stat_freq_1(1,nanc,all3,nball,fqall)

     if(nbpop==2) then
        if(f_hPIC=='y') then
           allocate(pic(nmq+nqtl))
           call eval_pic(nbpop+1,nball,nmq+nqtl,pic)
           call nbhaplotypes(nanc,all3,indic,nmq,nqtl)
           nb_h_init=nb_h
           nb_hc_init=nb_hc
           prop_h=real(nb_h)/real(nb_h_init)
           prop_hc=real(nb_hc)/real(nb_hc_init)
           do i=1,nqtl+nmq
              write(13,'(i8,1x,3(i4,1x),f4.2,1x,i4,1x,f4.2,1x,i2,1x,f10.6)')nanc,&
                   time,i,nb_h,prop_h,nb_hc,prop_hc,indic(i),pic(i)
           enddo
           deallocate(pic)
           print*,'F5'
        endif
     endif

     if(direct_fin==0) then
        allocate(ped_p1(nanc,3),remain(nanc,2))
        ped_p1=0
        do i=1,nanc
           ped_p1(i,1)=i
           remain(i,1)=i
           if(i<=nint(real(nanc)/2.)) then
              remain(i,2)=1
           else
              remain(i,1)=2
           endif
        enddo
     endif

     allocate(reserv(size(remain,1)+1))
     reserv=0; j=0
     do i=1,nanc
        do k=1,size(remain,1)
           if(remain(k,1)==i) then
              j=j+1
              reserv(j)=perf(i,1)
           endif
        enddo
     enddo

     if(direct_fin==1) then
        tail=size(remain,1)
        nr=count(any(remain==1,2)) ! Number of males in the remaining individuals
        tail_port=tail-nr ! Number of females in the remaining individuals
     else
        tail=nanc
        nr=nint(real(tail)/2.)
        tail_port=tail-nr
     endif

     ! Ordering of the individuals from the historical population
     deallocate(gind)
     allocate(gind(tail,nbpop+1))
     allocate(perf_temp(nanc),rang(nanc))
     rang=0
     if(minval(selection(1,1,:))/=1.) then
        if(maxval(mode_sel)==2) then
           r=(sum(perf(:,1)**2)/nanc)-(sum(perf(:,1))/nanc)**2
           alpha=(sum(gind(:,1)**2)/nanc)-(sum(gind(:,1))/nanc)**2/r
        endif
        if(mode_sel(1,1)==1) then
           call given_accur(gani,accur(1,1),accur(1,2),reserv,1,nr,&
                nr+tail_port,all3,pos_assoc,nqtl,eff_qtl,posqtl)
           k=0
           do i=1,size(remain,1)
              if(remain(i,2)==1) then
                 k=k+1
                 perf_temp(k)=reserv(i)
              endif
           enddo
           if(mode_sel(1,2)==0) then
              k=0
              do i=1,size(remain,1)
                 if(remain(i,2)==2) then
                    k=k+1
                    perf_temp(k+nr)=reserv(i)
                 endif
              enddo
           else if (mode_sel(1,2)==2) then
              allocate(EBV(tot_pop_fin(1)-nt*(2*nf+1)+1,1))
              call computeBLUP(ped_p1,tot_pop_fin(1)-nt*(2*nf+1),EBV,perf(:,1),alpha,remain)
              k=0
              do i=1,size(remain,1)
                 if(remain(i,2)==2) then
                    k=k+1
                    perf_temp(nr+k)=EBV(1+i,1)
                 endif
              enddo
              deallocate(EBV)
           endif
        else if(mode_sel(1,1)==2) then
           allocate(EBV(tot_pop_fin(1)-nt*(2*nf+1)+1,1))
           call computeBLUP(ped_p1,tot_pop_fin(1)-nt*(2*nf+1),EBV,perf(:,1),alpha,remain)
           j=0; k=0
           ! Only the EBV of the animals that are still alive are computed
           do i=1,size(remain,1)
              if(remain(i,2)==1) then
                 j=j+1
                 perf_temp(j)=EBV(1+i,1)
              else if(remain(i,2)==2.and.mode_sel(1,2)==2) then
                 k=k+1
                 perf_temp(nr+k)=EBV(1+i,1)
              endif
           enddo
           deallocate(EBV)
           if(mode_sel(1,2)==0) then
              k=0
              do i=1,size(remain,1)
                 if(remain(i,2)==2) then
                    k=k+1
                    perf_temp(k+nr)=reserv(i)
                 endif
              enddo
           else if (mode_sel(1,2)==1) then
              call given_accur(gani,accur(1,1),accur(1,2),reserv,1,nr,&
                   nr+tail_port,all3,pos_assoc,nqtl,eff_qtl,posqtl)
              k=0
              do i=1,size(remain,1)
                 if(remain(i,2)==2) then
                    k=k+1
                    perf_temp(k+nr)=reserv(i)
                 endif
              enddo
           endif
        else
           k=0
           do i=1,size(remain,1)
              if(remain(i,2)==1) then
                 k=k+1
                 perf_temp(k)=reserv(i)
              endif
              if(mode_sel(1,2)==0.and.remain(i,2)==2) then
                 l=l+1
                 perf_temp(k+nr)=reserv(i)
              endif
           enddo
           if(mode_sel(1,2)==2) then
              allocate(EBV(tot_pop_fin(1)-nt*(2*nf+1),1))
              call computeBLUP(ped_p1,tot_pop_fin(1)-nt*(2*nf+1),EBV,perf(:,1),alpha,remain)
              k=0
              do i=1,size(remain,1)
                 if(remain(i,2)==2) then
                    k=k+1
                    perf_temp(nint(real(nanc)/2.)+k)=EBV(1+i,1)
                 endif
              enddo
              deallocate(EBV)
           else if(mode_sel(1,2)==1) then
              call given_accur(gani,accur(1,1),accur(1,2),reserv,1,nr,&
                   nr+tail_port,all3,pos_assoc,nqtl,eff_qtl,posqtl)
              k=0
              do i=1,size(remain,1)
                 if(remain(i,2)==2) then
                    k=k+1
                    perf_temp(k+nint(real(nanc)/2.))=reserv(i)
                 endif

              enddo
           else          
              k=0
              do i=1,size(remain,1)
                 if(remain(i,2)==2) then
                    k=k+1
                    perf_temp(k+nint(real(nanc)/2.))=reserv(i)
                 endif
              enddo
           endif
        endif
        call search_best(perf_temp(1:nr),nr,rang(1:nr),nr)
        call search_best(perf_temp(1+nr:nr+tail_port),tail_port,rang(1+nr:nr+tail_port),tail_port)
!!$print*,k,perf_temp(1+nint(real(nanc)/2.)),1+nint(real(nanc)/2.)
     else
        do i=1,nr
           rang(i)=i
        enddo
        do i=1+nr,nr+tail_port
           rang(i)=i-nr
        enddo
     endif

     if(direct_fin==1) then
        ! Sort the individuals that are potential parents
        k=0; l=0
        do j=1,nanc
           !do i=1,size(remain,1)
           if(remain(j,2)==2) then
              k=k+1
              all2(:,nint(real(nanc)/2.)+k,:)=all3(:,j,:)
              gani(nint(real(nanc)/2.)+k,nbpop+1)=gani(j,1)
              if(store_cop==1) cop2(:,nint(real(nanc)/2.)+k,:)=cop3(:,j,:)
           else
              l=l+1
              all2(:,l,:)=all3(:,j,:)
              gani(l,nbpop+1)=gani(j,1)
              if(store_cop==1) cop2(:,l,:)=cop3(:,j,:)
           endif
        enddo
        all3=all2
        gani(:,1)=gani(:,nbpop+1)
        if(store_cop==1) cop3=cop2
     endif

     allocate(all(nmq+nqtl,nanc,2),cop(nmq+nqtl,nanc,2))
     if(direct_fin==1) allocate(parent(nt*(2*nf+1),2))
     do i=1,nr
        reserv(i)=perf_temp(rang(i))
        all(:,i,:)=all3(:,rang(i),:)
        if(store_cop==1) cop(:,i,:)=cop3(:,rang(i),:)
        gind(i,nbpop+1)=gani(rang(i),1)
        if(direct_fin==1) then
           l=0; test=.TRUE.
           k=0
           do while(test)
              k=k+1
              if(remain(k,2)==1) l=l+1
              if(l==rang(i)) test=.FALSE.
           enddo
           parent(i,:)=ped_p1(remain(k,1),2:3)
        endif
     enddo

     do i=1+nr,tail
        reserv(i)=perf_temp(rang(i)+nint(real(nanc/2.)))
        all(:,i,:)=all3(:,rang(i)+nint(real(nanc/2.)),:)
        if(store_cop==1) cop(:,i,:)=cop3(:,rang(i)+nint(real(nanc/2.)),:)
        gind(i,nbpop+1)=gani(rang(i)+nint(real(nanc/2.)),1)
        if(direct_fin==1) then
           l=0; test=.TRUE.
           k=0
           do while(test)
              k=k+1
              if(remain(k,2)==2) l=l+1
              if(l==rang(i)) test=.FALSE.
           enddo
           parent(i,:)=ped_p1(remain(k,1),2:3)
        endif
     enddo

     deallocate(perf_temp)
     do i=1,nanc
        all3(:,i,:)=all(:,i,:)
        if(store_cop==1) cop3(:,i,:)=cop(:,i,:)
     enddo
     allocate(nrmat_f(nanc,nanc))
     do i=1,nanc
        do j=1,nanc
           nrmat_f(i,j)=nrmat_fin(rang(i),rang(j))
        enddo
     enddo
     nrmat_fin=nrmat_f
     deallocate(rang,nrmat_f,all,cop)

     deallocate(perf)
     gind(:,1)=0
     gind(:,1)=gind(:,nbpop+1)

     allocate(all(nmq+nqtl,tail,2),all4(nmq+nqtl,nt*(1+2*nf),2))
     if(store_cop==1) allocate(cop(nmq+nqtl,tail,2),cop4(nmq+nqtl,nt*(1+2*nf),2))
     allocate(par(2,nt*(1+2*nf)+ngpm,2),gind2(nanc+nt+2*nf*nt+ngpm,2))
     allocate(perf(tail,nbpop+1))
     if(direct_fin==0) then
        limite=nint(real(nr)*selection(1,1,1))
     else
        j=0
        do i=1,nanc
           if(remain(i,2)==1) j=j+1
        enddo
        limite=nint(real(j)*selection(1,1,1))
     endif
     all4=0
     if(store_cop==1)cop4=0
     gind2=0
     do i=1,nanc
        gind2(i,1)=gind(i,nbpop+1)
     enddo
     deallocate(gind)

     !     print*,gind2(1:nanc,1)
     ! Choix des pères
     if(allocated(perf)) deallocate(perf)
     allocate(perf((1+2*nf)*nt,nbpop+1))
     perf=0

     do i=1,nt                
        par(1,i,1)=G05DYF(1,limite)
     enddo
     do i=1,nt
        all4(:,i,:)=all3(:,par(1,i,1),:)
        if(store_cop==1) cop4(:,i,:)=cop3(:,par(1,i,1),:)
        gind2(nanc+i,1)=gind2(par(1,i,1),1)
        perf(i,nbpop+1)=reserv(par(1,i,1))
     enddo
     deallocate(reserv)
     if(allocated(fqall)) deallocate(fqall)

     allocate(htz(nqtl))
     htz=0
     do i=1,nt
        do j=1,nqtl
           if(all4(posqtl(j),i,1)==alleff(j))then
              if(all4(posqtl(j),i,2)/=alleff(j)) htz(j)=htz(j)+1
           else
              if(all4(posqtl(j),i,2)==alleff(j)) htz(j)=htz(j)+1
           endif
        enddo
     enddo

     allocate(fqall(nmq+nqtl,nalmax(nbpop+1)))
     fqall=0
     call stat_freq_1(1,nt,all4,nball,fqall)
     open(45,file='heterozygotes')
     do i=1,nqtl
        write(45,*)last_ind+i,htz(i),alleff(i),fqall(posqtl(i),:)
     enddo
     deallocate(htz,fqall)
     !     DAMS
     all=0
     if(store_cop==1)cop=0
     all2=0
     if(store_cop==1)cop2=0
     ! choice of the maternal grand-sires
     do i=1,ngpm
        par(1,nt+i,1)=G05DYF(1,limite)
        id=0
     enddo
     do i=1,ngpm
        all3(:,nanc+i,:)=all3(:,par(1,nt+i,1),:)
        if(store_cop==1) cop3(:,nanc+i,:)=cop3(:,par(1,nt+i,1),:)
        gind2(nanc+i+nt,1)=gind2(par(1,nt+i,1),1)
        !        print*,'GPM',gind2(nanc+i+nt,1),gind2(par(1,nt+i,1),1)
     enddo

     ! creation of the mothers
     limite=nint(real(tail_port)*selection(1,1,2))
     do i=1,nf*nt
        par(1,nt+ngpm+i,2)=G05DYF(1,limite)+nint(real(nanc)/2.)
        id=0
        do j=1,nt
           if(par(1,nt+ngpm+i,2)/=par(1,j,1)) id=id+1
        enddo
        do j=1,ngpm
           if(par(1,nt+ngpm+i,2)/=par(1,nt+j,1)) id=id+1
        enddo
        do while(id/=nt+ngpm)
           par(1,nt+ngpm+i,2)=G05DYF(1,limite)
           id=0
           do j=1,nt
              if(par(1,nt+ngpm+i,2)/=par(1,j,1)) id=id+1
           enddo
           do j=1,ngpm
              if(par(1,nt+ngpm+i,2)/=par(1,nt+j,1)) id=id+1
           enddo
        enddo
        par(1,nt+ngpm+i,1)=G05DYF(1,ngpm)
     enddo

     if(allocated(all)) deallocate(all)
     allocate(all(nmq+nqtl,nf*nt,2))
     if(store_cop==1) then
        if(allocated(cop)) deallocate(cop)
        allocate(cop(nmq+nqtl,nf*nt,2))
     endif
!!$     print*,shape(all),'   ',shape(all2)

     do j=1,nchrom
        iv=sum(nloc(1:(j-1)))
        do i=1,nf*nt
           do k=1,2
              essai = .true.
              nb_recomb=random_poisson(pos_loc(nloc(j),j),essai)
              ii=G05DYF(1,2)
              if(nb_recomb==0) then
                 all(iv+1:iv+nloc(j),i,k)=all3(iv+1:iv+nloc(j),nanc+par(1,i+nt+ngpm,1),ii)
!!$                tab6(iv+1:iv+tab(j),i,k)=tab7(iv+1:iv+tab(j),tab4(i,k),ii)
              else
                 allocate(pos_recomb(nb_recomb))
                 do l=1,nb_recomb
                    r=G05CAF(r)*pos_loc(nloc(j),j)
                    pos_recomb(l)=r
                 enddo
                 allocate(pos_recomb2(nb_recomb))
                 if(nb_recomb>1) then
                    allocate(rang(nb_recomb))
                    rang=0
                    call search_best(-pos_recomb,nb_recomb,rang,nb_recomb)
                    pos_recomb2(:)=pos_recomb(rang(:))
                    deallocate(rang)
                 else
                    pos_recomb2=pos_recomb
                 endif
                 deallocate(pos_recomb)
                 v=0
                 vi=1
                 do while(v<nb_recomb)
                    test=.true.
                    do while(test)
                       all(iv+vi,i,k)=all3(iv+vi,nanc+par(1,i+nt+ngpm,1),ii)
!!$                      tab6(iv+vi,i,k)=tab7(iv+vi,tab4(i,k),ii)
                       if(vi+1>nloc(j)) test=.false.
                       if(pos_loc(vi,j)>=pos_recomb2(v+1)) then      
                          test=.false.
                          m=1
                          do l=v+2,nb_recomb
                             if(pos_loc(vi,j)>=pos_recomb2(l)) m=m+1
                          enddo
                       endif
                       vi=vi+1
                    enddo
                    if(mod(m,2)/=0) then
                       ii=3-ii
                    endif
                    v=v+m
                 enddo
                 if(vi<=nloc(j)) then
                    all(iv+vi:iv+nloc(j),i,k)=all3(iv+vi:iv+nloc(j),nanc+par(1,i+nt+ngpm,1),ii)
                    if(store_cop==1) cop(iv+vi:iv+nloc(j),i,k)=cop3(iv+vi:iv+nloc(j),nanc+par(1,i+nt+ngpm,1),ii)
                 endif
                 deallocate(pos_recomb2)
              endif
           enddo
        enddo
     enddo
     deallocate(all3)

     if(store_cop==1) then
        call mutat(1,nt*nf,nbpop+1,all,all2,cop,cop2)
     else
        call mutat_noCop(1,nt*nf,all,all2)
     endif
     do j=1,nt*nf
        m_inbr=(2-(nrmat_fin(par(1,j+ngpm+nt,1),par(1,j+ngpm+nt,1))-1)-(nrmat_fin(par(1,j+ngpm+nt,2),par(1,j+ngpm+nt,2))-1))/4
        mend=sqrt(m_inbr*polyg**2)
        mendel=G05DDF(0.d0,mend)
        gani(j,nbpop+1)=0.5*(gind2(nanc+nt+par(1,j+ngpm+nt,1),1)+gind2(par(1,j+ngpm+nt,2),1))+mendel
        valqtl=0
        epis=0
        do i=1,nqtl
           if(pos_assoc(i,3)/=0) then
              if(pos_assoc(i,1)<pos_assoc(i,4)) then
                 if(pos_assoc(i,6)==1) then
                    epis=epis+sum(eff_qtl(i,all(pos_assoc(i,1),j,:)))*&
                         sum(eff_qtl(pos_assoc(i,3),all(pos_assoc(i,4),j,:)))
                 else
                    test=.false.
                    if(eff_QTL(i,all(pos_assoc(i,1),j,1))==maxval(eff_QTL(i,:))) test=.true.
                    if(eff_QTL(i,all(pos_assoc(i,1),j,2))==maxval(eff_QTL(i,:))) test=.true.
                    if (test) epis=epis+ sum(eff_QTL(pos_assoc(i,3),all(pos_assoc(i,4),j,:)))
                 endif
              endif
           else
              valqtl=valqtl+sum(eff_qtl(i,all(posqtl(i),j,:)))
              if(all(pos_assoc(i,1),j,1)/=all(pos_assoc(i,1),j,2)) epis=epis+eff_dom(i)
           endif
        enddo
        env=G05DDF(0.d0,envir)
        perf(nt+j,nbpop+1)=gani(j,nbpop+1)+env+valqtl+epis
        gind2(j+nanc+nt+ngpm,1)=gani(j,nbpop+1)
     enddo
     do i=1,nf*nt
        all4(:,nt+i,:)=all(:,i,:)
        if(store_cop==1) cop4(:,nt+i,:)=cop(:,i,:)
     enddo

     deallocate(all,all2)
     if(allocated(cop)) deallocate(cop)
     if(allocated(cop2)) deallocate(cop2)

     ! Compute the new nrmat
     allocate(nrmat_f(nt*(nf+1),nt*(nf+1)))
     allocate(rang(nt*nf))
     rang=0
     nrmat_f=0
     do j=1,nt
        nrmat_f(j,j)=nrmat_fin(par(1,j,1),par(1,j,1))
        do k=1,j-1
           nrmat_f(j,k)=nrmat_fin(par(1,j,1),par(1,k,1))
           nrmat_f(k,j)=nrmat_f(j,k)
        enddo
     enddo
     do j=nt+1,nt*(nf+1)
        rang(j-nt)=1+nrmat_fin(par(1,nt+par(1,ngpm+j,1),1),par(1,ngpm+j,2))
     enddo
     do j=1,nt*nf
        do k=1,nt
           nrmat_f(k,nt+j)=(nrmat_fin(k,par(1,nt+par(1,nt+ngpm+j,1),1))+nrmat_fin(k,par(1,nt+ngpm+j,2)))/2
           nrmat_f(nt+j,k)=nrmat_f(k,nt+j)
        enddo
        nrmat_f(nt+j,nt+j)=rang(j)
     enddo
     deallocate(rang,nrmat_fin)

     open(41,file='simhaplo')
     open(48,file='simhaploNoQTL')
     if(store_cop==1) then
        open(50,file='simcop')
        open(51,file='simcopNoQTL')
     endif
     open(78,file='genotyp_err')

     allocate(all3(nmq+nqtl,nt*(1+nf),2))
     all3(:,1:nt*(nf+1),:)=all4(:,1:nt*(nf+1),:)
     if(typing_err==1) call genot_err(1,nt*(nf+1),all4,all3,errSNP,errMST,miss_genot)

     allocate(allp2(nmq,nt*(nf+1),2))
     if(store_cop==1) allocate(cop2(nmq,nt*(nf+1),2))
     l=0
     do i=1,nmq+nqtl
        if(indic(i)==0) then
           l=l+1
           allp2(l,1:nt*(nf+1),:)=all3(i,1:nt*(nf+1),:)
           if(store_cop==1) cop2(l,1:nt*(nf+1),:)=cop4(i,1:nt*(nf+1),:)
        endif
     enddo
     allocate(verif(nt+ngpm))
     verif=0
     do j=1,nt+ngpm
        verif(j)=remain(par(1,j,1),1)
        l=0
        do i=1,j-1
           if(verif(i)==verif(j)) l=l+1
        enddo
        if(l==0) then
           do k=1,2
              write(41,*)remain(par(1,j,1),1),k,all3(:,j,k)
              write(48,*)remain(par(1,j,1),1),k,allp2(:,j,k)  
              if(store_cop==1) then
                 write(50,*)remain(par(1,j,1),1),k,cop4(:,j,k)
                 write(51,*)remain(par(1,j,1),1),k,cop2(:,j,k)
              endif
           enddo
        endif
     enddo
     deallocate(verif)
     do j=1,nt*nf
        do k=1,2
           write(41,*)last_ind+j,k,all3(:,j,k)
           write(48,*)last_ind+j,k,allp2(:,j,k)  
           if(store_cop==1) then
              write(50,*)last_ind+j,k,cop4(:,j,k)
              write(51,*)last_ind+j,k,cop2(:,j,k)
           endif
        enddo
     enddo
     deallocate(allp2,all3)
     if(allocated(cop2)) deallocate(cop2)
     allocate(all(nmq+nqtl,nt*nf,2),all2(nmq+nqtl,nt*nf,2))
     if(store_cop==1) allocate(cop(nmq+nqtl,nt*nf,2),cop2(nmq+nqtl,nt*nf,2))
     !     SONS
     do i=1,nt
        do j=1,nf
           par(2,(i-1)*nf+j,1)=i
           par(2,(i-1)*nf+j,2)=(i-1)*nf+j+nt
        enddo
     enddo
     if(store_cop==1) then
        call trans(nt*nf,nchrom,nloc,all,all4,par,pos_loc,2,cop,cop4)
        call mutat(1,nt*nf,nbpop+1,all,all2,cop,cop2)
     else
        call trans_noCop(nt*nf,nchrom,nloc,all,all4,par,pos_loc,2)
        call mutat_noCop(1,nt*nf,all,all2) !,cop,cop2)
     endif
     deallocate(all2)
     if(store_cop==1) deallocate(cop2)

     do j=1,nt*nf
        all4(:,nt*(1+nf)+j,:)=all(:,j,:)
        if(store_cop==1) cop4(:,nt*(1+nf)+j,:)=cop(:,j,:)
     enddo

     do j=1,nf*nt
        m_inbr=(2-(nrmat_f(par(2,j,1),par(2,j,1))-1)-(nrmat_f(par(2,j,2),par(2,j,2))-1))/4
        mend=sqrt(m_inbr*polyg**2)
        mendel=G05DDF(0.d0,mend)
        gani(j,nbpop+1)=0.5*(gind2(nanc+par(2,j,1),1)+gind2(par(2,j,2)+nanc+nt+ngpm,1))+mendel
        valqtl=0
        epis=0
        do i=1,nqtl
           if(pos_assoc(i,3)/=0) then
              if(pos_assoc(i,1)<pos_assoc(i,4)) then
                 if(pos_assoc(i,6)==1) then
                    epis=epis+sum(eff_qtl(i,all(pos_assoc(i,1),j,:)))*&
                         sum(eff_qtl(pos_assoc(i,3),all(pos_assoc(i,4),j,:)))
                 else
                    test=.false.
                    if(eff_QTL(i,all(pos_assoc(i,1),j,1))==maxval(eff_QTL(i,:))) test=.true.
                    if(eff_QTL(i,all(pos_assoc(i,1),j,2))==maxval(eff_QTL(i,:))) test=.true.
                    if (test) epis=epis+ sum(eff_QTL(pos_assoc(i,3),all(pos_assoc(i,4),j,:)))
                 endif
              endif
           else
              valqtl=valqtl+sum(eff_qtl(i,all(posqtl(i),j,:)))
              if(all(pos_assoc(i,1),j,1)/=all(pos_assoc(i,1),j,2)) epis=epis+eff_dom(i)
           endif
        enddo
        !        print*,j,valqtl
        env=G05DDF(0.d0,envir)
        poid=1
        env=env/poid
        perf(j,nbpop+1)=gani(j,nbpop+1)+env+valqtl+epis
        gind2(j+nanc+nt*(1+nf)+ngpm,1)=gani(j,nbpop+1)
     enddo

     if(store_cop==1) then
        l=0
        test=.FALSE.
        if(.not.allocated(cop2)) then
           allocate(cop2(nmq,nt*nf,2))
           test=.TRUE.
        endif
        do i=1,nmq+nqtl
           if(indic(i)==1) then
              l=l+1
           else
              cop2(i-l,1:nt*nf,:)=cop4(i,nt*(1+nf)+1:nt*(1+2*nf),:)
           endif
        enddo
     endif
     l=0
     if(store_cop==1) then
        test=.FALSE.
        if(.not.allocated(cop2)) then
           allocate(cop2(nmq,nt*nf,2))
           test=.TRUE.
        endif
     endif
     allocate(all3(nmq+nqtl,nt*(1+2*nf),2))
     all3=all4
     if(typing_err==1) call genot_err(nt*(1+nf)+1,nt*(1+2*nf),all4,all3,errSNP,errMST,miss_genot)
     allocate(allp2(nmq,nt*nf,2))
     do i=1,nmq+nqtl
        if(indic(i)==1) then
           l=l+1
        else
           allp2(i-l,1:nt*nf,:)=all3(i,nt*(1+nf)+1:nt*(1+2*nf),:)
           if(store_cop==1) cop2(i-l,1:nt*nf,:)=cop4(i,nt*(1+nf)+1:nt*(1+2*nf),:)
        endif
     enddo
     do i=1,nt*nf
        do k=1,2
           write(41,*)last_ind+i+nt*nf,k,all3(:,nt*(1+nf)+i,k)
           write(48,*)last_ind+i+nt*nf,k,allp2(:,i,k)  
           if(store_cop==1) then
              write(50,*) last_ind+i+nt*nf,k,cop4(:,nt*(1+nf)+i,k)
              write(51,*) last_ind+i+nt*nf,k,cop2(:,i,k)
           endif
        enddo
     enddo
     deallocate(allp2,all3)
     if(allocated(cop2)) then
        if(test) then
           deallocate(cop2)
        else
           cop2=0
        endif
     endif

     open(220,file='simped')
     if(direct_fin==0) then
        do i=1,nt*(1+nf)
           write(220,*)i,zero,zero,last_gen,zero, '  1'
        enddo
        do j=1,nf*nt
           write(220,*)j+nt*(1+nf),par(2,j,1),par(2,j,2),last_gen+1,' 1   2'
        enddo
     else
        allocate(verif(nt+ngpm))
        verif=0
        do i=1,nt+ngpm
           verif(i)=remain(par(1,i,1),1)
           k=0
           do j=1,i-1
              if(verif(i)==verif(j)) k=k+1
           enddo
!!$print*,i,k,remain(par(1,i,1),1)
           if(k==0) write(220,*)remain(par(1,i,1),1),parent(par(1,i,1),1:2),last_gen,zero,'  1'
        enddo
        do i=1,nt*nf ! mothers are created
           write(220,*)last_ind+i,remain(par(1,nt+par(1,nt+ngpm+i,1),1),1),' 0 ',last_gen,zero,'   2'  
        enddo
        allocate(rang(nt*nf))
        call G05DYF2(1,2,nt*nf,rang)
        do i=1,nf*nt
           write(220,*)last_ind+i+nt*nf,remain(par(1,par(2,i,1),1),1),last_ind+par(2,i,2)-nt,last_gen+1,'         1',rang(i)
        enddo
        deallocate(rang)
     endif

     open(24,file='simperf')
     poid=1.
     do i=1,nt
        do j=1,nf
           write(24,*)last_ind+nt*nf+(i-1)*nf+j,perf((i-1)*nf+j,nbpop+1),&
                gani((i-1)*nf+j,nbpop+1)
        enddo
     enddo

     if(.not.allocated(fqall)) allocate(fqall(nmq+nqtl,nalmax(nbpop+1)))
     fqall=0
     call stat_freq_1(nt*(nf+1)+1,nt*(1+2*nf),all4,nball,fqall)

     if(f_fqall=='y') then
        do i=1,nmq+nqtl
           do j=1,nball(i,nbpop+1)
              write(10,*)i,j,fqall(i,j),nf*nt,time+2
           enddo
        enddo
     endif

     if(f_fqcop=='y'.and.store_cop==1) then
        allocate(fqcop(nmq+nqtl,ncopmax(nbpop+1)))
        fqcop=0
        call stat_freq_1(1,nf*nt,cop,maxcop,fqcop)
        allocate(cop_alef(nmq+nqtl,maxcop(nmq,nbpop+1)))
        cop_alef=0
        do i=1,nf*nt
           do j=1,2
              do k=1,nmq+nqtl
                 do l=1,nqtl
                    if(k==posqtl(l).and.all(k,i,j)==alleff(l)) cop_alef(k,cop(k,i,j))=cop_alef(k,cop(k,i,j))+1
                 enddo
              enddo
           enddo
        enddo
        allocate(coprest(nmq+nqtl))
        coprest=0
        do i=1,nmq+nqtl
           do j=1,maxcop(i,nbpop+1)
              if(fqcop(i,j)/=0) coprest(i)=coprest(i)+1
           enddo
        enddo
        do ii=1,nmq+nqtl
           do j=1,maxcop(ii,nbpop+1)
              if(indic(ii)==1) then
                 if(fqcop(ii,j)>0.0001) write(19,'(3(i6,1x),f8.6,1x,i6,1x,i8,1x,i4)')ii,j,&
                      coprest(ii),fqcop(ii,j),cop_alef(ii,j),nf*nt,time+2
              else
                 if(fqcop(ii,j)>0.0001) write(19,'(3(i6,1x),f8.6,1x,i6,1x,i8,1x,i4)')ii,j,&
                      coprest(ii),fqcop(ii,j),zero,nf*nt,time+2
              endif
           enddo
        enddo
        deallocate(fqcop,cop_alef,coprest)
     endif

     if(f_hPIC=='y') then
        allocate(pic(nmq+nqtl))
        call eval_pic(nbpop+1,nball,nmq+nqtl,pic)
        call nbhaplotypes(nf*nt,all,indic,nmq,nqtl)
        prop_h=real(nb_h)/real(nb_h_init)
        prop_hc=real(nb_hc)/real(nb_hc_init)
        do i=1,nqtl+nmq
           write(13,'(i8,1x,3(i4,1x),f4.2,1x,i4,1x,f4.2,1x,i2,1x,f10.6)')nf*nt,&
                time+2,i,nb_h,prop_h,nb_hc,prop_hc,indic(i),pic(i)
        enddo
     endif

     if(f_dl=='y'.or.f_dlq=='y') call LD(lg_chrom,bin,nchrom,nball,nmq,nqtl,nf*nt,&
          all,fqall,verif_print,1,chr_loc,nloc,pos_loc,time+2)

     if(f_ibd=='y'.or.f_ibdq=='y') then
        if(store_cop==1) then
           allocate(seg_ibd(maxloc,nchrom,nf*nt,2),deb(maxloc,nchrom,nf*nt,2),fin(maxloc,nchrom,nf*nt,2))
           allocate(seg_qtl(nqtl,nf*nt,2),nb_seg(nf*nt,2,nchrom))
           call long_seg(1,nf*nt,nmq,nqtl,posqtl,cop,seg_ibd,deb,fin,seg_qtl,nb_seg,lg_chrom,chr_QTL,nchrom,dist)
           do i=1,nf*nt
              do j=1,2
                 if(f_ibd=='y') then
                    do l=1,nchrom
                       do k=1,maxloc
                          if(seg_ibd(k,l,i,j)>0) then
                             write(21,*)last_ind+i,j,k,seg_ibd(k,l,i,j)
                          endif
                       enddo
                    enddo
                 endif
                 if(f_ibdq=='y') then
                    do k=1,nqtl
                       write(22,'(3(i4,1x),f12.7,1x,f6.4,1x,i6)')last_ind+i,j,k,seg_qtl(k,i,j),&
                            fqall(posqtl(k),alleff(k)),time+2
                    enddo
                 endif
              enddo
           enddo
           deallocate(seg_qtl,seg_ibd,chr_QTL)
           deallocate(nb_seg,deb,fin)
        endif
     endif

     if(f_csg=='y'.and.store_cop==1) then
        allocate(consmoy(nmq+nqtl),varcons(nmq+nqtl))
        call consang(1,nf*nt,nmq,nqtl,cop,consmoy,varcons)
        do j=1,nmq+nqtl
           write(23,*)j,consmoy(j),varcons(j),nf*nt,time+2
        enddo
     endif

     aux_test=.false.
     if (f_hPIC=='y') aux_test=.true.
     if (allocated(pic)) deallocate(pic)
     deallocate(fqall)

  else if (typ_pop==2) then

     ! Nothing needs to be changed from the situation in the historical generations
     open(48,file='simhaploNoQTL')
     open(41,file='simhaplo')
     open(220,file='simped')
     open(24,file='simperf')
     open(78,file='genotyp_err')
     if(store_cop==1) then
        open(50,file='simcop')
        open(51,file='simcopNoQTL')
     endif

     id=0; id2=0
     ! Outputs of the last historical generation if required
     if(gene_ped==time2+1) then
        if(direct_fin==0) then
           do i=1,n(1,0)
              write(220,*)last_ind+i,' 0     0       ',last_gen+1,'    0      1     pop1'
           enddo
           do i=1+n(1,0),sum(n(1:2,0))
              write(220,*)last_ind+i,' 0     0       ',last_gen+1,'    0      2      pop1'
           enddo
           do i=1+sum(n(1:2,0)),sum(n(1:3,0))
              write(220,*)last_ind+i,' 0     0       ',last_gen+ 1,'    0     1      pop2'
           enddo
           do i=1+sum(n(1:3,0)),sum(n(:,0))
              write(220,*)last_ind+i,' 0     0       ',last_gen+ 1,'    0     2       pop2'
           enddo
        else
           do i=1,n(1,0)
              write(220,*)ped_p1(i,:),last_gen+1,'    0    1    pop1'
           enddo
           do i=1+n(1,0),sum(n(1:2,0))
              write(220,*)ped_p1(i,:),last_gen+1,'    0     2  pop1'
           enddo
           do i=1+sum(n(1:2,0)),sum(n(1:3,0))
              write(220,*)ped_p2(i-sum(n(1:2,0)),:),last_gen+ 1,'    0   1    pop2'
           enddo
           do i=1+sum(n(1:3,0)),sum(n(:,0))
              write(220,*)ped_p2(i-sum(n(1:2,0)),:),last_gen+ 1,'    0   2    pop2'
           enddo
        endif
     endif
     if(gene_perf==time2+1) then
        do i=1,sum(n(1:2,0))
           write(24,*)remain(i,1),perf(i,1),gind(i,1)
        enddo
        do i=1,sum(n(3:4,0))
           write(24,*)remain2(i,2),perf(i,2),gind(i,2)
        enddo
     endif
     if(gene_typ==time2+1) then
        allocate(all3(nmq+nqtl,sum(n(:,0)),2))
        allocate(all2(nmq,sum(n(:,0)),2))
        all2(:,1:sum(n(1:2,0)),:)=all(:,1:sum(n(1:2,0)),:)
        all2(:,1+sum(n(1:2,0)):sum(n(:,0)),:)=allp2(:,1:sum(n(3:4,0)),:)
        if(typing_err==1) call genot_err(1,sum(n(:,0)),all2,all3,errSNP,errMST,miss_genot)
        deallocate(all2)
        allocate(all2(nmq,sum(n(:,0)),2))
        if(store_cop==1) then
           if(allocated(cop2)) deallocate(cop2)
           allocate(cop2(nmq,sum(n(:,0)),2))
        endif

        l=0
        do i=1,nmq+nqtl
           if(indic(i)==1) then
              l=l+1
           else
              all2(i-l,1:sum(n(1:2,0)),:)=all(i,1:sum(n(1:2,0)),:)
              all2(i-l,1+sum(n(1:2,0)):sum(n(:,0)),:)=allp2(i,1:sum(n(3:4,0)),:)
              if(store_cop==1) cop2(i-l,1:sum(n(1:2,0)),:)=cop(i,1:sum(n(1:2,0)),:)
              if(store_cop==1) cop2(i-l,1+sum(n(1:2,0)):sum(n(:,0)),:)=copp2(i,1:sum(n(3:4,0)),:)
           endif
        enddo
        do i=1,sum(n(:,0))
           do k=1,2
              if(i<=sum(n(1:2,0))) then
                 write(41,*)last_ind+i,k,all(:,i,k)
              else
                 write(41,*)last_ind+i,k,allp2(:,i-sum(n(1:2,0)),k)
              endif
              write(48,*)last_ind+i,k,all2(:,i,k)
              if(store_cop==1) then
                 if(i<=sum(n(1:2,0))) then
                    write(50,*)last_ind+i,k,cop(:,i,k)
                 else
                    write(50,*)last_ind+i,k,copp2(:,i-sum(n(1:2,0)),k)
                 endif
                 write(51,*)last_ind+i,k,(cop2(m,i,k),m=1,nmq)
              endif
           enddo
        enddo
        deallocate(all2)
        if(allocated(cop2)) deallocate(cop2)
     endif
     if(gene_typ==time2+1.or.gene_perf==time2+1.or.gene_ped==time2+1) id=id+sum(n(:,0))


     if(cross==1) then ! The population in which genes are introgressed is the former second one
        allocate(all2(nmq+nqtl,max(sum(n(3:4,0)),sum(n(1:2,0))),2),gind2(max(sum(n(3:4,0)),sum(n(1:2,0))),4))
        if(store_cop==1) allocate(cop2(nmq+nqtl,max(sum(n(3:4,0)),sum(n(1:2,0))),2))
        do i=1,sum(n(3:4,0))
           all2(:,i,:)=allp2(:,i,:)
           if(store_cop==1) cop2(:,i,:)=copp2(:,i,:)
           gind2(i,1)=gind(i,2)
           gind2(i,2)=perf(i,2)
        enddo
        do i=1,sum(n(1:2,0))
           gind2(i,3)=gind(i,1)
           gind2(i,4)=perf(i,1)
        enddo
        deallocate(allp2,gind,perf)
        if(allocated(copp2)) deallocate(copp2)
        j=0; k=0; l=0
        do i=0,time2
           j=max(j,sum(n(3:4,i)),sum(n(1:2,i)))
           k=max(k,sum(n(3:4,i)))
           l=max(l,sum(n(1:2,i)))
        enddo
        allocate(allp2(nmq+nqtl,l,2),gind(j,3),perf(j,3))
        gind=0; perf=0
        if(store_cop==1) allocate(copp2(nmq+nqtl,l,2))
        do i=1,sum(n(1:2,0))
           allp2(:,i,:)=all(:,i,:)
           if(store_cop==1) copp2(:,i,:)=cop(:,i,:)
           gind(i,2)=gind2(i,3)
           perf(i,2)=gind2(i,4)
        enddo
        deallocate(all)
        if(allocated(cop)) deallocate(cop)
        allocate(all(nmq+nqtl,k,2))
        if(store_cop==1) allocate(cop(nmq+nqtl,k,2))
        do i=1,sum(n(3:4,0))
           all(:,i,:)=all2(:,i,:)
           if(store_cop==1) cop(:,i,:)=cop2(:,i,:)
           gind(i,1)=gind2(i,1)
           perf(i,1)=gind2(i,2)
        enddo
        deallocate(all2,gind2)
        if(allocated(cop2)) deallocate(cop2)
        ! Also better to invert the number of animals, the proportions selected and the selection modes
        allocate(rang((time2+1)*4),reserv((time2+1)*5),rang2((time2+1)*5))
        do i=1,4
           do j=0,time2
              rang((i-1)*(time2+1)+j+1)=n(i,j)
              reserv((i-1)*(time2+1)+j+1)=sel(i,j,1)
              rang2((i-1)*(time2+1)+j+1)=mode_sel(j,i)
           enddo
        enddo
        deallocate(n)
        allocate(n(4,0:time2))
        do i=1,2
           do j=0,time2
              n(i,j)=rang((2+i-1)*(time2+1)+j+1)
              sel(i,j,1)=reserv((2+i-1)*(time2+1)+j+1)
              mode_sel(j,i)=rang2((2+i-1)*(time2+1)+j+1)
           enddo
        enddo
        do i=3,4
           do j=0,time2
              n(i,j)=rang((i-3)*(time2+1)+j+1)
              sel(i,j,1)=reserv((i-3)*(time2+1)+j+1)
              mode_sel(j,i)=rang2((i-3)*(time2+1)+j+1)
           enddo
        enddo
        deallocate(reserv,rang,rang2)
        ! And finally adapt the nmr matixes
        allocate(nrmat_f(max(sum(n(1:2,0)),sum(n(3:4,0))),sum(n(1:2,0))+2*sum(n(3:4,0))))
        nrmat_f=0
        do i=1,sum(n(1:2,0))
           nrmat_f(i,1:sum(n(1:2,0)))=nrmat(i,sum(n(1:2,0)))
           nrmat_f(i,sum(n(1:2,0))+1:sum(n(1:2,0))+sum(n(3:4,0)))=nrmat2(i,1:sum(n(3:4,0)))
        enddo
        do i=1,sum(n(3:4,0))
           nrmat_f(i,sum(n(1:2,0))+sum(n(3:4,0))+1:sum(n(1:2,0))+2*sum(n(3:4,0)))=&
                nrmat3(i,sum(n(3:4,0)))
        enddo
        deallocate(nrmat,nrmat2,nrmat3)
        j=0; k=0
        do i=0,time2
           j=max(j,sum(n(1:2,i)))
           k=max(k,sum(n(3:4,i)))
        enddo
        allocate(nrmat(j,j),nrmat2(j,k),nrmat3(k,k))
        do i=1,sum(n(1:2,0))
           nrmat(i,1:sum(n(1:2,0)))=nrmat_f(i,1:sum(n(1:2,0)))
           nrmat2(i,1:sum(n(3:4,0)))=nrmat_f(i,sum(n(1:2,0))+1:sum(n(1:2,0))+sum(n(3:4,0)))
        enddo
        do i=1,sum(n(3:4,0))
           nrmat3(i,1:sum(n(3:4,0)))=nrmat_f(i,sum(n(1:2,0))+sum(n(3:4,0))+1:sum(n(1:2,0))+2*sum(n(3:4,0)))
        enddo
        deallocate(nrmat_f)
     endif

     if(allocated(parent)) deallocate(parent)
     if(.not.allocated(ped_p1)) then
        allocate(ped_p1(sum(n(1:2,:)),3))
        allocate(remain(sum(n(1:2,:)),2))
        ped_p1=0
        do i=1,sum(n(1:2,0))
           ped_p1(i,1)=i
           remain(i,1)=i
        enddo
        remain(1:n(1,0),2)=1
        remain(1+n(1,0):sum(n(1:2,0)),2)=2
     endif
     if(.not.allocated(ped_p2)) then
        allocate(ped_p2(sum(n(3:4,:)),3))
        allocate(remain2(sum(n(3:4,:)),2))
        ped_p2=0
        do i=1,sum(n(3:4,0))
           ped_p2(i,1)=i+sum(n(1:2,0))
           remain2(i,1)=i+sum(n(1:2,0))
        enddo
        remain2(1:n(3,0),2)=1
        remain2(1+n(3,0):sum(n(3:4,0)),2)=2
        last_ind=0
     endif

     ! Evolution of the populations in the part typ_pop==2
     do gene=1,time2

        print*,'GENERATION',gene

        test2=.FALSE.
        do i=1,nb_introg
           if(gene==geneIntrog(i)) test2=.TRUE.
        enddo

        polyg=sqrt(sum(gind(1:sum(n(1:2,gene-1)),1)**2)/real(sum(n(1:2,gene-1)))-&
             (sum(gind(1:sum(n(1:2,gene-1)),1))/real(sum(n(1:2,gene-1))))**2)
        polyg2=sqrt(sum(gind(1:sum(n(3:4,gene-1)),2)**2)/real(sum(n(3:4,gene-1)))-&
             (sum(gind(1:sum(n(3:4,gene-1)),2))/real(sum(n(3:4,gene-1))))**2)
        ! SETTING UP THE PARAMETERS FOR EACH GENERATION
        ! Compute the number and females allowed to reproduce
        ! produce first the next generation of the first population

        if(test2) then ! The first population gets genes from the second one
           if(indIntrog(gene)==sum(n(1:2,gene))) then
              nt1=0
              nt2=nint(n(3,gene-1)*sel(5,gene-1,1))
           else
              nt1=nint(n(1,gene-1)*sel(1,gene-1,1))
              nt2=nint(n(3,gene-1)*sel(5,gene-1,1)) ! males from the 2nd population also used to produce population 1
           endif
           nt=nt1+nt2
        else
           nt1=nint(n(1,gene-1)*sel(1,gene-1,1))
           nt2=0
           nt=nt1
        endif
        nf=nint(n(2,gene-1)*sel(2,gene-1,1))

        allocate(damToSire(nf))
        damToSire=0
        if(DamSire==0) then
           if(evenly==0) then
              do i=2,nt
                 damPerSire(i,gene,1)=damPerSire(1,gene,1)
              enddo
           else
              if(sum(damPerSire(nt1+1:n(1,gene),gene,1))/=0) then
                 print*,'ERROR: SIRES THAT ARE NOT SELECTIBLE SHOULD BE PARENT'
                 stop 1
              endif
              if(sum(damPerSire(nt2+1:n(3,gene),gene,1))/=0) then
                 print*,'ERROR: SIRES THAT ARE NOT SELECTIBLE SHOULD BE PARENT'
                 stop 1
              endif
           endif
           do i=1,nt
              damToSire(sum(damPerSire(1:i-1,gene,1))+1:sum(damPerSire(1:i,gene,1)))=i
           enddo
        else
           ! The number of dams per sire is chosen randomly
           call G05DYF2(1,nt,nf,damToSire)
           ! So far, all females have one male, but not all males have females
           if (nt <= nf) then
              allocate(parent(nf,1))
              parent(:,1)=damToSire(:)
              ! Suppose that all selected sires have at least one female if there are enough females
              do i=1,nt
                 do while (count(any(parent .eq. i,1))==0)
                    allocate(verif(nt))
                    verif=0
                    ii=0
                    do j=1,nt
                       k=0
                       ! Number of females attributed to male j
                       do l=1,nf
                          if(parent(l,1)==j) k=k+1
                       enddo
                       ! if more than one, than record the number of the sire
                       if(k>1) then
                          ii=ii+1
                          verif(ii)=j
                       endif
                    enddo
                    ! Choose one sire among the recorded ones
                    l=G05DYF(1,ii)
                    allocate(rang(nf))
                    rang=0
                    k=0
                    ! Find the females associated to the chosen male
                    do j=1,nf
                       if(parent(j,1)==verif(l)) then
                          k=k+1
                          rang(k)=j
                       endif
                    enddo
                    ! Chosse one female among the recorded ones
                    j=G05DYF(1,k)
                    ! and associate it with the male which had no female at the beginning
                    parent(rang(j),1)=i
                    deallocate(rang, verif)
                 enddo
              enddo
              damToSire(:)=parent(:,1)
              deallocate(parent)
           endif
           do i=1,nt
              l=0
              do j=1,nf
                 if(damToSire(j)==i) l=l+1
              enddo
              damPerSire(i,gene,1)=l
           enddo
        endif
!!$        print*,'DPS',damPerSire(:,gene,1)
!!$        print*,'DTS',damToSire(:)

        ! Number of offspring per sire
        allocate(offspPerDam(nf))
        if(offSire==0) then
           if(uniformity==0) then
              do i=2,nt
                 offspPerSire(i,gene,1)=offspPerSire(1,gene,1)
              enddo
           endif
           if(constant3==0) then
              do i=1,nf
                 offspPerDam(i)=nint(real(offspPerSire(damToSire(i),gene,1))/&
                      real(damPerSire(damToSire(i),gene,1)))
              enddo
           else
              do i=1,nt
                 l=0
                 m=0
                 if(damPerSire(i,gene,1)==1) then
                    do j=1,nf
                       if(damToSire(j)==i) exit
                    enddo
                    offspPerDam(j)=offspPerSire(i,gene,1)
                 else
                    do j=1,nf
                       if(damToSire(j)==i) then
                          l=l+1
                          if(l<damPerSire(i,gene,1)) then
                             k=damPerSire(i,gene,1)-l ! Number of dams remaining for sire i after dam j
                             offspPerDam(j)=G05DYF(1,offspPerSire(i,gene,1)-m-k)
                             m=m+offspPerDam(j)
                          else
                             offspPerDam(j)=offspPerSire(i,gene,1)-m-k+1
                          endif
                       endif
                    enddo
                 endif
              enddo
           endif
        else ! The number of offspring per sire is random
           call G05DYF2(1,sum(n(1:2,gene)),nt,offspPerSire(:,gene,1))
           k=sum(offspPerSire(nt1+1:nt,gene,1))
           do while (k /= indIntrog(gene)) 
              l=G05DYF(nt1+1,nt)
              test=.TRUE.
              if(offspPerSire(l,gene,1)==0) test=.FALSE.
              if(offspPerSire(l,gene,1)==1.and.nt2/=n(3,gene-1)) test=.FALSE.
              if(test) then
                 if(k<indIntrog(gene)) then
                    offspPerSire(l,gene,1)=offspPerSire(l,gene,1)+1
                 else
                    offspPerSire(l,gene,1)=offspPerSire(l,gene,1)-1
                 endif
              endif
              k=sum(offspPerSire(nt1+1:nt,gene,1))  
           enddo
           k=sum(offspPerSire(1:nt1,gene,1))                 
           do while(k/=sum(n(1:2,gene))-indIntrog(gene)) 
              l=G05DYF(1,nt1)
              test=.TRUE.
              if(offspPerSire(l,gene,1)==0) test=.FALSE.
              if(offspPerSire(l,gene,1)==1.and.nt/=n(1,gene-1)) test=.FALSE.
              if(test) then
                 if(k<sum(n(1:2,gene))-indIntrog(gene)) then
                    offspPerSire(l,gene,1)=offspPerSire(l,gene,1)+1
                 else
                    offspPerSire(l,gene,1)=offspPerSire(l,gene,1)-1
                 endif
              endif
              k=sum(offspPerSire(1:nt1,gene,1))
           enddo
           do i=1,nt 
              l=0
              m=0
              ii=0
              if(damPerSire(i,gene,1)==1) then
                 do j=1,nf
                    if(damToSire(j)==i) exit
                 enddo
                 offspPerDam(j)=offspPerSire(i,gene,1)
              else
                 do j=1,nf
                    if(damToSire(j)==i) then
                       if(ii<offspPerSire(i,gene,1)) then
                          l=l+1
                          if(l<damPerSire(i,gene,1)) then
                             k=damPerSire(i,gene,1)-l ! Number of dams remaining for sire i after dam j
                             offspPerDam(j)=G05DYF(1,offspPerSire(i,gene,1)-m-k)
                             m=m+offspPerDam(j)
                          else
                             offspPerDam(j)=offspPerSire(i,gene,1)-m-k+1
                          endif
                          ii=ii+offspPerDam(j)
                       else
                          offspPerDam(j)=0
                       endif
                    endif
                 enddo
              endif
           enddo
        endif

        ! If selection, ordering the individuals
        if(minval(sel(:,gene-1,1))/=1.) then
           if(maxval(mode_sel(gene-1,:))==2) then
              k=sum(n(1:2,gene-1))
              r=sum(perf(1:k,1)**2)/k-(sum(perf(1:k,1))/k)**2
              alpha=(sum(gind(1:k,1)**2)/k-(sum(gind(1:k,1))/k)**2)/r
           endif
           allocate(perf_temp(sum(n(1:2,gene-1))))
           if(mode_sel(gene-1,1)==1) then
              allocate(reserv(sum(n(1:2,gene-1))))
              call given_accur(gind,accur(gene-1,1),accur(gene-1,2),reserv,1,n(1,gene-1),&
                   sum(n(1:2,gene-1)),all,pos_assoc,nqtl,eff_qtl,posqtl)
              k=0; l=0
              do i=1,sum(n(1:2,gene-1))
                 if(remain(i+sum(n(1:2,0:gene-2)),2)==1) then
                    k=k+1
                    perf_temp(k)=reserv(i)
                 endif
                 if(remain(i+sum(n(1:2,0:gene-2)),2)==2) then
                    l=l+1
                    perf_temp(l+n(1,gene-1))=reserv(i)
                 endif
              enddo
              deallocate(reserv)
              if(mode_sel(gene-1,2)==0) then
                 k=0
                 do i=1,sum(n(:,gene-1))
                    if(remain(i+sum(n(1:2,0:gene-2)),2)==2) then
                       k=k+1
                       perf_temp(k+n(1,gene-1))=perf(i,1)
                    endif
                 enddo
              else if(mode_sel(gene-1,2)==2) then
                 allocate(EBV(sum(n(:,gene-1))+1,1))
                 call computeBLUP(ped_p1(1:sum(n(1:2,1:gene-1)),:),sum(n(1:2,gene-1)),EBV,&
                      perf(:,1),alpha,remain)
                 k=0
                 do i=1,sum(n(1:2,gene-1))
                    if(remain(sum(n(1:2,gene-2))+i,2)==2) then
                       k=k+1
                       perf_temp(n(1,gene-1)+k)=EBV(1+i,1)
                    endif
                 enddo
                 deallocate(EBV)
              endif
           else if(mode_sel(gene-1,1)==2) then
              allocate(EBV(sum(n(1:2,gene-1))+1,1))
              call computeBLUP(ped_p1(1:sum(n(1:2,1:gene-1)),:),sum(n(1:2,gene-1)),EBV,&
                   perf(:,1),alpha,remain)
              j=0;k=0
              ! Only the EBV of the individuals that are still alive are computed
              do i=1,sum(n(:,gene-1))
                 if(remain(sum(n(1:2,gene-2))+i,2)==1) then
                    j=j+1
                    perf_temp(j)=EBV(i+1,1)
                 else if(remain(sum(n(1:2,gene-2))+i,2)==2.and.mode_sel(gene-1,2)==2) then
                    k=k+1
                    perf_temp(n(1,gene-1)+k)=EBV(1+i,1)
                 endif
              enddo
              deallocate(EBV)
              if(mode_sel(gene-1,2)==0) then
                 k=0
                 do i=1,sum(n(1:2,gene-1))
                    if(remain(i+sum(n(1:2,0:gene-2)),2)==2) then
                       k=k+1
                       perf_temp(k+n(1,gene-1))=perf(i,1)
                    endif
                 enddo
              else
                 allocate(reserv(sum(n(1:2,gene-1))))
                 call given_accur(gani,accur(gene-1,1),accur(gene-1,2),reserv,1,n(1,gene-1),&
                      n(2,gene-1),all,pos_assoc,nqtl,eff_qtl,posqtl)
                 k=0
                 do i=1,sum(n(1:2,gene-1))
                    if(remain(i+sum(n(1:2,0:gene-2)),2)==2) then
                       k=k+1
                       perf_temp(k+n(1,gene-1))=reserv(i)
                    endif
                 enddo
                 deallocate(reserv)
              endif
           else
              k=0;l=0
              !              print*,shape(remain),'   ',shape(perf_temp)
              do i=1,sum(n(1:2,gene-1))
                 if(remain(i+sum(n(1:2,0:gene-2)),2)==1) then
                    k=k+1
                    perf_temp(k)=perf(i,1)
                 endif
                 if(mode_sel(gene-1,2)==0.and.remain(i+sum(n(1:2,0:gene-2)),2)==2) then
                    l=l+1
                    perf_temp(k+n(1,gene-1))=perf(i,2)
                 endif
              enddo
              if(mode_sel(gene-1,2)==1) then
                 allocate(reserv(sum(n(1:2,gene-1))))
                 call given_accur(gani,accur(gene-1,1),accur(gene-1,2),reserv,1,n(1,gene-1),&
                      n(2,gene-1),all,pos_assoc,nqtl,eff_qtl,posqtl)
                 k=0
                 do i=1,sum(n(1:2,gene-1))
                    if(remain(i+sum(n(1:2,0:gene-2)),2)==2) then
                       k=k+1
                       perf_temp(k+n(1,gene-1))=reserv(i)
                    endif
                 enddo
                 deallocate(reserv)
              else if(mode_sel(gene-1,2)==2) then
                 allocate(EBV(sum(n(1:2,gene-1))+1,1))
                 call computeBLUP(ped_p1(1:sum(n(1:2,1:gene-1)),:),sum(n(1:2,gene-1)),EBV,&
                      perf(:,1),alpha,remain)
                 k=0
                 do i=1,sum(n(1:2,gene-1))
                    if(remain(sum(n(1:2,gene-2))+i,2)==2) then
                       k=k+1
                       perf_temp(n(1,gene-1)+k)=EBV(1+i,1)
                    endif
                 enddo
                 deallocate(EBV)
              endif
           endif
           allocate(rang(n(1,gene-1)),rang2(n(2,gene-1)))
           call search_best(perf_temp(1:n(1,gene-1)),n(1,gene-1),rang(1:n(1,gene-1)),n(1,gene-1))
           call search_best(perf_temp(1+n(1,gene-1):sum(n(1:2,gene-1))),n(2,gene-1),&
                rang2(1:n(2,gene-1)),n(2,gene-1))
           deallocate(perf_temp)
        endif
        if(sel(1,gene-1,1)==1) then
           allocate(rang(n(1,gene-1)))
           do i=1,n(1,gene-1)
              rang(i)=i
           enddo
        endif
        if(sel(2,gene-1,1)==1) then
           allocate(rang2(n(2,gene-1)))
           do i=1,n(2,gene-1)
              rang2(i)=i
           enddo
        endif

        ! Evaluating the females in the second population
        allocate(rang3(n(3,gene-1)))
        if(sel(5,gene-1,1)/=1) then
           if(mode_sel(gene-1,3)==0) then
              allocate(perf_temp(n(3,gene-1)))
              perf_temp(1:n(3,gene-1))=perf(1:n(3,gene-1),2)
           else if(mode_sel(gene-1,3)==1) then
              allocate(reserv(sum(n(3:4,gene-1))))
              call given_accur(gani,accur(gene-1,3),accur(gene-1,4),reserv,2,n(3,gene-1),&
                   n(4,gene-1),allp2,pos_assoc,nqtl,eff_qtl,posqtl)
              k=0
              allocate(perf_temp(n(3,gene-1)))
              do i=1,sum(n(3:4,gene-1))
                 if(remain2(i+sum(n(3:4,0:gene-2)),2)==1) then
                    k=k+1
                    perf_temp(k)=reserv(i)
                 endif
              enddo
              deallocate(reserv)
           else
              k=sum(n(3:4,gene-1))
              r=sum(perf(1:k,2)**2)/k-(sum(perf(1:k,2))/k)**2
              alpha=(sum(gind(1:k,2)**2)/k-(sum(gind(1:k,2))/k)**2)/r
              allocate(EBV(sum(n(3:4,gene-1))+1,1))
              call computeBLUP(ped_p2(1:sum(n(3:4,1:gene-1)),:),sum(n(3:4,gene-1)),EBV,&
                   perf(:,2),alpha,remain)
              allocate(perf_temp(n(3,gene-1)))
              k=0
              do i=1,sum(n(3:4,gene-1))
                 if(remain2(i+sum(n(3:4,0:gene-2)),2)==1) then
                    k=k+1
                    perf_temp(k)=EBV(i+1,1)
                 endif
              enddo
           endif
           call search_best(perf_temp,n(3,gene-1),rang3,n(3,gene-1))
           deallocate(perf_temp)

        else

           do i=1,n(3,gene-1)
              rang3(i)=i
           enddo
        endif

        ! Creation of the new generation
        allocate(parent(sum(n(1:2,gene)),2))
        allocate(all2(nmq+nqtl,sum(n(1:2,gene)),2))
        if(store_cop==1) allocate(cop2(nmq+nqtl,sum(n(1:2,gene)),2))
        allocate(herk(sum(n(1:2,gene))))
        herk=0
        parent=0

        ! Choose the sires
        do i=1,nt1 ! Out of those from the 1st population
           allocate(verif(offspPerSire(i,gene,1)))
           call G05DYF2(1,sum(n(1:2,gene)),offspPerSire(i,gene,1),verif)
           do j=1,offspPerSire(i,gene,1)
              if(parent(verif(j),1)==0) then
                 parent(verif(j),1)=rang(i)
                 herk(verif(j))=1
              else
                 do while (parent(verif(j),1)/=0)
                    verif(j)=G05DYF(1,sum(n(1:2,gene)))
                 enddo
                 parent(verif(j),1)=rang(i)
                 herk(verif(j))=1
              endif
              ped_p1(verif(j)+sum(n(1:2,0:gene-1)),2)=remain(sum(n(1:2,0:gene-2))+rang(i),1)
           enddo
           deallocate(verif)
        enddo
        do i=nt1+1,nt ! Out of those from the 2nd population
           allocate(verif(offspPerSire(i,gene,1)))
           call G05DYF2(1,sum(n(1:2,gene)),offspPerSire(i,gene,1),verif)
           do j=1,offspPerSire(i,gene,1)
              if(parent(verif(j),1)==0) then
                 parent(verif(j),1)=rang3(i-nt1)
                 herk(verif(j))=2
              else
                 do while (parent(verif(j),1)/=0)
                    verif(j)=G05DYF(1,sum(n(1:2,gene)))
                 enddo
                 parent(verif(j),1)=rang3(i-nt1)
                 herk(verif(j))=2
              endif
              ped_p1(verif(j)+sum(n(1:2,0:gene-1)),2)=remain2(sum(n(3:4,0:gene-2))+rang3(i-nt1),1)
           enddo
           deallocate(verif)
        enddo

        ! Choose the dams
        do i=1,nt
           allocate(schon(offspPerSire(i,gene,1)))
           l=0
           schon=0
           do k=1,sum(n(1:2,gene))
              if(i<=nt1) then
                 if(parent(k,1)==rang(i).and.herk(k)==1) then
                    l=l+1
                    schon(l)=k ! storing the number of the offspring of the sire i
                 endif
              else
                 if(parent(k,1)==rang3(i-nt1).and.herk(k)==2) then
                    l=l+1
                    schon(l)=k ! storing the number of the offspring of the sire i
                 endif
              endif
           enddo
           do j=1,nf
              if(damToSire(j)==i) then
                 allocate(verif(offspPerDam(j)))
                 verif=0
                 call G05DYF2(1,l,offspPerDam(j),verif) ! choose the offspring of sire i that are also from dam j
                 do k=1,offspPerDam(j)
                    if(parent(schon(verif(k)),2)==0) then
                       parent(schon(verif(k)),2)=n(1,gene-1)+rang2(j)
                    else
                       do while (parent(schon(verif(k)),2)/=0)
                          verif(k)=G05DYF(1,l)
                       enddo
                       parent(schon(verif(k)),2)=n(1,gene-1)+rang2(j)
                    endif
                    ped_p1(schon(verif(k))+sum(n(1:2,0:gene-1)),3)=remain(sum(n(1:2,0:gene-2))+rang2(j)+n(1,gene-1),1)
                 enddo
                 deallocate(verif)
              endif
           enddo
           deallocate(schon)
        enddo
        deallocate(rang,rang2)
        deallocate(offspPerDam,damToSire)

        ! Transmitting the genetic material
        call transm_adm_end(sum(n(1:2,gene)),nchrom,nloc,all2,all,&
             parent,pos_loc,allp2,cop2,cop,copp2,store_cop,herk)
        deallocate(all)
        if(allocated(cop)) deallocate(cop)
        j=0
        do i=1,time2
           j=max(j,sum(n(1:2,i)),sum(n(3:4,i)))
        enddo
        allocate(all(nmq+nqtl,j,2))
        if(store_cop==1) allocate(cop(nmq+nqtl,j,2))
        deallocate(gani)
        allocate(gani(j,nbpop+1))

        if(store_cop==1) then
           call mutat(1,sum(n(1:2,gene)),1,all2,all,cop2,cop)
        else
           call mutat_noCop(1,sum(n(1:2,gene)),all2,all)
        endif

        all(:,1:sum(n(1:2,gene)),:)=all2(:,1:sum(n(1:2,gene)),:)
        if(store_cop==1) cop(:,1:sum(n(1:2,gene)),:)=cop2(:,1:sum(n(1:2,gene)),:)
        deallocate(all2)
        if(allocated(cop2)) deallocate(cop2)

        if(test2) then
           polyg3=sqrt((sum(gind(1:sum(n(1:2,gene-1)),1)**2)+sum(gind(1:sum(n(3:4,gene-1)),2)**2))/sum(n(:,gene-1))-&
                ((sum(gind(1:sum(n(1:2,gene-1)),1))+sum(gind(1:sum(n(3:4,gene-1)),2)))/sum(n(:,gene-1)))**2)
        else
           polyg3=polyg
        endif
        call pheno_end(parent,gind,sum(n(1:2,gene)),1,polyg3,gani,1,envir,perf,all,eff_qtl,nqtl,posqtl,&
             pos_assoc,nrmat,nrmat3,eff_dom,herk)


        ! Finally create the new individuals of the second population
        nt=nint(n(3,gene-1)*sel(3,gene-1,1))
        nf=nint(n(4,gene-1)*sel(4,gene-1,1))
        allocate(damToSire(nf))
        damToSire=0
        if(DamSire==0) then
           if(evenly==0) then
              do i=2,nt
                 damPerSire(i,gene,2)=damPerSire(1,gene,2)
              enddo
           else
              if(sum(damPerSire(nt+1:n(3,gene),gene,2))/=0) then
                 print*,'ERROR: SIRES THAT ARE NOT SELECTIBLE SHOULD BE PARENT'
                 stop 1
              endif
           endif
           do i=1,nt
              damToSire(sum(damPerSire(1:i-1,gene,2))+1:sum(damPerSire(1:i,gene,2)))=i
           enddo
        else
           ! The number of dams per sire is chosen randomly
           call G05DYF2(1,nt,nf,damToSire)
           if(nt<=nf) then
              allocate(parent2(nf,1))
              parent2(:,1)=damToSire(:)
              do i=1,nt
                 do while (count(any(parent2 .eq. i,1))==0)
                    allocate(verif(nt))
                    verif=0
                    ii=0
                    do j=1,nt
                       k=0
                       do l=1,nf
                          if(parent2(l,1)==j) k=k+1
                       enddo
                       if(k>1) then
                          ii=ii+1
                          verif(ii)=j
                       endif
                    enddo
                    l=G05DYF(1,ii)
                    allocate(rang(nf))
                    rang=0
                    k=0
                    do j=1,nf
                       if(parent2(j,1)==verif(l)) then
                          k=k+1
                          rang(k)=j
                       endif
                    enddo
                    j=G05DYF(1,k)
                    parent2(rang(j),1)=i
                    deallocate(rang, verif)
                 enddo
              enddo
              damToSire(:)=parent2(:,1)
              deallocate(parent2)
           endif
           do i=1,nt
              l=0
              do j=1,nf
                 if(damToSire(j)==i) l=l+1
              enddo
              damPerSire(i,gene,2)=l
           enddo
        endif

        ! Number of offspring per sire
        allocate(offspPerDam(nf))
        if(offSire==0) then
           if(uniformity==0) then
              do i=2,nt
                 offspPerSire(i,gene,2)=offspPerSire(1,gene,2)
              enddo
           endif
           if(constant3==0) then
              do i=1,nf
                 offspPerDam(i)=nint(real(offspPerSire(damToSire(i),gene,2))/&
                      real(damPerSire(damToSire(i),gene,2)))
              enddo
           else
              do i=1,nt
                 l=0
                 m=0
                 if(damPerSire(i,gene,2)==1) then
                    do j=1,nf
                       if(damToSire(j)==i) exit
                    enddo
                    offspPerDam(j)=offspPerSire(i,gene,2)
                 else
                    do j=1,nf
                       if(damToSire(j)==i) then
                          l=l+1
                          if(l<damPerSire(i,gene,2)) then
                             k=damPerSire(i,gene,2)-l ! Number of dams remaining for sire i after dam j
                             offspPerDam(j)=G05DYF(1,offspPerSire(i,gene,2)-m-k)
                             m=m+offspPerDam(j)
                          else
                             offspPerDam(j)=offspPerSire(i,gene,2)-m-k+1
                          endif
                       endif
                    enddo
                 endif
              enddo
           endif
        else ! The number of offspring per sire is random
           offspPerSire(:,gene,2)=0
           call G05DYF2(1,nt,sum(n(3:4,gene)),offspPerSire(1:nt,gene,2))
           k=sum(offspPerSire(1:nt,gene,2))
           do while(k/=sum(n(3:4,gene))) 
              l=G05DYF(1,nt)
              test=.TRUE.
              if(offspPerSire(l,gene,2)==0) test=.FALSE.
              if(offspPerSire(l,gene,2)==1.and.nt/=n(3,gene-1)) test=.FALSE.
              if(test) then
                 if(k<sum(n(3:4,gene))) then
                    offspPerSire(l,gene,2)=offspPerSire(l,gene,2)+1
                 else
                    offspPerSire(l,gene,2)=offspPerSire(l,gene,2)-1
                 endif
              endif
              k=sum(offspPerSire(1:nt,gene,2))
           enddo
           do i=1,nt 
              l=0
              m=0
              ii=0
              if(damPerSire(i,gene,2)==1) then
                 do j=1,nf
                    if(damToSire(j)==i) exit
                 enddo
                 offspPerDam(j)=offspPerSire(i,gene,2)
              else
                 do j=1,nf
                    if(damToSire(j)==i) then
                       if(ii<offspPerSire(i,gene,2)) then
                          l=l+1
                          if(l<damPerSire(i,gene,2)) then
                             k=damPerSire(i,gene,2)-l ! Number of dams remaining for sire i after dam j
                             offspPerDam(j)=G05DYF(1,offspPerSire(i,gene,2)-m-k)
                             m=m+offspPerDam(j)
                          else
                             offspPerDam(j)=offspPerSire(i,gene,2)-m-k+1
                          endif
                          ii=ii+offspPerDam(j)
                       else
                          offspPerDam(j)=0
                       endif
                    endif
                 enddo
              endif
           enddo
        endif

        ! If selection, ordering the individuals
        if(sel(4,gene-1,1)/=1.) then
           if(mode_sel(gene-1,4)==2) then
              k=sum(n(3:4,gene-1))
              r=sum(perf(1:k,2)**2)/k-(sum(perf(1:k,2))/k)**2
              alpha=(sum(gind(1:k,2)**2)/k-(sum(gind(1:k,2))/k)**2)/r
              allocate(EBV(sum(n(3:4,gene-1))+1,1))
              call computeBLUP(ped_p2(1:sum(n(3:4,1:gene-1)),:),sum(n(3:4,gene-1)),EBV,&
                   perf(:,2),alpha,remain)
              allocate(perf_temp(n(4,gene-1)))
              k=0
              do i=1,sum(n(3:4,gene-1))
                 if(remain2(i+sum(n(3:4,0:gene-2)),2)==2) then
                    k=k+1
                    perf_temp(k)=EBV(i+1,1)
                 endif
              enddo
              deallocate(EBV)
           else if (mode_sel(gene-1,4)==0) then
              allocate(perf_temp(n(4,gene-1)))
              k=0
              do i=1,sum(n(3:4,gene-1))
                 if(remain2(i+sum(n(3:4,0:gene-2)),2)==2) then
                    k=k+1
                    perf_temp(k)=perf(i,2)
                 endif
              enddo
           else
              allocate(reserv(sum(n(3:4,gene-1))))
              call given_accur(gind,accur(gene-1,3),accur(gene-1,4),reserv,2,n(3,gene-1),&
                   sum(n(3:4,gene-1)),allp2,pos_assoc,nqtl,eff_qtl,posqtl)
              allocate(perf_temp(n(4,gene-1)))
              k=0
              do i=1,sum(n(3:4,gene-1))
                 if(remain2(i+sum(n(3:4,0:gene-2)),2)==2) then
                    k=k+1
                    perf_temp(k)=reserv(i)
                 endif
              enddo
              deallocate(reserv)
           endif
           allocate(rang2(n(4,gene-1)))
           call search_best(perf_temp(1:n(4,gene-1)),n(4,gene-1),&
                rang2,n(4,gene-1))
           deallocate(perf_temp)
        else
           allocate(rang2(n(4,gene-1)))
           do i=1,n(4,gene-1)
              rang2(i)=i
           enddo
        endif

        ! Creation of the new generation
        allocate(parent2(sum(n(3:4,gene)),2))
        allocate(all2(nmq+nqtl,sum(n(3:4,gene)),2))
        if(store_cop==1) allocate(cop2(nmq+nqtl,sum(n(3:4,gene)),2))
        parent2=0
        ! Choose the sires
        do i=1,nt ! Out of those from the 2nd population
           allocate(verif(offspPerSire(i,gene,2)))
           call G05DYF2(1,sum(n(3:4,gene)),offspPerSire(i,gene,2),verif)
           do j=1,offspPerSire(i,gene,2)
              if(parent2(verif(j),1)==0) then
                 parent2(verif(j),1)=rang3(i)
              else
                 do while (parent2(verif(j),1)/=0)
                    verif(j)=G05DYF(1,sum(n(3:4,gene)))
                 enddo
                 parent2(verif(j),1)=rang3(i)
              endif
              ped_p2(verif(j)+sum(n(3:4,0:gene-1)),2)=remain2(rang3(i)+sum(n(3:4,0:gene-2)),1)
           enddo
           deallocate(verif)
        enddo

        ! Choose the dams
        do i=1,nt
           allocate(schon(offspPerSire(i,gene,2)))
           l=0
           schon=0
           do k=1,sum(n(3:4,gene))
              if(parent2(k,1)==rang3(i)) then
                 l=l+1
                 schon(l)=k ! storing the number of offspring of the sire i
              endif
           enddo
           do j=1,nf
              if(damToSire(j)==i) then
                 allocate(verif(offspPerDam(j)))
                 verif=0
                 call G05DYF2(1,l,offspPerDam(j),verif) ! choose the offspring of sire i that are also from dam j
                 do k=1,offspPerDam(j)
                    if(parent2(schon(verif(k)),2)==0) then
                       parent2(schon(verif(k)),2)=n(3,gene-1)+rang2(j)
                    else
                       do while (parent2(schon(verif(k)),2)/=0)
                          verif(k)=G05DYF(1,l)
                       enddo
                       parent2(schon(verif(k)),2)=n(3,gene-1)+rang2(j)
                    endif
                    ped_p2(schon(verif(k))+sum(n(3:4,0:gene-1)),3)=remain2(rang2(i)+sum(n(3:4,0:gene-2))+n(3,gene-1),1)
                 enddo
                 deallocate(verif)
              endif
           enddo
           deallocate(schon)
        enddo
        deallocate(rang3,rang2)
        deallocate(offspPerDam,damToSire)

        ! Transmitting the genetic material
        if(store_cop==1) then
           call transm(sum(n(3:4,gene)),nchrom,nloc,all2,allp2,parent2,pos_loc,cop2,copp2)
           call mutat(1,sum(n(3:4,gene)),1,allp2,all2,copp2,cop2)
        else
           call transm_noCop(sum(n(3:4,gene)),nchrom,nloc,all2,allp2,parent2,pos_loc)
           call mutat_noCop(1,sum(n(3:4,gene)),allp2,all2)
        endif
        deallocate(all2)
        if(store_cop==1) deallocate(cop2)

        call pheno(parent2,gind,sum(n(3:4,gene)),2,polyg2,gani,1,envir2,perf,allp2,eff_qtl,nqtl,posqtl,&
             pos_assoc,nrmat3,eff_dom)

        call nrm_2pop_end(parent,parent2,sum(n(1:2,gene)),sum(n(3:4,gene)),sum(n(1:2,gene-1)),sum(n(3:4,gene-1)),&
             nrmat,nrmat2,nrmat3,herk)

        remain(1:sum(n(1:2,0:gene-1)),1)=0
        k=last_ind+sum(n(:,0:gene-1))
        do i=1,n(1,gene)
           remain(sum(n(1:2,0:gene-1))+i,1)=k+i
           remain(sum(n(1:2,0:gene-1))+i,2)=1
           ped_p1(sum(n(1:2,0:gene-1))+i,1)=k+i
        enddo
        do i=1+n(1,gene),sum(n(1:2,gene))
           remain(sum(n(1:2,0:gene-1))+i,1)=k+i
           remain(sum(n(1:2,0:gene-1))+i,2)=2
           ped_p1(sum(n(1:2,0:gene-1))+i,1)=k+i
        enddo
        remain2(1:sum(n(3:4,0:gene-1)),1)=0
        k=last_ind+sum(n(:,0:gene-1))+sum(n(1:2,gene))
        do i=1,n(3,gene)
           remain2(sum(n(3:4,0:gene-1))+i,1)=k+i
           remain2(sum(n(3:4,0:gene-1))+i,2)=1
           ped_p2(sum(n(3:4,0:gene-1))+i,1)=k+i
        enddo
        do i=1+n(3,gene),sum(n(3:4,gene))
           remain2(sum(n(3:4,0:gene-1))+i,1)=k+i
           remain2(sum(n(3:4,0:gene-1))+i,2)=2
           ped_p2(sum(n(3:4,0:gene-1))+i,1)=k+i
        enddo

        test=.FALSE.
        ! Then the outputs
        if(gene>=time2-gene_ped+1) then
           if(gene==time2) then
              do i=1,n(1,gene)
                 write(220,*)remain(sum(n(1:2,0:gene-1))+i,1), ped_p1(sum(n(1:2,0:gene-1))+i,&
                      2:3),last_gen+gene-time2+gene_ped, '1   1       pop1'
              enddo
              do i=1+n(1,gene),sum(n(1:2,gene))
                 write(220,*)remain(sum(n(1:2,0:gene-1))+i,1), ped_p1(sum(n(1:2,0:gene-1))+i,&
                      2:3),last_gen+gene-time2+gene_ped, '1   2      pop1'
              enddo
              do i=1,n(3,gene)
                 write(220,*)remain2(sum(n(3:4,0:gene-1))+i,1), ped_p2(sum(n(3:4,0:gene-1))+i,2:3),&
                      last_gen+gene-time2+gene_ped, '1    1      pop2'
              enddo
              do i=1+n(3,gene),sum(n(3:4,gene))
                 write(220,*)remain2(sum(n(3:4,0:gene-1))+i,1), ped_p2(sum(n(3:4,0:gene-1))+i,2:3),&
                      last_gen+gene-time2+gene_ped, '1    2      pop2'
              enddo
           else
              do i=1,n(1,gene)
                 write(220,*)remain(sum(n(1:2,0:gene-1))+i,1), ped_p1(sum(n(1:2,0:gene-1))+i,2:3),last_gen+1,'    0    1       pop1'
              enddo
              do i=1+n(1,gene),sum(n(1:2,gene))
                 write(220,*)remain(sum(n(1:2,0:gene-1))+i,1), ped_p1(sum(n(1:2,0:gene-1))+i,2:3),last_gen+1,'    0    2       pop1'
              enddo
              do i=1,n(3,gene)
                 write(220,*)remain2(sum(n(3:4,0:gene-1))+i,1),ped_p2(sum(n(3:4,0:gene-1))+i,2:3),last_gen+1,'    0    1      pop2'
              enddo
              do i=1+n(3,gene),sum(n(3:4,gene))
                 write(220,*)remain2(sum(n(3:4,0:gene-1))+i,1),ped_p2(sum(n(3:4,0:gene-1))+i,2:3),last_gen+1,'    0    2      pop2'
              enddo
           endif
           test=.TRUE.
        endif

        if(gene>=time2-gene_perf+1) then
           do i=1,sum(n(1:2,gene))
              write(24,*)remain(sum(n(1:2,0:gene-1))+i,1), perf(i,1),gind(i,1)
           enddo
!!$           do i=1,sum(n(3:4,gene))
!!$              write(24,*)remain2(sum(n(3:4,0:gene-1))+i,1), perf(i,2),gind(i,2)
!!$           enddo
           test=.TRUE.
        endif

        if(gene>=time2-gene_typ+1) then
           test=.TRUE.
           allocate(all3(nmq+nqtl,sum(n(1:2,gene)),2))
           allocate(all2(nmq+nqtl,sum(n(1:2,gene)),2))
           all2(:,1:sum(n(1:2,gene)),:)=all(:,1:sum(n(1:2,gene)),:)
           if(typing_err==1) call genot_err(1,sum(n(1:2,gene)),all2,all3,errSNP,errMST,miss_genot)
           deallocate(all2)
           allocate(all2(nmq,sum(n(1:2,gene)),2))
           if(store_cop==1) allocate(cop2(nmq,sum(n(1:2,gene)),2))
           l=0
           do i=1,nmq+nqtl
              if(indic(i)==1) then
                 l=l+1
              else
                 all2(i-l,1:sum(n(1:2,gene)),:)=all3(i,1:sum(n(1:2,gene)),:)
                 if(store_cop==1) cop2(i-l,1:sum(n(1:2,gene)),:)=cop(i,1:sum(n(1:2,gene)),:)
              endif
           enddo

           do i=1,sum(n(1:2,gene))
              do k=1,2
                 write(41,*)last_ind+id+i,k,all(:,i,k)
                 write(48,*)last_ind+id+i,k,all2(:,i,k)  
                 if(store_cop==1) then
                    write(50,*) remain(sum(n(1:2,0:gene-1))+i,1),k,(cop(m,i,k),m=1,nmq+nqtl)
                    write(51,*) remain(sum(n(1:2,0:gene-1))+i,1),k,(cop2(m,i,k),m=1,nmq)
                 endif
              enddo
           enddo
           deallocate(all2,all3)
           if(store_cop==1) deallocate(cop2)
        endif

        if(test) then
           id2=id
           id=id+sum(n(1:4,gene))
        endif

        deallocate(parent,parent2,herk)

     enddo


     if(.not.allocated(fqall)) allocate(fqall(nmq+nqtl,maxval(nball(:,:))))
     fqall=0
     call stat_freq_1(1,sum(n(1:2,time2)),all,nball,fqall)

     if(f_fqall=='y') then
        do i=1,nmq+nqtl
           do j=1,nball(i,1)
              write(10,*)i,j,fqall(i,j),sum(n(1:2,time2)),time+time2
           enddo
        enddo
        print*,'F6'
     endif

     if(f_fqcop=='y'.and.store_cop==1) then
        allocate(fqcop(nmq+nqtl,ncopmax(nbpop+1)))
        fqcop=0
        call stat_freq_1(1,sum(n(1:2,time2)),cop,maxcop,fqcop)
        allocate(cop_alef(nmq+nqtl,maxcop(nmq+nqtl,1)))
        cop_alef=0
        do i=1,sum(n(1:2,time2))
           do j=1,2
              do k=1,nmq+nqtl
                 do l=1,nqtl
                    if(k==posqtl(l).and.all(k,i,j)==alleff(l)) cop_alef(k,cop(k,i,j))=cop_alef(k,cop(k,i,j))+1
                 enddo
              enddo
           enddo
        enddo
        allocate(coprest(nmq+nqtl))
        coprest=0
        do i=1,nmq+nqtl
           do j=1,maxcop(i,1)
              if(fqcop(i,j)/=0) coprest(i)=coprest(i)+1
           enddo
        enddo
        do ii=1,nmq+nqtl
           do j=1,maxcop(ii,1)
              if(indic(ii)==1) then
                 if(fqcop(ii,j)>0.0001) write(19,'(3(i6,1x),f8.6,1x,i6,1x,i8,1x,i4)')ii,j,&
                      coprest(ii),fqcop(ii,j),cop_alef(ii,j),sum(n(1:2,time2)),time+time2
              else
                 if(fqcop(ii,j)>0.0001) write(19,'(3(i6,1x),f8.6,1x,i6,1x,i8,1x,i4)')ii,j,&
                      coprest(ii),fqcop(ii,j),zero,sum(n(1:2,time2)),time+time2
              endif
           enddo
        enddo
        deallocate(fqcop,cop_alef,coprest)
        print*,'F7'
     endif

     if(f_hPIC=='y') then
        allocate(pic(nmq+nqtl))
        call eval_pic(1,nball,nmq+nqtl,pic)
        call nbhaplotypes(nf*nt*tail_port,all2,indic,nmq,nqtl)
        prop_h=real(nb_h)/real(nb_h_init)
        prop_hc=real(nb_hc)/real(nb_hc_init)
        do i=1,nmq+nqtl
           write(13,'(i8,1x,3(i4,1x),f4.2,1x,i4,1x,f4.2,1x,i2,1x,f10.6)')sum(n(1:2,time2)),&
                time+time2,i,nb_h,prop_h,nb_hc,prop_hc,indic(i),pic(i)
        enddo
        print*,'F5'
     endif

     if(f_dl=='y'.or.f_dlq=='y') then
        call LD(lg_chrom,bin,nchrom,nball,nmq,nqtl,sum(n(1:2,time2)),all,fqall,verif_print,1,chr_loc,nloc,pos_loc,time+time2)
        print*,'F1'
     endif

     if(f_ibd=='y'.or.f_ibdq=='y') then
        if(store_cop==1) then
           allocate(seg_ibd(maxloc,nchrom,sum(n(1:2,time2)),2),deb(maxloc,nchrom,sum(n(1:2,time2)),2))
           allocate(fin(maxloc,nchrom,sum(n(1:2,time2)),2))
           allocate(seg_qtl(nqtl,sum(n(1:2,time2)),2),nb_seg(sum(n(1:2,time2)),2,nchrom))
           call long_seg(1,sum(n(1:2,time2)),nmq,nqtl,posqtl,cop,seg_ibd,deb,fin,seg_qtl,nb_seg,lg_chrom,chr_QTL,nchrom,dist)
           do i=1,sum(n(1:2,time2))
              do j=1,2
                 if(f_ibd=='y') then
                    do l=1,nchrom
                       do k=1,maxloc
                          if(seg_ibd(k,l,i,j)>0) then
                             write(21,*)last_ind+i,j,k,seg_ibd(k,l,i,j)
                          endif
                       enddo
                    enddo
                 endif
                 if(f_ibdq=='y') then
                    do k=1,nqtl
                       write(22,'(3(i4,1x),f12.7,1x,f6.4,1x,i6)')last_ind+i,j,k,seg_qtl(k,i,j),&
                            fqall(posqtl(k),alleff(k)),time+time2
                    enddo
                 endif
              enddo
           enddo
           deallocate(seg_qtl,seg_ibd,chr_QTL)
           deallocate(nb_seg,deb,fin)
           print*,'F2'
        endif
     endif

     if(f_csg=='y'.and.store_cop==1) then
        allocate(consmoy(nmq+nqtl),varcons(nmq+nqtl))
        call consang(1,sum(n(1:2,time2)),nmq,nqtl,cop,consmoy,varcons)
        do j=1,nmq+nqtl
           write(23,*)j,consmoy(j),varcons(j),sum(n(1:2,time2)),time+time2
        enddo
        print*,'F4'
     endif

     if (allocated(pic)) deallocate(pic)
     deallocate(fqall)

  else if (typ_pop==4) then

     open(41,file='simhaplo')
     open(411,file='simhaploNoQTL')
     open(42,file='simped')
     open(43,file='simperf')

     m=0
     mm=0
     nr=0
     allocate(reco(nmq+nqtl-1))
     reco=0.
     do i=1,nmq+nqtl-1
        reco(i)=fdinv(dist(i))      ! recombination rates
     enddo
     allocate(all2(nmq,1,2))
     if(allocated(parent)) deallocate(parent)

     IF(pedig==1)THEN
        if(lect==1)then
           nr=ntotanc1+ntotped1
           ! Simulated individuals
           allocate(all1(nmq+nqtl,anc1,2))
           allocate(perfp(anc1),gindp(anc1))
           do i=1,anc1
              all1(:,i,:)=all(:,i,:)
              perfp(i)=perf(i,1)
              gindp(i)=gind(i,1)
           enddo
           deallocate(all,perf,gind)
           if(nbpop==2) deallocate(allp2)
!!$           print*,'WARNING: ALL THE NUMBERS OF THE INDIVIDUALS IN THE REAL PEDIGREE MUT BE SUPERIOR TO',ntotanc1

           allocate(indm(ntotped1,1),perfm(ntotped1))
           allocate(gindm(ntotped1))
           allocate(all4(nmq+nqtl,ntotped1,2),parent(ntotped1,2))
           print*,ntotped1, ntotanc1
           open(125,file=file8)
           open(115,file=file9) 
           open(21,file=file10) 
           open(145,file=file11) 
           do i=1,ntotped1
              read(115,*)indm(i,1),parent(i,:) ! parent(i,1),parent(i,2)
              read(125,*)indm(i,1),all4(:,i,1),all4(:,i,2)
              read(145,*)indm(i,1),perfm(i)
              read(21,*)indm(i,1),gindm(i)
           enddo

           if(nbport==1)then
              allocate(all(nmq+nqtl,nt_hs*nfmax_hs*ndmax_hs,2))
              allocate(parent2(nt_hs,1),mat(nfmax_hs,1))
              allocate(gind_t(ndmax_hs),sires(nt_hs),dams(nfmax_hs),perf_t(ndmax_hs))
              do i=1,nt_hs
10               parent2(i,1)=G05DYF(1,ntotanc1)  
                 if(mod(parent2(i,1),2)/=0)then
                    sires(i)=parent2(i,1) ! bijective
                 else
                    go to 10
                 endif
                 if(any(parent2(i,1)==sires(1:i-1)))then
                    go to 10
                    sires(i)=parent2(i,1)
                 endif

                 iv=0
                 do ii=1,nmq+nqtl
                    if(indic(ii)==0) then
                       iv=iv+1
                       all2(iv,1,:)=all1(ii,parent2(i,1),:)
                    endif
                 enddo
                 do ii=1,2
                    write(41,*)parent2(i,1),ii,all1(:,parent2(i,1),ii)
                    write(411,*)parent2(i,1),ii,all2(:,1,ii)
                 enddo
                 write(42,*)parent2(i,1),'0    0' ! parent(indp(parent2(i,1),1),:)
                 write(43,*)parent2(i,1),perfp(parent2(i,1)),gindp(parent2(i,1))
              enddo

              mm=0
              do i=1,nt_hs
                 nfp=G05DYF(nfmin_hs,nfmax_hs)
                 do j=1,nfp 
20                  mat(j,1)=G05DYF(1,ntotped1)  
                    if(mod(indm(mat(j,1),1),2)==0)then
                       dams(j)=indm(mat(j,1),1)
                    else
                       go to 20
                    endif
                    if(any(indm(mat(j,1),1)==dams(1:j-1)))then
                       go to 20
                       dams(j)=indm(mat(j,1),1)
                    endif

                    iv=0
                    do ii=1,nmq+nqtl
                       if(indic(ii)==0) then
                          iv=iv+1
                          all2(iv,1,:)=all4(ii,mat(j,1),:)
                       endif
                    enddo
                    do ii=1,2
                       write(41,*)indm(mat(j,1),1),ii,all4(:,mat(j,1),ii)
                       write(411,*)indm(mat(j,1),1),ii,all2(:,1,ii)
                    enddo
                    write(42,*)indm(mat(j,1),1),parent(mat(j,1),:)
                    write(43,*)indm(mat(j,1),1),perfm(mat(j,1)),gindm(mat(j,1))

                    ndn=G05DYF(ndmin_hs,ndmax_hs)
                    do lll=1,ndn
                       mm=mm+1 
                       l=G05DYF(1,2)
                       all(:,lll,1)= all1(:,parent2(i,1),l)
                       do k=2,nmq+nqtl
                          r=G05CAF(r)
                          if(r<reco(k-1)) l=3-l
                          all(k,mm,1)=all1(k,parent2(i,1),l)
                       enddo
                       l=G05DYF(1,2)
                       all(:,lll,2)=all4(:,mat(j,1),l)
                       do k=2,nmq+nqtl
                          r=G05CAF(r)
                          if(r<reco(k-1)) l=3-l
                          all(k,mm,2)=all4(k,mat(j,1),l)
                       enddo
                       iv=0
                       do ii=1,nmq+nqtl
                          if(indic(ii)==0) then
                             iv=iv+1
                             all2(iv,1,:)=all(ii,mm,:)
                          endif
                       enddo
                       do ii=1,2
                          write(41,*)ntotanc1+maxval(indm(:,1))+mm,ii,all(:,mm,ii)
                          write(411,*)ntotanc1+maxval(indm(:,1))+mm,ii,all2(:,1,ii)
                       enddo


                       ! Individuals from 2 separed populations --> nrm=0 between them
                       mend=sqrt(0.5*polyg**2)
                       mendel=G05DDF(0.d0,mend)
                       gind_t(lll)=0.5*(gindp(parent2(i,1))+gindm(mat(j,1)))+mendel

                       valqtl=0.
                       epis=0
                       do k=1,nqtl
                          if(pos_assoc(k,3)/=0) then
                             if(pos_assoc(k,1)<pos_assoc(k,4)) then
                                if(pos_assoc(k,6)==1) then
                                   epis=epis+sum(eff_qtl(k,all(pos_assoc(k,1),mm,:)))*&
                                        sum(eff_qtl(pos_assoc(k,3),all(pos_assoc(k,4),mm,:)))
                                else
                                   test=.false.
                                   if(eff_qtl(k,all(pos_assoc(k,1),mm,1))==maxval(eff_qtl(k,:))) test=.true.
                                   if(eff_qtl(k,all(pos_assoc(k,1),mm,2))==maxval(eff_qtl(k,:))) test=.true.
                                   if (test) epis=epis+ sum(eff_qtl(pos_assoc(k,3),all(pos_assoc(k,4),mm,:)))
                                endif
                             endif
                          else
                             valqtl=valqtl+sum(eff_qtl(k,all(posqtl(k),mm,:)))
                             if(all(pos_assoc(k,1),mm,1)/=all(pos_assoc(k,1),mm,2)) &
                                  epis=epis+eff_dom(k)
                          endif
                       enddo
                       env=G05DDF(0.d0,envir)
                       poid=1
                       env=env/poid
                       perf_t(lll)=gind_t(lll)+env+valqtl+epis
                       write(42,*)ntotanc1+maxval(indm(:,1))+mm,parent2(i,1),indm(mat(j,1),1)
                       write(43,*)ntotanc1+maxval(indm(:,1))+mm,perf_t(lll),gind_t(lll)
                    enddo
                 enddo
              enddo
              deallocate(all4)


           else if(nbport==2)then
              allocate(all(nmq+nqtl,nt_hf2*nfmax_hf2*ndmax_hf2,2))
              nfp=G05DYF(nfmin_hf2,nfmax_hf2)
              allocate(gind_t(ndmax_hf2),sires(nt_hf2),dams(nfp),perf_t(ndmax_hf2))
              allocate(mat(nfp,1))
              do j=1,nfp  
30               mat(j,1)=G05DYF(1,ntotped1)  
                 if(mod(indm(mat(j,1),1),2)==0)then
                    dams(j)=indm(mat(j,1),1)
                 else
                    go to 30
                 endif
                 if(any(indm(mat(j,1),1)==dams(1:j-1)))then
                    go to 30
                    dams(j)=indm(mat(j,1),1)
                 endif
              enddo
              mm=0
              allocate(parent2(nt_hf2,1))
              do i=1,nt_hf2
40               parent2(i,1)=G05DYF(1,ntotanc1)  
                 if(mod(parent2(i,1),2)/=0)then
                    sires(i)=parent2(i,1)
                 else
                    go to 40
                 endif
                 if(any(parent2(i,1)==sires(1:i-1)))then
                    go to 40
                    sires(i)=parent2(i,1)
                 endif
                 iv=0
                 do ii=1,nmq+nqtl
                    if(indic(ii)==0) then
                       iv=iv+1
                       all2(iv,1,:)=all1(ii,parent2(i,1),:)
                    endif
                 enddo
                 do ii=1,2
                    write(41,*)parent2(i,1),ii,all1(:,parent2(i,1),ii)
                    write(411,*)parent2(i,1),ii,all2(:,1,ii)
                 enddo

                 write(42,*)parent2(i,1),parent(parent2(i,1),:)
                 write(43,*)parent2(i,1),perfp(parent2(i,1)),gindp(parent2(i,1))
                 do j=1,nfp  
                    iv=0
                    do ii=1,nmq+nqtl
                       if(indic(ii)==0) then
                          iv=iv+1
                          all2(iv,1,:)=all4(ii,mat(j,1),:)
                       endif
                    enddo
                    do ii=1,2
                       write(41,*)indm(mat(j,1),1),ii,all4(:,mat(j,1),ii)
                       write(411,*)indm(mat(j,1),1),ii,all2(:,1,ii)
                    enddo

                    write(42,*)indm(mat(j,1),1),parent(mat(j,1),:)
                    write(43,*)indm(mat(j,1),1),perfm(mat(j,1)),gindm(mat(j,1))
                    ndn=G05DYF(ndmin_hf2,ndmax_hf2)
                    do lll=1,ndn
                       mm=mm+1 
                       l=G05DYF(1,2)
                       all(:,mm,1)= all1(:,parent2(i,1),l)
                       do k=2,nmq+nqtl
                          r=G05CAF(r)
                          if(r<reco(k-1)) l=3-l
                          all(k,mm,1)=all1(k,parent2(i,1),l)
                       enddo
                       l=G05DYF(1,2)
                       all(:,mm,2)=all4(:,mat(j,1),l)
                       do k=2,nmq+nqtl
                          r=G05CAF(r)
                          if(r<reco(k-1)) l=3-l
                          all(k,mm,2)=all4(k,mat(j,1),l)
                       enddo
                       iv=0
                       do ii=1,nmq+nqtl
                          if(indic(ii)==0) then
                             iv=iv+1
                             all2(iv,1,:)=all(ii,mm,:)
                          endif
                       enddo
                       do ii=1,2
                          write(41,*)ntotanc1+maxval(indm(:,1))+mm,ii,all(:,mm,ii)
                          write(411,*)ntotanc1+maxval(indm(:,1))+mm,ii,all2(:,1,ii)
                       enddo
                       mend=sqrt(0.5*polyg**2)
                       mendel=G05DDF(0.d0,mend)
                       gind_t(lll)=0.5*(gindp(parent2(i,1))+gindm(mat(j,1)))+mendel

                       valqtl=0.
                       epis=0
                       do k=1,nqtl
                          if(pos_assoc(k,3)/=0) then
                             if(pos_assoc(k,1)<pos_assoc(k,4)) then
                                if(pos_assoc(k,6)==1) then
                                   epis=epis+sum(eff_qtl(k,all(pos_assoc(k,1),mm,:)))*&
                                        sum(eff_qtl(pos_assoc(k,3),all(pos_assoc(k,4),mm,:)))
                                else
                                   test=.false.
                                   if(eff_qtl(k,all(pos_assoc(k,1),mm,1))==maxval(eff_qtl(k,:))) test=.true.
                                   if(eff_qtl(k,all(pos_assoc(k,1),mm,2))==maxval(eff_qtl(k,:))) test=.true.
                                   if (test) epis=epis+ sum(eff_qtl(pos_assoc(k,3),all(pos_assoc(k,4),mm,:)))
                                endif
                             endif
                          else
                             valqtl=valqtl+sum(eff_qtl(k,all(posqtl(k),mm,:)))
                             if(all(pos_assoc(k,1),mm,1)/=all(pos_assoc(k,1),mm,2)) &
                                  epis=epis+eff_dom(k)
                          endif
                       enddo
                       env=G05DDF(0.d0,envir)
                       poid=1
                       env=env/poid
                       perf_t(lll)=gind_t(lll)+env+valqtl+epis
                       write(42,*)ntotanc1+maxval(indm(:,1))+mm,parent2(i,1),indm(mat(j,1),1)
                       write(43,*)ntotanc1+maxval(indm(:,1))+mm,perf_t(lll),gind_t(lll)
                    enddo
                 enddo
              enddo
           endif  ! de nbport


        else if(lect==2)then

           ntotanc1=anc1
           nr=ntotanc1+ntotped1

           ! Simulated individuals: the female ones
           allocate(all4(nmq+nqtl,anc1,2))
           allocate(perfm(anc1),gindm(anc1))
           do i=1,anc1
              all4(:,i,:)=all(:,i,:)
              perfm(i)=perf(i,1)
              gindm(i)=gind(i,1)
           enddo

           deallocate(all,perf,gind)
           if(nbpop==2) deallocate(allp2)
           print*,'WARNING: ALL OFFSPRING INDIVIDUALS IN THE REAL PEDIGREE MUST HAVE NUMBERS LOWER THAN',ntotped1+1

           allocate(all1(nmq+nqtl,ntotped1,2))
           allocate(indp(ntotped1,1),parent(ntotped1,2),perfp(ntotped1),gindp(ntotped1))
           open(125,file=file8)
           open(115,file=file9) 
           open(21,file=file10) 
           open(145,file=file11)
           do i=1,ntotped1
              read(115,*)indp(i,1),parent(i,:) ! parent(i,1),parent(i,2)
              read(125,*)indp(i,1),all1(:,i,1),all1(:,i,2)
              read(145,*)indp(i,1),perfp(i)
              read(21,*)indp(i,1),gindp(i)
           enddo

           if(nbport==1)then
              allocate(all(nmq+nqtl,nt_hs*nfmax_hs*ndmax_hs,2))
              allocate(gind_t(ndmax_hs),sires(nt_hs),dams(nfmax_hs),perf_t(ndmax_hs))
              allocate(parent2(nt_hs,2))
              do i=1,nt_hs
50               parent2(i,1)=G05DYF(1,ntotped1)  
                 if(mod(indp(parent2(i,1),1),2)/=0)then
                    sires(i)=indp(parent2(i,1),1)
                 else
                    go to 50
                 endif
                 if(any(indp(parent2(i,1),1)==sires(1:i-1)))then
                    go to 50
                    sires(i)=indp(parent2(i,1),1)
                 endif

                 iv=0
                 do ii=1,nmq+nqtl
                    if(indic(ii)==0) then
                       iv=iv+1
                       all2(iv,1,:)=all1(ii,parent2(i,1),:)
                    endif
                 enddo
                 do ii=1,2
                    write(41,*)indp(parent2(i,1),1),ii,all1(:,parent2(i,1),ii)
                    write(411,*)indp(parent2(i,1),1),ii,all2(:,1,ii)
                 enddo

                 write(42,*)indp(parent2(i,1),1),parent(parent2(i,1),:)

                 write(43,*)indp(parent2(i,1),1),perfp(parent2(i,1)),gindp(parent2(i,1))
              enddo

              allocate(mat(nfmax_hs,1))
              mm=0
              do i=1,nt_hs
                 nfp=G05DYF(nfmin_hs,nfmax_hs)
                 do j=1,nfp 
60                  mat(j,1)=G05DYF(1,ntotanc1)  
                    if(mod(mat(j,1),2)==0)then
                       dams(j)=mat(j,1)
                    else
                       go to 60
                    endif
                    if(any(mat(j,1)==dams(1:j-1)))then
                       go to 60
                       dams(j)=mat(j,1)
                    endif

                    iv=0
                    do ii=1,nmq+nqtl
                       if(indic(ii)==0) then
                          iv=iv+1
                          all2(iv,1,:)=all4(ii,mat(j,1),:)
                       endif
                    enddo
                    do ii=1,2
                       write(41,*)mat(j,1),ii,all4(:,mat(j,1),ii)
                       write(411,*)mat(j,1),ii,all2(:,1,ii)
                    enddo

                    write(42,*)mat(j,1),'0   0'
                    write(43,*)mat(j,1),perfm(mat(j,1)),gindm(mat(j,1))

                    ndn=G05DYF(ndmin_hs,ndmax_hs)
                    do lll=1,ndn
                       mm=mm+1 
                       l=G05DYF(1,2)
                       all(:,mm,1)= all1(:,parent2(i,1),l)
                       do k=2,nmq+nqtl
                          r=G05CAF(r)
                          if(r<reco(k-1)) l=3-l
                          all(k,mm,1)=all1(k,parent2(i,1),l)
                       enddo
                       l=G05DYF(1,2)
                       all(:,mm,2)=all4(:,mat(j,1),l)
                       do k=2,nmq+nqtl
                          r=G05CAF(r)
                          if(r<reco(k-1)) l=3-l
                          all(k,mm,2)=all4(k,mat(j,1),l)
                       enddo

                       iv=0
                       do ii=1,nmq+nqtl
                          if(indic(ii)==0) then
                             iv=iv+1
                             all2(iv,1,:)=all(ii,mm,:)
                          endif
                       enddo
                       do ii=1,2
                          write(41,*)ntotanc1+maxval(indp(:,1))+mm,ii,all(:,mm,ii)
                          write(411,*)ntotanc1+maxval(indp(:,1))+mm,ii,all2(:,1,ii)
                       enddo

                       mend=sqrt(0.5*polyg**2)
                       mendel=G05DDF(0.d0,mend)
                       gind_t(lll)=0.5*(gindp(parent2(i,1))+gindm(mat(j,1)))+mendel

                       valqtl=0d0
                       epis=0
                       do k=1,nqtl
                          if(pos_assoc(k,3)/=0) then
                             if(pos_assoc(k,1)<pos_assoc(k,4)) then
                                if(pos_assoc(k,6)==1) then
                                   epis=epis+sum(eff_qtl(k,all(pos_assoc(k,1),mm,:)))*&
                                        sum(eff_qtl(pos_assoc(k,3),all(pos_assoc(k,4),mm,:)))
                                else
                                   test=.false.
                                   if(eff_qtl(k,all(pos_assoc(k,1),mm,1))==maxval(eff_qtl(k,:))) test=.true.
                                   if(eff_qtl(k,all(pos_assoc(k,1),mm,2))==maxval(eff_qtl(k,:))) test=.true.
                                   if (test) epis=epis+ sum(eff_qtl(pos_assoc(k,3),all(pos_assoc(k,4),mm,:)))
                                endif
                             endif
                          else
                             valqtl=valqtl+sum(eff_qtl(k,all(posqtl(k),mm,:)))
                             if(all(pos_assoc(k,1),mm,1)/=all(pos_assoc(k,1),mm,2)) &
                                  epis=epis+eff_dom(k)
                          endif
                       enddo
                       env=G05DDF(0.d0,envir)
                       poid=1
                       env=env/poid
                       perf_t(lll)=gind_t(lll)+env+valqtl+epis
                       write(42,*)ntotanc1+maxval(indp(:,1))+mm,indp(parent2(i,1),1),mat(j,1)
                       write(43,*)ntotanc1+maxval(indp(:,1))+mm,perf_t(lll),gind_t(lll)
                    enddo
                 enddo
              enddo

           else if(nbport==2)then

              nfp=G05DYF(nfmin_hf2,nfmax_hf2)
              allocate(gind_t(ndmax_hf2),sires(nt_hf2),dams(nfp),perf_t(ndmax_hf2))
              allocate(mat(nfp,1),parent2(nt_hf2,1))
              allocate(all(nmq+nqtl,nt_hf2*nfmax_hf2*ndmax_hf2,2))

              do j=1,nfp  
70               mat(j,1)=G05DYF(1,ntotanc1)  
                 if(mod(mat(j,1),2)==0)then
                    dams(j)=mat(j,1)
                 else
                    go to 70
                 endif
                 if(any(mat(j,1)==dams(1:j-1)))then
                    go to 70
                    dams(j)=mat(j,1)
                 endif
              enddo

              do i=1,nt_hf2
80               parent2(i,1)=G05DYF(1,ntotped1)  
                 if(mod(indp(parent2(i,1),1),2)/=0)then
                    sires(i)=indp(parent2(i,1),1)
                 else
                    go to 80
                 endif
                 if(any(indp(parent2(i,1),1)==sires(1:i-1)))then
                    go to 80
                    sires(i)=indp(parent2(i,1),1)
                 endif

                 iv=0
                 do ii=1,nmq+nqtl
                    if(indic(ii)==0) then
                       iv=iv+1
                       all2(iv,1,:)=all1(ii,parent2(i,1),:)
                    endif
                 enddo
                 do ii=1,2
                    write(41,*)indp(parent2(i,1),1),ii,all1(:,parent2(i,1),ii)
                    write(411,*)indp(parent2(i,1),1),ii,all2(:,1,ii)
                 enddo
                 write(42,*)indp(parent2(i,1),1),parent(parent2(i,1),:)
                 write(43,*)indp(parent2(i,1),1),perfp(parent2(i,1)),gindp(parent2(i,1))

                 do j=1,nfp  

                    iv=0
                    do ii=1,nmq+nqtl
                       if(indic(ii)==0) then
                          iv=iv+1
                          all2(iv,1,:)=all4(ii,mat(j,1),:)
                       endif
                    enddo
                    do ii=1,2
                       write(41,*)mat(j,1),ii,all4(:,mat(j,1),ii)
                       write(411,*)mat(j,1),ii,all2(:,1,ii)
                    enddo

                    write(42,*)mat(j,1),parent(mat(j,1),:)
                    write(43,*)mat(j,1),perfm(mat(j,1)),gindm(mat(j,1))
                    ndn=G05DYF(ndmin_hf2,ndmax_hf2)
                    do lll=1,ndn
                       mm=mm+1 
                       l=G05DYF(1,2)
                       all(:,mm,1)= all1(:,parent2(i,1),l)
                       do k=2,nmq+nqtl
                          r=G05CAF(r)
                          if(r<reco(k-1)) l=3-l
                          all(k,mm,1)=all1(k,parent2(i,1),l)
                       enddo
                       l=G05DYF(1,2)
                       all(:,mm,2)=all4(:,mat(j,1),l)
                       do k=2,nmq+nqtl
                          r=G05CAF(r)
                          if(r<reco(k-1)) l=3-l
                          all(k,mm,2)=all4(k,mat(j,1),l)
                       enddo
                       iv=0
                       do ii=1,nmq+nqtl
                          if(indic(ii)==0) then
                             iv=iv+1
                             all2(iv,1,:)=all(ii,mm,:)
                          endif
                       enddo
                       do ii=1,2
                          write(41,*)ntotanc1+maxval(indp(:,1))+mm,ii,all(:,mm,ii)
                          write(411,*)ntotanc1+maxval(indp(:,1))+mm,ii,all2(:,1,ii)
                       enddo

                       mend=sqrt(0.5*polyg**2)
                       mendel=G05DDF(0.d0,mend)
                       gind_t(lll)=0.5*(gindp(parent2(i,1))+gindm(mat(j,1)))+mendel

                       valqtl=0d0
                       epis=0
                       do k=1,nqtl
                          if(pos_assoc(k,3)/=0) then
                             if(pos_assoc(k,1)<pos_assoc(k,4)) then
                                if(pos_assoc(k,6)==1) then
                                   epis=epis+sum(eff_qtl(k,all(pos_assoc(k,1),mm,:)))*&
                                        sum(eff_qtl(pos_assoc(k,3),all(pos_assoc(k,4),mm,:)))
                                else
                                   test=.false.
                                   if(eff_qtl(k,all(pos_assoc(k,1),mm,1))==maxval(eff_qtl(k,:))) test=.true.
                                   if(eff_qtl(k,all(pos_assoc(k,1),mm,2))==maxval(eff_qtl(k,:))) test=.true.
                                   if (test) epis=epis+ sum(eff_qtl(pos_assoc(k,3),all(pos_assoc(k,4),mm,:)))
                                endif
                             endif
                          else
                             valqtl=valqtl+sum(eff_qtl(k,all(posqtl(k),mm,:)))
                             if(all(pos_assoc(k,1),mm,1)/=all(pos_assoc(k,1),mm,2)) &
                                  epis=epis+eff_dom(k)
                          endif
                       enddo
                       env=G05DDF(0.d0,envir)
                       poid=1
                       env=env/poid
                       perf_t(lll)=gind_t(lll)+env+valqtl+epis
                       write(42,*)ntotanc1+maxval(indp(:,1))+mm,indp(parent2(i,1),1),mat(j,1)
                       write(43,*)ntotanc1+maxval(indp(:,1))+mm,perf_t(lll),gind_t(lll)
                    enddo
                 enddo
              enddo
           endif  ! de nbport

        else if(lect==3)then

           ! All animals are in the real pedigree
           deallocate(all,perf,gind)
           if(allocated(allp2)) deallocate(allp2)
           if(allocated(cop)) deallocate(cop)
           if(allocated(copp2)) deallocate(copp2)
           nr=ntotped1

           allocate(all1(nmq+nqtl,nr,2))
           allocate(ind(nr),parent(nr,2),gindp(nr),perfp(nr))

           open(125,file=file8)
           open(115,file=file9) 
           open(21,file=file10) 
           open(145,file=file11) 
           do i=1,ntotped1
              read(115,*)ind(i),parent(i,:) ! parent(i,1),parent(i,2)
              read(125,*)ind(i),all1(:,i,1),all1(:,i,2)
              read(145,*)ind(i),perfp(i)
              read(21,*) ind(i),gindp(i)
           enddo

           if(nbport==1)then

              allocate(all(nmq+nqtl,nt_hs*nfmax_hs*ndmax_hs,2),parent2(nt_hs,1),mat(nfmax_hs,1))
              allocate(gind_t(ndmax_hs),sires(nt_hs),dams(nfmax_hs),perf_t(ndmax_hs))
              do i=1,nt_hs
90               parent2(i,1)=G05DYF(1,ntotped1)  
                 if(mod(ind(parent2(i,1)),2)/=0)then
                    sires(i)=ind(parent2(i,1))
                 else
                    go to 90
                 endif
                 if(any(ind(parent2(i,1))==sires(1:i-1)))then
                    go to 90
                    sires(i)=ind(parent2(i,1))
                 endif

                 iv=0
                 do ii=1,nmq+nqtl
                    if(indic(ii)==0) then
                       iv=iv+1
                       all2(iv,1,:)=all1(ii,parent2(i,1),:)
                    endif
                 enddo
                 do ii=1,2
                    write(41,*)ind(parent2(i,1)),ii,all1(:,parent2(i,1),ii)
                    write(411,*)ind(parent2(i,1)),ii,all2(:,1,ii)
                 enddo

                 write(42,*)ind(parent2(i,1)),parent(parent2(i,1),:)
                 write(43,*)ind(parent2(i,1)),perfp(parent2(i,1)),gindp(parent2(i,1))
              enddo
              mm=0
              do i=1,nt_hs
                 nfp=G05DYF(nfmin_hs,nfmax_hs)
                 do j=1,nfp 
110                 mat(j,1)=G05DYF(1,ntotped1)  
                    if(mod(ind(mat(j,1)),1)==0)then
                       dams(j)=ind(mat(j,1))
                    else
                       go to 110
                    endif
                    if(any(ind(mat(j,1))==dams(1:j-1)))then
                       go to 110
                       dams(j)=ind(mat(j,1))
                    endif
                    iv=0
                    do ii=1,nmq+nqtl
                       if(indic(ii)==0) then
                          iv=iv+1
                          all2(iv,1,:)=all1(ii,mat(j,1),:)
                       endif
                    enddo
                    do ii=1,2
                       write(41,*)ind(mat(j,1)),ii,all1(:,mat(j,1),ii)
                       write(411,*)ind(mat(j,1)),ii,all2(:,1,ii)
                    enddo

                    write(42,*)ind(mat(j,1)),parent(mat(j,1),:)
                    write(43,*)ind(mat(j,1)),perfp(mat(j,1)),gindp(mat(j,1))
                    ndn=G05DYF(ndmin_hs,ndmax_hs)
                    do lll=1,ndn
                       mm=mm+1 
                       l=G05DYF(1,2)
                       all(:,mm,1)= all1(:,parent2(i,1),l)
                       do k=2,nmq+nqtl
                          r=G05CAF(r)
                          if(r<reco(k-1)) l=3-l
                          all(k,mm,1)=all1(k,parent2(i,1),l)
                       enddo
                       l=G05DYF(1,2)
                       all(:,mm,2)=all1(:,mat(j,1),l)
                       do k=2,nmq+nqtl
                          r=G05CAF(r)
                          if(r<reco(k-1)) l=3-l
                          all(k,mm,2)=all1(k,mat(j,1),l)
                       enddo
                       iv=0
                       do ii=1,nmq+nqtl
                          if(indic(ii)==0) then
                             iv=iv+1
                             all2(iv,1,:)=all(ii,mm,:)
                          endif
                       enddo
                       do ii=1,2
                          write(41,*)maxval(ind(:))+mm,ii,all(:,mm,ii)
                          write(411,*)maxval(ind(:))+mm,ii,all2(:,1,ii)
                       enddo

                       mend=sqrt(0.5*polyg**2)
                       mendel=G05DDF(0.d0,mend)
                       gind_t(lll)=0.5*(gindp(parent2(i,1))+gindp(mat(j,1)))+mendel

                       valqtl=0d0
                       epis=0
                       do k=1,nqtl
                          if(pos_assoc(k,3)/=0) then
                             if(pos_assoc(k,1)<pos_assoc(k,4)) then
                                if(pos_assoc(k,6)==1) then
                                   epis=epis+sum(eff_qtl(k,all(pos_assoc(k,1),mm,:)))*&
                                        sum(eff_qtl(pos_assoc(k,3),all(pos_assoc(k,4),mm,:)))
                                else
                                   test=.false.
                                   if(eff_qtl(k,all(pos_assoc(k,1),mm,1))==maxval(eff_qtl(k,:))) test=.true.
                                   if(eff_qtl(k,all(pos_assoc(k,1),mm,2))==maxval(eff_qtl(k,:))) test=.true.
                                   if (test) epis=epis+ sum(eff_qtl(pos_assoc(k,3),all(pos_assoc(k,4),mm,:)))
                                endif
                             endif
                          else
                             valqtl=valqtl+sum(eff_qtl(k,all(posqtl(k),mm,:)))
                             if(all(pos_assoc(k,1),mm,1)/=all(pos_assoc(k,1),mm,2)) &
                                  epis=epis+eff_dom(k)
                          endif
                       enddo
                       poid=1
                       env=env/poid
                       perf_t(lll)=gind_t(lll)+env+valqtl+epis
                       write(42,*)maxval(ind(:))+mm,ind(parent2(i,1)),ind(mat(j,1))
                       write(43,*)maxval(ind(:))+mm,perf_t(lll),gind_t(lll)
                    enddo
                 enddo
              enddo

           else if(nbport==2)then

              nfp=G05DYF(nfmin_hf2,nfmax_hf2)
              allocate(all(nmq+nqtl,nt_hf2*nfmax_hf2*ndmax_hf2,2),parent2(nt_hf2,1),mat(nfmax_hf2,1))
              allocate(gind_t(ndmax_hf2),sires(nt_hf2),dams(nfmax_hf2),perf_t(ndmax_hf2))

              do j=1,nfp  
120              mat(j,1)=G05DYF(1,ntotped1)  
                 if(mod(ind(mat(j,1)),1)==0)then
                    dams(j)=ind(mat(j,1))
                 else
                    go to 120
                 endif
                 if(any(ind(mat(j,1))==dams(1:j-1)))then
                    go to 120
                    dams(j)=ind(mat(j,1))
                 endif
              enddo

              mm=0
              do i=1,nt_hf2
130              parent2(i,1)=G05DYF(1,ntotped1)  
                 if(mod(ind(parent2(i,1)),2)/=0)then
                    sires(i)=ind(parent2(i,1))
                 else
                    go to 130
                 endif
                 if(any(ind(parent2(i,1))==sires(1:i-1)))then
                    go to 130
                    sires(i)=ind(parent2(i,1))
                 endif

                 iv=0
                 do ii=1,nmq+nqtl
                    if(indic(ii)==0) then
                       iv=iv+1
                       all2(iv,1,:)=all1(ii,parent2(i,1),:)
                    endif
                 enddo
                 do ii=1,2
                    write(41,*)ind(parent2(i,1)),ii,all1(:,parent2(i,1),ii)
                    write(411,*)ind(parent2(i,1)),ii,all2(:,1,ii)
                 enddo

                 write(42,*)ind(parent2(i,1)),parent(parent2(i,1),:)
                 write(43,*)ind(parent2(i,1)),perfp(parent2(i,1)),gindp(parent2(i,1))

                 do j=1,nfp  

                    iv=0
                    do ii=1,nmq+nqtl
                       if(indic(ii)==0) then
                          iv=iv+1
                          all2(iv,1,:)=all1(ii,mat(j,1),:)
                       endif
                    enddo
                    do ii=1,2
                       write(41,*)ind(mat(j,1)),ii,all1(:,mat(j,1),ii)
                       write(411,*)ind(mat(j,1)),ii,all2(:,1,ii)
                    enddo

                    write(42,*)ind(mat(j,1)),parent(mat(j,1),:)
                    write(43,*)ind(mat(j,1)),perfp(mat(j,1)),gindp(mat(j,1))

                    ndn=G05DYF(ndmin_hf2,ndmax_hf2)
                    do lll=1,ndn
                       mm=mm+1 
                       l=G05DYF(1,2)
                       all(:,mm,1)= all1(:,parent2(i,1),l)
                       do k=2,nmq+nqtl
                          r=G05CAF(r)
                          if(r<reco(k-1)) l=3-l
                          all(k,mm,1)=all1(k,parent2(i,1),l)
                       enddo
                       l=G05DYF(1,2)
                       all(:,mm,2)=all1(:,mat(j,1),l)
                       do k=2,nmq+nqtl
                          r=G05CAF(r)
                          if(r<reco(k-1)) l=3-l
                          all(k,mm,2)=all1(k,mat(j,1),l)
                       enddo

                       iv=0
                       do ii=1,nmq+nqtl
                          if(indic(ii)==0) then
                             iv=iv+1
                             all2(iv,1,:)=all(ii,mm,:)
                          endif
                       enddo
                       do ii=1,2
                          write(41,*)maxval(ind(:))+mm,ii,all(:,mm,ii)
                          write(411,*)maxval(ind(:))+mm,ii,all2(:,1,ii)
                       enddo

                       mend=sqrt(0.5*polyg**2)
                       mendel=G05DDF(0.d0,mend)
                       gind_t(lll)=0.5*(gindp(parent2(i,1))+gindp(mat(j,1)))+mendel

                       valqtl=0d0
                       epis=0
                       do k=1,nqtl
                          if(pos_assoc(k,3)/=0) then
                             if(pos_assoc(k,1)<pos_assoc(k,4)) then
                                if(pos_assoc(k,6)==1) then
                                   epis=epis+sum(eff_qtl(k,all(pos_assoc(k,1),mm,:)))*&
                                        sum(eff_qtl(pos_assoc(k,3),all(pos_assoc(k,4),mm,:)))
                                else
                                   test=.false.
                                   if(eff_qtl(k,all(pos_assoc(k,1),mm,1))==maxval(eff_qtl(k,:))) test=.true.
                                   if(eff_qtl(k,all(pos_assoc(k,1),mm,2))==maxval(eff_qtl(k,:))) test=.true.
                                   if (test) epis=epis+ sum(eff_qtl(pos_assoc(k,3),all(pos_assoc(k,4),mm,:)))
                                endif
                             endif
                          else
                             valqtl=valqtl+sum(eff_qtl(k,all(posqtl(k),mm,:)))
                             if(all(pos_assoc(k,1),mm,1)/=all(pos_assoc(k,1),mm,2)) &
                                  epis=epis+eff_dom(k)
                          endif
                       enddo
                       env=G05DDF(0.d0,envir)
                       poid=1
                       env=env/poid
                       perf_t(lll)=gind_t(lll)+env+valqtl+epis
                       write(42,*)maxval(ind(:))+mm,ind(parent2(i,1)),ind(mat(j,1))
                       write(43,*)maxval(ind(:))+mm,perf_t(lll),gind_t(lll)
                    enddo
                 enddo
              enddo
           endif  ! de nbport

        else if(lect==4)then
           nr=ntotanc1

           ! Simulated individuals
           allocate(all1(nmq+nqtl,anc1,2))
           allocate(perfp(anc1),gindp(anc1))
           do i=1,anc1
              all1(:,i,:)=all(:,i,:)
              perfp(i)=perf(i,1)
              gindp(i)=gind(i,1)
           enddo
           deallocate(all,perf,gind)
           if(nbpop==2) deallocate(allp2)

           allocate(nrmat_fin(ntotanc1,ntotanc1))
           do i=1,anc1
              nrmat_fin(i,1:anc1)=nrmat(i,1:anc1)
           enddo
           deallocate(nrmat)
           if(nbpop==2) then
              deallocate(nrmat2,nrmat3)
           endif

           if(nbport==1)then

              allocate(parent2(nt_hs,1),mat(nfmax_hs,1),perf_t(ndmax_hs))
              allocate(gind_t(ndmax_hs),sires(nt_hs),dams(nfmax_hs))
              allocate(all(nmq+nqtl,nt_hs*nfmax_hs*ndmax_hs,2))

              do i=1,nt_hs
140              parent2(i,1)=G05DYF(1,ntotanc1)  
                 if(mod(parent2(i,1),2)/=0)then
                    sires(i)=parent2(i,1)
                 else
                    go to 140
                 endif
                 if(any(parent2(i,1)==sires(1:i-1)))then
                    go to 140
                    sires(i)=parent2(i,1)
                 endif

                 iv=0
                 do ii=1,nmq+nqtl
                    if(indic(ii)==0) then
                       iv=iv+1
                       all2(iv,1,:)=all1(ii,parent2(i,1),:)
                    endif
                 enddo
                 do ii=1,2
                    write(41,*)parent2(i,1),ii,all1(:,parent2(i,1),ii)
                    write(411,*)parent2(i,1),ii,all2(:,1,ii)
                 enddo

                 write(42,*)parent2(i,1),'0   0'
                 write(43,*)parent2(i,1),perfp(parent2(i,1)),gindp(parent2(i,1))
              enddo

              mm=0
              do i=1,nt_hs
                 nf=G05DYF(nfmin_hs,nfmax_hs)
                 if (nf>=nfmin_hs.OR.nf<=nfmax_hs)then
                    nfp=nf
                 endif
                 do j=1,nfp 
150                 mat(j,1)=G05DYF(1,ntotanc1)  
                    if(mod(mat(j,1),2)==0)then
                       dams(j)=mat(j,1)
                    else
                       go to 150
                    endif
                    if(any(mat(j,1)==dams(1:j-1)))then
                       go to 150
                       dams(j)=mat(j,1)
                    endif
                    iv=0
                    do ii=1,nmq+nqtl
                       if(indic(ii)==0) then
                          iv=iv+1
                          all2(iv,1,:)=all1(ii,mat(j,1),:)
                       endif
                    enddo
                    do ii=1,2
                       write(41,*)mat(j,1),ii,all1(:,mat(j,1),ii)
                       write(411,*)mat(j,1),ii,all2(:,1,ii)
                    enddo

                    write(42,*)mat(j,1),'0    0'
                    write(43,*)mat(j,1),perfp(mat(j,1)),gindp(mat(j,1))

                    ndn=G05DYF(ndmin_hs,ndmax_hs)
                    do lll=1,ndn
                       mm=mm+1 
                       l=G05DYF(1,2)
                       all(:,mm,1)= all1(:,parent2(i,1),l)
                       do k=2,nmq+nqtl
                          r=G05CAF(r)
                          if(r<reco(k-1)) l=3-l
                          all(k,mm,1)=all1(k,parent2(i,1),l)
                       enddo
                       l=G05DYF(1,2)
                       all(:,mm,2)=all1(:,mat(j,1),l)
                       do k=2,nmq+nqtl
                          r=G05CAF(r)
                          if(r<reco(k-1)) l=3-l
                          all(k,mm,2)=all1(k,mat(j,1),l)
                       enddo

                       iv=0
                       do ii=1,nmq+nqtl
                          if(indic(ii)==0) then
                             iv=iv+1
                             all2(iv,1,:)=all(ii,mm,:)
                          endif
                       enddo
                       do ii=1,2
                          write(41,*)nr+mm,ii,all(:,mm,ii)
                          write(411,*)nr+mm,ii,all2(:,1,ii)
                       enddo

                       m_inbr=(2-(nrmat_fin(parent2(i,1),parent2(i,1))-1)-(nrmat_fin(mat(j,1),mat(j,1))-1))/4
                       mend=sqrt(m_inbr*polyg**2)
                       mendel=G05DDF(0.d0,mend)
                       gind_t(lll)=0.5*(gindp(parent2(i,1))+gindp(mat(j,1)))+mendel
                       valqtl=0d0
                       epis=0
                       do k=1,nqtl
                          if(pos_assoc(k,3)/=0) then
                             if(pos_assoc(k,1)<pos_assoc(k,4)) then
                                if(pos_assoc(k,6)==1) then
                                   epis=epis+sum(eff_qtl(k,all(pos_assoc(k,1),mm,:)))*&
                                        sum(eff_qtl(pos_assoc(k,3),all(pos_assoc(k,4),mm,:)))
                                else
                                   test=.false.
                                   if(eff_qtl(k,all(pos_assoc(k,1),mm,1))==maxval(eff_qtl(k,:))) test=.true.
                                   if(eff_qtl(k,all(pos_assoc(k,1),mm,2))==maxval(eff_qtl(k,:))) test=.true.
                                   if (test) epis=epis+ sum(eff_qtl(pos_assoc(k,3),all(pos_assoc(k,4),mm,:)))
                                endif
                             endif
                          else
                             valqtl=valqtl+sum(eff_qtl(k,all(posqtl(k),mm,:)))
                             if(all(pos_assoc(k,1),mm,1)/=all(pos_assoc(k,1),mm,2)) &
                                  epis=epis+eff_dom(k)
                          endif
                       enddo
                       env=G05DDF(0.d0,envir)
                       poid=1
                       env=env/poid
                       perf_t(lll)=gind_t(lll)+env+valqtl+epis
                       write(42,*)nr+mm,parent2(i,1),mat(j,1)
                       write(43,*)nr+mm,perf_t(lll),gind_t(lll)
                    enddo
                 enddo
              enddo

           else if(nbport==2)then

              allocate(parent2(nt_hf2,1),perf_t(ndmax_hf2))
              allocate(gind_t(ndmax_hf2),sires(nt_hf2),dams(nfmax_hf2))
              allocate(all(nmq+nqtl,nt_hf2*nfmax_hf2*ndmax_hf2,2))

              nfp=G05DYF(nfmin_hf2,nfmax_hf2)
              allocate(mat(nfp,1))
              do j=1,nfp  
160              mat(j,1)=G05DYF(1,ntotanc1)  
                 if(mod(mat(j,1),2)==0)then
                    dams(j)=mat(j,1)
                 else
                    go to 160
                 endif
                 if(any(mat(j,1)==dams(1:j-1)))then
                    go to 160
                    dams(j)=mat(j,1)
                 endif
              enddo

              mm=0
              do i=1,nt_hf2
170              parent2(i,1)=G05DYF(1,ntotanc1)  
                 if(mod(parent2(i,1),2)/=0)then
                    sires(i)=parent2(i,1)
                 else
                    go to 170
                 endif
                 if(any(parent2(i,1)==sires(1:i-1)))then
                    go to 170
                    sires(i)=parent2(i,1)
                 endif

                 iv=0
                 do ii=1,nmq+nqtl
                    if(indic(ii)==0) then
                       iv=iv+1
                       all2(iv,1,:)=all1(ii,parent2(i,1),:)
                    endif
                 enddo
                 do ii=1,2
                    write(41,*)parent2(i,1),ii,all1(:,parent2(i,1),ii)
                    write(411,*)parent2(i,1),ii,all2(:,1,ii)
                 enddo

                 write(42,*)parent2(i,1),'0   0'
                 write(43,*)parent2(i,1),perfp(parent2(i,1)),gindp(parent2(i,1))

                 do j=1,nfp  

                    iv=0
                    do ii=1,nmq+nqtl
                       if(indic(ii)==0) then
                          iv=iv+1
                          all2(iv,1,:)=all1(ii,mat(j,1),:)
                       endif
                    enddo
                    do ii=1,2
                       write(41,*)mat(j,1),ii,all1(:,mat(j,1),ii)
                       write(411,*)mat(j,1),ii,all2(:,1,ii)
                    enddo

                    write(42,*)mat(j,1),'0    0' !parent(mat(j,1),:)
                    write(43,*)mat(j,1),perfp(mat(j,1)),gindp(mat(j,1))
                    ndn=G05DYF(ndmin_hf2,ndmax_hf2)
                    do lll=1,ndn
                       mm=mm+1 
                       l=G05DYF(1,2)
                       all(:,mm,1)= all1(:,parent2(i,1),l)
                       do k=2,nmq+nqtl
                          r=G05CAF(r)
                          if(r<reco(k-1)) l=3-l
                          all(k,mm,1)=all1(k,parent2(i,1),l)
                       enddo
                       l=G05DYF(1,2)
                       all(:,mm,2)=all1(:,mat(j,1),l)
                       do k=2,nmq+nqtl
                          r=G05CAF(r)
                          if(r<reco(k-1)) l=3-l
                          all(k,mm,2)=all1(k,mat(j,1),l)
                       enddo
                       iv=0
                       do ii=1,nmq+nqtl
                          if(indic(ii)==0) then
                             iv=iv+1
                             all2(iv,1,:)=all(ii,mm,:)
                          endif
                       enddo
                       do ii=1,2
                          write(41,*)nr+mm,ii,all(:,mm,ii)
                          write(411,*)nr+mm,ii,all2(:,1,ii)
                       enddo

                       m_inbr=(2-(nrmat_fin(parent2(i,1),parent2(i,1))-1)-(nrmat_fin(mat(j,1),mat(j,1))-1))/4
                       mend=sqrt(m_inbr*polyg**2)
                       mendel=G05DDF(0.d0,mend)
                       gind_t(lll)=0.5*(gindp(parent2(i,1))+gindp(mat(j,1)))+mendel

                       valqtl=0d0
                       epis=0
                       do k=1,nqtl
                          if(pos_assoc(k,3)/=0) then
                             if(pos_assoc(k,1)<pos_assoc(k,4)) then
                                if(pos_assoc(k,6)==1) then
                                   epis=epis+sum(eff_qtl(k,all(pos_assoc(k,1),mm,:)))*&
                                        sum(eff_qtl(pos_assoc(k,3),all(pos_assoc(k,4),mm,:)))
                                else
                                   test=.false.
                                   if(eff_qtl(k,all(pos_assoc(k,1),mm,1))==maxval(eff_qtl(k,:))) test=.true.
                                   if(eff_qtl(k,all(pos_assoc(k,1),mm,2))==maxval(eff_qtl(k,:))) test=.true.
                                   if (test) epis=epis+ sum(eff_qtl(pos_assoc(k,3),all(pos_assoc(k,4),mm,:)))
                                endif
                             endif
                          else
                             valqtl=valqtl+sum(eff_qtl(k,all(posqtl(k),mm,:)))
                             if(all(pos_assoc(k,1),mm,1)/=all(pos_assoc(k,1),mm,2)) &
                                  epis=epis+eff_dom(k)
                          endif
                       enddo
                       env=G05DDF(0.d0,envir)
                       poid=1
                       env=env/poid
                       perf_t(lll)=gind_t(lll)+env+valqtl+epis
                       write(42,*)nr+mm,parent2(i,1),mat(j,1)
                       write(43,*)nr+mm,perf_t(lll),gind_t(lll)
                    enddo
                 enddo
              enddo
           endif  ! de nbport

        endif


     ELSE IF (pedig==2)THEN

        if(lect==1)then  

           ntotped1=ntotanc1
           ntotanc1=anc1
           allocate(all1(nmq+nqtl,nsires,2),all4(nmq+nqtl,ntotanc1,2))
           allocate(indp(ntotanc1,1),perfp(nsires),perfm(ntotanc1))
           allocate(gindm(ntotanc1),gindp(nsires),parent(nsires,2))

           do i=1,anc1
              all4(:,i,:)=all(:,i,:)
              perfm(i)=perf(i,1)
              gindm(i)=gind(i,1)
           enddo
           deallocate(all,perf,gind)
           if(allocated(allp2)) deallocate(allp2)

           open(125,file=file8)
           open(115,file=file9) 
           open(21,file=file10) 
           open(145,file=file11) 
           do i=1,nsires
              read(115,*)indp(i,1),parent(i,:) ! parent(i,1),parent(i,2)
              read(125,*)indp(i,1),all1(:,i,1),all1(:,i,2)
              read(145,*)indp(i,1),perfp(i)
              read(21,*)indp(i,1),gindp(i)
           enddo

           if(nbport==1)then
              allocate(parent2(nt_hs,1),mat(nfmax_hs,1),all(nmq+nqtl,nt_hs*nfmax_hs*ndmax_hs,2))
              allocate(sires(nt_hs),dams(nfmax_hs),perf_t(ndmax_hs),gind_t(ndmax_hs))
              do i=1,nt_hs
180              parent2(i,1)=G05DYF(1,nsires)  
                 sires(i)=indp(parent2(i,1),1)
                 if(any(indp(parent2(i,1),1)==sires(1:i-1)))then
                    go to 180
                    sires(i)=indp(parent2(i,1),1)
                 endif

                 iv=0
                 do ii=1,nmq+nqtl
                    if(indic(ii)==0) then
                       iv=iv+1
                       all2(iv,1,:)=all1(ii,parent2(i,1),:)
                    endif
                 enddo
                 do ii=1,2
                    write(41,*)indp(parent2(i,1),1),ii,all1(:,parent2(i,1),ii)
                    write(411,*)indp(parent2(i,1),1),ii,all2(:,1,ii)
                 enddo

                 write(42,*)indp(parent2(i,1),1),parent(parent2(i,1),:)
                 write(43,*)indp(parent2(i,1),1),perfp(parent2(i,1)),gindp(parent2(i,1))
              enddo

              mm=0
              do i=1,nt_hs
                 nf=G05DYF(nfmin_hs,nfmax_hs)
                 if (nf>=nfmin_hs.OR.nf<=nfmax_hs)then
                    nfp=nf
                 endif
                 do j=1,nfp 
190                 mat(j,1)=G05DYF(1,ntotanc1)
                    dams(j)=mat(j,1)
                    if(any(mat(j,1)==dams(1:j-1)))then
                       go to 190
                       dams(j)=mat(j,1)
                    endif

                    iv=0
                    do ii=1,nmq+nqtl
                       if(indic(ii)==0) then
                          iv=iv+1
                          all2(iv,1,:)=all4(ii,mat(j,1),:)
                       endif
                    enddo
                    do ii=1,2
                       write(41,*)mat(j,1),ii,all4(:,mat(j,1),ii)
                       write(411,*)mat(j,1),ii,all2(:,1,ii)
                    enddo

                    write(42,*)mat(j,1),'0     0' !parent(mat(j,1),:)
                    write(43,*)mat(j,1),perfm(mat(j,1)),gindm(mat(j,1))

                    ndn=G05DYF(ndmin_hs,ndmax_hs)
                    do lll=1,ndn
                       mm=mm+1 
                       l=G05DYF(1,2)
                       all(:,mm,1)= all1(:,parent2(i,1),l)
                       do k=2,nmq+nqtl
                          r=G05CAF(r)
                          if(r<reco(k-1)) l=3-l
                          all(k,mm,1)=all1(k,parent2(i,1),l)
                       enddo
                       l=G05DYF(1,2)
                       all(:,mm,2)=all4(:,mat(j,1),l)
                       do k=2,nmq+nqtl
                          r=G05CAF(r)
                          if(r<reco(k-1)) l=3-l
                          all(k,mm,2)=all4(k,mat(j,1),l)
                       enddo

                       iv=0
                       do ii=1,nmq+nqtl
                          if(indic(ii)==0) then
                             iv=iv+1
                             all2(iv,1,:)=all(ii,mm,:)
                          endif
                       enddo
                       do ii=1,2
                          write(41,*)ntotanc1+maxval(indp(:,1))+mm,ii,all(:,mm,ii)
                          write(411,*)ntotanc1+maxval(indp(:,1))+mm,ii,all2(:,1,ii)
                       enddo

                       mend=sqrt(0.5*polyg**2)
                       mendel=G05DDF(0.d0,mend)
                       gind_t(lll)=0.5*(gindp(parent2(i,1))+gindm(mat(j,1)))+mendel

                       valqtl=0d0
                       epis=0
                       do k=1,nqtl
                          if(pos_assoc(k,3)/=0) then
                             if(pos_assoc(k,1)<pos_assoc(k,4)) then
                                if(pos_assoc(k,6)==1) then
                                   epis=epis+sum(eff_qtl(k,all(pos_assoc(k,1),mm,:)))*&
                                        sum(eff_qtl(pos_assoc(k,3),all(pos_assoc(k,4),mm,:)))
                                else
                                   test=.false.
                                   if(eff_qtl(k,all(pos_assoc(k,1),mm,1))==maxval(eff_qtl(k,:))) test=.true.
                                   if(eff_qtl(k,all(pos_assoc(k,1),mm,2))==maxval(eff_qtl(k,:))) test=.true.
                                   if (test) epis=epis+ sum(eff_qtl(pos_assoc(k,3),all(pos_assoc(k,4),mm,:)))
                                endif
                             endif
                          else
                             valqtl=valqtl+sum(eff_qtl(k,all(posqtl(k),mm,:)))
                             if(all(pos_assoc(k,1),mm,1)/=all(pos_assoc(k,1),mm,2)) &
                                  epis=epis+eff_dom(k)
                          endif
                       enddo

                       env=G05DDF(0.d0,envir)
                       poid=1
                       env=env/poid
                       perf_t(lll)=gind_t(lll)+env+valqtl+epis
                       write(42,*)ntotanc1+maxval(indp(:,1))+mm,indp(parent2(i,1),1),mat(j,1)
                       write(43,*)ntotanc1+maxval(indp(:,1))+mm,perf_t(lll),gind_t(lll)
                    enddo
                 enddo
              enddo

           else if(nbport==2)then


              nfp=G05DYF(nfmin_hf2,nfmax_hf2)
              allocate(parent2(nt_hf2,1),mat(nfmax_hf2,1),all(nmq+nqtl,nt_hf2*nfmax_hf2*ndmax_hf2,2))
              allocate(sires(nt_hf2),dams(nfp),perf_t(ndmax_hf2),gind_t(ndmax_hf2))

              do j=1,nfp  
200              mat(j,1)=G05DYF(1,ntotanc1)  
                 dams(j)=mat(j,1)
                 if(any(mat(j,1)==dams(1:j-1)))then
                    go to 200
                    dams(j)=mat(j,1)
                 endif
              enddo

              do i=1,nt_hf2
210              parent2(i,1)=G05DYF(1,nsires)  
                 if(mod(indp(parent2(i,1),1),2)/=0)then
                    sires(i)=indp(parent2(i,1),1)
                 else
                    go to 210
                 endif
                 if(any(indp(parent2(i,1),1)==sires(1:i-1)))then
                    go to 210
                    sires(i)=indp(parent2(i,1),1)
                 endif

                 iv=0
                 do ii=1,nmq+nqtl
                    if(indic(ii)==0) then
                       iv=iv+1
                       all2(iv,1,:)=all1(ii,parent2(i,1),:)
                    endif
                 enddo
                 do ii=1,2
                    write(41,*)indp(parent2(i,1),1),ii,all1(:,parent2(i,1),ii)
                    write(411,*)indp(parent2(i,1),1),ii,all2(:,1,ii)
                 enddo

                 write(42,*)indp(parent2(i,1),1),parent(parent2(i,1),:)
                 write(43,*)indp(parent2(i,1),1),perfp(parent2(i,1)),gindp(parent2(i,1))
                 mm=0
                 do j=1,nfp  

                    iv=0
                    do ii=1,nmq+nqtl
                       if(indic(ii)==0) then
                          iv=iv+1
                          all2(iv,1,:)=all4(ii,mat(j,1),:)
                       endif
                    enddo
                    do ii=1,2
                       write(41,*)mat(j,1),ii,all4(:,mat(j,1),ii)
                       write(411,*)mat(j,1),ii,all2(:,1,ii)
                    enddo

                    write(42,*)mat(j,1),'0   0' !parent(mat(j,1),:)
                    write(43,*)mat(j,1),perfm(mat(j,1)),gindm(mat(j,1))
                    ndn=G05DYF(ndmin_hf2,ndmax_hf2)
                    do lll=1,ndn
                       mm=mm+1 
                       l=G05DYF(1,2)
                       all(:,mm,1)= all1(:,parent2(i,1),l)
                       do k=2,nmq+nqtl
                          r=G05CAF(r)
                          if(r<reco(k-1)) l=3-l
                          all(k,mm,1)=all1(k,parent2(i,1),l)
                       enddo
                       l=G05DYF(1,2)
                       all(:,mm,2)=all4(:,mat(j,1),l)
                       do k=2,nmq+nqtl
                          r=G05CAF(r)
                          if(r<reco(k-1)) l=3-l
                          all(k,mm,2)=all4(k,mat(j,1),l)
                       enddo

                       iv=0
                       do ii=1,nmq+nqtl
                          if(indic(ii)==0) then
                             iv=iv+1
                             all2(iv,1,:)=all(ii,mm,:)
                          endif
                       enddo
                       do ii=1,2
                          write(41,*)ntotanc1+maxval(indp(:,1))+mm,ii,all(:,mm,ii)
                          write(411,*)ntotanc1+maxval(indp(:,1))+mm,ii,all2(:,1,ii)
                       enddo

                       mend=sqrt(0.5*polyg**2)
                       mendel=G05DDF(0.d0,mend)
                       gind_t(lll)=0.5*(gindp(parent2(i,1))+gindm(mat(j,1)))+mendel

                       valqtl=0d0
                       epis=0
                       do k=1,nqtl
                          if(pos_assoc(k,3)/=0) then
                             if(pos_assoc(k,1)<pos_assoc(k,4)) then
                                if(pos_assoc(k,6)==1) then
                                   epis=epis+sum(eff_qtl(k,all(pos_assoc(k,1),mm,:)))*&
                                        sum(eff_qtl(pos_assoc(k,3),all(pos_assoc(k,4),mm,:)))
                                else
                                   test=.false.
                                   if(eff_qtl(k,all(pos_assoc(k,1),mm,1))==maxval(eff_qtl(k,:))) test=.true.
                                   if(eff_qtl(k,all(pos_assoc(k,1),mm,2))==maxval(eff_qtl(k,:))) test=.true.
                                   if (test) epis=epis+ sum(eff_qtl(pos_assoc(k,3),all(pos_assoc(k,4),mm,:)))
                                endif
                             endif
                          else
                             valqtl=valqtl+sum(eff_qtl(k,all(posqtl(k),mm,:)))
                             if(all(pos_assoc(k,1),mm,1)/=all(pos_assoc(k,1),mm,2)) &
                                  epis=epis+eff_dom(k)
                          endif
                       enddo
                       env=G05DDF(0.d0,envir)
                       poid=1
                       env=env/poid
                       perf_t(lll)=gind_t(lll)+env+valqtl+epis
                       write(42,*)ntotanc1+maxval(indp(:,1))+mm,indp(parent2(i,1),1),mat(j,1)
                       write(43,*)ntotanc1+maxval(indp(:,1))+mm,perf_t(lll),gind_t(lll)
                    enddo
                 enddo
              enddo
           endif  ! de nbport

        else if(lect==2)then

           ! males are from the simulation, females from a real pedigree
           nr=nsires+ntotped1

           allocate(all1(nmq+nqtl,nsires,2),all4(nmq+nqtl,ntotped1,2))
           allocate(indm(ntotped1,1),parent(ntotped1,2),perfp(nsires),perfm(ntotped1),gindp(nsires))
           allocate(gindm(ntotped1))

           open(125,file=file8)
           open(115,file=file9) 
           open(21,file=file10) 
           open(145,file=file11) 
           do i=1,ntotped1
              read(115,*)indm(i,1),parent(i,:) ! parent(i,1),parent(i,2)
              read(125,*)indm(i,1),all4(:,i,1),all4(:,i,2)
              read(145,*)indm(i,1),perfm(i)
              read(21,*)indm(i,1),gindm(i)
           enddo

           allocate(mat(nsires,1))
           if(nsires>anc1) print*,'WARNING: LESS THAN',nsires,' INDIVIDUALS WERE SIMULATED. THEY',&
                ' WILL BE REPLICATED BUT TREATED AS DIFFERENT INDIVIDUALS'
           if(nsires/=anc1) then
              call G05DYF2(1,anc1,nsires,mat(:,1))
              do i=1,nsires
                 j=mat(i,1)
                 do while(count(any(mat .eq. j,1))>1)
                    mat(i,1)=G05DYF(1,anc1)
                    j=mat(i,1)
                 enddo
              enddo
           else
              do i=1,nsires
                 mat(i,1)=i
              enddo
           endif
           do i=1,nsires
              if(mat(i,1)<=anc1) then
                 all1(:,i,:)=all(:,mat(i,1),:)
                 perfp(i)=perf(mat(i,1),1)
                 gindp(i)=gind(mat(i,1),1)
              else
                 all1(:,i,:)=allp2(:,mat(i,1)-anc1,:)
                 perfp(i)=perf(mat(i,1)-anc1,2)
                 gindp(i)=gind(mat(i,1)-anc1,2)
              endif
           enddo
           deallocate(all)
           deallocate(gind)
           deallocate(perf)
           deallocate(mat)
           if(allocated(allp2)) deallocate(allp2)


           if(nbport==1)then

              allocate(parent2(nt_hs,1),mat(nfmax_hs,1))
              allocate(perf_t(ndmax_hs),gind_t(ndmax_hs),sires(nt_hs),dams(nfmax_hs))
              allocate(all(nmq+nqtl,nt_hs*ndmax_hs*nfmax_hs,2))

              do i=1,nt_hs
220              parent2(i,1)=G05DYF(1,nsires)  
                 sires(i)=parent2(i,1)
                 if(any(parent2(i,1)==sires(1:i-1)))then
                    go to 220
                    sires(i)=parent2(i,1)
                 endif

                 iv=0
                 do ii=1,nmq+nqtl
                    if(indic(ii)==0) then
                       iv=iv+1
                       all2(iv,1,:)=all1(ii,parent2(i,1),:)
                    endif
                 enddo
                 do ii=1,2
                    write(41,*)i,ii,all1(:,parent2(i,1),ii)
                    write(411,*)i,ii,all2(:,1,ii)
                 enddo

                 write(42,*)i,'0   0'
                 write(43,*)i,perfp(parent2(i,1)),gindp(parent2(i,1))
              enddo

              mm=0
              do i=1,nt_hs
                 nfp=G05DYF(nfmin_hs,nfmax_hs)
                 do j=1,nfp 
230                 mat(j,1)=G05DYF(1,ntotped1)  
                    if(mod(indm(mat(j,1),1),2)==0)then
                       dams(j)=indm(mat(j,1),1)
                    else
                       go to 230
                    endif
                    if(any(indm(mat(j,1),1)==dams(1:j-1)))then
                       go to 230
                       dams(j)=indm(mat(j,1),1)
                    endif

                    iv=0
                    do ii=1,nmq+nqtl
                       if(indic(ii)==0) then
                          iv=iv+1
                          all2(iv,1,:)=all4(ii,mat(j,1),:)
                       endif
                    enddo
                    do ii=1,2
                       write(41,*)indm(mat(j,1),1),ii,all4(:,mat(j,1),ii)
                       write(411,*)indm(mat(j,1),1),ii,all2(:,1,ii)
                    enddo

                    write(42,*)indm(mat(j,1),1),parent(mat(j,1),:)
                    write(43,*)indm(mat(j,1),1),perfm(mat(j,1)),gindm(mat(j,1))

                    ndn=G05DYF(ndmin_hs,ndmax_hs)
                    do lll=1,ndn
                       mm=mm+1 
                       l=G05DYF(1,2)
                       all(:,mm,1)= all1(:,parent2(i,1),l)
                       do k=2,nmq+nqtl
                          r=G05CAF(r)
                          if(r<reco(k-1)) l=3-l
                          all(k,mm,1)=all1(k,parent2(i,1),l)
                       enddo
                       l=G05DYF(1,2)
                       all(:,mm,2)=all4(:,mat(j,1),l)
                       do k=2,nmq+nqtl
                          r=G05CAF(r)
                          if(r<reco(k-1)) l=3-l
                          all(k,mm,2)=all4(k,mat(j,1),l)
                       enddo

                       iv=0
                       do ii=1,nmq+nqtl
                          if(indic(ii)==0) then
                             iv=iv+1
                             all2(iv,1,:)=all(ii,mm,:)
                          endif
                       enddo
                       do ii=1,2
                          write(41,*)nsires+maxval(indm(:,1))+mm,ii,all(:,mm,ii)
                          write(411,*)nsires+maxval(indm(:,1))+mm,ii,all2(:,1,ii)
                       enddo

                       mend=sqrt(0.5*polyg**2)
                       mendel=G05DDF(0.d0,mend)
                       gind_t(lll)=0.5*(gindp(parent2(i,1))+gindm(mat(j,1)))+mendel

                       valqtl=0d0
                       epis=0
                       do k=1,nqtl
                          if(pos_assoc(k,3)/=0) then
                             if(pos_assoc(k,1)<pos_assoc(k,4)) then
                                if(pos_assoc(k,6)==1) then
                                   epis=epis+sum(eff_qtl(k,all(pos_assoc(k,1),mm,:)))*&
                                        sum(eff_qtl(pos_assoc(k,3),all(pos_assoc(k,4),mm,:)))
                                else
                                   test=.false.
                                   if(eff_qtl(k,all(pos_assoc(k,1),mm,1))==maxval(eff_qtl(k,:))) test=.true.
                                   if(eff_qtl(k,all(pos_assoc(k,1),mm,2))==maxval(eff_qtl(k,:))) test=.true.
                                   if (test) epis=epis+ sum(eff_qtl(pos_assoc(k,3),all(pos_assoc(k,4),mm,:)))
                                endif
                             endif
                          else
!!$             print*,tab(posqt(j),i,:)
                             valqtl=valqtl+sum(eff_qtl(k,all(posqtl(k),mm,:)))
                             if(all(pos_assoc(k,1),mm,1)/=all(pos_assoc(k,1),mm,2)) &
                                  epis=epis+eff_dom(k)
                          endif
                       enddo
                       env=G05DDF(0.d0,envir)
                       poid=1
                       env=env/poid
                       perf_t(lll)=gind_t(lll)+env+valqtl+epis
                       write(42,*)nsires+maxval(indm(:,1))+mm,parent2(i,1),indm(mat(j,1),1)
                       write(43,*)nsires+maxval(indm(:,1))+mm,perf_t(lll),gind_t(lll)
                    enddo
                 enddo
              enddo

           else if(nbport==2)then

              allocate(parent2(nt_hf2,1),mat(nfmax_hf2,1))
              allocate(perf_t(ndmax_hf2),gind_t(ndmax_hf2),sires(nt_hf2),dams(nfmax_hf2))
              allocate(all(nmq+nqtl,nt_hf2*ndmax_hf2*nfmax_hf2,2))

              nfp=G05DYF(nfmin_hf2,nfmax_hf2)
              do j=1,nfp  
250              mat(j,1)=G05DYF(1,ntotped1)  
                 if(mod(indm(mat(j,1),1),2)==0)then
                    dams(j)=indm(mat(j,1),1)
                 else
                    go to 250
                 endif
                 if(any(indm(mat(j,1),1)==dams(1:j-1)))then
                    go to 250
                    dams(j)=indm(mat(j,1),1)
                 endif
              enddo

              do i=1,nt_hf2
260              parent2(i,1)=G05DYF(1,nsires)  
                 if(mod(parent2(i,1),2)/=0)then
                    sires(i)=parent2(i,1)
                 else
                    go to 260
                 endif
                 if(any(parent2(i,1)==sires(1:i-1)))then
                    go to 260
                    sires(i)=parent2(i,1)
                 endif

                 iv=0
                 do ii=1,nmq+nqtl
                    if(indic(ii)==0) then
                       iv=iv+1
                       all2(iv,1,:)=all1(ii,parent2(i,1),:)
                    endif
                 enddo
                 do ii=1,2
                    write(41,*)i,ii,all1(:,parent2(i,1),ii)
                    write(411,*)i,ii,all2(:,1,ii)
                 enddo

                 write(42,*)i,'0     0'
                 write(43,*)i,perfp(parent2(i,1)),gindp(parent2(i,1))

                 mm=0
                 do j=1,nfp  
                    iv=0
                    do ii=1,nmq+nqtl
                       if(indic(ii)==0) then
                          iv=iv+1
                          all2(iv,1,:)=all4(ii,mat(j,1),:)
                       endif
                    enddo
                    do ii=1,2
                       write(41,*)indm(mat(j,1),1),ii,all4(:,mat(j,1),ii)
                       write(411,*)indm(mat(j,1),1),ii,all2(:,1,ii)
                    enddo

                    write(42,*)indm(mat(j,1),1),parent(mat(j,1),:)
                    write(43,*)indm(mat(j,1),1),perfm(mat(j,1)),gindm(mat(j,1))

                    ndn=G05DYF(ndmin_hf2,ndmax_hf2)
                    do lll=1,ndn
                       mm=mm+1 
                       l=G05DYF(1,2)
                       all(:,mm,1)= all1(:,parent2(i,1),l)
                       do k=2,nmq+nqtl
                          r=G05CAF(r)
                          if(r<reco(k-1)) l=3-l
                          all(k,mm,1)=all1(k,parent2(i,1),l)
                       enddo
                       l=G05DYF(1,2)
                       all(:,mm,2)=all4(:,mat(j,1),l)
                       do k=2,nmq+nqtl
                          r=G05CAF(r)
                          if(r<reco(k-1)) l=3-l
                          all(k,mm,2)=all4(k,mat(j,1),l)
                       enddo
                       iv=0
                       do ii=1,nmq+nqtl
                          if(indic(ii)==0) then
                             iv=iv+1
                             all2(iv,1,:)=all(ii,mm,:)
                          endif
                       enddo
                       do ii=1,2
                          write(41,*)nsires+maxval(indm(:,1))+mm,ii,all(:,mm,ii)
                          write(411,*)nsires+maxval(indm(:,1))+mm,ii,all2(:,1,ii)
                       enddo

                       mend=sqrt(0.5*polyg**2)
                       mendel=G05DDF(0.d0,mend)
                       gind_t(lll)=0.5*(gindp(parent2(i,1))+gindm(mat(j,1)))+mendel

                       valqtl=0d0
                       epis=0
                       do k=1,nqtl
                          if(pos_assoc(k,3)/=0) then
                             if(pos_assoc(k,1)<pos_assoc(k,4)) then
                                if(pos_assoc(k,6)==1) then
                                   epis=epis+sum(eff_qtl(k,all(pos_assoc(k,1),mm,:)))*&
                                        sum(eff_qtl(pos_assoc(k,3),all(pos_assoc(k,4),mm,:)))
                                else
                                   test=.false.
                                   if(eff_qtl(k,all(pos_assoc(k,1),mm,1))==maxval(eff_qtl(k,:))) test=.true.
                                   if(eff_qtl(k,all(pos_assoc(k,1),mm,2))==maxval(eff_qtl(k,:))) test=.true.
                                   if (test) epis=epis+ sum(eff_qtl(pos_assoc(k,3),all(pos_assoc(k,4),mm,:)))
                                endif
                             endif
                          else
!!$             print*,tab(posqt(j),i,:)
                             valqtl=valqtl+sum(eff_qtl(k,all(posqtl(k),mm,:)))
                             if(all(pos_assoc(k,1),mm,1)/=all(pos_assoc(k,1),mm,2)) &
                                  epis=epis+eff_dom(k)
                          endif
                       enddo
                       env=G05DDF(0.d0,envir)
                       poid=1
                       env=env/poid
!!$                       gind(lll)=gani(lll)
                       perf_t(lll)=gind_t(lll)+env+valqtl+epis
                       write(42,*)nsires+maxval(indm(:,1))+mm,parent2(i,1),indm(mat(j,1),1)
                       write(43,*)nsires+maxval(indm(:,1))+mm,perf_t(lll),gind_t(lll)
                    enddo
                 enddo
              enddo
           endif  ! de nbport
        endif  ! lect

     ENDIF   ! de pedig==2

  endif

  print*,'END OF THE PROGRAM'

  stop

contains


  subroutine create_pheno(gin,pop,nq,ef_qt,ef_do,envi,poly,nn,pos_as,perform,al,nm,fqa,fqa2,nba,her,rat_pQ,indi)
    implicit none
    integer :: i, nn, pop, nq, nm
    integer, dimension(:) :: indi
    integer, dimension(:,:) :: pos_as, nba
    integer, dimension(:,:,:) :: al
    real(r8) :: envi, poly, env
    real(r8) :: valqtl, epis
    real(r8), dimension(:) :: ef_do, her, rat_pQ
    real(r8), dimension(:,:) :: gin, ef_qt, perform, fqa, fqa2
    real(r8), dimension(:,:), allocatable  :: var

    perform(:,pop)=0
    gind(:,pop)=0

    allocate(var(nq+1,4))
    var=0
    i=0
    do l=1,nq+nm
       if(indi(l)==1) then
          i=i+1
          if (pos_as(i,7)==0) then 
             ! purely additive effect
             if(maxval(nba(l,:))==2) then
                var(i,1)= 2*fqa(l,1)*(1-fqa(l,1))*((2*ef_qt(i,1))**2)
             else
                valqtl=0
                epis=0
                do j=1,maxval(nba(l,:))
                   if(fqa(l,j)/=0) then
                      valqtl=valqtl+fqa(l,j)*(2*ef_qt(i,j))**2
                      epis=epis+(fqa(l,j)*(2*ef_qt(i,j)))**2
                   endif
                enddo
                var(i,1)=valqtl-epis
             endif
          else
             ! If dominance effects are present at the locus
             print*,'BE CARREFUL: DOMINANCE EFFECTS AND VARIANCES ARE ONLY ACCOUNTED FOR IF THE QTL HAS ONLY 2 ALLELES'
             var(i,1)= 2*fqa(i,1)*(1-fqa(i,1))*(((2*ef_qt(i,1))+ef_do(i)*(1-2*fqa(i,1)))**2)      
          endif
          var(i,3)=(2*fqa(i,1)*(1-fqa(i,1))*ef_do(i))**2 ! Dominance variance
          if(pos_as(i,3)/=0) then
             print*,'BE CARREFUL: EPISTATIC EFFECTS AND VARIANCES ARE ONLY ACCOUNTED FOR IF THE QTL HAS ONLY 2 ALLELES'
             if(pos_as(i,6)==1) then
                var(i,2)=((4*ef_qt(i,1)*ef_qt(pos_as(i,3),1))**2)*&
                     (fqa2(i,1)+fqa2(i,2)-(fqa2(i,1)-fqa2(i,2))**2)
             else
                var(i,2)=((2*ef_qt(pos_as(i,3),1))**2)*(((fqa2(i,1)+fqa2(i,2)))-&
                     (fqa2(i,1)-fqa2(i,2))**2)
             endif
          endif
       endif
    enddo
    do i=1,nq
       if(pos_as(i,3)/=0.and.min(pos_as(i,1),pos_as(i,4))==pos_as(i,1)) then
          var(nq+1,2)=var(nq+1,2)+var(i,2) !interaction
       else
          if(pos_as(i,3)==0) then
             var(nq+1,1)=var(nq+1,1)+var(i,1) ! Only purely additive QTL
             var(nq+1,3)=var(nq+1,3)+var(i,3) ! Dominance variance
          endif
       endif
    enddo
    envir=sqrt((var(nq+1,1)*(1+rat_pQ(pop))-her(pop)*(var(nq+1,3)+var(nq+1,2)+var(nq+1,1)*(1+rat_pQ(pop))))/her(pop))
    poly=sqrt(var(nq+1,1)*rat_pQ(pop))
!!$    print*,envir,poly

    deallocate(var)

!!$print*,'INTERN',nn,pop
    do i=1,nn
       env=G05DDF(0.d0,envi)
       gin(i,pop)=G05DDF(0.d0,poly)
       valqtl=0
       epis=0
       do j=1,nq
          if(pos_as(j,3)/=0) then
             if(pos_as(j,1)<pos_as(j,4)) then
                if(pos_as(j,6)==1) then
                   epis=epis+sum(ef_qt(j,al(pos_as(j,1),i,:)))*&
                        sum(ef_qt(pos_as(j,3),al(pos_as(j,4),i,:)))
                else
                   test=.false.
                   if(ef_qt(j,al(pos_as(j,1),i,1))==maxval(ef_qt(j,:))) test=.true.
                   if(ef_qt(j,al(pos_as(j,1),i,2))==maxval(ef_qt(j,:))) test=.true.
                   if (test) epis=epis+ sum(ef_qt(pos_as(j,3),al(pos_as(j,4),i,:)))
                endif
             endif
          else
             valqtl=valqtl+sum(ef_qt(j,al(pos_as(j,1),i,:)))
             if(al(pos_as(j,1),i,1)/=al(pos_as(j,1),i,2)) epis=epis+ef_do(j)
          endif
       enddo
       perform(i,pop)=gin(i,pop)+env+valqtl+epis
!!$       print*,i,env,gin(i,pop),al(posq(:),i,:),valqtl,epis
!!$       open(500,file='variances-initial')  ! input file
!!$       write(500,*) i, gin(i,pop),valqtl,env,epis
    enddo

  end subroutine create_pheno

  subroutine create_pheno_adm(gin,pop,nq,ef_qt,ef_do,envi,poly,nn,pos_as,perform,al)
    implicit none
    integer :: i, nn, pop, nq
    integer, dimension(:,:) :: pos_as
    integer, dimension(:,:,:) :: al
    real(r8) :: envi, poly, env
    real(r8) :: valqtl, epis
    real(r8), dimension(:) :: ef_do
    real(r8), dimension(:,:) :: gin, ef_qt, perform

    perform(:,pop)=0
    gind(:,pop)=0

!!$print*,'INTERN',nn,pop
    do i=1,nn
       env=G05DDF(0.d0,envi)
       gin(i,pop)=G05DDF(0.d0,poly)
       valqtl=0
       epis=0
       do j=1,nq
          if(pos_as(j,3)/=0) then
             if(pos_as(j,1)<pos_as(j,4)) then
                if(pos_as(j,6)==1) then
                   epis=epis+sum(ef_qt(j,al(pos_as(j,1),i,:)))*&
                        sum(ef_qt(pos_as(j,3),al(pos_as(j,4),i,:)))
                else
                   test=.false.
                   if(ef_qt(j,al(pos_as(j,1),i,1))==maxval(ef_qt(j,:))) test=.true.
                   if(ef_qt(j,al(pos_as(j,1),i,2))==maxval(ef_qt(j,:))) test=.true.
                   if (test) epis=epis+ sum(ef_qt(pos_as(j,3),al(pos_as(j,4),i,:)))
                endif
             endif
          else
             valqtl=valqtl+sum(ef_qt(j,al(pos_as(j,1),i,:)))
             if(al(pos_as(j,1),i,1)/=al(pos_as(j,1),i,2)) epis=epis+ef_do(j)
          endif
       enddo
       perform(i,pop)=gin(i,pop)+env+valqtl+epis
!!$       print*,i,env,gin(i,pop),al(posq(:),i,:),valqtl,epis
!!$       open(500,file='variances-initial')  ! input file
!!$       write(500,*) i, gin(i,pop),valqtl,env,epis
    enddo

  end subroutine create_pheno_adm



  subroutine mating(d,e,c,f,g,pare) ! Random mating
    ! d-e+1 offspring from c individuals
    implicit none
    integer :: d,c,e,f,g,ii
    integer, dimension(:,:) :: pare
    do ii=e,d
       pare(ii,1)=G05DYF(1,c)
       pare(ii,2)=G05DYF(1,f)+g
    enddo
  end subroutine mating

  subroutine mating_adm(c,d,e,f,g,pare) !introg(infus),n(gene-1,1),(n_gene,2),n(gene,1)
    ! Matings of individuals in a crossbred scheme
    integer::c,d,e,demi3,f,demi4,g,ii
    integer, dimension(:,:) :: pare
    demi3=nint(real(c)/2.)
    demi4=nint(real(f)/2.)
!!$print*,c,d,e,f,g,demi3,demi4
    do ii=1,demi3
       pare(ii,1)=G05DYF(1,d)
       pare(ii,2)=G05DYF(1,e)+g
    enddo
    do ii=1,c-demi3
       pare(demi4+ii,1)=G05DYF(1,d)
       pare(demi4+ii,2)=G05DYF(1,e)+g
    enddo
  end subroutine mating_adm


  subroutine transm(c,nc,tab,tab2,tab3,tab4,tab5,tab6,tab7)
    implicit none
    integer :: nc, c
    integer :: i, j, k, l, ii, iv, v, vi, m
    integer :: nb_recomb
    integer, dimension(:) :: tab ! nloc
    integer, dimension(:,:) :: tab4 ! parent
    integer, dimension(:,:,:) :: tab2, tab3, tab6, tab7 ! all2, all, cop, cop2
    integer, allocatable, dimension(:) :: rk
    real(r8), dimension(:,:) :: tab5 ! pos_loc
    real(r8), allocatable, dimension(:) :: pos_recomb, pos_recomb2
    logical :: essai

    do j=1,nc
       iv=sum(tab(1:(j-1)))
       do i=1,c
          do k=1,2
             essai = .true.
             nb_recomb=random_poisson(tab5(tab(j),j),essai)
             ii=G05DYF(1,2)
             if(nb_recomb==0) then
                tab2(iv+1:iv+tab(j),i,k)=tab3(iv+1:iv+tab(j),tab4(i,k),ii)
                tab6(iv+1:iv+tab(j),i,k)=tab7(iv+1:iv+tab(j),tab4(i,k),ii)
             else
                allocate(pos_recomb(nb_recomb))
                do l=1,nb_recomb
                   r=G05CAF(r)*tab5(tab(j),j)
                   pos_recomb(l)=r
                enddo
                allocate(pos_recomb2(nb_recomb))
                if(nb_recomb>1) then
                   allocate(rk(nb_recomb))
                   rk=0
                   call search_best(-pos_recomb,nb_recomb,rk,nb_recomb)
                   pos_recomb2(:)=pos_recomb(rk(:))
                   deallocate(rk)
                else
                   pos_recomb2=pos_recomb
                endif
                deallocate(pos_recomb)
                v=0
                vi=1
                do while(v<nb_recomb)
                   test=.true.
                   do while(test)
                      tab2(iv+vi,i,k)=tab3(iv+vi,tab4(i,k),ii)
                      tab6(iv+vi,i,k)=tab7(iv+vi,tab4(i,k),ii)
                      if(vi+1>tab(j)) test=.false.
                      if(tab5(vi,j)>=pos_recomb2(v+1)) then      
                         test=.false.
                         m=1
                         do l=v+2,nb_recomb
                            if(tab5(vi,j)>=pos_recomb2(l)) m=m+1
                         enddo
                      endif
                      vi=vi+1
                   enddo
                   if(mod(m,2)/=0) then
                      ii=3-ii
                   endif
                   v=v+m
                enddo
                if(vi<=tab(j)) then
                   tab2(iv+vi:iv+tab(j),i,k)=tab3(iv+vi:iv+tab(j),tab4(i,k),ii)
                   tab6(iv+vi:iv+tab(j),i,k)=tab7(iv+vi:iv+tab(j),tab4(i,k),ii)
                endif
                deallocate(pos_recomb2)
             endif
          enddo
       enddo
    enddo
    do i=1,c
       tab3(:,i,:)=tab2(:,i,:)
       tab7(:,i,:)=tab6(:,i,:)
    enddo
    tab2=0
    tab6=0
  end subroutine transm


  subroutine transm_noCop(c,nc,tab,tab2,tab3,tab4,tab5)
    implicit none
    integer :: nc, c
    integer :: i, j, k, l, ii, iv, v, vi, m
    integer :: nb_recomb
    integer, dimension(:) :: tab ! nloc
    integer, dimension(:,:) :: tab4 ! parent
    integer, dimension(:,:,:) :: tab2, tab3 ! all2, all, cop, cop2
    integer, allocatable, dimension(:) :: rk
    real(r8), dimension(:,:) :: tab5 ! pos_loc
    real(r8), allocatable, dimension(:) :: pos_recomb, pos_recomb2
    logical :: essai

    do j=1,nc
       iv=sum(tab(1:(j-1)))
       do i=1,c
          do k=1,2
             essai = .true.
             nb_recomb=random_poisson(tab5(tab(j),j),essai)
             ii=G05DYF(1,2)
             if(nb_recomb==0) then
                tab2(iv+1:iv+tab(j),i,k)=tab3(iv+1:iv+tab(j),tab4(i,k),ii)
             else
                allocate(pos_recomb(nb_recomb))
                do l=1,nb_recomb
                   r=G05CAF(r)*tab5(tab(j),j)
                   pos_recomb(l)=r
                enddo
                allocate(pos_recomb2(nb_recomb))
                if(nb_recomb>1) then
                   allocate(rk(nb_recomb))
                   rk=0
                   call search_best(-pos_recomb,nb_recomb,rk,nb_recomb)
                   pos_recomb2(:)=pos_recomb(rk(:))
                   deallocate(rk)
                else
                   pos_recomb2=pos_recomb
                endif
                deallocate(pos_recomb)
                v=0
                vi=1
                do while(v<nb_recomb)
                   test=.true.
                   do while(test)
                      tab2(iv+vi,i,k)=tab3(iv+vi,tab4(i,k),ii)
                      if(vi+1>tab(j)) test=.false.
                      if(tab5(vi,j)>=pos_recomb2(v+1)) then      
                         test=.false.
                         m=1
                         do l=v+2,nb_recomb
                            if(tab5(vi,j)>=pos_recomb2(l)) m=m+1
                         enddo
                      endif
                      vi=vi+1
                   enddo
                   if(mod(m,2)/=0) then
                      ii=3-ii
                   endif
                   v=v+m
                enddo
                if(vi<=tab(j)) then
                   tab2(iv+vi:iv+tab(j),i,k)=tab3(iv+vi:iv+tab(j),tab4(i,k),ii)
                endif
                deallocate(pos_recomb2)
             endif
          enddo
       enddo
    enddo
    tab3(:,1:c,:)=tab2(:,1:c,:)
    tab2=0
  end subroutine transm_noCop



  subroutine transm_adm(c,d,e,nc,tab,tab2,tab3,tab4,tab5,tab6,tab7,tab8,tab9)
    implicit none
    integer :: nc, c, d, e
    integer :: i, j, k, l, ii, iv, v, vi, m
    integer :: nb_recomb
    integer, dimension(:) :: tab ! nloc
    integer, dimension(:,:) :: tab4 ! parent
    integer, dimension(:,:,:) :: tab2, tab3, tab6, tab7, tab8, tab9 ! all2, all, allp2, cop, cop2, copp2
    integer, allocatable, dimension(:) :: rk
    real(r8), dimension(:,:) :: tab5 ! pos_loc
    real(r8), allocatable, dimension(:) :: pos_recomb, pos_recomb2
    logical :: essai

    demi2=nint(real(d)/2.)
!!$    print*,c,d,e,demi2

    do j=1,nc
       iv=sum(tab(1:(j-1)))
       do i=1,demi2
          essai = .true.
          nb_recomb=random_poisson(tab5(tab(j),j),essai)
          ii=G05DYF(1,2)
          if(nb_recomb==0) then
             tab2(iv+1:iv+tab(j),i,1)=tab6(iv+1:iv+tab(j),tab4(i,1),ii)
             tab7(iv+1:iv+tab(j),i,1)=tab9(iv+1:iv+tab(j),tab4(i,1),ii)
          else
             allocate(pos_recomb(nb_recomb))
             do l=1,nb_recomb
                r=G05CAF(r)*tab5(tab(j),j)
                pos_recomb(l)=r
             enddo
             allocate(pos_recomb2(nb_recomb))
             if(nb_recomb>1) then
                allocate(rk(nb_recomb))
                rk=0
                call search_best(-pos_recomb,nb_recomb,rk,nb_recomb)
                pos_recomb2(:)=pos_recomb(rk(:))
                deallocate(rk)
             else
                pos_recomb2=pos_recomb
             endif
             deallocate(pos_recomb)
             v=0
             vi=1
             do while(v<nb_recomb)
                test=.true.
                do while(test)
                   tab2(iv+vi,i,1)=tab6(iv+vi,tab4(i,1),ii)
                   tab7(iv+vi,i,1)=tab9(iv+vi,tab4(i,1),ii)
                   if(vi+1>tab(j)) test=.false.
                   if(tab5(vi,j)>=pos_recomb2(v+1)) then      
                      test=.false.
                      m=1
                      do l=v+2,nb_recomb
                         if(tab5(vi,j)>=pos_recomb2(l)) m=m+1
                      enddo
                   endif
                   vi=vi+1
                enddo
                if(mod(m,2)/=0) then
                   ii=3-ii
                endif
                v=v+m
             enddo
             if(vi<=tab(j)) then
                tab2(iv+vi:iv+tab(j),i,1)=tab6(iv+vi:iv+tab(j),tab4(i,1),ii)
                tab7(iv+vi:iv+tab(j),i,1)=tab9(iv+vi:iv+tab(j),tab4(i,1),ii)
             endif
             deallocate(pos_recomb2)
          endif
          essai = .true.
          nb_recomb=random_poisson(tab5(tab(j),j),essai)
          ii=G05DYF(1,2)
          if(nb_recomb==0) then
             tab2(iv+1:iv+tab(j),i,2)=tab3(iv+1:iv+tab(j),tab4(i,2),ii)
             tab7(iv+1:iv+tab(j),i,2)=tab8(iv+1:iv+tab(j),tab4(i,2),ii)
          else
             allocate(pos_recomb(nb_recomb))
             do l=1,nb_recomb
                r=G05CAF(r)*tab5(tab(j),j)
                pos_recomb(l)=r
             enddo
             allocate(pos_recomb2(nb_recomb))
             if(nb_recomb>1) then
                allocate(rk(nb_recomb))
                rk=0
                call search_best(-pos_recomb,nb_recomb,rk,nb_recomb)
                pos_recomb2(:)=pos_recomb(rk(:))
                deallocate(rk)
             else
                pos_recomb2=pos_recomb
             endif
             deallocate(pos_recomb)
             v=0
             vi=1
             do while(v<nb_recomb)
                test=.true.
                do while(test)
                   tab2(iv+vi,i,2)=tab3(iv+vi,tab4(i,2),ii)
                   tab7(iv+vi,i,2)=tab8(iv+vi,tab4(i,2),ii)
                   if(vi+1>tab(j)) test=.false.
                   if(tab5(vi,j)>=pos_recomb2(v+1)) then      
                      test=.false.
                      m=1
                      do l=v+2,nb_recomb
                         if(tab5(vi,j)>=pos_recomb2(l)) m=m+1
                      enddo
                   endif
                   vi=vi+1
                enddo
                if(mod(m,2)/=0) then
                   ii=3-ii
                endif
                v=v+m
             enddo
             if(vi<=tab(j)) then
                tab2(iv+vi:iv+tab(j),i,2)=tab3(iv+vi:iv+tab(j),tab4(i,2),ii)
                tab7(iv+vi:iv+tab(j),i,2)=tab8(iv+vi:iv+tab(j),tab4(i,2),ii)
             endif
             deallocate(pos_recomb2)
          endif
       enddo
       do i=demi2+1,e
          do k=1,2
             essai = .true.
             nb_recomb=random_poisson(tab5(tab(j),j),essai)
!!$             if(i==201) print*,'nb_recomb',nb_recomb
             ii=G05DYF(1,2)
             if(nb_recomb==0) then
!!$                print*,j,i,k,ii,iv,tab(j),tab4(i,k)
                tab2(iv+1:iv+tab(j),i,k)=tab3(iv+1:iv+tab(j),tab4(i,k),ii) ! k <--> parental origin, ii <--> gd-parental origin
                tab7(iv+1:iv+tab(j),i,k)=tab8(iv+1:iv+tab(j),tab4(i,k),ii)
             else
                allocate(pos_recomb(nb_recomb))
                do l=1,nb_recomb
                   r=G05CAF(r)*tab5(tab(j),j)
                   pos_recomb(l)=r
                enddo
                allocate(pos_recomb2(nb_recomb))
                if(nb_recomb>1) then
                   allocate(rk(nb_recomb))
                   rk=0
                   call search_best(-pos_recomb,nb_recomb,rk,nb_recomb)
                   pos_recomb2(:)=pos_recomb(rk(:))
                   deallocate(rk)
                else
                   pos_recomb2=pos_recomb
                endif
!!$                if(i==201) print*,'pos recomb',pos_recomb2
                deallocate(pos_recomb)
                v=0
                vi=1
                do while(v<nb_recomb)
                   test=.true.
                   do while(test)
                      tab2(iv+vi,i,k)=tab3(iv+vi,tab4(i,k),ii)
                      tab7(iv+vi,i,k)=tab8(iv+vi,tab4(i,k),ii)
                      if(vi+1>tab(j)) test=.false.
                      if(tab5(vi,j)>=pos_recomb2(v+1)) then      
                         test=.false.
                         m=1
                         do l=v+2,nb_recomb
                            if(tab5(vi,j)>=pos_recomb2(l)) m=m+1
                         enddo
                      endif
                      vi=vi+1
                   enddo
                   if(mod(m,2)/=0) then
                      ii=3-ii
                   endif
                   v=v+m
                enddo
                if(vi<=tab(j)) then
                   tab2(iv+vi:iv+tab(j),i,k)=tab3(iv+vi:iv+tab(j),tab4(i,k),ii)
                   tab7(iv+vi:iv+tab(j),i,k)=tab8(iv+vi:iv+tab(j),tab4(i,k),ii)
                endif
                deallocate(pos_recomb2)
             endif
          enddo
       enddo
       do i=e+1,e-demi2+d
          essai = .true.
          nb_recomb=random_poisson(tab5(tab(j),j),essai)
          ii=G05DYF(1,2)
          if(nb_recomb==0) then
             tab2(iv+1:iv+tab(j),i,1)=tab6(iv+1:iv+tab(j),tab4(i,1),ii)
             tab7(iv+1:iv+tab(j),i,1)=tab9(iv+1:iv+tab(j),tab4(i,1),ii)
          else
             allocate(pos_recomb(nb_recomb))
             do l=1,nb_recomb
                r=G05CAF(r)*tab5(tab(j),j)
                pos_recomb(l)=r
             enddo
             allocate(pos_recomb2(nb_recomb))
             if(nb_recomb>1) then
                allocate(rk(nb_recomb))
                rk=0
                call search_best(-pos_recomb,nb_recomb,rk,nb_recomb)
                pos_recomb2(:)=pos_recomb(rk(:))
                deallocate(rk)
             else
                pos_recomb2=pos_recomb
             endif
             deallocate(pos_recomb)
             v=0
             vi=1
             do while(v<nb_recomb)
                test=.true.
                do while(test)
                   tab2(iv+vi,i,1)=tab6(iv+vi,tab4(i,1),ii)
!!$                   if(i==251) print*,ii,iv,vi,'  ',tab2(iv+vi,i,1)
                   tab7(iv+vi,i,1)=tab9(iv+vi,tab4(i,1),ii)
                   if(vi+1>tab(j)) test=.false.
                   if(tab5(vi,j)>=pos_recomb2(v+1)) then      
                      test=.false.
                      m=1
                      do l=v+2,nb_recomb
                         if(tab5(vi,j)>=pos_recomb2(l)) m=m+1
                      enddo
                   endif
                   vi=vi+1
                enddo
                if(mod(m,2)/=0) then
                   ii=3-ii
                endif
                v=v+m
             enddo
             if(vi<=tab(j)) then
                tab2(iv+vi:iv+tab(j),i,1)=tab6(iv+vi:iv+tab(j),tab4(i,1),ii)
!!$                if(i==251) print*,ii,iv,vi,'  ',tab2(iv+vi:iv+tab(j),i,1)
                tab7(iv+vi:iv+tab(j),i,1)=tab9(iv+vi:iv+tab(j),tab4(i,1),ii)
             endif
             deallocate(pos_recomb2)
          endif
!!$          if(i==251) print*,'PARENTAL HAPLO',tab2(sum(tab(1:j-1))+1:sum(tab(1:j)),i,1)
          essai = .true.
          nb_recomb=random_poisson(tab5(tab(j),j),essai)
          ii=G05DYF(1,2)
          if(nb_recomb==0) then
             tab2(iv+1:iv+tab(j),i,2)=tab3(iv+1:iv+tab(j),tab4(i,2),ii)
             tab7(iv+1:iv+tab(j),i,2)=tab8(iv+1:iv+tab(j),tab4(i,2),ii)
          else
             allocate(pos_recomb(nb_recomb))
             do l=1,nb_recomb
                r=G05CAF(r)*tab5(tab(j),j)
                pos_recomb(l)=r
             enddo
             allocate(pos_recomb2(nb_recomb))
             if(nb_recomb>1) then
                allocate(rk(nb_recomb))
                rk=0
                call search_best(-pos_recomb,nb_recomb,rk,nb_recomb)
                pos_recomb2(:)=pos_recomb(rk(:))
                deallocate(rk)
             else
                pos_recomb2=pos_recomb
             endif
             deallocate(pos_recomb)
             v=0
             vi=1
             do while(v<nb_recomb)
                test=.true.
                do while(test)
                   tab2(iv+vi,i,2)=tab3(iv+vi,tab4(i,2),ii)
                   tab7(iv+vi,i,2)=tab8(iv+vi,tab4(i,2),ii)
                   if(vi+1>tab(j)) test=.false.
                   if(tab5(vi,j)>=pos_recomb2(v+1)) then      
                      test=.false.
                      m=1
                      do l=v+2,nb_recomb
                         if(tab5(vi,j)>=pos_recomb2(l)) m=m+1
                      enddo
                   endif
                   vi=vi+1
                enddo
                if(mod(m,2)/=0) then
                   ii=3-ii
                endif
                v=v+m
             enddo
             if(vi<=tab(j)) then
                tab2(iv+vi:iv+tab(j),i,2)=tab3(iv+vi:iv+tab(j),tab4(i,2),ii)
                tab7(iv+vi:iv+tab(j),i,2)=tab8(iv+vi:iv+tab(j),tab4(i,2),ii)
             endif
             deallocate(pos_recomb2)
          endif
       enddo
       do i=e-demi2+d,c
          do k=1,2
             essai = .true.
             nb_recomb=random_poisson(tab5(tab(j),j),essai)
             ii=G05DYF(1,2)
             if(nb_recomb==0) then
                tab2(iv+1:iv+tab(j),i,k)=tab3(iv+1:iv+tab(j),tab4(i,k),ii)
                tab7(iv+1:iv+tab(j),i,k)=tab8(iv+1:iv+tab(j),tab4(i,k),ii)
             else
                allocate(pos_recomb(nb_recomb))
                do l=1,nb_recomb
                   r=G05CAF(r)*tab5(tab(j),j)
                   pos_recomb(l)=r
                enddo
                allocate(pos_recomb2(nb_recomb))
                if(nb_recomb>1) then
                   allocate(rk(nb_recomb))
                   rk=0
                   call search_best(-pos_recomb,nb_recomb,rk,nb_recomb)
                   pos_recomb2(:)=pos_recomb(rk(:))
                   deallocate(rk)
                else
                   pos_recomb2=pos_recomb
                endif
                deallocate(pos_recomb)
                v=0
                vi=1
                do while(v<nb_recomb)
                   test=.true.
                   do while(test)
                      tab2(iv+vi,i,k)=tab3(iv+vi,tab4(i,k),ii)
                      tab7(iv+vi,i,k)=tab8(iv+vi,tab4(i,k),ii)
                      if(vi+1>tab(j)) test=.false.
                      if(tab5(vi,j)>=pos_recomb2(v+1)) then      
                         test=.false.
                         m=1
                         do l=v+2,nb_recomb
                            if(tab5(vi,j)>=pos_recomb2(l)) m=m+1
                         enddo
                      endif
                      vi=vi+1
                   enddo
                   if(mod(m,2)/=0) then
                      ii=3-ii
                   endif
                   v=v+m
                enddo
                if(vi<=tab(j)) then
                   tab2(iv+vi:iv+tab(j),i,k)=tab3(iv+vi:iv+tab(j),tab4(i,k),ii)
                   tab7(iv+vi:iv+tab(j),i,k)=tab8(iv+vi:iv+tab(j),tab4(i,k),ii)
                endif
                deallocate(pos_recomb2)
             endif
          enddo
       enddo
    enddo
    tab3(:,1:c,:)=tab2(:,1:c,:)
    tab8(:,1:c,:)=tab7(:,1:c,:)
    tab2=0
    tab7=0
  end subroutine transm_adm


  subroutine transm_adm_noCop(c,d,e,nc,tab,tab2,tab3,tab4,tab5,tab6)
    implicit none
    integer :: nc, c, d, e
    integer :: i, j, k, l, ii, iv, v, vi, m
    integer :: nb_recomb
    integer, dimension(:) :: tab ! nloc
    integer, dimension(:,:) :: tab4 ! parent
    integer, dimension(:,:,:) :: tab2, tab3, tab6 ! all2, all, allp2
    integer, allocatable, dimension(:) :: rk
    real(r8), dimension(:,:) :: tab5 ! pos_loc
    real(r8), allocatable, dimension(:) :: pos_recomb, pos_recomb2
    logical :: essai

    demi2=nint(real(d)/2.)
    do j=1,nc
       iv=sum(tab(1:(j-1)))
       do i=1,demi2
!!$ print*,i,tab4(i,:)
          essai = .true.
          nb_recomb=random_poisson(tab5(tab(j),j),essai)
          ii=G05DYF(1,2)
          if(nb_recomb==0) then
             tab2(iv+1:iv+tab(j),i,1)=tab6(iv+1:iv+tab(j),tab4(i,1),ii)
          else
             allocate(pos_recomb(nb_recomb))
             do l=1,nb_recomb
                r=G05CAF(r)*tab5(tab(j),j)
                pos_recomb(l)=r
             enddo
             allocate(pos_recomb2(nb_recomb))
             if(nb_recomb>1) then
                allocate(rk(nb_recomb))
                rk=0
                call search_best(-pos_recomb,nb_recomb,rk,nb_recomb)
                pos_recomb2(:)=pos_recomb(rk(:))
                deallocate(rk)
             else
                pos_recomb2=pos_recomb
             endif
             deallocate(pos_recomb)
             v=0
             vi=1
             do while(v<nb_recomb)
                test=.true.
                do while(test)
                   tab2(iv+vi,i,1)=tab6(iv+vi,tab4(i,1),ii)
                   if(vi+1>tab(j)) test=.false.
                   if(tab5(vi,j)>=pos_recomb2(v+1)) then      
                      test=.false.
                      m=1
                      do l=v+2,nb_recomb
                         if(tab5(vi,j)>=pos_recomb2(l)) m=m+1
                      enddo
                   endif
                   vi=vi+1
                enddo
                if(mod(m,2)/=0) then
                   ii=3-ii
                endif
                v=v+m
             enddo
             if(vi<=tab(j)) then
                tab2(iv+vi:iv+tab(j),i,1)=tab6(iv+vi:iv+tab(j),tab4(i,1),ii)
             endif
             deallocate(pos_recomb2)
          endif
          essai = .true.
          nb_recomb=random_poisson(tab5(tab(j),j),essai)
          ii=G05DYF(1,2)
          if(nb_recomb==0) then
             tab2(iv+1:iv+tab(j),i,2)=tab3(iv+1:iv+tab(j),tab4(i,2),ii)
          else
             allocate(pos_recomb(nb_recomb))
             do l=1,nb_recomb
                r=G05CAF(r)*tab5(tab(j),j)
                pos_recomb(l)=r
             enddo
             allocate(pos_recomb2(nb_recomb))
             if(nb_recomb>1) then
                allocate(rk(nb_recomb))
                rk=0
                call search_best(-pos_recomb,nb_recomb,rk,nb_recomb)
                pos_recomb2(:)=pos_recomb(rk(:))
                deallocate(rk)
             else
                pos_recomb2=pos_recomb
             endif
             deallocate(pos_recomb)
             v=0
             vi=1
             do while(v<nb_recomb)
                test=.true.
                do while(test)
                   tab2(iv+vi,i,2)=tab3(iv+vi,tab4(i,2),ii)
                   if(vi+1>tab(j)) test=.false.
                   if(tab5(vi,j)>=pos_recomb2(v+1)) then      
                      test=.false.
                      m=1
                      do l=v+2,nb_recomb
                         if(tab5(vi,j)>=pos_recomb2(l)) m=m+1
                      enddo
                   endif
                   vi=vi+1
                enddo
                if(mod(m,2)/=0) then
                   ii=3-ii
                endif
                v=v+m
             enddo
             if(vi<=tab(j)) then
                tab2(iv+vi:iv+tab(j),i,2)=tab3(iv+vi:iv+tab(j),tab4(i,2),ii)
             endif
             deallocate(pos_recomb2)
          endif
       enddo
       do i=demi2+1,e
          do k=1,2
             essai = .true.
             nb_recomb=random_poisson(tab5(tab(j),j),essai)
             ii=G05DYF(1,2)
             if(nb_recomb==0) then
                tab2(iv+1:iv+tab(j),i,k)=tab3(iv+1:iv+tab(j),tab4(i,k),ii)
             else
                allocate(pos_recomb(nb_recomb))
                do l=1,nb_recomb
                   r=G05CAF(r)*tab5(tab(j),j)
                   pos_recomb(l)=r
                enddo
                allocate(pos_recomb2(nb_recomb))
                if(nb_recomb>1) then
                   allocate(rk(nb_recomb))
                   rk=0
                   call search_best(-pos_recomb,nb_recomb,rk,nb_recomb)
                   pos_recomb2(:)=pos_recomb(rk(:))
                   deallocate(rk)
                else
                   pos_recomb2=pos_recomb
                endif
                deallocate(pos_recomb)
                v=0
                vi=1
                do while(v<nb_recomb)
                   test=.true.
                   do while(test)
                      tab2(iv+vi,i,k)=tab3(iv+vi,tab4(i,k),ii)
                      if(vi+1>tab(j)) test=.false.
                      if(tab5(vi,j)>=pos_recomb2(v+1)) then      
                         test=.false.
                         m=1
                         do l=v+2,nb_recomb
                            if(tab5(vi,j)>=pos_recomb2(l)) m=m+1
                         enddo
                      endif
                      vi=vi+1
                   enddo
                   if(mod(m,2)/=0) then
                      ii=3-ii
                   endif
                   v=v+m
                enddo
                if(vi<=tab(j)) then
                   tab2(iv+vi:iv+tab(j),i,k)=tab3(iv+vi:iv+tab(j),tab4(i,k),ii)
                endif
                deallocate(pos_recomb2)
             endif
          enddo
       enddo
       do i=e+1,e-demi2+d
          essai = .true.
          nb_recomb=random_poisson(tab5(tab(j),j),essai)
          ii=G05DYF(1,2)
          if(nb_recomb==0) then
!!$              print*,tab4(i,1)
             tab2(iv+1:iv+tab(j),i,1)=tab6(iv+1:iv+tab(j),tab4(i,1),ii)
          else
             allocate(pos_recomb(nb_recomb))
             do l=1,nb_recomb
                r=G05CAF(r)*tab5(tab(j),j)
                pos_recomb(l)=r
             enddo
             allocate(pos_recomb2(nb_recomb))
             if(nb_recomb>1) then
                allocate(rk(nb_recomb))
                rk=0
                call search_best(-pos_recomb,nb_recomb,rk,nb_recomb)
                pos_recomb2(:)=pos_recomb(rk(:))
                deallocate(rk)
             else
                pos_recomb2=pos_recomb
             endif
             deallocate(pos_recomb)
             v=0
             vi=1
             do while(v<nb_recomb)
                test=.true.
                do while(test)
                   tab2(iv+vi,i,1)=tab6(iv+vi,tab4(i,1),ii)
                   if(vi+1>tab(j)) test=.false.
                   if(tab5(vi,j)>=pos_recomb2(v+1)) then      
                      test=.false.
                      m=1
                      do l=v+2,nb_recomb
                         if(tab5(vi,j)>=pos_recomb2(l)) m=m+1
                      enddo
                   endif
                   vi=vi+1
                enddo
                if(mod(m,2)/=0) then
                   ii=3-ii
                endif
                v=v+m
             enddo
             if(vi<=tab(j)) then
                tab2(iv+vi:iv+tab(j),i,1)=tab6(iv+vi:iv+tab(j),tab4(i,1),ii)
             endif
             deallocate(pos_recomb2)
          endif
          essai = .true.
          nb_recomb=random_poisson(tab5(tab(j),j),essai)
          ii=G05DYF(1,2)
          if(nb_recomb==0) then
             tab2(iv+1:iv+tab(j),i,2)=tab3(iv+1:iv+tab(j),tab4(i,2),ii)
          else
             allocate(pos_recomb(nb_recomb))
             do l=1,nb_recomb
                r=G05CAF(r)*tab5(tab(j),j)
                pos_recomb(l)=r
             enddo
             allocate(pos_recomb2(nb_recomb))
             if(nb_recomb>1) then
                allocate(rk(nb_recomb))
                rk=0
                call search_best(-pos_recomb,nb_recomb,rk,nb_recomb)
                pos_recomb2(:)=pos_recomb(rk(:))
                deallocate(rk)
             else
                pos_recomb2=pos_recomb
             endif
             deallocate(pos_recomb)
             v=0
             vi=1
             do while(v<nb_recomb)
                test=.true.
                do while(test)
                   tab2(iv+vi,i,2)=tab3(iv+vi,tab4(i,2),ii)
                   if(vi+1>tab(j)) test=.false.
                   if(tab5(vi,j)>=pos_recomb2(v+1)) then      
                      test=.false.
                      m=1
                      do l=v+2,nb_recomb
                         if(tab5(vi,j)>=pos_recomb2(l)) m=m+1
                      enddo
                   endif
                   vi=vi+1
                enddo
                if(mod(m,2)/=0) then
                   ii=3-ii
                endif
                v=v+m
             enddo
             if(vi<=tab(j)) then
                tab2(iv+vi:iv+tab(j),i,2)=tab3(iv+vi:iv+tab(j),tab4(i,2),ii)
             endif
             deallocate(pos_recomb2)
          endif
       enddo
       do i=e-demi2+d,c
          do k=1,2
             essai = .true.
             nb_recomb=random_poisson(tab5(tab(j),j),essai)
             ii=G05DYF(1,2)
             if(nb_recomb==0) then
                tab2(iv+1:iv+tab(j),i,k)=tab3(iv+1:iv+tab(j),tab4(i,k),ii)
             else
                allocate(pos_recomb(nb_recomb))
                do l=1,nb_recomb
                   r=G05CAF(r)*tab5(tab(j),j)
                   pos_recomb(l)=r
                enddo
                allocate(pos_recomb2(nb_recomb))
                if(nb_recomb>1) then
                   allocate(rk(nb_recomb))
                   rk=0
                   call search_best(-pos_recomb,nb_recomb,rk,nb_recomb)
                   pos_recomb2(:)=pos_recomb(rk(:))
                   deallocate(rk)
                else
                   pos_recomb2=pos_recomb
                endif
                deallocate(pos_recomb)
                v=0
                vi=1
                do while(v<nb_recomb)
                   test=.true.
                   do while(test)
                      tab2(iv+vi,i,k)=tab3(iv+vi,tab4(i,k),ii)
                      if(vi+1>tab(j)) test=.false.
                      if(tab5(vi,j)>=pos_recomb2(v+1)) then      
                         test=.false.
                         m=1
                         do l=v+2,nb_recomb
                            if(tab5(vi,j)>=pos_recomb2(l)) m=m+1
                         enddo
                      endif
                      vi=vi+1
                   enddo
                   if(mod(m,2)/=0) then
                      ii=3-ii
                   endif
                   v=v+m
                enddo
                if(vi<=tab(j)) then
                   tab2(iv+vi:iv+tab(j),i,k)=tab3(iv+vi:iv+tab(j),tab4(i,k),ii)
                endif
                deallocate(pos_recomb2)
             endif
          enddo
       enddo
    enddo
    tab3(:,1:c,:)=tab2(:,1:c,:)
    tab2=0
  end subroutine transm_adm_noCop

  subroutine transm_adm_end(c,nc,tab,tab2,tab3,tab4,tab5,tab6,tab7,tab8,tab9,s_c,her)
    implicit none
    integer, intent(in):: c, nc, s_c ! sum(n(1:2,gene)), nbIntrog(gene), nt1, nchrom, store_cop
    integer:: j, i, l, ii, iv, v, vi, m, nb_recomb
    integer, dimension(:) :: tab, her ! nloc, herk
    integer, dimension(:,:) :: tab4 ! parent
    integer, dimension(:,:,:) :: tab2, tab3, tab6 ! all2, all, allp2
    integer, dimension(:,:,:) :: tab7, tab8, tab9 ! cop2, cop, copp2
    integer, allocatable, dimension(:) :: rk
    real(r8), dimension(:,:) :: tab5 ! pos_loc
    real(r8), allocatable, dimension(:) :: pos_recomb, pos_recomb2
    logical :: essai

    do j=1,nc
       iv=sum(tab(1:(j-1)))
       do i=1,c
!!$          print*,'CHROM',j,'IND',i
          ! Construct the paternally inherited chromosome
          essai = .true.
          nb_recomb=random_poisson(tab5(tab(j),j),essai)
          ii=G05DYF(1,2)
          if(nb_recomb==0) then
             if(her(i)==2) then
                tab2(iv+1:iv+tab(j),i,1)=tab6(iv+1:iv+tab(j),tab4(i,1),ii)
!!$                print*,'NO REC',i,iv+1,iv+tab(j),tab2(iv+1:iv+tab(j),i,1)
                if(s_c==1) tab7(iv+1:iv+tab(j),i,1)=tab9(iv+1:iv+tab(j),tab4(i,1),ii)
             else
                tab2(iv+1:iv+tab(j),i,1)=tab3(iv+1:iv+tab(j),tab4(i,1),ii)
!!$                print*,'NO REC',i,iv+1,iv+tab(j),tab2(iv+1:iv+tab(j),i,1)
                if(s_c==1) tab7(iv+1:iv+tab(j),i,1)=tab8(iv+1:iv+tab(j),tab4(i,1),ii)
             endif
          else
             allocate(pos_recomb(nb_recomb))
             do l=1,nb_recomb
                r=G05CAF(r)*tab5(tab(j),j)
                pos_recomb(l)=r
             enddo
             allocate(pos_recomb2(nb_recomb))
             if(nb_recomb>1) then
                allocate(rk(nb_recomb))
                rk=0
                call search_best(-pos_recomb,nb_recomb,rk,nb_recomb)
                pos_recomb2(:)=pos_recomb(rk(:))
                deallocate(rk)
             else
                pos_recomb2=pos_recomb
             endif
             deallocate(pos_recomb)
             v=0
             vi=1
             do while(v<nb_recomb)
                test=.true.
                do while(test)
                   if(her(i)==2) then
                      tab2(iv+vi,i,1)=tab6(iv+vi,tab4(i,1),ii)
!!$                      print*,'REC',i,iv+vi,tab2(iv+vi,i,1)
                      if(s_c==1) tab7(iv+vi,i,1)=tab9(iv+vi,tab4(i,1),ii)
                   else
                      tab2(iv+vi,i,1)=tab3(iv+vi,tab4(i,1),ii)
                      if(s_c==1) tab7(iv+vi,i,1)=tab8(iv+vi,tab4(i,1),ii)
                   endif
                   if(vi+1>tab(j)) test=.false.
                   if(tab5(vi,j)>=pos_recomb2(v+1)) then      
                      test=.false.
                      m=1
                      do l=v+2,nb_recomb
                         if(tab5(vi,j)>=pos_recomb2(l)) m=m+1
                      enddo
                   endif
                   vi=vi+1
                enddo
                if(mod(m,2)/=0) then
                   ii=3-ii
                endif
                v=v+m
             enddo
             if(vi<=tab(j)) then
                if(her(i)==2) then
                   tab2(iv+vi:iv+tab(j),i,1)=tab6(iv+vi:iv+tab(j),tab4(i,1),ii)
!!$                      print*,'REC',i,iv+vi,tab2(iv+vi:iv+tab(j),i,1)
                   if(s_c==1) tab7(iv+vi:iv+tab(j),i,1)=tab9(iv+vi:iv+tab(j),tab4(i,1),ii)
                else
                   tab2(iv+vi:iv+tab(j),i,1)=tab3(iv+vi:iv+tab(j),tab4(i,1),ii)
                   if(s_c==1) tab7(iv+vi:iv+tab(j),i,1)=tab8(iv+vi:iv+tab(j),tab4(i,1),ii)
                endif
             endif
             deallocate(pos_recomb2)
          endif
          ! Then the maternally inherited chromosme
          essai = .true.
          nb_recomb=random_poisson(tab5(tab(j),j),essai)
          ii=G05DYF(1,2)
          if(nb_recomb==0) then
             tab2(iv+1:iv+tab(j),i,2)=tab3(iv+1:iv+tab(j),tab4(i,2),ii)
             if(s_c==1) tab7(iv+1:iv+tab(j),i,2)=tab8(iv+1:iv+tab(j),tab4(i,2),ii)
          else
             allocate(pos_recomb(nb_recomb))
             do l=1,nb_recomb
                r=G05CAF(r)*tab5(tab(j),j)
                pos_recomb(l)=r
             enddo
             allocate(pos_recomb2(nb_recomb))
             if(nb_recomb>1) then
                allocate(rk(nb_recomb))
                rk=0
                call search_best(-pos_recomb,nb_recomb,rk,nb_recomb)
                pos_recomb2(:)=pos_recomb(rk(:))
                deallocate(rk)
             else
                pos_recomb2=pos_recomb
             endif
             deallocate(pos_recomb)
             v=0
             vi=1
             do while(v<nb_recomb)
                test=.true.
                do while(test)
                   tab2(iv+vi,i,2)=tab3(iv+vi,tab4(i,2),ii)
                   if(s_c==1) tab7(iv+vi,i,2)=tab8(iv+vi,tab4(i,2),ii)
                   if(vi+1>tab(j)) test=.false.
                   if(tab5(vi,j)>=pos_recomb2(v+1)) then      
                      test=.false.
                      m=1
                      do l=v+2,nb_recomb
                         if(tab5(vi,j)>=pos_recomb2(l)) m=m+1
                      enddo
                   endif
                   vi=vi+1
                enddo
                if(mod(m,2)/=0) then
                   ii=3-ii
                endif
                v=v+m
             enddo
             if(vi<=tab(j)) then
                tab2(iv+vi:iv+tab(j),i,2)=tab3(iv+vi:iv+tab(j),tab4(i,2),ii)
                if(s_c==1) tab7(iv+vi:iv+tab(j),i,2)=tab8(iv+vi:iv+tab(j),tab4(i,2),ii)
             endif
             deallocate(pos_recomb2)
          endif
       enddo
    enddo
  end subroutine transm_adm_end


  ! Subroutine changed in December 2010 - Fyt
  subroutine mutat(c,d,e,tab,tab2,tab3,tab4)
    implicit none
    integer :: c,d,e,j,k,ii,value,value2
    !    integer,allocatable :: tab(:,:,:),tab2(:,:,:),tab3(:,:,:),tab4(:,:,:)
    integer :: tab(:,:,:),tab2(:,:,:),tab3(:,:,:),tab4(:,:,:)
    integer, allocatable, dimension(:):: ind_mut, chr_mut
    integer, allocatable, dimension(:,:)::  ver
    logical:: test
    value=0
    value2=0
!!$    print*,'I'
    do i=c,d
       tab2(:,i,:)=tab(:,i,:)
       tab4(:,i,:)=tab3(:,i,:)
    enddo
    do j=1,nmq+nqtl
       if(indic(j)==1) then
          value=value+1
          value2=nmq+value
       else
          value2=j-value
       endif
       if(j==1) then
          test=.true.
       else
          test=.false.
       endif
       if(indic(j)==1) then
          i=G01BJC2(2*(d-c+1),tmutQTL,test)
       else
          if(typ(value2)==1) then 
             i=G01BJC2(2*(d-c+1),tmutSNP,test)
          else
             i=G01BJC2(2*(d-c+1),tmutMST,test)
          endif
       endif
!!$       print*,'NB mutations:',i,j
       if(i>0) then
          allocate(ind_mut(i),chr_mut(i))
          call G05DYF2(c,d,i,ind_mut)
          call G05DYF2(1,2,i,chr_mut)
!!$ Test that all mutations take place on distinct chromosomes
          allocate(ver(i,1))
          ver(:,1)=2*(ind_mut(:)-1)+chr_mut(:)
          do k=1,i
             do while (count(any(ver.eq.ver(k,1),1))>1) 
                ind_mut(k)=G05DYF(c,d)
                chr_mut(k)=G05DYF(1,2)
                ver(k,1)=2*(ind_mut(k)-1)+chr_mut(k)
!!$                print*,'A',count(any(ver.eq.ver(k,1),1))
             enddo
          enddo
          if(typ(value2)==1) then
             do k=1,i
                if(tab(j,ind_mut(k),chr_mut(k))==1) then
                   tab2(j,ind_mut(k),chr_mut(k))=tab(j,ind_mut(k),chr_mut(k))+1
                else if(tab(j,ind_mut(k),chr_mut(k))==2) then
                   tab2(j,ind_mut(k),chr_mut(k))=tab(j,ind_mut(k),chr_mut(k))-1
                endif
                maxcop(j,e)=maxcop(j,e)+1
                tab4(j,ind_mut(k),chr_mut(k))=maxcop(j,e)
                if(maxcop(j,e)>ncopmax(e)) then
                   ncopmax(e)=maxcop(j,e)
                endif
             enddo
          else 
             do k=1,i
                if(tab(j,ind_mut(k),chr_mut(k))==1) then
                   tab2(j,ind_mut(k),chr_mut(k))=tab(j,ind_mut(k),chr_mut(k))+1
                else if(tab(j,ind_mut(k),chr_mut(k))==maxval(nball(j,:))) then
                   tab2(j,ind_mut(k),chr_mut(k))=tab(j,ind_mut(k),chr_mut(k))-1
                else
                   ii=G05DYF(1,2)
                   if(ii==1) then
                      tab2(j,ind_mut(k),chr_mut(k))=tab(j,ind_mut(k),chr_mut(k))+1
                   else
                      tab2(j,ind_mut(k),chr_mut(k))=tab(j,ind_mut(k),chr_mut(k))-1
                   endif
                endif
!!$print*,tab2(j,ind_mut(k),chr_mut(k)),k,ind_mut(k),chr_mut(k),j
                !print*,'G',j,e,shape(maxcop)
                maxcop(j,e)=maxcop(j,e)+1
                !print*,'H'
                tab4(j,ind_mut(k),chr_mut(k))=maxcop(j,e)
                if(maxcop(j,e)>ncopmax(e)) then
                   ncopmax(e)=maxcop(j,e)
                endif
             enddo
          endif
!!$          print*,maxval(nball(:,e)),maxval(tab2(:,:,:))
          deallocate(ver,ind_mut,chr_mut)
       endif
    enddo
    do i=c,d
       tab(:,i,:)=tab2(:,i,:)
       tab3(:,i,:)=tab4(:,i,:)
    enddo
    tab2=0
    tab4=0
  end subroutine mutat

  subroutine mutat_noCop(c,d,tab,tab2)
    implicit none
    integer :: c,d,j,k,ii,value,value2,id
    !    integer,allocatable :: tab(:,:,:),tab2(:,:,:),tab3(:,:,:),tab4(:,:,:)
    integer :: tab(:,:,:),tab2(:,:,:)
    integer, allocatable, dimension(:):: ind_mut, chr_mut
    integer, allocatable, dimension(:,:)::  ver
    logical:: test
    value=0
    value2=0
!!$    print*,'I'
    tab2(:,c:d,:)=tab(:,c:d,:)
    do j=1,nmq+nqtl
       if(indic(j)==1) then
          value=value+1
          value2=nmq+value
       else
          value2=j-value
       endif
       if(j==1) then
          test=.true.
       else
          test=.false.
       endif
       if(indic(j)==1) then
          id=G01BJC2(2*(d-c+1),tmutQTL,test)
       else
          if(typ(value2)==1) then 
             id=G01BJC2(2*(d-c+1),tmutSNP,test)
          else
             id=G01BJC2(2*(d-c+1),tmutMST,test)
          endif
       endif
       ! if(id>0) print*,'NB MUTAT',id,j,tmutSNP,indic(j)
       if(id>0) then
          allocate(ind_mut(id),chr_mut(id))
          call G05DYF2(c,d,id,ind_mut)
          call G05DYF2(1,2,id,chr_mut)
!!$ Test that all mutations take place on distinct chromosomes
          allocate(ver(id,1))
          ver(:,1)=2*(ind_mut(:)-1)+chr_mut(:)
          do k=1,id
             do while (count(any(ver.eq.ver(k,1),1))>1) 
                ind_mut(k)=G05DYF(c,d)
                chr_mut(k)=G05DYF(1,2)
                ver(k,1)=2*(ind_mut(k)-1)+chr_mut(k)
             enddo
          enddo
          if(typ(value2)==1) then
             do k=1,id
                if(tab(j,ind_mut(k),chr_mut(k))==1) then
                   tab2(j,ind_mut(k),chr_mut(k))=tab(j,ind_mut(k),chr_mut(k))+1
                else if(tab(j,ind_mut(k),chr_mut(k))==2) then
                   tab2(j,ind_mut(k),chr_mut(k))=tab(j,ind_mut(k),chr_mut(k))-1
                endif
             enddo
          else 
             do k=1,id
                if(tab(j,ind_mut(k),chr_mut(k))==1) then
                   tab2(j,ind_mut(k),chr_mut(k))=tab(j,ind_mut(k),chr_mut(k))+1
                else if(tab(j,ind_mut(k),chr_mut(k))==maxval(nball(j,:))) then
                   tab2(j,ind_mut(k),chr_mut(k))=tab(j,ind_mut(k),chr_mut(k))-1
                else
                   ii=G05DYF(1,2)
                   if(ii==1) then
                      tab2(j,ind_mut(k),chr_mut(k))=tab(j,ind_mut(k),chr_mut(k))+1
                   else
                      tab2(j,ind_mut(k),chr_mut(k))=tab(j,ind_mut(k),chr_mut(k))-1
                   endif
                endif
!!$print*,tab2(j,ind_mut(k),chr_mut(k)),k,ind_mut(k),chr_mut(k),j
             enddo
          endif
!!$          print*,maxval(nball(:,e)),maxval(tab2(:,:,:))
          deallocate(ver,ind_mut,chr_mut)
       endif
    enddo
    tab(:,c:d,:)=tab2(:,c:d,:)
    tab2=0
  end subroutine mutat_noCop

  subroutine pheno(pare,gin,c,d,poly,gan,e,envi,per,tab,eff_qt,nq,posqt,pos_a,nrm,e_dom)  !! Phenotypes
    implicit none
    integer :: c,d,j,e,nq
    integer, dimension(:) :: posqt
    integer, dimension(:,:) :: pare, pos_a
    integer, dimension(:,:,:) :: tab
    real(r8) ::poly,men,env,mendel,envi
    real(r8) :: valqtl,epis,m_inbr
    real(r8), dimension(:) :: e_dom
    real(r8), dimension(:,:) :: gan, gin, per, eff_qt, nrm
    logical :: test

    do i=e,c
       m_inbr=(2-(nrm(pare(i,1),pare(i,1))-1)-(nrm(pare(i,2),pare(i,2))-1))/4
       men=sqrt(m_inbr*poly**2)
       mendel=G05DDF(0.d0,men)
       env=G05DDF(0.d0,envi)
       valqtl=0
       epis=0
       do j=1,nq
          if(pos_a(j,3)/=0) then
             if(pos_a(j,1)<pos_a(j,4)) then
                if(pos_a(j,6)==1) then
                   epis=epis+sum(eff_qt(j,tab(pos_a(j,1),i,:)))*&
                        sum(eff_qt(pos_a(j,3),tab(pos_a(j,4),i,:)))
                else
                   test=.false.
                   if(eff_qt(j,tab(pos_a(j,1),i,1))==maxval(eff_qt(j,:))) test=.true.
                   if(eff_qt(j,tab(pos_a(j,1),i,2))==maxval(eff_qt(j,:))) test=.true.
                   if (test) epis=epis+ sum(eff_qt(pos_a(j,3),tab(pos_a(j,4),i,:)))
                endif
             endif
          else
!!$             print*,tab(posqt(j),i,:)
             valqtl=valqtl+sum(eff_qt(j,tab(posqt(j),i,:)))
             if(tab(pos_assoc(j,1),i,1)/=tab(pos_assoc(j,1),i,2)) &
                  epis=epis+e_dom(j)
          endif
       enddo
       gan(i,d)=0.5*(gin(pare(i,1),d)+gin(pare(i,2),d))+mendel
       per(i,d)=gan(i,d)+env+valqtl+epis
       !       if(gene==time) print*,j,gan(j,d),gin(pare(j,1),d),gin(pare(j,2),d),mendel,env,valqtl
    enddo
    do j=e,c
       gin(j,d)=gan(j,d)
    enddo
    gani=0
  end subroutine pheno

  subroutine pheno_adm(pare,gin,c,nqt,poly,poly2,gani,f,envi,perf,tab,eff_qt,mat,mat2,pos_a,posqt,e_dom)  !! Phenotypes crossbred
    ! poly is the polygenic variance in the 1st population
    ! poly2 is the polygenic variance in the pool of both populations
    ! mat= nrmat
    ! mat2= nrmat3
    implicit none
    integer :: c,j,f,demi,demi2,nqt
    integer, dimension(:) :: posqt
    integer, dimension(:,:) :: pare, pos_a
    integer, dimension(:,:,:) :: tab
    real(r8) :: men, mendel, env, envi, poly, poly2
    real(r8) :: valqtl, epis, m_inbr 
    real(r8), dimension(:) :: e_dom
    real(r8), dimension(:,:) :: gani, gin, perf, eff_qt, mat, mat2
    demi=nint(real(c)/2.)
    demi2=nint(real(f)/2.)
    do i=1,demi ! admixed individuals
       m_inbr=(2-(mat2(pare(i,1),pare(i,1))-1)-(mat(pare(i,2),pare(i,2))-1))/4
       men=sqrt(m_inbr*poly2**2)
       mendel=G05DDF(0.d0,men)
       env=G05DDF(0.d0,envi)
       gani(i,1)=0.5*(gin(pare(i,1),2)+gin(pare(i,2),1))+mendel
       valqtl=0
       epis=0
       do j=1,nqt
          if(pos_a(j,3)/=0) then
             if(pos_a(j,1)<pos_a(j,4)) then
                if(pos_assoc(j,6)==1) then
                   epis=epis+sum(eff_qt(j,tab(pos_assoc(j,1),i,:)))*&
                        sum(eff_qt(pos_assoc(j,3),tab(pos_assoc(j,4),i,:)))
                else
                   test=.false.
                   if(eff_qt(j,tab(pos_assoc(j,1),i,1))==maxval(eff_qt(j,:))) test=.true.
                   if(eff_qt(j,tab(pos_assoc(j,1),i,2))==maxval(eff_qt(j,:))) test=.true.
                   if (test) epis=epis+ sum(eff_qt(pos_assoc(j,3),tab(pos_assoc(j,4),i,:)))
                endif
             endif
          else
!!$print*,i,j,posqt(j),tab(posqt(j),i,:)
             valqtl=valqtl+sum(eff_qt(j,tab(posqt(j),i,:)))
             if(tab(pos_assoc(j,1),i,1)/=tab(pos_assoc(j,1),i,2)) &
                  epis=epis+e_dom(j)
          endif
       enddo
       perf(i,1)=gani(i,1)+env+valqtl+epis
    enddo
    do i=demi2+1,demi+demi2 ! pure-bred individuals
       m_inbr=(2-(mat(pare(i,1),pare(i,1))-1)-(mat(pare(i,2),pare(i,2))-1))/4
       men=sqrt(m_inbr*poly**2)
       mendel=G05DDF(0.d0,men)
       env=G05DDF(0.d0,envi)
       gani(i,1)=0.5*(gin(pare(i,1),2)+gin(pare(i,2),1))+mendel
       valqtl=0
       epis=0
       do j=1,nqt
          if(pos_a(j,3)/=0) then
             if(pos_a(j,1)<pos_a(j,4)) then
                if(pos_assoc(j,6)==1) then
                   epis=epis+sum(eff_qt(j,tab(pos_assoc(j,1),i,:)))*&
                        sum(eff_qt(pos_assoc(j,3),tab(pos_assoc(j,4),i,:)))
                else
                   test=.false.
                   if(eff_qt(j,tab(pos_assoc(j,1),i,1))==maxval(eff_qt(j,:))) test=.true.
                   if(eff_qt(j,tab(pos_assoc(j,1),i,2))==maxval(eff_qt(j,:))) test=.true.
                   if (test) epis=epis+ sum(eff_qt(pos_assoc(j,3),tab(pos_assoc(j,4),i,:)))
                endif
             endif
          else
!!$             print*,i,j,tab(posqt(j),i,:)
             valqtl=valqtl+sum(eff_qt(j,tab(posqt(j),i,:)))
             if(tab(pos_assoc(j,1),i,1)/=tab(pos_assoc(j,1),i,2)) &
                  epis=epis+e_dom(j)
          endif
       enddo
       perf(i,1)=gani(i,1)+env+valqtl+epis
    enddo
    do i=demi+1,demi2 ! admixed individuals
       m_inbr=(2-(mat2(pare(i,1),pare(i,1))-1)-(mat(pare(i,2),pare(i,2))-1))/4
       men=sqrt(m_inbr*poly2**2)
       mendel=G05DDF(0.d0,men)
       env=G05DDF(0.d0,envi)
       gani(i,1)=0.5*(gin(pare(i,1),1)+gin(pare(i,2),2))+mendel
       valqtl=0
       epis=0
       do j=1,nqt
          if(pos_a(j,3)/=0) then
             if(pos_a(j,1)<pos_a(j,4)) then
                if(pos_assoc(j,6)==1) then
                   epis=epis+sum(eff_qt(j,tab(pos_assoc(j,1),i,:)))*&
                        sum(eff_qt(pos_assoc(j,3),tab(pos_assoc(j,4),i,:)))
                else
                   test=.false.
                   if(eff_qt(j,tab(pos_assoc(j,1),i,1))==maxval(eff_qt(j,:))) test=.true.
                   if(eff_qt(j,tab(pos_assoc(j,1),i,2))==maxval(eff_qt(j,:))) test=.true.
                   if (test) epis=epis+ sum(eff_qt(pos_assoc(j,3),tab(pos_assoc(j,4),i,:)))
                endif
             endif
          else
             valqtl=valqtl+sum(eff_qt(j,tab(posqt(j),i,:)))
             if(tab(pos_assoc(j,1),i,1)/=tab(pos_assoc(j,1),i,2)) &
                  epis=epis+e_dom(j)
          endif
       enddo
       perf(i,1)=gani(i,1)+env+valqtl+epis
    enddo
    do i=demi+demi2+1,f ! pure-bred individuals
       m_inbr=(2-(mat(pare(i,1),pare(i,1))-1)-(mat(pare(i,2),pare(i,2))-1))/4
       men=sqrt(m_inbr*poly**2)
       mendel=G05DDF(0.d0,men)
       env=G05DDF(0.d0,envi)
       gani(i,1)=0.5*(gin(pare(i,1),1)+gin(pare(i,2),1))+mendel
       epis=0
       valqtl=0
       do j=1,nqt
          if(pos_a(j,3)/=0) then
             if(pos_a(j,1)<pos_a(j,4)) then
                if(pos_assoc(j,6)==1) then
                   epis=epis+sum(eff_qt(j,tab(pos_assoc(j,1),i,:)))*&
                        sum(eff_qt(pos_assoc(j,3),tab(pos_assoc(j,4),i,:)))
                else
                   test=.false.
                   if(eff_qt(j,tab(pos_assoc(j,1),i,1))==maxval(eff_qt(j,:))) test=.true.
                   if(eff_qt(j,tab(pos_assoc(j,1),i,2))==maxval(eff_qt(j,:))) test=.true.
                   if (test) epis=epis+ sum(eff_qt(pos_assoc(j,3),tab(pos_assoc(j,4),i,:)))
                endif
             endif
          else
             valqtl=valqtl+sum(eff_qt(j,tab(posqt(j),i,:)))
             if(tab(pos_assoc(j,1),i,1)/=tab(pos_assoc(j,1),i,2)) &
                  epis=epis+e_dom(j)
          endif
       enddo
       perf(i,1)=gani(i,1)+env+valqtl+epis
    enddo
    do j=f,c
       gin(j,1)=gani(j,1)
    enddo
    gani=0
  end subroutine pheno_adm

  subroutine pheno_end(pare,gin,c,d,poly,gan,e,envi,per,tab,eff_qt,nq,posqt,&
       pos_a,nrm,nrm3,e_dom,her)  !! Phenotypes
    implicit none
    integer :: c,d,j,e,nq
    integer, dimension(:) :: posqt, her
    integer, dimension(:,:) :: pare, pos_a
    integer, dimension(:,:,:) :: tab ! all 
    real(r8) :: poly,men,env,mendel,envi,valqtl,epis,m_inbr
    real(r8), dimension(:) :: e_dom
    real(r8), dimension(:,:) :: gan, gin, per, eff_qt
    real(r8), dimension(:,:) :: nrm, nrm3
    logical :: test

    do i=e,c
       if(her(i)==2) then
          m_inbr=(2-(nrm3(pare(i,1),pare(i,1))-1)-(nrm(pare(i,2),pare(i,2))-1))/4
       else
          m_inbr=(2-(nrm(pare(i,1),pare(i,1))-1)-(nrm(pare(i,2),pare(i,2))-1))/4
       endif
       men=sqrt(m_inbr*poly**2)
       mendel=G05DDF(0.d0,men)
       env=G05DDF(0.d0,envi)
       valqtl=0
       epis=0
       do j=1,nq
          if(pos_a(j,3)/=0) then
             if(pos_a(j,1)<pos_a(j,4)) then
                if(pos_assoc(j,6)==1) then
                   epis=epis+sum(eff_qt(j,tab(pos_assoc(j,1),i,:)))*&
                        sum(eff_qt(pos_assoc(j,3),tab(pos_assoc(j,4),i,:)))
                else
                   test=.false.
                   if(eff_qt(j,tab(pos_assoc(j,1),i,1))==maxval(eff_qt(j,:))) test=.true.
                   if(eff_qt(j,tab(pos_assoc(j,1),i,2))==maxval(eff_qt(j,:))) test=.true.
                   if (test) epis=epis+ sum(eff_qt(pos_assoc(j,3),tab(pos_assoc(j,4),i,:)))
                endif
             endif
          else
!!$             print*,tab(posqt(j),i,:)
             valqtl=valqtl+sum(eff_qt(j,tab(posqt(j),i,:)))
             if(tab(pos_assoc(j,1),i,1)/=tab(pos_assoc(j,1),i,2)) &
                  epis=epis+e_dom(j)
          endif
       enddo
       if(her(i)==2) then
          gan(i,d)=0.5*(gin(pare(i,1),2)+gin(pare(i,2),d))+mendel
       else
          gan(i,d)=0.5*(gin(pare(i,1),1)+gin(pare(i,2),d))+mendel
       endif
       per(i,d)=gan(i,d)+env+valqtl+epis
       !       if(gene==time) print*,j,gan(j,d),gin(pare(j,1),d),gin(pare(j,2),d),mendel,env,valqtl
    enddo
    do j=e,c
       gin(j,d)=gan(j,d)
    enddo
    gani=0
  end subroutine pheno_end


  subroutine trans(c,nc,tab,tab2,tab3,tab4,tab5,gene,tab6,tab7)
    implicit none
    integer :: nc, c, gene
    integer :: i, j, k, l, ii, iv, v, vi
    integer :: nb_recomb
    integer, dimension(:) :: tab ! nloc
!!$    integer, dimension(:,:) :: tab4 ! parent
    integer, dimension(:,:,:) :: tab2, tab3, tab4, tab6, tab7 ! all2, all, cop, cop2
    integer, allocatable, dimension(:) :: rk
    real(r8), dimension(:,:) :: tab5 ! pos_loc
    real(r8), allocatable, dimension(:) :: pos_recomb, pos_recomb2
    logical :: essai

    do j=1,nc
       iv=sum(tab(1:(j-1)))
       do i=1,c
          do k=1,2
             essai = .true.
             nb_recomb=random_poisson(tab5(tab(j),j),essai)
             ii=G05DYF(1,2)
             if(nb_recomb==0) then
                tab2(iv+1:iv+tab(j),i,k)=tab3(iv+1:iv+tab(j),tab4(gene,j,1),ii)
                tab6(iv+1:iv+tab(j),i,k)=tab7(iv+1:iv+tab(j),tab4(gene,j,1),ii)
             else
                allocate(pos_recomb(nb_recomb))
                do l=1,nb_recomb
                   r=G05CAF(r)*tab5(tab(j),j)
                   pos_recomb(l)=r
                enddo
                allocate(pos_recomb2(nb_recomb))
                if(nb_recomb>1) then
                   allocate(rk(nb_recomb))
                   rk=0
                   call search_best(-pos_recomb,nb_recomb,rk,nb_recomb)
                   pos_recomb2(:)=pos_recomb(rk(:))
                   deallocate(rk)
                else
                   pos_recomb2=pos_recomb
                endif
                deallocate(pos_recomb)
                v=0
                vi=1
                do while(v<nb_recomb)
                   test=.true.
                   do while(test)
                      tab2(iv+vi,i,k)=tab3(iv+vi,tab4(gene,j,1),ii)
                      tab6(iv+vi,i,k)=tab7(iv+vi,tab4(gene,j,1),ii)
                      if(vi+1>tab(j)) test=.false.
                      if(tab5(vi,j)>=pos_recomb2(v+1)) then      
                         test=.false.
                         m=1
                         do l=v+2,nb_recomb
                            if(tab5(vi,j)>=pos_recomb2(l)) m=m+1
                         enddo
                      endif
                      vi=vi+1
                   enddo
                   if(mod(m,2)/=0) then
                      ii=3-ii
                   endif
                   v=v+m
                enddo
                if(vi<=tab(j)) then
                   tab2(iv+vi:iv+tab(j),i,k)=tab3(iv+vi:iv+tab(j),tab4(gene,j,1),ii)
                   tab6(iv+vi:iv+tab(j),i,k)=tab7(iv+vi:iv+tab(j),tab4(gene,j,1),ii)
                endif
                deallocate(pos_recomb2)
             endif
          enddo
       enddo
    enddo
  end subroutine trans

  subroutine trans_noCop(c,nc,tab,tab2,tab3,tab4,tab5,gene)
    implicit none
    integer :: nc, c, gene
    integer :: i, j, k, l, ii, iv, v, vi
    integer :: nb_recomb
    integer, dimension(:) :: tab ! nloc
!!$    integer, dimension(:,:) :: tab4 ! parent
    integer, dimension(:,:,:) :: tab2, tab3, tab4 ! all2, all
    integer, allocatable, dimension(:) :: rk
    real(r8), dimension(:,:) :: tab5 ! pos_loc
    real(r8), allocatable, dimension(:) :: pos_recomb, pos_recomb2
    logical :: essai

    do j=1,nc
       iv=sum(tab(1:(j-1)))
       do i=1,c
          do k=1,2
             essai = .true.
             nb_recomb=random_poisson(tab5(tab(j),j),essai)
             ii=G05DYF(1,2)
             if(nb_recomb==0) then
                tab2(iv+1:iv+tab(j),i,k)=tab3(iv+1:iv+tab(j),tab4(gene,j,1),ii)
             else
                allocate(pos_recomb(nb_recomb))
                do l=1,nb_recomb
                   r=G05CAF(r)*tab5(tab(j),j)
                   pos_recomb(l)=r
                enddo
                allocate(pos_recomb2(nb_recomb))
                if(nb_recomb>1) then
                   allocate(rk(nb_recomb))
                   rk=0
                   call search_best(-pos_recomb,nb_recomb,rk,nb_recomb)
                   pos_recomb2(:)=pos_recomb(rk(:))
                   deallocate(rk)
                else
                   pos_recomb2=pos_recomb
                endif
                deallocate(pos_recomb)
                v=0
                vi=1
                do while(v<nb_recomb)
                   test=.true.
                   do while(test)
                      tab2(iv+vi,i,k)=tab3(iv+vi,tab4(gene,j,1),ii)
                      if(vi+1>tab(j)) test=.false.
                      if(tab5(vi,j)>=pos_recomb2(v+1)) then      
                         test=.false.
                         m=1
                         do l=v+2,nb_recomb
                            if(tab5(vi,j)>=pos_recomb2(l)) m=m+1
                         enddo
                      endif
                      vi=vi+1
                   enddo
                   if(mod(m,2)/=0) then
                      ii=3-ii
                   endif
                   v=v+m
                enddo
                if(vi<=tab(j)) then
                   tab2(iv+vi:iv+tab(j),i,k)=tab3(iv+vi:iv+tab(j),tab4(gene,j,1),ii)
                endif
                deallocate(pos_recomb2)
             endif
          enddo
       enddo
    enddo
  end subroutine trans_noCop


  subroutine sele(c,d,e,nq,pol,envi,tab,nrm,pos_a,eff_qt,e_dom,ran,posqt,nan,gene)  !! calcul des performances des individus et classement selon celles-ci
    implicit none
    integer :: c,d,e,j,nq,nan,gene
    !    integer,allocatable :: tab(:,:,:)
    integer :: tab(:,:,:)
    integer, dimension(:) :: ran, posqt
    integer, dimension(:,:) :: pos_a
    real(r8) :: mendel,valqtl,env,pol,men,envi,epis
    real(r8),dimension(:) :: e_dom
    real(r8),allocatable,dimension(:) :: perf_t
    real(r8),dimension(:,:) :: nrm, eff_qt !nrmat_f, pos_assoc
    do i=c,d
       m_inbr=(2-(nrm(par(iv,i,1)-(nan+(gene-2)*d),par(iv,i,1)-(nan+(gene-2)*d))-1)-&
            (nrm(par(iv,i,2)-(nan+(gene-2)*d),par(iv,i,2)-(nan+(gene-2)*d))-1))/4
       men=sqrt(m_inbr*pol**2)
       mendel=G05DDF(0.d0,men)
       env=G05DDF(0.d0,envi)
       valqtl=0
       epis=0
       do j=1,nq
          if(pos_a(j,3)/=0) then
             if(pos_a(j,1)<pos_a(j,4)) then
                if(pos_assoc(j,6)==1) then
                   epis=epis+sum(eff_qt(j,tab(pos_assoc(j,1),i,:)))*&
                        sum(eff_qt(pos_assoc(j,3),tab(pos_assoc(j,4),i,:)))
                else
                   test=.false.
                   if(eff_qt(j,tab(pos_assoc(j,1),i,1))==maxval(eff_qt(j,:))) test=.true.
                   if(eff_qt(j,tab(pos_assoc(j,1),i,2))==maxval(eff_qt(j,:))) test=.true.
                   if (test) epis=epis+ sum(eff_qt(pos_assoc(j,3),tab(pos_assoc(j,4),i,:)))
                endif
             endif
          else
             valqtl=valqtl+sum(eff_qt(j,tab(posqt(j),i,:)))
             if(tab(pos_assoc(j,1),i,1)/=tab(pos_assoc(j,1),i,2)) &
                  epis=epis+e_dom(j)
          endif
       enddo
       env=G05DDF(0.d0,envir)
       perf(i,e)=gani(i,e)+env+valqtl+epis
       gind(i,e)=gani(i,e)
    enddo
    allocate(perf_t(d-c+1))
    call search_best(perf_t,d-c+1,ran,d-c+1)
    deallocate(perf_t)
  end subroutine sele


  subroutine choix_surv(c,d,tab2,tab3,tab5,tab6)  !! Random choice of individuals for a sudden bottleneck
    implicit none
    integer :: c,d,i
    !    integer, allocatable ::table(:),tab2(:,:,:),tab3(:,:,:),tab4(:)
    !    integer,allocatable ::tab5(:,:,:),tab6(:,:,:)
    integer ::tab2(:,:,:),tab3(:,:,:),tab6(:,:,:),tab5(:,:,:)
    integer,allocatable :: table(:),tab4(:)
    allocate(table(d),tab4(d))
    tab4=0
    do i=1,d
       table(i)=G05DYF(1,c)
       do while(tab4(i)/=0)
          table(i)=G05DYF(1,c)
       enddo
       tab4(i)=1
       tab3(:,i,:)=tab2(:,table(i),:)
       tab6(:,i,:)=tab5(:,table(i),:)
    enddo
    deallocate(table,tab4)
  end subroutine choix_surv

  subroutine choix_surv_noCop(c,d,tab2,tab3)  !! Random choice of individuals for a sudden bottleneck
    implicit none
    integer :: c,d,i
    !    integer, allocatable ::table(:),tab2(:,:,:),tab3(:,:,:),tab4(:)
    !    integer,allocatable ::tab5(:,:,:),tab6(:,:,:)
    integer ::tab2(:,:,:),tab3(:,:,:)
    integer,allocatable :: table(:),tab4(:)
    allocate(table(d),tab4(d))
    tab4=0
    do i=1,d
       table(i)=G05DYF(1,c)
       do while(tab4(i)/=0)
          table(i)=G05DYF(1,c)
       enddo
       tab4(i)=1
       tab3(:,i,:)=tab2(:,table(i),:)
    enddo
    deallocate(table,tab4)
  end subroutine choix_surv_noCop


  subroutine long_seg(d,c,nm,nq,posq,tab,tab2,tab3,tab4,tab5,tab6,lg_ch,chr_QT,nch,dis)  !! Length of founder segments
    implicit none
    integer :: c,d,ii,i,j,k,l,iii,nm,nq,j2,nch
    integer :: tab(:,:,:), tab3(:,:,:,:), tab4(:,:,:,:), posq(:), chr_QT(:) ! tab3<--> deb, tab4 <--> fin
    integer, dimension(:,:,:) :: tab6
    real(r8) :: tab2(:,:,:,:), tab5(:,:,:), lg_ch(:), dis(:)
    tab2=0
    tab3=1
    tab4=0
    tab6=1
    tab5=0
    do i=d,c
       do k=1,2
          ii=1
          do j=1,nm+nq-1
             if(tab(j,i,k)==tab(j+1,i,k).and.dis(j)/=100) then
                tab2(tab6(i,k,ii),ii,i,k)=dis(j)+tab2(tab6(i,k,ii),ii,i,k)
                tab4(tab6(i,k,ii),ii,i,k)=j+1
             else if(tab(j,i,k)/=tab(j+1,i,k).and.dis(j)/=100) then
                tab2(tab6(i,k,ii),ii,i,k)=0.5*dis(j)+tab2(tab6(i,k,ii),ii,i,k)
                tab4(tab6(i,k,ii),ii,i,k)=j
                tab6(i,k,ii)=tab6(i,k,ii)+1
                tab2(tab6(i,k,ii),ii,i,k)=0.5*dis(j)
                tab3(tab6(i,k,ii),ii,i,k)=j+1
                if(j+1==nm+nq) then
                   tab3(tab6(i,k,ii),ii,i,k)=j+1
                endif
             else if(dis(j)==100) then
                tab4(tab6(i,k,ii),ii,i,k)=j
                ii=ii+1
                tab3(tab6(i,k,ii),ii,i,k)=j+1
             endif
          enddo
       enddo
    enddo
    j=maxval(chr_QT)
    j2=minval(chr_QT)
    do i=d,c
       do k=1,2
          do l=1,nq
             do iv=j2,j
                if(chr_QT(l)==iv) then
                   do iii=1,tab6(i,k,iv)
                      if(posq(l)<=tab4(iii,iv,i,k).and.posq(l)>=tab3(iii,iv,i,k)) tab5(l,i,k)=tab2(iii,iv,i,k)  !! Segment containing QTL l
                   enddo
                endif
             enddo
          enddo
       enddo
    enddo
    do i=1,nch
       do j=d,c
          do k=1,2
             if(abs(tab2(1,i,j,k)-lg_ch(i))<0.00000001) tab2(1,i,j,k)=lg_ch(i)
          enddo
       enddo
    enddo
  end subroutine long_seg


  subroutine consang(c,d,nm,nq,tab,tab2,tab3)  !! Average inbreeding and its variance at each locus
    implicit none
    integer:: c,d,i,j,nm,nq
    integer ::tab(:,:,:)
    integer, allocatable, dimension(:) :: cons
    integer,allocatable,dimension(:,:) :: inbreed
    real(r8) :: tab2(:), tab3(:)
    allocate(inbreed(d-c+1,nm+nq),cons(nm+nq))
    inbreed=0
    tab2=0
    tab3=0
    cons=0
    do i=c,d
       do j=1,nm+nq
          if(tab(j,i,1)==tab(j,i,2)) inbreed(i,j)=1
       enddo
    enddo
    do j=1,nm+nq
       do i=c,d
          if(inbreed(i,j)==1) cons(j)=cons(j)+1
          tab3(j)=tab3(j)+inbreed(i,j)*inbreed(i,j)
       enddo
    enddo
    pr=1./real(d-c+1)
    do j=1,nm+nq
       tab2(j)=cons(j)*pr
       tab3(j)=tab3(j)-(d-c+1)*tab2(j)*tab2(j)
       tab3(j)=tab3(j)/real(d-c)
    enddo
  end subroutine consang


  subroutine stat_freq_1(f,c,tab,tab3,tab2)  !! Occurences of a value
    implicit none
    integer :: c,f,m,j,k,l
    integer :: tab(:,:,:),tab3(:,:)
    real(r8) :: tab2(:,:)
    tab2=0
    do m=1,nmq+nqtl
       do j=f,c
          do k=1,2
             l=tab(m,j,k)
             tab2(m,l)=tab2(m,l)+1
          enddo
       enddo
    enddo
    l=0
    do i=1,nmq+nqtl
       do j=1,maxval(tab3(i,:))
          tab2(i,j)=real(tab2(i,j))/real(2*(c-f+1))
       enddo
    enddo

  end subroutine stat_freq_1

  subroutine stat_freq_init(f,c,e,tab,tab3,tab2,indi)  !! Occurences of a value
    implicit none
    integer :: c,e,f,m,j,k,l
    integer :: tab(:,:,:),tab3(:,:),indi(:)
    real(r8) :: tab2(:,:)
    tab2=0
    do m=1,nmq+nqtl
       do j=f,c
          do k=1,2
             l=tab(m,j,k)
             tab2(m,l)=tab2(m,l)+1
          enddo
       enddo
    enddo
    l=0
    do i=1,nmq+nqtl
       if(indi(i)==1) then
          l=l+1
          do j=1,tab3(nmq+l,e)
             tab2(i,j)=real(tab2(i,j))/real(2*(c-f+1))
          enddo
       else
          do j=1,tab3(i-l,e)
             tab2(i,j)=real(tab2(i,j))/real(2*(c-f+1))
          enddo
       endif
    enddo
  end subroutine stat_freq_init



  subroutine LD(lg_chrom,bin,nchr,nba,nm,nq,d,tab,fqa,verif_print,pop,chr_lo,nloc,pos_loc,gener)
    implicit none

    integer:: i, j, k, l, o, ii, m, n1, nn, nchr, nm, nq, d, pop, gener, d_c, ll
    integer, dimension(:),intent(in) :: verif_print, chr_lo, nloc
    integer, dimension(:,:), intent(in):: nba
    integer, dimension(:,:,:),intent(in):: tab
    real(r8):: p, q, d_pri, d_prov2, dmax, di, khi2pri, khideux, bin
    real(r8), dimension(:),intent(in):: lg_chrom
    real(r8), dimension(:,:),intent(in):: fqa, pos_loc
    real(r8), allocatable, dimension(:,:):: fqgen
    real(r8), allocatable, dimension(:,:,:,:):: ld_intra, ld_inter
    ! di not necessary --> not to be allocated; idem khi2prim and dprim

    ! compute D'
    !    allocate(d_prov2(nm+nq-1,maxval(nalmax(:)),nm+nq,maxval(nalmax(:))))
    !    allocate(dmax(nm+nq-1,maxval(nalmax(:)),nm+nq,maxval(nalmax(:))))
    !    allocate(fqgen(nm+nq-1,maxval(nalmax(:)),nm+nq,maxval(nalmax(:))))

    if(verif_print(8)==1) then
       ! simld_sum
       d_c=ceiling(maxval(lg_chrom)/bin) ! bin in M
       k=d_c
       allocate(ld_intra(k,nchr,15,2)) ! # occurencies, sum, sum of the squares and repartition of the values for the two LD measures
       ! classes: 0, 0 to 0.1, .1 to .2, ..., .8 to .9, .9 to 1, 1 --> 12 classes
       ld_intra=0
       allocate(ld_inter(nchr-1,nchr-1,15,2)) ! chr 1 -> last-1 for the 1st dim, chr 2 -> last for the 2nd dim
       ld_inter=0
    endif
    allocate(fqgen(maxval(nball),maxval(nball)))
    fqgen=0
    ll=0
    do i=1,nm+nq-1
       n1=0
       do k=1,nba(i,pop)
          if(fqa(i,k)>0) n1=n1+1
       enddo
       do j=i+1,nm+nq
          ll=ll+1
          d_pri=0
          d_prov2=0
          dmax=0
          di=0
          khideux=0
!!$print*,i,j,gener
          fqgen=0.
          do k=1,d
             do o=1,2
                l=tab(i,k,o)
                m=tab(j,k,o)
                fqgen(l,m)=fqgen(l,m)+1
             enddo
          enddo
          !       enddo
          !    enddo
          fqgen=fqgen/(real(2*d))
!!$          print*,i,j,fqgen
          !    do i=1,nm+nq-1
          !       do j=i+1,nm+nq
          nn=0; n1=0
          do k=1,nba(j,pop)
             if(fqa(j,k)>0) nn=nn+1
          enddo
          do k=1,nba(i,pop)
             if(fqa(i,k)>0) n1=n1+1
          enddo
          ii=min(n1,nn)
          do k=1,nba(i,pop)
             do l=1,nba(j,pop)
                p=fqa(i,k)
                q=fqa(j,l)
                di=fqgen(k,l)-p*q
!!$                print*,i,j,k,l,di
                if (di<0) then
                   dmax=min(p*q,(1-p)*(1-q))
                else
                   dmax=min((1-p)*q,(1-q)*p)
                endif
                if (dmax==0) then
                   d_prov2=0
                else
                   d_prov2=p*q*abs(di)/(dmax)
                endif
                d_pri=d_pri+d_prov2
                if(p*q/=0) then
                   di=di**2/(p*q)
                else
                   di=0
                endif
                khideux=khideux+di
             enddo
          enddo
          if(ii/=1) then
             khi2pri=khideux/real(ii-1)
          else
             khi2pri=0
             d_pri=0
          endif
          if(verif_print(1)/=0)  then
             if(chr_lo(j)==chr_lo(i)) then
                r=abs(pos_loc(j-sum(nloc(1:chr_loc(j)-1)),chr_loc(j))-pos_loc(i-&
                     sum(nloc(1:chr_loc(i)-1)),chr_loc(i)))
                r=real(int(r*1000000000+.5)/1000000000.)
             else
                r=10
             endif
             write(11,'(i6,1x,i4,1x,2(f6.4,1x),i8,1x,i4,1x,f10.6)') i, j, d_pri, khi2pri, d, gener, r
          endif
          test=.FALSE.
          if(indic(i)/=0.or.indic(j)/=0) test=.TRUE.
          if(verif_print(10)/=0.and.test) write(111,'(i6,1x,i4,1x,2(f6.4,1x),i8,1x,i4,1x,f10.6)') i, j,&
               d_pri, khideux, d ,gener, r
          if(verif_print(8)==1) then
             if(chr_lo(j)==chr_lo(i)) then
                r=abs(pos_loc(j-sum(nloc(1:chr_loc(j)-1)),chr_loc(j))-pos_loc(i-&
                     sum(nloc(1:chr_loc(i)-1)),chr_loc(i)))
                r=real(int(r*1000000000+.5)/1000000000.)
                d_c=1
                do while(r>=d_c*bin)
                   d_c=d_c+1
                enddo
                k=1
                do while(d_pri>=k*.1) ! LD frequency classes
                   k=k+1
                enddo
                ld_intra(d_c,chr_lo(j),1,1)=ld_intra(d_c,chr_lo(j),1,1)+1
                ld_intra(d_c,chr_lo(j),2,1)=ld_intra(d_c,chr_lo(j),2,1)+d_pri
                ld_intra(d_c,chr_lo(j),3,1)=ld_intra(d_c,chr_lo(j),3,1)+d_pri**2
                if(d_pri==0) then
                   ld_intra(d_c,chr_lo(j),4,1)=ld_intra(d_c,chr_lo(j),4,1)+1
                else if(d_pri==1) then
                   ld_intra(d_c,chr_lo(j),15,1)=ld_intra(d_c,chr_lo(j),15,1)+1
                else
                   ld_intra(d_c,chr_lo(j),4+k,1)=ld_intra(d_c,chr_lo(j),4+k,1)+1
                endif
!!$if(gener==0) print*,r,d_c,i,j
!!$
!!$                if(gener==0) print*,r,d_c,d_pri,k,ld_intra(d_c,chr_lo(j),1,1),ld_intra(d_c,chr_lo(j),4,1),&
!!$                     ld_intra(d_c,chr_lo(j),4+k,1),ld_intra(d_c,chr_lo(j),15,1)
                do while(khi2pri>=k*.1) ! LD frequency classes
                   k=k+1
                enddo
                ld_intra(d_c,chr_lo(j),1,2)=ld_intra(d_c,chr_lo(j),1,2)+1
                ld_intra(d_c,chr_lo(j),2,2)=ld_intra(d_c,chr_lo(j),2,2)+khi2pri
                ld_intra(d_c,chr_lo(j),3,2)=ld_intra(d_c,chr_lo(j),3,2)+khi2pri**2
                if(khi2pri==0) then
                   ld_intra(d_c,chr_lo(j),4,2)=ld_intra(d_c,chr_lo(j),4,2)+1
                else if(khi2pri==1) then
                   ld_intra(d_c,chr_lo(j),15,2)=ld_intra(d_c,chr_lo(j),15,2)+1
                else
                   ld_intra(d_c,chr_lo(j),4+k,2)=ld_intra(d_c,chr_lo(j),4+k,2)+1
                endif
!!$                if(gener==0.and.d_c==5) print*,ld_intra(d_c,chr_lo(j),2,2),ld_intra(d_c,chr_lo(j),3,2),&
!!$                     ld_intra(d_c,chr_lo(j),2,1),ld_intra(d_c,chr_lo(j),3,1),d_pri,khi2pri
!!$
             else
                k=min(chr_lo(j),chr_lo(i))
                l=max(chr_lo(j),chr_lo(i))
                ld_inter(k,l-1,1,1)=ld_inter(k,l-1,1,1)+1
                ld_inter(k,l-1,2,1)=ld_inter(k,l-1,2,1)+d_pri
                ld_inter(k,l-1,3,1)=ld_inter(k,l-1,3,1)+d_pri**2
                ii=1
                do while(d_pri>=ii*.1)
                   ii=ii+1
                enddo
                if(d_pri==0) then
                   ld_inter(k,l-1,4,1)=ld_inter(k,l-1,4,1)+1
                else if(d_pri==1) then
                   ld_inter(k,l-1,15,1)=ld_inter(k,l-1,15,1)+1
                else
                   ld_inter(k,l-1,4+ii,1)=ld_inter(k,l-1,4+ii,1)+1
                endif
                ii=1
                do while(khi2pri>=ii*.1)
                   ii=ii+1
                enddo
                ld_inter(k,l-1,1,2)=ld_inter(k,l-1,1,2)+1
                ld_inter(k,l-1,2,2)=ld_inter(k,l-1,2,2)+khi2pri
                ld_inter(k,l-1,3,2)=ld_inter(k,l-1,3,2)+khi2pri**2
                if(khi2pri==0) then
                   ld_inter(k,l-1,4,2)=ld_inter(k,l-1,4,2)+1
                else if(khi2pri==1) then
                   ld_inter(k,l-1,15,2)=ld_inter(k,l-1,15,2)+1
                else
                   ld_inter(k,l-1,4+ii,2)=ld_inter(k,l-1,4+ii,2)+1
                endif
             endif
          endif
       enddo
    enddo
    deallocate(fqgen)

    do j=4,15
       do k=1,nchrom
          do i=1,ceiling(lg_chrom(k)/bin)
             do l=1,2
                if(ld_intra(i,k,1,l)/=0) ld_intra(i,k,j,l)=ld_intra(i,k,j,l)/ld_intra(i,k,1,l)
             enddo
          enddo
       enddo
    enddo
    if(verif_print(8)==1) then
       do k=1,nchrom
          do i=1,ceiling(lg_chrom(k)/bin)
             write(112,'(a5,1x,i2,1x,i4,1x,a4,1x,f9.0,1x,f10.4,1x,f10.4,1x,12(f6.4,1x),i4)') 'Intra',&
                  k, i, 'D''',ld_intra(i,k,:,1),gener
             write(112,'(a5,1x,i2,1x,i4,1x,a4,1x,f9.0,1x,f10.4,1x,f10.4,1x,12(f6.4,1x),i4)') 'Intra',&
                  k, i, 'chi2',ld_intra(i,k,:,2),gener
          enddo
          do i=k+1,nchrom
             write(112,'(a5,1x,i2,1x,i4,1x,a4,1x,f9.0,1x,f10.4,1x,f10.4,1x,12(f6.4,1x),i4)') 'Inter',&
                  k, i,  'D''',ld_inter(k,i-1,:,1),gener
             write(112,'(a5,1x,i2,1x,i4,1x,a4,1x,f9.0,1x,f10.4,1x,f10.4,1x,12(f6.4,1x),i4)') 'Inter',&
                  k, i,  'chi2',ld_inter(k,i-1,:,2),gener
          enddo
       enddo
    endif
    if (allocated(ld_intra)) deallocate(ld_intra)
    if (allocated(ld_inter)) deallocate(ld_inter)

  end subroutine LD


  subroutine nbhaplotypes(c,tab,indi,nm,nq)  !! Identification of the various haplotypes of size c defined by alleles or copy numbers
    implicit none
    integer ::c,i,j,k,l, nm, nq
    integer :: tab(:,:,:), indi(:)
    integer, allocatable, dimension(:,:,:) :: all8, all10, all6, all7
    integer, allocatable, dimension(:) :: haploq, haplo
    allocate(all8(nm+nq,c,2),all10(nm+nq,2*c,1),all6(nm+nq,c,2))
    allocate(all7(nm+nq,2*c,1))
    do i=1,c
       all8(:,i,:)=tab(:,i,:) ! all loci
       all6(:,i,:)=tab(:,i,:) ! no QTL
    enddo
    do i=1,nm+nq
       if(indic(i)==1) all6(i,:,:)=0
    enddo
    do i=1,c
       id=0
       id2=0
       do k=1,nm+nq
          if(indi(k)/=1) then
             if(all6(k,i,1)==tab(k,i,2)) id2=id2+1
          endif
          if(all8(k,i,1)==tab(k,i,2)) id=id+1 
       enddo
       if(id==nm+nq) all8(:,i,2)=0
       if(id2==nm) all6(:,i,2)=0
    enddo
    do i=1,c-1
       do j=i+1,c
          id=0
          if(all8(1,i,1)/=0.and.all8(1,j,1)/=0) then
             do k=1,nm+nq
                if(all8(k,i,1)==tab(k,j,1)) id=id+1
             enddo
             if(id==nm+nq) all8(:,j,1)=0
          endif
          id=0
          if(all8(1,i,2)/=0.and.all8(1,j,2)/=0) then
             do k=1,nm+nq
                if(all8(k,i,2)==tab(k,j,2)) id=id+1
             enddo
             if(id==nm+nq) all8(:,j,2)=0
          endif
          id=0
          if(all8(1,i,1)/=0.and.all8(1,j,2)/=0) then
             do k=1,nm+nq
                if(all8(k,i,1)==tab(k,j,2)) id=id+1
             enddo
             if(id==nm+nq) all8(:,j,2)=0
          endif
          id=0
          if(all6(1,i,1)/=0.and.all6(1,j,1)/=0) then
             do k=1,nm+nq
                if(indi(k)/=1) then
                   if(all6(k,i,1)==tab(k,j,1)) id=id+1
                endif
             enddo
             if(id==nm) all6(:,j,1)=0
          endif
          id=0
          if(all6(1,i,2)/=0.and.all6(1,j,2)/=0) then
             do k=1,nm+nq
                if(indi(k)/=1) then
                   if(all6(k,i,1)==tab(k,j,2)) id=id+1
                endif
             enddo
             if(id==nm) all6(:,j,2)=0
          endif
          id=0
          if(all6(1,i,1)/=0.and.all6(1,j,2)/=0) then
             do k=1,nm+nq
                if(indi(k)/=1) then
                   if(all6(k,i,1)==tab(k,j,2)) id=id+1
                endif
             enddo
             if(id==nm) all6(:,j,2)=0
          endif
       enddo
    enddo
    nb_hc=0
    nb_h=0
    do i=1,c
       do j=1,2
          if(all8(1,i,j)/=0) then
             nb_hc=nb_hc+1
             all10(:,nb_hc,1)=all8(:,i,j)
          endif
          if(all6(1,i,j)/=0) then
             nb_h=nb_h+1
             all7(:,nb_h,1)=all6(:,i,j)
          endif
       enddo
    enddo
    deallocate(all8,all6)
    allocate(haploq(nb_hc),haplo(nb_h))
    haploq=0
    haplo=0
    do i=1,nb_hc
       do j=1,c
          do l=1,2
             id=0
             do k=1,nm+nq
                if(all10(k,i,1)==tab(k,j,l)) id=id+1
             enddo
             if(id==nm+nq) haploq(i)=haploq(i)+1
          enddo
       enddo
    enddo
    do i=1,nb_h
       do j=1,c
          do l=1,2
             id=0
             do k=1,nm+nq
                if(indi(k)/=1) then
                   if(all7(k,i,1)==tab(k,j,l)) id=id+1
                endif
             enddo
             if(id==nm) haplo(i)=haplo(i)+1
          enddo
       enddo
    enddo
    deallocate(all7,all10)
  end subroutine nbhaplotypes


  subroutine eval_pic(c,tab,nm,pi)   !! PIC
    integer ::c,i,j,k,nm
    integer :: tab(:,:)
    real(r8)::pr,pr1,pi(:)
    real(r8), allocatable, dimension(:) :: pic1, pic2
    allocate(pic1(nm),pic2(nm))
    pi=0
    pic1=0
    pic2=0
    do i=1,nm
       do j=1,tab(i,c)
          pic1(i)=pic1(i)+fqall(i,j)*fqall(i,j)
       enddo
       do j=1,tab(i,c)-1
          do k=1,tab(i,c)
             pr=fqall(i,j)**2
             pr1=fqall(i,k)**2
             pic2(i)=pic2(i)+2*pr*pr1
          enddo
       enddo
       pi(i)=1-pic1(i)-pic2(i)
    enddo
    deallocate(pic1,pic2)
  end subroutine eval_pic



  subroutine export(c,d,tab)  !! File usable by QTLIM.f
    integer :: c,d,i,j,k
    integer:: tab(:,:,:)
    character*1:: anal(4)
    integer, allocatable, dimension(:,:,:) :: typaj
    open(8,file='param-Ter')  !! paramètres à fournir pour QTLIM.f externes au simulateur
    do i=1,4
       read(8,*)anal(i)
    enddo
    read(8,*)sc_dist
    read(8,*)tol
    read(8,*)maxcal
    read(8,*)qtl_fq
    read(8,*)mu
    read(8,*)add
    read(8,*)dom
    read(8,*)res_var
    read(8,*)lambda
    read(8,*)tps
    allocate(typaj(nmq,d,2))  !! Haplotypes codés par chiffres
    do i=c,d
       l=0
       do j=1,nmq+nqtl
          if(indic(j)==1) then
             l=l+1
          else
             typaj(j-l,i,1)=tab(j,i,1)
             typaj(j-l,i,2)=tab(j,i,2)
          endif
       enddo
    enddo
    open(40,file='Ter')
    write(40,*)d-c+1
    write(40,*)nmq
    write(40,'(f6.4)')sc_dist
    write(40,'(f10.8)')tol
    write(40,*)maxcal
    do i=1,nmq
       write(40,'(f10.5)')cart(i)/100
    enddo
    write(40,'(f10.5)')qtl_fq
    write(40,'(f10.5)')mu
    write(40,'(f10.5)')add
    write(40,'(f10.5)')dom
    write(40,'(f10.5)')res_var
    write(40,'(f10.5)')lambda
    write(40,*)tps
    do i=c,d
       do k=1,2
          write(40,*)(typaj(j,i,k),j=1,nmq)
       enddo
    enddo
    do i=1,nt
       !    do i=c-nt*(1+nf),d-nt*(1+nf)
       do j=1,nf
          write(40,*)perf((i-1)*nf+j,nbpop+1)
       enddo
    enddo
    do i=1,4
       write(40,*)anal(i)
       if(anal(3)=='y'.and.i==3) write(40,*)'2'    !! Terwilliger par haplotype calculé avec des haplotypes de 2 marqueurs
    enddo
    deallocate(typaj)
  end subroutine export


  subroutine nrm_1pop(paren,nn,nn_1,mat)
    implicit none
    integer :: nn, nn_1
    ! init=0 for the 1st population, maxval(n(:,1)) else
    integer, dimension (:,:) :: paren
    real(r8), allocatable, dimension (:) :: diag
    real(r8), allocatable, dimension (:,:) :: prov
    real(r8), dimension (:,:) :: mat
    !print*,'nrm'
    allocate(diag(nn))
    diag=0
    do j=1,nn
       diag(j)=1+(mat(paren(j,1),paren(j,2))/2)
    enddo
    allocate(prov(nn_1,nn))
    do j=1,nn
       do ii=1,nn_1
          prov(ii,j)=(mat(ii,paren(j,1))+mat(ii,paren(j,2)))/2     
       enddo
    enddo
    do j=1,nn
       do ii=j+1,nn
          mat(j,ii)=(prov(paren(ii,1),j)+prov(paren(ii,2),j))/2       
          mat(ii,j)=mat(j,ii)
       enddo
       mat(j,j)=diag(j) 
    enddo
    deallocate(prov,diag)
!!$    do i=1,nn
!!$       print*,i,'NRMAT',mat(i,:)
!!$    enddo

  end subroutine nrm_1pop


  subroutine nrm_2pop_sep(paren,paren2,nn,nn2,nn_1,nn2_1,mat,mat2)
    implicit none
    integer :: nn, nn2, nn_1, nn2_1
    ! init=0 for the 1st population, maxval(n(:,1)) else
    integer, dimension (:,:) :: paren, paren2
    real(r8), allocatable, dimension (:) :: diag
    real(r8), allocatable, dimension (:,:) :: prov, stoc
    real(r8), dimension (:,:) :: mat, mat2

    ! First save the existing coefficients
    allocate(stoc(max(nn_1,nn2_1),nn_1+nn2_1))
    stoc(1:nn_1,1:nn_1)=mat(1:nn_1,1:nn_1)
    stoc(1:nn2_1,nn_1+1:nn_1+nn2_1)=mat2(1:nn2_1,1:nn2_1)
    mat=0
    allocate(diag(nn))
    allocate(prov(nn_1,nn))
    do j=1,nn
       diag(j)=1+(stoc(paren(j,1),paren(j,2))/2)
    enddo
    do j=1,nn
       do ii=1,nn_1
          prov(ii,j)=(stoc(ii,paren(j,1))+stoc(ii,paren(j,2)))/2     
       enddo
    enddo
    do j=1,nn
       do ii=j+1,nn
          mat(j,ii)=(prov(paren(ii,1),j)+prov(paren(ii,2),j))/2       
          mat(ii,j)=mat(j,ii)
       enddo
       mat(j,j)=diag(j) 
    enddo
    deallocate(diag,prov)

    allocate(diag(nn2),prov(nn2_1,nn2))
    do j=1,nn2
       diag(j)=1+(stoc(paren2(j,1),paren2(j,2))/2)
    enddo
    do j=1,nn2
       do ii=1,nn2_1
          prov(j,ii)=(stoc(ii,nn_1+paren2(j,1))+stoc(ii,nn_1+paren2(j,2)))/2     
       enddo
    enddo
    do j=1,nn2
       do ii=j+1,nn2
          mat2(j,ii)=(prov(paren2(ii,1),j)+prov(paren2(ii,2),j))/2       
          mat2(ii,j)=mat(j,ii)
       enddo
       mat2(j,j)=diag(j) 
    enddo
    deallocate(diag,prov,stoc)

  end subroutine nrm_2pop_sep


  subroutine nrm_2pop_inf(paren,paren2,nn,nn2,nn_1,nn2_1,mat,mat2,mat3,n_inf)
    implicit none
    integer :: nn, nn2, nn_1, nn2_1, n_inf
    ! init=0 for the 1st population, maxval(n(:,1)) else
    integer, dimension (:,:) :: paren, paren2
    real(r8), allocatable, dimension (:) :: diag
    real(r8), allocatable, dimension (:,:) :: prov, stoc
    real(r8), dimension (:,:) :: mat, mat2, mat3

    allocate(diag(nn+nn2))
    diag=0
    ! First save the existing coefficients
    allocate(stoc(max(nn_1,2*nn2_1),nn_1+2*nn2_1))
    stoc(1:nn_1,1:nn_1)=mat(1:nn_1,1:nn_1)
    stoc(1:nn_1,nn_1+1:nn_1+nn2_1)=mat2(1:nn_1,1:nn2_1)
    stoc(1:nn2_1,nn_1+nn2_1+1:nn_1+2*nn2_1)=mat3(1:nn2_1,1:nn2_1)
!!$    print*,shape(stoc)
!!$    do i=1,nn
!!$       print*,i,paren(i,:)
!!$    enddo
!!$    do i=1,nn2
!!$       print*,i,paren2(i,:)
!!$    enddo

    mat=0
    mat2=0
    mat3=0

    ! Diagonal for the new individuals of the 1st population
    do j=1,nint(n_inf/2.)
       ! Admixed individuals: the 2nd parent comes from the 2nd population
       diag(j)=1+(stoc(paren(j,2),nn_1+paren(j,1))/2) ! dam from the 1st pop, sire from the 2nd
    enddo
    do j=nint(n_inf/2.)+1,nint(nn/2.)
       diag(j)=1+(stoc(paren(j,1),paren(j,2))/2)
    enddo
    do j=nint(nn/2.)+1,nint(nn/2.)+nint(n_inf/2.)
       ! Admixed individuals: the 1st parent comes from the 2nd population
       diag(j)=1+(stoc(paren(j,2),nn_1+paren(j,1))/2)
    enddo
    do j=nint(nn/2.)+nint(n_inf/2.)+1,nn
       diag(j)=1+(stoc(paren(j,1),paren(j,2))/2)
    enddo

    ! Diagonal for the new individuals of the 2nd population
    do j=1,nn2
       diag(nn+j)=1+0.5*(stoc(paren2(j,1),nn_1+nn2_1+paren2(j,2)))
    enddo

    ! Old individuals of the 1st population
    allocate(prov(nn_1+nn2_1,nn+nn2))
    prov=0
    do j=1,nn_1
       ! 1/ With the new individuals of the 1st population
       ! 1a/ Admixed individuals
       do k=1,nint(n_inf/2.)
          prov(j,k)=0.5*(stoc(j,nn_1+paren(k,1))+stoc(j,paren(k,2)))
       enddo
       ! 1b/ Purebred
       do k=nint(n_inf/2.)+1,nint(nn/2.)
          prov(j,k)=0.5*(stoc(j,paren(k,1))+stoc(j,paren(k,2)))
       enddo
       ! 1a/ Admixed individuals
       do k=nint(nn/2.)+1,nint(nn/2.)+nint(n_inf/2.)
          prov(j,k)=0.5*(stoc(j,nn_1+paren(k,1))+stoc(j,paren(k,2)))
       enddo
       ! 1b/ Purebred
       do k=nint(nn/2.)+nint(n_inf/2.)+1,nn
          prov(j,k)=0.5*(stoc(j,paren(k,1))+stoc(j,paren(k,2)))
       enddo

       ! 2/ With the new individuals of the 2nd population 
       do k=1,nn2
          prov(j,nn+k)=0.5*(stoc(j,nn_1+paren2(k,1))+stoc(j,nn_1+paren2(k,2)))
       enddo
    enddo

    ! Old individuals of the 2nd population
    do j=1,nn2_1
       ! 1/ With the new individuals of the 1st population
       ! 1a/ Admixed individuals
       do k=1,nint(n_inf/2.)
          prov(nn_1+j,k)=0.5*(stoc(paren(k,1),nn_1+nn2_1+j)+stoc(paren(k,2),nn_1+j))
       enddo
       ! 1b/ Purebred
       do k=nint(n_inf/2.)+1,nint(nn/2.)
          prov(nn_1+j,k)=0.5*(stoc(paren(k,1),nn_1+j)+stoc(paren(k,2),nn_1+j))
       enddo
       ! 1a/ Admixed individuals
       do k=nint(nn/2.)+1,nint(nn/2.)+nint(n_inf/2.)
          prov(nn_1+j,k)=0.5*(stoc(paren(k,1),nn_1+nn2_1+j)+stoc(paren(k,2),nn_1+j))
       enddo
       ! 1b/ Purebred
       do k=nint(nn/2.)+nint(n_inf/2.)+1,nn
          prov(nn_1+j,k)=0.5*(stoc(paren(k,1),nn_1+j)+stoc(paren(k,2),nn_1+j))
       enddo

       ! 2/ With the new individuals of the 2nd population 
       do k=1,nn2
          prov(nn_1+j,nn+k)=0.5*(stoc(j,nn_1+nn2_1+paren2(k,1))+stoc(j,nn_1+nn2_1+paren2(k,2)))
       enddo
    enddo

    ! New individuals among them
    ! Population 1
    do j=1,nint(n_inf/2.)
       do k=1,nn
          mat(j,k)=0.5*(prov(nn_1+paren(j,1),k)+prov(paren(j,2),k))
          mat(k,j)=mat(j,k)
       enddo
    enddo
!!$    print*,shape(mat), nn
    do j=nint(n_inf/2.)+1,nint(nn/2.)
       do k=1,nn
!!$print*,parent(j,1),paren(j,2)
          mat(j,k)=0.5*(prov(paren(j,1),k)+prov(paren(j,2),k))
          mat(k,j)=mat(j,k)
       enddo
    enddo
    do j=nint(nn/2.)+1,nint(nn/2.)+nint(n_inf/2.)
       do k=1,nn
          mat(j,k)=0.5*(prov(nn_1+paren(j,1),k)+prov(paren(j,2),k))
          mat(k,j)=mat(j,k)
       enddo
    enddo
    do j=nint(nn/2.)+nint(n_inf/2.)+1,nn
       do k=1,nn
          mat(j,k)=0.5*(prov(paren(j,1),k)+prov(paren(j,2),k))
          mat(k,j)=mat(j,k)
       enddo
    enddo

    ! Population 1 with population 2
    do j=1,nint(n_inf/2.)
       do k=1,nn2
          mat2(j,k)=0.5*(prov(nn_1+paren(j,1),nn+k)+prov(paren(j,2),nn+k))
       enddo
    enddo
    do j=nint(n_inf/2.)+1,nint(nn/2.)
       do k=1,nn2
          mat2(j,k)=0.5*(prov(paren(j,1),nn+k)+prov(paren(j,2),nn+k))
       enddo
    enddo
    do j=nint(nn/2.)+1,nint(nn/2.)+nint(n_inf/2.)
       do k=1,nn2
          mat2(j,k)=0.5*(prov(nn_1+paren(j,1),nn+k)+prov(paren(j,2),nn+k))
       enddo
    enddo
    do j=nint(nn/2.)+nint(n_inf/2.)+1,nn
       do k=1,nn2
          mat2(j,k)=0.5*(prov(paren(j,1),nn+k)+prov(paren(j,2),nn+k))
       enddo
    enddo

    ! Population 2
    do j=1,nn2
       do k=1,nn2
          mat3(j,k)=0.5*(prov(nn_1+paren2(k,1),nn+j)+prov(nn_1+paren2(k,2),nn+j))
          mat(k,j)=mat(j,k)
       enddo
    enddo

    do j=1,nn
       mat(j,j)=diag(j)
    enddo

    do j=1,nn2
       mat3(j,j)=diag(nn+j)
    enddo

    deallocate(diag,prov,stoc)

  end subroutine nrm_2pop_inf


  subroutine nrm_2pop_end(paren,paren2,nn,nn2,nn_1,nn2_1,mat,mat2,mat3,her)
    implicit none
    integer :: nn, nn2, nn_1, nn2_1
    ! init=0 for the 1st population, maxval(n(:,1)) else
    integer, dimension (:) :: her
    integer, dimension (:,:) :: paren, paren2
    real(r8), allocatable, dimension (:) :: diag
    real(r8), allocatable, dimension (:,:) :: prov, stoc
    real(r8), dimension (:,:),intent(inout) :: mat, mat2, mat3

    allocate(diag(nn+nn2))
    diag=0
    ! First save the existing coefficients
    allocate(stoc(max(nn_1,2*nn2_1),nn_1+2*nn2_1))
    stoc(1:nn_1,1:nn_1)=mat(1:nn_1,1:nn_1)
    stoc(1:nn_1,nn_1+1:nn_1+nn2_1)=mat2(1:nn_1,1:nn2_1)
    stoc(1:nn2_1,nn_1+nn2_1+1:nn_1+2*nn2_1)=mat3(1:nn2_1,1:nn2_1)

    ! Diagonal for the new individuals of the 1st population
    do j=1,nn
       if(her(j)==2) then
          ! Admixed individuals: the 1st parent comes from the 2nd population
          diag(j)=1+(stoc(paren(j,2),nn_1+paren(j,1))/2)
       else
          diag(j)=1+(stoc(paren(j,1),paren(j,2))/2)
       endif
    enddo

    ! Diagonal for the new individuals of the 2nd population
    do j=1,nn2
       diag(nn+j)=1+0.5*(stoc(paren2(j,1),nn_1+nn2_1+paren2(j,2)))
    enddo

    ! Old individuals of the 1st population
    allocate(prov(nn_1+nn2_1,nn+nn2))
    prov=0
    do j=1,nn_1
       do k=1,nn
          if(her(j)==2) then
             ! 1/ With the new individuals of the 1st population
             ! 1a/ Admixed individuals
             prov(j,k)=0.5*(stoc(j,nn_1+paren(k,1))+stoc(j,paren(k,2)))
          else
             prov(j,k)=0.5*(stoc(j,paren(k,1))+stoc(j,paren(k,2)))
          endif
       enddo

       ! 2/ With the new individuals of the 2nd population 
       do k=1,nn2
          prov(j,nn+k)=0.5*(stoc(j,nn_1+paren2(k,1))+stoc(j,nn_1+paren2(k,2)))
       enddo
    enddo

    ! Old individuals of the 2nd population
    do j=1,nn2_1
       ! 1/ With the new individuals of the 1st population
       ! 1a/ Admixed individuals
       do k=1,nn
          if(her(j)==2) then
             prov(nn_1+j,k)=0.5*(stoc(j,nn_1+nn2_1+paren(k,1))+stoc(paren(k,2),nn_1+j))
          else
             prov(nn_1+j,k)=0.5*(stoc(paren(k,1),nn_1+j)+stoc(paren(k,2),nn_1+j))
          endif
       enddo

       ! 2/ With the new individuals of the 2nd population 
       do k=1,nn2
          prov(nn_1+j,nn+k)=0.5*(stoc(j,nn_1+nn2_1+paren2(k,1))+stoc(j,nn_1+nn2_1+paren2(k,2)))
       enddo
    enddo

    mat=0
    mat2=0
    mat3=0

    ! New individuals among them
    ! Population 1
    do j=1,nn
       do k=1,nn
          if(her(j)==2) then
             mat(j,k)=0.5*(prov(nn_1+paren(j,1),k)+prov(paren(j,2),k))
             mat(k,j)=mat(j,k)
          else
!!$print*,parent(j,1),paren(j,2)
             mat(j,k)=0.5*(prov(paren(j,1),k)+prov(paren(j,2),k))
             mat(k,j)=mat(j,k)
          endif
       enddo
    enddo

    ! Population 1 with population 2
    do j=1,nn
       do k=1,nn2
          if(her(j)==2) then
             mat2(j,k)=0.5*(prov(nn_1+paren(j,1),nn+k)+prov(paren(j,2),nn+k))
          else
             mat2(j,k)=0.5*(prov(paren(j,1),nn+k)+prov(paren(j,2),nn+k))
          endif
       enddo
    enddo

    ! Population 2
    do j=1,nn2
       do k=1,nn2
          mat3(j,k)=0.5*(prov(nn_1+paren2(k,1),nn+j)+prov(nn_1+paren2(k,2),nn+j))
          mat(k,j)=mat(j,k)
       enddo
    enddo

    do j=1,nn
       mat(j,j)=diag(j)
    enddo

    do j=1,nn2
       mat3(j,j)=diag(nn+j)
    enddo
    deallocate(diag,prov,stoc)

  end subroutine nrm_2pop_end


  !********* Subroutines for a real pedigree - S.Teyssèdre
  subroutine affiche(tab,p,q) !Affiche un tableau p lignes, q colonnes
    implicit none
    integer :: p,q
    integer, dimension(p,q) :: tab
    do i=1,p
       print '(1x,16i5)',tab(i,:)
    enddo
  end subroutine affiche

  subroutine affiche_r(tab,p,q) !Affiche un tableau de réels p lignes, q colonnes
    implicit none
    integer :: p,q
    real(r8), dimension(p,q) :: tab
    do i=1,p
       print '(2x,5F8.4)',tab(i,:)
       !200 format(q(2x,F8.4))
    enddo
  end subroutine affiche_r

  subroutine pheno_ped(ind,ef_qtl,val_polyg,men,envi,nq,valnew,perfnew,nrm,alq,gen,e_dom,pos_as,&
       par1,par2,e) !Affiche un tableau p lignes, q colonnes
    implicit none
    integer :: ind,j,nq, par1, par2,e
    integer, dimension(:,:) :: gen, pos_as
    real(r8) :: valqtl, valnew, perfnew, men, envi, mendel, env, m_inbr, pol, epis
    real(r8) :: ef_qtl(:,:), val_polyg(:), e_dom(:), alq(:,:), nrm(:,:)
    !real(r8), allocatable :: ef_qtl(:,:), val_polyg(:)
    !print*,'Val_polyg=',val_polyg
!!$    print*,ind,par1,par2,shape(nrm)
    m_inbr=(2-(nrm(par1,par1)-1)-(nrm(par2,par2)-1))/4
    pol=sqrt(m_inbr*men)
    mendel=G05DDF(0.d0,pol)
    env=G05DDF(0.d0,envi)
    valqtl=0
    epis=0
    do j=1,nq
       if(pos_as(j,3)/=0) then
          if(pos_as(j,1)<pos_as(j,4)) then
             if(pos_assoc(j,6)==1) then
                epis=epis+(ef_qtl((2*ind-1),j)+ef_qtl((2*ind),j))*&
                     (ef_qtl((2*ind-1),pos_as(j,3))+ef_qtl((2*ind),pos_as(j,3)))
             else
                test=.false.
                if(ef_qtl((2*ind-1),j)==maxval(alq(j,:))) test=.true.
                if(ef_qtl((2*ind),j)==maxval(alq(j,:))) test=.true.
                if (test) epis=epis+ ef_qtl((2*ind-1),pos_as(j,3))+ef_qtl((2*ind),pos_as(j,3))
             endif
          endif
       else
          valqtl=valqtl+ef_qtl((2*ind)-1,j)+ef_qtl((2*ind),j)
          if(gen(2*e-1,pos_as(j,1))/=gen(2*e,pos_as(j,1))) epis=epis+e_dom(j)
       endif
    enddo
    valnew=0.5*(val_polyg(1)+val_polyg(2))+mendel
    perfnew=valnew+env+valqtl+epis
  end subroutine pheno_ped

  subroutine transm1(tab,tab2,tab3,tab4)  ! transmission of the haplotypes & recombination
    implicit none
    integer :: k,l
    integer :: tab(:,:),tab2(:,:),tab3(:,:),tab4(:,:)
    ! ALLELE D'ORIGINE 1
    l=G05DYF(1,2)   ! gamete 1 ou 2
    !print*,'Haplotype paternel reçu par le nouvel individu=',l
    tab2(1,1)=tab(l,1)
    tab4(1,1)=tab3(l,1)
    do k=2,nmq+nqtl
       r=G05CAF(r)
       if(r<reco(k-1)) l=3-l
       tab2(1,k)=tab(l,k)
       tab4(1,k)=tab3(l,k)
    enddo
    ! ALLELE D'ORIGINE 2
    l=G05DYF(1,2)   ! gamete 1 ou 2
    !print*,'Haplotype maternel reçu par le nouvel individu=',l
    tab2(2,1)=tab(2+l,1)
    tab4(2,1)=tab3(2+l,1)
    do k=2,nmq+nqtl
       r=G05CAF(r)
       if(r<reco(k-1)) l=3-l
       tab2(2,k)=tab(2+l,k)
       tab4(2,k)=tab3(2+l,k)
    enddo
  end subroutine transm1

  subroutine transm1_noCop(tab,tab2)  ! transmission of the haplotypes & recombination
    implicit none
    integer :: k,l
    integer :: tab(:,:),tab2(:,:)
    ! ALLELE D'ORIGINE 1
    l=G05DYF(1,2)   ! gamete 1 ou 2
    !print*,'Haplotype paternel reçu par le nouvel individu=',l
    tab2(1,1)=tab(l,1)
    do k=2,nmq+nqtl
       r=G05CAF(r)
       if(r<reco(k-1)) l=3-l
       tab2(1,k)=tab(l,k)
    enddo
    ! ALLELE D'ORIGINE 2
    l=G05DYF(1,2)   ! gamete 1 ou 2
    !print*,'Haplotype maternel reçu par le nouvel individu=',l
    tab2(2,1)=tab(2+l,1)
    do k=2,nmq+nqtl
       r=G05CAF(r)
       if(r<reco(k-1)) l=3-l
       tab2(2,k)=tab(2+l,k)
    enddo
  end subroutine transm1_noCop

  subroutine genot_err(c,d,tab,tab2,errSNP,errMST,miss_geno)
    implicit none
    integer :: c,d,j,k,ii,value,value2
    !    integer,allocatable :: tab(:,:,:),tab2(:,:,:),tab3(:,:,:),tab4(:,:,:)
    integer :: tab(:,:,:),tab2(:,:,:)
    integer, allocatable, dimension(:):: ind_mut, chr_mut, rk
    integer, allocatable, dimension(:,:)::  ver
    real(r8)::errSNP, errMST, miss_geno
    logical:: test
    value=0
    value2=0
    tab2(:,c:d,:)=tab(:,c:d,:)
    do j=1,nmq+nqtl
       if(indic(j)==1) then
          value=value+1
          value2=nmq+value
       else
          value2=j-value
       endif
       if(j==1) then
          test=.true.
       else
          test=.false.
       endif
       if(typ(value2)==1) then 
          i=G01BJC2(2*(d-c+1),errSNP,test)
       else
          i=G01BJC2(2*(d-c+1),errMST,test)
       endif
       if(i>0) then
          allocate(ind_mut(i),chr_mut(i))
          call G05DYF2(c,d,i,ind_mut)
          call G05DYF2(1,2,i,chr_mut)
          allocate(ver(i,1))
          ver(:,1)=2*(ind_mut(:)-1)+chr_mut(:)
          do k=1,i
             do while (count(any(ver.eq.ver(k,1),1))>1) 
                ind_mut(k)=G05DYF(c,d)
                chr_mut(k)=G05DYF(1,2)
                ver(k,1)=2*(ind_mut(k)-1)+chr_mut(k)
             enddo
          enddo
          allocate(rk(i))
          call search_best(dble(ind_mut),i,rk,i)
          do k=1,i
             write(78,*) j,ind_mut(rk(k)),chr_mut(rk(k)),&
                  tab(j,ind_mut(rk(k)),chr_mut(rk(k)))
          enddo
          deallocate(rk)
          if(typ(value2)==1) then
             do k=1,i
                if(tab(j,ind_mut(k),chr_mut(k))==1) then
                   tab2(j,ind_mut(k),chr_mut(k))=tab(j,ind_mut(k),chr_mut(k))+1
                else if(tab(j,ind_mut(k),chr_mut(k))==2) then
                   tab2(j,ind_mut(k),chr_mut(k))=tab(j,ind_mut(k),chr_mut(k))-1
                endif
             enddo
          else 
             do k=1,i
                if(tab(j,ind_mut(k),chr_mut(k))==1) then
                   tab2(j,ind_mut(k),chr_mut(k))=tab(j,ind_mut(k),chr_mut(k))+1
                else if(tab(j,ind_mut(k),chr_mut(k))==maxval(nball(j,:))) then
                   tab2(j,ind_mut(k),chr_mut(k))=tab(j,ind_mut(k),chr_mut(k))-1
                else
                   ii=G05DYF(1,2)
                   if(ii==1) then
                      tab2(j,ind_mut(k),chr_mut(k))=tab(j,ind_mut(k),chr_mut(k))+1
                   else
                      tab2(j,ind_mut(k),chr_mut(k))=tab(j,ind_mut(k),chr_mut(k))-1
                   endif
                endif
             enddo
          endif
          deallocate(ver,ind_mut,chr_mut)
       endif

       ! Missing genotypes
       i=G01BJC2(2*(d-c+1),miss_geno,test)
!!$       print*,'NB MISSING',i
       if(i>0) then
          allocate(ind_mut(i))
          call G05DYF2(c,d,i,ind_mut)
          allocate(ver(i,1))
          ver(:,1)=2*(ind_mut(:)-1)
          do k=1,i
             do while (count(any(ver.eq.ver(k,1),1))>1) 
                ind_mut(k)=G05DYF(c,d)
                ver(k,1)=2*(ind_mut(k)-1)
             enddo
          enddo
          allocate(rk(i))
          call search_best(dble(ind_mut),i,rk,i)
          do k=1,i
             tab2(j,ind_mut(rk(k)),:)=0
          enddo
          deallocate(rk,ind_mut,ver)
       endif
    enddo
  end subroutine genot_err


  subroutine given_accur(gin,accurm,accurf,per_tmp,pop,nm,nn,tab,pos_a,nq,eff_qt,posqt)
    implicit none
    integer:: pop, nm, nn, nq, tab(:,:,:), pos_a(:,:),posqt(:), i, j
    real(r8), allocatable, dimension(:):: BV
    real(r8), intent(in):: gin(:,:),accurm, accurf,eff_qt(:,:)
    real(r8):: per_tmp(:), poly, va, env

    allocate(BV(nn))
    BV=0.
    do i=1,nn
       do j=1,nq
          if(pos_a(j,3)==0) then
             BV(i)=BV(i)+sum(eff_qt(j,tab(posqt(j),i,:)))
          endif
       enddo
       BV(i)=BV(i)+gin(i,pop)
    enddo
    poly=sum(BV(1:nm)**2)/real(nm)-(sum(BV(1:nm))/real(nm))**2
    va=sqrt(poly*(1-accurm**2)/(accurm**2))
    do i=1,nm
       env=G05DDF(0.d0,va)
       per_tmp(i)=BV(i)+env
    enddo

    poly=sum(BV(1+nm:nn)**2)/real(nn-nm)-(sum(BV(1+nm:nn))/real(nn-nm))**2
    va=sqrt(poly*(1-accurf**2)/(accurf**2))
    do i=nm+1,nn
       env=G05DDF(0.d0,va)
       per_tmp(i)=BV(i)+env
    enddo
  end subroutine given_accur


  subroutine recode(nInd,ped,corresp)
    implicit none
    integer:: i, nInd
    integer, dimension(:,:):: corresp, ped
    ! To find the right row (or colomn) when computing the nrm with a pedigree provided by the user
    corresp=0
    do i=1,nInd
       corresp(i,1)=i
       corresp(i,2)=ped(i,1)
    enddo
    do i=1,nInd
       do j=1,nInd
          ! Recoded sire in col. 3
          if(ped(i,2)==ped(j,1)) corresp(i,3)=corresp(j,1)
          ! Recoded dam in col. 4
          if(ped(i,3)==ped(j,1)) corresp(i,4)=corresp(j,1)
       enddo
    enddo
  end subroutine recode

subroutine variances(pop,nq,ef_qt,ef_do,envi,poly,pos_as,al,nm,fqa,fqa2,nba,her,rat_pQ,indi)
    implicit none
    integer :: i, pop, nq, nm
    integer, dimension(:) :: indi
    integer, dimension(:,:) :: pos_as, nba
    integer, dimension(:,:,:) :: al
    real(r8) :: envi, poly, env
    real(r8) :: valqtl, epis
    real(r8), dimension(:) :: ef_do, her, rat_pQ
    real(r8), dimension(:,:) :: ef_qt, fqa, fqa2
    real(r8), dimension(:,:), allocatable  :: var

    allocate(var(nq+1,4))
    var=0
    i=0
    do l=1,nq+nm
       if(indi(l)==1) then
          i=i+1
          if (pos_as(i,7)==0) then 
             ! purely additive effect
             if(maxval(nba(l,:))==2) then
                var(i,1)= 2*fqa(l,1)*(1-fqa(l,1))*((2*ef_qt(i,1))**2)
             else
                valqtl=0
                epis=0
                do j=1,maxval(nba(l,:))
                   if(fqa(l,j)/=0) then
                      valqtl=valqtl+fqa(l,j)*(2*ef_qt(i,j))**2
                      epis=epis+(fqa(l,j)*(2*ef_qt(i,j)))**2
                   endif
                enddo
                var(i,1)=valqtl-epis
             endif
          else
             ! If dominance effects are present at the locus
             print*,'BE CARREFUL: DOMINANCE EFFECTS AND VARIANCES ARE ONLY ACCOUNTED FOR IF THE QTL HAS ONLY 2 ALLELES'
             var(i,1)= 2*fqa(i,1)*(1-fqa(i,1))*(((2*ef_qt(i,1))+ef_do(i)*(1-2*fqa(i,1)))**2)      
          endif
          var(i,3)=(2*fqa(i,1)*(1-fqa(i,1))*ef_do(i))**2 ! Dominance variance
          if(pos_as(i,3)/=0) then
             print*,'BE CARREFUL: EPISTATIC EFFECTS AND VARIANCES ARE ONLY ACCOUNTED FOR IF THE QTL HAS ONLY 2 ALLELES'
             if(pos_as(i,6)==1) then
                var(i,2)=((4*ef_qt(i,1)*ef_qt(pos_as(i,3),1))**2)*&
                     (fqa2(i,1)+fqa2(i,2)-(fqa2(i,1)-fqa2(i,2))**2)
             else
                var(i,2)=((2*ef_qt(pos_as(i,3),1))**2)*(((fqa2(i,1)+fqa2(i,2)))-&
                     (fqa2(i,1)-fqa2(i,2))**2)
             endif
          endif
       endif
    enddo
    do i=1,nq
       if(pos_as(i,3)/=0.and.min(pos_as(i,1),pos_as(i,4))==pos_as(i,1)) then
          var(nq+1,2)=var(nq+1,2)+var(i,2) !interaction
       else
          if(pos_as(i,3)==0) then
             var(nq+1,1)=var(nq+1,1)+var(i,1) ! Only purely additive QTL
             var(nq+1,3)=var(nq+1,3)+var(i,3) ! Dominance variance
          endif
       endif
    enddo
    envir=sqrt((var(nq+1,1)*(1+rat_pQ(pop))-her(pop)*(var(nq+1,3)+var(nq+1,2)+var(nq+1,1)*(1+rat_pQ(pop))))/her(pop))
    poly=sqrt(var(nq+1,1)*rat_pQ(pop))
  end subroutine variances


  ! calcul du tx de recomb en fonction de la distance
  function fdinv(d)
    real(r8) fdinv,d
    fdinv=0.5d0*(1.-exp(-2.d0*d))   !! haldane inverse
    !      fdinv=0.5d0*(exp(4.d0*d)-1.)/(exp(4.d0*d)+1.d0) !! kosambi inverse
    return
  end function fdinv

end program simulateur
