INCLUDE 'random.f90'
INCLUDE 'eig3.f90'

Program NewGen
USE random
use eig_m

IMPLICIT NONE

INTEGER :: i, j, k, l, m, n, io
INTEGER :: seed, iseed
INTEGER :: nSires, nSires_in, nDams, nDams_In
INTEGER :: nSires_sel, nDams_sel
INTEGER :: Dam_per_Sire, Sire_per_Dam
INTEGER :: noff, noff_male, noff_female
INTEGER :: nLoci, nChr, nSNP, nQTL
INTEGER :: teller, CO_teller
INTEGER :: Chr, ID, Indicator, Chr_dummy
INTEGER :: ID1, ID2
INTEGER :: NrMating_Dams, NrMating_Sires, NrMating
INTEGER :: StartID
INTEGER :: nCrossover, patmat
INTEGER :: tel_SNP, tel_QTL
INTEGER :: ntraits
INTEGER :: Sire, Dam
INTEGER :: temp2, tel
INTEGER :: teller1, teller2, teller3, teller4
INTEGER :: nTOP_Sires, nTOP_Dams

INTEGER, ALLOCATABLE, DIMENSION (:) :: firstSNP_chr, Chr_length
INTEGER, ALLOCATABLE, DIMENSION (:) :: ID_Sires, ID_Dams, ID_offspring
INTEGER, ALLOCATABLE, DIMENSION (:) :: ID_Sel_Sires, ID_Sel_Dams
INTEGER, ALLOCATABLE, DIMENSION (:) :: Dams_sel, Sires_sel
INTEGER, ALLOCATABLE, DIMENSION (:) :: Dams_mating_perm, Dams_mating, Sires_mating_perm, Sires_mating
INTEGER, ALLOCATABLE, DIMENSION (:,:,:) :: Sires, Dams, Genotype_Male_offspring, Genotype_Female_offspring, QTL_offspring
INTEGER, ALLOCATABLE, DIMENSION (:) :: SNP_sel, QTL_sel
INTEGER, ALLOCATABLE, DIMENSION (:,:) :: Pedigree_File

REAL :: position
REAL :: dummy, dummy2
REAL :: RAN2
REAL :: temp
REAL :: EBV
REAL :: r_1, r_2, r_3
REAL :: Sum_TBV, Sum_E, Sum_Phen
REAL :: var
REAL :: AFreq, AFreq2
REAL(KIND=8) :: gasdev

REAL, ALLOCATABLE, DIMENSION (:) :: Pos_Crossover
REAL, ALLOCATABLE, DIMENSION (:) :: Rvalues
REAL, ALLOCATABLE, DIMENSION (:) :: Loci_LineA, temp_Poly
REAL, ALLOCATABLE, DIMENSION (:) :: Poly_Sire, Loci_PGD
REAL, ALLOCATABLE, DIMENSION (:) :: QTL_AFreq
REAL, ALLOCATABLE, DIMENSION (:) :: Phen_Missing

REAL, ALLOCATABLE, DIMENSION (:,:) :: Loci_Map
REAL, ALLOCATABLE, DIMENSION (:,:) :: Effect, VarComp, PrevGen
REAL, ALLOCATABLE, DIMENSION (:,:) :: TBV,TBV_test, Env, Phen
REAL, ALLOCATABLE, DIMENSION (:,:) :: Polygenic_TBV_Dam, Polygenic_TBV_Sire, TBV_Old
REAL, ALLOCATABLE, DIMENSION (:,:) :: Chol_COR11, Chol_COR12, Chol_COR21, Chol_COR22, Chol_COR31, Chol_COR32
REAL, ALLOCATABLE, DIMENSION (:,:) :: CorMatrix1, CorMatrix2, CorMatrix3
REAL, ALLOCATABLE, DIMENSION (:,:) :: Alleles_Common, Var_Poly_Sire, Chol_Matrix, Poly_Sire_Temp
REAL, ALLOCATABLE, DIMENSION (:,:) :: CovMat, CovMat_Bend, CovMatrix_BOA

CHARACTER(len=100) :: Mapfile, GenoSires_File, GenoDams_File, GenoMale_Off_File, GenoFemale_Off_File, Ped_File, Geno_SNP_Off_File
CHARACTER(len=100) :: QTLEffects_File, Phenotype_File, VarComp_File, TBV_File, Statistics_File, SelCan_File
CHARACTER(len=100) :: Info_PrevousGen_File, TBV_PreviousGen_File, PolyTBV_Dam_File, PolyTBV_Sire_File, Proportion_FILE
CHARACTER(len=15) :: Name, MethodSel_Sires, SelProp_Sires, MethodSel_Dams, SelProp_Dams
CHARACTER(len=15) :: TypeNextGen, TypeCB
CHARACTER(len=8) :: Sex
CHARACTER(len=10) :: Title

LOGICAL, ALLOCATABLE, DIMENSION(:) :: Dam_sel_log, Sire_sel_log

!!!!-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
!!!! Start program
r_1 = 0
r_2 = 0
r_3 = 0

!!!! Input for the program
OPEN(UNIT=11, FILE='NextGeneration.inp',ACTION='READ', STATUS='OLD')
READ(11,*) TypeNextGen
IF (TypeNextGen == "Crossbred") then
	REWIND(11)
	READ(11,*) TypeNextGen, TypeCB
END IF
READ(11,*) Title
READ(11,*) Mapfile
READ(11,*) nSires_in, GenoSires_File
IF ((TypeNextGen == "Nucleus") .OR. (TypeNextGen == "Multiplication")) then
	READ(11,*) nDams_In, GenoDams_File
ELSE
	READ(11,*) 
	nDams_In = 0
END IF
READ(11,*) nSires_sel, MethodSel_Sires
	IF (MethodSel_Sires == 'MiXBLUP') then
	REWIND(11)
	DO i = 1, 5
		READ(11,*) 
	END DO
	READ(11,*) nSires_sel, MethodSel_Sires, SelProp_Sires, nTOP_Sires
	END IF
READ(11,*) nDams_sel, MethodSel_Dams
 	IF (MethodSel_Dams == 'MiXBLUP') then
	REWIND(11)
	DO i = 1, 6
		READ(11,*) 
	END DO
	READ(11,*) nDams_sel, MethodSel_Dams, SelProp_Dams, nTOP_Dams
	END IF
READ(11,*) Dam_per_Sire, Sire_per_Dam
READ(11,*) noff, noff_male, noff_female
READ(11,*) StartID
READ(11,*) ntraits, QTLEffects_File, VarComp_File
IF (TypeNextGen == "Crossbred") then
	IF(ntraits == 2) then
		READ(11,*) r_1
	ELSE IF (ntraits == 3) then
		READ(11,*) r_1, r_2
	ELSE IF (ntraits == 4) then
		READ (11,*) r_1, r_2, r_3
	ELSE
		WRITE(*,*) 'Number of traits is ', ntraits, ' which is exceeding the maximum number of traits of 4 '
	END IF
	READ(11,*) Info_PrevousGen_File
	IF (TypeCB == "4-way") then
		READ(11,*) TBV_PreviousGen_File
	END IF
END IF
CLOSE(11)

IF (TypeNextGen == "Crossbred") then
	IF (TypeCB == "4-way") then
		MethodSel_Sires = 'RANDOM'
		MethodSel_Dams = 'RANDOM'
	END IF
END IF


IF (TypeNextGen == "Nucleus") then
	GenoMale_Off_File = 'NP_' // trim(Title) // '_Genotypes_Males.txt'
	GenoFemale_Off_File = 'NP_' // trim(Title) // '_Genotypes_Females.txt'
	Geno_SNP_Off_File = 'NP_' // trim(Title) // '_Genotypes_SNPs.txt'
	Ped_File = 'NP_' // trim(Title) // '_Pedigree.txt'
	Phenotype_File = 'NP_' // trim(Title) // '_Phenotypes.txt'
	Statistics_File = 'NP_' // trim(Title) // '_GeneralStatistics.txt'
	SelCan_File = 'NP_' // trim(Title) // '_Phen_SelectionCandidates.txt' 
ELSE IF (TypeNextGen == "Multiplication") then
	GenoMale_Off_File = 'MP_' // trim(Title) // '_Genotypes_Males.txt'
	GenoFemale_Off_File = 'MP_' // trim(Title) // '_Genotypes_Females.txt'
	Geno_SNP_Off_File = 'MP_' // trim(Title) // '_Genotypes_SNPs.txt'
	Ped_File = 'MP_' // trim(Title) // '_Pedigree.txt'
	Phenotype_File = 'MP_' // trim(Title) // '_Phenotypes.txt'
	Statistics_File = 'MP_' // trim(Title) // '_GeneralStatistics.txt'
	SelCan_File = 'MP_' // trim(Title) // '_Phen_SelectionCandidates.txt' 
ELSE IF(TypeNextGen == "Crossbred") then
	IF (TypeCB == "2-way") then
		GenoMale_Off_File = '2wayCB_' // trim(Title) // '_Genotypes_Males.txt'
		GenoFemale_Off_File = '2wayCB_' // trim(Title) // '_Genotypes_Females.txt'
		Geno_SNP_Off_File = '2wayCB_' // trim(Title) // '_Genotypes_SNPs.txt'
		Ped_File = '2wayCB_' // trim(Title) // '_Pedigree.txt'
		Phenotype_File = '2wayCB_' // trim(Title) // '_Phenotypes.txt'
		Statistics_File = '2wayCB_' // trim(Title) // '_GeneralStatistics.txt'
		SelCan_File = '2wayCB_' // trim(Title) // '_Phen_SelectionCandidates.txt' 
	ELSE IF (TypeCB == "4-way") then
		GenoMale_Off_File = '4wayCB_' // trim(Title) // '_Genotypes_Males.txt'
		GenoFemale_Off_File = '4wayCB_' // trim(Title) // '_Genotypes_Females.txt'
		Geno_SNP_Off_File = '4wayCB_' // trim(Title) // '_Genotypes_SNPs.txt'
		Ped_File = '4wayCB_' // trim(Title) // '_Pedigree.txt'
		Phenotype_File = '4wayCB_' // trim(Title) // '_Phenotypes.txt'
		Statistics_File = '4wayCB_' // trim(Title) // '_GeneralStatistics.txt'
		SelCan_File = '4wayCB_' // trim(Title) // '_Phen_SelectionCandidates.txt' 
	END IF
END IF


!!!! Read in Seed
OPEN(UNIT=1, FILE='Seed_NextGen.dat', STATUS='OLD')
READ(1,*) seed
CLOSE(1)
iseed = -seed

!!!! Read Map file
OPEN(UNIT=12, FILE=Mapfile, ACTION='READ', STATUS='OLD')
nLoci = 0
nChr = 0
Chr_dummy = 0
DO 
	READ(12,*,iostat=io) dummy, Name, Chr, position, ID, AFreq, AFreq2, Indicator
	IF(io/=0) EXIT
	nLoci = nLoci + 1
	IF(Chr/=Chr_dummy) then
		nChr = nChr + 1
		Chr_dummy = Chr
	END IF
END DO
REWIND(12)

ALLOCATE(Loci_Map(nLoci, 3))
ALLOCATE(QTL_AFreq(nLoci))
nSNP = 0
nQTL = 0
ALLOCATE(firstSNP_chr(nChr+1))
firstSNP_chr = 0
Chr_dummy = 0
ALLOCATE(Chr_length(nChr))
Chr_length = 0

