include 'eig.f90'

!! Reads in QMSim files, when assuming NOT all animals in the pedigree are in the genotype file
Program QMSim
use eig_m

IMPLICIT NONE

INTEGER :: i, j, k, io
INTEGER :: Generation, nwdr, Allel
INTEGER :: Gen, nGen, nInd, nIndGen
INTEGER :: nchr, GenSel, NrSireSel, NrDamSel
INTEGER :: nr_words, start
INTEGER :: ID, Sire, Dam
INTEGER :: nMale, nFemale
INTEGER :: nMarker, nQTL, nSNP, ncanQTL
INTEGER :: nbin_SNP, ncanSNP, nsel_bin
INTEGER :: tel1, tel2, teller
INTEGER :: seed, iseed
INTEGER :: chr
INTEGER :: nDam, nSire
INTEGER :: max_NR_read, rep_30, rest_nr
INTEGER :: nTrait
INTEGER, ALLOCATABLE, DIMENSION(:) :: words
INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ID_Male, ID_Female, ID_Sire, ID_Dam
INTEGER, ALLOCATABLE, DIMENSION (:) :: pat, mat, Geno
INTEGER, ALLOCATABLE, DIMENSION (:) :: CanQTL, sel, Sel_QTL, QTL_sel
INTEGER, ALLOCATABLE, DIMENSION (:) :: Sel_Sire, Sel_Dam
INTEGER, ALLOCATABLE, DIMENSION (:) :: CanSNP
INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: Genotypes_Male, Genotypes_Female
INTEGER, ALLOCATABLE, DIMENSION(:,:) :: Bin_SNP, Sel_SNP
INTEGER, ALLOCATABLE, DIMENSION(:,:) :: QTLGeno
INTEGER, ALLOCATABLE, DIMENSION (:) :: teller_bin, nsel_bin_vec, SNP_sel, QTL_SNP_sel

REAL :: Freq, position
REAL :: Bin_size
REAL :: r_1, r_2, r_3
REAL(KIND=8) :: gasdev
REAL :: var
REAL, ALLOCATABLE, DIMENSION(:) :: Rvalues, Temp
REAL, ALLOCATABLE, DIMENSION (:) :: h2, Sum_TBV, Var_TBV, Var_E, Var_Phen, Sum_Phen
REAL, ALLOCATABLE, DIMENSION (:) :: Count_Freq
REAL, ALLOCATABLE, DIMENSION (:,:) :: AFreq
REAL, ALLOCATABLE, DIMENSION (:,:) :: Chol_COR11, Chol_COR12, Chol_COR21, Chol_COR22, Chol_COR31, Chol_COR32
REAL, ALLOCATABLE, DIMENSION (:,:) :: CorMatrix1, CorMatrix2, CorMatrix3
REAL, ALLOCATABLE, DIMENSION (:,:) :: Effect, TBV, Env, Phen

CHARACTER(len=100) :: GenoIn_File, GenoUitQTL_males, GenoUitSNP_males, GenoUitQTL_females, GenoUitSNP_females, GenoUitSNP_males_females, GenoUit_males, GenoUit_females
CHARACTER(len=100) :: Data_File, Map_File, Freq_File, PhenoUit, QTLEffectsUit, VarComponents_File
CHARACTER(len=100) :: GenoUitQTL_males2, GenoUitSNP_males2, GenoUitQTL_females2, GenoUitSNP_females2, GenoUit_males2
CHARACTER(len=100) :: GenoUit_females2, GenoUitSNP_males_females2, PhenoUit2, QTLEffectsUit2, VarComponents_File2

CHARACTER(len=200) :: Line
CHARACTER(len=2) :: Sex
CHARACTER(len=20) :: dist_QTL, dist_SNP
CHARACTER(len=30) :: Name
CHARACTER(len=32) :: LineAfreq
CHARACTER(LEN=3) :: Overlap
CHARACTER(LEN=40) :: fformat

LOGICAL, ALLOCATABLE, DIMENSION(:) :: Male_Log, Female_Log, QTL_sel_log, SNP_sel_log

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

