혈통 파일 리넘버링 하기

혈통 파일을 유전평가할 때 연속된 번호로 리넘버 해야할 때가 있다.

 

혈통 파일에 오류가 없고, 세대순으로 정렬되어 있다고 가정

 

프로그램

 

PROGRAM pedi_renumber

! program name : pedi_renumber
! programmer : Park Byoungho
! usage : pedi_renumber pedigree_file
! purpose : read pedigree file, write renumbered pedigree file
! Pedigree file must be sorted by generation
! date : 2009.12.4.

IMPLICIT NONE

INTEGER, PARAMETER :: I4 = SELECTED_INT_KIND(9) ! 4 byte 정수 정의

! store animla, serial_num
TYPE list_node
CHARACTER(LEN = 32) :: key
INTEGER(KIND = I4) :: serial_num
TYPE(list_node), POINTER :: next
END TYPE list_node

! to create array of pointer
TYPE list_head
TYPE(list_node), POINTER :: next
END TYPE list_head

! bucket size
INTEGER, PARAMETER :: HASHSIZE = 65536_I4

! define bucket of hash
TYPE(list_head), DIMENSION(HASHSIZE) :: bucket

!main

! data dictionary
INTEGER(KIND = I4) :: i ! for loop when reading pedigree data
INTEGER :: j ! for loop, maximum iteration for making generation
CHARACTER(LEN = 32) :: key, sire, dam ! for reading each data line
INTEGER(KIND = I4) :: renum_key, renum_sire, renum_dam ! renumbered animal, sire and dam
TYPE(list_node), POINTER :: node, ptr
CHARACTER(LEN = 256) :: in_filename
INTEGER :: status ! I/O status
CHARACTER(LEN = 256) :: error_msg ! error message

CALL init_bucket()

CALL get_command_argument(1, in_filename) ! get pedigree data filename from the command line

! open data file and store data to hash
OPEN(UNIT = 20, FILE = in_filename, STATUS = 'OLD', ACTION = 'READ', IOSTAT = status, IOMSG = error_msg)

IF (status /= 0) THEN ! file open failed
WRITE (*,'(1X, A, A)') 'Data file open failed -- error message : ', error_msg
STOP
END IF