DO i = 1, nLoci
	READ(12,*,iostat=io) dummy, Name, Chr, position, ID, AFreq, AFreq2, Indicator
	Loci_Map(i,1) = Chr
	Loci_Map(i,2) = position
	Loci_Map(i,3) = Indicator
	IF (Indicator == 0) then
		nSNP = nSNP + 1
	ELSE IF (Indicator == 1) then
		nQTL = nQTL + 1
		QTL_AFreq(nQTL) = AFreq
	END IF
	Chr_length(Chr) = ceiling(position)
	IF (Chr /= Chr_dummy) then
		firstSNP_chr(Chr) = i
		Chr_dummy = Chr
	END IF
	firstSNP_chr(nChr+1) = i + 1
END DO
CLOSE(12)

ALLOCATE(SNP_sel(nSNP))
ALLOCATE(QTL_sel(nQTL))
tel_SNP = 0
tel_QTL = 0

DO i = 1, nLoci
	IF(Loci_Map(i,3) == 1) then
		tel_QTL = tel_QTL + 1
		QTL_sel(tel_QTL) = i
	ELSE IF (Loci_Map(i,3) == 0) then
		tel_SNP = tel_SNP + 1
		SNP_sel(tel_SNP) = i
	END IF
END DO

WRITE(*,*) '************************************************************************'
WRITE(*,*) 'The number of loci in the Mapfile is ', nLoci, ' those loci are spread over ', 	nChr, ' chromosome'
DO i = 1, nChr
	WRITE(*,*) 'Chromosome ', i, ' contains ', firstSNP_chr(i+1) - firstSNP_chr(i), ' loci and has a length of ', Chr_length(i), ' cM' 
END DO
WRITE(*,*) 'Of those loci, ', nQTL, ' loci are selected as QTL and ', nSNP, ' are selected as SNP'

!!!!! Investigate if all animals are needed for mating structure 
WRITE(*,*) '************************************************************************'
WRITE(*,*) 'Investigate if all animals are needed for mating structure ' 

NrMating_Dams = nDams_sel * Sire_per_Dam
NrMating_Sires = nSires_sel * Dam_per_Sire

IF (NrMating_Dams == NrMating_Sires) then
	NrMating = NrMating_Dams
	WRITE(*,*) 'The number of matings is ', NrMating
	nDams = nrMating_Sires / Sire_per_Dam
	nSires = nrMating_Sires / Dam_per_Sire
	WRITE(*,*) nSires, ' sires will be mated ', NrMating/nSires, ' times'
	WRITE(*,*) nDams, ' dams will be mated ', NrMating/nDams, ' times'
ELSE IF (NrMating_Dams > NrMating_Sires) then
	NrMating = nrMating_Sires
	WRITE(*,*) 'The number of matings is ',  NrMating
	nDams = nrMating_Sires / Sire_per_Dam
	nSires = nrMating_Sires / Dam_per_Sire
	WRITE(*,*) nSires, ' sires will be mated ', NrMating/nSires, ' times'
	WRITE(*,*) nDams, ' dams will be mated ', NrMating/nDams, ' times'
ELSE IF (NrMating_Dams < NrMating_Sires) then
	NrMating = NrMating_Dams
	WRITE(*,*) 'The number of matings is ',  NrMating
	nDams = nrMating_Sires / Sire_per_Dam
	nSires = nrMating_Sires / Dam_per_Sire
	WRITE(*,*) nSires, ' sires will be mated ', NrMating/nSires, ' times'
	WRITE(*,*) nDams, ' dams will be mated ', NrMating/nDams, ' times'
END IF

!!!!! Check if animals have to be selected to have enough sires and dams
IF ((nSires_in == nSires) .AND. (nDams_in == nDams)) then
	WRITE(*,*) 'All sires and dams in genotype file can be used to generate next generation'
	ALLOCATE(Dam_sel_log(nDams_In))
	Dam_sel_log = .TRUE.
	ALLOCATE(Sire_sel_log(nSires_in))
	Sire_sel_log = .TRUE.	
ELSE 
	IF (nSires_in == nSires) then
		ALLOCATE(Sire_sel_log(nSires_in))
		Sire_sel_log = .TRUE.	
	ELSE IF (nSires_in > nSires) then
		IF (MethodSel_Sires == 'RANDOM') then
			WRITE(*,*) 'Sires will be selected ', MethodSel_Sires	
			WRITE(*,*) nSires, ' sires will be randomly selected from ', nSires_in, ' in inputfile' 

			ALLOCATE(Sires_sel(nSires_in))
			DO i = 1, nSires_in
				Sires_sel(i) = i
			END DO
			call perm(Sires_sel(1:(nSires_in)),iseed)
	
			ALLOCATE(Sire_sel_log(nSires_in))
			Sire_sel_log = .FALSE.
			DO i = 1, nSires
				Sire_sel_log(Sires_sel(i)) = .TRUE.
			END DO
		ELSE IF (MethodSel_Sires == 'MiXBLUP') then
			WRITE(*,*) nSires, ' sires will be selected from ', nSires_in, ' based on ', MethodSel_Sires
			WRITE(*,*) 'The selected ', nSires, ' sires will be the ', SelProp_Sires, ' sires'
			OPEN(UNIT=41, FILE='EBV_SelCan_Males.txt', ACTION='READ', STATUS='OLD')
			ALLOCATE(ID_Sel_Sires(nSires))
		
			IF (SelProp_Sires == "Top") then
				DO i = 1, nSires
					READ(41,*) ID, EBV
					ID_Sel_Sires(i) = ID
				END DO
				CLOSE(41)
			ELSE IF (SelProp_Sires == "Subtop") then
				DO i = 1, nTop_Sires+nSires
					READ(41,*) ID, EBV
					IF (i>nTop_Sires) then
						ID_Sel_Sires(i-nTop_Sires) = ID
					END IF
				END DO
				CLOSE(41)
			END IF
				
			DO m = 1, nSires-1
				DO n = m+1, nSires
					IF (ID_Sel_Sires(n) < ID_Sel_Sires(m)) then
						temp2 = ID_Sel_Sires(n)
						ID_Sel_Sires(n) = ID_Sel_Sires(m)
						ID_Sel_Sires(m) = temp2
					END IF 
				END DO
			END DO	
			
			ALLOCATE(Sire_sel_log(nSires_in))
			Sire_sel_log = .FALSE.
			OPEN(UNIT=13, FILE=GenoSires_File, ACTION='READ', STATUS='OLD')
			tel = 1
			DO i = 1, nSires_in
				READ(13, *, iostat = io) ID1
				READ(13, *, iostat = io) ID2
				IF (io/=0) then
					WRITE(*,*) 'Number of sires in genotype file is not correct '
					EXIT
				END IF
				IF(ID1 /= ID2) then
					WRITE(*,*) 'ERROR: Genotype file is not in haplotype format!!'
					EXIT	
				ELSE IF (ID1 == ID2) then
					IF(ID_Sel_Sires(tel) == ID1) then
						Sire_sel_log(i) = .TRUE.
						tel = tel + 1
					END IF
				END IF
			END DO
			CLOSE(13)
			WRITE(*,*) tel-1, ' number of sires selected from genotype file '
		ELSE
			WRITE(*,*) 'ERROR: Method for selecting sires is not available'
		END IF
	ELSE
		WRITE(*,*) 'ERROR: Not enough sires in genotype file for breeding program ' 
		WRITE(*,*) nSires_in, '  sires in genotype file; ', nSires, '  sires needed for breeding program' 
	END IF
	
	IF (nDams_in == nDams) then
		ALLOCATE(Dam_sel_log(nDams_In))
		Dam_sel_log = .TRUE.
	ELSE IF (nDams_in < nDams) then
		IF (TypeNextGen == 'Crossbred') then
			WRITE(*,*) 'No genotypes of dams available ' 
			WRITE(*,*) 'Polygenic TBV created for each dam '
			
			OPEN(UNIT=32, FILE=VarComp_File, STATUS='OLD', ACTION='READ')
			ALLOCATE(VarComp(ntraits,2))
			DO i = 1, ntraits
				READ(32,*) VarComp(i,1), VarComp(i,2)
			END DO
			CLOSE(32)
			
			WRITE(*,*) 'Variance components - trait 1'
			WRITE(*,*) VarComp(1,1), VarComp(1,2)
			
			WRITE(*,*) 'Variance components - trait 2'
			WRITE(*,*) VarComp(2,1), VarComp(2,2)
			
			IF (ntraits >2) then
				WRITE(*,*) 'Variance components - trait 3'
				WRITE(*,*) VarComp(3,1), VarComp(3,2)
			END IF
			
			IF (ntraits >3) then
				WRITE(*,*) 'Variance components - trait 4'
				WRITE(*,*) VarComp(4,1), VarComp(4,2)
			END IF
			
			ALLOCATE(CorMatrix1(2,2))
			ALLOCATE(CorMatrix2(2,2))
			ALLOCATE(CorMatrix3(2,2))
			CorMatrix1=r_1
			CorMatrix2=r_2
			CorMatrix3=r_3

			DO i = 1, 2
				CorMatrix1(i,i) = 1
				CorMatrix2(i,i) = 1
				CorMatrix3(i,i) = 1
			END DO
	
			ALLOCATE(Chol_COR11(2,2))
			Chol_COR11 = CORmatrix1
			call Chol(Chol_COR11(1:2, 1:2))
			ALLOCATE(Chol_COR12(2,2))
			Chol_COR12 = 0
			Do i = 1, 2
				DO j = 1, 2
					Chol_COR12(i,j) = Chol_COR11(j,i)
				END DO
			END DO
	
			ALLOCATE(Chol_COR21(2,2))
			Chol_COR21 = CORmatrix2
			call Chol(Chol_COR21(1:2, 1:2))
			ALLOCATE(Chol_COR22(2,2))
			Chol_COR22 = 0
			Do i = 1, 2
				DO j = 1, 2
					Chol_COR22(i,j) = Chol_COR21(j,i)
				END DO
			END DO
	
			ALLOCATE(Chol_COR31(2,2))
			Chol_COR31 = CORmatrix3
			call Chol(Chol_COR31(1:2, 1:2))
			ALLOCATE(Chol_COR32(2,2))
			Chol_COR32 = 0
			Do i = 1, 2
				DO j = 1, 2
					Chol_COR32(i,j) = Chol_COR31(j,i)
				END DO
			END DO
			
			OPEN(UNIT=34, FILE=Info_PrevousGen_File, STATUS='OLD', ACTION='READ')
			ALLOCATE(PrevGen(ntraits, 6))
			ALLOCATE(Polygenic_TBV_Dam(nDams,1+ntraits))
			ALLOCATE(temp_Poly(2))
			
			DO i = 1, ntraits
				READ(34,*) PrevGen(i,1:6)
				Polygenic_TBV_Dam(:,i+1) = PrevGen(i,1)
			END DO
			CLOSE(34)
			
			ALLOCATE(ID_Sel_Dams(nDams))
			ALLOCATE(Rvalues(2))
			DO i = 1, nDams
				ID_Sel_Dams(i) = i
				Polygenic_TBV_Dam(i,1) = i
				Call ggnml(iseed, 2, Rvalues(1:2))
				temp_Poly(1:2) = (matmul(Rvalues(1:2), Chol_COR12))
				Polygenic_TBV_Dam(i,2) = Polygenic_TBV_Dam(i,2) + temp_Poly(1) * sqrt(VarComp(1,1))
				Polygenic_TBV_Dam(i,3) = Polygenic_TBV_Dam(i,3) + temp_Poly(2) * sqrt(VarComp(2,1))
				IF (ntraits>2) then
					temp_Poly(1:2) = matmul(Rvalues(1:2), Chol_COR22)
					Polygenic_TBV_Dam(i,4) = Polygenic_TBV_Dam(i,4) + temp_Poly(2) * sqrt(VarComp(3,1))
				END IF
				IF (ntraits>3) then
					temp_Poly(1:2) = matmul(Rvalues(1:2), Chol_COR32)
					Polygenic_TBV_Dam(i,5) = Polygenic_TBV_Dam(i,5) + temp_Poly(2) * sqrt(VarComp(4,1))
				END IF
			END DO
			DEALLOCATE(VarComp)
			DEALLOCATE(CorMatrix1)
			DEALLOCATE(CorMatrix2)
			DEALLOCATE(CorMatrix3)
			DEALLOCATE(Chol_COR11)
			DEALLOCATE(Chol_COR12)
			DEALLOCATE(Chol_COR21)
			DEALLOCATE(Chol_COR22)
			DEALLOCATE(Chol_COR31)
			DEALLOCATE(Chol_COR32)
			
			IF (TypeCB == "2-way") then 
				PolyTBV_Dam_File = '2wayCB_' // trim(Title) // '_PolyTBV_Dams.txt'
			ELSE IF (TypeCB == "4-way") then 
				PolyTBV_Dam_File = '4wayCB_' // trim(Title) // '_PolyTBV_Dams.txt'
			END IF			
			
			OPEN(UNIT=33, FILE=PolyTBV_Dam_File, STATUS='UNKNOWN', ACTION='WRITE')
			DO i = 1, nDams
				WRITE(33,*) Polygenic_TBV_Dam(i,1:(ntraits+1))
			END DO
			CLOSE(33)
		ELSE
			WRITE(*,*) 'ERROR: Not enough dams in genotype file for breeding program ' 
			WRITE(*,*) nDams_in, '  dams in genotype file; ', nDams, '  dams needed for breeding program' 
		END IF
	ELSE IF (nDams_in > nDams) then
		IF (MethodSel_Dams == 'RANDOM') then
			WRITE(*,*) 'Dams will be selected ', MethodSel_Dams	
			WRITE(*,*) nDams, ' dams will be randomly selected from ', nDams_in, ' in inputfile' 
		
			IF ((TypeNextGen == 'Nucleus') .OR. (TypeNextGen == 'Multiplication')) then
				WRITE(*,*) nDams, ' dams will be randomly selected from ', nDams_In, ' in inputfile' 
				ALLOCATE(Dams_sel(nDams_In))
				DO i = 1, nDams_In
					Dams_sel(i) = i
				END DO
				call perm(Dams_sel(1:(nDams_In)),iseed)
		
				ALLOCATE(Dam_sel_log(nDams_In))
				Dam_sel_log = .FALSE.
				DO i = 1, nDams
					Dam_sel_log(Dams_sel(i)) = .TRUE.
				END DO
			END IF
		ELSE IF (MethodSel_Dams == 'MiXBLUP') then
			WRITE(*,*) nDams, ' dams will be selected from ', nDams_in, ' based on ', MethodSel_Dams
			WRITE(*,*) 'The selected ', nDams, ' sires will be the ', SelProp_Dams, ' sires'
					
			IF (SelProp_Dams == "Top") then
				OPEN(UNIT=42, FILE='EBV_SelCan_Females.txt', ACTION='READ', STATUS='OLD')
				ALLOCATE(ID_Sel_Dams(nDams))
				DO i = 1, nDams
					READ(42,*) ID, EBV
					ID_Sel_Dams(i) = ID
				END DO
				CLOSE(42)
			ELSE IF (SelProp_Dams == "Subtop") then
				OPEN(UNIT=42, FILE='EBV_SelCan_Females.txt', ACTION='READ', STATUS='OLD')
				ALLOCATE(ID_Sel_Dams(nDams))
				DO i = 1, nTop_Dams+nDams
					READ(42,*) ID, EBV
					IF (i>nTop_Dams) then
						ID_Sel_Dams(i-nTop_Dams) = ID
					END IF
				END DO
				CLOSE(42)
			ELSE
				WRITE(*,*) 'Type of next generation: ', TypeNextGen, '  is not possible' 
			END IF
		
			DO m = 1, nDams-1
				DO n = m+1, nDams
					IF (ID_Sel_Dams(n) < ID_Sel_Dams(m)) then
						temp2 = ID_Sel_Dams(n)
						ID_Sel_Dams(n) = ID_Sel_Dams(m)
						ID_Sel_Dams(m) = temp2
					END IF 
				END DO
			END DO	

			IF ((TypeNextGen == "Nucleus") .OR. (TypeNextGen == "Multiplication")) then
				ALLOCATE(Dam_sel_log(nDams_in))
				Dam_sel_log = .FALSE.
				OPEN(UNIT=14, FILE=GenoDams_File, ACTION='READ', STATUS='OLD')
				tel = 1
				DO i = 1, nDams_in
					READ(14, *, iostat = io) ID1
					READ(14, *, iostat = io) ID2
					IF (io/=0) then
						WRITE(*,*) 'Number of dams in genotype file is not correct '
						EXIT
					END IF
					IF(ID1 /= ID2) then
						WRITE(*,*) 'ERROR: Genotype file is not in haplotype format!!'
						EXIT	
					ELSE IF (ID1 == ID2) then
						IF(ID_Sel_Dams(tel) == ID1) then
							Dam_sel_log(i) = .TRUE.
							tel = tel + 1
						END IF
					END IF
				END DO
				CLOSE(14)
				WRITE(*,*) tel-1, ' number of dams selected from genotype file '
			END IF
		ELSE
			WRITE(*,*) 'ERROR: Method for selecting dams is not available'
		END IF
	END IF
