혈통을 세대별로 나누기

 

혈통 파일을 읽어 세대별로 나누기

 

 

PROGRAM sort_by_gen

! program name : sort_by_gen
! programmer : Park Byoungho
! usage : sort_by_gen datafile
! purpose : read pedigree file, calculate the generation and write pedigree file with generation

IMPLICIT NONE

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

! store animla, sire, dam and etc info
TYPE list_node
CHARACTER(LEN = 32) :: key, sire, dam
INTEGER(KIND = I4) :: code
INTEGER :: gen
INTEGER :: sex
INTEGER :: count
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
TYPE(list_node), POINTER :: node, ptr
CHARACTER(LEN = 40) :: in_filename, out_filename
INTEGER :: status ! I/O status
CHARACTER(LEN = 40) :: error_msg ! error message

CALL init_bucket()

WRITE(*,*) 'Enter the input pedigree filename : '
READ(*,*) in_filename

WRITE(*,*) 'Enter the output pedigree filename : '
READ(*,*) out_filename

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

IF (status == 0) THEN ! file open success
i = 1
DO
READ(UNIT = 11, FMT = *, IOSTAT = status) key, sire, dam
IF (status /= 0) EXIT ! end of file
CALL add_node(key, sire, dam, i, 1, 0)
i = i + 1
END DO
ELSE ! data file open fail
WRITE (*,'(1X, A, A)') 'File open failed -- error message : ', error_msg
STOP
END IF

CLOSE(11)
! end of making hash

DO j = 1, 50 ! iteration
DO i = 1, HASHSIZE
IF(ASSOCIATED(bucket(i)%next)) THEN
ptr => bucket(i)%next
DO
IF (ASSOCIATED(ptr)) THEN
IF (ptr%sire /= '0') CALL add_gen(ptr%sire, ptr%gen, 2) ! process sire
IF (ptr%dam /= '0') call add_gen(ptr%dam, ptr%gen, 1) ! process dam
!WRITE(*,*) ptr%key
ptr => ptr%next
ELSE
EXIT
END IF
END DO
END IF
END DO ! end of i
END DO ! end of j

CALL write_bucket(out_filename)

CALL clear_bucket()
! WRITE(*,*) 'Bye'

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, sire, dam, code, gen, sex)
CHARACTER(LEN = 32), INTENT(IN) :: key, sire, dam
TYPE(list_node), POINTER :: node, tmp
INTEGER(KIND = I4) :: hv, err
INTEGER(KIND = I4), INTENT(IN) :: code
INTEGER, INTENT(IN) :: gen, sex

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%sire = sire
node%dam = dam
node%code = code
node%gen = gen
node%sex = sex
node%count = 1
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 animal is already in the hash
node%count = node%count + 1
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%sire = sire
tmp%dam = dam
tmp%code = code
tmp%gen = gen
tmp%sex = sex
tmp%count = 1
node%next => tmp

EXIT
END IF
END IF
END DO
END IF
END SUBROUTINE

SUBROUTINE add_gen(parent, gen, sex)
CHARACTER(LEN = 32), INTENT(IN) :: parent ! sire or dam for generation addition
INTEGER, INTENT(IN) :: gen, sex ! generation of offsprint, sex of sire or dam
TYPE(list_node), POINTER :: node
CHARACTER(LEN = 32) :: sire = '0', dam = '0'

CALL lookup(parent, node)
IF(ASSOCIATED(node)) THEN ! if there is a sire in the hash
IF ( node%gen < gen + 1) node%gen = gen + 1
IF (node%sex == 0) THEN ! sex is not defined yet
node%sex = sex
ELSE
IF (node%sex /= sex) node%sex = 3 ! sex is strange
END IF
ELSE ! if there in not a sire in the hash
CALL add_node(parent, sire, dam, 0, 1, sex)
END IF

END SUBROUTINE add_gen

SUBROUTINE write_bucket(filename)
CHARACTER(LEN = 40), INTENT(IN) :: filename
INTEGER :: i
TYPE(list_node), POINTER :: node

OPEN(UNIT = 12, FILE = filename, STATUS = 'REPLACE', ACTION = 'WRITE')

DO i = 1, HASHSIZE
IF(ASSOCIATED(bucket(i)%next)) THEN
node => bucket(i)%next
DO
IF (.NOT. ASSOCIATED(node)) EXIT
WRITE(12,*) node%key, node%sire, node%dam, node%code, node%gen, node%sex, node%count
node => node%next
END DO
END IF
END DO ! end of i

CLOSE(12)
END SUBROUTINE write_bucket

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 sort_by_gen

 

위 소스를 sort_by_gen.f95로 저장

 

 

혈통 자료

 

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

개체 sire dam

 

 

프로그램을 이용한 혈통자료 처리 결과

 

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

개체, sire, dam, 읽은 순서, 세대수, 암수(0=모름,1=암,2=수,3=오류),읽은 횟수

 

컴파일 및 실행 화면