!!!! Input for the program
OPEN(UNIT=11, FILE='QMSimFortran.inp',ACTION='READ', STATUS='OLD')
READ(11,*) GenoIn_File
READ(11,*) GenoUitQTL_males, GenoUitSNP_males
READ(11,*) GenoUitQTL_females, GenoUitSNP_females
READ(11,*) GenoUit_males, GenoUit_females
READ(11,*) GenoUitSNP_males_females
READ(11,*) Data_File
READ(11,*) Map_File
READ(11,*) GenSel
READ(11,*) NrSireSel, NrDamSel
READ(11,*) Freq_File
READ(11,*) nQTL, dist_QTL, Overlap
READ(11,*) nSNP, dist_SNP, nbin_SNP
READ(11,*) nTrait
ALLOCATE(h2(nTrait))
IF(nTrait==2) then
	READ(11,*) h2(1), h2(2)
ELSE IF (nTrait==3) then
	READ(11,*) h2(1), h2(2), h2(3)
ELSE 
	READ(11,*) h2(1), h2(2), h2(3), h2(4)
END IF
IF(nTrait==2) then
	READ(11,*) r_1
ELSE IF (nTrait==3) then
	READ(11,*) r_1, r_2
ELSE
	READ(11,*) r_1, r_2, r_3
END IF	
READ(11,*) PhenoUit
READ(11,*) QTLEffectsUit
Read(11,*) VarComponents_File

CLOSE(11)

GenoUitQTL_males2 = 'NP/NP_' // trim(GenoUitQTL_males)
GenoUitSNP_males2 = 'NP/NP_' // trim(GenoUitSNP_males)
GenoUitQTL_females2 = 'NP/NP_' // trim(GenoUitQTL_females)
GenoUitSNP_females2 = 'NP/NP_' // trim(GenoUitSNP_females)
GenoUit_males2 = 'NP/NP_' // trim(GenoUit_males)
GenoUit_females2 = 'NP/NP_' // trim(GenoUit_females)
GenoUitSNP_males_females2 = 'NP/NP_' // trim(GenoUitSNP_males_females)
PhenoUit2 = 'NP/NP_' // trim(PhenoUit)
QTLEffectsUit2 = 'NP/' // trim(QTLEffectsUit)
VarComponents_File2 = 'NP/' // trim(VarComponents_File)


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

!!!! Count the number of individuals and generations in the pedigree file, save the sex of each individual
OPEN(UNIT=12, FILE=Data_File, STATUS='OLD', ACTION='READ')
READ(12,*)
Generation = 0
nInd = 0
nGen = 0
nIndGen=0 
ALLOCATE(words(6))

DO 
	READ(12,'(A200)',iostat=io) Line
	IF (io/=0) EXIT
	Call wordlength(Line, nwdr, words)
	READ(Line(1:words(1)),'(I12)') ID
	READ(Line(words(1)+1:words(2)),'(I12)') Sire
	READ(Line(words(2)+1:words(3)),'(I12)') Dam
	READ(Line(words(3)+1:words(4)),'(A2)') Sex
	READ(Line(words(4)+1:words(5)), '(I4)') Gen
	nInd = nInd + 1
	IF (Gen /= Generation) then
		nGen = nGen + 1
		Generation = Gen
	END IF 
END DO
REWIND(12)
nIndGen = nInd/nGen

WRITE(*,*) 'Number of individuals in the data file is ', nInd
WRITE(*,*) 'Number of generations in the data file is ', nGen
WRITE(*,*) 'Number of individuals per generation in the data file is ', nIndGen

!!!! Create logical vector with males and females
ALLOCATE(ID_Male(nIndGen,2))
ALLOCATE(ID_Female(nIndGen,2))

nMale = 0
nFemale = 0
ID_Male = 0
ID_Female = 0
teller = 0 

READ(12,*)
DO i = 1, nInd
	READ(12,'(A200)',iostat=io) Line
	IF (io/=0) EXIT
	Call wordlength(Line, nwdr, words)
	READ(Line(words(4)+1:words(5)), '(I4)') Gen
	IF(Gen == GenSel) then
		teller = teller + 1
		READ(Line(1:words(1)),'(I12)') ID
		READ(Line(words(1)+1:words(2)),'(I12)') Sire
		READ(Line(words(2)+1:words(3)),'(I12)') Dam
		READ(Line(words(3)+1:words(4)),'(A2)') Sex
		READ(Line(words(4)+1:words(5)), '(I4)') Gen
		IF(Sex == 'M') then
			nMale = nMale + 1
			ID_Male(nMale,1) = teller
			ID_Male(nMale,2) = ID
		ELSE IF (Sex == 'F') then
			nFemale = nFemale + 1
			ID_Female(nFemale,1) = teller
			ID_Female(nFemale,2) = ID
		END IF
	END IF 