END IF	

IF (TypeNextGen == 'Crossbred') then
	IF (TypeCB == "4-way") then
		WRITE(*,*) 'Create polygenic TBVs of sires ' 

		ALLOCATE(TBV_Old(nSires_in,ntraits*7))
		ALLOCATE(Polygenic_TBV_Sire(nSires,((ntraits*2)+1)))
		Polygenic_TBV_Sire = 0
		
		OPEN(UNIT=38, FILE=TBV_PreviousGen_File, ACTION='READ', STATUS='OLD')
		teller = 0
		DO i = 1, nSires_in
			READ(38,*) TBV_old(i,:)
			IF (Sire_sel_log(i)) then
				teller=teller+1
				Polygenic_TBV_Sire(teller,1) = i
				DO j = 1, ntraits
					Polygenic_TBV_Sire(teller,((j*2))) = TBV_old(i,((j*7)-2)) + TBV_old(i,((j*7)-1))
					Polygenic_TBV_Sire(teller,((j*2)+1)) = TBV_old(i,((j*7)-6))
				END DO
			END IF
		END DO
		DEALLOCATE(TBV_old)
		CLOSE(38)
		
		PolyTBV_Sire_File = '4wayCB_' // trim(Title) // '_PolyTBV_Sire.txt'

		OPEN(UNIT=33, FILE=PolyTBV_Sire_File, STATUS='UNKNOWN', ACTION='WRITE')
		DO i = 1, nSires
			WRITE(33,'(I8,X,10(F12.8,X))') Polygenic_TBV_Sire(i,:)
		END DO
		CLOSE(33)
	END IF
END IF

!!!! Set-up mating structure
WRITE(*,*) '************************************************************************'
WRITE(*,*) 'Set-up mating structure ' 

ALLOCATE(Dams_mating_perm(nDams*Sire_per_Dam))
DO i = 1, (nDams*Sire_per_Dam)
	Dams_mating_perm(i) = i
END DO
Call perm(Dams_mating_perm(1:(nDams*Sire_per_Dam)), iseed)

ALLOCATE(Dams_mating(nDams*Sire_per_Dam))
DO i = 1, (nDams*Sire_per_Dam)
	Dams_mating(i) = ceiling(REAL(Dams_mating_perm(i))/REAL(Sire_per_Dam))
END DO

ALLOCATE(Sires_mating_perm(nSires*Dam_per_Sire))
DO i = 1, (nSires*Dam_per_Sire)
	Sires_mating_perm(i) = i
END DO

ALLOCATE(Sires_mating(nSires*Dam_per_Sire))
DO i = 1, (nSires*Dam_per_Sire)
	Sires_mating(i) = ceiling(REAL(Sires_mating_perm(i))/REAL(Dam_per_Sire))
END DO

!!!! Read genotypes sires
WRITE(*,*) '************************************************************************'
WRITE(*,*) 'Read genotype files ' 

OPEN(UNIT=13, FILE=GenoSires_File, ACTION='READ', STATUS='OLD')

IF ((TypeNextGen == 'Nucleus') .OR. (TypeNextGen == 'Multiplication') .OR. (TypeCB == '2-way')) then
	ALLOCATE(Sires(nSires, nLoci, 2))
	ALLOCATE(ID_Sires(nSires))
	teller = 0
	tel = 0
	
	DO i = 1, nSires_in
		IF (Sire_sel_log(i)) then
			tel = tel + 1
			READ(13, *, iostat = io) ID1, Sires(tel,1:nLoci,1)
			READ(13, *, iostat = io) ID2, Sires(tel,1:nLoci,2)
			IF (io/=0) then
				WRITE(*,*) 'Number of sires in genotype file is not correct '
				EXIT
			END IF
			IF(ID1 /= ID2) then
				WRITE(*,*) 'ERROR: Genotype file is not in haplotype format!!'
				EXIT	
			ELSE IF (ID1 == ID2) then
				teller = teller + 1
				ID_Sires(teller) = ID1		
			END IF
		ELSE
			READ(13, *, iostat = io) ID1
			READ(13, *, iostat = io) ID2
			IF (io/=0) then
				WRITE(*,*) 'Number of sires in genotype file is not correct '
				EXIT
			END IF
			IF(ID1 /= ID2) then
				WRITE(*,*) 'ERROR: Genotype file is not in haplotype format!!'
				EXIT	
			END IF
		END IF
	END DO
ELSE IF (TypeCB == '4-way') then
	ALLOCATE(Sires(nSires, nLoci, 1))
	ALLOCATE(ID_Sires(nSires))
	teller = 0
	tel = 0
	
	DO i = 1, nSires_in
		IF (Sire_sel_log(i)) then
			tel = tel + 1
			READ(13, *, iostat = io) ID1, Sires(tel,1:nLoci,1)
			IF (io/=0) then
				WRITE(*,*) 'Number of sires in genotype file is not correct '
				EXIT
			END IF
			teller = teller + 1
			ID_Sires(teller) = ID1		
		ELSE
			READ(13, *, iostat = io) ID1
			IF (io/=0) then
				WRITE(*,*) 'Number of sires in genotype file is not correct '
				EXIT
			END IF
		END IF
	END DO
END IF
CLOSE(13)

!!!! Read genotypes dams

IF ((TypeNextGen == 'Nucleus') .OR. (TypeNextGen == 'Multiplication')) then
	OPEN(UNIT=14, FILE=GenoDams_File, ACTION='READ', STATUS='OLD')

	ALLOCATE(Dams(nDams, nLoci, 2))
	ALLOCATE(ID_Dams(nDams))
	teller = 0 
	tel = 0
	
	DO i = 1, nDams_In
		IF (Dam_sel_log(i)) then
			tel = tel + 1
			READ(14, *, iostat = io) ID1, Dams(tel,1:nLoci,1)
			READ(14, *, iostat = io) ID2, Dams(tel,1:nLoci,2)
			IF (io/=0) then
				WRITE(*,*) 'Number of dams in genotype file is not correct '
				EXIT
			END IF
			IF(ID1 /= ID2) then
				WRITE(*,*) 'ERROR: Genotype file is not in haplotype format!!'
				EXIT
			ELSE IF (ID1 == ID2) then
				teller = teller + 1
				ID_Dams(teller) = ID1		
			END IF
		ELSE
			READ(14, *, iostat = io) ID1
			READ(14, *, iostat = io) ID2
			IF (io/=0) then
				WRITE(*,*) 'Number of dams in genotype file is not correct '
				EXIT
			END IF
			IF(ID1 /= ID2) then
				WRITE(*,*) 'ERROR: Genotype file is not in haplotype format!!'
				EXIT
			END IF
		END IF
	END DO
	CLOSE(14)
