m_qtlmap_genealogy
NAME
m_qtlmap_genealogy -- Genealogy routines.
SYNOPSIS
DESCRIPTION
NOTES
SEE ALSO
calculCd
[ Top ] [ m_qtlmap_genealogy ] [ Variables ]
NAME
calculCd
DESCRIPTION
Indicates the calculus of censured data (asked by the user).
genea_list
[ Top ] [ m_qtlmap_genealogy ] [ Variables ]
NAME
genea_list
DESCRIPTION
Get information from genealogy file
DIMENSIONS
number of animal with the genealogy information 3 : 1 -> ID ANIMAL, 2 -> SIRE, 3 -> DAM
genea_niv
[ Top ] [ m_qtlmap_genealogy ] [ Variables ]
NAME
genea_niv
DESCRIPTION
Get the genealogy (0 grand-parents, 1, parents, 2 progeny)
DIMENSIONS
number of animal with the genealogy information
genealogy_outbred_gen
[ Top ] [ m_qtlmap_genealogy ] [ Variables ]
NAME
genealogy_outbred_gen
DESCRIPTION
Indicates the outbred generation in simulation case.
rac
[ Top ] [ m_qtlmap_genealogy ] [ Variables ]
NAME
rac
DESCRIPTION
Race parents or race founders
DIMENSIONS
CREATE_STRUCT_GRAND_PARENT
[ Top ] [ m_qtlmap_genealogy ] [ Subroutines ]
NAME
CREATE_STRUCT_GRAND_PARENT
DESCRIPTION
Fill ngp,ngm,ngmgp,nrgm,repro,gpere,gmere arrays from the information readed (genea_list,genea_niv).
INPUTS
nb_max_indiv : get the number of animal defined in the genalogy file
NOTES
SOURCE
239 SUBROUTINE CREATE_STRUCT_GRAND_PARENT(nb_max_indiv) 240 integer,intent(in) :: nb_max_indiv 241 !local 242 character(len=LEN_DEF) :: ind 243 character(len=LEN_DEF) :: father 244 character(len=LEN_DEF) :: mother 245 integer :: gen,alloc_stat,l,i,ir1 246 character(len=LEN_DEF) :: word_token 247 character(len=LEN_LINE) :: line_read 248 249 ! nombre de gd meme par gd pere : dim nbre gp 250 integer , dimension (:),allocatable :: ngmgp_t 251 ! nombre de parent par gd mere 252 integer , dimension (:),allocatable :: nrgm_t 253 254 character(len=LEN_DEF) , dimension (:),allocatable ::gmere_t 255 character(len=LEN_DEF) , dimension (:),allocatable ::gpere_t 256 character(len=LEN_DEF) , dimension (:),allocatable ::repro_t 257 character(len=LEN_DEF) , dimension (:),allocatable ::reprop_t 258 character(len=LEN_DEF) , dimension (:),allocatable ::reprom_t 259 character(len=LEN_DEF) , dimension (:),allocatable ::racep_t 260 character(len=LEN_DEF) , dimension (:),allocatable ::racem_t 261 logical :: is_ok 262 263 call log_mess('SUBROUTINE : CREATE_STRUCT_GRAND_PARENT',DEBUG_DEF) 264 ! Initialize Buffer with the indiv max 265 ALLOCATE (ngmgp_t(nb_max_indiv), stat = alloc_stat) 266 CALL check_allocate(alloc_stat) 267 268 ALLOCATE (nrgm_t(nb_max_indiv), stat = alloc_stat) 269 CALL check_allocate(alloc_stat) 270 271 ALLOCATE (gmere_t(nb_max_indiv), stat = alloc_stat) 272 CALL check_allocate(alloc_stat) 273 274 ALLOCATE (gpere_t(nb_max_indiv), stat = alloc_stat) 275 CALL check_allocate(alloc_stat) 276 277 ALLOCATE (reprop_t(nb_max_indiv), stat = alloc_stat) 278 CALL check_allocate(alloc_stat) 279 ALLOCATE (reprom_t(nb_max_indiv), stat = alloc_stat) 280 CALL check_allocate(alloc_stat) 281 ALLOCATE (repro_t(nb_max_indiv), stat = alloc_stat) 282 CALL check_allocate(alloc_stat) 283 ALLOCATE (racep_t(nb_max_indiv), stat = alloc_stat) 284 CALL check_allocate(alloc_stat) 285 ALLOCATE (racem_t(nb_max_indiv), stat = alloc_stat) 286 CALL check_allocate(alloc_stat) 287 288 nr = 0 ; ngp = 0 ; ngm = 0 289 ngmgp_t(1)=0 ; ngmgp_t(2)=0 ; nrgm_t(1)=0 ; nrgm_t(2)=0 290 !********------- GEN=1 ------********* 291 !lire old.. 292 !si gen==1 293 ind="" 294 295 if (genea_niv(1)>0) then 296 ind = trim(genea_list(1,1)) 297 father = trim(genea_list(1,2)) 298 mother = trim(genea_list(1,3)) 299 nr = 1 300 gpere_t(nr) = trim(genea_list(1,2)) 301 gmere_t(nr) = trim(genea_list(1,3)) 302 repro_t(nr) = trim(genea_list(1,1)) 303 reprop_t(nr) = trim(genea_list(1,2)) 304 reprom_t(nr) = trim(genea_list(1,3)) 305 racep_t(nr) = trim(rac(1,1)) 306 racem_t(nr) = trim(rac(1,2)) 307 ngp = 1 ; ngm = 1 308 nrgm_t(ngm+1)=nrgm_t(ngm+1)+1 309 ngmgp_t(ngp+1)=ngmgp_t(ngp+1)+1 310 end if 311 312 do l=2,genea_niv(1) 313 ind = trim(genea_list(l,1)) 314 father = trim(genea_list(l,2)) 315 mother = trim(genea_list(l,3)) 316 nr=nr+1 317 repro_t(nr) = ind 318 reprop_t(nr) = ind 319 reprom_t(nr) = ind 320 racep_t(nr) = trim(rac(l,1)) 321 racem_t(nr) = trim(rac(l,2)) 322 323 ! print *,'last gp:',trim(gpere_t(ngp)),' current:',trim(father) 324 ! print *,'last gm:',trim(gmere_t(ngm)),' current:',trim(mother) 325 !New grandfather and grandmother 326 IF ( gpere_t(ngp) /= father) THEN 327 !print *,'nvx gp:',trim(father) 328 ngm=ngm+1 329 nrgm_t(ngm+1)=nrgm_t(ngm)+1 330 gmere_t(ngm)=mother 331 ngp=ngp+1 332 gpere_t(ngp)=father 333 ! print *,'ngmgp_t[',ngp,']:',ngmgp_t(ngp) 334 ngmgp_t(ngp+1)=ngmgp_t(ngp)+1 335 336 !New grandmother 337 ELSE IF ( gmere_t(ngm) /= mother) THEN 338 !print *,'nvx gm:',trim(mother) 339 ngm=ngm+1 340 nrgm_t(ngm+1)=nrgm_t(ngm)+1 341 gmere_t(ngm)=mother 342 ngmgp_t(ngp+1)=ngmgp_t(ngp+1)+1 343 ELSE 344 nrgm_t(ngm+1)=nrgm_t(ngm+1)+1 345 ENDIF 346 END DO 347 348 !ALLOCATES TABLE AND DESALLOCATE BUFFER TAB 349 !------------------------------------------- 350 ALLOCATE (ngmgp(ngp+1), stat = alloc_stat) 351 CALL check_allocate(alloc_stat) 352 DO i=1,ngp+1 353 ngmgp(i) = ngmgp_t(i) 354 END DO 355 DEALLOCATE(ngmgp_t) 356 357 ALLOCATE (nrgm(ngm+1), stat = alloc_stat) 358 CALL check_allocate(alloc_stat) 359 DO i=1,ngm+1 360 nrgm(i) = nrgm_t(i) 361 END DO 362 DEALLOCATE(nrgm_t) 363 364 ALLOCATE (gmere(ngm), stat = alloc_stat) 365 CALL check_allocate(alloc_stat) 366 DO i=1,ngm 367 gmere(i) = gmere_t(i) 368 END DO 369 DEALLOCATE(gmere_t) 370 371 ALLOCATE (gpere(ngp), stat = alloc_stat) 372 CALL check_allocate(alloc_stat) 373 DO i=1,ngp 374 gpere(i) = gpere_t(i) 375 END DO 376 DEALLOCATE(gpere_t) 377 378 ALLOCATE (repro(nr), stat = alloc_stat) 379 CALL check_allocate(alloc_stat) 380 ALLOCATE (reprop(nr), stat = alloc_stat) 381 CALL check_allocate(alloc_stat) 382 ALLOCATE (reprom(nr), stat = alloc_stat) 383 CALL check_allocate(alloc_stat) 384 ALLOCATE (racep(nr), stat = alloc_stat) 385 CALL check_allocate(alloc_stat) 386 ALLOCATE (racem(nr), stat = alloc_stat) 387 CALL check_allocate(alloc_stat) 388 ALLOCATE (rep_reprop(nr), stat = alloc_stat) 389 CALL check_allocate(alloc_stat) 390 ALLOCATE (rep_reprom(nr), stat = alloc_stat) 391 CALL check_allocate(alloc_stat) 392 rep_reprop=0; rep_reprom=0 393 DO i=1,nr 394 repro(i) = repro_t(i) 395 reprop(i) = reprop_t(i) 396 reprom(i) = reprom_t(i) 397 racep(i) = racep_t(i) 398 racem(i) = racem_t(i) 399 !print *, 'RACE',i, repro(i), racep(i), racem(i) 400 do ir1=1,nr 401 if (reprop(i)==repro(ir1)) rep_reprop(i)=ir1 402 if (reprom(i)==repro(ir1)) rep_reprom(i)=ir1 403 if (rep_reprom(i).ne.0.and.rep_reprop(i).ne.0) exit 404 end do ! ir1label 405 END DO 406 DEALLOCATE(repro_t) 407 DEALLOCATE(reprop_t) 408 DEALLOCATE(reprom_t) 409 deallocate(rac) 410 call log_mess('END SUBROUTINE : CREATE_STRUCT_GRAND_PARENT',DEBUG_DEF) 411 END SUBROUTINE CREATE_STRUCT_GRAND_PARENT
CREATE_STRUCT_PARENT
[ Top ] [ m_qtlmap_genealogy ] [ Subroutines ]
NAME
CREATE_STRUCT_PARENT
DESCRIPTION
Fill ndm,nmp,pere,mere,animal,nd,nm,np arrays from the information readed (genea_list,genea_niv).
INPUTS
nb_max_indiv : get the number of animal defined in the genalogy file
NOTES
SOURCE
424 SUBROUTINE CREATE_STRUCT_PARENT(nb_max_indiv) 425 integer,intent(in) ::nb_max_indiv 426 427 428 character(len=LEN_DEF) ::ind 429 character(len=LEN_DEF) ::father 430 character(len=LEN_DEF) ::mother 431 integer ::gen,alloc_stat,err,eof,l,i,start 432 character(len=LEN_DEF) ::word_token 433 character(len=LEN_LINE) ::line_read 434 integer , dimension (:),allocatable :: ndm_t 435 integer , dimension (:),allocatable :: nmp_t 436 437 character(len=LEN_DEF) , dimension (:),allocatable ::mere_t 438 character(len=LEN_DEF) , dimension (:),allocatable ::pere_t 439 character(len=LEN_DEF) , dimension (:),allocatable ::animal_t 440 logical ::is_ok 441 442 call log_mess('SUBROUTINE : CREATE_STRUCT_PARENT',DEBUG_DEF) 443 444 if ( genea_niv(2) <= 0 ) then 445 call stop_application("none animals with generation 2 is detected"); 446 end if 447 448 !*** 449 ! Initialize Buffer with the indiv max 450 ALLOCATE (ndm_t(nb_max_indiv+1), stat = alloc_stat) 451 CALL check_allocate(alloc_stat) 452 453 ALLOCATE (nmp_t(nb_max_indiv+1), stat = alloc_stat) 454 CALL check_allocate(alloc_stat) 455 456 ALLOCATE (mere_t(nb_max_indiv), stat = alloc_stat) 457 CALL check_allocate(alloc_stat) 458 459 ALLOCATE (pere_t(nb_max_indiv), stat = alloc_stat) 460 CALL check_allocate(alloc_stat) 461 462 ALLOCATE (animal_t(nb_max_indiv), stat = alloc_stat) 463 CALL check_allocate(alloc_stat) 464 465 nd=1 466 nm=1 467 np=1 468 469 ndm_t(1)=0 470 ndm_t(2)=1 471 472 nmp_t(1)=0 473 nmp_t(2)=1 474 475 start = sum(genea_niv(:1)) 476 ind = trim(genea_list(start+1,1)) 477 father = trim(genea_list(start+1,2)) 478 mother = trim(genea_list(start+1,3)) 479 480 animal_t(nd) = ind 481 pere_t(np) = father 482 mere_t(nm) = mother 483 484 DO l=start+2,start+genea_niv(2) 485 ind = trim(genea_list(l,1)) 486 father = trim(genea_list(l,2)) 487 mother = trim(genea_list(l,3)) 488 nd = nd+1 489 animal_t(nd) = ind 490 491 IF ( pere_t(np) /= father ) THEN 492 nm = nm + 1 493 mere_t(nm)= mother 494 ndm_t(nm+1)=ndm_t(nm)+1 495 np=np+1 496 pere_t(np)=father 497 nmp_t(np+1)=nmp_t(np)+1 498 ELSE IF ( mere_t(nm) /= mother ) THEN 499 nm = nm + 1 500 mere_t(nm)= mother 501 ndm_t(nm+1)= ndm_t(nm)+1 502 nmp_t(np+1)= nmp_t(np+1)+1 503 ELSE 504 ndm_t(nm+1)=ndm_t(nm+1)+1 505 END IF 506 507 END DO 508 509 !ALLOCATES TABLE AND DESALLOCATE BUFFER TAB 510 !------------------------------------------- 511 ALLOCATE (ndm(nm+1), stat = alloc_stat) 512 CALL check_allocate(alloc_stat) 513 DO i=1,nm+1 514 ndm(i) = ndm_t(i) 515 END DO 516 DEALLOCATE(ndm_t) 517 518 ALLOCATE (nmp(np+1), stat = alloc_stat) 519 CALL check_allocate(alloc_stat) 520 DO i=1,np+1 521 nmp(i) = nmp_t(i) 522 END DO 523 DEALLOCATE(nmp_t) 524 525 ALLOCATE (mere(nm), stat = alloc_stat) 526 CALL check_allocate(alloc_stat) 527 DO i=1,nm 528 mere(i) = mere_t(i) 529 END DO 530 DEALLOCATE(mere_t) 531 532 ALLOCATE (pere(np), stat = alloc_stat) 533 CALL check_allocate(alloc_stat) 534 DO i=1,np 535 pere(i) = pere_t(i) 536 END DO 537 DEALLOCATE(pere_t) 538 ALLOCATE (animal(nd), stat = alloc_stat) 539 CALL check_allocate(alloc_stat) 540 DO i=1,nd 541 animal(i) = animal_t(i) 542 END DO 543 DEALLOCATE(animal_t) 544 545 546 call log_mess('END SUBROUTINE : CREATE_STRUCT_PARENT',DEBUG_DEF) 547 END SUBROUTINE CREATE_STRUCT_PARENT 548 549 !********************************************** 550 ! SUBROUTINE : CREATE_STRUCT_DERIVED_GENEALOGY 551 !********************************************** 552 SUBROUTINE CREATE_STRUCT_DERIVED_GENEALOGY () 553 554 integer :: alloc_stat 555 integer :: ip,im,ir,ifem,i 556 call log_mess('SUBROUTINE CREATE_STRUCT_DERIVED_GENEALOGY',DEBUG_DEF) 557 558 do ip=1,size(pere) 559 reppere(ip)=INT_NOT_DEFINED 560 do ir=1,size(repro) 561 if ( pere(ip) == repro(ir) ) then 562 reppere(ip)= ir 563 exit 564 endif 565 end do ! irlabel 566 end do ! iplabel 567 568 nfem=1 569 femelle(nfem)=mere(nfem) 570 do im=1,size(mere) 571 repmere(im)=INT_NOT_DEFINED 572 do ir=1,size(repro) 573 if ( mere(im) == repro(ir) ) then 574 repmere(im)= ir 575 exit 576 endif 577 end do ! irlabel 578 do ifem=1,nfem 579 if(mere(im).eq.femelle(ifem)) then 580 repfem(im)=ifem 581 exit 582 end if 583 end do 584 if (ifem > nfem) then 585 nfem=nfem+1 586 femelle(nfem)=mere(im) 587 repfem(im)=nfem 588 end if 589 end do ! iplabel 590 591 call log_mess('END SUBROUTINE CREATE_STRUCT_DERIVED_GENEALOGY',DEBUG_DEF) 592 END SUBROUTINE CREATE_STRUCT_DERIVED_GENEALOGY
log_debug_genea
[ Top ] [ m_qtlmap_genealogy ] [ Subroutines ]
NAME
log_debug_genea
DESCRIPTION
NOTES
SOURCE
917 subroutine log_debug_genea() 918 integer :: i,j,k 919 920 do i=1,ngp 921 print *,'------------------------------------------------' 922 print *,'index gp:',i,' ngmgp(',i,')=',ngmgp(i),' ngmgp(',(i+1),')=',ngmgp(i+1) 923 do j=ngmgp(i)+1,ngmgp(i+1) 924 925 do k=nrgm(j)+1,nrgm(j+1) 926 print *,k 927 print *,trim(repro(k)),' ',trim(gpere(i)),' ',trim(gmere(j)),' 1' 928 end do 929 end do 930 end do 931 end subroutine log_debug_genea
read_genealogy
[ Top ] [ m_qtlmap_genealogy ] [ Subroutines ]
NAME
read_traits
DESCRIPTION
Read the genealogy user file. In a computation of censure data case, the genealogy number (4th record) can be greater than 3 :
new traits values (and a censured data) are computated for each progeny which have progenies.
INPUTS
optcalculCd : indicates the computation of censured data
NOTES
SOURCE
95 SUBROUTINE read_genealogy(optcalculCd) 96 logical ,optional ,intent(in) :: optcalculCd 97 integer :: nb_max_indiv = 0 98 integer :: ios,eof,i,alloc_stat,j,niv, k,k1,k2,ip,jm 99 integer , parameter :: GENERATION_MAX=10 100 character(len=LEN_DEF) :: rac1,an,nom_race_t(30) 101 call log_mess('SUBROUTINE : read_genealogy',DEBUG_DEF) 102 call log_mess('reading genealogy file...',INFO_DEF) 103 104 105 106 if (present(optcalculCd)) calculCd = optcalculCd 107 108 allocate (genea_list(MAX_ANIMAL,3)) 109 allocate (genea_niv(GENERATION_MAX)) 110 allocate (rac(MAX_ANIMAL,2)) 111 genea_niv=0 112 rac='' 113 rac1='' 114 ios = 57 115 ! compte max indiv and check line 116 open(ios,file=in_genea) 117 eof = 0 118 i=1 119 nb_max_indiv=0 120 do while ( eof == 0 ) 121 read(ios,*,iostat=eof) (genea_list(i,j),j=1,3),niv 122 ! print *, 'eof=',eof,i, trim(rac(i,1)), trim(rac(i,2)) 123 if ( trim(genea_list(i,1)) /= '' .and. eof == 0 ) then 124 nb_max_indiv = nb_max_indiv+1 125 if (calculCd) then 126 if ( niv == 2 ) then 127 call add_animal_genea(datasetUser,genea_list(i,2),genea_list(i,3),genea_list(i,1),nb_max_indiv-sum(genea_niv(:1))) 128 else 129 call add_animal_genea(datasetUser,genea_list(i,2),genea_list(i,3),genea_list(i,1)) 130 end if 131 end if 132 i=i+1 133 if (niv < 1 .or. niv> GENERATION_MAX ) then 134 call stop_application("Bad definition of generation :"//trim(str(i))) 135 end if 136 genea_niv(niv) = genea_niv(niv)+1 137 end if 138 end do 139 close(ios) 140 if ( raceFileDefined ) then 141 ! lecture du fichier race 142 eof=0 143 open(ios,file=in_race) 144 do while ( eof == 0 ) 145 read(ios,*,iostat=eof) an, rac1 146 do j=1, genea_niv(1) 147 if (trim(an)==trim(genea_list(j,2))) rac(j,1)=rac1 148 if (trim(an)==trim(genea_list(j,3))) rac(j,2)=rac1 149 enddo 150 i=i+1 151 end do 152 close(ios) 153 ! identification du nombre de races dans le fichier 154 k=0 155 NB_RACES=1 156 nom_race_t='' 157 do j=1, genea_niv(1) 158 if (rac(j,1)==''.or.rac(j,2)=='') then 159 print *, 'Breed origin has to be given for all or no parents. There is a missing breed origin for parent ', & 160 trim(genea_list(j,1)) 161 stop 162 endif 163 k1=0; k2=0 164 do i=1, j-1 165 if (trim(rac(j,1)).ne.trim(rac(i,1)).and.trim(rac(j,1)).ne.trim(rac(i,2))) k1=k1+1 166 if (trim(rac(j,2)).ne.trim(rac(i,1)).and.trim(rac(j,2)).ne.trim(rac(i,2))) k2=k2+1 167 enddo 168 if (k1==j-1) then 169 k=k+1 170 nom_race_t(k)=trim(rac(j,1)) 171 endif 172 if (k2==(j-1).and.k1/=(j-1)) then 173 k=k+1 174 nom_race_t(k)=trim(rac(j,2)) 175 endif 176 enddo 177 NB_RACES=k 178 else 179 NB_RACES=1 180 rac='UNKNOWN' 181 end if 182 !$OMP PARALLEL DEFAULT(SHARED) NUM_THREADS(2) 183 !$OMP SECTIONS 184 !$OMP SECTION 185 CALL CREATE_STRUCT_GRAND_PARENT(nb_max_indiv) 186 !$OMP SECTION 187 CALL CREATE_STRUCT_PARENT(nb_max_indiv) 188 !$OMP END SECTIONS NOWAIT 189 !$OMP END PARALLEL 190 191 ! create repere 192 ALLOCATE (reppere(size(pere)), stat = alloc_stat) 193 CALL check_allocate(alloc_stat,'reppere') 194 ALLOCATE (repmere(size(mere)), stat = alloc_stat) 195 CALL check_allocate(alloc_stat,'repmere') 196 ALLOCATE (femelle(size(mere)), stat = alloc_stat) 197 CALL check_allocate(alloc_stat,'femelle') 198 ALLOCATE (repfem(size(mere)), stat = alloc_stat) 199 CALL check_allocate(alloc_stat,'repfem') 200 201 CALL CREATE_STRUCT_DERIVED_GENEALOGY() 202 call log_mess('NP='//trim(str(np)),VERBOSE_DEF) 203 call log_mess('NM='//trim(str(nm)),VERBOSE_DEF) 204 call log_mess('ND='//trim(str(nd)),VERBOSE_DEF) 205 call log_mess('END SUBROUTINE : read_genealogy',DEBUG_DEF) 206 207 deallocate (genea_list) 208 deallocate (genea_niv) 209 210 211 ALLOCATE (nom_race(NB_RACES), stat = alloc_stat) 212 CALL check_allocate(alloc_stat,'NB_RACES') 213 214 nom_race='UNKNOWN' 215 do k=1,NB_RACES 216 if ( raceFileDefined ) nom_race(k)=nom_race_t(k) 217 !print *,'NOM RACES ',nom_race(k) 218 enddo 219 ! do ip=1,np 220 ! print *,'RACE DES PARENTS DES PERES= ', ip ,pere(ip), reppere(ip), racep(reppere(ip)),racem(reppere(ip)) 221 ! do jm=nmp(ip)+1,nmp(ip+1) 222 ! print *,'RACE DES PARENTS DES MERES= ', jm, mere(jm),repmere(jm), racep(repmere(jm)),racem(repmere(jm)) 223 ! enddo 224 ! enddo 225 226 END SUBROUTINE read_genealogy
sim_genea
[ Top ] [ m_qtlmap_genealogy ] [ Subroutines ]
NAME
sim_genea
DESCRIPTION
Simulates a population according :
* number of dam by sire
* number of progenies by dam
* croisement type
INPUTS
inmp : number of dam by sire indm : number of progenies by dam croisement : OUTBRED_KEYWORD, F2_KEYWORD, BC_KEYWORD
NOTES
SOURCE
610 subroutine sim_genea(inmp,indm,croisement) 611 integer ,intent(in) :: inmp,indm 612 character(len=LEN_BUFFER_WORD),intent(in):: croisement 613 614 if ( croisement == OUTBRED_KEYWORD ) then 615 !ne necessite pas de regneration si une genealogie a deja ete creer 616 if ( .not. genealogy_outbred_gen ) then 617 call sim_genea_outbread(inmp,indm) 618 end if 619 else 620 call sim_genea_F2_BC(inmp,indm) 621 end if 622 623 end subroutine sim_genea
sim_genea_F2_BC
[ Top ] [ m_qtlmap_genealogy ] [ Subroutines ]
NAME
sim_genea_F2_BC
DESCRIPTION
INPUTS
inmp : number of dam by sire indm : number of progenies by dam
NOTES
Sous programme de simulation de la genealogie de la population: familles de tailles equilibrees np peres, nmp meres par pere et ndm descendants par mere
SOURCE
707 subroutine sim_genea_F2_BC(inmp,indm) 708 integer ,intent(in) :: inmp,indm 709 !Divers 710 integer ind,igp,jgm,ir,ip,jm,kr,ijm,nm1,nm2,kd,i,j 711 integer , dimension(:,:),allocatable :: ncr 712 integer , dimension(:),allocatable :: meres 713 real :: xcr 714 real,external :: ranf 715 ! 716 !****************************************************************************** 717 !****************************************************************************** 718 ! Dispositif F2 �quilibre 719 ! ngp=ngm=np, 1 male et inmp femelles par famille 720 ! nm*indm descendants 721 !****************************************************************************** 722 !****************************************************************************** 723 ! 724 ! 725 !************************************************************************** 726 ! Construction des numeros d'animaux : ind 727 ! 728 ! GRAND-PARENTS 729 ! 730 ! - 1 � ngp => gd peres 731 ! - ngp+1 a ngp+ngm => gd meres 732 !************************************************************************** 733 ! 734 ind=1 735 ! Initialisation des numeros des gd peres 736 ! 737 gpere(1)=str(ind) 738 ngmgp(1)=0 739 do igp=2,ngp 740 ind=ind+1 741 gpere(igp)=str(ind) 742 ! sexe(ind)=1 743 ! gener(ind)=0 744 ngmgp(igp)=ngmgp(igp-1)+1 !! 1 par defaut 745 end do 746 ngmgp(ngp+1)=ngmgp(ngp)+1 747 ! 748 ! Initialisation des numeros des gd peres 749 ! 750 nrgm(1)=0 751 do jgm=1,ngm 752 ind=ind+1 753 gmere(jgm)=str(ind) 754 ! sexe(ind)=2 755 ! gener(ind)=0 756 if(jgm.gt.1)nrgm(jgm)=nrgm(jgm-1)+1+inmp !! chaq couple F0 => 1pere+nmp meres 757 end do 758 nrgm(ngm+1)=nrgm(ngm)+1+inmp 759 ! 760 !************************************************************************** 761 ! REPRODUCTEURS 762 ! 763 ! - ngp+ngm +1 a ngp+ngm+nr => repro 764 !************************************************************************** 765 ! Initialisation 766 ! 767 allocate(meres(size(mere))) 768 ir=0 769 ip=0 770 jm=0 771 nmp(1)=0 772 ! 773 do igp=1,ngp 774 jgm=igp !! 1 couple F0, 775 ir=ir+1 776 ip=ip+1 777 ind=ind+1 778 ! 779 ! Creation des males F1 et tables de correspondaces peres 780 repro(ir)=str(ind) 781 pere(ip)=repro(ir) 782 ! reppere(ip)=ir 783 ! gener(ind)=1 784 ! sexe(ind)=1 785 if(ip.gt.1) nmp(ip)=nmp(ip-1)+inmp 786 ! write (1,1000) trim(repro(ir)),trim(gpere(igp)),trim(gmere(jgm)),' 1' 787 ! 788 ! Creation des femelles F1 789 do kr=1,inmp 790 ind=ind+1 791 jm=jm+1 792 ir=ir+1 793 repro(ir)=str(ind) 794 meres(jm)=ind 795 ! gener(ind)=1 796 ! sexe(ind)=2 797 ! write (1,1000) trim(repro(ir)),trim(gpere(igp)),trim(gmere(jgm)),' 1' 798 end do 799 end do 800 ! 801 ! Affectations des croisements F1 (BOURRIN) 802 allocate (ncr(np,inmp)) 803 do ijm=1,inmp 804 ip=1 805 !XXX xcr=g05caf(xcr) 806 xcr=ranf() 807 xcr=xcr*(np+1)+np*(ijm-1) 808 ncr(ip,ijm)=xcr 809 ! OFI: modif, sinon ncr(ip,ijm) peut valoir 0,vu que c est un index de tableaux..... 810 if (ncr(ip,ijm)==0) ncr(ip,ijm) = 1 811 do ip=2,np 812 if(ncr(ip-1,ijm).eq.np*ijm)then 813 ncr(ip,ijm)=1+np*(ijm-1) 814 else 815 ncr(ip,ijm)=ncr(ip-1,ijm)+1 816 end if 817 end do 818 end do 819 820 ! 821 ! Tables de correspondances meres 822 nmp(1)=0 823 do ip=1,np 824 if(ip.gt.1)nmp(ip)=nmp(ip-1)+inmp 825 do ijm=1,inmp 826 jm=nmp(ip)+ijm 827 mere(jm)=str(meres(ncr(ip,ijm))) 828 repfem(jm)=jm 829 ! do ir=1,nr 830 ! if(mere(jm).eq.repro(ir)) repmere(jm)=ir 831 ! end do 832 end do 833 end do 834 835 836 837 nfem=nm 838 nmp(np+1)=nmp(np)+inmp 839 ! 840 ! Descendants: genealogie et numeros 841 ndm(1)=0 842 do ip=1,np 843 nm1=nmp(ip)+1 844 nm2=nmp(ip+1) 845 do jm=nm1,nm2 846 if(jm.gt.1)ndm(jm)=ndm(jm-1)+indm 847 do kd=ndm(jm)+1,ndm(jm)+indm 848 ind=ind+1 849 animal(kd)=str(ind) 850 ! gener(ind)=2 851 ! sexe(ind)=2 852 ! xcr=g05caf(xcr) 853 ! if(xcr.gt.0.5)sexe(ind)=1 854 ! write (1,1000) trim(animal(kd)),trim(pere(ip)),trim(mere(jm)),' 2' 855 end do 856 end do 857 end do 858 ndm(nm+1)=ndm(nm)+indm 859 !1000 format(1x,a,1x,a,1x,a,1x,a3) 860 ! close(1) 861 862 deallocate (ncr) 863 deallocate(meres) 864 call CREATE_STRUCT_DERIVED_GENEALOGY 865 866 ! call log_debug_genea() 867 ! stop 868 869 end subroutine sim_genea_F2_BC
sim_genea_outbread
[ Top ] [ m_qtlmap_genealogy ] [ Subroutines ]
NAME
sim_genea_outbread
DESCRIPTION
INPUTS
inmp : number of dam by sire indm : number of progenies by dam
NOTES
SOURCE
637 subroutine sim_genea_outbread(inmp,indm) 638 integer ,intent(in) :: inmp,indm 639 640 integer :: ind,i,j,kd 641 642 ! creation of sires and parent o them 643 ngmgp(1)=0 644 nrgm(1)=0 645 ind = 1 646 do i=1,np 647 pere(i)=str(ind) 648 repro(i)=pere(i) 649 ind = ind + 1 650 gpere(i)=str(ind) 651 ind = ind +1 652 gmere(i)=str(ind) 653 ind = ind + 1 654 nrgm(i+1)=nrgm(i)+1 655 ngmgp(i+1)=ngmgp(i)+1 656 end do 657 ! dams 658 do i=1,nm 659 mere(i)=str(ind) 660 repro(np+i)=mere(i) 661 ind = ind + 1 662 gpere(np+i)=str(ind) 663 ind = ind +1 664 gmere(np+i)=str(ind) 665 ind = ind + 1 666 nrgm(np+i+1)=nrgm(np+i)+1 667 ngmgp(np+i+1)=ngmgp(np+i)+1 668 end do 669 !progeny 670 nmp(1)=0 671 ndm(1)=0 672 kd=1 673 674 do i=1,np 675 nmp(i+1)=nmp(i)+inmp 676 do j=nmp(i)+1,nmp(i+1) 677 ndm(j+1)=ndm(j)+indm 678 do kd=ndm(j)+1,ndm(j+1) 679 animal(kd) = str(ind) 680 ind = ind+1 681 end do 682 end do 683 end do 684 685 call CREATE_STRUCT_DERIVED_GENEALOGY 686 687 genealogy_outbred_gen = .true. 688 ! call log_debug_genea() 689 ! stop 690 691 end subroutine sim_genea_outbread
write_genea
[ Top ] [ m_qtlmap_genealogy ] [ Subroutines ]
NAME
write_genea
DESCRIPTION
INPUTS
file_name : path name of the output file
NOTES
SOURCE
883 subroutine write_genea(file_name) 884 character(len=*),intent(in) :: file_name 885 integer :: ip,jm,kr,jgm,igp,id 886 887 open(1,file=file_name) 888 889 call log_mess('TODO:write generation file for genealogy...') 890 do igp=1,ngp 891 do jgm=ngmgp(igp)+1,ngmgp(igp+1) 892 do kr=nrgm(jgm)+1,nrgm(jgm+1) 893 write (1,*) trim(repro(kr)),' ',trim(gpere(igp)),' ',trim(gmere(jgm)),' 1' 894 end do 895 end do 896 end do 897 do ip=1,np 898 do jm=nmp(ip)+1,nmp(ip+1) 899 do id=ndm(jm)+1,ndm(jm+1) 900 write (1,*) trim(animal(id)),' ',trim(pere(ip)),' ',trim(mere(jm)),' 2' 901 end do 902 end do 903 end do 904 close(1) 905 906 end subroutine write_genea