END DO
REWIND(12)
nIndGen = nInd/nGen

WRITE(*,*) 'Number of males in the selected generation is ', nMale
WRITE(*,*) 'Number of females in the selected generation is ', nFemale

!!!! Randomly select males and females to produce the next generation

	ALLOCATE(sel(nMale))
	DO i = 1, nMale
		sel(i) = i
	END DO
	Call perm(sel(1:nMale), iseed)

	ALLOCATE(Sel_Sire(NrSireSel))
	DO i = 1, NrSireSel 
		Sel_Sire(i) = ID_Male(sel(i),1)
	END DO
	DEALLOCATE(sel)
	
	ALLOCATE(Male_Log(nIndGen))
	Male_Log = .FALSE.
	DO i = 1, NrSireSel
		Male_Log(Sel_Sire(i)) = .TRUE.
	END DO
	DEALLOCATE(Sel_Sire)
		
	ALLOCATE(sel(nFemale))
	DO i = 1, nFemale
		sel(i) = i
	END DO
	Call perm(sel(1:nFemale), iseed)
	ALLOCATE(Sel_Dam(NrDamSel))
	DO i = 1, NrDamSel 
		Sel_Dam(i) = ID_Female(sel(i),1)
	END DO
	DEALLOCATE(sel)
	
	ALLOCATE(Female_Log(nIndGen))
	Female_Log = .FALSE.
	DO i = 1, NrDamSel
		Female_Log(Sel_Dam(i)) = .TRUE.
	END DO
	DEALLOCATE(Sel_Dam)

ALLOCATE(ID_Sire(NrSireSel,2))
ALLOCATE(ID_Dam(NrDamSel,2))

nDam = 0
nSire = 0
teller = 0

READ(12,*)
DO i = 1, nInd
	READ(12,'(A200)',iostat=io) Line
	IF (io/=0) EXIT
	Call wordlength(Line, nwdr, words)
	READ(Line(words(4)+1:words(5)), '(I4)') Gen
	IF(Gen == GenSel) then
		teller = teller + 1
		READ(Line(1:words(1)),'(I12)') ID
		READ(Line(words(1)+1:words(2)),'(I12)') Sire
		READ(Line(words(2)+1:words(3)),'(I12)') Dam
		READ(Line(words(3)+1:words(4)),'(A2)') Sex
		READ(Line(words(4)+1:words(5)), '(I4)') Gen
		IF(Male_Log(teller)) then
			nSire = nSire + 1
			ID_Sire(nSire,1) = teller
			ID_Sire(nSire,2) = ID
		ELSE IF (Female_Log(teller)) then
			nDam = nDam + 1
			ID_Dam(nDam,1) = teller
			ID_Dam(nDam,2) = ID
		END IF
	END IF 
END DO
CLOSE(12)

WRITE(*,*) 'Number of sires to generate the next generation is ', nSire
WRITE(*,*) 'Number of dams to generate the next generation is ', nDam

!!!! Count the number of markers
nMarker = 0
OPEN(UNIT=13, FILE=Map_File, STATUS='OLD', ACTION='READ')
READ(13,*)
DO
	READ(13,*,iostat=io) 
	IF(io/=0) EXIT
	nMarker = nMarker + 1
END DO
CLOSE(13)

WRITE(*,*) 'Number of markers is ', nMarker	

!!!! Create genotype matrices with three dimensions: nrInd, nrMarkers, paternal of maternal haplotype
!!!! One matrix for males, one for females
ALLOCATE(Pat(nMarker))
ALLOCATE(Mat(nMarker))
ALLOCATE(Geno(nMarker*2))

Pat = 0
Mat = 0
tel1 = 0
tel2 = 0

DO i = 1, nMarker
	Pat(i) = i*2-1
	Mat(i) = i*2
END DO

ALLOCATE(Genotypes_Male(NrSireSel,nMarker,2))
ALLOCATE(Genotypes_Female(NrDamSel,nMarker,2))