ELSE IF (TypeNextGen == 'Crossbred') then
	ALLOCATE(ID_Dams(nDams))
	DO i = 1, nDams
		ID_Dams(i) = Polygenic_TBV_Dam(i,1)
	END DO
END IF

!!!! Start with mating
WRITE(*,*) '************************************************************************'
WRITE(*,*) 'Start with mating ' 
WRITE(*,*) 'Sample number of recombination events '
WRITE(*,*) 'Create genotypes of offspring '
 
OPEN(UNIT=21, FILE=Ped_File, STATUS='UNKNOWN', ACTION='WRITE')

IF((TypeNextGen == 'Nucleus') .OR. (TypeNextGen == 'Multiplication')) then
	WRITE(*,*) 'Simulating phenotypes in ', TypeNextGen, ' Breeding scheme'
	ALLOCATE(Genotype_Male_offspring(NrMating*noff_male, nLoci, 2))
	ALLOCATE(Genotype_Female_offspring(NrMating*noff_female, nLoci, 2))
	ALLOCATE(ID_offspring(NrMating*noff))

	teller = 0
	Genotype_Male_offspring = 0
	Genotype_Female_offspring = 0
	CO_teller = 1
	ID_offspring = 0

	DO i = 1, NrMating
		DO j = 1, noff_male
			teller = teller + 1
			WRITE(21,'(X,I12,X,I12,X,I12,X,A4)') StartID+teller, ID_Sires(Sires_mating(i)), ID_Dams(Dams_mating(i)), 'Male'
			ID_offspring(teller) = StartID+teller
			DO k = 1, 2																	! 1 = alleles inherited from father, 2 = alleles inherited from mother
				DO l = 1, nChr
					dummy = RAN2(seed) 													! draw wheter first basepair is haplotype 1 or 2 			
					IF (dummy .GT. 0.5000) then
						patmat = 2
					ELSE
						patmat = 1
					END IF			
					nCrossover = random_Poisson(REAL(Chr_length(l))/100, .true.)		! Sample number of recombinations from Poisson distribution with mu equal to the chromosome length
					IF (nCrossover == 0) then											! When no crossover event, genotype, is genotype parent
						IF (k==1) then
							Genotype_Male_offspring(teller,firstSNP_chr(l):(firstSNP_chr(l+1)-1),k) = Sires(Sires_mating(i),firstSNP_chr(l):(firstSNP_chr(l+1)-1),patmat)
						ELSE IF (k==2) then
							Genotype_Male_offspring(teller,firstSNP_chr(l):(firstSNP_chr(l+1)-1),k) = Dams(Dams_mating(i),firstSNP_chr(l):(firstSNP_chr(l+1)-1),patmat)
						END IF
					ELSE IF (nCrossover > 0) then
						ALLOCATE(Pos_Crossover(nCrossover+1))
						Pos_Crossover = (Chr_length(l))
						DO m = 1, nCrossover
							Pos_Crossover(m) = RAN2(seed) * (Chr_length(l))				! Sample position of crossover events
						END DO
						IF (nCrossover>1) then											! When >1 crossover events, order the positions from first on chromosome to last
							DO m = 1, nCrossover-1
								DO n = m+1, nCrossover
									IF (Pos_Crossover(n) < Pos_Crossover(m)) then
										temp = Pos_Crossover(n)
										Pos_Crossover(n) = Pos_Crossover(m)
										Pos_Crossover(m) = temp
									END IF 
								END DO
							END DO	
						END IF				
						CO_teller = 1
						DO m = firstSNP_chr(l), (firstSNP_chr(l+1)-1)											
							IF (Loci_Map(m,2) > Pos_Crossover(CO_teller)) then			! Of crossover on this position, patmat changes to other haplotype
								CO_teller = CO_teller + 1
								patmat = 3 - patmat
							END IF
							IF (k==1) then
								Genotype_Male_offspring(teller,m,k) = Sires(Sires_mating(i),m,patmat)
							ELSE IF (k==2) then
								Genotype_Male_offspring(teller,m,k) = Dams(Dams_mating(i),m,patmat)
							END IF
						END DO	
						DEALLOCATE(Pos_Crossover)
					END IF
				END DO
			END DO	
		END DO
	END DO

	WRITE(*,*) '************************************************************************'
	WRITE(*,*) 'Write genotypes of male offspring' 

	OPEN(UNIT=22, FILE=GenoMale_Off_File, STATUS='UNKNOWN', ACTION='WRITE')
	OPEN(UNIT=23, FILE=Geno_SNP_Off_File, STATUS='UNKNOWN', ACTION='WRITE')
	ALLOCATE(QTL_offspring(NrMating*noff, nQTL, 2))

	DO i = 1, NrMating*noff_male
		WRITE(22,'(I12,X, 30000(I1,X))') ID_offspring(i), Genotype_Male_offspring(i,1:nLoci,1)
		WRITE(22,'(I12,X, 30000(I1,X))') ID_offspring(i), Genotype_Male_offspring(i,1:nLoci,2)
		
		WRITE(23,'(I12,X, 30000(I1,X))') ID_offspring(i), Genotype_Male_offspring(i,SNP_sel,1)
		WRITE(23,'(I12,X, 30000(I1,X))') ID_offspring(i), Genotype_Male_offspring(i,SNP_sel,2)

		QTL_offspring(i,1:nQTL,1) = Genotype_Male_offspring(i,QTL_sel,1) - 1
		QTL_offspring(i,1:nQTL,2) = Genotype_Male_offspring(i,QTL_sel,2) - 1
	END DO
	CLOSE(22)
	DEALLOCATE(Genotype_Male_offspring)

	teller=0
	DO i = 1, NrMating
		DO j = 1, noff_female
			teller = teller + 1
			WRITE(21,'(X,I12,X,I12,X,I12,X,A6)') StartID+teller+(NrMating*noff_male), ID_Sires(Sires_mating(i)), ID_Dams(Dams_mating(i)), 'Female'
			ID_offspring(teller+(NrMating*noff_male)) = StartID+teller+(NrMating*noff_male)
			DO k = 1, 2																	! 1 = alleles inherited from father, 2 = alleles inherited from mother
				DO l = 1, nChr
					dummy = RAN2(seed) 													! draw wheter first basepair is haplotype 1 or 2 			
					IF (dummy .GT. 0.5000) then
						patmat = 2
					ELSE
						patmat = 1
					END IF			
					nCrossover = random_Poisson(REAL(Chr_length(l))/100, .true.)		! Sample number of recombinations from Poisson distribution with mu equal to the chromosome length
					IF (nCrossover == 0) then											! When no crossover event, genotype, is genotype parent
						IF (k==1) then
							Genotype_Female_offspring(teller,firstSNP_chr(l):(firstSNP_chr(l+1)-1),k) = Sires(Sires_mating(i),firstSNP_chr(l):(firstSNP_chr(l+1)-1),patmat)
						ELSE IF (k==2) then
							Genotype_Female_offspring(teller,firstSNP_chr(l):(firstSNP_chr(l+1)-1),k) = Dams(Dams_mating(i),firstSNP_chr(l):(firstSNP_chr(l+1)-1),patmat)
						END IF
					ELSE IF (nCrossover > 0) then
						ALLOCATE(Pos_Crossover(nCrossover+1))
						Pos_Crossover = (Chr_length(l))
						DO m = 1, nCrossover
							Pos_Crossover(m) = RAN2(seed) * (Chr_length(l))				! Sample position of crossover events
						END DO
						IF (nCrossover>1) then											! When >1 crossover events, order the positions from first on chromosome to last
							DO m = 1, nCrossover-1
								DO n = m+1, nCrossover
									IF (Pos_Crossover(n) < Pos_Crossover(m)) then
										temp = Pos_Crossover(n)
										Pos_Crossover(n) = Pos_Crossover(m)
										Pos_Crossover(m) = temp
									END IF 
								END DO
							END DO	
						END IF				
						CO_teller = 1
						DO m = firstSNP_chr(l), (firstSNP_chr(l+1)-1)									
							IF (Loci_Map(m,2) > Pos_Crossover(CO_teller)) then			! Of crossover on this position, patmat changes to other haplotype
								CO_teller = CO_teller + 1
								patmat = 3 - patmat
							END IF
							IF (k==1) then
								Genotype_Female_offspring(teller,m,k) = Sires(Sires_mating(i),m,patmat)
							ELSE IF (k==2) then
								Genotype_Female_offspring(teller,m,k) = Dams(Dams_mating(i),m,patmat)
							END IF
						END DO	
						DEALLOCATE(Pos_Crossover)
					END IF
				END DO
			END DO	
		END DO
	END DO
	CLOSE(21)
	
	WRITE(*,*) 'Write genotypes of female offspring' 

	OPEN(UNIT=24, FILE=GenoFemale_Off_File, STATUS='UNKNOWN', ACTION='WRITE')

	DO i = 1, NrMating*noff_female
		WRITE(24,'(I12,X, 30000(I1,X))') ID_offspring(i+(NrMating*noff_male)), Genotype_female_offspring(i,1:nLoci,1)
		WRITE(24,'(I12,X, 30000(I1,X))') ID_offspring(i+(NrMating*noff_male)), Genotype_female_offspring(i,1:nLoci,2)
	
		WRITE(23,'(I12,X, 30000(I1,X))') ID_offspring(i+(NrMating*noff_male)), Genotype_female_offspring(i,SNP_sel,1)
		WRITE(23,'(I12,X, 30000(I1,X))') ID_offspring(i+(NrMating*noff_male)), Genotype_female_offspring(i,SNP_sel,2)

		QTL_offspring(i+(NrMating*noff_male),1:nQTL,1) = Genotype_female_offspring(i,QTL_sel,1) - 1
		QTL_offspring(i+(NrMating*noff_male),1:nQTL,2) = Genotype_female_offspring(i,QTL_sel,2) - 1
	END DO
	DEALLOCATE(Genotype_female_offspring)

	WRITE(*,*) '************************************************************************'
	WRITE(*,*) 'Simulate phenotypes' 

	OPEN(UNIT=31, FILE=QTLEffects_File, STATUS='OLD', ACTION='READ')
	ALLOCATE(Effect(nQTL, ntraits))

	DO i = 1, nQTL
		READ(31,*) j, Effect(i,1:ntraits)
	END DO
	CLOSE(31)

	OPEN(UNIT=32, FILE=VarComp_File, STATUS='OLD', ACTION='READ')
	ALLOCATE(VarComp(ntraits,2))

	DO i = 1, ntraits
		READ(32,*) VarComp(i,1), VarComp(i,2)
	END DO
	CLOSE(32)

	ALLOCATE(TBV(NrMating*noff, ntraits))
	TBV = 0
	DO i = 1, ntraits
		DO j = 1, NrMating*noff
			DO k = 1, nQTL
				TBV(j,i) = TBV(j,i) + QTL_offspring(j,k,1) *Effect(k,i)
				TBV(j,i) = TBV(j,i) + QTL_offspring(j,k,2) *Effect(k,i)
			END DO
		END DO 
	END DO

	ALLOCATE(Env(NrMating*noff, ntraits))
	DO i = 1, ntraits
		DO j = 1, (NrMating*noff)
			Env(j,i) = gasdev(iseed) * sqrt(VarComp(i,2))
		END DO
	END DO

	ALLOCATE(Phen(NrMating*noff, ntraits))

	DO i = 1, ntraits	
		Phen(:,i) = TBV(:,i) + Env(:,i)
	END DO
	
	ALLOCATE(Phen_Missing(ntraits*3))
	Phen_Missing = -99.
	
	OPEN(UNIT=33, FILE=Phenotype_File, ACTION='WRITE', STATUS='UNKNOWN')
	OPEN(UNIT=38, File=SelCan_File, ACTION='WRITE', STATUS='UNKNOWN')
	
	DO i = 1, (NrMating*noff)
		WRITE(33,'(I10,X,14(F15.7,X))') ID_offspring(i), TBV(i,:), Env(i,:), Phen(i,:), 1.
		WRITE(38,'(I10,X,14(F15.7,X))') ID_offspring(i), Phen_Missing(:), 1.
	END DO
	CLOSE(33)
	CLOSE(38)