! open animal - serial number data file
OPEN(UNIT = 30, FILE = TRIM(in_filename) // '.as', STATUS = 'REPLACE', ACTION = 'WRITE')
! open renumbered pedigree data file
OPEN(UNIT = 40, FILE = TRIM(in_filename) // '.rp', STATUS = 'REPLACE', ACTION = 'WRITE')
! open pedigree cyclic error data file
OPEN(UNIT = 50, FILE = TRIM(in_filename) // '.pc', STATUS = 'REPLACE', ACTION = 'WRITE')

! read pedigree and make hash
i = 1
DO
READ(UNIT = 20, FMT = *, IOSTAT = status) key, sire, dam
IF (status /= 0) EXIT ! end of file

WRITE(30,*) key, i
CALL add_node(key, i)
i = i + 1
END DO

REWIND(20)

! renumber pedigree
DO
READ(UNIT = 20, FMT = *, IOSTAT = status) key, sire, dam
IF (status /= 0) EXIT ! end of file

! look up the serial number of key
CALL lookup(key, node)
renum_key = node%serial_num

! look up the serial number of sire
IF (sire == '0') THEN
renum_sire = 0
ELSE
CALL lookup(sire, node)
renum_sire = node%serial_num
END IF

! look up the serial number of dam
IF (dam == '0') THEN
renum_dam = 0
ELSE
CALL lookup(dam, node)
renum_dam = node%serial_num
END IF

! see if pedigree cyclic error
IF (renum_key <= renum_sire .OR. renum_key <= renum_dam) THEN
WRITE(50,*) key, sire, dam
END IF

WRITE(40,*) key, sire, dam, renum_key, renum_sire, renum_dam
END DO

CLOSE(20)
CLOSE(30)
CLOSE(40)
CLOSE(50)

CALL clear_bucket()

CONTAINS

FUNCTION hash(key)
INTEGER(KIND = I4) :: hash
CHARACTER(LEN = 32), INTENT(IN) :: key
INTEGER :: i, keylen, uv
INTEGER(KIND = I4) :: hashval

hashval = 5381
keylen = LEN_TRIM(key)
DO i = 1, keylen
!uv = MOD(hashval * 33, 65536_I4)
hashval = MOD(hashval * 33 + IACHAR(key(i:i)), 65536_I4) + 1
END DO
hash = hashval
END FUNCTION

SUBROUTINE init_bucket()
INTEGER :: i
DO i = 1, HASHSIZE
NULLIFY(bucket(i)%next)
END DO
END SUBROUTINE

SUBROUTINE lookup(key, node)
TYPE(list_node), POINTER, INTENT(OUT) :: node
CHARACTER(LEN = 32), INTENT(IN) :: key

node => bucket(hash(key))%next
DO
IF(.NOT. ASSOCIATED(node)) EXIT
IF(node%key == key) EXIT
node => node%next
END DO
END SUBROUTINE lookup

SUBROUTINE add_node(key, serial_num)
CHARACTER(LEN = 32), INTENT(IN) :: key
INTEGER(KIND = I4), INTENT(IN) :: serial_num
TYPE(list_node), POINTER :: node, tmp
INTEGER(KIND = I4) :: hv, err

hv = hash(key)

IF(.NOT. ASSOCIATED(bucket(hv)%next)) THEN ! if bucket(hv) is empty, i.e. no data at bucket(hv)
ALLOCATE(node, STAT = err)
IF(err /= 0) STOP 'Error : no memory'

NULLIFY(node%next)
node%key = key
node%serial_num = serial_num
bucket(hv)%next => node
ELSE ! if bucket(hv) is not empty, i.e. some data at bucket(hv)

node => bucket(hv)%next
DO ! see if animal is in the hash
IF(node%key == key) THEN ! if there is already an animal in the hash
EXIT
ELSE ! to reach the end of each bucket
IF(ASSOCIATED(node%next)) THEN
node => node%next
ELSE
ALLOCATE(tmp, STAT = err)
IF(err /= 0) STOP 'Error : no memory'
NULLIFY(tmp%next)

tmp%key = key
tmp%serial_num = serial_num
node%next => tmp

EXIT
END IF
END IF
END DO
END IF
END SUBROUTINE

SUBROUTINE del_list(node)
TYPE(list_node), POINTER :: node, tmp
DO
IF (ASSOCIATED(node)) THEN
!WRITE(*,*) node%key, node%code, node%gen, node%sex
tmp => node%next
DEALLOCATE(node)
node => tmp
ELSE
EXIT
END IF
END DO
END SUBROUTINE del_list

SUBROUTINE clear_bucket()
INTEGER :: i
DO i = 1, HASHSIZE
IF(ASSOCIATED(bucket(i)%next)) THEN
!WRITE(*,*) i
CALL del_list(bucket(i)%next)
NULLIFY(bucket(i)%next)
END IF
END DO
END SUBROUTINE clear_bucket

END PROGRAM pedi_renumber

위 프로그램 소스를 pedi_renumber.f95 로 저장

 

예제 혈통 자료

 

5 1 2
6 3 4
7 5 6
8 7 9
9 10 12
16 13 14
17 15 14
18 16 17
29 18 19
20 21 19
21 22 23
22 24 0
23 24 0
25 0 29
28 26 27
33 31 32
32 34 35

위 혈통자료를 exam_pedi2.dat 로 저장

 

혈통 파일 오류 검사는 '혈통을 세대순으로 정렬하기'의 pedi_ana.f95를 이용

 

배치 파일

 

오류 검사와 리넘버를 한 번에

 

pedi_ana %1 %2
sort -nrk 5 %2 -o %2.cyc
sort -nrk 6 %2 -o %2.sex
sort -nrk 7 %2 -o %2.cnt
sort -nrk 8 %2 -o %2.dup
pedi_renumber %2.cyc

프로그램 컴파일 및 실행 화면

 

 

 

자료

 

 

1259941134_pedi_renumber.zip

다운로드

1259941134_pedi_renumber.zip