OPEN(UNIT=14, FILE=GenoIn_File, STATUS='OLD', ACTION='READ')
READ(14,*)
DO i = 1, nIndGen
	READ(14,*) ID, Geno  
	IF((Male_Log(i)) .OR. (Female_Log(i))) then 
		IF (Male_Log(i)) then
			tel1 = tel1+1
			IF(ID_Sire(tel1,2) /= ID) then
				WRITE(*,*) 'Something wrong with genotype or data file - Sire' , i
				EXIT
			END IF
			Genotypes_Male(tel1,1:nMarker,1) = Geno(Pat)
			Genotypes_Male(tel1,1:nMarker,2) = Geno(Mat)
		ELSE IF (Female_Log(i)) then
			tel2 = tel2 + 1
			IF(ID_Dam(tel2,2) /= ID) then
				WRITE(*,*) 'Something wrong with genotype or data file - Dam', i 
				EXIT
			END IF
			Genotypes_Female(tel2,1:nMarker,1) = Geno(Pat)
			Genotypes_Female(tel2,1:nMarker,2) = Geno(Mat)
		END IF
	END IF
END DO

!!!! Compute allele frequencies from markers
ALLOCATE(Count_Freq(nMarker))
Count_Freq = 0.
DO i = 1, nMarker
	DO j = 1, NrSireSel
		Count_Freq(i) = Count_Freq(i) + real(Genotypes_Male(j,i,1))-1.
		Count_Freq(i) = Count_Freq(i) + real(Genotypes_Male(j,i,2))-1.
	END DO
	DO j = 1, NrDamSel
		Count_Freq(i) = Count_Freq(i) + real(Genotypes_Female(j,i,1))-1.
		Count_Freq(i) = Count_Freq(i) + real(Genotypes_Female(j,i,2))-1.
	END DO
END DO

ALLOCATE(AFreq(nMarker,2))
DO i = 1, nMarker
	AFreq(i,1) = i
	AFreq(i,2) = Count_Freq(i)/((NrSireSel+NrDamSel)*2)
END DO	

!!!! Select the candidate QTL from the markers
!!!! Candidate QTL should be segregating
teller = 0
ALLOCATE(CanQTL(nMarker))
DO i = 1, nMarker
	IF(AFreq(i,2) == 1.0000) CYCLE
	IF(AFreq(i,2) == 0.0000) CYCLE
	teller = teller+1	
	CanQTL(teller) = i
END DO
ncanQTL = teller

WRITE(*,*) 'The number of candidate QTL is ', ncanQTL
	
!!!! Select the QTL from the candidate QTL
IF (dist_QTL == 'Random') then
	ALLOCATE(sel(ncanQTL))
	DO i = 1, ncanQTL
		sel(i) = i
	END DO
	Call perm(sel(1:ncanQTL), iseed)
	ALLOCATE(Sel_QTL(nQTL))
	DO i = 1, nQTL 
		Sel_QTL(i) = CanQTL(sel(i))
	END DO
	DEALLOCATE(sel)
		
	ALLOCATE(QTL_sel_log(nMarker))
	QTL_sel_log = .FALSE.
	DO i = 1, nQTL
		QTL_sel_log(Sel_QTL(i)) = .TRUE.
	END DO
	
!!!! Write mapfile of QTL	
	OPEN(UNIT=13, FILE=Map_File, STATUS='OLD')
	OPEN(UNIT=16, FILE='NP/Mapfile_QTL.txt', STATUS='UNKNOWN',buffered='yes')
	READ(13,*)
	teller = 0	
	ALLOCATE(QTL_sel(nQTL))
	DO i = 1, nMarker
		READ(13,*) Name, Chr, position
		IF (QTL_sel_log(i)) then
			teller = teller+1
			QTL_sel(teller) = i
			WRITE(16,'(I10, X, A10, X, I2, X, F18.6, X, F18.2, X, F12.6, X, F12.6)') teller, Name, Chr, position, AFreq(i,1), AFreq(i,2), (1-AFreq(i,2))
		END IF
	END DO
	CLOSE(13)
	CLOSE(16)
	
!!!! Write genotype files for QTL, one file for males, one for females	
!!!! Create Matrix with Genotypes of QTL 