ELSE IF (TypeNextGen == 'Crossbred') then
WRITE(*,*) 'Simulating phenotypes in ', TypeNextGen, ' Breeding scheme'
	IF (TypeCB == "2-way") then
		WRITE(*,*) 'Type of Crossbreds is ', TypeCB
		ALLOCATE(Genotype_Male_offspring(NrMating*noff_male, nLoci, 1))
		ALLOCATE(Genotype_Female_offspring(NrMating*noff_female, nLoci, 1))
		ALLOCATE(ID_offspring(NrMating*noff))

		teller = 0
		Genotype_Male_offspring = 0
		Genotype_Female_offspring = 0
		CO_teller = 1
		ID_offspring = 0

		DO i = 1, NrMating
			DO j = 1, noff_male
				teller = teller + 1
				WRITE(21,'(X,I12,X,I12,X,I12,X,A4)') StartID+teller, ID_Sires(Sires_mating(i)), ID_Dams(Dams_mating(i)), 'Male'
				ID_offspring(teller) = StartID+teller
				DO l = 1, nChr
					dummy = RAN2(seed) 													! draw wheter first basepair is haplotype 1 or 2 			
					IF (dummy .GT. 0.5000) then
						patmat = 2
					ELSE
						patmat = 1
					END IF			
					nCrossover = random_Poisson(REAL(Chr_length(l))/100, .true.)		! Sample number of recombinations from Poisson distribution with mu equal to the chromosome length
					IF (nCrossover == 0) then											! When no crossover event, genotype, is genotype parent
						Genotype_Male_offspring(teller,firstSNP_chr(l):(firstSNP_chr(l+1)-1),1) = Sires(Sires_mating(i),firstSNP_chr(l):(firstSNP_chr(l+1)-1),patmat)
					ELSE IF (nCrossover > 0) then
						ALLOCATE(Pos_Crossover(nCrossover+1))
						Pos_Crossover = (Chr_length(l))
						DO m = 1, nCrossover
							Pos_Crossover(m) = RAN2(seed) * (Chr_length(l))				! Sample position of crossover events
						END DO
						IF (nCrossover>1) then											! When >1 crossover events, order the positions from first on chromosome to last
							DO m = 1, nCrossover-1
								DO n = m+1, nCrossover
									IF (Pos_Crossover(n) < Pos_Crossover(m)) then
										temp = Pos_Crossover(n)
										Pos_Crossover(n) = Pos_Crossover(m)
										Pos_Crossover(m) = temp
									END IF 
								END DO
							END DO	
						END IF				
						CO_teller = 1
						DO m = firstSNP_chr(l), (firstSNP_chr(l+1)-1)									
							IF (Loci_Map(m,2) > Pos_Crossover(CO_teller)) then			! Of crossover on this position, patmat changes to other haplotype
								CO_teller = CO_teller + 1
								patmat = 3 - patmat
							END IF
							Genotype_Male_offspring(teller,m,1) = Sires(Sires_mating(i),m,patmat)
						END DO	
						DEALLOCATE(Pos_Crossover)
					END IF
				END DO	
			END DO
		END DO

		WRITE(*,*) '************************************************************************'
		WRITE(*,*) 'Write genotypes of male offspring' 

		OPEN(UNIT=22, FILE=GenoMale_Off_File, STATUS='UNKNOWN', ACTION='WRITE')
		OPEN(UNIT=23, FILE=Geno_SNP_Off_File, STATUS='UNKNOWN', ACTION='WRITE')
		ALLOCATE(QTL_offspring(NrMating*noff, nQTL, 2))

		DO i = 1, NrMating*noff_male
			WRITE(22,'(I12,X, 30000(I1,X))') ID_offspring(i), Genotype_Male_offspring(i,1:nLoci,1)
			WRITE(23,'(I12,X, 30000(I1,X))') ID_offspring(i), Genotype_Male_offspring(i,SNP_sel,1)
			QTL_offspring(i,1:nQTL,1) = Genotype_Male_offspring(i,QTL_sel,1) - 1
		END DO
		CLOSE(22)
		DEALLOCATE(Genotype_Male_offspring)

		teller=0
		DO i = 1, NrMating
			DO j = 1, noff_female
				teller = teller + 1
				WRITE(21,'(X,I12,X,I12,X,I12,X,A6)') StartID+teller+(NrMating*noff_male), ID_Sires(Sires_mating(i)), ID_Dams(Dams_mating(i)), 'Female'
				ID_offspring(teller+(NrMating*noff_male)) = StartID+teller+(NrMating*noff_male)
				DO l = 1, nChr
					dummy = RAN2(seed) 													! draw wheter first basepair is haplotype 1 or 2 			
					IF (dummy .GT. 0.5000) then
						patmat = 2
					ELSE
						patmat = 1
					END IF			
					nCrossover = random_Poisson(REAL(Chr_length(l))/100, .true.)		! Sample number of recombinations from Poisson distribution with mu equal to the chromosome length
					IF (nCrossover == 0) then											! When no crossover event, genotype, is genotype parent
						Genotype_Female_offspring(teller,firstSNP_chr(l):(firstSNP_chr(l+1)-1),1) = Sires(Sires_mating(i),firstSNP_chr(l):(firstSNP_chr(l+1)-1),patmat)
					ELSE IF (nCrossover > 0) then
						ALLOCATE(Pos_Crossover(nCrossover+1))
						Pos_Crossover = (Chr_length(l))
						DO m = 1, nCrossover
							Pos_Crossover(m) = RAN2(seed) * (Chr_length(l))				! Sample position of crossover events
						END DO
						IF (nCrossover>1) then											! When >1 crossover events, order the positions from first on chromosome to last
							DO m = 1, nCrossover-1
								DO n = m+1, nCrossover
									IF (Pos_Crossover(n) < Pos_Crossover(m)) then
										temp = Pos_Crossover(n)
										Pos_Crossover(n) = Pos_Crossover(m)
										Pos_Crossover(m) = temp
									END IF 
								END DO
							END DO	
						END IF				
						CO_teller = 1
						DO m = firstSNP_chr(l), (firstSNP_chr(l+1)-1)									
							IF (Loci_Map(m,2) > Pos_Crossover(CO_teller)) then			! Of crossover on this position, patmat changes to other haplotype
								CO_teller = CO_teller + 1
								patmat = 3 - patmat
							END IF
							Genotype_Female_offspring(teller,m,1) = Sires(Sires_mating(i),m,patmat)
						END DO	
						DEALLOCATE(Pos_Crossover)
					END IF
				END DO	
			END DO
		END DO
		CLOSE(21)
		
		WRITE(*,*) 'Write genotypes of female offspring' 

		OPEN(UNIT=24, FILE=GenoFemale_Off_File, STATUS='UNKNOWN', ACTION='WRITE')

		DO i = 1, NrMating*noff_female
			WRITE(24,'(I12,X, 30000(I1,X))') ID_offspring(i+(NrMating*noff_male)), Genotype_female_offspring(i,1:nLoci,1)
			WRITE(23,'(I12,X, 30000(I1,X))') ID_offspring(i+(NrMating*noff_male)), Genotype_female_offspring(i,SNP_sel,1)
			QTL_offspring(i+(NrMating*noff_male),1:nQTL,1) = Genotype_female_offspring(i,QTL_sel,1) - 1
		END DO
		DEALLOCATE(Genotype_female_offspring)

		WRITE(*,*) '************************************************************************'
		WRITE(*,*) 'Simulate phenotypes' 

		OPEN(UNIT=31, FILE=QTLEffects_File, STATUS='OLD', ACTION='READ')
		ALLOCATE(Effect(nQTL, ntraits))

		DO i = 1, nQTL
			READ(31,*) j, Effect(i,1:ntraits)
		END DO
		CLOSE(31)

		OPEN(UNIT=32, FILE=VarComp_File, STATUS='OLD', ACTION='READ')
		ALLOCATE(VarComp(ntraits,2))

		DO i = 1, ntraits
			READ(32,*) VarComp(i,1), VarComp(i,2)
		END DO
		CLOSE(32)

!!!!!	TBV 
!!!!!	Part of TBV based on genotypes coming from sire
		ALLOCATE(TBV(NrMating*noff, ntraits))
		ALLOCATE(TBV_test(NrMating*noff, ntraits*7))
		TBV = 0
		TBV_test = 0
		TBV(:,1) = -99.
		DO i = 2, ntraits
			DO j = 1, NrMating*noff
				DO k = 1, nQTL
					TBV(j,i) = TBV(j,i) + QTL_offspring(j,k,1) *Effect(k,i)
				END DO
			END DO 
			TBV_test(:,(((i-1)*7)+1)) = TBV(:,i)
		END DO
				
!!!! 	Polygenic term coming from dam
		teller = 0
		DO i = 1, NrMating 
			DO j = 1, noff_male
			teller = teller + 1
				DO k = 2, ntraits
					TBV(teller,k) = TBV(teller,k) + 0.5*Polygenic_TBV_Dam(Dams_mating(i),k+1)
					TBV_test(teller,(((k-1)*7)+5)) = 0.5*Polygenic_TBV_Dam(Dams_mating(i),k+1)
				END DO
			END DO
		END DO
		
		DO i = 1, NrMating 
			DO j = 1, noff_female
			teller = teller + 1
				DO k = 2, ntraits
					TBV(teller,k) = TBV(teller,k) + 0.5*Polygenic_TBV_Dam(Dams_mating(i),k+1)
					TBV_test(teller,(((k-1)*7)+5)) = 0.5*Polygenic_TBV_Dam(Dams_mating(i),k+1)
				END DO
			END DO
		END DO
		
!!!!	Mendelian sampling term	of dam component	
		DO i = 2, ntraits
			DO j = 1, NrMating*noff
				TBV(j,i) = TBV(j,i) + gasdev(iseed) * sqrt(0.25 * VarComp(i,1))
				TBV_test(j,(((i-1)*7)+6)) = TBV(j,i) - TBV_test(j,(((i-1)*7)+5))-TBV_test(j,(((i-1)*7)+1))
				TBV_test(j,(((i-1)*7)+7)) = TBV(j,i)
			END DO
		END DO