ALLOCATE(QTLGeno(NrSireSel+NrDamSel,nQTL+1))
QTLGeno=0

	OPEN(Unit=21, FILE=GenoUitQTL_males2, ACTION='WRITE', STATUS='UNKNOWN',buffered='yes')
	
	DO i=1,NrSireSel
		WRITE(21,'(I12,X, 30000(I1,X))') ID_Sire(i,2),Genotypes_Male(i,QTL_sel,1)
		QTLGeno(i,1) = ID_Sire(i,2)	
		QTLGeno(i,2:(nQTL+1)) = Genotypes_Male(i,QTL_sel,1)
		WRITE(21,'(I12,X, 30000(I1,X))') ID_Sire(i,2),Genotypes_Male(i,QTL_sel,2)
		QTLGeno(i,2:(nQTL+1)) = QTLGeno(i,2:(nQTL+1)) + Genotypes_Male(i,QTL_sel,2)-2
	END DO
	CLOSE(21)
	
	OPEN(Unit=22, FILE=GenoUitQTL_females2, ACTION='WRITE', STATUS='UNKNOWN',buffered='yes')
	DO i=1,NrDamSel
		WRITE(22,'(I12,X, 30000(I1,X))') ID_Dam(i,2),Genotypes_Female(i,QTL_sel,1)
		QTLGeno((NrSireSel+i),1) = ID_Dam(i,2)	
		QTLGeno((NrSireSel+i),2:(nQTL+1)) = Genotypes_Female(i,QTL_sel,1)
		WRITE(22,'(I12,X, 30000(I1,X))') ID_Dam(i,2),Genotypes_Female(i,QTL_sel,2)
		QTLGeno((NrSireSel+i),2:(nQTL+1)) = QTLGeno((NrSireSel+i),2:(nQTL+1)) + Genotypes_Female(i,QTL_sel,2)-2
	END DO
	CLOSE(21)
ELSE
	WRITE(*,*) 'Not possible to select QTL from this distribution'
END IF

!!!! Select candidate SNP from the markers
!!!! Overlap = Yes: SNPs can be QTL, Overlap = No: SNPs can not be QTL
ALLOCATE(CanSNP(nMarker))
ncanSNP = 0
teller = 0
IF(Overlap == 'Yes') then
	CanSNP = CanQTL
	ncanSNP = ncanQTL 
ELSE IF (Overlap == 'No') then
	DO i = 1, nMarker
		IF(QTL_sel_log(i)) CYCLE
		IF(AFreq(i,2) == 1.0000) CYCLE
		IF(AFreq(i,2) == 0.0000) CYCLE
		teller = teller+1	
		CanSNP(teller) = i
	END DO
	ncanSNP = teller
END IF
	
WRITE(*,*) 'The number of candidate SNP is ', ncanSNP


!!!! Select SNP from Uniform distribution
!!!! For this, the candidate SNPs have to be divided in bins, based on allele frequency	
If (Dist_SNP == 'Uniform') then	
	Bin_size = real(1) / real(nbin_SNP)
	WRITE(*,*) ' Size of the bins for selecting SNPs is ', Bin_size
	WRITE(*,*) ' Number of bins for selecting SNPs is ', nbin_SNP
	ALLOCATE(Bin_SNP(ncanSNP,(nbin_SNP)))
	ALLOCATE(teller_bin(nbin_SNP))
	teller_bin = 0
	Do i = 1, nMarker
		IF(QTL_sel_log(i)) CYCLE
		IF(AFreq(i,2) == 1.0000) CYCLE
		IF(AFreq(i,2) == 0.0000) CYCLE
		k = INT(AFreq(i,2)/Bin_size) + 1
		teller_bin(k) = teller_bin(k) + 1
		Bin_SNP(teller_bin(k),k) = AFreq(i,1)
	END DO
	
	OPEN(UNIT=31, FILE="NP/Number_SNPs_Bin.txt", STATUS='UNKNOWN', ACTION='WRITE')

!!!! Write file with distribution of candidate SNPs over the bins
	DO i = 1, nbin_SNP
		WRITE(31,'(i4,2x,i6)') i, teller_bin(i)
	END DO
	CLOSE(31)
	
!!!! If first or last bins contain not enough candidate SNPs, they are merged with the neighboring bins	
	nsel_bin = nSNP / nbin_SNP
	ALLOCATE(nsel_bin_vec(nbin_SNP))
	nsel_bin_vec = nsel_bin
	
	IF (teller_bin(1) < nsel_bin) then
		DO i = 1, teller_bin(1)
			teller_bin(2) = teller_bin(2) + 1
			Bin_SNP(teller_bin(2),2) = Bin_SNP(i,1)
			Bin_SNP(i,1) = 0
		END DO
		teller_bin(1) = 0
		nsel_bin_vec(1) = 0
		nsel_bin_vec(2) = 2 * nsel_bin
	END IF
	
	IF (teller_bin(nbin_SNP) < nsel_bin) then
		DO i = 1, teller_bin(nbin_SNP)
			teller_bin(nbin_SNP-1) = teller_bin(nbin_SNP-1) + 1
			Bin_SNP(teller_bin(nbin_SNP-1),nbin_SNP-1) = Bin_SNP(i,nbin_SNP)
			Bin_SNP(nbin_SNP,1) = 0
		END DO
		teller_bin(nbin_SNP) = 0
		nsel_bin_vec(nbin_SNP) = 0
		nsel_bin_vec(nbin_SNP-1) = 2 * nsel_bin
	END IF
	