!!!!!	Environmental component
		ALLOCATE(Env(NrMating*noff, ntraits))
		Env = -99.
		DO i = 2, ntraits
			DO j = 1, (NrMating*noff)
				Env(j,i) = gasdev(iseed) * sqrt(VarComp(i,2))
			END DO
		END DO

		ALLOCATE(Phen(NrMating*noff, ntraits))
		Phen = -99.

		DO i = 2, ntraits	
			Phen(:,i) = TBV(:,i) + Env(:,i)
		END DO
	
		ALLOCATE(Phen_Missing(ntraits*3))
		Phen_Missing = -99.

		TBV_File = '2wayCB_' // trim(Title) // '_TBV.txt'

		OPEN(UNIT=33, FILE=Phenotype_File, ACTION='WRITE', STATUS='UNKNOWN')
		OPEN(UNIT=71, FILE=TBV_File, ACTION='WRITE', STATUS='UNKNOWN') 
		OPEN(UNIT=38, File=SelCan_File, ACTION='WRITE', STATUS='UNKNOWN')
		
		DO i = 1, (NrMating*noff)
			WRITE(33,'(I10,X,14(F15.7,X))') ID_offspring(i), TBV(i,:), Env(i,:), Phen(i,:), 1.
			WRITE(71,'(28(F14.6,X))') TBV_test(i,:)
			WRITE(38,'(I10,X,14(F15.7,X))') ID_offspring(i), Phen_Missing(:), 1.
		END DO
		CLOSE(33)
		CLOSE(71)
		CLOSE(38)

	ELSE IF (TypeCB == "4-way") then
		WRITE(*,*) 'Type of Crossbreds is ', TypeCB
		ALLOCATE(Genotype_Male_offspring(NrMating*noff_male, nLoci, 1))
		ALLOCATE(Genotype_Female_offspring(NrMating*noff_female, nLoci, 1))
		ALLOCATE(ID_offspring(NrMating*noff))
		ALLOCATE(Loci_LineA(NrMating*noff))

		teller = 0
		Genotype_Male_offspring = 0
		Genotype_Female_offspring = 0
		CO_teller = 1
		ID_offspring = 0
		Loci_LineA = 0

		DO i = 1, NrMating
			DO j = 1, noff_male
				teller = teller + 1
				WRITE(21,'(X,I12,X,I12,X,I12,X,A4)') StartID+teller, ID_Sires(Sires_mating(i)), ID_Dams(Dams_mating(i)), 'Male'
				ID_offspring(teller) = StartID+teller
				DO l = 1, nChr
					dummy = RAN2(seed) 													! draw wheter first basepair is haplotype 1 or 2 			
					IF (dummy .GT. 0.5000) then
						patmat = 2
					ELSE
						patmat = 1
					END IF			
					nCrossover = random_Poisson(REAL(Chr_length(l))/100, .true.)		! Sample number of recombinations from Poisson distribution with mu equal to the chromosome length
					IF (nCrossover == 0) then											! When no crossover event, genotype, is genotype parent
						IF (patmat==1) then
							Genotype_Male_offspring(teller,firstSNP_chr(l):(firstSNP_chr(l+1)-1),1) = Sires(Sires_mating(i),firstSNP_chr(l):(firstSNP_chr(l+1)-1),patmat)
							Loci_LineA(teller) =  Loci_LineA(teller) + firstSNP_chr(l+1) - firstSNP_chr(l)
						ELSE IF (patmat==2) then
							Genotype_Male_offspring(teller,firstSNP_chr(l):(firstSNP_chr(l+1)-1),1) = 9
						END IF
					ELSE IF (nCrossover > 0) then
						ALLOCATE(Pos_Crossover(nCrossover+1))
						Pos_Crossover = (Chr_length(l))
						DO m = 1, nCrossover
							Pos_Crossover(m) = RAN2(seed) * (Chr_length(l))				! Sample position of crossover events
						END DO
						IF (nCrossover>1) then											! When >1 crossover events, order the positions from first on chromosome to last
							DO m = 1, nCrossover-1
								DO n = m+1, nCrossover
									IF (Pos_Crossover(n) < Pos_Crossover(m)) then
										temp = Pos_Crossover(n)
										Pos_Crossover(n) = Pos_Crossover(m)
										Pos_Crossover(m) = temp
									END IF 
								END DO
							END DO	
						END IF				
						CO_teller = 1
						DO m = firstSNP_chr(l), (firstSNP_chr(l+1)-1)										
							IF (Loci_Map(m,2) > Pos_Crossover(CO_teller)) then			! Of crossover on this position, patmat changes to other haplotype
								CO_teller = CO_teller + 1
								patmat = 3 - patmat
							END IF
							IF (patmat==1) then
								Genotype_Male_offspring(teller,m,1) = Sires(Sires_mating(i),m,patmat)
								Loci_LineA(teller) = Loci_LineA(teller) + 1
							ELSE IF (patmat==2) then
								Genotype_Male_offspring(teller,m,1) = 9
							END IF
						END DO	
						DEALLOCATE(Pos_Crossover)
					END IF
				END DO	
			END DO
		END DO

		WRITE(*,*) '************************************************************************'
		WRITE(*,*) 'Write genotypes of male offspring' 

		OPEN(UNIT=22, FILE=GenoMale_Off_File, STATUS='UNKNOWN', ACTION='WRITE')
		OPEN(UNIT=23, FILE=Geno_SNP_Off_File, STATUS='UNKNOWN', ACTION='WRITE')
		ALLOCATE(QTL_offspring(NrMating*noff, nQTL, 2))

		DO i = 1, NrMating*noff_male
			WRITE(22,'(I12,X, 30000(I1,X))') ID_offspring(i), Genotype_Male_offspring(i,1:nLoci,1)
			WRITE(23,'(I12,X, 30000(I1,X))') ID_offspring(i), Genotype_Male_offspring(i,SNP_sel,1)
			QTL_offspring(i,1:nQTL,1) = Genotype_Male_offspring(i,QTL_sel,1) - 1
		END DO
		CLOSE(22)
		DEALLOCATE(Genotype_Male_offspring)

		teller=0
		DO i = 1, NrMating
			DO j = 1, noff_female
				teller = teller + 1
				WRITE(21,'(X,I12,X,I12,X,I12,X,A6)') StartID+teller+(NrMating*noff_male), ID_Sires(Sires_mating(i)), ID_Dams(Dams_mating(i)), 'Female'
				ID_offspring(teller+(NrMating*noff_male)) = StartID+teller+(NrMating*noff_male)
				DO l = 1, nChr
					dummy = RAN2(seed) 													! draw wheter first basepair is haplotype 1 or 2 			
					IF (dummy .GT. 0.5000) then
						patmat = 2
					ELSE
						patmat = 1
					END IF			
					nCrossover = random_Poisson(REAL(Chr_length(l))/100, .true.)		! Sample number of recombinations from Poisson distribution with mu equal to the chromosome length
					IF (nCrossover == 0) then											! When no crossover event, genotype, is genotype parent
						IF (patmat==1) then
							Genotype_Female_offspring(teller,firstSNP_chr(l):(firstSNP_chr(l+1)-1),1) = Sires(Sires_mating(i),firstSNP_chr(l):(firstSNP_chr(l+1)-1),patmat)
							Loci_LineA(teller+(NrMating*noff_male)) = Loci_LineA(teller+(NrMating*noff_male)) + firstSNP_chr(l+1) - firstSNP_chr(l)
						ELSE IF (patmat==2) then
							Genotype_Female_offspring(teller,firstSNP_chr(l):(firstSNP_chr(l+1)-1),1) = 9
						END IF
					ELSE IF (nCrossover > 0) then
						ALLOCATE(Pos_Crossover(nCrossover+1))
						Pos_Crossover = (Chr_length(l))
						DO m = 1, nCrossover
							Pos_Crossover(m) = RAN2(seed) * (Chr_length(l))				! Sample position of crossover events
						END DO
						IF (nCrossover>1) then											! When >1 crossover events, order the positions from first on chromosome to last
							DO m = 1, nCrossover-1
								DO n = m+1, nCrossover
									IF (Pos_Crossover(n) < Pos_Crossover(m)) then
										temp = Pos_Crossover(n)
										Pos_Crossover(n) = Pos_Crossover(m)
										Pos_Crossover(m) = temp
									END IF 
								END DO
							END DO	
						END IF				
						CO_teller = 1
						DO m = firstSNP_chr(l), (firstSNP_chr(l+1)-1)										
							IF (Loci_Map(m,2) > Pos_Crossover(CO_teller)) then			! Of crossover on this position, patmat changes to other haplotype
								CO_teller = CO_teller + 1
								patmat = 3 - patmat
							END IF
							IF (patmat ==1) then
								Genotype_Female_offspring(teller,m,1) = Sires(Sires_mating(i),m,patmat)
								Loci_LineA(teller+(NrMating*noff_male)) = Loci_LineA(teller+(NrMating*noff_male)) + 1
							ELSE IF (patmat==2) then
								Genotype_Female_offspring(teller,m,1) = 9
							END IF
						END DO	
						DEALLOCATE(Pos_Crossover)
					END IF
				END DO	
			END DO
		END DO
		CLOSE(21)
		
		WRITE(*,*) 'Write genotypes of female offspring' 

		OPEN(UNIT=24, FILE=GenoFemale_Off_File, STATUS='UNKNOWN', ACTION='WRITE')

		DO i = 1, NrMating*noff_female
			WRITE(24,'(I12,X, 30000(I1,X))') ID_offspring(i+(NrMating*noff_male)), Genotype_female_offspring(i,1:nLoci,1)
			WRITE(23,'(I12,X, 30000(I1,X))') ID_offspring(i+(NrMating*noff_male)), Genotype_female_offspring(i,SNP_sel,1)
			QTL_offspring(i+(NrMating*noff_male),1:nQTL,1) = Genotype_female_offspring(i,QTL_sel,1) - 1
		END DO
		DEALLOCATE(Genotype_female_offspring)

		WRITE(*,*) '************************************************************************'
		WRITE(*,*) 'Simulate phenotypes' 

		OPEN(UNIT=31, FILE=QTLEffects_File, STATUS='OLD', ACTION='READ')
		ALLOCATE(Effect(nQTL, ntraits))

		DO i = 1, nQTL
			READ(31,*) j, Effect(i,1:ntraits)
		END DO
		CLOSE(31)

		OPEN(UNIT=32, FILE=VarComp_File, STATUS='OLD', ACTION='READ')
		ALLOCATE(VarComp(ntraits,2))

		DO i = 1, ntraits
			READ(32,*) VarComp(i,1), VarComp(i,2)
		END DO
		CLOSE(32)

!!!!!	TBV 
!!!!!	Part of TBV based on genotypes coming from paternal grand sire
		ALLOCATE(TBV(NrMating*noff, ntraits))
		ALLOCATE(TBV_test(NrMating*noff, ntraits*7))
		TBV = 0
		TBV_test = 0
		TBV(:,1) = -99.
		DO i = 2, ntraits
			DO j = 1, NrMating*noff
				DO k = 1, nQTL
					IF (QTL_offspring(j,k,1) < 3) then
						TBV(j,i) = TBV(j,i) + QTL_offspring(j,k,1) *Effect(k,i)
					ELSE IF (QTL_offspring(j,k,1) == 8 ) then
						TBV(j,i) = TBV(j,i) + (QTL_AFreq(k)) *Effect(k,i)
					END IF
				END DO
			END DO 
			TBV_Test(:,(((i-1)*7)+2)) = TBV(:,i)
		END DO

!!!!!	Covariance structure coming from Paternal Grand Dam
!!!!!	Count number of alleles in common between sibs coming from Paternal Grand Dam (coded as 8 in QTL_offspring)

		ALLOCATE(Loci_PGD(noff*NrMating))
		ALLOCATE(CovMatrix_BOA(noff*NrMating, noff*NrMating))
		teller1 = 0
		teller2 = 0
		teller3 = 0
		teller4 = 0
		Loci_PGD = 0
		CovMatrix_BOA = 0
		
		DO i = 1, nSires
			ALLOCATE(Alleles_Common(noff*Dam_per_Sire,noff*Dam_per_Sire))
			
			teller4 = (i-1) * (noff_female*Dam_per_Sire)
			DO j = 1, noff_male*Dam_per_Sire
				teller1 = teller1 + 1
				DO k = 1, j
					Alleles_Common(j,k) = count((QTL_offspring(teller1,1:nQTL,1)+QTL_offspring(teller1-j+k,1:nQTL,1)) == 16)			!Among male offspring
					Alleles_Common(k,j) = Alleles_Common(j,k)
					IF (k==j) then
						Loci_PGD(((i-1)*noff_male*Dam_per_Sire)+j) = Alleles_Common(j,k)
					END IF
				END DO
			END DO
			DO j = 1, noff_female*Dam_per_Sire
				teller2 = teller2 + 1
				DO k = 1, j
					Alleles_Common(j+(noff_male*Dam_per_Sire),k+(noff_male*Dam_per_Sire)) = count((QTL_offspring((NrMating*noff_male)+teller2,1:nQTL,1)+QTL_offspring((NrMating*noff_male)+teller2-j+k,1:nQTL,1)) == 16)			!Among female offspring
					Alleles_Common(k+(noff_male*Dam_per_Sire),j+(noff_male*Dam_per_Sire)) = Alleles_Common(j+(noff_male*Dam_per_Sire),k+(noff_male*Dam_per_Sire))
					IF (k==j) then
						Loci_PGD((NrMating*noff_male)+((i-1)*noff_female*Dam_per_Sire)+j) = Alleles_Common(j+(noff_male*Dam_per_Sire),k+(noff_male*Dam_per_Sire))
					END IF
				END DO
			END DO
			DO j = 1, noff_male*Dam_per_Sire
				teller3 = teller3 + 1
				DO k = 1, noff_female*Dam_per_Sire
					teller4 = teller4 + 1
					Alleles_Common(j,k+(noff_male*Dam_per_Sire)) = count((QTL_offspring(teller3,1:nQTL,1)+QTL_offspring((NrMating*noff_male)+teller4,1:nQTL,1)) == 16)			!Among male and female offspring
					Alleles_Common(k+(noff_male*Dam_per_Sire),j) = Alleles_Common(j,k+(noff_male*Dam_per_Sire))
				END DO
				teller4 = (i-1) * (noff_female*Dam_per_Sire)
			END DO

			Alleles_Common = (Alleles_Common/REAL(nQTL))
			ALLOCATE(CovMat(noff*Dam_per_Sire, noff*Dam_per_Sire))
			
			DO j= 1,noff*Dam_per_Sire
				DO k = 1, j
					IF(j==k) then
						CovMat(j,k) = Alleles_Common(j,j) * (1-Alleles_Common(j,j))
					ELSE
						CovMat(j,k) = Alleles_Common(j,k) - (Alleles_Common(j,j)*Alleles_Common(k,k))
						CovMat(k,j) = CovMat(j,k)
					END IF
				END DO
			END DO
			
			DO j = 1, noff_male*Dam_per_Sire
				DO k = 1, j
					CovMatrix_BOA(((i-1)*noff_male*Dam_per_Sire)+j,((i-1)*noff_male*Dam_per_Sire)+k)=Alleles_Common(j,k)*0.5
					CovMatrix_BOA(((i-1)*noff_male*Dam_per_Sire)+k,((i-1)*noff_male*Dam_per_Sire)+j)=Alleles_Common(k,j)*0.5
				END DO
			END DO
			DO j = 1, noff_female*Dam_per_Sire
				DO k = 1, j
					CovMatrix_BOA((noff_male*Dam_per_Sire*nSires)+((i-1)*noff_female*Dam_per_Sire)+j,(noff_male*Dam_per_Sire*nSires)+((i-1)*noff_female*Dam_per_Sire)+k)=Alleles_Common(j+(noff_male*Dam_per_Sire),k+(noff_male*Dam_per_Sire))*0.5
					CovMatrix_BOA((noff_male*Dam_per_Sire*nSires)+((i-1)*noff_female*Dam_per_Sire)+k,(noff_male*Dam_per_Sire*nSires)+((i-1)*noff_female*Dam_per_Sire)+j)=Alleles_Common(k+(noff_male*Dam_per_Sire),j+(noff_male*Dam_per_Sire))*0.5
				END DO
			END DO
			DO j = 1, noff_male*Dam_per_Sire
				DO k = 1, noff_female*Dam_per_Sire
					CovMatrix_BOA(((i-1)*noff_male*Dam_per_Sire)+j,(noff_male*Dam_per_Sire*nSires)+((i-1)*noff_female*Dam_per_Sire)+k)=Alleles_Common(j,k+(noff_male*Dam_per_Sire))*0.5
					CovMatrix_BOA((noff_male*Dam_per_Sire*nSires)+((i-1)*noff_female*Dam_per_Sire)+k,((i-1)*noff_male*Dam_per_Sire)+j)=Alleles_Common(k+(noff_male*Dam_per_Sire),j)*0.5
				END DO
			END DO
			
			CALL bend_matrix((noff*Dam_per_Sire), CovMat) 			
			ALLOCATE(CovMat_Bend(noff*Dam_per_Sire,noff*Dam_per_Sire))
			CovMat_Bend = CovMat
			
			CALL chol(CovMat_Bend(1:(noff*Dam_per_Sire),1:(noff*Dam_per_Sire)))  
			ALLOCATE(Chol_Matrix(noff*Dam_per_Sire,noff*Dam_per_Sire))
			Chol_Matrix = transpose(CovMat_Bend)
			
			DEALLOCATE(CovMat)
			DEALLOCATE(CovMat_Bend)

			ALLOCATE(Var_Poly_Sire((noff*Dam_per_Sire),ntraits))
			Var_Poly_Sire = 0
			
			DO j = 2, ntraits			
				ALLOCATE(Poly_Sire((noff*Dam_per_Sire)))
				Poly_Sire = 0
				CALL ggnml(iseed, (noff*Dam_per_Sire), Poly_Sire(1:((noff*Dam_per_Sire))))

				Var_Poly_Sire(1:noff*Dam_per_Sire,j) = matmul(Poly_Sire(1:((noff*Dam_per_Sire))),Chol_Matrix)
				Var_Poly_Sire(1:((noff*Dam_per_Sire)),j) = Var_Poly_Sire(1:((noff*Dam_per_Sire)),j) * sqrt(0.5*VarComp(j,1))
				DEALLOCATE(Poly_Sire)
			END DO

!!!!!	Part of TBV based on genotypes coming from paternal grand dam
			DO j = 1, noff_male*Dam_per_Sire
				DO k = 2, ntraits
					TBV_Test(((i-1)*noff_male*Dam_per_Sire)+j,(((k-1)*7)+1)) = (1-Alleles_Common(j,j)) * Polygenic_TBV_Sire(i,(((k*2)+1)))
					TBV_Test(((i-1)*noff_male*Dam_per_Sire)+j,(((k-1)*7)+2)) = TBV(((i-1)*noff_male*Dam_per_Sire)+j,k)-TBV_Test(((i-1)*noff_male*Dam_per_Sire)+j,(((k-1)*7)+1))
				END DO
			END DO
			DO j = 1, noff_female*Dam_per_Sire
				DO k = 2, ntraits
					TBV_Test((NrMating*noff_male)+((i-1)*noff_female*Dam_per_Sire)+j,(((k-1)*7)+1)) = (1-Alleles_Common(j+(noff_male*Dam_per_Sire),j+(noff_male*Dam_per_Sire))) * Polygenic_TBV_Sire(i,(((k*2)+1)))
					TBV_Test((NrMating*noff_male)+((i-1)*noff_female*Dam_per_Sire)+j,(((k-1)*7)+2)) = TBV((NrMating*noff_male)+((i-1)*noff_female*Dam_per_Sire)+j,k)-TBV_Test((NrMating*noff_male)+((i-1)*noff_female*Dam_per_Sire)+j,(((k-1)*7)+1))
				END DO		
			END DO					
					
			DO j = 1, noff_male*Dam_per_Sire
				DO k = 2, ntraits
					TBV(((i-1)*noff_male*Dam_per_Sire)+j,k) = TBV(((i-1)*noff_male*Dam_per_Sire)+j,k) + Alleles_Common(j,j) * Polygenic_TBV_Sire(i,(2*k)) + Var_Poly_Sire(j,k)
					TBV_test(((i-1)*noff_male*Dam_per_Sire)+j,(((k-1)*7)+3)) = Alleles_Common(j,j) * Polygenic_TBV_Sire(i,(2*k))
					TBV_test(((i-1)*noff_male*Dam_per_Sire)+j,(((k-1)*7)+4)) = Var_Poly_Sire(j,k)
				END DO
			END DO
			DO j = 1, noff_female*Dam_per_Sire
				DO k = 2, ntraits
					TBV((NrMating*noff_male)+((i-1)*noff_female*Dam_per_Sire)+j,k) = TBV((NrMating*noff_male)+((i-1)*noff_female*Dam_per_Sire)+j,k) + Alleles_Common(j+(noff_male*Dam_per_Sire),j+(noff_male*Dam_per_Sire))*Polygenic_TBV_Sire(i,(2*k)) + Var_Poly_Sire(j+(noff_male*Dam_per_Sire),k)
					TBV_test((NrMating*noff_male)+((i-1)*noff_female*Dam_per_Sire)+j,(((k-1)*7)+3)) = Alleles_Common(j+(noff_male*Dam_per_Sire),j+(noff_male*Dam_per_Sire))*Polygenic_TBV_Sire(i,(2*k))
					TBV_test((NrMating*noff_male)+((i-1)*noff_female*Dam_per_Sire)+j,(((k-1)*7)+4)) = Var_Poly_Sire(j+(noff_male*Dam_per_Sire),k)
				END DO
			END DO
			
			DEALLOCATE(Var_Poly_Sire)
			DEALLOCATE(Chol_Matrix)
			DEALLOCATE(Alleles_Common)
			
		END DO
		
		OPEN(UNIT=81, FILE="G_matrix_PGD_CB.grm", ACTION='WRITE', STATUS='UNKNOWN')
		DO i = 1, (NrMating*noff)
			DO j = 1, i
				IF (CovMatrix_BOA(i,j) == 0) CYCLE
				WRITE(81,'(I12,X,I12,X,F15.10,X,I12,X,I12)') i, j, CovMatrix_BOA(i,j), ID_offspring(i), ID_offspring(j)
			END DO
		END DO
		CLOSE(81)
		
!!!! 	TBV (Polygenic) coming from dam
		teller = 0
		DO i = 1, NrMating 
			DO j = 1, noff_male
			teller = teller + 1
				DO k = 2, ntraits
					TBV(teller,k) = TBV(teller,k) + 0.5*Polygenic_TBV_Dam(Dams_mating(i),k+1)
					TBV_test(teller,(((k-1)*7)+5)) = 0.5*Polygenic_TBV_Dam(Dams_mating(i),k+1)
				END DO
			END DO
		END DO
		
		DO i = 1, NrMating 
			DO j = 1, noff_female
			teller = teller + 1
				DO k = 2, ntraits
					TBV(teller,k) = TBV(teller,k) + 0.5*Polygenic_TBV_Dam(Dams_mating(i),k+1)
					TBV_test(teller,(((k-1)*7)+5)) = 0.5*Polygenic_TBV_Dam(Dams_mating(i),k+1)
				END DO
			END DO
		END DO
		
!!!!	Mendelian sampling term from dam		
		DO i = 2, ntraits
			DO j = 1, NrMating*noff
				TBV(j,i) = TBV(j,i) + gasdev(iseed) * sqrt(0.25 * VarComp(i,1))
				TBV_test(j,(((i-1)*7)+6)) = TBV(j,i) - TBV_test(j,(((i-1)*7)+5))- TBV_test(j,(((i-1)*7)+4))- TBV_test(j,(((i-1)*7)+3))- TBV_test(j,(((i-1)*7)+2)) - TBV_test(j,(((i-1)*7)+1))
				TBV_test(j,(((i-1)*7)+7)) = TBV(j,i)
			END DO
		END DO