!!!! Select the SNPs from the candidate SNPs
!!!! Select an equal amount from each of the bins
	ALLOCATE(Sel_SNP(nbin_SNP,nsel_bin*2))
	Do i = 1, nbin_SNP
		ALLOCATE(sel(1:teller_bin(i)))
		IF (teller_bin(i) == 0) then
			DEALLOCATE(sel)
			CYCLE
		END IF
		Do j = 1, teller_bin(i)
			sel(j) = j
		END DO
		Call perm(sel(1:teller_bin(i)), iseed)
		DO j = 1, nsel_bin_vec(i)
			Sel_SNP(i,j) = Bin_SNP(sel(j),i)
		END DO
		DEALLOCATE(sel)
	END DO

	ALLOCATE(SNP_sel_log(nMarker))
	SNP_sel_log = .FALSE.

	DO i = 1, nbin_SNP
		DO j = 1, nsel_bin_vec(i)
			SNP_sel_log(Sel_SNP(i,j)) = .TRUE.
		END DO
	END DO

!!!! Write mapfile of SNPs
	OPEN(UNIT=23, FILE=Map_File, STATUS='OLD')
	OPEN(UNIT=26, FILE='NP/Mapfile_SNP.txt', STATUS='UNKNOWN',buffered='yes')
	OPEN(UNIT=27, FILE='NP/Mapfile_QTL+SNP.txt', STATUS='UNKNOWN',buffered='yes')
	READ(23,*)
	teller = 0	
	ALLOCATE(SNP_sel(nSNP))
	DO i = 1, nMarker
		READ(23,*) Name, Chr, position
		IF (SNP_sel_log(i)) then
			teller = teller+1
			SNP_sel(teller) = i
			WRITE(26,'(I10, X, A10, X, I2, X, F18.6, X, F18.6, X, F12.6, X, F12.6)') teller, Name, Chr, position, AFreq(i,1), AFreq(i,2), (1-AFreq(i,2))
		END IF
	END DO
	REWIND(23)
	CLOSE(26)

	teller = 0
	ALLOCATE(QTL_SNP_sel(nSNP+nQTL))
	READ(23,*)
	DO i = 1, nMarker
		READ(23,*) Name, Chr, position
		IF (SNP_sel_log(i))then
			teller = teller+1
			QTL_SNP_sel(teller) = i
			WRITE(27,'(I10, X, A10, X, I2, X, F18.6, X, F18.6, X, F12.6, X, F12.6, X, I6)') teller, Name, Chr, position, AFreq(i,1), AFreq(i,2), (1-AFreq(i,2)), 0
		END IF
		IF (QTL_sel_log(i))then
			teller = teller+1
			QTL_SNP_sel(teller) = i
			WRITE(27,'(I10, X, A10, X, I2, X, F18.6, X, F18.6, X, F12.6, X, F12.6, X, I6)') teller, Name, Chr, position, AFreq(i,1), AFreq(i,2), (1-AFreq(i,2)), 1
		END IF
	END DO
	CLOSE(23)
	CLOSE(27)
	
!!!! Write genotype files for SNPs, one file for males, one for females, one for both males and females
	OPEN(Unit=24, FILE=GenoUitSNP_males2, ACTION='WRITE', STATUS='UNKNOWN',buffered='yes')
	OPEN(Unit=26, FILE=GenoUitSNP_males_females2, ACTION='WRITE', STATUS='UNKNOWN',buffered='yes')
		
	DO i=1,NrSireSel
		WRITE(24,'(I12,X, 30000(I1,X))') ID_Sire(i,2),Genotypes_Male(i,SNP_sel,1)
		WRITE(24,'(I12,X, 30000(I1,X))') ID_Sire(i,2),Genotypes_Male(i,SNP_sel,2)
		WRITE(26,'(I12,X, 30000(I1,X))') ID_Sire(i,2),Genotypes_Male(i,SNP_sel,1)
		WRITE(26,'(I12,X, 30000(I1,X))') ID_Sire(i,2),Genotypes_Male(i,SNP_sel,2)
	END DO
	CLOSE(24)
	
	OPEN(Unit=25, FILE=GenoUitSNP_females2, ACTION='WRITE', STATUS='UNKNOWN',buffered='yes')
	DO i=1,NrDamSel
		WRITE(25,'(I12,X, 30000(I1,X))') ID_Dam(i,2),Genotypes_Female(i,SNP_sel,1)
		WRITE(25,'(I12,X, 30000(I1,X))') ID_Dam(i,2),Genotypes_Female(i,SNP_sel,2)
		WRITE(26,'(I12,X, 30000(I1,X))') ID_Dam(i,2),Genotypes_Female(i,SNP_sel,1)
		WRITE(26,'(I12,X, 30000(I1,X))') ID_Dam(i,2),Genotypes_Female(i,SNP_sel,2)
	END DO
	CLOSE(25)
	CLOSE(26)

!!!! Write genotype files for SNPs and QTL, one file for males, one for females
	OPEN(Unit=51, FILE=GenoUit_males2, ACTION='WRITE', STATUS='UNKNOWN',buffered='yes')
		
	DO i=1,NrSireSel
		WRITE(51,'(I12,X, 30000(I1,X))') ID_Sire(i,2),Genotypes_Male(i,QTL_SNP_sel,1)
		WRITE(51,'(I12,X, 30000(I1,X))') ID_Sire(i,2),Genotypes_Male(i,QTL_SNP_sel,2)
	END DO
	CLOSE(51)
	
	OPEN(Unit=52, FILE=GenoUit_females2, ACTION='WRITE', STATUS='UNKNOWN',buffered='yes')
	DO i=1,NrDamSel
		WRITE(52,'(I12,X, 30000(I1,X))') ID_Dam(i,2),Genotypes_Female(i,QTL_SNP_sel,1)
		WRITE(52,'(I12,X, 30000(I1,X))') ID_Dam(i,2),Genotypes_Female(i,QTL_SNP_sel,2)
	END DO
	CLOSE(52)
	
ELSE
	WRITE(*,*) 'Not possible to select SNPs from this distribution'
END IF

!!!!! Create phenotypes
!!!!! Calculate Cholesky decomposition of the correlation matrix
	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

!!!!! Simulate effects of the QTL 
	ALLOCATE(Effect(nQTL, nTrait))
	ALLOCATE(Rvalues(2))
	ALLOCATE(Temp(2))
	
	DO i = 1, nQTL
		Call ggnml(iseed, 2, Rvalues(1:2))
		Effect(i,1:2) = matmul(Rvalues(1:2), Chol_COR12) 
		IF (nTrait>2) then
			Temp(1:2) = matmul(Rvalues(1:2), Chol_COR22)
			Effect(i,3) = Temp(2)
		END IF
		IF (nTrait>3) then
			Temp(1:2) = matmul(Rvalues(1:2), Chol_COR32)
			Effect(i,4) = Temp(2)
		END IF
	END DO
	
	OPEN(UNIT=51, FILE=QTLEffectsUit2, STATUS='UNKNOWN', ACTION='WRITE')
	
	DO i = 1, nQTL
		WRITE(51,'(I10, 4(F12.8,X))') i, Effect(i,1:nTrait)
	END DO
	CLOSE(51)

!!!!! Calculate TBV
	ALLOCATE(TBV((NrSireSel+NrDamSel),nTrait))
	ALLOCATE(Sum_TBV(nTrait))
	Sum_TBV = 0
	TBV = 0
	
	DO i = 1, NrSireSel+NrDamSel
		DO j = 1, nQTL
			DO k = 1, nTrait
				TBV(i,k) = TBV(i,k) + QTLGeno(i,1+j) *Effect(j,k)
			END DO
		END DO
		DO k = 1, nTrait
			Sum_TBV(k) = Sum_TBV(k) + TBV(i,k)
		END DO
	END DO
	
	ALLOCATE(Var_TBV(nTrait))
	DO k = 1, nTrait
		Var_TBV(k) = var((NrSireSel+NrDamSel),TBV(:,k))
	END DO