!!!!!	Environmental component
		ALLOCATE(Env(NrMating*noff, ntraits))
		Env = -99
		
		DO i = 2, ntraits
			DO j = 1, (NrMating*noff)
				Env(j,i) = gasdev(iseed) * sqrt(VarComp(i,2))
			END DO
		END DO

		ALLOCATE(Phen(NrMating*noff, ntraits))
		Phen = -99

		DO i = 2, ntraits	
			Phen(:,i) = TBV(:,i) + Env(:,i)
		END DO
	
		ALLOCATE(Phen_Missing(ntraits*3))
		Phen_Missing = -99.
		
		TBV_File = '4wayCB_' // trim(Title) // '_TBV.txt'
		Proportion_FILE = '4wayCB_' // trim(Title) //'_Proportion_PGD.txt'
	
		OPEN(UNIT=33, FILE=Phenotype_File, ACTION='WRITE', STATUS='UNKNOWN')
		OPEN(UNIT=38, FILE=SelCan_File, ACTION='WRITE', STATUS='UNKNOWN')
		OPEN(UNIT=71, FILE=TBV_File, ACTION='WRITE', STATUS='UNKNOWN')
		OPEN(UNIT=73, FILE=Proportion_FILE, ACTION='WRITE', STATUS='UNKNOWN')	

		DO i = 1, (NrMating*noff)
			WRITE(33,'(I10,X,14(F15.7,X))') ID_offspring(i), TBV(i,:), Env(i,:), Phen(i,:), 1.
			WRITE(71,'(28(F12.6,X))') TBV_test(i,:)
			WRITE(73,'(X,F12.0, X, F12.8)') Loci_PGD(i), Loci_PGD(i)/nQTL
			WRITE(38,'(I10,X,14(F15.7,X))') ID_offspring(i), Phen_Missing(:), 1.
		END DO
		CLOSE(33)
		CLOSE(71)
		CLOSE(73)	
		CLOSE(38)
	END IF
END IF	



!!!!! General statistics of simulation
WRITE(*,*) '************************************************************************'
WRITE(*,*) 'Generate general statistics of simulated phenotypes' 
		
OPEN(UNIT=72, FILE=Statistics_File, STATUS='UNKNOWN', ACTION='WRITE')

DO i = 1, ntraits
	Sum_TBV = 0
	Sum_E = 0
	Sum_Phen = 0
	DO j = 1, (NrMating*noff)
		Sum_TBV = Sum_TBV + TBV(j,i)
		Sum_E = Sum_E + Env(j,i)
		Sum_Phen = Sum_Phen + Phen(j,i)
	END DO
	WRITE(72,'(6(F16.8,X))') Sum_TBV/(NrMating*noff), var((NrMating*noff),TBV(:,i)), Sum_E/(NrMating*noff), var((NrMating*noff),Env(:,i)), Sum_Phen/(NrMating*noff), var((NrMating*noff),Phen(:,i))
END DO
		
Contains

! -------------------------------------------------------------------------------------------------------------------------------------------------	
! Subroutine perm
! -------------------------------------------------------------------------------------------------------------------------------------------------	

	
      subroutine perm(s,iseed)
      implicit none
      INTEGER (KIND=4), DIMENSION (:) :: s
      integer :: p(size(s,1))
      integer :: n,i,j,k,jj,ii,istart,last,iseed
      REAL(KIND=4) :: ran2

      n=size(s,1)
      do 1 i=2,n
1       p(i-1)=i
      istart=1
      p(n)=0
      j=0
      do 2 i=n,2,-1
         k=int(ran2(iseed)*i)+1
         j=j+1
         if(k.eq.1) then
            s(j)=istart
            istart=p(istart)
            else
               jj=istart
               do 3 ii=1,k-1
                  last=jj
3                jj=p(jj)
               s(j)=jj
               p(last)=p(jj)
               endif
2      continue
      s(n)=istart
      return
      end subroutine perm
! -------------------------------------------------------------------------------------------------------------------------------------------------	

! -------------------------------------------------------------------------------------------------------------------------------------------------	
! Subroutine ggnml
! -------------------------------------------------------------------------------------------------------------------------------------------------	
	  
	subroutine ggnml(iseed,n,a)
	IMPLICIT NONE
	REAL, DIMENSION (:) :: a
	REAL :: NINT,b,gasdev2
	INTEGER :: iseed,n,l,i,nn

	nn=nint(n/2.)
	l=0
	do i=1,nn
		a(l+1)=gasdev2(iseed,b)
		if(L+2.le.n)a(l+2)=b
			l=l+2
	end do
	return
	end subroutine ggnml

! -------------------------------------------------------------------------------------------------------------------------------------------------	

! -------------------------------------------------------------------------------------------------------------------------------------------------	
! Subroutine bend_matrix
! -------------------------------------------------------------------------------------------------------------------------------------------------	

subroutine bend_matrix(n, a)
 use eig_m
 implicit none
 !declarations
 INTEGER :: n, i, j, k, l
 INTEGER :: br, ncpu
 REAL(KIND=4), DIMENSION(n, n) :: a
 REAL(KIND=8), DIMENSION(n, n) :: U !, D
 !local
 REAL(KIND=8) :: myone = 1.d0
 REAL(KIND=8) :: myzero = 0.d0
 REAL(KIND=8), DIMENSION(n) :: ev , D, diff
 REAL(KIND=8), DIMENSION(n, n) :: ai
 REAL(KIND=8) :: ev_min, tmp, epsilon, min_val, tmp_a
! LOGICAL :: skip_eig_value
 LOGICAL, DIMENSION(n) :: adjusted
 
	epsilon = 10e-6
	U = a
    call eig(U, ev, 'vectors') !output: U is matrix of eigenvectors; ev is vector with eigenvalues
	
    ev_min=minval(ev)
!    print *,' The minimum eigenvalue before bending the G-matrix is ',ev_min
    if(ev_min < epsilon)then
		l = 0
        do
			l = l + 1
			D = 0.0
			min_val = epsilon
			adjusted = .false.
			diff = .0
			do i=1,n
				if ( ev(i) <= epsilon ) then
					adjusted(i) = .true.
					D(i) = sqrt(epsilon)
					diff(i) = epsilon - ev(i)
				else		 
					D(i) = sqrt(ev(i))
				end if	 
			end do
 !         a = matmul( U , matmul ( D, transpose ( U )  ) )	!this requires 2 x n^3 multiplications - 1/2 x ( n^2 + n^3 ) after "tuning" => but this option requires to store another n x n matrix
!		  a = 0.0
		  !the following requires "only" 1/2 x ( n + n^3 ) multiplications
!	      do i = 1, n
!	        do j = 1, n
!		      U(i,j) = U(i,j) * D(j)
!		    end do
!		  end do
		  !memory used could be reduced by storing a as a vector
			do i = 1, n
				do j = 1, i !n
					tmp_a = a(i,j)
					do k = 1, n
						if ( adjusted(k)) then
							tmp_a = tmp_a + (U(i,k) * diff(k) * U(j,k))
						end if
					end do
					a(i,j) = tmp_a
					a(j,i) = tmp_a
				end do
			end do		  
			U = a
			
			call eig(U, ev, 'vectors') !output: a is matrix of eigenvectors; ev is vector with eigenvalues
		
			ev_min=minval(ev)
	
			IF (2*ev_min > epsilon) then
				EXIT
			ELSE 
				print *,' Number of times this matrix is bended: ',l,ev_min
			END IF
 			
		end do
	end if

 end subroutine bend_matrix


End program NewGen


!!=================================================================================================================================================
!! 					FUNCTIES
!!=================================================================================================================================================

! -------------------------------------------------------------------------------------------------------------------------------------------------	
! Functie RAN2, nodig voor de subroutine perm
! -------------------------------------------------------------------------------------------------------------------------------------------------	
	  
      FUNCTION RAN2(IDUM)
!  c     RAN2, Numerical Recepes 2dn edition 1992
!      implicit none
      INTEGER :: idum,IM1,IM2,IMM1,IA1,IA2,IQ1,IQ2,IR1,IR2,NTAB,NDIV
      REAL :: AM,EPS,RNMX
      REAL(KIND=4) :: RAN2  !RAN2 added
      PARAMETER (IM1=2147483563,IM2=2147483399,AM=1./IM1,IMM1=IM1-1,  &
     IA1=40014,IA2=40692,IQ1=53668,IQ2=52774,IR1=12211,IR2=3791,     &
     NTAB=32,NDIV=1+IMM1/NTAB,EPS=1.2e-7,RNMX=1.-EPS)
     INTEGER :: idum2,j,k,iv(NTAB),iy
      SAVE iv,iy,idum2
      DATA idum2/123456789/, iv/NTAB*0/, iy/0/
      if (idum.le.0) then
          idum=max(-idum,1)
          idum2=idum
          do 11 j=NTAB+8,1,-1
            k=idum/IQ1
            idum=IA1*(idum-k*IQ1)-k*IR1
            if (idum.lt.0) idum=idum+IM1
            if (j.le.NTAB) iv(j)=idum
11      continue
          iy=iv(1)
      endif
      k=idum/IQ1
      idum=IA1*(idum-k*IQ1)-k*IR1
      if (idum.lt.0) idum=idum+IM1
      k=idum2/IQ2
      idum2=IA2*(idum2-k*IQ2)-k*IR2
      if (idum2.lt.0) idum2=idum2+IM2
      j=1+iy/NDIV
      iy=iv(j)-idum2
      iv(j)=idum
      if(iy.lt.1)iy=iy+IMM1 !problem: iy has no value
      ran2=min(AM*iy,RNMX)
      return
      END FUNCTION	

! -------------------------------------------------------------------------------------------------------------------------------------------------	
! Functie GASDEV, trekt random getallen uit een normale verdeling
! -------------------------------------------------------------------------------------------------------------------------------------------------	
		
	        FUNCTION GASDEV(IDUM)
!       Returns a normally distributed deviate with zero mean and unit variance,
!         using RAN2(IDUM) as the source of uniform deviates
        implicit none
        INTEGER :: IDUM,ISET
        REAL(KIND=8) :: GASDEV,V1,V2,FAC,R,GSET
		REAL(KIND=4) :: RAN2
!         DATA ISET/0/
!         IF (ISET.EQ.0) THEN
801              V1=2.*RAN2(IDUM)-1.
                   V2=2.*RAN2(IDUM)-1.
                R=V1**2+V2**2
                IF(R.GE.1..OR.R.EQ.0.)GO TO 801
                FAC=SQRT(-2.*LOG(R)/R)
                GSET=V1*FAC
                GASDEV=V2*FAC
                ISET=1
!        ELSE
!                 GASDEV=GSET
!        ISET=0
!         END IF
        RETURN
          END function
!  (C) Copr. 1986-92 Numerical Recipes Software 6!+'21%0{%&1++L)*


      FUNCTION GASDEV2(IDUM,gset)
      IMPLICIT NONE
      REAL :: V1,V2,R,FAC,GSET,GASDEV2
      REAL(KIND=4) :: RAN2
      INTEGER :: IDUM

1       V1=2.*RAN2(IDUM)-1.
        V2=2.*RAN2(IDUM)-1.
        R=V1**2+V2**2
        IF(R.GE.1.)GO TO 1
        FAC=SQRT(-2.*LOG(R)/R)
        GSET=V1*FAC
        GASDEV2=V2*FAC
      RETURN
      END FUNCTION
	  
! -------------------------------------------------------------------------------------------------------------------------------------------------	
! Functie Var, berekent de variantie
! -------------------------------------------------------------------------------------------------------------------------------------------------	
	  
	FUNCTION VAR(n,arr1)

	IMPLICIT NONE
	integer :: i,n
	REAL(KIND=4), dimension(n) :: arr1
	REAL(KIND=4) :: sumx,sumx2,sumy,sumy2,sumxy2
	REAL(KIND=4) :: var

	sumx=0.0; sumx2=0.0; sumy=0.0; sumy2=0.0; sumxy2=0.0
	do i=1,n
		sumx=sumx+arr1(i)
		sumx2=sumx2+arr1(i)**2
	end do
	
	var=0.0
	var=(sumx2-sumx**2/n)/(n-1)

	END FUNCTION