!!!! Sample environmental effect	
	ALLOCATE(Env((NrSireSel+NrDamSel),nTrait))
	DO i = 1, (NrSireSel+NrDamSel)
		DO k = 1, nTrait
			Env(i,k) = gasdev(iseed) * sqrt(((1/h2(k))-1)*Var_TBV(k))
		END DO
	END DO

	ALLOCATE(Var_E(nTrait))
	DO k = 1, nTrait
		Var_E(k) = var((NrSireSel+NrDamSel),Env(:,k))
	END DO

	ALLOCATE(Phen((NrSireSel+NrDamSel),nTrait))
	
	DO k = 1, nTrait
		Phen(:,k) = TBV(:,k) + Env(:,k)
	END DO
	
	ALLOCATE(Var_Phen(nTrait))
	DO k = 1, nTrait
		Var_Phen(k) = var((NrSireSel+NrDamSel),Phen(:,k))
	END DO
	
	OPEN(UNIT=52, FILE=PhenoUit2, ACTION='WRITE', STATUS='UNKNOWN')
	
	Do i = 1, (NrSireSel+NrDamSel)
		WRITE(52,'(I10,X,12(F15.7,X),X,I5)') QTLGeno(i,1), TBV(i,1:nTrait), Env(i,1:nTrait), Phen(i,1:nTrait), 1.0  
	END DO
	CLOSE(52)
	
	OPEN(UNIT=61, FILE=VarComponents_File2, ACTION='WRITE', STATUS='UNKNOWN')
	DO k = 1, nTrait
		WRITE(61,'(F12.7,X,F12.7,X,F12.7)') Var_TBV(k), Var_E(k), Var_Phen(k)
	END DO
	CLOSE(61)
	
	ALLOCATE(Sum_Phen(nTrait))
	Sum_Phen = 0
	DO i = 1, (NrSireSel+NrDamSel)
		DO k = 1, nTrait
			Sum_Phen(k) = Sum_Phen(k) + Phen(i,k)
		END DO
	END DO
	
	OPEN(UNIT=99, FILE='NP/VarComponents_Trait1.dat', ACTION='WRITE', STATUS='UNKNOWN')
	WRITE(99,'(A4)') 'mean' 
	WRITE(99,'(A4,X,F14.6)') 'Phen_1', Sum_Phen(1)/(NrSireSel+NrDamSel)
	WRITE(99,*)  
	WRITE(99,'(A1)') 'G' 
	WRITE(99,'(A14,X,F14.6)') 'Phen_1(animal)', Var_TBV(1)
	WRITE(99,*) 
	WRITE(99,'(A8)') 'residual' 
	WRITE(99,'(A6,X,F14.6)') 'Phen_1', Var_E(1)
	CLOSE(99)

	OPEN(UNIT=101, FILE='NP/VarComponents_Trait1.fix', ACTION='WRITE', STATUS='UNKNOWN')
	WRITE(101,'(A10,X,F14.6)') 've', Var_E(1)
	WRITE(101,*)  
	WRITE(101,'(A10,X,F14.6)') 'va', Var_TBV(1)
	CLOSE(101)
	
Contains
! -------------------------------------------------------------------------------------------------------------------------------------------------	
! Subroutine wordlength
! -------------------------------------------------------------------------------------------------------------------------------------------------	
Subroutine wordlength(sentence, nr_words, length)
IMPLICIT NONE
CHARACTER(LEN=200), INTENT(IN):: sentence
INTEGER, INTENT(OUT) :: nr_words
INTEGER, DIMENSION(6), INTENT(OUT) :: length

INTEGER :: i, stringlength
CHARACTER(LEN=1) :: lastchar

stringlength = LEN(sentence)
nr_words = 0
lastchar = ' '
length = 0

do i=1,stringlength
   if ( (lastchar .EQ. ' ') .AND. (sentence(I:I) .NE. ' ') ) then
      ! a blank followed by another character indicates the start of a new word
      nr_words = nr_words + 1
!	print *, nr_words, i
	  IF((nr_words .GT. 1) .AND. (nr_words .LE. 6)) then
			length(nr_words-1) = i-1
		END IF
		IF (nr_words .GT. 6) EXIT
   end if
   lastchar = sentence(I:I)
end do

end subroutine wordlength

! -------------------------------------------------------------------------------------------------------------------------------------------------	
! 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

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

End program QMSim

!!=================================================================================================================================================
!! 					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
