! ! Sib-pair is a computer program for genetic analysis ! Author: David L Duffy ! ! Compiler, version, linked in external libraries etc recorded here: ! ! 1) GUI additions ! 1a) Hooks to call JAPI (library calling AWT) ! Java Application Programming Interface 1.0.6 (http://www.japi.de/) ! Main author: Merten Joost ! japi is an open source free software GUI toolkit, which makes it easy ! to develop platform independent applications. Written in JAVA and C, ! provides the JAVA AWT Toolkit to non object-oriented languages incl ! Fortran 77 and Fortran 90 onwards. Development stopped in 2003 ! ! 1b) Hooks to call PILIB (library calling GTK+) ! Platform Independent Library for use with Fortran 9x ! PILIB 0.5 (http://www.sourceforge.net/projects/pilib) ! ! 1c) Interface to EGGX/ProCALL graphics library ! X Library for use with C or Fortran 9x ! Main author: Chisato Yamauchi ! ! 2) Interface to ZLib ! 3) Unix pipes ! module extras character (len=60) :: version = VERSION character (len=32), parameter :: hasextras = ' ' & #if JAPI // '(JAPI/AWT GUI) ' & #elif PILIB // '(PILIB GUI) ' & #endif #if ZLIB // '(zlib) ' & #endif #if POPEN // '(pipes) ' & #endif #if EGGX // '(eggx) ' & #endif // ' ' #if !defined(FLANG) && defined (SUN) contains function compiler_version() character (len=10) :: compiler_version compiler_version='Oracle f95' end function compiler_version function compiler_options() character (len=3) :: compiler_options compiler_options='-O3' end function compiler_options #endif end module extras ! #if JAPI module japi implicit none ! boolean integer,parameter :: j_true = 1 integer,parameter :: j_false = 0 ! alignment integer,parameter :: j_left = 0 integer,parameter :: j_center = 1 integer,parameter :: j_right = 2 integer,parameter :: j_top = 3 integer,parameter :: j_bottom = 4 integer,parameter :: j_topleft = 5 integer,parameter :: j_topright = 6 integer,parameter :: j_bottomleft = 7 integer,parameter :: j_bottomright = 8 ! cursor integer,parameter :: j_default_cursor = 0 integer,parameter :: j_crosshair_cursor = 1 integer,parameter :: j_text_cursor = 2 integer,parameter :: j_wait_cursor = 3 integer,parameter :: j_sw_resize_cursor = 4 integer,parameter :: j_se_resize_cursor = 5 integer,parameter :: j_nw_resize_cursor = 6 integer,parameter :: j_ne_resize_cursor = 7 integer,parameter :: j_n_resize_cursor = 8 integer,parameter :: j_s_resize_cursor = 9 integer,parameter :: j_w_resize_cursor = 10 integer,parameter :: j_e_resize_cursor = 11 integer,parameter :: j_hand_cursor = 12 integer,parameter :: j_move_cursor = 13 ! orientation integer,parameter :: j_horizontal = 0 integer,parameter :: j_vertical = 1 ! fonts integer,parameter :: j_plain = 0 integer,parameter :: j_bold = 1 integer,parameter :: j_italic = 2 integer,parameter :: j_courier = 1 integer,parameter :: j_helvetia = 2 integer,parameter :: j_times = 3 integer,parameter :: j_dialogin = 4 integer,parameter :: j_dialogout = 5 ! colors integer,parameter :: j_black = 0 integer,parameter :: j_white = 1 integer,parameter :: j_red = 2 integer,parameter :: j_green = 3 integer,parameter :: j_blue = 4 integer,parameter :: j_cyan = 5 integer,parameter :: j_magenta = 6 integer,parameter :: j_yellow = 7 integer,parameter :: j_orange = 8 integer,parameter :: j_green_yellow = 9 integer,parameter :: j_green_cyan = 10 integer,parameter :: j_blue_cyan = 11 integer,parameter :: j_blue_magenta = 12 integer,parameter :: j_red_magenta = 13 integer,parameter :: j_dark_gray = 14 integer,parameter :: j_light_gray = 15 integer,parameter :: j_gray = 16 ! borderstyle integer,parameter :: j_none = 0 integer,parameter :: j_linedown = 1 integer,parameter :: j_lineup = 2 integer,parameter :: j_areadown = 3 integer,parameter :: j_areaup = 4 ! mouselistener integer,parameter :: j_moved = 0 integer,parameter :: j_dragged = 1 integer,parameter :: j_pressed = 2 integer,parameter :: j_released = 3 integer,parameter :: j_entererd = 4 integer,parameter :: j_exited = 5 integer,parameter :: j_doubleclick = 6 ! j_moved integer,parameter :: j_resized = 1 integer,parameter :: j_hidden = 2 integer,parameter :: j_shown = 3 ! windowlistener integer,parameter :: j_activated = 0 integer,parameter :: j_deactivated = 1 integer,parameter :: j_opened = 2 integer,parameter :: j_closed = 3 integer,parameter :: j_iconified = 4 integer,parameter :: j_deiconified = 5 integer,parameter :: j_closing = 6 ! imagefileformat integer,parameter :: j_gif = 0 integer,parameter :: j_jpg = 1 integer,parameter :: j_ppm = 2 integer,parameter :: j_bmp = 3 ! ledformat integer,parameter :: j_round = 0 integer,parameter :: j_rect = 1 ! randommax integer,parameter :: j_randmax = 2147483647 ! interface logical,external :: j_start logical,external :: j_connect external :: j_setport external :: j_setdebug integer,external :: j_frame integer,external :: j_button integer,external :: j_graphicbutton integer,external :: j_checkbox integer,external :: j_label integer,external :: j_graphiclabel integer,external :: j_canvas integer,external :: j_panel integer,external :: j_borderpanel integer,external :: j_radiogroup integer,external :: j_radiobutton integer,external :: j_list integer,external :: j_choice integer,external :: j_dialog integer,external :: j_window integer,external :: j_popupmenu integer,external :: j_scrollpane integer,external :: j_hscrollbar integer,external :: j_vscrollbar integer,external :: j_line integer,external :: j_printer integer,external :: j_image external :: j_filedialog external :: j_fileselect integer,external :: j_messagebox integer,external :: j_alertbox integer,external :: j_choicebox2 integer,external :: j_choicebox3 integer,external :: j_progressbar integer,external :: j_led integer,external :: j_sevensegment integer,external :: j_meter external :: j_additem integer,external :: j_textfield integer,external :: j_textarea integer,external :: j_menubar integer,external :: j_menu integer,external :: j_helpmenu integer,external :: j_menuitem integer,external :: j_checkmenuitem external :: j_pack external :: j_print external :: j_playsoundfile external :: j_play integer,external :: j_sound external :: j_setfont external :: j_setfontname external :: j_setfontsize external :: j_setfontstyle external :: j_seperator external :: j_disable external :: j_enable logical,external :: j_getstate integer,external :: j_getrows integer,external :: j_getcolumns integer,external :: j_getselect logical,external :: j_isselect logical,external :: j_isvisible logical,external :: j_isparent logical,external :: j_isresizable external :: j_select external :: j_deselect external :: j_multiplemode external :: j_insert external :: j_remove external :: j_removeitem external :: j_removeall external :: j_setstate external :: j_setrows external :: j_setcolumns external :: j_seticon external :: j_setimage external :: j_setvalue external :: j_setradiogroup external :: j_setunitinc external :: j_setblockinc external :: j_setmin external :: j_setmax external :: j_setdanger external :: j_setslidesize external :: j_setcursor external :: j_setresizable integer,external :: j_getlength integer,external :: j_getvalue integer,external :: j_getdanger integer,external :: j_getscreenheight integer,external :: j_getscreenwidth integer,external :: j_getheight integer,external :: j_getwidth integer,external :: j_getinsets integer,external :: j_getlayoutid integer,external :: j_getinheight integer,external :: j_getinwidth external :: j_gettext external :: j_getitem integer,external :: j_getitemcount external :: j_delete external :: j_replacetext external :: j_appendtext external :: j_inserttext external :: j_settext external :: j_selectall external :: j_selecttext integer,external :: j_getselstart integer,external :: j_getselend external :: j_getseltext integer,external :: j_getcurpos external :: j_setcurpos external :: j_setechochar external :: j_seteditable external :: j_setshortcut external :: j_quit external :: j_kill external :: j_setsize integer,external :: j_getaction integer,external :: j_nextaction external :: j_show external :: j_showpopup external :: j_add external :: j_release external :: j_releaseall external :: j_hide external :: j_dispose external :: j_setpos integer,external :: j_getviewportheight integer,external :: j_getviewportwidth integer,external :: j_getxpos integer,external :: j_getypos external :: j_getpos integer,external :: j_getparentid external :: j_setfocus logical,external :: j_hasfocus integer,external :: j_getstringwidth integer,external :: j_getfontheight integer,external :: j_getfontascent integer,external :: j_keylistener integer,external :: j_getkeycode integer,external :: j_getkeychar integer,external :: j_mouselistener integer,external :: j_getmousex integer,external :: j_getmousey external :: j_getmousepos integer,external :: j_getmousebutton integer,external :: j_focuslistener integer,external :: j_componentlistener integer,external :: j_windowlistener external :: j_setflowlayout external :: j_setborderlayout external :: j_setgridlayout external :: j_setfixlayout external :: j_setnolayout external :: j_setborderpos external :: j_sethgap external :: j_setvgap external :: j_setinsets external :: j_setalign external :: j_setflowfill external :: j_translate external :: j_cliprect external :: j_drawrect external :: j_fillrect external :: j_drawroundrect external :: j_fillroundrect external :: j_drawoval external :: j_filloval external :: j_drawcircle external :: j_fillcircle external :: j_drawarc external :: j_fillarc external :: j_drawline external :: j_drawpolyline external :: j_drawpolygon external :: j_fillpolygon external :: j_drawpixel external :: j_drawstring external :: j_setxor integer,external :: j_getimage external :: j_getimagesource external :: j_drawimagesource integer,external :: j_getscaledimage external :: j_drawimage external :: j_drawscaledimage external :: j_setcolor external :: j_setcolorbg external :: j_setnamedcolor external :: j_setnamedcolorbg integer,external :: j_loadimage logical,external :: j_saveimage external :: j_sync external :: j_beep integer,external :: j_random external :: j_sleep contains function fonttype(s) integer :: fonttype character (len=*) :: s fonttype=0 if (s == 'bold') then fonttype=1 else if (s == 'italic') then fonttype=2 else if (s == 'bolditalic') then fonttype=3 else if (s == 'courier') then fonttype=1 else if (s == 'helvetica') then fonttype=2 else if (s == 'times') then fonttype=3 else if (s == 'dialogin') then fonttype=4 else if (s == 'dialogout') then fonttype=5 end if end function fonttype ! function aligntype(s) integer :: aligntype character (len=*) :: s aligntype=1 if (s == 'left') then aligntype=0 else if (s == 'center') then aligntype=1 else if (s == 'right') then aligntype=2 else if (s == 'top') then aligntype=3 else if (s == 'bottom') then aligntype=4 else if (s == 'topleft') then aligntype=5 else if (s == 'topright') then aligntype=6 else if (s == 'bottomleft') then aligntype=7 else if (s == 'bottomright') then aligntype=8 end if end function aligntype end module japi #endif ! ! Interface to posix file handling on Unix and Darwin ! module posix_dir use iso_c_binding ! integer, parameter :: DT_BLK=6, DT_CHR=2, DT_DIR=4, DT_FIFO=1, & DL_LNK=10, DT_REG=8, DT_SOCK=12, DT_UNKNOWN=0, DT_WHT=14 character (len=1), dimension(0:14), parameter :: file_type_letter = (/ & 'u', 'p', 'c', ' ', 'd', ' ', & 'b', ' ', 'f', ' ', 's', ' ', 'S', ' ', 'w' /) character (len=18), dimension(0:14), parameter :: file_type_label = (/ & 'Unknown ', 'named pipe (FIFO) ', & 'character device ', ' ', & 'directory ', ' ', & 'block device ', ' ', & 'regular file ', ' ', & 'symbolic link ', ' ', & 'UNIX domain socket', ' ', & 'whiteout (deleted)' /) ! ! dirent structure ! d_ino is the inode, d_off or d_seekoff is filesystem dependent, ! d_type is the type of file (directory, regular etc), ! d_reclen is the record length of the entry, d_namlen ! is the length of d_name, the entry (file) name. ! #if DARWIN64 integer, parameter :: PC_NAME_MAX=1024 type, bind(C) :: dirent integer (c_int64_t) :: d_ino integer(c_int64_t) :: d_seekoff integer(c_int16_t) :: d_reclen integer(c_int16_t) :: d_namlen character(kind=c_char) :: d_type character(kind=c_char), dimension(PC_NAME_MAX) :: d_name end type dirent #elif DARWIN32 integer, parameter :: PC_NAME_MAX=256 type, bind(C) :: dirent integer (c_int) :: d_ino integer(c_int16_t) :: d_reclen character(kind=c_char) :: d_type integer(c_int8_t) :: d_namlen character(kind=c_char), dimension(256) :: d_name end type dirent #else integer, parameter :: PC_NAME_MAX=256 type, bind(C) :: dirent integer (c_long) :: d_ino integer (c_long) :: d_off integer(c_short) :: d_reclen character(kind=c_char) :: d_type character(kind=c_char), dimension(256) :: d_name end type dirent #endif ! ! The readdir() function returns a pointer to a dirent structure ! representing the next directory entry in the directory stream ! pointed to by dirp. ! interface function opendir(dir_name) bind(C, name='opendir') use, intrinsic :: ISO_C_BINDING type (c_ptr) :: opendir character(kind=c_char), dimension(*) :: dir_name end function end interface interface function readdir(dirp) bind(C, name='readdir') use, intrinsic :: ISO_C_BINDING type (c_ptr) :: readdir type (c_ptr), value :: dirp end function end interface interface subroutine rewinddir(dirp) bind(C, name='rewinddir') use, intrinsic :: ISO_C_BINDING type (c_ptr), value :: dirp end subroutine end interface interface function closedir(dirp) bind(C, name='closedir') use, intrinsic :: ISO_C_BINDING integer (c_int) :: closedir type (c_ptr), value :: dirp end function end interface end module posix_dir ! ! higher level file directory routines ! module directory_utilities contains subroutine list_files(dir, files, filetypes, inodes, ios) use posix_dir character (len=*), intent(in) :: dir character (len=:), dimension(:), allocatable, optional :: files character (len=:), dimension(:), allocatable, optional :: filetypes integer, dimension(:), allocatable, optional :: inodes integer, intent(out), optional :: ios integer, parameter :: MAXLEN = 1024 type (c_ptr) :: dirp = c_null_ptr type (c_ptr) :: dentry = c_null_ptr integer (c_int) :: ioerr type(dirent), pointer :: curr_entry character (len=MAXLEN) :: dirnam integer :: filtyp, i, inode, longest, n, nf, nd logical :: filexist dirnam=dir if (dirnam == '') dirnam = '.' if (present(ios)) ios=0 inquire(file=dirnam, exist=filexist) if (.not.filexist) then if (present(ios)) ios=-2 write(*,'(3a)') 'ERROR: No such file as "', trim(dirnam), '".' if (present(files)) then if (allocated(files)) deallocate(files) allocate(character(len=1) :: files(0)) end if return end if dirnam = trim(dirnam) // C_NULL_CHAR dirp = opendir(dirnam) if (.not.c_associated(dirp)) then if (present(files)) then if (allocated(files)) deallocate(files) allocate(character(len=len_trim(dir)) :: files(1)) files(1)=trim(dir) end if return else n=0 nd=0 nf=0 longest=0 do dentry=readdir(dirp) if (.not.c_associated(dentry)) exit call c_f_pointer(dentry, curr_entry) filtyp=ichar(curr_entry%d_type) n=n+1 if (filtyp == DT_DIR) nd=nd+1 if (filtyp == DT_REG) nf=nf+1 do i=1, PC_NAME_MAX if (curr_entry%d_name(i) == c_null_char) exit end do if (i > longest) longest=i end do if (.not.(present(files) .or. present(filetypes) .or. present(inodes))) then write(*,'(3a,3(i0,a),a,i0,a)') '"', trim(dirnam), '": ', n, ' total; ', & nd, ' directories; ', nf, ' regular files;' , & ' longest name ', longest,' characters.' else call rewinddir(dirp) if (present(files)) then if (allocated(files)) deallocate(files) allocate(character(len=longest) :: files(n)) files=' ' end if if (present(filetypes)) then if (allocated(filetypes)) deallocate(filetypes) allocate(character(len=1) :: filetypes(n)) end if if (present(inodes)) then if (allocated(inodes)) deallocate(inodes) allocate(inodes(n)) end if n=0 do dentry=readdir(dirp) if (.not.c_associated(dentry)) exit call c_f_pointer(dentry, curr_entry) n=n+1 if (present(inodes)) then inodes(n)=curr_entry%d_ino end if if (present(filetypes)) then filetypes(n)=file_type_letter(ichar(curr_entry%d_type)) end if if (present(files)) then ! files(n)=' ' do i=1, PC_NAME_MAX if (curr_entry%d_name(i) == c_null_char) exit files(n)(i:i)=curr_entry%d_name(i) end do end if end do end if ioerr=closedir(dirp) if (ioerr /= 0) then write(*,'(a,i0)') 'ERROR: closedir = ', ioerr if (present(ios)) ios=ioerr end if end if end subroutine list_files end module directory_utilities ! ! flang currently lacks some POSIX style utility functions ! #if FLANG module posix_utils use iso_c_binding interface function c_chdir(dir_name) bind(C, name='chdir') use, intrinsic :: ISO_C_BINDING integer (c_int) :: c_chdir character(kind=c_char), dimension(*) :: dir_name end function c_chdir end interface interface function c_unlink(file_name) bind(C, name='unlink') use, intrinsic :: ISO_C_BINDING integer (c_int) :: c_unlink character(kind=c_char), dimension(*) :: file_name end function c_unlink end interface interface function c_isatty(fd) bind(C, name='isatty') use, intrinsic :: ISO_C_BINDING integer (c_int) :: c_isatty integer (c_int) :: fd end function c_isatty end interface interface function gethostname(file_name, len) bind(C, name='gethostname') use, intrinsic :: ISO_C_BINDING integer (c_int) :: gethostname character(kind=c_char), dimension(*) :: file_name integer (c_size_t) :: len end function gethostname end interface contains subroutine chdir(dir, status) character (len=*), intent(in) :: dir integer, optional :: status integer (c_int) :: i i=c_chdir(trim(dir) // C_NULL_CHAR) if (present(status)) status=i end subroutine chdir subroutine unlink(f, status) character (len=*), intent(in) :: f integer, optional :: status integer (c_int) :: i i=c_unlink(trim(f) // C_NULL_CHAR) if (present(status)) status=i end subroutine unlink function hostnm(file_name) integer :: hostnm character (len=*) :: file_name integer :: flen, i, j integer (c_size_t) :: length character(kind=c_char), dimension(len(file_name)) :: name file_name=' ' flen=len(file_name) length=flen i=gethostname(name, length) j=1 do while (name(j) /= C_NULL_CHAR .and. j <= flen) file_name(j:j)=name(j) j=j+1 end do hostnm=i end function hostnm end module posix_utils #endif ! ! Output stream, formatting ! module outstream integer :: outstr ! stream integer :: logstr ! logging stream character (len=1) :: tabsep = ' ' ! character to separate output words contains ! ! format free output, adding newline if line exceeding specified length ! subroutine newlin(sol, eol, pos, newpos) integer, intent(in) :: sol, eol integer, intent(inout) :: pos integer, intent(in) :: newpos if (pos > eol) then pos=newpos write(outstr,*) write(outstr,'(a)', advance='no') repeat(' ', sol-1) end if return end subroutine newlin ! ! print one string, inserting newline if past r margin ! cursor at l margin at beginning ! subroutine colprint(sol, eol, string) integer, intent(in) :: sol, eol character (len=*), intent(in) :: string integer :: i, slen, wid slen=len_trim(string) wid=eol-sol+1 i=1 do write(outstr, '(a)') string(i:min(i+wid,slen)) i=i+wid if (i > slen) exit write(outstr,'(a)', advance='no') repeat(' ', sol-1) end do end subroutine colprint ! ! hexdump -C ! subroutine hexdump(start, finish, string, offset) integer (kind=8), intent(in) :: start, finish character (len=*) :: string integer (kind=8), optional, intent(in) :: offset integer (kind=8) :: i, ich, j, off, siz integer :: idxwidth, widest character (len=8) :: idxfmt off=0 idxwidth=8 idxfmt='(z8.8)' if (present(offset)) off=offset siz=min(finish, len(string)) idxwidth=int(log(dble(off+siz))/log(16.0d0)+1.0d0) if (idxwidth > 8) then write(idxfmt,'(a,i0,a,i0,a)') '(z', idxwidth, '.', idxwidth,')' end if j=max(0, start-1) do while (j < siz) write(outstr, idxfmt, advance='no') off+j do i=j+1, min(j+16, siz) write(outstr,'(1x,z2.2)', advance='no') ichar(string(i:i)) end do if ((siz-j) < 16) then do i=siz+1, j+16 write(outstr,'(a3)', advance='no') ' ' end do end if write(outstr, '(a)', advance='no') ' | ' do i=j+1, min(j+16, siz) ich=ichar(string(i:i)) if (ich >= 32 .and. ich < 128) then write(outstr,'(a)', advance='no') string(i:i) else write(outstr,'(a)', advance='no') '.' end if end do write(outstr,*) j=j+16 end do end subroutine hexdump end module outstream ! ! Environmental (automatic) variables for evaluator ! module automatic_data integer, parameter :: ENVNUM = 16 integer, parameter :: ENV_SEX = 1, ENV_FEMALE = 2, ENV_MALE = 3, & ENV_ISFOU = 4, ENV_ISNON = 5, ENV_NUM = 6, & ENV_NFOUN = 7, ENV_ANYMIS = 8, ENV_ANYTYP = 9, & ENV_ALLTYP = 10, ENV_NUMTYP = 11, ENV_FAMNUM = 12, & ENV_INDEX = 13, ENV_COMMAR = 14, ENV_PROTYP = 15, & ENV_CHOSEN=16 character (len=6), dimension(ENVNUM) :: env = & (/'sex ', 'female','male ', & 'isfou ','isnon ', 'num ', 'nfoun ', & 'anymis', 'anytyp', 'alltyp', 'numtyp', & 'famnum', 'index ', 'commar', 'protyp', 'chosen' /) end module automatic_data ! ! List of reserved words ! Token name, left binding power, right binding power, operation ! Pos Name LBP RBP Op (1=unary postfix; 2=binary, infix; 3=if; ! --- ------- --- --- -- 10=zero-arg functions eg rand) ! 0 null 0 0 0 ! 1 ( 200 0 0 ! 2 ) 0 5 0 ! 3 if 0 45 3 ! 4 then 5 25 0 ! 5 else 5 25 0 ! 6 * 120 121 2 ! 7 / 120 121 2 ! 8 + 100 101 2 ! 9 - 100 101 2 ! 10 ^ 139 138 2 ! 11 = 0 0 2 ! 12 not 70 70 1 ! 13 and 65 66 2 ! 14 or 60 61 2 ! 15 < 80 80 2 ! 16 > 80 80 2 ! 17 ge 80 80 2 ! 18 le 80 80 2 ! 19 ne 80 80 2 ! 20 eq 80 80 2 ! 21 neg 138 138 1 ! 22 pos 138 138 1 ! 23 abs 140 140 1 ! 24 sqrt 140 140 1 ! 25 log 140 140 1 ! 26 exp 140 140 1 ! 27 sin 140 140 1 ! 28 cos 140 140 1 ! 29 tan 140 140 1 ! 30 asin 140 140 1 ! 31 acos 140 140 1 ! 32 atan 140 140 1 ! 33 inht 140 140 1 ! 34 int 140 140 1 ! 35 round 140 140 1 ! 36 istyp 140 140 1 ! 37 untyp 140 140 1 ! 38 ishet 140 140 1 ! 39 ishom 140 140 1 ! 40 alla 140 140 1 ! 41 allb 140 140 1 ! 42 rand 0 0 10 ! 43 rnorm 0 0 10 ! 44 pi 0 0 10 ! 45 y 0 0 10 ! 46 n 0 0 10 ! 47 x 0 0 10 ! 48 NUM 0 0 10 ! 49 julian 140 140 1 ! 50 greg 140 140 1 ! 51 log10 140 140 1 ! 52 begin 201 0 0 ! 53 end 0 4 0 ! 54 ; 0 0 0 ! 55 eps 0 0 10 ! 56 pnorm 140 140 1 ! 57 qnorm 140 140 1 ! 58 fact 140 140 1 ! 59 mod 120 121 2 ! module parser_data use automatic_data integer, parameter :: TOKNUM=59 integer, parameter :: TOK_NULL=0, TOK_LBRACKET=1, TOK_RBRACKET=2, & TOK_IF=3, TOK_THEN=4, TOK_ELSE=5, & TOK_MULT=6, TOK_DIVIDE=7, TOK_ADD=8, & TOK_SUBTRACT=9, TOK_POW=10, TOK_EQUAL=11, & TOK_NOT=12, TOK_AND=13, TOK_OR=14, & TOK_LT=15, TOK_GT=16, TOK_GE=17, & TOK_LE=18, TOK_NE=19, TOK_EQ=20, & TOK_NEG=21, TOK_POS=22, TOK_ABS=23, & TOK_SQRT=24, TOK_LOG=25, TOK_EXP=26, & TOK_SIN=27, TOK_COS=28, TOK_TAN=29, & TOK_ASIN=30, TOK_ACOS=31, TOK_ATAN=32, & TOK_INHT=33, TOK_INT=34, TOK_ROUND=35, & TOK_ISTYP=36, TOK_UNTYP=37, TOK_ISHET=38, & TOK_ISHOM=39, TOK_ALLA=40, TOK_ALLB=41, & TOK_RAND=42, TOK_RNORM=43, TOK_PI=44, & TOK_Y=45, TOK_N=46, TOK_X=47, & TOK_NUM=48, TOK_JULIAN=49, TOK_GREG=50, & TOK_LOG10=51, TOK_BEGIN=52, TOK_END=53, & TOK_COLON=54, TOK_EPS=55, TOK_PNORM=56, & TOK_QNORM=57, TOK_FACT=58, TOK_MOD=59 character (len=6), dimension(TOKNUM) :: token = & (/'( ',') ','if ','then ','else ','* ', '/ ', & '+ ','- ','^ ','= ','not ','and ', 'or ', & '< ','> ', & 'ge ','le ','ne ','eq ','neg ','pos ', 'abs ', & 'sqrt ','log ','exp ', & 'sin ','cos ','tan ','asin ','acos ','atan ', 'inht ', & 'int ','round ', & 'istyp ','untyp ','ishet ','ishom ','alla ','allb ', & 'rand ','rnorm ','pi ','y ','n ','x ', 'NUM ', & 'julian','greg ','log10 ','begin ','end ',': ', 'eps ', & 'pnorm ','qnorm ','fact ','mod ' /) integer, dimension(0:TOKNUM) :: lbp = & (/0, 200,0,0,5,5,120,120, 100,100,139,0,70,65,60,80,80, & 80,80,80,80,138,138,140,140,140,140, & 140,140,140,140,140,140,140,140,140, & 140,140,140,140,140,140,0,0,0,0,0,0,0, & 140,140,140, 201,0,0,0, 140,140,140, 120 /) integer, dimension(0:TOKNUM) :: rbp = & (/0, 0,5,45,25,25,121,121, 101,101,138,0,70,66,61,80,80, & 80,80,80,80,138,138,140,140,140,140, & 140,140,140,140,140,140,140,140,140, & 140,140,140,140,140,140,0,0,0,0,0,0,0, & 140,140,140, 0,4,0,0, 140,140,140, 121 /) integer, dimension(0:TOKNUM) :: op = & (/0, 0,0,3,0,0,2,2, 2,2,2,2,1,2,2,2,2,2,2,2,2,1,1,1,1,1,1, & 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 10,10,10,10,10,10,10, 1,1,1, & 0,0,0,10, 1,1,1, 2 /) ! ! Evaluate type of each term in expression word(farg...larg) and actn ! actn=0 error =1 purely arithmetic =2 legal ! ! Types are: wtyp wtag expr ! ---- -------- -------- ! tokens 0 0...TOKNUM - ! env 1 1...ENVNUM (value) ! constant 2 value ! trait data 10 1...NLOCI (value) ! constant genotype 3 value, value ! genotype data 11 1...NLOCI (value, value) ! MISS 4 MISS ! missing trait 12 1...NLOCI MISS ! MISS genotype 5 MISS/MISS ! missing trait 13 1...NLOCI MISS/MISS ! NUM 6 - ! integer (kind=1), parameter :: partok=0 integer (kind=1), parameter :: parenv=1 integer (kind=1), parameter :: partra=2 integer (kind=1), parameter :: pargen=3 integer (kind=1), parameter :: parmtr=4 integer (kind=1), parameter :: parmge=5 integer (kind=1), parameter :: parnum=6 integer (kind=1), parameter :: parvar=8 end module parser_data ! ! parse comparison in isaff (simple expression) ! 15='<', 16='>', 17='ge', 18='le', 19='ne', 20='eq' ! 21='odd', 22='even' ! module comp_ops integer, parameter :: COMP_LT=15, COMP_GT=16, COMP_GE=17, COMP_LE=18, & COMP_NE=19, COMP_EQ=20, COMP_ODD=21, COMP_EVEN=22 contains ! ! determine if trait being compared to a constant, for isaff ! function iscomp(op) logical iscomp character (len=*), intent(in) :: op iscomp=(op == '<' .or. op == '>' .or. op == 'lt' .or. & op == 'gt' .or. op == 'und' .or. op == 'ove' .or. & op == '>=' .or. op == '<=' .or. op == 'le' .or. & op == 'ge' .or. op == 'ne' .or. op == '^=' .or. & op == '==' .or.op == 'eq' .or. op == 'odd' .or. op(1:3) == 'eve') end function iscomp ! ! Show comparison ! function compsign(idx) character (len=2) :: compsign integer, intent(in) :: idx character(len=2), dimension(6) :: ctok = (/' <',' >','>=','<=','^=','=='/) compsign=' ' if (idx > 14 .and. idx < 21) compsign=ctok(idx-14) end function compsign ! ! parse comparison in isaff ! 15='<', 16='>', 17='ge', 18='le', 19='ne', 20='eq' ! 21='odd', 22='even' ! subroutine docomp(pos, words, gt, thresh) integer, intent(inout) :: pos character (len=*), dimension(:), intent(in) :: words integer, intent(out) :: gt double precision, intent(out) :: thresh character (len=3) :: op integer :: tpos ! functions double precision :: fval gt=0 thresh=0.0d0 tpos=pos+1 op=words(pos)(1:3) if (iscomp(words(tpos))) then op=trim(op) // trim(words(tpos)) tpos=tpos+1 end if if (op == '<' .or. op == 'lt' .or. op == 'und') then gt=COMP_LT else if (op == '>' .or. op == 'gt' .or. op == 'ove') then gt=COMP_GT else if (op == '>=' .or. op == 'ge') then gt=COMP_GE else if (op == '<=' .or. op == 'le') then gt=COMP_LE else if (op == '^=' .or. op == 'ne') then gt=COMP_NE else if (op == '==' .or. op == 'eq') then gt=COMP_EQ else if (op == 'odd') then gt=COMP_ODD thresh=1.0d0 else if (op == 'eve') then gt=COMP_EVEN thresh=0.0d0 end if if (gt >= COMP_LT .and. gt <= COMP_EQ) then thresh=fval(words(tpos)) pos=tpos+1 else pos=tpos end if end subroutine docomp ! ! Message defining proband based on comparison ! subroutine defpro(gt, thresh, asnote) use outstream integer, intent(in) :: gt double precision, intent(in) :: thresh logical, intent(in) :: asnote integer, parameter :: MISS=-9999 ! functions ! character(len=2) :: compsign if (asnote) then write(outstr,'(a)', advance='no') & 'NOTE: Proband defined as trait value' end if if (gt > 14) then if (thresh == MISS) then write(outstr,'(1x,a,1x,a)') compsign(gt), 'x' else if (gt <= COMP_EQ) then if (anint(thresh) == thresh) then write(outstr,'(1x,a,1x,i0)') compsign(gt), int(thresh) else write(outstr,'(1x,a,1x,f9.4)') compsign(gt), thresh end if else if (gt == COMP_ODD) then write(outstr,'(1x,a)') 'being odd.' else if (gt == COMP_EVEN) then write(outstr,'(1x,a)') 'being even.' end if else write(outstr,'(1x,a)') 'being present.' end if end subroutine defpro end module comp_ops ! ! Linkage and physical maps ! genetic map functions are 1=Haldane, 2=Kosambi ! default map units is Mbp or cM (assuming 1 Mbp/cM) ! mapunits=type of map unit cM/M/Mbp/kbp/bp, ! mapconstant=multiplier for internal map units (Mbp/cM) ! module genetic_maps character (len=7), dimension(2), parameter :: mapfunname = & (/ 'Haldane', 'Kosambi' /) character (len=3), dimension(5), parameter :: mapunitname = & (/ 'cM ', 'M ', 'Mbp', 'kbp', 'bp ' /) integer :: mapunits = 1 double precision :: mapconstant = 1.0d0 ! ! Summary information about chromosomes (linkage groups) ! for different classes of locus (markers, traits such as gene expression) ! type chromosome_data integer :: nchrom ! number of chromosomes integer :: ntypes ! number of classes of locus character(len=2), dimension(:), allocatable :: chromlabel ! number of loci integer, dimension(:), allocatable :: totcount integer, dimension(:), allocatable :: mapcount ! position and index of loci starting or ending each chromosome double precision, dimension(:,:), allocatable :: chromstart, chromend integer, dimension(:,:), allocatable :: mapstart, mapend end type chromosome_data contains ! ! Optimal format for writing different map units ! function mapformat(mapunits, width) character (len=7) :: mapformat integer, intent(in) :: mapunits character (len=*), intent(in) :: width if (mapunits == 4) then mapformat='(f' // width // '.3)' else if (mapunits == 5) then mapformat= '(f' // width // '.0)' else mapformat= '(f' // width // '.6)' end if end function mapformat ! ! formatted map position fixed to length 12 ! function mapstring(x) character (len=12) :: mapstring double precision, intent(in) :: x integer, parameter :: MISS = -9999 if (mapunits == 4) then if (x == MISS) then mapstring=' . ' else write(mapstring, '(f12.3)') x/mapconstant end if else if (mapunits == 5) then if (x == MISS) then mapstring=' .' else write(mapstring, '(f12.0)') x/mapconstant end if else if (x == MISS) then mapstring=' . ' else write(mapstring, '(f12.6)') x/mapconstant end if end if end function mapstring ! inverse Haldane (mapf=1) or Kosambi (mapf=2) mapping x cM to r ! function invmap(x, mapf) double precision invmap double precision, intent(in) :: x integer, intent(in) :: mapf if (mapf == 1) then invmap=0.5d0*(1.0d0-exp(-0.02d0*abs(x))) else if (mapf == 2) then invmap=0.5d0*(exp(0.04d0*abs(x))-1.0d0)/(exp(0.04d0*abs(x))+1.0d0) else invmap=x end if if (invmap < 0.001d0) invmap=0.001d0 end function invmap ! ! set up and finalize summary chromosomal map data ! for different classes of locus ! subroutine setup_chroms(nchrom, ntypes, table) integer, intent(in) :: nchrom integer, intent(in) :: ntypes type (chromosome_data) :: table table%nchrom=nchrom table%ntypes=ntypes allocate(table%chromlabel(nchrom)) allocate(table%totcount(ntypes)) allocate(table%mapcount(nchrom)) allocate(table%chromstart(nchrom, ntypes), table%chromend(nchrom, ntypes)) allocate(table%mapstart(nchrom, ntypes), table%mapend(nchrom, ntypes)) table%chromend=-1.0d0 table%chromstart=1.0e20 table%totcount=0 table%mapcount=0 table%mapstart=0 table%mapend=0 end subroutine setup_chroms subroutine clean_chroms(table) type (chromosome_data) :: table deallocate(table%chromlabel) deallocate(table%chromstart, table%chromend) deallocate(table%totcount, table%mapcount) deallocate(table%mapstart, table%mapend) end subroutine clean_chroms ! ! Linear search for chromosome in chromosome_data ! (recall sort is numeric not alphabetic) ! subroutine whichchrom(chrom, table, pos) character (len=*), intent(in) :: chrom type (chromosome_data), intent(in) :: table integer, intent(out) :: pos integer :: hi, lo do pos=1, table%nchrom if (chrom == table%chromlabel(pos)) then return end if end do pos=0 end subroutine whichchrom ! ! Convert NCBI sequence name to chromosome eg ! Homo sapiens chromosome 1, GRCh38.p13 <-> NC_000001.11 ! Bug with chr 10 and 20 fixed 20211117 ! subroutine ncbiseq_to_chr(chrom) character (len=*), intent(inout) :: chrom integer :: dpos, zpos if (len(chrom) < 3) return if (chrom(1:3) == 'NC_') then dpos=index(chrom, '.') if (dpos > 0) then do zpos=4, dpos-1 if (chrom(zpos:zpos) /= '0') then chrom=chrom((zpos):(dpos-1)) exit end if end do end if end if end subroutine ncbiseq_to_chr end module genetic_maps ! ! epoch for Julian dates (defaults to 2440588==1970-01-01), ! module julian_epoch double precision :: epoch = 2440588.0d0 end module julian_epoch ! ! date and time subroutines ! module timelib character (len=3), dimension(7), parameter :: days = (/ & 'Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat' /) character (len=3), dimension(12), parameter :: months = (/ & 'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', & 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec' /) character (len=9), dimension(12), parameter :: long_months = (/ & 'January ', 'February ', 'March ', 'April ', 'May ', 'June ', & 'July ', 'August ', 'September', 'October ', 'November ', 'December ' /) contains ! ! Julian and Gregorian from Peter Meyer's on-line notes: ! In 1968 in a letter to the editor of Communications of the ACM (CACM, ! volume 11, number 10, October 1968, p.657) Henry F. Fliegel and Thomas ! C. Van Flandern presented such conversion algorithms: ! ! gdate takes the form YYYYMMDD ! function tojulian(gdate) double precision tojulian double precision, intent(in) :: gdate integer :: date, dy, mo, yr date = nint(gdate) yr = date/10000 date = date-10000*yr mo = date/100 dy = date-100*mo date = ( 1461 * ( yr + 4800 + ( mo - 14 ) / 12 ) ) / 4 + & ( 367 * ( mo - 2 - 12 * ( ( mo - 14 ) / 12 ) ) ) / 12 - & ( 3 * ( ( yr + 4900 + ( mo - 14 ) / 12 ) / 100 ) ) / 4 + dy - 32075 tojulian = dble(date) end function tojulian ! ! from Julian to Gregorian ! function togreg(jdate) double precision togreg double precision, intent(in) :: jdate integer :: date, dy, mo, yr integer :: a, b, c, d, e date = nint(jdate) a = date + 32044 b = ( 4 * a + 3) / 146097 c = a - ( 146097 * b ) / 4 d = ( 4 * c + 3 ) / 1461 e = c - ( 1461 * d ) / 4 mo = (( 5 * e ) + 2) / 153 yr = 100 * b + d - 4800 + mo / 10 dy = e - (153 * mo + 2) / 5 + 1 mo = mo + 3 + ( -12 * (mo / 10) ) if (yr < 0) yr=yr-1 date = sign(10000*abs(yr) + 100*mo + dy, yr) togreg = dble(date) end function togreg ! ! Gregorian date as decimal year ! function getyear(gdate) double precision getyear double precision, intent(in) :: gdate integer :: date, yr double precision :: d1, yrlen date = nint(gdate) yr = date/10000 d1 = tojulian(dble(10000*yr)+101.0d0) yrlen = tojulian(dble(10000*(yr+1))+101.0d0) - d1 getyear=dble(yr)+(tojulian(gdate)-d1)/yrlen end function getyear ! function dayofweek(jd) integer :: dayofweek double precision, intent(in) :: jd dayofweek = mod(int(jd), 7) + 1 end function dayofweek ! ! Date and time like fdate ! function current_time() character (len=17) :: current_time integer (kind=8), dimension(8) :: datevals character (len=17) :: res call date_and_time(values=datevals) write(res,'(i4,a1,a3,a1,i2.2,1x,i2.2,a1,i2.2)') & datevals(1), '-', months(datevals(2)),'-', datevals(3), & datevals(5), ':', datevals(6) current_time=res end function current_time ! ! Today as ISO YYYYMMDD ! function isodate() integer :: isodate integer (kind=8), dimension(8) :: datevals call date_and_time(values=datevals) isodate=int(10000,kind=8)*datevals(1)+int(100,kind=8)*datevals(2)+datevals(3) end function isodate ! ! Current seconds since POSIX epoch excluding leap seconds ! function time_since_epoch() integer (kind=8) :: time_since_epoch integer (kind=8), dimension(8) :: datevals integer (kind=8) :: today call date_and_time(values=datevals) today=10000*datevals(1)+100*datevals(2)+datevals(3) today=86400*(int(tojulian(dble(today)), kind=8)-2440588) time_since_epoch=today - 60*datevals(4) + & 3600*datevals(5) + 60*datevals(6) + datevals(7) end function time_since_epoch end module timelib ! ! time/random number generator seeds ! module rndseed integer :: ix = 1, iy = 2, iz = 3 integer :: initix = 1, initiy = 2, initiz = 3 end module rndseed ! ! random number generators ! module rngs contains ! ! Moved initialization here 20180802, as ifort did not like ! rndseed and rng being simultaneously accessible by main ! subroutine init_rng(iseed) use rndseed integer, intent(in) :: iseed initix=mod(iseed,29282) if (iseed > 29282) then initiy=mod(iseed/29282,29282) else initiy=mod(419*ix+6173,29282) end if initiz=mod(419*iy+6173,29282) ix=initix iy=initiy iz=initiz end subroutine init_rng ! subroutine set_rng_seeds(i, j, k) use rndseed integer, intent(in) :: i, j, k initix=i initiy=j initiz=k ix=initix iy=initiy iz=initiz end subroutine set_rng_seeds ! subroutine get_rng_seeds(i, j, k) use rndseed integer, intent(out) :: i, j, k i=ix j=iy k=iz end subroutine get_rng_seeds ! ! Algorithm AS 183 Appl Stat 1982; 31:188 ! Returns a pseudo-random number from U(0,1) ! ! ix,iy,iz should be "randomly" initialised to 1-30000 ! eg via time ! function random() use rndseed real :: random ix = mod ( 171 * ix, 30269 ) iy = mod ( 172 * iy, 30307 ) iz = mod ( 170 * iz, 30323 ) random=amod(float(ix)/30269.0+float(iy)/30307.0 + float(iz)/30323.0,1.0) end function random ! ! Return a pseudo-random integer from integer U(lo..hi) ! integer function irandom(lo,hi) integer, intent(in) :: lo integer, intent(in) :: hi real :: x x=random() irandom=lo+int(float(hi-lo+1)*x) if (irandom > hi) irandom=hi end function irandom ! ! Random character string ! subroutine uniqnam(nchar, str) integer, intent(in) :: nchar character (len=*) :: str integer i str=' ' do i=1, nchar str(i:i)=char(96+irandom(1,26)) end do end subroutine uniqnam ! ! Triangular random number generator ! function rantri() real :: rantri rantri=random() + random() - 1.0 end function rantri ! ! The function RANDN() returns a normally distributed pseudo-random ! number with zero mean and unit variance. Calls are made to a ! function subprogram RANDOM() which returns independent random ! numbers uniform in the interval (0,1). ! ! The algorithm uses the ratio of uniforms method of A.J. Kinderman ! and J.F. Monahan augmented with quadratic bounding curves. function randn() real :: randn real :: a, b, q, r1, r2, s, t, u, v, x, y data s, t, a ,b / 0.449871, -0.386595, 0.19600, 0.25472/ data r1, r2/ 0.27597, 0.27846/ ! Generate P = (u,v) uniform in rectangle enclosing acceptance region 50 u = random() v = random() v = 1.7156 * (v - 0.5) ! Evaluate the quadratic form x = u - s y = abs(v) - t q = x**2 + y*(a*y - b*x) ! Accept P if inside inner ellipse if (q < r1) go to 100 ! Reject P if outside outer ellipse if (q > r2) go to 50 ! Reject P if outside acceptance region if (v**2 > -4.0*log(u)*u**2) go to 50 ! Return ratio of P's coordinates as the normal deviate 100 randn = v/u end function randn ! ! Permute the contents of an integer array ! subroutine permut(n, ia) integer, intent(in) :: n integer, dimension(n), intent(inout) :: ia integer :: ifro, i, ito, itmp do i=1, n ifro=irandom(1,n) ito=irandom(1,n) itmp=ia(ito) ia(ito)=ia(ifro) ia(ifro)=itmp end do end subroutine permut ! ! Sample of size r without replacement from 1..n by rejection sampling ! subroutine sampleindices(n, r, ia) integer, intent(in) :: n, r integer, dimension(r), intent(out) :: ia integer :: i, itmp, j if (r >= n) then do i=1, r ia(i)=i end do call permut(r, ia) return end if ! else do i=1, r 1 continue itmp=irandom(1, n) do j=1, i-1 if (ia(j) == itmp) goto 1 end do ia(i)=itmp end do end subroutine sampleindices end module rngs ! ! interrupt ! module interrupt integer :: irupt contains ! ! keyboard interrupt handler (exits after 6 interrupts, usually ctrl-C) ! #if defined (IFORT) function handler() integer (kind=4) :: handler irupt=irupt+1 handler=irupt if (irupt > 5) then write(*,'(a)') 'Multiple interrupts received! Exiting.' stop end if end function handler #else subroutine handler() irupt=irupt+1 if (irupt > 5) then write(*,'(a)') 'Multiple interrupts received! Exiting.' stop end if end subroutine handler #endif end module interrupt ! ! Input buffer, stack of input streams, prompt string etc ! ilevel=0 historical or macro command; =1 keyboard; =2,3,4 files ! toplevel=highest occupied level ! ilevold=last level, if ilevel currently 0 ! ! incstr stream for ith inclusion ! infil name of file ! incaction 1=read entire stream 2=read locus information only ! 3=1+delete ! module iobuff integer, parameter :: STDIN=5, STDOUT=6 integer, parameter :: LINSIZ = 20000 character (len=LINSIZ) :: commands, lin, scheme_lin character (len=3):: prompt_string = '>> ' integer :: ilevel=1, ilevold=1, toplevel=1 integer, parameter :: NSTRM=4 integer, dimension(NSTRM) :: incstr = (/STDIN, 4, 10, 12/) integer, dimension(0:NSTRM) :: incaction=1 character(len=256), dimension(2:NSTRM) :: infil=' ' contains subroutine newinclude(inctyp, keep, filnam, ioerr) use outstream character (len=3), intent(in) :: inctyp integer, intent(in) :: keep character (len=*), intent(in) :: filnam integer, intent(out) :: ioerr ioerr=1 if (toplevel < NSTRM) then toplevel=toplevel+1 open(incstr(toplevel), file=filnam, iostat=ioerr, status='old') if (ioerr == 0) then write(outstr,'(/3a)') 'Reading commands from "', trim(filnam),'".' infil(toplevel)=filnam incaction(toplevel)=1 if (inctyp == 'loc') incaction(toplevel)=incaction(toplevel) + 1 if (keep == 2) incaction(toplevel)=incaction(toplevel) + keep if (ilevel == 0) then ilevold=toplevel else ilevel=ilevel+1 end if else write(outstr,'(/3a/)') 'ERROR: Unable to open "', trim(filnam), '".' toplevel=toplevel-1 end if else write(outstr,'(/a/7x,a,i0,a/)') & 'ERROR: Cannot further nest "include" or "locus" commands.', & 'Highest nesting level=', toplevel, '.' end if end subroutine newinclude end module iobuff ! ! iostat codes needed for wrinline etc ! now available in the intrinsic module ! module iocodes #if OPEN64 | PATHSCALE integer, parameter :: eofcode = -4001 integer, parameter :: eolcode = -4006 character (len=10), parameter :: stream_access = 'sequential' character (len=6), parameter :: stream_form = 'binary' #else integer, parameter :: eofcode = -1 integer, parameter :: eolcode = -2 character (len=6), parameter :: stream_access = 'stream' character (len=11), parameter :: stream_form = 'unformatted' #endif end module iocodes ! ! Definition of a port ! slots: associated file name ! 1=uncompressed 2=gzipped 3=bgzipped 4=unzipped copy 5=pipe ! Fortran style logical unit number ! gzip C-style file handle ! module ioports #if !OPEN64 use, intrinsic :: ISO_C_BINDING #endif integer, parameter :: PORT_STANDARD = 1, PORT_GZIPPED = 2, & PORT_BGZIPPED = 3, PORT_COPY = 4, PORT_PIPE = 5 type, public :: ioport character (len=256) :: filnam character (len=1) :: stat = ' ' integer :: filtyp integer :: fstream ! ! Position in file or stream ! if compressed, record block, actual file position and ! virtual file position ie in uncompressed text ! integer (kind=8) :: file_position = -1 integer (kind=8) :: block_position = -1 integer (kind=8) :: actual_file_position = -1 #if !OPEN64 type (c_ptr) :: handle = c_null_ptr #endif end type ioport end module ioports ! ! Fortran interface to zlib ! based on looking at fgzlib, fgsl and Janus Weil's example ! on comp.lang.fortran May 2009 ! currently enough functionality to read gzipped text files ! #if ZLIB module f95zlib use, intrinsic :: ISO_C_BINDING use ioports integer, parameter :: & Z_VERSION_ERROR = -6, Z_BUF_ERROR = -5, Z_MEM_ERROR = -4, & Z_DATA_ERROR = -3, Z_STREAM_ERROR = -2 , Z_ERRNO = -1, & Z_OK = 0, Z_STREAM_END = 1, Z_NEED_DICT =2 character (len=15), dimension(-6:2), parameter :: zlib_errors = (/ & 'Z_VERSION_ERROR', 'Z_BUF_ERROR ', 'Z_MEM_ERROR ', & 'Z_DATA_ERROR ', 'Z_STREAM_ERROR ', 'Z_ERRNO ', & 'Z_OK ', 'Z_STREAM_END ', 'Z_NEED_DICT ' /) integer, dimension(16), parameter :: magic= (/ & 31, 139, 8, 4, 0, 0, 0, 0, 0, 255, 6, 0, 66, 67, 2, 0 /) ! buffer for gzread integer, parameter :: ZBUFLEN = 65536 character (len=ZBUFLEN), target :: zbuffer ! current character and end of zbuffer integer :: zbufpos=0, zbufend=ZBUFLEN ! ! z_stream structure ! type, bind(C) :: zlib_stream type (c_ptr) :: next_in ! next input byte integer(c_int) :: avail_in ! number of bytes available at next_in integer(c_long) :: total_in ! bytes read so far type (c_ptr) :: next_out ! next output byte integer(c_int) :: avail_out ! number of bytes available at next_in integer(c_long) :: total_out ! bytes read so far type (c_ptr) :: msg ! last error message, NULL if none type (c_ptr) :: internal_state ! not visible to applications type (c_ptr) :: zalloc ! used to allocate the internal state type (c_ptr) :: zfree ! used to free the internal state type (c_ptr) :: opaque ! private object for zalloc/zfree integer(c_int) :: data_type ! binary/text/decoding status integer(c_long) :: adler ! Adler-32 or CRC-32 integer(c_long) :: reserved ! unused end type ! zlibVersion interface function zlibversion() bind(C, name='zlibVersion') use, intrinsic :: ISO_C_BINDING type (c_ptr) :: zlibversion end function end interface ! zlibCompileFlags interface function zlibcompileflags() bind(C, name='zlibCompileFlags') use, intrinsic :: ISO_C_BINDING integer (c_int) :: zlibcompileflags end function end interface ! inflateInit2 interface function inflateInit2(strm, windowBits, version, stream_size) & bind(C, name='inflateInit2_') use, intrinsic :: ISO_C_BINDING type (c_ptr), value :: strm integer(c_int), value :: windowBits character(kind=c_char) :: version(*) integer(c_int), value :: stream_size end function end interface ! inflate interface function inflate(strm, flsh) bind(C, name='inflate') use, intrinsic :: ISO_C_BINDING type (c_ptr), value :: strm integer(c_int), value :: flsh end function end interface ! inflateEnd interface subroutine inflateEnd(strm) bind(C, name='inflateEnd') use, intrinsic :: ISO_C_BINDING type (c_ptr), value :: strm end subroutine end interface ! uncompress interface function uncompress(dest, destLen, source, sourceLen) bind(C, name='uncompress') use, intrinsic :: ISO_C_BINDING integer(c_int) :: uncompress type (c_ptr), value :: dest type (c_ptr), value :: destLen type (c_ptr), value :: source integer(c_long), value :: sourceLen end function end interface ! compress interface function compress(dest, destLen, source, sourceLen) bind(C, name='compress') use, intrinsic :: ISO_C_BINDING integer(c_int) :: compress type (c_ptr), value :: dest type (c_ptr), value :: destLen type (c_ptr), value :: source integer(c_long), value :: sourceLen end function end interface ! gzopen interface function gzopen(path, mode) bind(C, name='gzopen') use, intrinsic :: ISO_C_BINDING character(kind=c_char), dimension(*) :: path, mode type (c_ptr) :: gzopen end function end interface ! gzread interface function gzread(filehandle, buf, len) bind(C, name='gzread') use, intrinsic :: ISO_C_BINDING integer (c_int) :: gzread type (c_ptr), value :: filehandle type (c_ptr), value :: buf integer(c_int), value :: len end function end interface ! gzwrite interface function gzwrite (filehandle, buf, len) bind(C, name='gzwrite') use, intrinsic :: ISO_C_BINDING integer (c_int) :: gzwrite type (c_ptr), value :: filehandle type (c_ptr), value :: buf integer(c_int), value :: len end function end interface ! gzgetc interface function gzgetc(filehandle) bind(C, name='gzgetc') use, intrinsic :: ISO_C_BINDING integer (c_int) :: gzgetc type (c_ptr), value :: filehandle end function end interface ! gzrewind interface function gzrewind(filehandle) bind(C, name='gzrewind') use, intrinsic :: ISO_C_BINDING integer(c_int) :: gzrewind type (c_ptr), value :: filehandle end function end interface ! gzerror interface function gzerror(filehandle) bind(C, name='gzerror') use, intrinsic :: ISO_C_BINDING type (c_ptr) :: gzerror type (c_ptr), value :: filehandle end function end interface ! gzclose interface function gzclose(filehandle) bind(C, name='gzclose') use, intrinsic :: ISO_C_BINDING integer(c_int) :: gzclose type (c_ptr), value :: filehandle end function end interface ! gzseek interface function gzseek(filehandle, offset, whence) bind(C, name='gzseek') use, intrinsic :: ISO_C_BINDING integer(c_long) :: gzseek type (c_ptr), value :: filehandle integer(c_long), value :: offset integer(c_int), value :: whence end function end interface ! gztell interface function gztell(filehandle) bind(C, name='gztell') use, intrinsic :: ISO_C_BINDING integer(c_long) :: gztell type (c_ptr), value :: filehandle end function end interface contains ! ! Wrapper for zlibversion ! subroutine zlib_version(vstring) use iso_c_binding character (len=*), intent(out) :: vstring type (c_ptr) :: str_ptr character (len=1, kind=c_char), dimension (:), pointer :: res => null () integer :: i str_ptr = zlibversion() call c_f_pointer(str_ptr, res, [255]) vstring='' do i=1, len(vstring) if (res(i) == c_null_char) exit vstring(i:i)=res(i) end do end subroutine zlib_version ! ! Wrapper for zlibCompileFlags ! subroutine zlib_compileflags() use outstream use iso_c_binding character (len=1, kind=c_char), dimension (:), pointer :: res => null () integer :: i integer(c_int) :: ir character (len=2), dimension(0:3), parameter :: sizes = & (/'16', '32', '64', 'Ot'/) ir=zlibcompileflags() write(outstr, '(2a)', advance='no') ' uInt:', sizes(ibits(ir,0,2)) write(outstr, '(2a)', advance='no') ' uLong:', sizes(ibits(ir,2,2)) write(outstr, '(2a)', advance='no') ' voidfp:', sizes(ibits(ir,4,2)) write(outstr, '(2a)') ' z_off_t:', sizes(ibits(ir,6,2)) end subroutine zlib_compileflags ! ! Wrapper for compress ! subroutine zlib_compress(uncompressed_data, len_result, compressed_data, ios) use iso_c_binding character (len=*), intent(in), target :: uncompressed_data integer (kind=8), intent(out) :: len_result character (len=*), intent(out), target :: compressed_data integer, intent(out) :: ios type (c_ptr) :: input_ptr = c_null_ptr type (c_ptr) :: output_ptr = c_null_ptr integer :: i integer(c_long) :: source_len type (c_ptr) :: comp_len_ptr = c_null_ptr integer (c_long), target :: comp_len ios=0 len_result=0 source_len=len(uncompressed_data) input_ptr=c_loc(uncompressed_data(1:1)) comp_len=len(compressed_data) comp_len_ptr=c_loc(comp_len) output_ptr=c_loc(compressed_data(1:1)) ios=compress(output_ptr, comp_len_ptr, input_ptr, source_len) if (ios == 0) len_result=comp_len end subroutine zlib_compress ! ! Wrapper for uncompress - default compression settings ! subroutine zlib_uncompress(compressed_data, result_len, uncompressed_data, ios) use iso_c_binding character (len=*), intent(in), target :: compressed_data integer (kind=8), intent(out) :: result_len character (len=*), intent(out), target :: uncompressed_data integer, intent(out) :: ios type (c_ptr) :: input_ptr = c_null_ptr type (c_ptr) :: output_ptr = c_null_ptr integer :: i integer(c_long) :: comp_len type (c_ptr) :: uncomp_len_ptr = c_null_ptr integer (c_long), target :: uncomp_len ios=0 result_len=0 comp_len=len(compressed_data) input_ptr=c_loc(compressed_data(1:1)) uncomp_len=len(uncompressed_data) uncomp_len_ptr=c_loc(uncomp_len) uncompressed_data=' ' output_ptr=c_loc(uncompressed_data(1:1)) ios=uncompress(output_ptr, uncomp_len_ptr, input_ptr, comp_len) if (ios == 0) result_len = uncomp_len end subroutine zlib_uncompress ! ! Wrapper for inflateInit2, inflate, inflateEnd, allowing adjustment of compress level ! This is essential for reading bgzf files ! Follows uncompress() ! subroutine zlib_inflate(compressed_data, windowbits, result_len, uncompressed_data, ios) use iso_c_binding character (len=*), intent(in), target :: compressed_data integer, intent(in) :: windowbits integer (kind=8), intent(out) :: result_len character (len=*), intent(out), target :: uncompressed_data integer, intent(out) :: ios integer (kind=8), parameter :: umax8 = 4294967294_8 integer (kind=4), parameter :: umax4 = -1 type(zlib_stream), target :: zstrm integer(c_int) :: wbits integer(c_int) :: cerr type (c_ptr) :: stream_ptr = c_null_ptr type (c_ptr) :: input_ptr = c_null_ptr type (c_ptr) :: output_ptr = c_null_ptr type (c_ptr) :: uncomp_len_ptr = c_null_ptr integer (c_int) :: comp_len integer (c_long), target :: uncomp_len integer (c_long) :: clen, left character (len=1, kind=c_char), dimension (1), target :: buf character (len=8) :: vstring integer :: i logical :: usable_out call zlib_version(vstring) ios=0 result_len=0 uncompressed_data=' ' wbits=windowbits comp_len=len(compressed_data) uncomp_len=len(uncompressed_data) uncomp_len_ptr=c_loc(uncomp_len) input_ptr=c_loc(compressed_data(1:1)) output_ptr=c_loc(uncompressed_data(1:1)) usable_out=(uncomp_len > 0) if (usable_out) then left=uncomp_len uncomp_len=0 else left=1 output_ptr=c_loc(buf(1)) end if zstrm%next_in = input_ptr zstrm%avail_in = 0 zstrm%total_in = 0 zstrm%msg = c_null_ptr zstrm%internal_state = c_null_ptr zstrm%zalloc = c_null_ptr zstrm%zfree = c_null_ptr zstrm%opaque = c_null_ptr zstrm%data_type = 0 zstrm%adler = 0 zstrm%reserved = 0 stream_ptr=c_loc(zstrm) cerr = inflateInit2(stream_ptr, wbits, trim(vstring) // C_NULL_CHAR, & #if SUN int(sizeof(zstrm), kind=c_int)) #else int(c_sizeof(zstrm), kind=c_int)) #endif if (cerr /= 0) then ios=cerr return end if zstrm%next_out = output_ptr zstrm%avail_out = 0 cerr = 0 do while (cerr == 0) if (zstrm%avail_out == 0) then if (left > umax8) then zstrm%avail_out = umax4 else zstrm%avail_out = left end if left=left-zstrm%avail_out end if if (zstrm%avail_in == 0) then if (comp_len > umax8) then zstrm%avail_in = umax4 else zstrm%avail_in = comp_len end if comp_len=comp_len-zstrm%avail_in end if cerr=inflate(stream_ptr, comp_len) end do if (usable_out) then result_len=zstrm%total_out else if (zstrm%total_out > 0 .and. cerr == Z_BUF_ERROR) then left=1 end if call inflateEnd(stream_ptr) ios=cerr if (cerr == Z_STREAM_END) then ios=Z_OK else if (cerr == Z_NEED_DICT) then ios=Z_DATA_ERROR else if (cerr == Z_BUF_ERROR .and. (left + zstrm%avail_out) > 0) then ios=Z_DATA_ERROR end if end subroutine zlib_inflate ! ! Wrapper for gzopen ! also reinitializes gzread's buffer ! subroutine fgz_open(path, mode, fd, ios) use iso_c_binding character(kind=c_char, len=*), intent(in) :: path, mode type (ioport) :: fd #if SUN character(kind=c_char, len=len_trim(path)+1) :: cpath character(kind=c_char, len=len_trim(mode)+1) :: cmode integer :: eos #endif integer :: ios ios=0 fd%filnam=path fd%filtyp=PORT_GZIPPED fd%fstream=-1 fd%file_position=0 #if SUN eos=len_trim(path) cpath=path cpath((eos+1):(eos+1))=c_null_char eos=len_trim(mode) cmode=mode cmode((eos+1):(eos+1))=c_null_char fd%handle = gzopen(cpath, cmode) #else fd%handle = gzopen(trim(path) // c_null_char, trim(mode) // c_null_char) #endif if (.not.c_associated(fd%handle)) ios=-1 zbufpos=0 end subroutine fgz_open ! ! Wrapper for gzrewind ! subroutine fgz_rewind(fd, ios) use iso_c_binding type(ioport) :: fd integer :: ios integer(c_int) :: ir ios = 0 ir = gzrewind(fd%handle) if (ir /= 0) then ios=ir fd%file_position=-1 else fd%file_position=0 end if zbufpos=0 end subroutine fgz_rewind ! ! Wrapper for gzseek ! subroutine fgz_seek(fd, offset, ios, offset_typ) use iso_c_binding type(ioport) :: fd integer (kind=8), intent(in) :: offset integer, intent(out) :: ios character(len=3), intent(in), optional :: offset_typ integer(c_long) :: off, res integer(c_int) :: ir, whence integer i ios = 0 off = offset whence=0 if (present(offset_typ)) then if (offset_typ == 'CUR') then whence=1 else if (offset_typ == 'END') then whence=2 else if (offset_typ == 'DAT') then whence=3 else if (offset_typ == 'HOL') then whence=4 end if end if res = gzseek(fd%handle, off, whence) if (res == -1) then ios=-1 fd%file_position = -1 else fd%file_position = res if (whence == 1) then fd%file_position = fd%file_position + res else fd%file_position = gztell(fd%handle) end if end if zbufpos=0 end subroutine fgz_seek ! ! Wrapper for gzread ! read one 32 bit integer ! subroutine fgz_read_integer(fd, res, ios) use iso_c_binding use iocodes type(ioport) :: fd integer, intent(out) :: res integer, intent(out) :: ios integer(c_int), target :: ires integer(c_int) :: blen, rlen type (c_ptr) :: buf = c_null_ptr ios=0 res=0 buf=c_loc(ires) blen=4 rlen=gzread(fd%handle, buf, blen) if (rlen <= 0) then ios=-1 fd%file_position = -1 return end if fd%file_position = fd%file_position + 4 res=ires end subroutine fgz_read_integer ! ! Wrapper for gzread ! read one 64 bit integer ! subroutine fgz_read_longint(fd, res, ios) use iso_c_binding use iocodes type(ioport) :: fd integer (kind=8), intent(out) :: res integer, intent(out) :: ios integer(c_long), target :: ires integer(c_int) :: blen, rlen type (c_ptr) :: buf = c_null_ptr ios=0 res=0 buf=c_loc(ires) blen=8 rlen=gzread(fd%handle, buf, blen) if (rlen <= 0) then ios=-1 fd%file_position = -1 return end if fd%file_position = fd%file_position + 8 res=ires end subroutine fgz_read_longint ! ! Wrapper for gzread ! read one line of text from buffer ! subroutine fgz_read(fd, lin, advance, ignore_eol, ios) use iso_c_binding use iocodes type(ioport) :: fd character(len=*) :: lin character(len=*), intent(in), optional :: advance logical, intent(in), optional :: ignore_eol integer, intent(out) :: ios integer :: i, j, linlen, nchar, newzpos, pos integer(c_int) :: blen, rlen ! ! eol morez more ! F T T read buffer, copy to output ! F T F read buffer, output full ! T F F found ! advancing ! no after output full, exit with buffer pos at end of text ! yes after output full, exit with buffer pos at next ! logical :: advancing, text_mode logical :: eol, more, morez type (c_ptr) :: buf = c_null_ptr text_mode=.true. if (present(ignore_eol)) text_mode=.not.ignore_eol advancing=.true. if (present(advance)) advancing=(advance == 'yes') linlen=len(lin) ios=0 lin=' ' sta=1 nchar=-1 pos=0 j=0 eol=.false. more=.true. morez=.true. do while (morez) j=j+1 ! refill buffer if necessary if (zbufpos == 0) then blen=ZBUFLEN buf=c_loc(zbuffer(1:1)) rlen=gzread(fd%handle, buf, blen) if (rlen <= 0) then ios=-1 fd%file_position = -1 return end if zbufpos=1 zbufend=rlen end if ! place buffer index at or buffer end ! if will exit after updating output newzpos=zbufend+1 nchar=zbufend-zbufpos+1 if (text_mode) then do i=zbufpos, zbufend if (zbuffer(i:i) == achar(10)) then eol=.true. morez=.false. newzpos=i+1 nchar=i-zbufpos exit end if end do end if ! read in min(buffer, remaining output) ! if not advancing move buffer idx back to last character read and exit if (more) then if (linlen < pos+nchar) then more=.false. nchar=linlen-pos if (.not.advancing) then newzpos=zbufpos+nchar morez=.false. eol=.false. end if end if lin((pos+1):(pos+nchar))=zbuffer(zbufpos:(zbufpos+nchar-1)) pos=pos+nchar end if fd%file_position = fd%file_position + newzpos - zbufpos zbufpos=newzpos if (zbufpos > zbufend) then zbufpos=0 end if end do if (.not.advancing .and. eol) ios=eolcode end subroutine fgz_read ! ! Read one token from gzipped file ! subroutine fgz_readtoken(fd, separator, word, ios) use, intrinsic :: ISO_C_BINDING use outstream use iocodes type(ioport) :: fd character(len=*), intent(in) :: separator character(len=*), intent(out) :: word integer, intent(out) :: ios integer :: nchar character (len=1) :: ch integer :: pos, wlen, word_start integer(c_int) :: blen, rlen type (c_ptr) :: buf = c_null_ptr ! ! eol morez more ! F T T read buffer, copy to output ! F T F read buffer, output full ! T F F found ! logical :: eol, eow, inword, more, morez ios=0 inword=.false. word=' ' wlen=len(word) sta=1 nchar=-1 plevel=1 pos=0 j=0 eol=.false. eow=.false. inword=.false. more=.true. morez=.true. do while (morez) j=j+1 ! refill buffer if necessary if (zbufpos == 0) then blen=ZBUFLEN buf=c_loc(zbuffer(1:1)) rlen=gzread(fd%handle, buf, blen) if (rlen <= 0) then ios=-1 fd%file_position = -1 return end if zbufpos=1 zbufend=rlen end if ! skip over white space or separator newzpos=zbufend+1 word_start=zbufpos if (.not.inword) then skip_whitespace: do while (word_start <= zbufend) ch=zbuffer(word_start:word_start) if (ch == achar(10)) then eol=.true. more=.false. morez=.false. newzpos=word_start+1 exit skip_whitespace else if (scan(ch, separator) == 0) then inword=.true. exit skip_whitespace end if word_start=word_start+1 end do skip_whitespace end if ! nchar=0 if (.not.eol) then nchar=zbufend-word_start+1 do i=word_start, zbufend ch=zbuffer(i:i) if (ch == achar(10)) then eol=.true. morez=.false. newzpos=i+1 nchar=i-word_start inword=.false. exit else if (scan(ch, separator) > 0) then morez=.false. newzpos=i+1 nchar=i-word_start inword=.false. exit end if end do end if if (more) then nchar=min(nchar, wlen-pos) if (nchar > 0) then word((pos+1):(pos+nchar))=zbuffer(word_start:(word_start+nchar-1)) pos=pos+nchar more=(pos < wlen) end if end if fd%file_position = fd%file_position + newzpos - zbufpos zbufpos=newzpos if (zbufpos > zbufend) then zbufpos=0 end if end do if (eol) ios=eolcode end subroutine fgz_readtoken ! ! write one line of text to a gzipped textfile ! subroutine fgz_write(fd, lin, advance, ios) use iso_c_binding use iocodes type(ioport) :: fd character(len=*) :: lin character(len=*), intent(in), optional :: advance integer, intent(out) :: ios logical :: advancing integer :: ioerr, lenlin, lsta, lpos integer(c_int) :: blen, wlen type (c_ptr) :: buf = c_null_ptr advancing=.true. if (present(advance)) then advancing=(advance == 'yes') end if ios=0 lpos=0 lenlin=len_trim(lin) do lsta=lpos+1 lpos=min(lsta+ZBUFLEN-1, lenlin) zbuffer=lin(lsta:lpos) buf=c_loc(zbuffer(1:1)) blen=lpos-lsta+1 wlen=gzwrite(fd%handle, buf, blen) ioerr=wlen if (ioerr == 0) exit if (lpos == lenlin) then if (advancing) then zbuffer=char(10) buf=c_loc(zbuffer(1:1)) blen=1 wlen=gzwrite(fd%handle, buf, blen) ioerr=wlen end if exit end if end do if (ioerr == 0) ios=-1 end subroutine fgz_write ! ! Wrapper for gzerror ! subroutine fgz_error(fd) use iso_c_binding use outstream type(ioport) :: fd type (c_ptr) :: str_ptr character (len=1, kind=c_char), dimension (:), pointer :: res => null () integer :: i str_ptr = gzerror(fd%handle) call c_f_pointer(str_ptr, res, [255]) do i=1, len(res) if (res(i) == c_null_char) exit write(outstr,'(a1)', advance='no') res(i) end do end subroutine fgz_error ! ! Wrapper for gzclose ! subroutine fgz_close(fd, ios) use iso_c_binding type(ioport) :: fd integer :: ios integer(c_int) :: ic ios = 0 ic = gzclose(fd%handle) if (ic /= 0) ios = ic end subroutine fgz_close end module f95zlib ! ! Reading bgzipped files ! !* BGZF/GZIP header (specialized from RFC 1952; little endian): ! ID1 ID2 CM FLG MTIME XFL OS XLEN SI1 SI2 SLEN !+---+---+---+---+---+---+---+---+---+---+---+---+---+---+---+---+---+---+ !| 31|139| 8| 4| 0| 0|255| 6| 66| 67| 2|BLK_LEN| !+---+---+---+---+---+---+---+---+---+---+---+---+---+---+---+---+---+---+ ! BGZF extension: ! ^ ^ ^ ^ ! | | | | ! FLG.EXTRA XLEN B C ! ! BGZF format is compatible with GZIP. It limits the size of each compressed ! block to 2^16 bytes and adds and an extra "BC" field in the gzip header which ! records the size. ! module bgzf integer, parameter :: BGZF_BLOCK_SIZE = 65280 integer, parameter :: BGZF_MAX_BLOCK_SIZE = 65536 integer, parameter :: BLOCK_HEADER_LENGTH = 18 integer, parameter :: BLOCK_FOOTER_LENGTH = 8 contains ! ! To read bgzf format, need something like ! bioruby-bgzf read_bgzf_block ! ! Read one line from BGZF file ! subroutine bgzf_read(port, lin, ignore_eol, advance,ios) use, intrinsic :: ISO_C_BINDING use outstream use iocodes use f95zlib type(ioport) :: port character(len=*) :: lin character(len=*), intent(in), optional :: advance logical, intent(in), optional :: ignore_eol integer, intent(out) :: ios integer :: block_size, crc32, input_size, ich, nblocks, nchar integer (kind=8) :: ulen character (len=BGZF_MAX_BLOCK_SIZE) :: compressed_data integer :: nl, nlines, nshow, pos ! ! eol morez more ! F T T read buffer, copy to output ! F T F read buffer, output full ! T F F found ! advancing ! no after output full, exit with buffer pos at end of text ! yes after output full, exit with buffer pos at next ! logical :: advancing, text_mode logical :: eol, more, morez text_mode=.true. if (present(ignore_eol)) text_mode=.not.ignore_eol advancing=.true. if (present(advance)) advancing=(advance == 'yes') linlen=len(lin) ios=0 lin=' ' sta=1 nchar=-1 plevel=1 pos=0 j=0 eol=.false. more=.true. morez=.true. do while (morez) j=j+1 ! refill buffer if necessary if (zbufpos == 0) then inquire(port%fstream, pos=port%actual_file_position) call read_bgzf_block(port%fstream, compressed_data, & block_size, input_size, crc32, ios) if (ios /= 0) then port%file_position = -1 return end if zbufpos=1 zbufend=input_size if (input_size == 0) then ios=-1 port%file_position = -1 return end if call zlib_inflate(compressed_data(1:block_size), -15, ulen, & zbuffer(1:input_size), ios) port%block_position = port%block_position + 1 end if ! place buffer index at or buffer end ! if will exit after updating output newzpos=zbufend+1 nchar=zbufend-zbufpos+1 if (text_mode) then call chase_eol(zbufpos, zbufend, zbuffer, eol, morez, newzpos, nchar) end if ! read in min(buffer, remaining output) ! if not advancing move buffer idx back to last character read and exit if (more) then if (linlen < pos+nchar) then more=.false. nchar=linlen-pos if (.not.advancing) then newzpos=zbufpos+nchar morez=.false. eol=.false. end if end if call copybuff(zbufpos, pos, nchar, zbuffer, lin) pos=pos+nchar end if port%file_position = port%file_position + newzpos - zbufpos zbufpos=newzpos if (zbufpos > zbufend) then zbufpos=0 end if end do if (.not.advancing .and. eol) ios=eolcode end subroutine bgzf_read subroutine copybuff(zbufpos, pos, nchar, zbuffer, lin) integer, intent(in) :: zbufpos, pos, nchar character(len=*), intent(in) :: zbuffer character(len=*) :: lin lin((pos+1):(pos+nchar))=zbuffer(zbufpos:(zbufpos+nchar-1)) end subroutine copybuff subroutine chase_eol(zbufpos, zbufend, zbuffer, eol, morez, newzpos, nchar) integer, intent(in) :: zbufpos, zbufend character(len=*), intent(in) :: zbuffer logical :: eol, morez integer :: newzpos, nchar integer :: i do i=zbufpos, zbufend if (zbuffer(i:i) == achar(10) .or. zbuffer(i:i) == achar(13)) then eol=.true. morez=.false. newzpos=i+1 if (zbuffer(i:i) == achar(13)) newzpos=newzpos+1 nchar=i-zbufpos exit end if end do end subroutine chase_eol ! ! Read one token from BGZF file ! subroutine bgzf_readtoken(port, separator, word, ios) use, intrinsic :: ISO_C_BINDING use outstream use iocodes use f95zlib type(ioport) :: port character(len=*), intent(in) :: separator character(len=*), intent(out) :: word integer, intent(out) :: ios integer :: block_size, crc32, input_size, ich, nblocks, nchar integer (kind=8) :: ulen character (len=1) :: ch character (len=BGZF_MAX_BLOCK_SIZE) :: compressed_data integer :: nl, nlines, nshow, pos, wlen, word_start ! ! eol morez more ! F T T read buffer, copy to output ! F T F read buffer, output full ! T F F found ! logical :: eol, eow, inword, more, morez ios=0 inword=.false. word=' ' wlen=len(word) sta=1 nchar=-1 plevel=1 pos=0 j=0 eol=.false. eow=.false. inword=.false. more=.true. morez=.true. do while (morez) j=j+1 ! refill buffer if necessary if (zbufpos == 0) then inquire(port%fstream, pos=port%actual_file_position) call read_bgzf_block(port%fstream, compressed_data, & block_size, input_size, crc32, ios) if (ios /= 0) then port%file_position = -1 return end if zbufpos=1 zbufend=input_size if (input_size == 0) then ios=-1 port%file_position = -1 return end if call zlib_inflate(compressed_data(1:block_size), -15, ulen, & zbuffer(1:input_size), ios) port%block_position = port%block_position + 1 end if ! skip over white space or separator newzpos=zbufend+1 word_start=zbufpos if (.not.inword) then skip_whitespace: do while (word_start <= zbufend) ch=zbuffer(word_start:word_start) if (ch == achar(10)) then eol=.true. more=.false. morez=.false. newzpos=word_start+1 exit skip_whitespace else if (scan(ch, separator) == 0) then inword=.true. exit skip_whitespace end if word_start=word_start+1 end do skip_whitespace end if ! nchar=0 if (.not.eol) then nchar=zbufend-word_start+1 do i=word_start, zbufend ch=zbuffer(i:i) if (ch == achar(10)) then eol=.true. morez=.false. newzpos=i+1 nchar=i-word_start inword=.false. exit else if (scan(ch, separator) > 0) then morez=.false. newzpos=i+1 nchar=i-word_start inword=.false. exit end if end do end if if (more) then nchar=min(nchar, wlen-pos) if (nchar > 0) then word((pos+1):(pos+nchar))=zbuffer(word_start:(word_start+nchar-1)) pos=pos+nchar more=(pos < wlen) end if end if port%file_position = port%file_position + newzpos - zbufpos zbufpos=newzpos if (zbufpos > zbufend) then zbufpos=0 end if end do if (eol) ios=eolcode end subroutine bgzf_readtoken ! ! Read one BGZF block ! subroutine read_bgzf_block(strm, compressed_data, block_size, input_size, crc32, ios) use, intrinsic :: ISO_C_BINDING use iocodes use outstream use f95zlib implicit none integer, intent(in) :: strm character (len=*) :: compressed_data integer :: block_size, crc32, input_size integer :: ios integer :: i, ilen, si1, si2 integer (kind=8) :: ipos integer (c_int16_t) :: bc, slen, xlen integer (c_int32_t) :: ival character (len=1) :: ch, ch2, ch3, ch4 character (len=1), dimension(10) :: contents10 read(strm, iostat=ios) contents10 if (ios /= 0) then write(outstr,'(a)') 'ERROR: Could not read file!' return end if do i=1, 4 if (ichar(contents10(i)) /= magic(i)) then write(outstr,'(a,i0,3(a1,i0),a,i0,3(a1,i0))') & 'ERROR: Bad magic number! Expected ', & magic(1), '-', magic(2), '-', & magic(3), '-', magic(4), ' but read ', & ichar(contents10(1)), '-', ichar(contents10(2)), '-', & ichar(contents10(3)), '-', ichar(contents10(4)) ios=-99 return end if end do read(strm, iostat=ios) xlen ilen=0 bc=0 do while (ilen < xlen) read(strm, iostat=ios) ch, ch2 si1=ichar(ch) si2=ichar(ch2) read(strm, iostat=ios) slen if (si1 == 66 .and. si2 == 67) then if (slen /= 2) then write(outstr,'(a)') 'ERROR: slen ', slen, ' /= 2' ios=-98 return end if if (bc /= 0) then write(outstr,'(a)') 'ERROR: duplicate field with block size' ios=-97 return end if read(strm, iostat=ios) bc inquire(strm, pos=ipos) read(strm, pos=ipos+slen-2, iostat=ios) else read(strm, pos=slen, iostat=ios) end if ilen=ilen+4+slen end do if (ilen /= xlen) then write(outstr,'(a,i0,a,i0,a)') & 'ERROR: total length of subfields is ', ilen, ' bytes but must be ', xlen, '.' ios=-96 return end if if (bc == 0) then write(outstr,'(a)') 'ERROR: Block size not found in any subfield.' ios=-95 return end if block_size=bc-xlen-19 read(strm) compressed_data(1:block_size) read(strm, iostat=ios) ival if (ios /= 0) return crc32=ival read(strm, iostat=ios) ival if (ios /= 0) return input_size=ival if (input_size > ZBUFLEN .or. input_size < 0) then write(outstr,'(a,i0,a,i0)') & 'ERROR: BGZF bad input_size = ', input_size, ' block_size=', block_size ios=-96 end if end subroutine read_bgzf_block ! subroutine bgzf_seek(port, block_pos, virtual_offset, ios) use, intrinsic :: ISO_C_BINDING use outstream use iocodes use f95zlib type(ioport) :: port integer (kind=8), intent(in) :: block_pos, virtual_offset integer, intent(out) :: ios integer :: block_size, crc32, input_size, ich, nblocks integer (kind=8) :: ulen character (len=BGZF_MAX_BLOCK_SIZE) :: compressed_data read(port%fstream, pos=block_pos, iostat=ios) if (ios == 0) then call read_bgzf_block(port%fstream, compressed_data, & block_size, input_size, crc32, ios) if (ios /= 0) then port%file_position = -1 return end if zbufpos=1 zbufend=input_size if (input_size == 0) then ios=-1 port%file_position = -1 return end if call zlib_inflate(compressed_data(1:block_size), -15, ulen, & zbuffer(1:input_size), ios) port%block_position = port%block_position + 1 inquire(port%fstream, pos=port%actual_file_position) zbufpos=virtual_offset end if end subroutine bgzf_seek end module bgzf #endif ! ! Fortran interface to popen ! #if POPEN module f95pipes use, intrinsic :: ISO_C_BINDING use ioports ! popen interface function popen(path, mode) bind(C, name='popen') use, intrinsic :: ISO_C_BINDING character(kind=c_char), dimension(*) :: path, mode type (c_ptr) :: popen end function end interface ! fgetc interface function fgetc(handle) bind(C, name='fgetc') use, intrinsic :: ISO_C_BINDING integer(kind=c_int) :: fgetc type (c_ptr), value :: handle end function end interface ! fgets interface function fgets(buf, siz, handle) bind(C, name='fgets') use, intrinsic :: ISO_C_BINDING type (c_ptr) :: fgets character(kind=c_char), dimension(*) :: buf integer(kind=c_int), value :: siz type (c_ptr), value :: handle end function end interface ! read (2) interface function c_read(filehandle, buf, len) bind(C, name='read') use, intrinsic :: ISO_C_BINDING integer (c_int) :: c_read type (c_ptr), value :: filehandle type (c_ptr), value :: buf integer(c_int), value :: len end function end interface ! fputs interface function fputs(buf, handle) bind(C, name='fputs') use, intrinsic :: ISO_C_BINDING integer (c_int) :: fputs character(kind=c_char), dimension(*) :: buf type (c_ptr), value :: handle end function end interface ! pclose interface function pclose(handle) bind(C, name='pclose') use, intrinsic :: ISO_C_BINDING integer(c_int) :: pclose type (c_ptr), value :: handle end function end interface contains ! wrapper for popen ! fd%stat gives mode subroutine pipe_open(command, fd, ios) use, intrinsic :: iso_c_binding character(*), intent(in) :: command type (ioport) :: fd integer :: ios ios=0 fd%filnam=command fd%filtyp=PORT_PIPE fd%fstream=-1 fd%handle = popen(trim(command) // C_NULL_CHAR, fd%stat // C_NULL_CHAR) if (.not.c_associated(fd%handle)) ios=-1 end subroutine pipe_open ! ! rewind pipe subroutine pipe_rewind(fd, ios) use, intrinsic :: iso_c_binding type (ioport) :: fd integer :: ios call pipe_close(fd, ios) if (ios == 0) call pipe_open(fd%filnam, fd, ios) end subroutine pipe_rewind ! ! wrapper for read subroutine pipe_read_integer(fd, res, ios) use iso_c_binding use iocodes type(ioport) :: fd integer, intent(out) :: res integer, intent(out) :: ios integer(c_int), target :: ires integer(c_int) :: blen, rlen type (c_ptr) :: buf = c_null_ptr ios=0 res=0 buf=c_loc(ires) blen=4 rlen=c_read(fd%handle, buf, blen) if (rlen <= 0) then ios=-1 fd%file_position = -1 return end if fd%file_position = fd%file_position + 4 res=ires end subroutine pipe_read_integer ! ! wrapper for fgets subroutine pipe_read(fd, lin, advance, ios) use iso_c_binding type(ioport) :: fd character(len=*) :: lin character(len=*), intent(in), optional :: advance integer, intent(out) :: ios integer :: i, eos integer(c_int) :: clen ios=0 clen=len(lin) lin=' ' if (.not.c_associated(fgets(lin, clen, fd%handle))) then fd%file_position=-1 ios=-1 return end if eos=2 do i=1, clen if (lin(i:i) == C_NULL_CHAR) then eos=i-2 exit end if end do lin=lin(1:eos) fd%file_position=fd%file_position+eos+1 end subroutine pipe_read ! ! next whitespace separated token - wraps fgetc ! subroutine pipe_readtoken(fd, word, separator, ios) use iso_c_binding type(ioport) :: fd character(len=*) :: word character(len=*), intent(in) :: separator integer, intent(out) :: ios integer :: i, eos, pos, wlen integer(kind=c_int) :: ich character (len=1) :: ch ios=0 pos=0 wlen=len(word) word=' ' do ich=fgetc(fd%handle) if (ios == 0) exit ch=achar(ich) if (scan(ch, separator) /= 0) exit pos=pos+1 word(pos:pos)=ch end do fd%file_position=fd%file_position+pos end subroutine pipe_readtoken ! ! wrapper for fputs subroutine pipe_write(fd, lin, advance, ios) use iso_c_binding type(ioport) :: fd character(len=*) :: lin character(len=*), intent(in), optional :: advance integer, intent(out) :: ios logical :: advancing integer(c_int) :: ioerr ios=0 advancing=.true. if (present(advance)) then advancing=(advance == 'yes') end if ioerr=fputs(trim(lin) // C_NULL_CHAR, fd%handle) ios=ioerr if (advancing) then ioerr=fputs(char(10) // C_NULL_CHAR, fd%handle) ios=ioerr end if end subroutine pipe_write ! ! wrapper for pclose subroutine pipe_close(fd, ios) use iso_c_binding type(ioport) :: fd integer :: ios integer(c_int) :: ic ios = 0 ic = pclose(fd%handle) if (ic /= 0) ios = ic end subroutine pipe_close end module f95pipes #endif ! ! Readline subroutine for either plain or (b)gzipped files -- ! module fileio use iocodes use ioports #if ZLIB use f95zlib use bgzf #endif #if POPEN use f95pipes #endif use outstream public :: close_port, isgzipped, newlun, open_port, readline, rewind_port, seek_port contains ! ! Find a free Fortran style unit ! subroutine newlun(strm) integer, intent(out) :: strm integer, parameter :: MAXUNITS = 99 integer :: iport logical :: ios do iport=8, MAXUNITS inquire(iport, opened=ios) if (.not.ios) then strm=iport return end if end do write(*,'(a)') 'No available i/o streams!' stop end subroutine newlun ! ! Test if gzipped file, reading magic number 31,139,8 ... ! 1=gzipped 2=bgzipped ! function isgzipped(filnam) integer :: isgzipped character (len=*), intent(in) :: filnam integer, dimension(16), parameter :: magic= (/ & 31, 139, 8, 4, 0, 0, 0, 0, 0, 255, 6, 0, 66, 67, 2, 0 /) integer :: s character (len=1) :: ch1, ch2, ch3 character (len=1), dimension(13) :: contents13 isgzipped=0 call newlun(s) open(s, file=filnam, access=stream_access, form=stream_form, & status='old', iostat=ios) if (ios /= 0) then write(outstr, '(3a)') 'ERROR: Cannot open "', trim(filnam), & '" to read magic number.' return end if read(s, iostat=ios) ch1, ch2, ch3 if (ios /= 0) then write(outstr, '(3a)') 'ERROR: Could not read header of "', trim(filnam), '".' else if (ichar(ch1) == magic(1) .and. & ichar(ch2) == magic(2) .and. & ichar(ch3) == magic(3)) then isgzipped=isgzipped+1 read(s, iostat=ios) contents13 if (ios == 0) then if (ichar(contents13(7)) == magic(10) .and. & ichar(contents13(8)) == magic(11) .and. & ichar(contents13(13)) == magic(16)) then isgzipped=isgzipped+1 end if end if end if close(s, status='keep') return end function isgzipped ! ! Fill large real array from stream ! subroutine readbigreal(strm, n, vec) integer, intent(in) :: strm integer (kind=8), intent(in) :: n real, dimension(n), intent(out) :: vec ! largest allowable unformatted read from a file integer (kind=8), parameter :: CHUNKSIZE = 268435456 integer (kind=8) :: iblock, fin, sta if (n <= CHUNKSIZE) then read(strm) vec else sta=1 do fin=min(sta+CHUNKSIZE-1, n) read(strm) vec(sta:fin) if (fin == n) exit sta=sta+CHUNKSIZE end do end if end subroutine readbigreal ! ! Open a (plain or gzipped) file or pipe for reading or writing ! subroutine open_port(filnam, port, mode, ios) use rngs character (len=*), intent(in) :: filnam character (len=1), intent(in) :: mode type (ioport) :: port integer, intent(out) :: ios integer :: eon, gzipped, strm logical :: apipe, filexist character(len=3) :: fileage #if !(ZLIB) character(len=len(filnam)) :: wrkfil #endif ios=0 apipe=.false. filexist=.false. gzipped=0 fileage='old' if (mode == 'w') fileage='new' eon=len_trim(filnam) if (eon == 0) then write(outstr,'(a)') 'ERROR: No file name given.' ios=1 return end if port%stat=mode #if POPEN apipe=((mode == 'r' .and. filnam(eon:eon) == '|') .or. & (mode == 'w' .and. filnam(1:1) == '|')) #endif if (mode == 'r' .and..not.apipe) gzipped=isgzipped(filnam) if (.not.apipe) then inquire(file=filnam, exist=filexist) if (fileage == 'new' .and. filexist) then call delfile(filnam, 1) end if end if if (gzipped > 0) then #if ZLIB if (gzipped == 2 .and. mode == 'r') then call newlun(strm) open(strm, file=filnam, status=fileage, & access='stream', form='unformatted', iostat=ios) port%filnam=filnam port%filtyp=PORT_BGZIPPED port%fstream=strm port%file_position=0 zbufpos=0 else call fgz_open(filnam, mode // 'b', port, ios) end if #else if (mode == 'r') then call uniqnam(5, wrkfil) wrkfil='sp-' // trim(wrkfil) // '.txt' call system('gzip -cd "' // trim(filnam) // '" > ' // wrkfil) port%filnam=wrkfil else if (filnam(max(1,(eon-2)):eon) == '.gz') then port%filnam=filnam(1:(eon-3)) else port%filnam=filnam end if end if call newlun(strm) open(strm, file=port%filnam, status=fileage, access='stream', form='formatted', iostat=ios) port%filtyp=PORT_COPY port%fstream=strm port%file_position=0 #endif #if POPEN else if (apipe) then if (mode == 'r') then call pipe_open(filnam(1:(eon-1)), port, ios) else call pipe_open(filnam(2:eon), port, ios) end if #endif else call newlun(strm) open(strm, file=filnam, status=fileage, access='stream', form='formatted', iostat=ios) port%filnam=filnam port%filtyp=PORT_STANDARD port%fstream=strm port%file_position=0 end if end subroutine open_port ! ! Reopen a file for reading or writing ! subroutine rewind_port(port, ios) type(ioport), intent(inout) :: port integer, intent(out) :: ios ios=0 if (port%filtyp == PORT_STANDARD .or. port%filtyp == PORT_COPY) then rewind(port%fstream) #if ZLIB else if (port%filtyp == PORT_GZIPPED) then call fgz_rewind(port, ios) else if (port%filtyp == PORT_BGZIPPED) then rewind(port%fstream) zbufpos=0 #endif #if POPEN else if (port%filtyp == PORT_PIPE) then call pipe_rewind(port, ios) #endif end if port%file_position=0 end subroutine rewind_port ! ! Set (read) position in a file or stream (if possible) ! subroutine seek_port(port, pos, ios) type(ioport), intent(inout) :: port integer (kind=8), intent(in) :: pos integer, intent(out) :: ios ios=0 if (port%filtyp == PORT_STANDARD .or. port%filtyp == PORT_COPY) then read(port%fstream, fmt='(a)', pos=pos, advance='no', iostat=ios) port%file_position = pos port%actual_file_position = pos #if ZLIB else if (port%filtyp == PORT_GZIPPED) then call fgz_seek(port, pos, ios) else if (port%filtyp == PORT_BGZIPPED) then call fgz_seek(port, pos, ios) #endif #if POPEN else if (port%filtyp == PORT_PIPE) then ios=-1 #endif end if end subroutine seek_port ! ! Return position in file ! function port_position(port) integer (kind=8) :: port_position type(ioport), intent(in) :: port port_position=port%file_position end function port_position ! ! Read one record from file ! subroutine readline(port, lin, advance, ignore_eol, ios) type (ioport) :: port character(len=*) :: lin character(len=*), optional :: advance character(len=*), optional :: ignore_eol integer, intent(out) :: ios character (len=3) :: advancing logical :: binary_mode ios=0 advancing='yes' binary_mode=.false. if (present(advance)) then advancing=advance end if if (present(ignore_eol)) then if (ignore_eol == 'yes') then advancing='no' binary_mode=.true. end if end if if (port%filtyp == PORT_STANDARD .or. port%filtyp == PORT_COPY) then read(port%fstream,'(a)', advance=advancing, iostat=ios) lin if (binary_mode .and. ios == eolcode) ios = 0 inquire(port%fstream, pos=port%actual_file_position) port%file_position = port%actual_file_position #if ZLIB else if (port%filtyp == PORT_GZIPPED) then call fgz_read(port, lin, advance=advancing, ignore_eol=binary_mode, ios=ios) else if (port%filtyp == PORT_BGZIPPED) then call bgzf_read(port, lin, advance=advancing, ignore_eol=binary_mode, ios=ios) #endif #if POPEN else if (port%filtyp == PORT_PIPE) then call pipe_read(port, lin, advance=advancing, ios=ios) if (binary_mode .and. ios == eolcode) ios = 0 #endif end if end subroutine readline ! ! Read next whitespace separated token from file, flagging if eol ! subroutine readtoken(port, word, ios) type (ioport) :: port character(len=*), intent(out) :: word integer, intent(out) :: ios character (len=2), parameter :: whitespace = achar(32) // achar(9) ios=0 if (port%filtyp == PORT_STANDARD .or. port%filtyp == PORT_COPY) then call stream_readtoken(port, word, whitespace, ios) #if ZLIB else if (port%filtyp == PORT_GZIPPED) then call fgz_readtoken(port, whitespace, word, ios) else if (port%filtyp == PORT_BGZIPPED) then call bgzf_readtoken(port, whitespace, word, ios) #endif #if POPEN else if (port%filtyp == PORT_PIPE) then call pipe_readtoken(port, whitespace, word, ios=ios) #endif end if end subroutine readtoken ! subroutine stream_readtoken(port, word, separator, ios) use outstream use iocodes type(ioport) :: port character(len=*), intent(in) :: separator character(len=*), intent(out) :: word integer, intent(out) :: ios integer :: pos, wlen character(len=1) :: ch ios=0 pos=0 wlen=len(word) word=' ' do read(port%fstream, '(a1)', advance='no', iostat=ios) ch if (ios /= 0) exit if (scan(ch, separator) /= 0) exit pos=pos+1 word(pos:pos)=ch end do port%file_position=port%file_position+pos end subroutine stream_readtoken ! ! read N bytes from the current port ! subroutine read_bytes(port, lin, ios) type (ioport), intent(in) :: port character(len=*) :: lin integer, intent(out) :: ios ich=0 call readline(port, lin, ignore_eol='yes', ios=ios) end subroutine read_bytes ! ! Write one record to file ! subroutine writeline(port, lin, advance, ios) type (ioport), intent(in) :: port character(len=*) :: lin character(len=*), optional :: advance integer, intent(out) :: ios character (len=3) :: advancing ios=0 advancing='yes' if (present(advance)) then advancing=advance end if if (port%filtyp == PORT_STANDARD .or. port%filtyp == PORT_COPY) then write(port%fstream,'(a)', advance=advancing, iostat=ios) lin #if ZLIB else if (port%filtyp == PORT_GZIPPED) then call fgz_write(port, lin, advance=advancing, ios=ios) else if (port%filtyp == PORT_BGZIPPED) then call fgz_write(port, lin, advance=advancing, ios=ios) #endif #if POPEN else if (port%filtyp == PORT_PIPE) then call pipe_write(port, lin, advance=advancing, ios=ios) #endif end if end subroutine writeline ! ! Close file for reading - ! if gzipped but ZLIB not available, then delete temporary file ! subroutine close_port(port, ios) type (ioport), intent(in) :: port integer, intent(out) :: ios ios=0 if (port%filtyp == PORT_STANDARD) then close(port%fstream) #if ZLIB else if (port%filtyp == PORT_GZIPPED) then call fgz_close(port, ios) else if (port%filtyp == PORT_BGZIPPED) then close(port%fstream) #else else if (port%filtyp == PORT_COPY) then close(port%fstream) if (port%stat == 'w') then call system('gzip "' // trim(port%filnam) // '"') else call delfile(port%filnam, -2) end if #endif #if POPEN else if (port%filtyp == PORT_PIPE) then call pipe_close(port, ios) #endif end if end subroutine close_port end module fileio ! ! String utilities ! module string_utilities public :: alnum, chfind, escape, strfind, toupper, tolower, & lcase, capitalize, fcheck, sclean, widest contains ! ! find an unescaped character in a string ! function chfind(string, ch) integer :: chfind character (len=*), intent(in) :: string character (len=1), intent(in) :: ch integer :: i, lent chfind=1 if (ch == string(chfind:chfind)) return lent=len_trim(string) do chfind=2, lent if (ch == string(chfind:chfind)) then i=chfind-1 #if defined (WIN32) || defined (IFORT) || defined (NOESCAPE) if (string(i:i) == '\') then #else if (string(i:i) == '\\') then #endif cycle end if return end if end do chfind=0 end function chfind ! ! functions supporting regexp ! notice alnum includes "_" ! function alnum(ch) logical :: alnum character (len=1) :: ch integer :: ich ich=ichar(ch) alnum = ((ich > 47 .and. ich < 58) .or. & (ich > 64 .and. ich < 91) .or. & (ich > 94 .and. ich < 123)) end function alnum ! ! test if at start of word ! function on_sow(string, pos) logical :: on_sow character (len=*), intent(in) :: string integer, intent(in) :: pos on_sow=.false. if (pos > len(string) .or. pos < 1) return if (alnum(string(pos:pos))) then if (pos == 1) then on_sow=.true. else if (pos > 1) then on_sow = .not.alnum(string((pos-1):(pos-1))) end if end if end function on_sow ! ! test if at end of word - is backward looking function on_eow(string, pos) logical :: on_eow character (len=*), intent(in) :: string integer, intent(in) :: pos on_eow=.false. if (pos < 2) return if (pos > len(string)) then on_eow=.true. else if (.not.alnum(string(pos:pos))) then on_eow = alnum(string((pos-1):(pos-1))) end if end function on_eow ! ! Compare string to a search string, allowing wildcards '*.', ! metacharacters \<, \>, simple lists of characters [ccc], ! and case matching ! function strfind(regexp, targt, nocase) logical :: strfind character (len=*), intent(in) :: regexp character (len=*), intent(in) :: targt integer, intent(in) :: nocase ! 1=respect 2=ignore integer :: i, ich1, ich2, lenr, lent, pos, rbrace, wpos logical :: looking, metachar integer :: wild ! 0=not 1=wild 2=wild+literal lenr=len_trim(regexp) lent=len_trim(targt) ! while regexp and target not exhausted if (lent == 0 .or. lenr == 0) then strfind=.false. if (lenr == 1) strfind=(regexp(lenr:lenr) == '*') return end if i=1 pos=1 wpos=0 wild=0 looking=.true. strfind=.true. do while (looking) !---DEBUG ! do ! write(*,*) regexp(1:(pos-1)), ' ->', regexp(pos:pos), '<- ', regexp(pos+1:lenr), & ! ' <|> ', targt(1:(i-1)), ' ->', targt(i:i), '<- ', targt(i+1:lent), ' ', & ! strfind, ' wild=', wild, ' metachar=', metachar ! if (.not.looking) exit metachar=.false. if (regexp(pos:pos) == '*') then wild=1 wpos=pos pos=pos+1 looking=(pos <= lenr) else ! this character matches? if (regexp(pos:pos) == '.' .and. wild == 0) then strfind=.true. else if (regexp(pos:pos) == '[') then rbrace=index(regexp((pos+1):lenr),']') if (rbrace > 0) then rbrace=rbrace+pos strfind=brackexp(regexp((pos+1):(rbrace-1)), targt(i:i)) pos=rbrace else strfind=(regexp(pos:pos) == targt(i:i)) end if #if defined (WIN32) || defined (IFORT) || defined (NOESCAPE) else if (regexp(pos:pos) == '\') then #else else if (regexp(pos:pos) == '\\') then #endif if (pos < lenr) then pos=pos+1 if (regexp(pos:pos) == '<') then metachar=.true. strfind=on_sow(targt, i) else if (regexp(pos:pos) == '>') then metachar=.true. strfind=on_eow(targt, i) else strfind=(regexp(pos:pos) == targt(i:i)) end if end if else if (nocase == 2) then ich1=ichar(regexp(pos:pos)) ich2=ichar(targt(i:i)) if (ich1 >= 65 .and. ich1 <= 90) ich1=ich1+32 if (ich2 >= 65 .and. ich2 <= 90) ich2=ich2+32 strfind=(ich1 == ich2) else strfind=(regexp(pos:pos) == targt(i:i)) end if looking=strfind if (wild == 1 .and. .not.metachar) wild=wild+1 ! if metacharacter and wild+literal do not advance i if (metachar .and. wild > 1) i=i-1 if (wild > 0) then looking=.true. if (.not.strfind) then pos=wpos wild=1 end if end if pos=pos+1 i=i+1 ! target exhausted? If regexp ends in wild card or end-of-word, then found if (i > lent) then looking=.false. if (pos == (lenr-1)) then if (regexp(pos:pos+1) == '\>') then if (wild == 1) strfind=.true. pos=pos+2 end if end if if (pos == lenr) then if (regexp(pos:pos) == '*') wild=1 end if if (pos <= lenr .and. wild /= 1) strfind=.false. end if ! regexp exhausted? if regexp doesn't end in wild card, then not found ! so [-recycle completely-] exit if (pos > lenr) then if (i <= lent) then if (wild > 0) then looking=.false. strfind=.true. else looking=.false. strfind=.false. end if end if ! if not exhausted and only partial match and previous wild card, then recycle else if (.not.strfind .and. wpos /= 0 .and. i <= lent) then looking=.true. pos=wpos+1 end if end if end do end function strfind ! ! Evaluate bracket expression: range ! function brackexp(be, ch) logical :: brackexp character (len=*), intent(in) :: be character (len=1), intent(in) :: ch integer, parameter :: dash = 45 integer :: i, ich, inext, j, k, pos, siz logical :: nocaret nocaret=.true. ich=ichar(ch) pos=0 siz=len(be) pos=1 if (be(pos:pos) == '^') then nocaret=.false. pos=pos+1 end if j=pos+1 do while (pos <= siz) inext=-1 if (pos < siz) inext=ichar(be(j:j)) if (inext == dash .and. j < siz) then k=j+1 do i=ichar(be(pos:pos)), ichar(be(k:k)) if (ich == i) then brackexp=nocaret return end if end do pos=pos+2 else if (be(pos:pos) == ch) then brackexp=nocaret return end if pos=pos+1 j=j+1 end do brackexp=.not.nocaret end function brackexp ! ! Escape a target character, usually " ! 20260508 added doubled quotes as equivalent ! subroutine escape(str, trget, ifail) character (len=*) :: str character (len=1) :: trget integer, optional, intent(out) :: ifail integer :: i, n, off, siz if (present(ifail)) ifail = 0 siz=len(str) n=len_trim(str) i=n do while (i > 0) if (str(i:i) == trget) n=n+1 i=i-1 end do if (n >= siz) then write(*,'(3a/7x,a,i5,a)') & 'ERROR: Ran out of room while escaping <',trget,'>.', & 'Buffer length is ', siz, ' characters.' if (present(ifail)) ifail = -1 return end if n=len_trim(str) i=n do while (i > 0) if (str(i:i) == trget) then off=1 if (i > 1) then if (str((i-1):(i-1))==trget .and. & (trget=='"' .or. trget=='''')) then off=2 end if end if #if defined (WIN32) || defined (IFORT) || defined (NOESCAPE) str=str(1:(i-off)) // '\' // str(i:n) #else str=str(1:(i-off)) // '\\' // str(i:n) #endif n=n+2-off end if i=i-1 end do end subroutine escape ! ! lower to upper case alphabetic ! subroutine toupper(str) character(len=*) :: str integer :: i, ich do i=1, len_trim(str) ich=ichar(str(i:i)) if (ich > 96 .and. ich < 123) then str(i:i)=achar(ich-32) end if end do end subroutine toupper ! subroutine tolower(str) character(len=*) :: str integer :: i, ich do i=1, len_trim(str) ich=ichar(str(i:i)) if (ich > 64 .and. ich < 91) then str(i:i)=achar(ich+32) end if end do end subroutine tolower ! ! And a function equivalent ! function lcase(str) result (res) character(len=*) :: str character(len=len(str)) :: res integer :: i, ich res=str do i=1, len(str) ich=ichar(str(i:i)) if (ich > 64 .and. ich < 91) then res(i:i)=achar(ich+32) end if end do end function lcase ! subroutine capitalize(str) character(len=*) :: str integer :: i, ich logical :: cap cap=.true. do i=1, len_trim(str) ich=ichar(str(i:i)) if (cap) then if (ich > 96 .and. ich < 123) then str(i:i)=achar(ich-32) end if cap=.false. else if (ich > 64 .and. ich < 91) then str(i:i)=achar(ich+32) else if (ich == 32 .or. ich == 9) then cap=.true. end if end if end do end subroutine capitalize ! ! check that Fortran format statement matches write arguments ! only tests number and all one type ! function fcheck(fstring, narg, vtype) result (res) logical :: res character (len=*) :: fstring integer :: narg character (len=1) :: vtype integer :: i, irpt, j, k, n, nd, slen character (len=1) :: ch character (len=5) :: ftypes = 'abfgi' character (len=11) :: digit = '0123456789.' character (len=2) :: brackets = '()' logical :: inamatch res=.false. n=0 nd=0 irpt=0 inamatch=.false. slen=len_trim(fstring) if (fstring(1:1) == '(' .and. fstring(slen:slen) == ')') then do i=2, slen-1 ch=fstring(i:i) call tolower(ch) if (ch == vtype) then if (vtype == 'x') then if (nd > 0) then n=n+1 if (n > narg) exit else exit end if else if (nd > 0) then j=i-nd k=i-1 read(fstring(j:k),'(i' //fstring(j:k) // ')') irpt n=n+irpt else n=n+1 inamatch=.true. end if res=.true. nd=0 else if (scan(ch, digit) > 0) then nd=nd+1 else if (ch == 'x' .or. ch == ',') then nd=0 else if (scan(ch, brackets) > 0) then if (inamatch) then res=.false. exit else if (nd > 0) then read(fstring((i-nd+1):i),'(i10)') irpt end if else if (scan(ch, ftypes) > 0) then res=.false. exit end if end do end if res=(res .and. n == narg) end function fcheck ! ! scrub non-ASCII characters ! subroutine sclean(string) character (len=*), intent(inout) :: string integer :: i do i=1, len(string) if (ichar(string(i:i)) < 32) then string(i:i)=' ' end if end do end subroutine sclean ! ! cast integer to string ! function int2str(iv) character (len=:), allocatable :: int2str integer, intent(in) :: iv integer :: nchar nchar=1+int(floor(log10(real(abs(iv))))) if (iv < 0) nchar=nchar+1 allocate(character(len=nchar) :: int2str) write(int2str,'(i0)') iv end function int2str ! ! longest word in character array ! function widest(words) integer :: widest character(len=*), dimension(:) :: words integer :: i, n, w n=size(words) widest=0 do i=1, n w=len_trim(words(i)) if (w > widest) widest=w end do end function widest end module string_utilities ! ! Scanner ! module scanner ! typ action - slashes are allowed in id strings, but elsewhere are a separator ! 1 whitespace separated ! 2 whitespace separated or reserved character (id by opchar) ! 3 whitespace or slash separated (so genotypes can be written a/b) ped data ! 4 whitespace or slash separated (so genotypes can be written a/b) case data ! 5 whitespace or slash separated (so genotypes can be written a/b) case data, noid ! 6 character or slash separated (eg CSV, TSV with genotypes written a/b) ! 7 character separated (eg CSV, TSV) ! integer, parameter :: SEP_WHITE=1, SEP_WH_RES=2, & SEP_WH_SLASH_PED=3, SEP_WH_SLASH_CAS=4, & SEP_WH_SLASH_CAS_NOID=5, SEP_CHAR_SLASH=6, SEP_CHAR=7 character (len=13), parameter :: opchar='][()*+-/<=>^:' character (len=3), parameter :: opsimple='=:;' character (len=4), parameter :: opvcfdec='=:;,' contains ! ! skip leading whitespace ! function sow(string) integer :: sow character (len=*), intent(in) :: string integer :: i i=0 do i=1, len(string) if (string(i:i) /= ' ' .and. ichar(string(i:i)) /= 9) then exit end if end do sow=i end function sow ! ! Test if reading a CSV file - based on whether current line contains a ! number of likely separators ! function countsep(sep, s) integer :: countsep character (len=*), intent(in) :: s character (len=1), intent(in) :: sep integer :: i, n n=0 do i=1, len(s) if (s(i:i) == sep) n=n+1 end do countsep=n end function countsep ! ! Next token in buffer ! ! Need to know which word if reading pedigree or case-control data (with ! or without ID) as slashes separate alleles in data but are allowed in ! ID strings ! ! typ action ! 1 SEP_WHITE whitespace separated ! 2 SEP_WH_RES whitespace separated or reserved character (id by reserved string) ! 3 SEP_WH_SLASH whitespace or slash separated (so genotypes can be written a/b) ped data ! 4 SEP_WH_SLASH_CAS whitespace or slash separated (so genotypes can be written a/b) case data ! 5 SEP_WH_SLASH_CAS_NOID whitespace or slash separated (so genotypes can be written a/b) case data, noid ! 6 SEP_CHAR_SLASH character or slash separated (eg CSV, TSV with genotypes written as a/b) ! 7 SEP_CHAR character separated (eg CSV, TSV) ! subroutine nextword(pos, s, eos, reserved, nword, word, stat, sep, typ) integer, intent(inout) :: pos character (len=*), intent(in) :: s integer, intent(in) :: eos character (len=*):: reserved integer, intent(inout) :: nword character (len=*), intent(out) :: word integer, intent(out) :: stat character (len=1), intent(in) :: sep integer, intent(in) :: typ integer :: skip_ids ! Fields to skip splitting on slashes integer :: iarg, nsep, sarg character (len=1) :: ch character (len=1), parameter :: tab = achar(9) character (len=1), parameter :: cr = achar(13) word=' ' stat=-1 if (pos > eos) return ! ! skip ped,id,fa,mo or id or none skip_ids=4 if (typ == SEP_WH_SLASH_CAS) skip_ids=1 if (typ == SEP_WH_SLASH_CAS_NOID) skip_ids=0 stat=0 nsep=0 ! Added 20180423 ! on a separator and style is SEP_CHAR; and 20210909, SEP_CHAR_SLASH when on '/' if (((typ == SEP_CHAR .or. typ == SEP_CHAR_SLASH) .and. s(pos:pos) == sep) .or. & (typ == SEP_CHAR_SLASH .and. s(pos:pos) == '/')) then if (pos == 1 .and. nword == 0) then nword=nword+1 return end if pos=pos+1 if (pos > eos) then nword=nword+1 return end if end if ! ! start of main loop do while (pos <= eos) ch=s(pos:pos) ! a reserved operator is one word if (typ==SEP_WH_RES .and. scan(ch, reserved) > 0) then word=ch nword=nword+1 pos=pos+1 return ! if not for language parser, ! skip slashes as these are genotype allele separators else if (typ > SEP_WH_RES .and. typ < SEP_CHAR .and. nword > skip_ids & .and. ch == '/') then continue ! quoted text, usually genotypes "a/b" else if (ch .eq.'"') then iarg=-1 ! skip leading blanks within quotes ! may be unmatched quote do pos=pos+1 if (pos >= eos) exit if (s(pos:pos) /= ' ') exit end do sarg=pos do if (pos > eos) exit if (s(pos:pos) == '"') exit iarg=iarg+1 pos=pos+1 end do word=s(sarg:(sarg+iarg)) nword=nword+1 pos=pos+1 return ! any other character must start a word so read up to next boundary ! notice kludge for DOS line ends under unix (20180112) else if (ch /= ' ' .and. ch /= tab) then iarg=-1 sarg=pos findeow: do if (pos > eos) exit ch=s(pos:pos) if (typ == SEP_CHAR .or. typ == SEP_CHAR_SLASH) then if (ch == sep) exit else if (ch ==' ' .or. ch == tab .or. ch == cr .or. ch == '"') exit end if if (typ > SEP_WH_RES .and. typ < SEP_CHAR .and. ch == '/') exit if (typ == SEP_WH_RES) then ! kludge for exponential notation if (scan(ch, reserved) > 0) then if (ch == '-' .or. ch == '+') then if ((pos-sarg) < 2) exit ch=s((pos-1):(pos-1)) if (ch /= 'd' .and. ch /= 'D' .and. ch /= 'e' .and. ch /= 'E') exit do j=sarg, pos-3 ich=ichar(s(j:j)) if (ich /= 46 .and. (ich < 48 .or. ich > 57)) exit findeow end do else exit end if end if end if iarg=iarg+1 pos=pos+1 end do findeow pos=pos-1 ! word=s(sarg:(sarg+iarg)) nword=nword+1 pos=pos+1 return end if pos=pos+1 end do stat=-1 end subroutine nextword ! ! extracts narg arguments from input string s ! subroutine args(s, narg, arg, sep, typ) character (len=*), intent(in) :: s integer, intent(in) :: typ integer, intent(inout) :: narg character (len=*), dimension(:), intent(out) :: arg character (len=1) :: sep integer :: eol, i, maxwords, n, sol, stat character (len=512) :: word maxwords=size(arg) do i=1, min(narg, maxwords) arg(i)=' ' end do if (len(s)==0 .or. s=='') then narg=0 return end if ! sol=sow(s) eol=len_trim(s) n=0 i=sol do call nextword(i, s, eol, opchar, n, word, stat, sep, typ) if (stat == -1) exit arg(n)=word if (n == maxwords) exit end do narg=n end subroutine args ! ! extracts the nth whitespace or character separated argument ! from input string s ! subroutine getword(s, which, word, sep, style) character (len=*), intent(in) :: s integer, intent(in) :: which character (len=*), intent(out) :: word character(len=1), optional :: sep integer, optional :: style integer :: eol, i, n, sol, stat, typ character (len=1) :: sepchar ! functions ! logical :: opchar word=' ' if (len(s)==0 .or. s=='') return sol=sow(s) eol=len_trim(s) typ=SEP_WHITE sepchar=' ' if (present(sep)) then sepchar=sep typ=SEP_CHAR end if if (present(style)) then typ=style end if n=0 i=sol do call nextword(i, s, eol, opchar, n, word, stat, sepchar, typ) if (stat == -1) then word=' ' exit else if (n == which) then exit end if end do end subroutine getword ! ! Find start or end of nth whitespace-separated argument in input string s ! function wordpos(s, which, first) integer wordpos character (len=*), intent(in) :: s integer, intent(in) :: which logical, intent(in), optional :: first character (len=1), parameter :: tab = achar(9) integer :: eol, i, n, sol, stat character(len=1) :: word wordpos=0 if (len(s)==0 .or. s=='') return sol=sow(s) eol=len_trim(s) n=0 i=sol do call nextword(i, s, eol, opchar, n, word, stat, ' ', SEP_WHITE) if (stat == -1) then exit else if (n == which) then exit end if end do if (n < which) return if (present(first)) then if (first .and. i > 0) then i=i-1 do while (s(i:i) /= ' ' .and. s(i:i) /= tab) i=i-1 end do end if end if wordpos=i end function wordpos ! ! Return count of (whitespace-separated) arguments from input string s ! function countargs(s, sep, typ) integer :: countargs character (len=*), intent(in) :: s character (len=1) :: sep integer, intent(in) :: typ character (len=3) :: word integer :: eol, i, n, sol, stat countargs=0 if (len(s)==0) return sol=sow(s) eol=len_trim(s) n=0 i=sol stat=0 do while (stat == 0) call nextword(i, s, eol, opchar, n, word, stat, sep, typ) end do countargs=n end function countargs ! ! Get next non-blank line from a port and split into words ! subroutine getlin(port, narg, words, lin, skipbl) use fileio type(ioport), intent(in) :: port integer, intent(out) :: narg character (len=40), dimension(:), intent(in out) :: words character (len=*), intent(inout) :: lin integer, intent(in) :: skipbl integer :: ioerr do call readline(port, lin, ios=ioerr) if (ioerr /= 0) exit narg=size(words) call args(lin, narg, words, ' ', SEP_WHITE) if (skipbl /= 1 .or. narg /= 0) exit end do end subroutine getlin ! ! Return index of first matching (whitespace-or-other-separated) word ! in input string s ! eg wordfind('GQ','GT:AD:GQ:PL:DP',':',SEP_CHAR) => 3 ! function wordfind(target_word, s, sep, typ, exact) integer :: wordfind character (len=*), intent(in) :: target_word character (len=*), intent(in) :: s character (len=1) :: sep integer, intent(in) :: typ logical, optional, intent(in) :: exact character (len=len(target_word)) :: word integer :: eol, i, n, sol, stat logical :: allow_extra_text wordfind=0 if (len(s) == 0 .or. len(target_word) == 0) return allow_extra_text = .FALSE. if (present(exact)) then allow_extra_text = .not.exact end if sol=sow(s) eol=len_trim(s) n=0 i=sol stat=0 if (allow_extra_text) then do while (stat == 0) call nextword(i, s, eol, opchar, n, word, stat, sep, typ) if (index(word, trim(target_word)) == 1) then wordfind=n return end if end do else do while (stat == 0) call nextword(i, s, eol, opchar, n, word, stat, sep, typ) if (word == target_word) then wordfind=n return end if end do end if end function wordfind ! ! Extracts the matching label for a list of value=label pairs in a string ! subroutine get_label(val, s, label, prefix) double precision, intent(in) :: val character (len=*), intent(in) :: s character (len=*), intent(out) :: label logical, intent(in) :: prefix integer :: cpos, eol, i, lenlab, n, npos, sol, stat character (len=len(label)), dimension(0:2) :: circular character(len=20) :: fstring ! functions logical :: isreal double precision :: fval lenlab=len(label) label=' ' if (anint(val) == val) then write(fstring, '(a,i0,a)') '(i',lenlab, ')' write(label, fstring) int(val) label=adjustl(label) else write(fstring, '(a,i0,a)') '(f',lenlab, '.0)' write(label, fstring) val label=adjustl(label) end if if (len(s) == 0 .or. s == '') return circular(0:2)=' ' sol=sow(s) eol=len_trim(s) cpos=2 i=sol n=1 do cpos=mod(cpos+1,3) call nextword(i, s, eol, opsimple, n, circular(mod(cpos+1,3)), stat, ' ', SEP_WH_RES) if (stat == -1) then return else if (circular(cpos) == '=') then npos=mod(cpos+2,3) if (isreal(circular(npos))) then if (fval(circular(npos)) == val) then if (prefix) then label=trim(circular(npos)) // '=' // circular(mod(cpos+1,3)) else label=circular(mod(cpos+1,3)) end if return end if end if end if end do end subroutine get_label ! ! Extracts the value or the name from a matched name=value pair in a string ! subroutine getpairval(varnam, s, reserved, res, forward) character (len=*), intent(in) :: varnam character (len=*), intent(in) :: s character (len=*), intent(in) :: reserved ! list of reserved characters character (len=*), intent(out) :: res logical, optional, intent(in) :: forward integer :: cpos, dir, eol, i, n, sol, stat character (len=len(res)), dimension(0:2) :: circular res=' ' if (len(s) == 0 .or. s == '') return dir=1 if (present(forward)) then if (.not.forward) dir=dir+1 end if circular(0:2)=' ' sol=sow(s) eol=len_trim(s) cpos=2 i=sol n=1 do cpos=mod(cpos+1,3) call nextword(i, s, eol, reserved, n, circular(mod(cpos+1,3)), stat, ' ', SEP_WH_RES) if (stat == -1) then return else if (circular(cpos) == '=') then if (circular(mod(cpos+3-dir,3)) == varnam) then res=circular(mod(cpos+dir,3)) return end if end if end do end subroutine getpairval ! ! Simpler scanner that returns position of beginning and end of each word Nx2 array ! subroutine wordbounds(str, separators, nwords, bounds) character (len=*), intent(in) :: str character (len=*), intent(in) :: separators integer :: nwords integer, dimension(:,:) :: bounds integer :: i, maxw, nc logical :: inword nc=len_trim(str) maxw=size(bounds,1) nwords=0 bounds=0 inword=.false. do i=1, nc if (scan(str(i:i), separators) > 0) then inword=.false. else if (.not.inword) then if (nwords == maxw) return nwords=nwords+1 bounds(nwords,1)=i end if bounds(nwords,2)=i inword=.true. end if end do end subroutine wordbounds ! ! Replace white space and reserved characters ! in words with underscores ! subroutine sanitize(nwords, word) integer, intent(in) :: nwords character (len=*), dimension (nwords) :: word integer :: i, j, wlen character (len=1), parameter :: tab = achar(9) do i=1, nwords wlen=len_trim(word(i)) do j=1, wlen if (word(i)(j:j) == ' ' .or. word(i)(j:j) == tab) then word(i)(j:j) = '_' else if (scan(word(i)(j:j), opchar) > 0) then word(i)(j:j) = '_' end if end do end do end subroutine sanitize end module scanner ! ! Parse a datestring a la R's format.Date ! module datestring use timelib integer (kind=1), dimension(32), parameter :: month_hash = (/ & 4, 5, 0, 33, 0, 33, 9, 33, 33, 33, 33, 4, 33, & 10, 3, 15, 33, 15, 33, 13, 0, 0, 33, 33, 4, 33, 33, 33, 33, 33, 33, 33 /) integer (kind=1), dimension(32), parameter :: month_num = (/ & 12,0,0,11,7,2,0,0, 5,8,6,0,0,10,1,9, & 0,0,0,3,0,0,0,0, 0,0,0,0,0,0,0,4 /) contains ! ! Hash to speed up abbr month string -> number ! function get_month_number(str) integer :: get_month character(len=3), intent(in) :: str integer :: i, j, imonth get_month_number=0 i=mod(ichar(str(2:2)),32) j=mod(ichar(str(3:3)),32) imonth=1+month_hash(i) + month_hash(j) if (imonth < 33) then imonth=month_num(imonth) if (months(imonth) == str) then get_month_number=imonth end if end if end function get_month_number ! ! Converts date string to Gregorian integer YYYYMMDD ! Apparently POSIX %y if <68 then 20xx else 19xx ! subroutine parse_string_date(sdate, idate, fstring, ierr) use string_utilities character(len=*), intent(in) :: sdate integer(kind=8), intent(out) :: idate character(len=*), intent(in) :: fstring integer, intent(out) :: ierr integer :: eofs, eos, fpos, pos, istate, success integer(kind=8) :: idy, imo, itmp, iyr character (len=1) :: ch character (len=3) :: cmonth ierr=-1 idate=0 idy=1 imo=1 iyr=1970 if (fstring /= '') then if (fstring == 'D' .or. fstring == 'm/d/y') then success=7 read(sdate,'(i2,1x,i2,1x,i2)', err=999) imo, idy, iyr iyr=2000+iyr else if (fstring == 'F' .or. fstring == 'Y-m-d' .or. & fstring == 'Y/m/d') then success=7 read(sdate ,'(i4,1x,i2,1x,i2)', err=999) iyr, imo, idy else success=0 istate=0 eos=len_trim(sdate) eofs=len_trim(fstring) fpos=1 pos=1 do while (pos <= eos .and. fpos <= eofs) ch=fstring(fpos:fpos) if (ch == 'd') then read(sdate(pos:(pos+1)),'(i2)', err=999) idy success=success+1 pos=pos+2 else if (ch == 'b') then cmonth=sdate(pos:(pos+2)) call capitalize(cmonth) itmp=get_month_number(cmonth) if (itmp > 0) then imo=itmp success=success+2 end if pos=pos+3 else if (ch == 'm') then read(sdate(pos:(pos+1)),'(i2)', err=999) imo success=success+2 pos=pos+2 else if (ch == 'y') then read(sdate(pos:(pos+1)),'(i2)', err=999) iyr iyr=2000+iyr success=success+4 pos=pos+4 else if (ch == 'Y') then read(sdate(pos:(pos+3)),'(i4)', err=999) iyr success=success+4 pos=pos+4 else if (scan(ch, ' /-:') > 0) then if (ch /= sdate(pos:pos)) then exit end if pos=pos+1 else pos=pos+1 end if fpos=fpos+1 end do end if if (success >= 4) then ierr=0 idate=10000*iyr + 100*imo + idy end if else ! YYYYMMDD if (len_trim(sdate) == 8) then success=7 do i=1, 8 ich=ichar(sdate(i:i)) if (ich < 48 .or. ich > 57) then success=0 exit end if end do if (success == 7) then ierr=0 read(sdate,'(i8)') idate return end if end if end if 999 continue end subroutine parse_string_date end module datestring ! ! Sorting etc ! module sorts contains ! ! SLATEC quicksort routine. Jones, Kahaner and Wisniewski. ! double precision ! subroutine dsort(n, dx) integer, intent(in) :: n double precision, dimension(:) :: dx ! local scalars double precision r, t, tt integer i, ij, j, k, l, m, nn ! local arrays .. integer il(21), iu(21) nn=n m = 1 i = 1 j = nn r = 0.375d0 20 continue if (i == j) go to 60 if (r <= 0.5898437d0) then r = r+3.90625d-2 else r = r-0.21875d0 end if 30 continue k = i ! ! select a central element of the array and save it in location t ! ij = i + int((j-i)*r) t = dx(ij) ! ! if first element of array is greater than t, interchange with t ! if (dx(i) > t) then dx(ij) = dx(i) dx(i) = t t = dx(ij) end if l = j ! ! if last element of array is less than than t, interchange with t ! if (dx(j) < t) then dx(ij) = dx(j) dx(j) = t t = dx(ij) ! ! if first element of array is greater than t, interchange with t ! if (dx(i) .gt. t) then dx(ij) = dx(i) dx(i) = t t = dx(ij) end if end if ! ! find an element in the second half of the array which is smaller than t ! do do l = l-1 if (dx(l) <= t) exit end do ! ! find an element in the first half of the array which is greater than t ! do k = k+1 if (dx(k) >= t) exit end do ! ! interchange these elements ! if (k > l) exit tt = dx(l) dx(l) = dx(k) dx(k) = tt end do ! ! save upper and lower subscripts of the array yet to be sorted ! if (l-i .gt. j-k) then il(m) = i iu(m) = l i = k m = m+1 else il(m) = k iu(m) = j j = l m = m+1 endif go to 70 ! ! begin again on another portion of the unsorted array ! 60 continue m = m-1 if (m .eq. 0) return i = il(m) j = iu(m) 70 continue if (j-i .ge. 1) go to 30 if (i .eq. 1) go to 20 i = i-1 80 continue i = i+1 if (i .eq. j) go to 60 t = dx(i+1) if (dx(i) .le. t) go to 80 k = i 90 continue dx(k+1) = dx(k) k = k-1 if (t .lt. dx(k)) go to 90 dx(k+1) = t go to 80 end subroutine dsort ! ! SLATEC quicksort routine. Jones, Kahaner and Wisniewski. ! here allowing for a missing value indicator, and carrying an indicator along ! pulls down the missing data. To sort test statistics retaining a pointer ! to the variable name ! subroutine srank(n, x, iy) integer :: n double precision, dimension(:) :: x integer, dimension(:) :: iy ! local scalars double precision, dimension(n) :: dx integer, parameter :: MISS=-9999 double precision r, t, tt integer i, ij, j, k, l, m, nn, tty, ty ! local arrays .. integer il(21), iu(21) if (n < 1) return dx=x(1:n) nn=n m = 1 i = 1 j = nn r = 0.375d0 20 continue if (i == j) go to 60 if (r <= 0.5898437d0) then r = r+3.90625d-2 else r = r-0.21875d0 end if 30 continue k = i ! ! select a central element of the array and save it in location t ! ij = i + int((j-i)*r) t = dx(ij) ty = iy(ij) ! ! if first element of array is greater than t, interchange with t ! if (dx(i) > t) then dx(ij) = dx(i) dx(i) = t t = dx(ij) iy(ij) = iy(i) iy(i) = ty ty = iy(ij) end if l = j ! ! if last element of array is less than than t, interchange with t ! if (dx(j) < t) then dx(ij) = dx(j) dx(j) = t t = dx(ij) iy(ij) = iy(j) iy(j) = ty ty = iy(ij) ! ! if first element of array is greater than t, interchange with t ! if (dx(i) > t) then dx(ij) = dx(i) dx(i) = t t = dx(ij) iy(ij) = iy(i) iy(i) = ty ty = iy(ij) end if end if ! ! find an element in the second half of the array which is smaller than t ! do do l = l-1 if (dx(l) <= t) exit end do ! ! find an element in the first half of the array which is greater than t ! do k = k+1 if (dx(k) >= t) exit end do ! ! interchange these elements ! if (k > l) exit tt = dx(l) dx(l) = dx(k) dx(k) = tt tty = iy(l) iy(l) = iy(k) iy(k) = tty end do ! ! save upper and lower subscripts of the array yet to be sorted ! if (l-i > j-k) then il(m) = i iu(m) = l i = k m = m+1 else il(m) = k iu(m) = j j = l m = m+1 endif go to 70 ! ! begin again on another portion of the unsorted array ! 60 continue m = m-1 ! ! test if finished -- look for any missing values if (m == 0) then i=1 do while (i <= nn) if (dx(i) == MISS) exit i=i+1 end do if (i <= nn) then j=i do while (j <= nn) if (dx(j) /= MISS) exit j=j+1 end do m=j-i do k=j, nn dx(k-m)=dx(k) iy(k-m)=iy(k) end do n=nn-m do k=n+1, nn iy(k)=0 end do end if return end if i = il(m) j = iu(m) 70 continue if (j-i >= 1) go to 30 if (i == 1) go to 20 i = i-1 80 continue i = i+1 if (i == j) go to 60 t = dx(i+1) ty = iy(i+1) if (dx(i) <= t) go to 80 k = i 90 continue dx(k+1) = dx(k) iy(k+1) = iy(k) k = k-1 if (t < dx(k)) go to 90 dx(k+1) = t iy(k+1) = ty go to 80 end subroutine srank ! ! SLATEC quicksort routine. Jones, Kahaner and Wisniewski. ! The option to sort descending has been removed, the argument order ! changed, and the sort is now from bot...top, rather than 1...top. ! subroutine isort(bot, top, ix, iy, kflag) integer, intent(in) :: bot integer, intent(in) :: top integer, intent(inout) :: ix(*) integer, intent(inout) :: iy(*) integer, intent(in) :: kflag ! local variables REAL :: r integer :: i, ij, j, k, l, m, nn, t, tt, ty, tty integer :: il(21), iu(21) nn = top if (nn < bot) RETURN if (kflag == 2) GO TO 100 ! Sort IX only m = 1 i = bot j = nn r = 0.375E0 20 if (i == j) GO TO 60 if (r <= 0.5898437E0) then r = r+3.90625E-2 else r = r-0.21875E0 end if 30 k = i ! Select a central element of the array and save it in location T ij = i + INT((j-i)*r) t = ix(ij) ! If first element of array is greater than T, interchange with T if (ix(i) > t) then ix(ij) = ix(i) ix(i) = t t = ix(ij) end if l = j ! If last element of array is less than than T, interchange with T if (ix(j) < t) then ix(ij) = ix(j) ix(j) = t t = ix(ij) ! If first element of array is greater than T, interchange with T if (ix(i) > t) then ix(ij) = ix(i) ix(i) = t t = ix(ij) end if end if ! Find an element in the second half of the array which is smaller ! than T 40 l = l-1 if (ix(l) > t) GO TO 40 ! Find an element in the first half of the array which is greater ! than T 50 k = k+1 if (ix(k) < t) GO TO 50 ! Interchange these elements if (k <= l) then tt = ix(l) ix(l) = ix(k) ix(k) = tt GO TO 40 end if ! Save upper and lower subscripts of the array yet to be sorted if (l-i > j-k) then il(m) = i iu(m) = l i = k m = m+1 else il(m) = k iu(m) = j j = l m = m+1 end if GO TO 70 ! Begin again on another portion of the unsorted array 60 m = m-1 if (m == 0) RETURN i = il(m) j = iu(m) 70 if (j-i >= 1) GO TO 30 if (i == 1) GO TO 20 i = i-1 80 i = i+1 if (i == j) GO TO 60 t = ix(i+1) if (ix(i) <= t) GO TO 80 k = i 90 ix(k+1) = ix(k) k = k-1 if (t < ix(k)) GO TO 90 ix(k+1) = t GO TO 80 ! Sort IX and carry IY along 100 m = 1 i = bot j = nn r = 0.375E0 110 if (i == j) GO TO 150 if (r <= 0.5898437E0) then r = r+3.90625E-2 else r = r-0.21875E0 end if 120 k = i ! Select a central element of the array and save it in location T ij = i + INT((j-i)*r) t = ix(ij) ty = iy(ij) ! If first element of array is greater than T, interchange with T if (ix(i) > t) then ix(ij) = ix(i) ix(i) = t t = ix(ij) iy(ij) = iy(i) iy(i) = ty ty = iy(ij) end if l = j ! If last element of array is less than T, interchange with T if (ix(j) < t) then ix(ij) = ix(j) ix(j) = t t = ix(ij) iy(ij) = iy(j) iy(j) = ty ty = iy(ij) ! If first element of array is greater than T, interchange with T if (ix(i) > t) then ix(ij) = ix(i) ix(i) = t t = ix(ij) iy(ij) = iy(i) iy(i) = ty ty = iy(ij) end if end if ! Find an element in the second half of the array which is smaller ! than T 130 l = l-1 if (ix(l) > t) GO TO 130 ! Find an element in the first half of the array which is greater ! than T 140 k = k+1 if (ix(k) < t) GO TO 140 ! Interchange these elements if (k <= l) then tt = ix(l) ix(l) = ix(k) ix(k) = tt tty = iy(l) iy(l) = iy(k) iy(k) = tty GO TO 130 end if ! Save upper and lower subscripts of the array yet to be sorted if (l-i > j-k) then il(m) = i iu(m) = l i = k m = m+1 else il(m) = k iu(m) = j j = l m = m+1 end if GO TO 160 ! Begin again on another portion of the unsorted array 150 m = m-1 if (m == 0) RETURN i = il(m) j = iu(m) 160 if (j-i >= 1) GO TO 120 if (i == 1) GO TO 110 i = i-1 170 i = i+1 if (i == j) GO TO 150 t = ix(i+1) ty = iy(i+1) if (ix(i) <= t) GO TO 170 k = i 180 ix(k+1) = ix(k) iy(k+1) = iy(k) k = k-1 if (t < ix(k)) GO TO 180 ix(k+1) = t iy(k+1) = ty GO TO 170 end subroutine isort ! subroutine long_isort(bot, top, ix, iy, kflag) integer, intent(in) :: bot integer, intent(in) :: top integer (kind=8), intent(inout) :: ix(*) integer, intent(inout) :: iy(*) integer, intent(in) :: kflag ! local variables REAL :: r integer :: i, ij, j, k, l, m, nn, ty, tty integer (kind=8) :: t, tt integer :: il(21), iu(21) nn = top if (nn < bot) RETURN if (kflag == 2) GO TO 100 ! Sort IX only m = 1 i = bot j = nn r = 0.375E0 20 if (i == j) GO TO 60 if (r <= 0.5898437E0) then r = r+3.90625E-2 else r = r-0.21875E0 end if 30 k = i ! Select a central element of the array and save it in location T ij = i + INT((j-i)*r) t = ix(ij) ! If first element of array is greater than T, interchange with T if (ix(i) > t) then ix(ij) = ix(i) ix(i) = t t = ix(ij) end if l = j ! If last element of array is less than than T, interchange with T if (ix(j) < t) then ix(ij) = ix(j) ix(j) = t t = ix(ij) ! If first element of array is greater than T, interchange with T if (ix(i) > t) then ix(ij) = ix(i) ix(i) = t t = ix(ij) end if end if ! Find an element in the second half of the array which is smaller ! than T 40 l = l-1 if (ix(l) > t) GO TO 40 ! Find an element in the first half of the array which is greater ! than T 50 k = k+1 if (ix(k) < t) GO TO 50 ! Interchange these elements if (k <= l) then tt = ix(l) ix(l) = ix(k) ix(k) = tt GO TO 40 end if ! Save upper and lower subscripts of the array yet to be sorted if (l-i > j-k) then il(m) = i iu(m) = l i = k m = m+1 else il(m) = k iu(m) = j j = l m = m+1 end if GO TO 70 ! Begin again on another portion of the unsorted array 60 m = m-1 if (m == 0) RETURN i = il(m) j = iu(m) 70 if (j-i >= 1) GO TO 30 if (i == 1) GO TO 20 i = i-1 80 i = i+1 if (i == j) GO TO 60 t = ix(i+1) if (ix(i) <= t) GO TO 80 k = i 90 ix(k+1) = ix(k) k = k-1 if (t < ix(k)) GO TO 90 ix(k+1) = t GO TO 80 ! Sort IX and carry IY along 100 m = 1 i = bot j = nn r = 0.375E0 110 if (i == j) GO TO 150 if (r <= 0.5898437E0) then r = r+3.90625E-2 else r = r-0.21875E0 end if 120 k = i ! Select a central element of the array and save it in location T ij = i + INT((j-i)*r) t = ix(ij) ty = iy(ij) ! If first element of array is greater than T, interchange with T if (ix(i) > t) then ix(ij) = ix(i) ix(i) = t t = ix(ij) iy(ij) = iy(i) iy(i) = ty ty = iy(ij) end if l = j ! If last element of array is less than T, interchange with T if (ix(j) < t) then ix(ij) = ix(j) ix(j) = t t = ix(ij) iy(ij) = iy(j) iy(j) = ty ty = iy(ij) ! If first element of array is greater than T, interchange with T if (ix(i) > t) then ix(ij) = ix(i) ix(i) = t t = ix(ij) iy(ij) = iy(i) iy(i) = ty ty = iy(ij) end if end if ! Find an element in the second half of the array which is smaller ! than T 130 l = l-1 if (ix(l) > t) GO TO 130 ! Find an element in the first half of the array which is greater ! than T 140 k = k+1 if (ix(k) < t) GO TO 140 ! Interchange these elements if (k <= l) then tt = ix(l) ix(l) = ix(k) ix(k) = tt tty = iy(l) iy(l) = iy(k) iy(k) = tty GO TO 130 end if ! Save upper and lower subscripts of the array yet to be sorted if (l-i > j-k) then il(m) = i iu(m) = l i = k m = m+1 else il(m) = k iu(m) = j j = l m = m+1 end if GO TO 160 ! Begin again on another portion of the unsorted array 150 m = m-1 if (m == 0) RETURN i = il(m) j = iu(m) 160 if (j-i >= 1) GO TO 120 if (i == 1) GO TO 110 i = i-1 170 i = i+1 if (i == j) GO TO 150 t = ix(i+1) ty = iy(i+1) if (ix(i) <= t) GO TO 170 k = i 180 ix(k+1) = ix(k) iy(k+1) = iy(k) k = k-1 if (t < ix(k)) GO TO 180 ix(k+1) = t iy(k+1) = ty GO TO 170 end subroutine long_isort ! ! SLATEC quicksort routine for character key. Jones, Kahaner and Wisniewski. ! The options to sort descending and not reorder the second array have been ! removed, and argument order changed. ! SUBROUTINE csort(n, cx, iy) integer, INTENT(IN) :: n CHARACTER (LEN=*), INTENT(INOUT) :: cx(*) integer, INTENT(IN OUT) :: iy(*) ! local variables REAL :: r CHARACTER (LEN=len(cx(1))) :: t, tt integer :: i, ij, j, k, l, m, nn, ty, tty integer :: il(21), iu(21) nn = n IF (nn < 1) RETURN ! Sort CX and carry IY along m = 1 i = 1 j = nn r = 0.375E0 110 IF (i == j) GO TO 150 IF (r <= 0.5898437E0) THEN r = r+3.90625E-2 ELSE r = r-0.21875E0 end IF 120 k = i ! Select a central element of the array and save it in location T ij = i + INT((j-i)*r) t = cx(ij) ty = iy(ij) ! If first element of array is greater than T, interchange with T IF (cx(i) > t) THEN cx(ij) = cx(i) cx(i) = t t = cx(ij) iy(ij) = iy(i) iy(i) = ty ty = iy(ij) end IF l = j ! If last element of array is less than T, interchange with T IF (cx(j) < t) THEN cx(ij) = cx(j) cx(j) = t t = cx(ij) iy(ij) = iy(j) iy(j) = ty ty = iy(ij) ! If first element of array is greater than T, interchange with T IF (cx(i) > t) THEN cx(ij) = cx(i) cx(i) = t t = cx(ij) iy(ij) = iy(i) iy(i) = ty ty = iy(ij) end IF end IF ! Find an element in the second half of the array which is smaller ! than T 130 l = l-1 IF (cx(l) > t) GO TO 130 ! Find an element in the first half of the array which is greater ! than T 140 k = k+1 IF (cx(k) < t) GO TO 140 ! Interchange these elements IF (k <= l) THEN tt = cx(l) cx(l) = cx(k) cx(k) = tt tty = iy(l) iy(l) = iy(k) iy(k) = tty GO TO 130 end IF ! Save upper and lower subscripts of the array yet to be sorted IF (l-i > j-k) THEN il(m) = i iu(m) = l i = k m = m+1 ELSE il(m) = k iu(m) = j j = l m = m+1 end IF GO TO 160 ! Begin again on another portion of the unsorted array 150 m = m-1 IF (m == (1-1)) RETURN i = il(m) j = iu(m) 160 IF (j-i >= 1) GO TO 120 IF (i == 1) GO TO 110 i = i-1 170 i = i+1 IF (i == j) GO TO 150 t = cx(i+1) ty = iy(i+1) IF (cx(i) <= t) GO TO 170 k = i 180 cx(k+1) = cx(k) iy(k+1) = iy(k) k = k-1 IF (t < cx(k)) GO TO 180 cx(k+1) = t iy(k+1) = ty GO TO 170 end subroutine csort ! ! Sort a matrix by multiple keys ! subroutine imultsort(nr, nc, mat, idx) integer, intent(in) :: nr, nc integer, dimension(nr,nc), intent(inout) :: mat integer, dimension(nr), intent(inout) :: idx integer :: i, j, sta, stratum integer, dimension(nr) :: key key=mat(1,:) call isort(1, nr, key, idx, 2) mat=mat(idx,:) do j=2, nc key=mat(j,:) stratum=mat(1,j-1) sta=1 do i=2, nr if (mat(i, j-1) /= stratum) then call isort(sta, i-1, key, idx, 2) sta=i stratum=mat(i, j-1) end if end do mat=mat(idx,:) end do end subroutine imultsort ! ! Sort two vectors ! subroutine srank2(n, x, y, iy) integer, intent(in) :: n double precision, dimension(:) :: x, y integer, dimension(:) :: iy double precision, dimension(n) :: wrk integer :: i, j, ns, sta, fin double precision :: val ns=n call srank(ns, x, iy) do i=1, n wrk(i)=y(iy(i)) end do ! sort y within ties x sta=1 val=x(sta) do i=2, n if (x(i) /= val) then fin=i-1 ns=fin-sta+1 if (ns > 1) then call srank(ns, wrk(sta:fin), iy(sta:fin)) end if sta=i val=x(sta) end if end do end subroutine srank2 ! ! MSD radix sort key1, key2 ! subroutine msdsort(bot,top,key1,key2,ord) integer, intent(in) :: bot integer, intent(in) :: top integer, dimension(:), intent(in) :: key1 integer, dimension(:), intent(inout) :: key2 integer, dimension(:), intent(inout) :: ord integer :: curkey,fin,i,sta curkey=key1(bot) sta=bot fin=bot do i=bot+1, top if (key1(i) == curkey) then fin=i else call isort(sta, fin, key2, ord, 2) sta=i fin=i curkey=key1(sta) end if end do call isort(sta, fin, key2, ord, 2) end subroutine msdsort ! ! reorder array in place following SPICE toolkit routines ! subroutine reorder(n, idx, x) integer :: n integer, dimension(n) :: idx double precision, dimension(n) :: x integer :: i, ipos, itmp double precision :: tmp i=1 do while (i < n) ipos=i tmp=x(ipos) itmp=idx(ipos) do while (itmp /= i) x(ipos)=x(itmp) ipos=itmp itmp=idx(itmp) idx(ipos)=-idx(ipos) end do x(ipos)=tmp idx(itmp)=-idx(itmp) do while (idx(i) < 0 .and. i < n) i=i+1 end do end do idx=abs(idx) end subroutine reorder end module sorts ! ! Hash table for indexing IDs etc ! module idhash_class integer, parameter :: HK_PED_ID=1, HK_ID=2, HK_LOCNAM=3, HK_MAPPOS=4, HK_CHROM=5, & HK_INT=6, HK_CELL=7 type hash_table logical :: current = .false. ! is hash known to be up to date logical :: hasdups = .false. ! multiple exact matches present integer :: keytyp = HK_PED_ID ! magic number for type of string hashed integer :: nrec = 0 ! size of table (prime) integer :: primroot = 0 ! constant for "expt hash" probe integer, dimension(:), allocatable :: address end type hash_table contains ! ! Allocate an open addressed hash table ! number of buckets is prime ! probe using exponential hash following Muehlbacher 2004 JUCS 10: 1239-1249 ! subroutine setup_hash(keytyp, nrec, hashtab, load) integer, intent(in) :: keytyp, nrec type (hash_table), intent(inout) :: hashtab integer, intent(in) :: load integer, parameter :: NTABSIZ = 30 integer, dimension(NTABSIZ), parameter :: tabsizes = (/ & 61, 139, 557, 997, 3023, 4093, 7993, 16381, 49943, 79979, 109943, & 131071, 199999, 399989, 499979, 599999, & 699967, 799999, 899981, 999983, 1099997, 2000003, & 3000017, 4000037, 5000011, 9999991, 19999999, 39999983, & 59999999, 79999987 /) integer, dimension(NTABSIZ), parameter :: primroots = (/ & 2, 2, 2, 7, 5, 2, 5, 2, 5, 2, & 5, 3, 3, 2, 2, 7, 3, 3, 2, 5, & 2, 2, 5, 2, 2, 22, 3, 5, 11, 2 /) integer :: astat, nsiz, tload, w astat=0 tload=load if (load <= 0) tload=1 if (load >= 100) tload=99 hashtab%current = .false. hashtab%hasdups = .false. hashtab%keytyp=keytyp nsiz=nrec do i=1, NTABSIZ if (tabsizes(i) > 100*nsiz/tload) then nsiz=tabsizes(i) w=primroots(i) exit end if end do if (allocated(hashtab%address)) then if (hashtab%nrec < nsiz) then deallocate(hashtab%address) allocate(hashtab%address(nsiz), stat=astat) end if else allocate(hashtab%address(nsiz), stat=astat) end if if (astat /= 0) then write(*,'(a,i0/7x,a,i0)') & 'ERROR: Unable to allocate hash table! stat=', astat, & 'Requested size=', nsiz end if hashtab%nrec=nsiz hashtab%primroot=w hashtab%address=0 end subroutine setup_hash ! ! release memory held by a hash table ! subroutine cleanup_hash(hashtab) type (hash_table), intent(inout) :: hashtab if (allocated(hashtab%address)) then deallocate(hashtab%address) end if hashtab%current=.false. hashtab%hasdups=.false. hashtab%nrec=0 hashtab%primroot=0 end subroutine cleanup_hash ! ! Print out hash table ! subroutine print_hash(hashtab) type (hash_table), intent(in) :: hashtab integer :: i, n write(*,'(a,i0)') 'nrecords=', hashtab%nrec write(*,'(a,i0)') 'primroot=', hashtab%primroot write(*,'(a,l1)') 'any dups=', hashtab%hasdups n=0 do i=1, hashtab%nrec if (hashtab%address(i) /= 0) then write(*,'(i6,1x,i0)') i, hashtab%address(i) n=n+1 end if end do write(*,'(a,i0,a,f6.1,a)') 'occupied=', n, ' (', & 100.0d0*real(n,kind=8)/real(hashtab%nrec,kind=8), ')' end subroutine print_hash ! ! populate hash table ! subroutine fill_hash(hashtab, string_array) type (hash_table), intent(inout) :: hashtab character (len=*), dimension(:), intent(in) :: string_array integer :: i, idx, iprobe, j n=size(string_array) do i=1, n idx=string_hash(trim(string_array(i)), hashtab%nrec) j=idx iprobe=hashtab%primroot do while (hashtab%address(j+1) /= 0) iaddress=hashtab%address(j+1) j=mod(idx+iprobe, hashtab%nrec) iprobe=mod(iprobe*hashtab%primroot, hashtab%nrec) end do hashtab%address(j+1) = i end do hashtab%current=.true. end subroutine fill_hash ! subroutine fill_hash_int(hashtab, iarray) type (hash_table), intent(inout) :: hashtab integer, dimension(:), intent(in) :: iarray integer :: i, idx, iprobe, j n=size(iarray) do i=1, n idx=integer_hash(iarray(i), hashtab%nrec) j=idx iprobe=hashtab%primroot do while (hashtab%address(j+1) /= 0) iaddress=hashtab%address(j+1) j=mod(idx+iprobe, hashtab%nrec) iprobe=mod(iprobe*hashtab%primroot, hashtab%nrec) end do hashtab%address(j+1) = i end do hashtab%current=.true. end subroutine fill_hash_int ! ! add new element to hash table ! subroutine insert_hash(hashtab, string, iaddress) type (hash_table), intent(inout) :: hashtab character (len=*), intent(in) :: string integer, intent(in) :: iaddress integer :: idx, iprobe, j idx=string_hash(trim(string), hashtab%nrec) j=idx iprobe=hashtab%primroot do while (hashtab%address(j+1) /= 0) j=mod(idx+iprobe, hashtab%nrec) iprobe=mod(iprobe*hashtab%primroot, hashtab%nrec) end do hashtab%address(j+1) = iaddress end subroutine insert_hash ! int subroutine insert_hash_int(hashtab, iv, iaddress) type (hash_table), intent(inout) :: hashtab integer, intent(in) :: iv integer, intent(in) :: iaddress integer :: idx, iprobe, j idx=integer_hash(iv, hashtab%nrec) j=idx iprobe=hashtab%primroot do while (hashtab%address(j+1) /= 0) j=mod(idx+iprobe, hashtab%nrec) iprobe=mod(iprobe*hashtab%primroot, hashtab%nrec) end do hashtab%address(j+1) = iaddress end subroutine insert_hash_int ! ! Search hash table ! subroutine find_hashtab(str, string_array, hashtab, iaddress) character (len=*) :: str character(len=*), dimension(:), intent(in) :: string_array type (hash_table), intent(in) :: hashtab integer, intent(out) :: iaddress integer :: idx, iprobe, j iaddress=0 if (hashtab%nrec == 0) return idx=string_hash(str, hashtab%nrec) iprobe=hashtab%primroot j=idx do iaddress=hashtab%address(j+1) if (iaddress == 0) return if (str == string_array(iaddress)) return j=mod(idx+iprobe, hashtab%nrec) iprobe=mod(iprobe*hashtab%primroot, hashtab%nrec) end do end subroutine find_hashtab ! subroutine find_hashtab_int(iv, iarray, hashtab, iaddress) integer, intent(in) :: iv integer, dimension(:), intent(in) :: iarray type (hash_table), intent(in) :: hashtab integer, intent(out) :: iaddress integer :: idx, iprobe, j iaddress=0 if (hashtab%nrec == 0) return idx=integer_hash(iv, hashtab%nrec) iprobe=hashtab%primroot j=idx do iaddress=hashtab%address(j+1) if (iaddress == 0) return if (iv == iarray(iaddress)) return j=mod(idx+iprobe, hashtab%nrec) iprobe=mod(iprobe*hashtab%primroot, hashtab%nrec) end do end subroutine find_hashtab_int ! ! String hash function (that used by SRFI-64) ! function string_hash(str, ibound) integer :: string_hash character (len=*), intent(in) :: str integer, intent(in) :: ibound integer :: h, i, slen slen=len(str) h=31 do i=1, slen h=mod(37*h + ichar(str(i:i)), ibound) end do string_hash=h end function string_hash ! ! integer hash function ! function integer_hash(iv, ibound) integer :: integer_hash integer, intent(in) :: iv integer, intent(in) :: ibound integer_hash=mod(abs(iv)+1, ibound) end function integer_hash ! ! for float->string hash function ! function floathex(rv) character(len=8) :: floathex double precision, intent(in) :: rv integer :: h, i, slen character (len=16) :: buff write(buff,'(z16.16)') rv floathex=buff(9:16) end function floathex end module idhash_class ! ! multidimensional contingency table ! ! ncat=#dimensions of table ! ncells=#cells in table ! ntot=grand total of counts ! hits=#insertions already present in table ! misses=#insertions not already present in table ! used to optimize expansion of arrays ! idx=pointer to label/data for cell, ! icount=counts ! categories=workspace containing all labels/data, ! ! hashed with delayed quicksort (20190406) ! ! cell categories are stored as type table_cell: ! module table_cell_type integer, parameter :: TABLE_CELL_UNSET=0, & TABLE_CELL_INTEGER=1, & TABLE_CELL_REAL=2, & TABLE_CELL_STRING=3, & TABLE_CELL_FACTOR=4 type table_cell integer :: content_type = TABLE_CELL_UNSET ! 1=i8, 2=r8, 3=string, 4=factor integer (kind=8) :: ivalue = 0 double precision :: rvalue = 0.0d0 integer :: slength = 0 character, dimension(:), allocatable :: svalue end type table_cell contains function get_table_cell_type(x) integer :: get_table_cell_type type (table_cell), intent(in) :: x get_table_cell_type=x%content_type end function get_table_cell_type ! ! low level fortran string to table_cell ! subroutine copystring(string, x) character(len=*) :: string type (table_cell) :: x if (x%content_type == TABLE_CELL_UNSET) then x%content_type = TABLE_CELL_STRING end if !write(*,*) 'In copystring, len_trim(string): ', len_trim(string), '"',string,'"' x%slength=len_trim(string) if (allocated(x%svalue)) deallocate(x%svalue) allocate(character(len=1) :: x%svalue(x%slength)) do i=1, x%slength x%svalue(i)=string(i:i) end do !write(*,*) 'In copystring, x: ', x%slength, '"',x%svalue,'"' end subroutine copystring ! ! append fortran string to table cell ! subroutine appendstring(string, x) character(len=*) :: string type (table_cell) :: x integer :: i, j, newlen, slen character, dimension(:), allocatable :: tstring slen=len(string) if (.not.allocated(x%svalue)) then call copystring(string, x) else newlen=x%slength+slen allocate(character(len=1) :: tstring(x%slength)) tstring=x%svalue deallocate(x%svalue) allocate(character(len=1) :: x%svalue(newlen)) x%svalue(1:x%slength)=tstring j=1 do i=x%slength+1, newlen x%svalue(i)=string(j:j) j=j+1 end do x%slength=newlen deallocate(tstring) end if end subroutine appendstring ! ! recast ! subroutine set_table_cell_type(newtyp, x) integer, intent(in) :: newtyp type (table_cell) :: x integer, parameter :: WRKSTRING_LEN = 80 integer :: i, ioerr, slen character (len=20) :: fstring character (len=WRKSTRING_LEN) :: wrkstring wrkstring=' ' if (newtyp < TABLE_CELL_UNSET .or. newtyp > TABLE_CELL_FACTOR) return if (x%content_type == newtyp) return if (x%content_type == TABLE_CELL_UNSET) then x%ivalue=0 x%rvalue=0.0d0 x%slength=0 else if (newtyp == TABLE_CELL_UNSET) then x%ivalue=0 x%rvalue=0.0d0 x%slength=0 else if (newtyp == TABLE_CELL_INTEGER .or. newtyp == TABLE_CELL_FACTOR) then if (x%content_type == TABLE_CELL_REAL) then x%ivalue = int(x%rvalue) x%rvalue=0.0d0 if (newtyp == TABLE_CELL_FACTOR) then write(wrkstring, '(i0)') x%ivalue call copystring(wrkstring, x) end if else if (x%content_type == TABLE_CELL_STRING) then if (x%slength > 0 .and. x%slength <= WRKSTRING_LEN) then do i=1, x%slength wrkstring(i:i)=x%svalue(i) end do write(fstring, '(a,i0,a)') '(i',x%slength, ')' read(wrkstring,fstring) x%ivalue end if x%slength=0 deallocate(x%svalue) end if else if (newtyp == TABLE_CELL_REAL) then if (x%content_type == TABLE_CELL_INTEGER) then x%rvalue = dble(x%ivalue) x%ivalue=0 else if (x%content_type == TABLE_CELL_STRING) then if (x%slength > 0 .and. x%slength <= WRKSTRING_LEN) then do i=1, x%slength wrkstring(i:i)=x%svalue(i) end do write(fstring, '(a,i0,a)') '(f',x%slength, '.0)' read(wrkstring,fstring,iostat=ioerr) x%rvalue end if x%slength=0 deallocate(x%svalue) end if else if (newtyp == TABLE_CELL_STRING) then if (x%content_type == TABLE_CELL_INTEGER) then write(fstring, '(a,i0,a)') '(i', WRKSTRING_LEN, ')' write(wrkstring, '(i20)') x%ivalue x%ivalue=0 else if (x%content_type == TABLE_CELL_REAL) then write(fstring, '(a,i0,a)') '(f',WRKSTRING_LEN,'.0)' write(wrkstring, fstring) x%rvalue x%rvalue=0.0d0 end if call copystring(wrkstring, x) end if x%content_type = newtyp end subroutine set_table_cell_type ! ! is non-string ! function table_cell_numeric(x) logical :: table_cell_numeric type (table_cell), intent(in) :: x table_cell_numeric = (x%content_type /= TABLE_CELL_STRING) end function table_cell_numeric ! ! Is string and contents of string numeric? ! function table_cell_string_numeric(x) logical :: table_cell_string_numeric type (table_cell), intent(in) :: x integer :: i, ioerr character (len=40) :: string double precision :: v logical :: res res=.false. string=' ' if (x%content_type == TABLE_CELL_STRING) then res=.true. do i=1, x%slength string(i:i)=x%svalue(i) end do read(string,'(f40.0)',iostat=ioerr) v res=(ioerr == 0) end if table_cell_string_numeric=res end function table_cell_string_numeric ! ! Is string and contents of string an integer? ! Useful for factor levels ! function table_cell_string_int(x) logical :: table_cell_string_int type (table_cell), intent(in) :: x integer :: i, ich logical :: res res=.false. if (x%content_type == TABLE_CELL_STRING) then res=.true. do i=1, x%slength ich=ichar(x%svalue(i)) if (ich < 48 .or. ich > 57) then res=.false. exit end if end do end if table_cell_string_int=res end function table_cell_string_int ! ! len_trim for table_cell ! function table_cell_len_trim(x) integer :: table_cell_len_trim type (table_cell), intent(in) :: x integer :: res res = x%slength if (x%content_type == TABLE_CELL_STRING .or. & x%content_type == TABLE_CELL_FACTOR) then do res=x%slength, 1, -1 if (x%svalue(res) /= ' ') exit end do end if table_cell_len_trim=res end function table_cell_len_trim ! ! numbers precede strings in collation sequence, ! integer-real comparisons cast former to real ! function table_cell_eq(x, y) logical :: table_cell_eq type (table_cell), intent(in) :: x, y integer :: i logical :: res res = .FALSE. if (x%content_type == y%content_type) then if (x%content_type == TABLE_CELL_INTEGER .or. & x%content_type == TABLE_CELL_FACTOR) then res = (x%ivalue == y%ivalue) else if (x%content_type == TABLE_CELL_REAL) then res = (x%rvalue == y%rvalue) else if (x%content_type == TABLE_CELL_STRING) then if (x%slength == y%slength) then res = .TRUE. do i=1, x%slength if (x%svalue(i) /= y%svalue(i)) then res = .FALSE. exit end if end do end if else if (x%content_type == TABLE_CELL_UNSET) then res = .TRUE. end if end if table_cell_eq = res end function table_cell_eq ! function table_cell_ne(x, y) logical :: table_cell_ne type (table_cell), intent(in) :: x, y table_cell_ne = .not.table_cell_eq(x, y) end function table_cell_ne ! function table_cell_gt(x, y) logical :: table_cell_gt type (table_cell), intent(in) :: x, y integer :: i, minlen logical :: eq, res res = .FALSE. if (y%content_type == TABLE_CELL_UNSET) then if (x%content_type /= TABLE_CELL_UNSET) then res = .TRUE. end if else if (x%content_type == y%content_type) then if (x%content_type == TABLE_CELL_INTEGER .or. & x%content_type == TABLE_CELL_FACTOR) then res = (x%ivalue > y%ivalue) else if (x%content_type == TABLE_CELL_REAL) then res = (x%rvalue > y%rvalue) else if (x%content_type == TABLE_CELL_STRING) then if (x%slength > 0) then minlen=min(x%slength, y%slength) eq = .TRUE. do i=1, minlen if (x%svalue(i) > y%svalue(i)) then eq= .FALSE. res = .TRUE. exit else if (x%svalue(i) < y%svalue(i)) then eq= .FALSE. exit end if end do if (eq .and. x%slength > y%slength) res=.TRUE. end if end if else if (.not.table_cell_numeric(x) .and. table_cell_numeric(y)) then res = .TRUE. else if (x%content_type == TABLE_CELL_INTEGER .and. & y%content_type == TABLE_CELL_REAL) then res = (dble(x%ivalue) > y%rvalue) else if (x%content_type == TABLE_CELL_REAL .and. & y%content_type == TABLE_CELL_INTEGER) then res = (x%rvalue > dble(y%ivalue)) end if table_cell_gt = res end function table_cell_gt ! function table_cell_lt(x, y) logical :: table_cell_lt type (table_cell), intent(in) :: x, y integer :: i logical :: eq, res res = .FALSE. if (x%content_type == TABLE_CELL_UNSET) then if (y%content_type /= TABLE_CELL_UNSET) then res = .TRUE. end if else if (x%content_type == y%content_type) then if (x%content_type == TABLE_CELL_INTEGER .or. & x%content_type == TABLE_CELL_FACTOR) then res = (x%ivalue < y%ivalue) else if (x%content_type == TABLE_CELL_REAL) then res = (x%rvalue < y%rvalue) else if (x%content_type == TABLE_CELL_STRING) then if (x%slength > 0) then minlen=min(x%slength, y%slength) eq = .TRUE. do i=1, minlen if (x%svalue(i) < y%svalue(i)) then eq = .FALSE. res = .TRUE. exit else if (x%svalue(i) > y%svalue(i)) then eq = .FALSE. exit end if end do if (eq .and. x%slength < y%slength) res=.TRUE. else if (y%slength > 0) then res = .TRUE. end if end if else if (table_cell_numeric(x) .and. .not.table_cell_numeric(y)) then res = .TRUE. else if (x%content_type == TABLE_CELL_INTEGER .and. & y%content_type == TABLE_CELL_REAL) then res = (dble(x%ivalue) < y%rvalue) else if (x%content_type == TABLE_CELL_REAL .and. & y%content_type == TABLE_CELL_INTEGER) then res = (x%rvalue < dble(y%ivalue)) end if table_cell_lt = res end function table_cell_lt ! subroutine set_table_cell(x, ivalue, rvalue, string) type (table_cell), intent(out) :: x integer, intent(in), optional :: ivalue double precision, intent(in), optional :: rvalue character (len=*), intent(in), optional :: string integer :: i x%content_type = TABLE_CELL_UNSET if (allocated(x%svalue)) deallocate(x%svalue) if (present(ivalue)) then if (present(string)) then x%content_type = TABLE_CELL_FACTOR call copystring(string, x) else x%content_type = TABLE_CELL_INTEGER end if x%ivalue = ivalue else if (present(rvalue)) then x%content_type = TABLE_CELL_REAL x%rvalue = rvalue else if (present(string)) then x%content_type = TABLE_CELL_STRING call copystring(string, x) end if end subroutine set_table_cell ! subroutine get_table_cell(x, ivalue, rvalue, string) type (table_cell), intent(in) :: x integer, optional, intent(out) :: ivalue double precision, optional, intent(out) :: rvalue character (len=*), optional, intent(out) :: string integer, parameter :: WRKSTRING_LEN = 80 integer :: i, slen character (len=20) :: fstring character (len=WRKSTRING_LEN) :: wrkstring if (present(ivalue)) then ivalue=0 if (x%content_type == TABLE_CELL_INTEGER .or. & x%content_type == TABLE_CELL_FACTOR) then ivalue=x%ivalue else if (x%content_type == TABLE_CELL_REAL) then ivalue=int(x%ivalue) else if (x%content_type == TABLE_CELL_STRING) then if (x%slength > 0 .and. x%slength <= WRKSTRING_LEN) then do i=1, x%slength wrkstring(i:i)=x%svalue(i) end do write(fstring, '(a,i0,a)') '(i',x%slength, ')' read(wrkstring,fstring) ivalue end if end if else if (present(rvalue)) then rvalue=0.0d0 if (x%content_type == TABLE_CELL_INTEGER .or. & x%content_type == TABLE_CELL_FACTOR) then rvalue=dble(x%ivalue) else if (x%content_type == TABLE_CELL_REAL) then rvalue=x%rvalue else if (x%content_type == TABLE_CELL_STRING) then if (x%slength > 0 .and. x%slength <= WRKSTRING_LEN) then do i=1, x%slength wrkstring(i:i)=x%svalue(i) end do write(fstring, '(a,i0,a)') '(1x,f',x%slength, '.0)' read(wrkstring,fstring) rvalue end if end if else if (present(string)) then string=' ' slen=len(string) if (x%content_type == TABLE_CELL_INTEGER) then write(fstring, '(a,i0,a)') '(1x,i',slen, ')' write(string, fstring) x%ivalue else if (x%content_type == TABLE_CELL_REAL) then write(fstring, '(a,i0,a)') '(1x,f',slen, '.0)' write(string, fstring) x%rvalue else if (x%content_type == TABLE_CELL_STRING .or. & x%content_type == TABLE_CELL_FACTOR) then if (x%slength > 0) then do i=1, min(slen, x%slength) string(i:i)=x%svalue(i) end do end if end if end if end subroutine get_table_cell ! subroutine write_table_cell(strm, x, width, tabsep, advance) integer, intent(in), optional :: strm type (table_cell), intent(in) :: x integer, intent(in), optional :: width character(len=1), intent(in), optional :: tabsep character(len=*), intent(in), optional :: advance character (len=2), parameter :: misval = '.' character (len=1) :: sep character (len=3) :: adv character (len=20) :: fstring integer :: i, stream, w logical :: ismiss, whole adv='yes' if (present(advance)) adv=advance sep=' ' if (present(tabsep)) sep=tabsep stream=6 if (present(strm)) stream=strm write(stream, '(a1)', advance='no') sep if (x%content_type == TABLE_CELL_INTEGER) then fstring='(i0)' if (present(width)) then write(fstring, '(a,i0,a)') '(i', width, ')' end if write(stream, fstring, advance=adv) x%ivalue else if (x%content_type == TABLE_CELL_REAL) then whole=(anint(x%rvalue) == x%rvalue .and. abs(x%rvalue) < abs(dfloat(huge(0)))) if (whole) then fstring='(i0)' else fstring='(g12.4)' end if if (present(width)) then if (whole) then write(fstring, '(a,i0,a)') '(i', width, ')' else w=max(width,6) write(fstring, '(a,i0,a)') '(f', w, '.4)' end if end if if (whole) then write(stream, fstring, advance=adv) int(x%rvalue, kind=8) else write(stream, fstring, advance=adv) x%rvalue end if else if (x%content_type == TABLE_CELL_STRING .or. & x%content_type == TABLE_CELL_FACTOR) then do i=1, x%slength write(stream, '(a1)', advance='no') x%svalue(i) end do if (present(width)) then do i=1, width-x%slength write(stream, '(a1)', advance='no') ' ' end do end if if (adv == 'yes') write(stream,*) else fstring='(1x,a)' if (present(width)) then write(fstring, '(a,i0,a)') '(a', width, ')' end if write(stream, fstring, advance=adv) misval end if end subroutine write_table_cell end module table_cell_type module contingency_table use table_cell_type use idhash_class ! type table_data integer :: ncat ! dimensions integer :: ncells ! cells in table integer :: ntot ! sum of counts integer :: hits ! hits on old categories since last expansion integer :: misses ! novel categories since last expansion logical :: sorted ! is idx sorted? type (table_cell), dimension(:), allocatable :: colnames type (table_cell), dimension(:,:), allocatable :: categories ! idx gives ordering of cells - see sort_table, print_table integer, dimension(:), allocatable :: idx integer, dimension(:), allocatable :: catlevel integer, dimension(:), allocatable :: icount type (hash_table) :: table_hash end type table_data contains ! ! allocate space for contingency table ! subroutine setup_table(ncat, maxcells, table) integer :: ncat, maxcells type (table_data) :: table integer :: i character (len=50) :: colnam table%ncat = ncat table%ncells = 0 table%ntot = 0 table%hits= 0 table%misses= 0 table%sorted= .false. allocate(table%colnames(ncat)) do i=1, ncat write(colnam, '(i0)') i colnam='V' // adjustl(colnam) call set_table_cell(table%colnames(i), string=trim(colnam)) end do allocate(table%categories(maxcells, ncat)) allocate(table%idx(maxcells)) allocate(table%catlevel(maxcells)) allocate(table%icount(maxcells)) call setup_hash(HK_CELL, maxcells, table%table_hash, 90) end subroutine setup_table ! ! zero table for reuse ! subroutine zero_table(table) type (table_data) :: table integer :: i do i=1, table%ncells table%icount(i)=0 table%idx(i)=0 table%catlevel(i)=0 end do table%ncells = 0 table%ntot = 0 table%hits = 0 table%misses = 0 table%sorted= .false. call cleanup_hash(table%table_hash) call setup_hash(HK_CELL, 20, table%table_hash, 90) end subroutine zero_table ! ! deallocate space ! subroutine clean_table(table) type (table_data) :: table table%ncat = 0 table%ncells = 0 table%ntot = 0 table%hits = 0 table%misses = 0 table%sorted= .false. deallocate(table%colnames) deallocate(table%categories) deallocate(table%idx) deallocate(table%catlevel) deallocate(table%icount) call cleanup_hash(table%table_hash) end subroutine clean_table ! ! increase available space ! subroutine expand_table(nextra, table) integer :: nextra type (table_data) :: table type (table_data) :: table2 integer :: nrow, ncol nrow = size(table%idx) ncol = table%ncat call setup_table(ncol, nrow, table2) table2%ncells = table%ncells table2%ntot = table%ntot table2%colnames(1:ncol) = table%colnames(1:ncol) table2%categories(1:nrow, 1:ncol) = table%categories(1:nrow, 1:ncol) table2%idx(1:nrow) = table%idx(1:nrow) table2%catlevel(1:nrow) = table%catlevel(1:nrow) table2%icount(1:nrow) = table%icount(1:nrow) call clean_table(table) call setup_table(ncol, nrow+nextra, table) table%ncells = table2%ncells table%ntot = table2%ntot table%hits = 0 table%misses = 0 table%sorted= .false. table%colnames(1:ncol) = table2%colnames(1:ncol) table%categories(1:nrow, 1:ncol) = table2%categories(1:nrow, 1:ncol) table%idx(1:nrow) = table2%idx(1:nrow) table%catlevel(1:nrow) = table2%catlevel(1:nrow) table%icount(1:nrow) = table2%icount(1:nrow) call clean_table(table2) call fill_tablehash(table) end subroutine expand_table ! ! insert colname ! subroutine set_table_colname(icol, colnam, table) integer, intent(in) :: icol character (len=*) :: colnam type (table_data) :: table call set_table_cell(table%colnames(icol), string=trim(colnam)) end subroutine set_table_colname ! ! hash vector of table values ! function cell_hash(ncat, values, ibound) integer :: cell_hash integer, intent(in) :: ncat type (table_cell), dimension(ncat), intent(in) :: values integer, intent(in) :: ibound integer :: h, h0, i, j, res character (len=8) :: cval h=31 do i=1, ncat if (values(i)%content_type == TABLE_CELL_STRING .or. & values(i)%content_type == TABLE_CELL_FACTOR) then do j=1, values(i)%slength h=mod(37*h + ichar(values(i)%svalue(j)), ibound) end do else if (values(i)%content_type == TABLE_CELL_INTEGER) then h=mod(37*h + abs(values(i)%ivalue), ibound) else if (values(i)%content_type == TABLE_CELL_REAL) then cval=transfer(values(i)%rvalue, cval) do j=1, 8 h=mod(37*h + ichar(cval(j:j)), ibound) end do end if end do cell_hash=h end function cell_hash ! function cell_vector_eq(vec1, vec2) logical :: cell_vector_eq type(table_cell), dimension(:), intent(in) :: vec1, vec2 integer :: i, ncat ncat=size(vec1) cell_vector_eq=.false. if (ncat /= size(vec2)) return do i=1, ncat if (table_cell_ne(vec1(i), vec2(i))) return end do cell_vector_eq=.true. end function cell_vector_eq ! function cell_vector_gt(vec1, vec2) logical :: cell_vector_gt type(table_cell), dimension(:), intent(in) :: vec1, vec2 integer :: i, ncat ncat=size(vec1) cell_vector_gt=.false. if (ncat /= size(vec2)) return do i=1, ncat if (table_cell_gt(vec1(i), vec2(i))) then cell_vector_gt=.true. return else if (table_cell_lt(vec1(i), vec2(i))) then return end if end do end function cell_vector_gt ! function cell_vector_le(vec1, vec2) logical :: cell_vector_le type(table_cell), dimension(:), intent(in) :: vec1, vec2 cell_vector_le = .not.cell_vector_gt(vec1, vec2) end function cell_vector_le ! function cell_vector_lt(vec1, vec2) logical :: cell_vector_lt type(table_cell), dimension(:), intent(in) :: vec1, vec2 integer :: i, ncat ncat=size(vec1) cell_vector_lt=.false. if (ncat /= size(vec2)) return do i=1, ncat if (table_cell_lt(vec1(i), vec2(i))) then cell_vector_lt=.true. return else if (table_cell_gt(vec1(i), vec2(i))) then return end if end do end function cell_vector_lt ! function cell_vector_ge(vec1, vec2) logical :: cell_vector_ge type(table_cell), dimension(:), intent(in) :: vec1, vec2 cell_vector_ge = .not.cell_vector_lt(vec1, vec2) end function cell_vector_ge ! ! insert data ! subroutine insert_table_cells(ncat, values, table, iwt, slot) integer, intent(in) :: ncat type (table_cell), dimension(ncat), intent(in) :: values type (table_data) :: table integer, intent(in) :: iwt integer, optional, intent(out) :: slot ! local variables integer :: catpos, i, idx, iprobe, j double precision :: missrate catpos=0 if (table%table_hash%nrec > 0) then idx=cell_hash(ncat, values, table%table_hash%nrec) iprobe=table%table_hash%primroot j=idx do catpos=table%table_hash%address(j+1) if (catpos == 0) exit if (cell_vector_eq(table%categories(catpos,1:ncat), values)) exit j=mod(idx+iprobe, table%table_hash%nrec) iprobe=mod(iprobe*table%table_hash%primroot, table%table_hash%nrec) end do end if ! just right if (catpos > 0) then table%hits=table%hits+1 table%ntot=table%ntot+iwt table%icount(catpos)=table%icount(catpos)+iwt if (present(slot)) slot=catpos return end if ! ! else if not found ! if not enough room, expand table ! if (table%ncells == size(table%idx)) then missrate = dble(table%misses)/dble(table%hits+table%misses) call expand_table(max(10,int(dble(table%ncells)*missrate)), table) end if ! insert new record table%ntot=table%ntot+iwt table%misses=table%misses+1 table%ncells=table%ncells+1 catpos=table%ncells table%idx(catpos)=catpos table%icount(catpos)=iwt do k=1, ncat table%categories(catpos,k) = values(k) end do table%sorted=.false. if (present(slot)) slot=catpos idx=cell_hash(ncat, values, table%table_hash%nrec) j=idx iprobe=table%table_hash%primroot do while (table%table_hash%address(j+1) /= 0) j=mod(idx+iprobe, table%table_hash%nrec) iprobe=mod(iprobe*table%table_hash%primroot, table%table_hash%nrec) end do table%table_hash%address(j+1) = catpos end subroutine insert_table_cells ! subroutine insert_table(ncat, rvalues, table, iwt) integer, intent(in) :: ncat double precision, dimension(ncat), intent(in) :: rvalues type (table_data) :: table integer, intent(in) :: iwt type (table_cell), dimension(ncat) :: cell_values integer :: i do i=1, ncat call set_table_cell(cell_values(i), rvalue=rvalues(i)) end do call insert_table_cells(ncat, cell_values, table, iwt) end subroutine insert_table ! ! rehash table_hash ! subroutine fill_tablehash(table) type (table_data) :: table integer :: i, idx, iprobe, j, ncat ncat=table%ncat table%table_hash%address=0 do i=1, table%ncells idx=cell_hash(ncat, table%categories(i,1:ncat), & table%table_hash%nrec) j=idx iprobe=table%table_hash%primroot do while (table%table_hash%address(j+1) /= 0) iaddress=table%table_hash%address(j+1) j=mod(idx+iprobe, table%table_hash%nrec) iprobe=mod(iprobe*table%table_hash%primroot, table%table_hash%nrec) end do table%table_hash%address(j+1) = i end do table%table_hash%current=.true. end subroutine fill_tablehash ! ! Sort table on counts ! subroutine sort_table_by_counts(table) use sorts type (table_data) :: table integer, dimension(table%ncells) :: scount interface subroutine ascend(n, ia) integer, intent(in) :: n integer, dimension(:), intent(inout) :: ia end subroutine ascend end interface scount=table%icount call ascend(table%ncells, table%idx) call isort(1, table%ncells, scount, table%idx, 2) ! since no longer sorted on entries table%sorted=.false. end subroutine sort_table_by_counts ! ! Quicksort multicategory table categories - changes idx and catlabel ! subroutine sort_table(table, columns) type (table_data) :: table integer, dimension(:), optional, intent(in) :: columns ! local scalars integer, parameter :: MISS=-9999 double precision :: r integer i, ii, ij, j, k, l, m, n, nn, tty, ty ! local arrays .. integer :: ncat integer, dimension(table%ncat) :: sel integer il(21), iu(21) n=table%ncells if (n < 1) return ncat=table%ncat if (present(columns)) then ncat=size(columns) do j=1, ncat sel(j)=columns(j) end do else do j=1, ncat sel(j)=j end do end if do ii=1, n table%idx(ii)=ii end do nn=n m = 1 i = 1 j = nn r = 0.375d0 20 continue if (i == j) go to 60 if (r <= 0.5898437d0) then r = r+3.90625d-2 else r = r-0.21875d0 end if 30 continue k = i ! ! select a central element of the array and save it in location t ! ij = i + int((j-i)*r) ty = table%idx(ij) ! ! if first element of array is greater than t, interchange with t ! if (cell_vector_gt(table%categories(table%idx(i),sel), & table%categories(ty,sel))) then table%idx(ij) = table%idx(i) table%idx(i) = ty ty = table%idx(ij) end if l = j ! ! if last element of array is less than than t, interchange with t ! if (cell_vector_lt(table%categories(table%idx(j),sel), & table%categories(ty,sel))) then table%idx(ij) = table%idx(j) table%idx(j) = ty ty = table%idx(ij) ! ! if first element of array is greater than t, interchange with t ! if (cell_vector_gt(table%categories(table%idx(i),sel), & table%categories(ty,sel))) then table%idx(ij) = table%idx(i) table%idx(i) = ty ty = table%idx(ij) end if end if ! ! find an element in the second half of the array which is smaller than t ! do do l = l-1 if (cell_vector_le(table%categories(table%idx(l),sel), & table%categories(ty,sel))) exit end do ! ! find an element in the first half of the array which is greater than t ! do k = k+1 if (cell_vector_ge(table%categories(table%idx(k),sel), & table%categories(ty,sel))) exit end do ! ! interchange these elements ! if (k > l) exit tty = table%idx(l) table%idx(l) = table%idx(k) table%idx(k) = tty end do ! ! save upper and lower subscripts of the array yet to be sorted ! if (l-i > j-k) then il(m) = i iu(m) = l i = k m = m+1 else il(m) = k iu(m) = j j = l m = m+1 endif go to 70 ! ! begin again on another portion of the unsorted array ! finished if none left ! 60 continue m = m-1 if (m == 0) then do ii=1, n table%catlevel(table%idx(ii))=ii end do table%sorted=.true. return end if i = il(m) j = iu(m) 70 continue if (j-i >= 1) go to 30 if (i == 1) go to 20 i = i-1 80 continue i = i+1 if (i == j) go to 60 ty = table%idx(i+1) if (cell_vector_le(table%categories(table%idx(i),1:ncat), & table%categories(ty,1:ncat))) then go to 80 end if k = i 90 continue table%idx(k+1) = table%idx(k) k = k-1 if (cell_vector_lt(table%categories(ty,1:ncat), & table%categories(table%idx(k),1:ncat))) go to 90 table%idx(k+1) = ty go to 80 end subroutine sort_table ! ! Search table -- needs table to be sorted ! returns rank of row ! function search_table(ncat, values, table, plevel) integer :: search_table integer, intent(in) :: ncat type (table_cell), intent(in) :: values(ncat) type (table_data) :: table integer, intent(in) :: plevel ! local variables integer :: i, idx, j, iprobe if (.not.table%sorted) then call sort_table(table) end if i=0 if (table%table_hash%nrec > 0) then idx=cell_hash(ncat, values, table%table_hash%nrec) iprobe=table%table_hash%primroot j=idx do i=table%table_hash%address(j+1) if (i == 0) exit if (cell_vector_eq(table%categories(i,1:ncat), values)) exit j=mod(idx+iprobe, table%table_hash%nrec) iprobe=mod(iprobe*table%table_hash%primroot, table%table_hash%nrec) end do end if if (i > 0) then search_table=table%catlevel(i) else if (plevel > 0) then write(*,'(a)', advance='no') 'Couldn''t find ' do i=1, ncat call write_table_cell(x=values(i), advance='no') end do write(*,*) end if search_table=0 end if end function search_table ! ! Increment cell count if correct address already available ! subroutine incr_table(pos, table, iwt) integer, intent(in) :: pos type (table_data) :: table integer, intent(in) :: iwt table%icount(pos)=table%icount(pos)+iwt table%ntot=table%ntot+iwt end subroutine incr_table ! ! print a table -- needs table to be sorted ! subroutine table_column_widths(table, widths) type (table_data) :: table integer, dimension(table%ncat), intent(out) :: widths ! local variables integer :: ityp, i, j double precision :: tmp do j=1, table%ncat widths(j)=table%colnames(j)%slength do i=1, table%ncells ityp = table%categories(table%idx(i),j)%content_type if (ityp == TABLE_CELL_STRING .or. ityp == TABLE_CELL_FACTOR) then widths(j) = max(widths(j), table%categories(table%idx(i),j)%slength) else tmp=1.0d0 if (ityp == TABLE_CELL_INTEGER) then tmp=dble(table%categories(table%idx(i),j)%ivalue) widths(j) = max(widths(j), int(log10(tmp))+1) else tmp=table%categories(table%idx(i),j)%rvalue widths(j) = max(widths(j), int(log10(tmp))+6) end if end if end do end do end subroutine table_column_widths ! subroutine print_table_unsorted(table) use outstream type (table_data) :: table ! local variables integer, dimension(table%ncat) :: widths integer :: i, j, pos, typ, wid integer (kind=8) :: tot double precision :: den character (len=15) :: fstring character (len=80) :: colnam typ=2 do i=1, table%ncells table%idx(i)=i end do call table_column_widths(table, widths) ! column headers write(outstr,'(/a7)', advance='no') ' index ' wid=7 do j=1, table%ncat wid=wid+widths(j)+1 write(outstr,'(a)',advance='no') tabsep write(fstring, '(a,i0,a)') '(a', widths(j), ')' call get_table_cell(table%colnames(j), string=colnam) write(outstr, fstring, advance='no') colnam end do write(outstr,'(2a)',advance='no') tabsep, 'Frequency' if (typ == 2) then write(outstr,'(2a)') tabsep, ' Presented' else write(outstr,*) end if write(outstr,'(a)', advance='no') repeat('-',7) do j=1, table%ncat write(outstr,'(2a)',advance='no') tabsep, repeat('-',widths(j)) end do write(outstr,'(2a)', advance='no') tabsep, repeat('-',10) if (typ == 2) then write(outstr,'(a,1x,a)') tabsep, repeat('-',10) else write(outstr,*) end if ! category counts den=1.0d0 if (table%ntot > 1) then den=1.0d0/dfloat(table%ntot) end if do i=1, table%ncells pos = table%idx(i) write(outstr,'(i6,a)', advance='no') i, ':' do j=1, table%ncat call write_table_cell(strm=outstr, x=table%categories(pos,j), & width=widths(j), tabsep=tabsep, advance='no') end do write(outstr,'(a,i10)', advance='no') tabsep, table%icount(pos) if (typ == 2) then write(outstr,'(3x,i0)') table%idx(i) else write(outstr,'(1x,a,f5.3,a)') '(', den*dfloat(table%icount(pos)), ')' end if end do wid=wid+1 write(fstring, '(a,i0,a)') '(', wid, 'x,a10)' write(outstr,fstring) repeat('-',10) write(fstring, '(a,i0,a)') '(a,', wid-5, 'x,i10)' write(outstr,fstring) 'Total', table%ntot end subroutine print_table_unsorted ! subroutine print_table(table, show_presentation_order) use outstream type (table_data) :: table integer, optional, intent(in) :: show_presentation_order ! local variables integer, dimension(table%ncat) :: widths integer :: i, j, pos, typ, wid integer (kind=8) :: tot double precision :: den character (len=15) :: fstring character (len=80) :: colnam if (.not.table%sorted) then call sort_table(table) end if typ=1 if (present(show_presentation_order)) typ=show_presentation_order call table_column_widths(table, widths) ! column headers write(outstr,'(/a7)', advance='no') ' index ' wid=7 do j=1, table%ncat wid=wid+widths(j)+1 write(outstr,'(a)',advance='no') tabsep write(fstring, '(a,i0,a)') '(a', widths(j), ')' call get_table_cell(table%colnames(j), string=colnam) write(outstr, fstring, advance='no') colnam end do write(outstr,'(2a)',advance='no') tabsep, 'Frequency' if (typ == 2) then write(outstr,'(2a)') tabsep, ' Presented' else write(outstr,*) end if write(outstr,'(a)', advance='no') repeat('-',7) do j=1, table%ncat write(outstr,'(2a)',advance='no') tabsep, repeat('-',widths(j)) end do write(outstr,'(2a)', advance='no') tabsep, repeat('-',10) if (typ == 2) then write(outstr,'(a,1x,a)') tabsep, repeat('-',10) else write(outstr,*) end if ! category counts den=1.0d0 if (table%ntot > 1) then den=1.0d0/dfloat(table%ntot) end if do i=1, table%ncells pos = table%idx(i) write(outstr,'(i6,a)', advance='no') i, ':' do j=1, table%ncat call write_table_cell(strm=outstr, x=table%categories(pos,j), & width=widths(j), tabsep=tabsep, advance='no') end do write(outstr,'(a,i10)', advance='no') tabsep, table%icount(pos) if (typ == 2) then write(outstr,'(3x,i0)') table%idx(i) else write(outstr,'(1x,a,f5.3,a)') '(', den*dfloat(table%icount(pos)), ')' end if end do wid=wid+1 write(fstring, '(a,i0,a)') '(', wid, 'x,a10)' write(outstr,fstring) repeat('-',10) write(fstring, '(a,i0,a)') '(a,', wid-5, 'x,i10)' write(outstr,fstring) 'Total', table%ntot end subroutine print_table ! ! fill a table with marginal counts from another table ! subroutine marginal_table(nmargin, margin, table, martable) integer :: nmargin integer, dimension(:) :: margin type (table_data) :: table type (table_data) :: martable integer :: i, idx, j type (table_cell), dimension(nmargin) :: values do j=1, nmargin martable%colnames(j) = table%colnames(margin(j)) end do do i=1, table%ncells do j=1, nmargin values(j) = table%categories(i,margin(j)) end do call insert_table_cells(nmargin, values, martable, table%icount(i)) end do call sort_table(martable) end subroutine marginal_table ! ! Convert table counts to a R (dim1 x dim2 ..x dimN-1) x C (dimN) matrix ! so mtable1 is marginal table for vars 1..nloc-1, mtable2 is univariate ! subroutine flat_table(mtable1, mtable2, table, mat) type (table_data), intent(in) :: mtable1, mtable2 type (table_data), intent(in) :: table integer, dimension(:), intent(inout) :: mat integer catpos, i, j, k, matpos, pos logical :: match type (table_cell), dimension(mtable1%ncat) :: values if (.not.table%sorted) then call sort_table(table) end if if (.not.mtable1%sorted) then call sort_table(mtable1) end if if (.not.mtable2%sorted) then call sort_table(mtable2) end if do i=1, mtable1%ncells*mtable2%ncells mat(i)=0 end do matpos=0 pos=1 catpos=table%idx(pos) do i=1, mtable1%ncells do k=1, mtable1%ncat values(k)=mtable1%categories(mtable1%idx(i), k) end do do j=1, mtable2%ncells matpos=matpos+1 match=.true. do k=1, mtable1%ncat if (table_cell_ne(table%categories(catpos, k), values(k))) then match=.false. exit end if end do if (match .and. & table_cell_eq(table%categories(catpos, table%ncat), & mtable2%categories(mtable2%idx(j),1))) then mat(matpos)=table%icount(catpos) if (pos==table%ncells) then return end if pos=pos+1 catpos=table%idx(pos) end if end do end do k=0 do i=1, mtable1%ncells write(*,*) i,': ', (mat(k+j), j=1, mtable2%ncells) k=k+mtable2%ncells end do end subroutine flat_table ! ! get dimension of a margin ! function dim_table(margin, table) integer :: dim_table integer :: margin integer, dimension(1) :: marg type (table_data) :: table type (table_data) :: martable dim_table=0 if (margin > 0 .and. margin <= table%ncat) then call setup_table(1, 100, martable) marg(1)=margin call marginal_table(1, marg, table, martable) dim_table=martable%ncells end if end function dim_table ! ! Binary search of first column, for ordered key-values ! Returns table row ! function search_table_key(val, table) integer :: search_table_key type (table_cell), intent(in) :: val type (table_data) :: table ! local variables integer :: catpos, hi, lo, pos search_table_key=0 if (table%ncells < 1) return hi=table%ncells lo=1 do while (hi >= lo) pos=lo+(hi-lo)/2 catpos=table%idx(pos) if (table_cell_gt(val, table%categories(catpos,1))) then lo=pos+1 else if (table_cell_lt(val, table%categories(catpos,1))) then hi=pos-1 else search_table_key=table%idx(pos) return end if end do end function search_table_key ! ! legacy real specific factor level corresponding to value ! function findlev(val, table) integer :: findlev double precision, intent(in) :: val type (table_data) :: table integer, parameter :: MISS=-9999 type (table_cell), dimension(1) :: sval integer :: catpos, i, idx, j, iprobe if (val == MISS) then findlev=MISS return end if if (.not.table%sorted) then call sort_table(table) end if if (table%ncells < 5) then do i=1, table%ncells if (val == table%categories(i,1)%rvalue) then findlev=table%catlevel(i) return end if end do else if (table%table_hash%nrec > 0) then call set_table_cell(sval(1), rvalue=val) idx=cell_hash(1, sval, table%table_hash%nrec) iprobe=table%table_hash%primroot j=idx do i=table%table_hash%address(j+1) if (i == 0) exit if (val == table%categories(i,1)%rvalue) then findlev=table%catlevel(i) return end if j=mod(idx+iprobe, table%table_hash%nrec) iprobe=mod(iprobe*table%table_hash%primroot, table%table_hash%nrec) end do end if ! if not found write(*,*) 'ERROR: In findlev, ', val, ' not in table!' do i=1, table%ncells write(*,'(i0)', advance='no') i call write_table_cell(x=table%categories(table%idx(i),1)) end do findlev=1 end function findlev ! ! find rank based on position in 1-D table ! function findrank_cell(val, table) double precision :: findrank_cell type (table_cell), intent(in) :: val type (table_data) :: table integer i, catpos, cumsum if (table%ncat == 1) then cumsum=0 do i=1, table%ncells catpos=table%idx(i) ! write(*,'(a,2(1x,i0),a)', advance='no') 'findrank ', i, catpos, ' ' ! call write_table_cell(x=table%categories(catpos,1), advance='no') ! write(*,'(a,i0,f9.4)') ' ', cumsum, dble(cumsum + (1+table%icount(catpos))/2) + & ! 0.5d0*mod(1+table%icount(catpos), 2) if (table_cell_eq(val, table%categories(catpos,1))) then findrank_cell = dble(cumsum + (1+table%icount(catpos))/2) + & 0.5d0*mod(1+table%icount(catpos), 2) return end if cumsum=cumsum+table%icount(catpos) end do end if ! not here, return median !? write(*,'(a)', advance='no') 'ERROR: In findrank_cell, ' call write_table_cell(x=val, advance='no') write(*,'(a)') ' not in table!' if (table%ncat > 1) write(*,*) ' Table has ', table%ncat,' dimensions!' findrank_cell=0.5d0*dble(table%ntot) end function findrank_cell ! ! legacy real specific ! function findrank(val, table) double precision findrank double precision val type (table_data) :: table integer catpos, i, cumsum cumsum=0 do i=1, table%ncells catpos=table%idx(i) if (val == table%categories(catpos,1)%rvalue) then findrank = dble(cumsum + (1+table%icount(catpos))/2) + & 0.5d0*mod(1+table%icount(catpos), 2) return end if cumsum=cumsum+table%icount(catpos) end do ! not here, return median !? write(*,*) 'ERROR: In findrank, ', val, ' not in table!' if (table%ncat>1) write(*,*) ' Table has ', table%ncat,' dimensions!' findrank=0.5d0*dble(table%ntot) end function findrank ! ! write 1-D table category real values to ordered real array ! subroutine table_r_array(table, rarray) type (table_data) :: table double precision, dimension(table%ncells), intent(out) :: rarray integer :: i, idx if (.not.table%sorted) then call sort_table(table) end if do i=1, table%ncells rarray(i)=table%categories(table%idx(i),1)%rvalue end do end subroutine table_r_array ! ! Sum the category values * counts for a 1-D table subroutine summate(table, tot) type (table_data) :: table double precision, intent(out) :: tot integer :: catpos, i tot=0.0d0 do i=1, table%ncells catpos=table%idx(i) tot=tot+real(table%icount(catpos))*table%categories(catpos,1)%rvalue end do end subroutine summate ! end module contingency_table ! ! Extract key-value pairs from a string ! and put in table. ! Key can be integer or string, value is string ! module keyval contains subroutine extract_kv(string, kv_table, longest_value, key_type) use scanner use contingency_table character(len=*) :: string type (table_data) :: kv_table integer, intent(out) :: longest_value character(len=1), intent(in), optional :: key_type integer :: cpos, eol, i, key, lenval, pos, sol, stat, typ character (len=80), dimension(0:2) :: circular type (table_cell), dimension(2) :: values ! functions integer :: ival longest_value=0 call setup_table(2, 20, kv_table) eol=len_trim(string) if (eol == 0) return typ=1 if (present(key_type)) then if (key_type == 'c') typ=2 end if circular(0:2)=' ' sol=sow(string) cpos=2 i=sol n=1 do cpos=mod(cpos+1,3) call nextword(i, string, eol, opsimple, n, circular(mod(cpos+1,3)), & stat, ' ', SEP_WH_RES) if (stat == -1) then exit else if (circular(cpos) == '=') then lenval=len_trim(circular(mod(cpos+1,3))) if (lenval > longest_value) longest_value=lenval if (typ == 1) then key=ival(trim(circular(mod(cpos+2,3)))) call set_table_cell(values(1), ivalue=key) else call set_table_cell(values(1), string=trim(circular(mod(cpos+2,3)))) end if call set_table_cell(values(2), string=trim(circular(mod(cpos+1,3)))) call insert_table_cells(2, values, kv_table, 1) end if end do call sort_table(kv_table) end subroutine extract_kv ! ! search key-value table ! function search_kv(kv_table, key) use contingency_table character(len=:), allocatable :: search_kv type (table_data) :: kv_table integer, intent(in) :: key type (table_cell) :: keycell integer :: i, pos character(len=80) :: str call set_table_cell(keycell, ivalue=key) pos=search_table_key(keycell, kv_table) if (pos > 0) then call get_table_cell(kv_table%categories(pos,2), string=str) i=len_trim(str) allocate(character(len=i) :: search_kv) search_kv=trim(str) else allocate(character(len=1) :: search_kv) search_kv=' ' end if end function search_kv end module keyval ! ! Utilities to print arrays ! module showcomponent contains subroutine show_one_iarray(nam, sep, sta, fin, isall, array) character (len=*) :: nam, sep integer :: sta, fin logical :: isall integer, dimension(:) :: array write(*,'(a8,2x,l1)', advance='no') nam, isall if (isall) then write(*,'(i12,1x,a)', advance='no') size(array), sep write(*,'((10(a,i0)/25x,10(a,i0)):)') (' ', array(i), i=sta, fin) else write(*,*) end if end subroutine show_one_iarray ! subroutine show_one_carray(nam, sep, sta, fin, isall, array) character (len=*) :: nam, sep integer :: sta, fin logical :: isall character (len=*), dimension(:) :: array write(*,'(a8,2x,l1)', advance='no') nam, isall if (isall) then write(*,'(i12,1x,a)', advance='no') size(array), sep write(*,'((10(1x,3a)/25x,10(1x,3a)):)') ('"', trim(array(i)), '"', i=sta, fin) else write(*,*) end if end subroutine show_one_carray ! subroutine show_one_farray(nam, sep, sta, fin, isall, array) character (len=*) :: nam, sep integer :: sta, fin logical :: isall double precision, dimension(:) :: array integer :: i, j write(*,'(a8,2x,l1)', advance='no') nam, isall if (isall) then i=sta j=min(fin,i+9) write(*,'(i12,1x,a)', advance='no') size(array), sep write(*,*) array(i:j) do while (j < fin) i=i+10 j=min(fin,i+9) write(*,'(24x,a1)', advance='no') ' ' write(*,*) array(i:j) end do else write(*,*) end if end subroutine show_one_farray end module showcomponent ! ! Locus types bitpatterns ! loctyp Compression_scheme Deleted Marker: Autosomal X-marker Haploid Y-chrom / Affection Quantitative ! CC D T ! 1 00 0 0 001 Autosomal marker ! 2 00 0 0 010 X-chromosome marker ! 4 00 0 0 100 Haploid unspecified ! 5 00 0 0 101 Mitochondrial marker ! 6 00 0 0 110 Y-Chromosome marker ! 8 00 0 1 000 Trait unspecified ! 9 00 0 1 001 Quantitative trait ! 10 00 0 1 010 Binary trait ! 11 00 0 1 011 Categorical trait ! 12 00 0 1 100 Special trait (computed) ! module locus_types integer, parameter :: LOC_ANY=0, LOC_HAP=4, LOC_TRA=8, LOC_DEL=16, LOC_CMP=32 integer, parameter :: LOC_CODOM=1, LOC_XLIN=2, LOC_MIT=5, LOC_YHA=6, & LOC_QUA=9, LOC_AFF=10 , LOC_CAT=11, LOC_SPECIAL=12 integer, parameter :: DEL_CODOM=LOC_DEL+LOC_CODOM, & DEL_XLIN=LOC_DEL+LOC_XLIN, DEL_HAP=LOC_DEL+LOC_HAP, & DEL_QUA=LOC_DEL+LOC_QUA, DEL_AFF=LOC_DEL+LOC_AFF, & DEL_CAT=LOC_DEL+LOC_CAT character (len=1), dimension(13), parameter :: typloc = & (/ 'm','x','m','h','i','y','h','t', 'q','a','c','s','d' /) character (len=12), dimension(13), parameter :: typlloc = & (/'marker ', 'xmarker ', & 'diploid ', 'haploid ', & 'mitochond ', 'ymarker ', & 'haploid ', 'trait ', & 'quantitative', 'affection ', & 'categorical ', 'computed ', & 'deleted ' /) contains function loccode(ch) integer :: loccode character (len=1), intent(in) :: ch loccode=0 if (ch == 'm') then loccode=LOC_CODOM else if (ch == 'q') then loccode=LOC_QUA else if (ch == 'c') then loccode=LOC_CAT else if (ch == 'a') then loccode=LOC_AFF else if (ch == 'x') then loccode=LOC_XLIN else if (ch == 'y') then loccode=LOC_YHA else if (ch == 'i') then loccode=LOC_MIT else if (ch == 'h') then loccode=LOC_HAP else if (ch == 't') then loccode=LOC_TRA else if (ch == 's') then loccode=LOC_SPECIAL else if (ch == 'd') then loccode=LOC_DEL end if end function loccode ! ! same locus type or same class, ignoring compression type but not where dropped ! function same_loctyp(loctyp, reftyp) logical :: same_loctyp integer, intent(in) :: loctyp, reftyp same_loctyp=(mod(loctyp, LOC_CMP) == mod(reftyp, LOC_CMP)) if (mod(reftyp, 4) /= 0) return if (reftyp == LOC_HAP) then same_loctyp=(ishaploid(loctyp) .and. isactive(loctyp)) else if (reftyp == LOC_TRA) then same_loctyp=(.not.ismarker(loctyp) .and. isactive(loctyp)) else if (reftyp == LOC_DEL) then same_loctyp=(.not.isactive(loctyp)) else if (reftyp == (LOC_TRA + LOC_DEL)) then same_loctyp=(.not.ismarker(loctyp) .and. .not.isactive(loctyp)) end if end function same_loctyp ! is an active variable function isactive(loctyp) logical :: isactive integer, intent(in) :: loctyp isactive=(iand(loctyp, LOC_DEL) == 0) end function isactive ! trait - active function istrait(loctyp) logical :: istrait integer, intent(in) :: loctyp istrait=(loctyp == LOC_QUA .or. loctyp == LOC_AFF .or. loctyp == LOC_CAT) end function istrait ! calculated trait function isspecial(loctyp) logical :: isspecial integer, intent(in) :: loctyp isspecial=(loctyp == LOC_SPECIAL) end function isspecial ! quantitative trait function isqtrait(loctyp) logical :: isqtrait integer, intent(in) :: loctyp isqtrait=(loctyp == LOC_QUA) end function isqtrait ! binary trait - active function isafftrait(loctyp) logical :: isafftrait integer, intent(in) :: loctyp isafftrait=(loctyp == LOC_AFF) end function isafftrait ! categorical trait - active function iscattrait(loctyp) logical :: iscattrait integer, intent(in) :: loctyp iscattrait=(loctyp == LOC_CAT) end function iscattrait ! marker - inactive or active function ismarker(loctyp) logical :: ismarker integer, intent(in) :: loctyp ismarker=(iand(loctyp, LOC_TRA) == 0) end function ismarker ! genotype encoding 1=standard 2=sequence 3=compressed SNP function gencode(loctyp) integer :: gencode integer, intent(in) :: loctyp gencode=(loctyp/LOC_CMP)+1 end function gencode ! is a haploid locus function ishaploid(loctyp) logical :: ishaploid integer, intent(in) :: loctyp ishaploid=(iand(loctyp, LOC_TRA) == 0 .and. iand(loctyp, LOC_HAP) == 4) end function ishaploid ! is genotype storage compact (gencode > 1) function iscompressed(loctyp) logical :: iscompressed integer, intent(in) :: loctyp iscompressed=(loctyp > LOC_CMP) end function iscompressed ! most association/linkage procedures are for active diploid codominant markers function isactdip(loctyp) logical :: isactdip integer, intent(in) :: loctyp isactdip=(same_loctyp(loctyp, LOC_CODOM) .or. same_loctyp(loctyp, LOC_XLIN)) end function isactdip ! eligible for a keep or drop function iseligiblemarker(loctyp, choice, active) logical :: iseligiblemarker integer, intent(in) :: loctyp integer, intent(in) :: choice logical, intent(in) :: active if (active) then iseligiblemarker = iand(loctyp, LOC_TRA) == choice .and. iand(loctyp, LOC_DEL) == 0 else iseligiblemarker = iand(loctyp, LOC_TRA) == choice .and. iand(loctyp, LOC_DEL) /= 0 end if end function iseligiblemarker end module locus_types ! ! String length for locus names and annotations ! module locstring_widths integer, parameter :: loc_width = 20 integer, parameter :: annotation_width = 40 integer, parameter :: chromosome_width = 2 end module locstring_widths ! ! Locus name hash table ! module lochash_class use locstring_widths use idhash_class contains subroutine make_lochash(nloci, loc, lochash) integer, intent(in) :: nloci character(len=loc_width), dimension(:), intent(in) :: loc type (hash_table), intent(inout) :: lochash integer :: exactdup, i, iaddress, idx, iprobe, j call setup_hash(HK_LOCNAM, nloci, lochash, 90) exactdup=0 do i=1, nloci idx=string_hash(trim(loc(i)), lochash%nrec) j=idx iprobe=lochash%primroot do while (lochash%address(j+1) /= 0) iaddress=lochash%address(j+1) if (loc(i) == loc(iaddress)) then exactdup=exactdup+1 end if j=mod(idx+iprobe, lochash%nrec) iprobe=mod(iprobe*lochash%primroot, lochash%nrec) end do lochash%address(j+1) = i end do lochash%current=.true. if (exactdup > 0) lochash%hasdups=.true. end subroutine make_lochash ! ! append most recent locus to hash table ! subroutine insert_lochash(str, nloci, loc, lochash) character (len=*), intent(in) :: str integer, intent(in) :: nloci character(len=loc_width), dimension(:), intent(in) :: loc type (hash_table), intent(inout) :: lochash integer :: idx, iprobe, j if (nloci > (lochash%nrec-10)) then call cleanup_hash(lochash) call make_lochash(nloci, loc, lochash) end if idx=string_hash(str, lochash%nrec) j=idx iprobe=lochash%primroot do while (lochash%address(j+1) /= 0) j=mod(idx+iprobe, lochash%nrec) iprobe=mod(iprobe*lochash%primroot, lochash%nrec) end do lochash%address(j+1) = nloci end subroutine insert_lochash ! subroutine show_lochash(nloci, lochash) integer, intent(in) :: nloci type (hash_table), intent(inout) :: lochash write(*,'(a)') 'Locus name hash:' write(*,'(a,l1)') ' Up to date? ', lochash%current write(*,'(a,l1)') ' Duplicates? ', lochash%hasdups write(*,'(a,i0)') ' Table size ', lochash%nrec write(*,'(a,i0)') ' No. of loci ', nloci write(*,*) end subroutine show_lochash ! ! hash map position 'chr:bp' ! subroutine make_maphash(nloci, loctyp, group, map, map_str, maphash) use locstring_widths use locus_types integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp character (len=chromosome_width), dimension(:), intent(in) :: group double precision, dimension(:), intent(in) :: map character (len=13), dimension(:), intent(out) :: map_str type (hash_table), intent(inout) :: maphash integer, parameter :: MISS=-9999 integer :: i, idx, iprobe, j character (len=13) :: pos_str ! functions integer :: tobp call setup_hash(HK_MAPPOS, nloci, maphash, 90) do i=1, nloci if (isactive(loctyp(i)) .and. map(i) /= MISS) then write(pos_str,'(i10)') tobp(map(i)) pos_str= trim(group(i)) // ':' // adjustl(pos_str) map_str(i)=pos_str idx=string_hash(trim(pos_str), maphash%nrec) j=idx iprobe=maphash%primroot do while (maphash%address(j+1) /= 0) j=mod(idx+iprobe, maphash%nrec) iprobe=mod(iprobe*maphash%primroot, maphash%nrec) end do maphash%address(j+1) = i end if end do maphash%current=.true. end subroutine make_maphash end module lochash_class ! ! Storage for the locus data ! module locus_data use outstream use locstring_widths use lochash_class use showcomponent ! ! Working locus structure: ! number of loci, locus name, locus type, and locus position in file ! loctyp 1=marker 2=X-marker... ! integer :: nloci = 0 character(len=loc_width), dimension(:), allocatable :: loc ! Hash table for locus names type (hash_table), save :: lochash character(len=annotation_width), dimension(:), allocatable :: locnotes integer, dimension(:), allocatable :: loctyp, locpos, outpos ! position of locus on sex-averaged linkage map or sequence character (len=chromosome_width), dimension(:), allocatable :: group double precision, dimension(:), allocatable :: map ! indices for subsetting, reordering integer :: nord = 0 integer, dimension(:), allocatable :: locord integer, dimension(:), allocatable :: wloc ! collected statistics, such as P-values double precision, dimension(:), allocatable :: locstat ! ! A container for basic locus data ! type locus_container integer :: nloci character(len=loc_width), dimension(:), allocatable :: loc integer, dimension(:), allocatable :: loctyp character (len=chromosome_width), dimension(:), allocatable :: group double precision, dimension(:), allocatable :: map end type locus_container ! ! whichstat is statistic held in locstat ! locstat_typ is type of statistic: ! 0 = P-value ! 1 = continuous ! 2 = categorical ! integer :: locstat_typ character (len=4), dimension(0:2), parameter :: & locstat_type_string = (/ 'pval', 'cont', 'cat ' /) character (len=60) :: whichstat=' ' ! ! twinning=the zygosity indicator locus number ! MISS = no zygosity indicator ! 0 = twintrait is set, but corresponding locus not yet declared ! twintrait=name of zygosity indicator ! twintype=zygosity category scheme ! 1: (MZ==(zyg > 0)) ! 2: (MZ==(zyg > 0 and odd? zyg)) ! integer :: twinning, twintype character (len=loc_width) :: twintrait=' ' ! ! sexmarker is sex-informative marker character (len=loc_width) :: sexmarker=' ' contains ! ! Allocate storage for locus descriptions ! subroutine setup_loci(n) integer :: n integer, parameter :: MISS=-9999 allocate(loc(n), loctyp(n), locpos(n), locnotes(n), group(n), outpos(n)) allocate(map(n), locstat(n)) allocate(locord(n), wloc(n)) loc='' loctyp=0 locpos=0 locnotes='' group='' outpos=0 map=MISS locstat=MISS locord=0 wloc=0 end subroutine setup_loci ! ! Initialize automatic variables ! subroutine setup_auto() use locus_types use automatic_data integer, parameter :: MISS=-9999 integer :: i if (size(loc)-nloci < ENVNUM) then write(*,*) 'FATAL ERROR! Inadequate allocation for locus data in setup_auto!' stop end if loctyp(1:ENVNUM)=LOC_SPECIAL do i=1, ENVNUM loc(i)=env(i) locpos(i)=i group(i)='' map(i)=MISS end do locnotes(1)='1=Male 2=Female' locnotes(2)='Female sex 1=Female 0=Male' locnotes(3)='Male sex 1=Male 0=Female' locnotes(4)='Pedigree founder 1=Founder 0=Nonfounder' locnotes(5)='Pedigree nonfounder 1=Nonfound 0=Found' locnotes(6)='Pedigree size' locnotes(7)='Number of founders' locnotes(8)='Any missing data? 0=Complete 1=Missing' locnotes(9)='Any observed genotypes? 0=None 1=Some' locnotes(10)='Fully genotyped? 0=Incomplete 1=Fully' locnotes(11)='Nonmissing count' locnotes(12)='Pedigree index' locnotes(13)='Individual index' locnotes(14)='Max nonmissing markers shared' locnotes(15)='Genotype call rate' locnotes(16)='Chosen for last operation' nloci=nloci+ENVNUM end subroutine setup_auto ! ! Count number of automatic variables (eg interrogate old binary images) ! subroutine count_specials(nvars) use locus_types use automatic_data integer, intent(out) :: nvars integer :: i, lenloc nvars=0 lenloc=size(loctyp) do i=1, lenloc if (.not.isspecial(loctyp(i))) exit nvars=nvars+1 end do end subroutine count_specials ! ! Deallocate storage for locus descriptions ! subroutine cleanup_loci() deallocate(loc, loctyp, locpos, locnotes, group, outpos) deallocate(map, locstat) deallocate(locord, wloc) call cleanup_hash(lochash) end subroutine cleanup_loci ! ! Expand arrays for locus descriptions ! subroutine expand_loci(nextra, plevel) integer, intent(in) :: nextra integer, intent(in) :: plevel integer :: newsiz, oldsiz ! temporary storage character (len=loc_width), dimension(:), allocatable :: loc2 integer, dimension(:), allocatable :: loctyp2 integer, dimension(:), allocatable :: locpos2, outpos2 character (len=annotation_width), dimension(:), allocatable :: locnotes2 character (len=chromosome_width), dimension(:), allocatable :: group2 double precision, dimension(:), allocatable :: map2 oldsiz=size(loc) if (nextra <= 0) then if (plevel > 0) then write(outstr,'(a,i0)') 'NOTE: maximum number of loci already ', oldsiz end if return end if newsiz=oldsiz+nextra if (plevel > 0) then write(outstr,'(a,i0)') 'NOTE: expanding maximum number of loci to ', newsiz end if allocate(loc2(oldsiz), loctyp2(oldsiz), locpos2(oldsiz), outpos2(oldsiz), & locnotes2(oldsiz), group2(oldsiz), map2(oldsiz)) loc2=loc loctyp2=loctyp locpos2=locpos outpos2=outpos locnotes2=locnotes group2=group map2=map call cleanup_loci() call setup_loci(newsiz) loc(1:oldsiz)=loc2(1:oldsiz) loctyp(1:oldsiz)=loctyp2(1:oldsiz) locpos(1:oldsiz)=locpos2(1:oldsiz) outpos(1:oldsiz)=outpos2(1:oldsiz) locnotes(1:oldsiz)=locnotes2(1:oldsiz) group(1:oldsiz)=group2(1:oldsiz) map(1:oldsiz)=map2(1:oldsiz) deallocate(loc2, loctyp2, locpos2, outpos2, locnotes2, map2) end subroutine expand_loci ! ! insert a locus into the locus list ! other details of the slot are left blank ! subroutine insloc(pos) integer, intent(inout) :: pos integer :: i do i=nloci-1, pos, -1 loc(i+1)=loc(i) loctyp(i+1)=loctyp(i) locpos(i+1)=locpos(i) outpos(i+1)=outpos(i) group(i+1)=group(i) map(i+1)=map(i) end do end subroutine insloc ! ! Preallocate arrays for locus descriptions from MERLIN locus file ! subroutine setupmer(port, plevel) use automatic_data use outstream use fileio use scanner type (ioport) :: port integer, intent(in) :: plevel integer :: ioerr, narg, newsiz character (len=100) :: s character (len=40), dimension(2) :: words newsiz=0 do call readline(port, s, ios=ioerr) if (ioerr /= 0) exit narg=2 call args(s, narg, words, ' ', SEP_WHITE) if (words(1)(1:1) /= 'E') then newsiz=newsiz+1 end if end do if (plevel > 0) then write(outstr,'(a,i0,a)') 'Merlin locus file contains ', newsiz, ' markers.' end if call rewind_port(port, ioerr) newsiz=5*(1+newsiz/5) call expand_loci(newsiz, 0) end subroutine setupmer ! ! Allocate arrays for locus descriptions from PLINK .map/.bim file ! subroutine setup_plink(port, nmark, newsiz, typ) use fileio type (ioport) :: port integer, intent(out) :: nmark integer, intent(out) :: newsiz integer, intent(in) :: typ ! merge, join, join+compress integer :: ioerr, oldsiz character (len=100) :: s nmark=0 do call readline(port, s, ios=ioerr) if (ioerr /= 0) exit if (s /= ' ') nmark=nmark+1 end do call rewind_port(port, ioerr) newsiz=nmark+nloci+1 oldsiz=size(loc) if (newsiz > oldsiz .and. typ > 1) then newsiz=5*(1+newsiz/5) call expand_loci(newsiz-oldsiz, 0) end if end subroutine setup_plink ! ! Allocate arrays for locus descriptions from Sib-pair binary dataset ! subroutine setup_bin(port, nmark, newsiz, typ) use fileio type (ioport) :: port integer, intent(out) :: nmark integer, intent(out) :: newsiz integer, intent(in) :: typ ! merge, join, join+compress integer :: ioerr, oldsiz character (len=4) :: byte character (len=21) :: slin nmark=0 slin=' ' call readline(port, slin, advance='no', ios=ioerr) if (slin(1:16) /= 'Sib-pair raw ped') then write(outstr,'(a)') 'ERROR: Not a Sib-pair binary pedigree file.' return end if call readline(port, byte, advance='no', ios=ioerr) if (ioerr == 0) nmark=transfer(byte, ich) call rewind_port(port, ioerr) newsiz=nmark+nloci+1 oldsiz=size(loc) if (newsiz > oldsiz .and. typ > 1) then newsiz=5*(1+newsiz/5) call expand_loci(newsiz-oldsiz, 0) end if end subroutine setup_bin ! ! initialize locstat (stores test statistic for each locus) ! locstat_typ is type of statistic: ! 0 = P-value ! 1 = continuous ! 2 = categorical ! subroutine setup_stat(comment, typ) character (len=*), intent(in) :: comment integer, intent(in), optional :: typ integer, parameter :: MISS=-9999 whichstat=comment locstat_typ=0 if (present(typ)) locstat_typ=typ locstat=MISS end subroutine setup_stat ! ! Diagnostics for locus structure ! subroutine show_locus_allocation(first, last) integer, intent(in) :: first, last integer :: sta, fin sta=1 fin=min(5,size(loc)) if (first > 0) then sta=min(first, size(loc)) end if if (last > 0) then fin=min(last, size(loc)) end if write(*,'(a,i0,a,i0)') 'nloci=', nloci, ' size(loc)=', size(loc) write(*,'(a/a)') 'Array Alloc? N : Values', & '-------- --------------------' call show_one_carray('loc', ':', sta, fin, allocated(loc), loc) call show_one_iarray('loctyp', ':', sta, fin, allocated(loctyp), loctyp) call show_one_iarray('locpos', ':', sta, fin, allocated(locpos), locpos) call show_one_iarray('outpos', ':', sta, fin, allocated(outpos), outpos) call show_one_carray('locnotes', ':', sta, fin, allocated(locnotes), locnotes) call show_one_carray('group', ':', sta, fin, allocated(group), group) call show_one_farray('map', ':', sta, fin, allocated(map), map) call show_one_farray('locstat', ':', sta, fin, allocated(locstat), locstat) call show_one_iarray('locord', ':', sta, fin, allocated(locord), locord) call show_one_iarray('wloc', ':', sta, fin, allocated(wloc), wloc) write(*,*) end subroutine show_locus_allocation ! ! Old to new locus types subroutine newloctyp() integer :: i do i=1, nloci if (mod(loctyp(i),10) == 3 .or. mod(loctyp(i),10) == 4) then loctyp(i)=loctyp(i)+6 end if if (mod(loctyp(i),10) == 5) then loctyp(i)=loctyp(i)-1 end if if (loctyp(i) > 10) then loctyp(i)=loctyp(i)+6 end if end do end subroutine newloctyp ! ! initialize a locus container ! subroutine setup_locus_container(n, ldata) integer, intent(in) :: n type (locus_container) :: ldata integer, parameter :: MISS=-9999 allocate(ldata%loc(n), ldata%loctyp(n), ldata%group(n)) allocate(ldata%map(n)) ldata%nloci=n ldata%loc='' ldata%loctyp=0 ldata%group='' ldata%map=MISS end subroutine setup_locus_container ! subroutine cleanup_locus_container(ldata) type (locus_container) :: ldata deallocate(ldata%loc, ldata%loctyp, ldata%group, ldata%map) ldata%nloci=0 end subroutine cleanup_locus_container end module locus_data ! ! Subset, manipulate or print locus_data ! module locus_list integer :: locus_output_position = 1 contains ! ! determine if word is name of a trait locus ! subroutine gettrait(nam, typ1, typ2, nloci, loc, lochash, loctyp, trait, plevel) use outstream use locus_types use idhash_class use locstring_widths use automatic_data character (len=loc_width), intent(in) :: nam integer, intent(in) :: typ1 integer, intent(in) :: typ2 integer, intent(in) :: nloci character (len=loc_width), dimension(:), intent(in) :: loc type (hash_table) :: lochash integer, dimension(:), intent(in) :: loctyp integer, intent(out) :: trait integer, intent(in) :: plevel integer, parameter :: MISS=-9999 integer :: i ! functions integer :: ival logical :: is_strict_int trait=MISS if (nam == ' ') return if (is_strict_int(nam)) then i=ival(nam) if (1 <= i .and. i <= nloci-ENVNUM) trait=i+ENVNUM else call find_hashtab(trim(nam), loc, lochash, i) if (i /= 0) trait=i end if if (trait == MISS) then if (plevel >= 0) then write(*,'(/3a)') & 'NOTE: Unable to find requested variable "', trim(nam),'".' end if else if (.not.isactive(loctyp(trait)) .and. typ1 /= LOC_ANY) then if (plevel >= 0) then write(*,'(/3a)') & 'NOTE: "', trim(loc(trait)), '" is currently dropped from analysis.' end if trait=MISS else if (.not.(same_loctyp(loctyp(trait), typ1) .or. & same_loctyp(loctyp(trait), typ2)) .and. typ1 /= LOC_ANY) then if (plevel >= 0) then write(*,'(/3a)') & 'NOTE: "', trim(loc(trait)), '" is inappropriate locus type for requested procedure.' end if trait=MISS end if end subroutine gettrait ! ! check if name is not already used or reserved ! function isinuse(namechek, string, loc, lochash) use parser_data use lochash_class use locstring_widths logical isinuse logical :: namechek character (len=*), intent(in) :: string character (len=loc_width), dimension(:), intent(in) :: loc type (hash_table) :: lochash integer :: i ! functions logical :: isreal if (.not.namechek) then isinuse=.false. return end if call find_hashtab(trim(string(1:loc_width)), loc, lochash, i) isinuse=(i > 0) do i=1, toknum if (token(i) == string) then isinuse=.true. return end if end do do i=1, envnum if (env(i) == string) then isinuse=.true. return end if end do if (isreal(string)) isinuse=.true. return end function isinuse ! ! Get a single binary trait or dichotomized quantitative trait ! subroutine getbin(sta, fin, words, nloci, loc, lochash, loctyp, trait, gt, thresh) use outstream use locus_types use idhash_class use comp_ops integer, intent(in) :: sta integer, intent(in) :: fin character (len=40), dimension(:), intent(in) :: words integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc type (hash_table) :: lochash integer, dimension(:), intent(in) :: loctyp integer, intent(out) :: trait integer, intent(out) :: gt double precision, intent(out) :: thresh integer, parameter :: MISS=-9999 integer :: i character (len=3) :: keyword call gettrait(words(sta), LOC_TRA, 0, nloci, loc, lochash, loctyp, trait, 0) gt=0 thresh=MISS i=sta+1 do while(i<=fin) keyword=words(i)(1:3) if (iscomp(keyword)) then call docomp(i, words, gt, thresh) else i=i+1 end if end do if (trait /= MISS .and. thresh == MISS) then if (loctyp(trait) == LOC_QUA) trait=MISS end if end subroutine getbin ! ! Load list of traits into an array ! ! allows wild cards and spans ! filter= selection must also be of class eg LOC_CODOM, LOC_ANY ! typ=1 active loci, =2 inactive loci, =3 all loci (used by ls etc) ! ! output both as list (terms) and as index vector (chosen) ! subroutine loadnam(sta, fin, words, nloci, loc, lochash, loctyp, & group, map, locstat, chosen, nterms, terms, filter, typ, & division) use outstream use locus_types use locstring_widths use idhash_class use lochash_class use sorts use string_utilities use automatic_data integer, intent(in) :: sta ! first word of list integer, intent(in) :: fin ! last word of list character (len=40), dimension(:), intent(in) :: words integer, intent(in) :: nloci character (len=loc_width), dimension(:), intent(in) :: loc type (hash_table) :: lochash integer, dimension(:), intent(in out) :: loctyp character (len=chromosome_width), dimension(:), intent(in) :: group double precision, dimension(:), intent(in) :: map double precision, dimension(:), intent(in) :: locstat integer, dimension(:), intent(out) :: chosen integer, intent(out) :: nterms integer, dimension(:), intent(out) :: terms integer, intent(in) :: filter, typ integer, optional, intent(out) :: division ! local variables integer :: ichr, i, j, locnum, maxterms, nmark, offset, pos, span integer :: be, bymap, dir, en double precision :: hash_locnam double precision, dimension(nloci) :: mapidx integer, dimension(nloci) :: ord ! functions ! chfind, strfind integer :: chrnum, ival logical :: is_strict_int, has_env bymap=0 has_env=.false. chosen(1:nloci)=0 nterms=0 if (present(division)) division=0 maxterms=size(terms) ! empty list is all loci if (sta > fin) then call actlist(typ, nloci, loctyp, nterms, chosen) end if pos=sta i=0 locnum=1 offset=0 if (typ == 2) offset=LOC_DEL do while (pos <= fin) if (words(pos)(1:1) == '$') then ! by activity if (words(pos)(2:2) == 'A') then call actlist(1, nloci, loctyp, nterms, chosen) else if (words(pos)(2:2) == 'D') then call actlist(2, nloci, loctyp, nterms, chosen) else if (words(pos)(2:2) == 'M') then call mappedlist(nloci, map, nterms, chosen) else ! a class of variable bymap=0 i=loccode(words(pos)(2:2)) dir=1 be=1 en=nloci if (words(pos)(3:3) == 'r' .or. words(pos)(4:4) == 'r') then dir=-1 be=nloci en=1 else if (words(pos)(3:3) == 'm') then bymap=1 else if (words(pos)(3:3) == 't') then bymap=2 end if i=i+offset if (bymap == 0) then do locnum=be,en,dir if (same_loctyp(loctyp(locnum), i) .and. chosen(locnum) == 0) then nterms=nterms+1 chosen(locnum)=nterms end if end do else nmark=0 if (bymap == 1) then do locnum=1, nloci if (same_loctyp(loctyp(locnum), i) .and. chosen(locnum) == 0) then nmark=nmark+1 ord(nmark)=locnum ichr=chrnum(group(locnum)) hash_locnam=0.0d0 if (loc(locnum)(1:2) /= 'rs') hash_locnam=0.5d0 mapidx(nmark)=1.0d9*ichr + 1.0d6*map(locnum) + hash_locnam end if end do else do locnum=1, nloci if (same_loctyp(loctyp(locnum), i) .and. chosen(locnum) == 0) then nmark=nmark+1 ord(nmark)=locnum mapidx(nmark)=locstat(locnum) end if end do end if call srank(nmark, mapidx, ord) do j=1, nmark nterms=nterms+1 chosen(ord(j))=nterms end do end if end if locnum=1 pos=pos+1 else if (chfind(words(pos),'*') /= 0) then ! a wild card do locnum=1, nloci if (strfind(words(pos), loc(locnum), 1) .and. chosen(locnum) == 0) then nterms=nterms+1 chosen(locnum)=nterms end if end do locnum=1 pos=pos+1 ! list partitioned in two else if (words(pos) == 'versus' .and. present(division)) then division=nterms pos=pos+1 else ! a variable name or range of variables names span=0 if (words(pos) == 'to' .or. words(pos) == '--') then span=locnum pos=pos+1 end if if (pos <= fin) then if (is_strict_int(words(pos))) then locnum=ival(words(pos)) + ENVNUM if (locnum < 0 .or. locnum > nloci) locnum=0 else if (.not.lochash%current) then call make_lochash(nloci, loc, lochash) end if call find_hashtab(trim(words(pos)(1:loc_width)), loc, lochash, locnum) end if else locnum=nloci end if if (locnum == 0) then write(outstr,'(3a/)') & 'ERROR: Unable to find locus "', trim(words(pos)), '".' else if (locnum <= ENVNUM) then if (span /= 0) then write(outstr,'(3a/)') & 'ERROR: Span cannot involve "', trim(words(pos)), '".' else has_env=.true. nterms=nterms+1 chosen(locnum)=nterms end if else if (span == 0) span=locnum call order(span, locnum) if (typ == 1) then do i=span, locnum if (isactive(loctyp(i)) .and. chosen(i) == 0) then nterms=nterms+1 chosen(i)=nterms end if end do else if (typ == 2) then do i=span, locnum if (.not.isactive(loctyp(i)) .and. chosen(i) == 0) then nterms=nterms+1 chosen(i)=nterms end if end do else do i=span, locnum if (chosen(i) == 0) then nterms=nterms+1 chosen(i)=nterms end if end do end if end if pos=pos+1 end if end do ! ! filter out types if requested ! if (filter /= 0) then do locnum=1, nloci if (loctyp(locnum) /= filter .and. chosen(locnum) > 0) then chosen(locnum)=0 end if end do end if do locnum=1, nloci if (chosen(locnum) > 0) then terms(chosen(locnum))=locnum end if end do end subroutine loadnam ! ! Nearest neighbours in locus list of same type ! subroutine neighbours(idx, dir, nreq, nloci, loctyp, chosen) use locus_types integer, intent(in) :: idx integer, intent(in) :: dir, nreq integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(inout) :: chosen ! local variables integer :: i, nmark, bound, ltyp if (dir == 1) then bound=nloci if (idx == bound) return else bound=1 if (idx == bound) return end if ltyp=loctyp(idx) nmark=0 i=idx do i=i+dir if (i == bound) exit if (same_loctyp(loctyp(i), ltyp)) then nmark=nmark+1 chosen(i)=1 end if if (nmark == nreq) exit end do end subroutine neighbours ! ! All active/inactive ! subroutine actlist(typ, nloci, loctyp, nchosen, chosen) use locus_types integer, intent(in) :: typ integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, intent(inout) :: nchosen integer, dimension(:), intent(inout) :: chosen ! local variables integer :: locnum if (typ == 1) then do locnum=1, nloci if (isactive(loctyp(locnum)) .and. .not.isspecial(loctyp(locnum))) then nchosen=nchosen+1 chosen(locnum)=nchosen end if end do else if (typ == 2) then do locnum=1, nloci if (.not.isactive(loctyp(locnum))) then nchosen=nchosen+1 chosen(locnum)=nchosen end if end do else do locnum=1, nloci nchosen=nchosen+1 chosen(locnum)=nchosen end do end if end subroutine actlist ! ! All mapped loci ! subroutine mappedlist(nloci, map, nchosen, chosen) use locus_types integer, intent(in) :: nloci double precision, dimension(:), intent(in) :: map integer, intent(inout) :: nchosen integer, dimension(:), intent(inout) :: chosen ! local variables integer, parameter :: MISS = -9999 integer :: locnum do locnum=1, nloci if (map(locnum) /= MISS) then nchosen=nchosen+1 chosen(locnum)=nchosen end if end do end subroutine mappedlist ! ! Select loci based on search of annotations ! subroutine search_annot(sta, fin, words, nloci, locnotes, chosen, nterms, terms) use outstream use locstring_widths use automatic_data use string_utilities integer, intent(in) :: sta integer, intent(in) :: fin character (len=*), dimension(:), intent(in) :: words integer, intent(in) :: nloci character (len=annotation_width), dimension(:), intent(in) :: locnotes integer, dimension(:), intent(out) :: chosen integer, intent(out) :: nterms integer, dimension(:), intent(out) :: terms integer, parameter :: MISS=-9999 integer :: i, j character (len=256) :: string nterms=0 chosen=0 do j=sta, fin string='*' // trim(words(j)) // '*' do i=ENVNUM+1, nloci if (strfind(string, locnotes(i), 1)) then if (chosen(i) == 0) then nterms=nterms+1 chosen(i)=nterms end if end if end do end do do i=1, nloci if (chosen(i) > 0) then terms(chosen(i))=i end if end do end subroutine search_annot ! ! Select loci based on chromosome ! subroutine search_chrom(sta, fin, words, nloci, group, chosen, nterms, terms) use outstream use locstring_widths use automatic_data use string_utilities use idhash_class integer, intent(in) :: sta integer, intent(in) :: fin character (len=*), dimension(:), intent(in) :: words integer, intent(in) :: nloci character (len=chromosome_width), dimension(:), intent(in) :: group integer, dimension(:), intent(out) :: chosen integer, intent(out) :: nterms integer, dimension(:), intent(out) :: terms integer, parameter :: MISS=-9999 type (hash_table) :: chromhash integer :: i, ichrom, j, nchrom nterms=0 chosen=0 nchrom=fin-sta+1 if (nchrom < 3) then do i=1, nloci wordloop: do j=sta, fin if (words(j) == group(i)) then if (chosen(i) == 0) then nterms=nterms+1 chosen(i)=nterms end if exit wordloop end if end do wordloop end do else call setup_hash(HK_CHROM, nchrom, chromhash, 50) call fill_hash(chromhash, words(sta:fin)) do i=1, nloci call find_hashtab(trim(group(i)), words(sta:fin), & chromhash, ichrom) if (ichrom > 0 .and. chosen(i) == 0) then nterms=nterms+1 chosen(i)=nterms end if end do call cleanup_hash(chromhash) end if do i=1, nloci if (chosen(i) > 0) then terms(chosen(i))=i end if end do end subroutine search_chrom ! ! List loci using short (typ=2) or long (typ=1) form ! plevel < -1 will give a simple list of names ! subroutine listloci(nord, locord, nloci, loc, loctyp, outpos, locnotes, & typ, prompt, plevel) use interrupt use outstream use locus_types use locstring_widths use automatic_data integer, intent(in) :: nord integer, intent(in) :: locord(nord) integer, intent(in) :: nloci character (len=loc_width), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: outpos character (len=annotation_width), dimension(:), intent(in) :: locnotes integer, intent(in) :: typ logical, intent(in) :: prompt integer, intent(in) :: plevel integer :: i, ityp, j, eon, longest, nmark, nshow, ntrait, pos character (len=1) :: cmp character (len=20) :: fmtstring ! functions double precision :: bonf character (len=20000) :: get_notes0 longest=0 nshow=nord if (prompt .and. plevel < 1) nshow = min(1000, nord) nmark=0 ntrait=0 if (typ == 1) then if (plevel > -2) then do j=1, nord longest=max(longest, len_trim(loc(locord(j)))) if (longest == loc_width) exit end do longest=max(longest, 12) write(fmtstring,'(a,i0,a)') '(2(/a', longest, ',1x,a,1x,a))' write(outstr, fmtstring, advance='yes') & 'Locus ', 'Type', 'Position', & repeat('-', longest), repeat('-',4), repeat('-',16) write(fmtstring,'(a,i0,a)') '(a', longest, ')' do j=1, nshow i=locord(j) ityp=min(13, mod(loctyp(i), LOC_CMP)) if (ismarker(loctyp(i))) then nmark=nmark+1 cmp=' ' if (iscompressed(loctyp(i))) cmp='s' write(outstr, fmtstring, advance='no') loc(i) if (locus_output_position == 1) then write(outstr,'(2x,2a1,4x,i12,5x,a)') & typloc(ityp), cmp, i-ENVNUM, trim(locnotes(i)) else write(outstr,'(2x,2a1,2x,i7,a2,i7,3x,a)') & typloc(ityp), cmp, outpos(i)+5, '--', outpos(i)+6, trim(locnotes(i)) end if else if (isspecial(loctyp(i))) then if (plevel > 0) then write(outstr, fmtstring, advance='no') loc(i) write(outstr,'(2x,a1,22x,a)') & typloc(ityp), trim(locnotes(i)) end if else write(outstr, fmtstring, advance='no') loc(i) if (locus_output_position == 1) then write(outstr,'(2x,a1,5x,i12,5x,a)') & typloc(ityp), i-ENVNUM, trim(get_notes0(loc(i), locnotes(i))) else write(outstr,'(2x,a1,3x,i7,12x,a)') & typloc(ityp), outpos(i)+5, trim(get_notes0(loc(i), locnotes(i))) end if end if if (irupt > 0) exit end do write(outstr,'(/a,i7,3(/a,3x,f8.6)/)') 'Number of marker loci= ',nmark, & 'Bonferroni corr. 5% = ',bonf(nmark,0.05D0), & 'Bonferroni corr. 1% = ',bonf(nmark,0.01D0), & 'Bonferroni corr. 0.1%= ',bonf(nmark,0.001D0) else do j=1, nshow i=locord(j) write(outstr,'(a)') trim(loc(i)) end do end if else if (typ == 2) then nmark=0 pos=0 do j=1, nshow i=locord(j) eon=len_trim(loc(i)) pos=pos+eon+1 if (isspecial(loctyp(i))) then if (plevel > 0) then pos=pos+2 call newlin(1,78,pos,eon+2) write(outstr,'(3a)', advance='no') '{',loc(i)(1:eon),'} ' end if else if (.not.isactive(loctyp(i))) then pos=pos+2 call newlin(1,78,pos,eon+2) write(outstr,'(3a)', advance='no') '(',loc(i)(1:eon),') ' else if (ismarker(loctyp(i))) then nmark=nmark+1 call newlin(1,78,pos,eon+2) write(outstr,'(2a)', advance='no') loc(i)(1:eon),' ' else ntrait=ntrait+1 pos=pos+1 call newlin(1,78,pos,eon+2) write(outstr,'(2a)', advance='no') loc(i)(1:eon),'* ' end if if (irupt > 0) exit end do if (plevel > -2) then write(outstr,'(/i0,a,i0,a)') & ntrait, ' active traits; ',nmark, ' active markers.' end if end if return end subroutine listloci ! ! Output counts of class of loci ! subroutine cntclasses(nloci, loctyp) use outstream use locus_types integer, intent(in) :: nloci integer, dimension(nloci), intent(in) :: loctyp integer :: i, types(6) types=0 do i=1, nloci if (same_loctyp(loctyp(i), LOC_CODOM)) then types(1)=types(1)+1 else if (same_loctyp(loctyp(i), LOC_XLIN)) then types(2)=types(2)+1 else if (same_loctyp(loctyp(i), LOC_QUA) .or. & same_loctyp(loctyp(i), LOC_CAT)) then types(3)=types(3)+1 else if (same_loctyp(loctyp(i), LOC_AFF)) then types(4)=types(4)+1 else if (ishaploid(loctyp(i)) .and. isactive(loctyp(i))) then types(5)=types(5)+1 else if (.not.isactive(loctyp(i))) then types(6)=types(6)+1 end if end do write(outstr,'(/a,i0)', advance='no') & 'mar: ', types(1) if (types(2) > 0) then write(outstr,'(a,i0)', advance='no') ' xma: ', types(2) end if if (types(5) > 0) then write(outstr,'(a,i0)', advance='no') ' hap: ', types(5) end if write(outstr,'(a,i0,a,i0)', advance='no') & ' qua: ', types(3), ' aff: ', types(4) if (types(6) > 0) then write(outstr,'(a,i0)', advance='no') ' dro: ', types(6) end if write(outstr,*) end subroutine cntclasses ! ! Count active codominant markers or active loci ! subroutine cntmark(nloci, loctyp, nmark, typ) use locus_types use automatic_data integer, intent(in) :: nloci integer, dimension(nloci), intent(in) :: loctyp integer, intent(out) :: nmark integer, intent(in) :: typ integer :: i nmark=0 if (typ == 1) then do i=ENVNUM+1, nloci if (isactdip(loctyp(i))) then nmark=nmark+1 end if end do else if (typ == 3) then do i=ENVNUM+1, nloci if (ismarker(loctyp(i)) .and. isactive(loctyp(i))) then nmark=nmark+1 end if end do else do i=ENVNUM+1, nloci if (isactive(loctyp(i))) nmark=nmark+1 end do end if end subroutine cntmark ! ! Find next active codominant marker in list ! function findmk(sta, fin, loctyp) use locus_types integer findmk integer, intent(in) :: sta integer, intent(in) :: fin integer, dimension(:), intent(in) :: loctyp integer, parameter :: MISS=-9999 integer :: i findmk=MISS i=sta do while (i <= fin) if (isactdip(loctyp(i))) then findmk=i exit end if i=i+1 end do end function findmk ! ! Find first codominant or haploid marker in list ! function findml(nord, locord, loctyp) use locus_types integer findml integer, intent(in) :: nord integer, dimension(:), intent(in) :: locord integer, dimension(:), intent(in out) :: loctyp integer, parameter :: MISS=-9999 integer :: i findml=MISS do i=1, nord if (ismarker(loctyp(locord(i))) .and. isactive(loctyp(locord(i)))) then findml=locord(i) exit end if end do end function findml ! ! produce next pair of markers from: ! 1. named pair 2. One named 3. map order 4. all pairs 10. empty ! subroutine ldlist(typ, loc1, loc2, nloci, loctyp, last) integer, intent(inout) :: typ integer, intent(out) :: loc1 integer, intent(out) :: loc2 integer, intent(in) :: nloci integer, dimension(:), intent(inout) :: loctyp logical, intent(out) :: last ! integer, parameter :: MISS=-9999 ! if (last) return ! if (typ == 1) then typ=10 else if (typ == 2) then if (loc2 == MISS) loc2=0 loc2=findmk(loc2+1, nloci, loctyp) if (loc2 == loc1) then loc2=findmk(loc2+1, nloci, loctyp) end if last=(loc2 == MISS) else if (typ == 3 .or. typ == 4) then loc1=findmk(1, nloci, loctyp) if (loc1 /= MISS) then loc2=findmk(loc1+1, nloci, loctyp) typ=typ+2 else loc2=MISS end if last=(loc2 == MISS) else if (typ == 5) then loc1=loc2 loc2=findmk(loc2+1, nloci, loctyp) last=(loc2 == MISS) else if (typ == 6) then loc2=findmk(loc2+1, nloci, loctyp) if (loc2 == MISS) then loc1=findmk(loc1+1, nloci, loctyp) last=(loc1 == MISS) if (.not.last) then loc2=findmk(loc1+1, nloci, loctyp) last=(loc2 == MISS) end if end if else last=.not.last end if return end subroutine ldlist end module locus_list ! ! Phenotype/genotype data storage classes are currently: ! SCLASS = i1 4-bit genotypes or 8-bit alleles ! GCLASS = i2 16-bit alleles ! PCLASS = r8 ! (TCLASS = any) ! Chunksize is the blocksize for reading/writing binary images, ! so as not to exceed LRECL or buffers ! module storage_classes integer, parameter :: NDATACLASS = 4 integer, parameter :: TCLASS = 4, SCLASS = 1, GCLASS = 2, PCLASS = 3 integer (kind=8), parameter :: chunksize = 268435456 end module storage_classes ! ! A container for large (dense) matrices that can keep them as ! random access files and buffer a subset of columns in memory ! module matrix_class use fileio ! default width of buffer submatrix integer, parameter :: DBUFWID = 2 ! largest allowable unformatted write to a file integer (kind=8), parameter :: CHUNKSIZE = 268435456 ! matrix size above which store to file rather than in memory integer (kind=8), parameter :: MATRIX_THRESH_SIZE = 0 integer (kind=8) :: mthresh = MATRIX_THRESH_SIZE integer :: matrix_number = 0 type matrix_i1 integer :: nrows = 0 integer :: ncols = 0 integer (kind=8) :: ncells = 0 integer :: isize = 1 integer :: typ = 0 ! integer :: thiscol = 0 integer :: bufwidth = 0 integer (kind=1), dimension(:,:), allocatable :: dta integer :: stream = 0 character (len=256) :: filnam = ' ' end type matrix_i1 ! public :: matrix_create, matrix_destroy, matrix_write, matrix_read, & ! matrix_active, matrix_copy, matrix_get_row, matrix_set_row, & ! matrix_get_col, matrix_set_col, & ! matrix_get_el, matrix_set_el contains ! ! Create a matrix container ! subroutine matrix_set_bufwidth(bufwidth) integer :: bufwidth #if THREADED integer :: nthreads, tid integer :: omp_get_num_threads, omp_get_thread_num !$OMP PARALLEL PRIVATE(TID) tid = omp_get_thread_num() if (tid == 0) then nthreads = omp_get_num_threads() bufwidth=2*nthreads end if !$OMP END PARALLEL #else bufwidth=DBUFWID #endif end subroutine matrix_set_bufwidth subroutine matrix_create(nr, nc, a, astat, setbufwidth) use rngs integer, intent(in) :: nc, nr type (matrix_i1) :: a integer, intent(out) :: astat integer, optional :: setbufwidth integer (kind=1), parameter :: zero = 0 integer :: i, ichunk, ios, bufwidth integer (kind=8) :: bigi, iblock character (len=5) :: prefix if (present(setbufwidth)) bufwidth=setbufwidth astat=0 matrix_number = matrix_number + 1 a%isize=1 a%ncells = int(nc, kind=8) * int(nr, kind=8) ! if small enough, store in memory if (a%ncells < mthresh .or. mthresh <= 0) then a%typ = 1 a%nrows = nr a%ncols = nc a%bufwidth = 0 if (allocated(a%dta)) deallocate(a%dta) allocate(a%dta(nr, nc), stat=astat) if (astat == 0) then a%dta=zero return end if end if return ! else stored in file a%typ = 2 a%nrows = nr a%ncols = nc call matrix_set_bufwidth(bufwidth) a%bufwidth = bufwidth allocate(a%dta(nr,bufwidth), stat=astat) a%dta=zero call uniqnam(5, prefix) write(a%filnam,'(a,i0)') 'sp-' // prefix // '_', matrix_number do call newlun(a%stream) open(a%stream, file=a%filnam, access=stream_access, & form=stream_form, iostat=ios) if (ios == 0) exit end do call matrix_zero(a) end subroutine matrix_create ! ! zero a matrix ! subroutine matrix_zero(a) type (matrix_i1) :: a integer (kind=1), parameter :: zero = 0 integer :: i, ichunk integer (kind=8) :: bigi, iblock if (a%typ == 1) then a%dta=zero else if (a%ncells <= CHUNKSIZE) then write(a%stream) (zero, bigi=1, a%ncells) else ichunk=int(a%ncells/CHUNKSIZE, kind=4) iblock=a%ncells/ichunk do i=1, ichunk write(a%stream) (zero, bigi=1, iblock) end do write(a%stream) (zero, bigi=(ichunk*iblock), a%ncells) end if end if end subroutine matrix_zero ! ! Copy a matrix container (a -> b) ! subroutine matrix_copy(a, b, iflag, newrows, rowfilter, & newcols, colfilter, setbufwidth) use rngs type (matrix_i1) :: a, b integer, intent(out) :: iflag integer, optional :: newrows integer, dimension(:), optional :: rowfilter integer, optional :: newcols integer, dimension(:), optional :: colfilter integer, optional :: setbufwidth integer (kind=1), parameter :: zero = 0 integer :: bufwidth, i, ios, j, nr, nc integer (kind=8) :: bigi character (len=5) :: prefix logical :: hasfilter integer, dimension(:), allocatable :: rfilter, cfilter hasfilter=.false. bufwidth=DBUFWID if (present(setbufwidth)) bufwidth=setbufwidth iflag=0 matrix_number = matrix_number + 1 nr = a%nrows nc = a%ncols if (present(newrows)) nr=newrows if (present(newcols)) nc=newcols allocate(rfilter(a%nrows)) do i=1, a%nrows rfilter(i)=i end do if (present(rowfilter)) then hasfilter=.true. rfilter=rowfilter end if allocate(cfilter(a%ncols)) do i=1, a%ncols cfilter(i)=i end do if (present(colfilter)) then hasfilter=.true. cfilter=colfilter end if b%ncells = int(nc, kind=8) * int(nr, kind=8) b%typ = 2 if (b%ncells < mthresh .or. mthresh <= 0) b%typ = 1 b%nrows = nr b%ncols = nc b%isize = a%isize if (b%typ == 1) then if (allocated(b%dta)) deallocate(b%dta) allocate(b%dta(b%nrows, b%ncols), stat=ios) ! if not successful in allocation, fall through if (ios == 0) then b%dta=zero if (a%ncells > 0) then if (a%typ == 1) then b%dta(rfilter, cfilter)=a%dta else rewind(a%stream) read(a%stream) b%dta(rfilter, cfilter) end if end if return end if end if ! stored as file if (hasfilter) then write(*,'(a)') 'FATAL: Do not support matrix as file with filtering!' stop end if if (allocated(b%dta)) deallocate(b%dta) allocate(b%dta(nr, bufwidth)) b%bufwidth=bufwidth b%dta=zero if (b%stream /= 0) then close(b%stream, status='delete') end if call uniqnam(5, prefix) write(b%filnam,'(a,i0)') 'sp-' // prefix // '_', matrix_number do call newlun(b%stream) open(b%stream, file=b%filnam, access=stream_access, & form=stream_form, iostat=ios) if (ios == 0) exit end do if (a%ncells > 0) then if (a%typ == 1) then write(b%stream) a%dta write(b%stream) (zero, bigi=a%ncells+1, b%ncells) else rewind(a%stream) do i=1, a%ncols read(a%stream) a%dta(1:a%nrows,1) write(b%stream) a%dta(1:a%nrows,1) end do write(b%stream) (zero, bigi=a%ncells+1, b%ncells) end if else call matrix_zero(b) end if end subroutine matrix_copy ! ! Destroy a matrix container ! subroutine matrix_destroy(a) type (matrix_i1) :: a if (allocated(a%dta)) deallocate(a%dta) if (a%typ == 2) then a%thiscol = 0 close(a%stream, status='delete') end if a%nrows = 0 a%ncols = 0 a%ncells = 0 a%isize = 0 a%typ = 0 a%stream = 0 a%filnam = ' ' end subroutine matrix_destroy ! ! Test if matrix allocated/active ! function matrix_active(a) logical :: matrix_active type (matrix_i1) :: a matrix_active=(a%typ /= 0) end function matrix_active ! ! Size of matrix in container ! function matrix_size(a) integer (kind=8) :: matrix_size type (matrix_i1) :: a if (a%typ /= 0) then matrix_size = int(a%isize, kind=8) * a%ncells else matrix_size = 0 end if end function matrix_size ! ! Number of matrix rows accessor ! function matrix_nrows(a) integer :: matrix_nrows type (matrix_i1) :: a matrix_nrows = 0 if (a%typ /= 0) matrix_nrows = a%nrows end function matrix_nrows ! ! Number of matrix cols accessor ! function matrix_ncols(a) integer :: matrix_ncols type (matrix_i1) :: a matrix_ncols = 0 if (a%typ /= 0) matrix_ncols = a%ncols end function matrix_ncols ! ! Matrix storage type ! function matrix_type(a) character (len=6) :: matrix_type character (len=6), dimension(2), parameter :: mtypes = (/ 'memory', 'file ' /) type (matrix_i1) :: a matrix_type = mtypes(a%typ) end function matrix_type ! ! Write a matrix ! subroutine matrix_write(a, stream, iflag) type (matrix_i1) :: a integer, intent(in) :: stream integer, intent(out) :: iflag integer :: fin, i, iblock, ichunk, sta iflag=0 write(stream) 'Matrix' write(stream) a%nrows, a%ncols, a%isize, a%bufwidth if (a%typ == 1) then if (a%ncells <= CHUNKSIZE) then write(stream, err=999) a%dta else iblock=int(CHUNKSIZE/a%nrows, kind=4) sta=1 do fin=min(sta+iblock-1, a%ncols) write(stream, err=999) a%dta(1:a%nrows,sta:fin) if (fin == a%ncols) exit sta=sta+iblock end do end if else if (a%typ == 2) then rewind(a%stream) do i=1, a%ncols read(a%stream, end=999, err=999) a%dta(:,1) write(stream) a%dta(:,1) end do end if return 999 continue write(*,'(a,i0)', advance='no') & 'ERROR: error writing matrix data typ=', a%typ if (a%typ == 2) then write(*,'(7x,a,i0,a,i0)') 'col=', i, ' of ', a%ncols else write(*,*) end if iflag=-3 return end subroutine matrix_write ! ! Write one row of a matrix to an open stream, ! needed by disjoin, nuclear etc ! subroutine matrix_write_row(irow, a, stream) integer, intent(in) :: irow type (matrix_i1), intent(in) :: a integer, intent(in) :: stream integer :: ios integer (kind=8) :: ipos integer (kind=1), dimension(a%ncols) :: onerow if (a%ncols == 0) return if (a%typ == 1) then write(stream) a%dta(irow,1:a%ncols) else if (a%typ == 2) then ipos=a%isize*(irow-1)+1 istride=a%isize*a%nrows do i=1, a%ncols read(a%stream, pos=ipos) onerow(i) ipos=ipos+istride end do write(stream) onerow end if end subroutine matrix_write_row ! ! Write selected elements of one row ! subroutine matrix_write_filtered_row(irow, a, ncols, cols, stream) integer, intent(in) :: irow type (matrix_i1), intent(in) :: a integer, intent(in) :: ncols integer, dimension(ncols), intent(in) :: cols integer, intent(in) :: stream integer :: i, ios integer (kind=8) :: basepos, ipos, istride integer (kind=1), dimension(ncols) :: onerow if (ncols == 0) return if (a%typ == 1) then do i=1, ncols onerow(i)=a%dta(irow, cols(i)) end do else if (a%typ == 2) then basepos=a%isize*(irow-1)+1 istride=a%isize*a%nrows do i=1, ncols ipos=basepos+istride*int(cols(i)-1, kind=8) read(a%stream, pos=ipos) onerow(i) end do end if write(stream) onerow end subroutine matrix_write_filtered_row ! ! Read a matrix ! subroutine matrix_read(stream, a, iflag) integer, intent(in) :: stream type (matrix_i1), intent(inout) :: a integer, intent(out) :: iflag integer :: fin, iblock, ichunk, ios, sta logical :: sopen character (len=6) :: filtyp iflag=0 matrix_number = matrix_number + 1 read(stream) filtyp if (filtyp /= 'Matrix') then write(*,'(a)') 'ERROR: Wrong file type for matrix_read!' iflag=-1 return end if read(stream) a%nrows, a%ncols, a%isize, a%bufwidth a%ncells=int(a%nrows, kind=8)*int(a%ncols, kind=8) call matrix_read_contents(stream, a, iflag) end subroutine matrix_read ! ! Fill a matrix container from a unformatted stream ! subroutine matrix_read_unformatted(stream, nr, nc, a, iflag) integer, intent(in) :: stream integer, intent(in) :: nc, nr type (matrix_i1), intent(inout) :: a integer, intent(out) :: iflag integer :: ios logical :: sopen character (len=6) :: filtyp iflag=0 matrix_number = matrix_number + 1 a%typ = 1 a%nrows=nr a%ncols=nc a%isize=1 call matrix_set_bufwidth(a%bufwidth) a%ncells = int(nc, kind=8) * int(nr, kind=8) call matrix_read_contents(stream, a, iflag) end subroutine matrix_read_unformatted ! ! Read in actual contents of matrix ! subroutine matrix_read_contents(stream, a, iflag) integer, intent(in) :: stream type (matrix_i1), intent(inout) :: a integer, intent(out) :: iflag integer :: fin, iblock, ichunk, ios, sta logical :: sopen character (len=6) :: filtyp iflag=0 ios=0 ! try and store in memory if (a%ncells < mthresh .or. mthresh <= 0) then a%typ = 1 if (.not.allocated(a%dta)) then allocate(a%dta(a%nrows, a%ncols), stat=ios) else if (size(a%dta,1) /= a%nrows .or. size(a%dta,2) /= a%ncols) then deallocate(a%dta) allocate(a%dta(a%nrows, a%ncols), stat=ios) end if if (ios == 0) then if (a%ncells <= CHUNKSIZE) then read(stream, err=999, end=999) a%dta else iblock=int(CHUNKSIZE/a%nrows, kind=4) sta=1 do fin=min(sta+iblock-1, a%ncols) read(stream, err=999, end=999) a%dta(1:a%nrows,sta:fin) if (fin == a%ncols) exit sta=sta+iblock end do end if return end if end if ! fall through to file storage iflag=-3 return a%typ = 2 a%thiscol = 0 call matrix_set_bufwidth(a%bufwidth) inquire(a%stream, opened=sopen) if (sopen) then close(a%stream, status='delete') end if if (allocated(a%dta)) deallocate(a%dta) allocate(a%dta(a%nrows, a%bufwidth), stat=ios) do call newlun(a%stream) open(a%stream, file=a%filnam, access=stream_access, & form=stream_form, iostat=ios) if (ios == 0) exit end do do i=1, a%ncols read(stream, err=999) a%dta(:,1) write(a%stream) a%dta(:,1) end do return ! read error 999 continue write(*,'(a)') 'ERROR: error reading matrix data.' iflag=-3 return end subroutine matrix_read_contents ! ! Read one row of a matrix from an open stream, ! was written row major by matrix_write_row ! subroutine matrix_read_row(stream, irow, a) integer, intent(in) :: stream integer, intent(in) :: irow type (matrix_i1), intent(in out) :: a integer :: i, ios, istride integer (kind=8) :: ipos integer (kind=1), dimension(a%ncols) :: onerow if (a%ncols == 0) return if (a%typ == 1) then read(stream) a%dta(irow,1:a%ncols) else if (a%typ == 2) then read(stream) onerow ipos=a%isize*(irow-1)+1 istride=a%isize*a%nrows do i=1, a%ncols write(a%stream, pos=ipos, err=999) onerow(i) ipos=ipos+istride end do end if return ! read error 999 continue write(*,'(a,i0,a,i0,a)') & 'ERROR: error reading matrix row ', irow, ' at col=', i, '.' iflag=-3 return end subroutine matrix_read_row ! ! Set row ! subroutine matrix_set_row(ivals, irow, a, iflag) integer (kind=1), dimension(:), intent(in) :: ivals integer, intent(in) :: irow type (matrix_i1) :: a integer, intent(out) :: iflag integer :: i, j, nelements integer (kind=8) :: ipos iflag=-1 if (a%typ == 0) return iflag=-2 if (irow < 1 .or. irow > a%nrows) return iflag=-3 nelements=size(ivals) if (nelements /= 1 .and. nelements /= a%ncols) return iflag=0 if (a%typ == 1) then if (nelements == 1) then do j=1, a%ncols a%dta(irow,j)=ivals(1) end do else if (nelements == a%ncols) then do j=1, a%ncols a%dta(irow,j)=ivals(j) end do end if else if (a%typ == 2) then ipos=a%isize*(irow-1)+1 istride=a%isize*a%nrows if (nelements == 1) then do i=1, a%ncols write(a%stream, pos=ipos, err=999) ivals(1) ipos=ipos+istride end do else if (nelements == a%ncols) then do i=1, a%ncols write(a%stream, pos=ipos, err=999) ivals(i) ipos=ipos+istride end do end if end if return ! read error 999 continue write(*,'(a,i0,a,i0,a)') & 'ERROR: error writing matrix row ', irow, ' at col=', i, '.' iflag=-3 return end subroutine matrix_set_row ! ! Get row ! subroutine matrix_get_row(a, irow, ivals, iflag) type (matrix_i1) :: a integer, intent(in) :: irow integer (kind=1), dimension(:), intent(out) :: ivals integer, intent(out) :: iflag integer :: i, j, nelements integer (kind=8) :: ipos ivals=0 iflag=-1 if (a%typ == 0) return iflag=-2 if (irow < 1 .or. irow > a%nrows) return iflag=0 nelements=min(a%ncols,size(ivals)) if (a%typ == 1) then do j=1, nelements ivals(j)=a%dta(irow,j) end do else if (a%typ == 2) then ipos=a%isize*(irow-1)+1 istride=a%isize*a%nrows do i=1, nelements read(a%stream, pos=ipos, end=999, err=999) ivals(i) ipos=ipos+istride end do end if return ! read error 999 continue write(*,'(a,i0,a,i0,a)') & 'ERROR: error reading matrix row ', irow, ' at col=', i, '.' iflag=-3 return end subroutine matrix_get_row ! ! Copy row ! subroutine matrix_copy_row(rowa, a, rowb, b, iflag) integer, intent(in) :: rowa, rowb type (matrix_i1), intent(in out) :: a, b integer, intent(out) :: iflag integer :: nelements integer (kind=1), dimension(:), allocatable :: onerow integer :: i, ipos, jpos, istride iflag=-1 if (a%typ == 0 .or. b%typ == 0) return iflag=-2 if (rowa < 1 .or. rowa > a%nrows .or. rowb < 1 .or. rowb > b%nrows) return nelements=min(a%ncols, b%ncols) if (a%typ == 1) then do i=1, nelements b%dta(rowb,i)=a%dta(rowa,i) end do else if (a%typ == 2) then allocate(onerow(nelements)) ipos=a%isize*(rowa-1)+1 jpos=b%isize*(rowb-1)+1 istride=a%isize*a%nrows do i=1, nelements read(a%stream,pos=ipos) onerow write(b%stream,pos=jpos) onerow ipos=ipos+istride jpos=jpos+istride end do end if end subroutine matrix_copy_row ! ! Set col ! subroutine matrix_set_col(ivals, icol, a, iflag) integer (kind=1), dimension(:), intent(in) :: ivals integer, intent(in) :: icol type (matrix_i1), intent(in out) :: a integer, intent(out) :: iflag integer :: nelements integer :: i, j, istride integer (kind=8) :: ipos iflag=-1 if (a%typ == 0) return iflag=-2 if (icol < 1 .or. icol > a%ncols) return iflag=-3 nelements=size(ivals) if (nelements /= 1 .and. nelements /= a%nrows) then write(*,*) 'Setting column icol of matrix, but nrows=', a%nrows, & ' and length of new data vector nelements=', nelements return end if iflag=0 if (a%typ == 1) then a%dta(:,icol) = ivals if (nelements == 1) then do i=1, a%nrows a%dta(i,icol)=ivals(1) end do else if (nelements == a%ncols) then do i=1, a%nrows a%dta(i,icol)=ivals(i) end do end if else if (a%typ == 2) then ipos=a%isize*a%nrows*int(icol-1, kind=8)+1 if (nelements == 1) then write(a%stream,pos=ipos) (ivals(1), i=1, a%nrows) if (icol >= a%thiscol .and. icol <= (a%thiscol+a%bufwidth-1)) then do i=1, a%nrows a%dta(i,icol-a%thiscol+1) = ivals(1) end do end if else if (nelements == a%nrows) then write(a%stream,pos=ipos) ivals if (icol >= a%thiscol .and. icol <= (a%thiscol+a%bufwidth-1)) then a%dta(:,icol-a%thiscol+1) = ivals end if end if end if end subroutine matrix_set_col ! ! Get col: updates column buffer ! subroutine matrix_get_col(a, icol, ivals, iflag) type (matrix_i1), intent(in out) :: a integer, intent(in) :: icol integer (kind=1), dimension(:), intent(out) :: ivals integer, intent(out) :: iflag integer :: nelements integer :: thiscol integer (kind=8) :: ipos iflag=-1 if (a%typ == 0) return iflag=-2 if (icol < 1 .or. icol > a%ncols) return iflag=0 nelements=min(a%nrows, size(ivals)) if (a%typ == 1) then ! ivals(1:nelements)=a%dta(1:nelements,icol) ivals=a%dta(:,icol) else if (a%typ == 2) then if (icol < a%thiscol .or. icol > (a%thiscol+a%bufwidth-1)) then thiscol=min(icol, a%ncols-a%bufwidth+1) ipos=a%isize*a%nrows*int(thiscol-1,kind=8)+1 read(a%stream, pos=ipos, err=999) a%dta a%thiscol=thiscol end if ivals(1:nelements)=a%dta(1:nelements,icol-a%thiscol+1) end if return 999 continue write(*,'(a,i0/7x,a,i0,1x,i0)') & 'ERROR: error reading matrix column ', icol, & 'from matrix size ', a%nrows, a%ncols iflag=-3 return end subroutine matrix_get_col ! ! Set element: updates column buffer as well if current ! subroutine matrix_set_el(ival, irow, icol, a, iflag) integer (kind=1), intent(in) :: ival integer, intent(in) :: irow integer, intent(in) :: icol type (matrix_i1) :: a integer, intent(out) :: iflag integer (kind=8) :: ipos iflag=-1 if (a%typ == 0) return iflag=-2 if (irow < 1 .or. irow > a%nrows .or. icol < 1 .or. icol > a%ncols) return iflag=0 if (a%typ == 1) then a%dta(irow,icol) = ival else if (a%typ == 2) then if (icol >= a%thiscol .and. icol <= (a%thiscol+a%bufwidth-1)) then a%dta(irow,icol-a%thiscol+1) = ival end if ipos=a%isize*(int(a%nrows, kind=8)*int(icol-1,kind=8)+(irow-1))+1 write(a%stream,pos=ipos) ival end if end subroutine matrix_set_el ! ! Get element: updates column buffer ! subroutine matrix_get_el(irow, icol, a, ival, iflag) integer, intent(in) :: irow integer, intent(in) :: icol type (matrix_i1) :: a integer (kind=1), intent(out) :: ival integer, intent(out) :: iflag integer :: thiscol integer (kind=8) :: ipos ! iflag=-1 ! if (a%typ == 0) return ! iflag=-2 ! if (irow < 1 .or. irow > a%nrows .or. icol < 1 .or. icol > a%ncols) return iflag=0 if (a%typ == 1) then ival = a%dta(irow,icol) else if (a%typ == 2) then if (icol < a%thiscol .or. icol > (a%thiscol+a%bufwidth-1)) then thiscol=min(icol, a%ncols-a%bufwidth+1) ipos=a%isize*a%nrows*int(thiscol-1, kind=8)+1 read(a%stream, pos=ipos, err=999) a%dta a%thiscol=thiscol ! write(*,*) 'matrix_get_el ', irow, icol, ival ! write(*,*) 'thiscol=', a%thiscol, ' bufwidth=', a%bufwidth ! call matrix_print(a) end if ival=a%dta(irow,icol-a%thiscol+1) ! write(*,*) 'matrix_get_el ', irow, icol, ival end if return 999 continue write(*,'(a,i0,1x,i0/7x,a,i0,1x,i0)') & 'ERROR: error reading matrix element ', irow, icol, & 'from matrix size ', a%nrows, a%ncols write(*,*) 'thiscol=', a%thiscol, ' bufwidth=', a%bufwidth call matrix_print(a) iflag=-3 stop return end subroutine matrix_get_el ! ! Print matrix ! subroutine matrix_print(a) type (matrix_i1) :: a integer :: i, j, n integer (kind=1), dimension(:), allocatable :: onerow character (len=6), dimension(2) :: stype = (/'memory', 'file '/) if (a%typ == 0) then write(*,'(/a)') 'Empty matrix!' return end if write(*,*) write(*,'(3(a,i0),2a)') 'nrows=', a%nrows, ' ncols=', a%ncols, & ' kind=', a%isize, ' storage_type=', stype(a%typ) write(*,*) if (a%typ == 1) then do i=1, min(10,a%nrows) write(*,'(i4,a,15(1x,i0):)') i, ': ', (a%dta(i,j), j=1, min(15,a%ncols)) end do else if (a%typ == 2) then write(*,'(3a)') 'Filename="', trim(a%filnam), '"' allocate(onerow(min(15, a%ncols))) write(*,'(a,i0,a,i0)') 'read buffer is ', a%nrows, ' x ', a%bufwidth rewind(a%stream) do i=1, min(10,a%nrows) call matrix_get_row(a, i, onerow, iflag) write(*,'(i4,a,15(1x,i0):)') i, ': ', (onerow(j), j=1, min(15,a%ncols)) end do end if end subroutine matrix_print end module matrix_class ! ! Simple symmetric matrix operations ! module symmetric_matrix contains ! ! print n rows of symmetric lower triangular matrix ! subroutine printmat(n, c, fstring) use outstream integer, intent(in) :: n double precision, dimension(:), intent(in) :: c character(*), intent(in) :: fstring integer :: i, pos pos=0 do i=1, n write(outstr,fstring) c((pos+1):(pos+i)) pos=pos+i end do end subroutine printmat ! ! print entire symmetric matrix ! subroutine printmat_full(n, c) use outstream integer, intent(in) :: n double precision, dimension(:), intent(in) :: c integer :: i, j, k, pos pos=0 do i=1, n write(outstr,'(f6.4)', advance='no') c(pos+1) do j=2, i-1 write(outstr,'(1x,f6.4)', advance='no') c(pos+j) end do k=pos do j=i, n write(outstr,'(1x,f6.4)', advance='no') c(k+i) k=k+j end do write(outstr,*) pos=pos+i end do end subroutine printmat_full ! ! hash code for a matrix - after the Java equivalent ! function hashmat(n, c) character (len=16) hashmat integer, intent(in) :: n double precision, dimension(:), intent(in) :: c integer (kind=8) :: bits, h h=123456789 do i=1, n bits = transfer(c(i), bits) h = h * 31 + ieor(bits, ishft(bits, -32)) end do write(hashmat,'(z16)') h end function hashmat ! ! Evaluate S T ! where S is symmetric lower triangular matrix ! T is symmetric lower triangular matrix ! subroutine multsym(n, x, y, w) integer, intent(in) :: n double precision, dimension(:), intent(in) :: x double precision, dimension(:), intent(in) :: y double precision, dimension(:,:), intent(out) :: w integer :: i, ic, j, pos, k integer :: clcpos double precision :: cell do ic=1, n pos=0 do i=1, n cell=0.0d0 do j=1, i-1 cell=cell+y(clcpos(j,ic))*x(pos+j) end do k=pos do j=i, n cell=cell+y(clcpos(j,ic))*x(k+i) k=k+j end do w(i,ic)=cell pos=pos+i end do end do end subroutine multsym ! ! Evaluate S x ! where S is symmetric lower triangular matrix ! x is a vector ! subroutine postmult(n, x, c, w) integer, intent(in) :: n double precision, dimension(:), intent(in) :: x double precision, dimension(:), intent(in) :: c double precision, dimension(:), intent(out) :: w integer :: i, j, pos, k pos=0 do i=1, n w(i)=0.0D0 do j=1, i-1 w(i)=w(i)+x(j)*c(pos+j) end do k=pos do j=i, n w(i)=w(i)+x(j)*c(k+i) k=k+j end do pos=pos+i end do end subroutine postmult ! ! Evaluate S X ! where S is symmetric lower triangular matrix ! X is a full n*m matrix ! result is full n*m matrix ! subroutine postmultm(n, m, x, c, w) integer, intent(in) :: n, m double precision, dimension(:,:), intent(in) :: x double precision, dimension(:), intent(in) :: c double precision, dimension(:,:), intent(out) :: w integer :: i, ic, j, pos, k double precision :: cell do ic=1, m pos=0 do i=1, n cell=0.0d0 do j=1, i-1 cell=cell+x(j,ic)*c(pos+j) end do k=pos do j=i, n cell=cell+x(j,ic)*c(k+i) k=k+j end do w(i,ic)=cell pos=pos+i end do end do end subroutine postmultm ! ! Evaluate 1' S 1 ! where S is symmetric lower triangular matrix ! subroutine sumsym(n, c, res) integer, intent(in) :: n double precision, dimension(:), intent(in) :: c double precision, intent(out) :: res integer :: i, j, pos res=0.0D0 pos=0 do i=1, n do j=1, i-1 pos=pos+1 res=res+2*c(pos) end do pos=pos+1 res=res+c(pos) end do end subroutine sumsym ! ! Evaluate (typ=1) x' S x or (typ=2) 1' S x ! where S is symmetric lower triangular matrix ! subroutine quadmult(typ, n, x, c, res) integer, intent(in) :: typ integer, intent(in) :: n double precision, dimension(:), intent(in) :: x double precision, dimension(:), intent(in) :: c double precision, intent(out) :: res double precision, dimension(n) :: w integer :: i call postmult(n, x, c, w) res=0.0D0 if (typ == 1) then do i=1, n res=res+w(i)*x(i) end do else do i=1, n res=res+w(i) end do end if end subroutine quadmult ! ! Evaluate X' S X ! where S is symmetric lower triangular matrix ! X n*m matrix ! result returned in lower triangular form ! subroutine quadxxm(n, m, x, c, res) integer, intent(in) :: n, m double precision, dimension(:,:), intent(in) :: x double precision, dimension(:), intent(in) :: c double precision, dimension(:), intent(out) :: res integer :: i, j, k, pos double precision, dimension(n,m) :: w call postmultm(n, m, x, c, w) pos=0 do i=1, m do j=i, m pos=pos+1 res(pos)=0.0d0 do k=1, n res(pos)=res(pos)+w(k,i)*x(k,j) end do end do end do end subroutine quadxxm ! ! Evaluate x' S y ! where S is symmetric lower triangular matrix ! x, y are 1-D arrays ! subroutine quadxy(n, x, c, y, res) integer, intent(in) :: n double precision, dimension(:), intent(in) :: x double precision, dimension(:), intent(in) :: c double precision, dimension(:), intent(in) :: y double precision, intent(out) :: res double precision, dimension(n) :: w integer :: i, j, pos, k call postmult(n, x, c, w) res=0.0D0 do i=1, n res=res+w(i)*y(i) end do end subroutine quadxy ! ! Evaluate X' S y ! where S is symmetric lower triangular matrix ! X full n*m matrix, y n-vector ! subroutine quadxymv(n, m, x, c, y, res) integer, intent(in) :: n, m double precision, dimension(:,:), intent(in) :: x double precision, dimension(:), intent(in) :: c double precision, dimension(:), intent(in) :: y double precision, dimension(:), intent(out) :: res double precision, dimension(n) :: w call postmult(n, y, c, w) do j=1, m res(j)=0.0d0 do i=1, n res(j)=res(j)+w(i)*x(i,j) end do end do end subroutine quadxymv ! ! Evaluate X' S Y ! where S is symmetric lower triangular matrix ! X, Y full n*m1,n*m2 matrices ! subroutine quadxym(n, m1, m2, x, c, y, res) integer, intent(in) :: n, m1, m2 double precision, dimension(:,:), intent(in) :: x double precision, dimension(:), intent(in) :: c double precision, dimension(:,:), intent(in) :: y double precision, dimension(:,:), intent(out) :: res double precision, dimension(n,m2) :: w call postmultm(n, m2, y, c, w) res=matmul(transpose(x(1:n,1:m1)), w) end subroutine quadxym ! ! Evaluate 1' S Y ! where S is symmetric lower triangular matrix ! Y full n*m matrix ! subroutine quadxy1(n, m, c, y, res) integer, intent(in) :: n, m double precision, dimension(:), intent(in) :: c double precision, dimension(:,:), intent(in) :: y double precision, dimension(:), intent(out) :: res double precision, dimension(n,m) :: w call postmultm(n, m, y, c, w) do j=1, m res(j)=0.0d0 do i=1, n res(j)=res(j)+w(i,j) end do end do end subroutine quadxy1 ! ! Evaluate (y-m)' S (y-m) where S is symmetric lower triangular matrix ! subroutine quadform(n, x, m, c, res) integer, intent(in) :: n double precision, dimension(:), intent(in) :: x double precision, dimension(:), intent(in) :: m double precision, dimension(:), intent(in) :: c double precision, intent(out) :: res integer :: i double precision, dimension(n) :: w do i=1, n w(i)=x(i)-m(i) end do call quadmult(1, n, w, c, res) end subroutine quadform ! ! Choleski decomposition of a symmetric matrix stored as lower triangular ! subroutine chol(a, n, nn, u, nullty, ifault) double precision, intent(in) :: a(nn) integer, intent(in) :: n integer, intent(in out) :: nn double precision, intent(in out) :: u(nn) integer, intent(out) :: nullty integer, intent(out) :: ifault double precision :: eta, eta2, x, w, zero, zabs, zsqrt data eta,zero /1.0d-15, 0.0d0/ zabs(x)=abs(x) zsqrt(x)=sqrt(x) ifault=1 if (n <= 0) return ifault=3 if (nn /= n*(n+1)/2) return ifault=2 nullty=0 j=1 k=0 eta2=eta*eta i1=0 do icol=1,n i1=i1+icol x=eta2*a(i1) l=0 kk=0 do irow=1,icol kk=kk+irow k=k+1 w=a(k) m=j do i=1,irow l=l+1 if (i == irow) exit w=w-u(l)*u(m) m=m+1 end do if (irow == icol) exit if (u(l) == zero) go to 30 u(k)=w/u(l) cycle 30 if(w*w > zabs(x*a(kk))) return u(k)=zero end do 50 if (zabs(w) <= zabs(eta*a(k))) go to 60 if (w < zero) return u(k)=zsqrt(w) go to 70 60 u(k)=zero nullty=nullty+1 70 j=j+icol end do ifault=0 return end subroutine chol ! ! Evaluate S y, where S is lower triangular ! subroutine lowermult(n, y, s, w) integer, intent(in) :: n double precision, intent(in) :: y(n) double precision, intent(in out) :: s(n*(n+1)/2) double precision, intent(out) :: w(n) integer :: i, j, pos pos=0 do i=1, n w(i)=0.0D0 do j=1, i w(i)=w(i)+y(j)*s(pos+j) end do pos=pos+i end do end subroutine lowermult ! ! Augment main diagonal of symmetric matrix by factor ! subroutine addridge(n, s, m) integer, intent(in) :: n double precision, intent(in out) :: s(n*(n+1)/2) double precision, intent(in) :: m integer :: i, pos pos=0 do i=1, n pos=pos+i s(pos)=m*s(pos) end do end subroutine addridge end module symmetric_matrix ! ! tabix position index ! module tabixtools use idhash_class implicit none ! ! tabix or tribble (?) index file: ! ! magic Magic string char[4] TBI\1 ! n_ref # sequences int32_t ! format Format (0: generic; 1: SAM; 2: VCF) int32_t ! col_seq Column for the sequence name int32_t ! col_beg Column for the start of a region int32_t ! col_end Column for the end of a region int32_t ! meta Leading character for comment lines int32_t ! skip # lines to skip at the beginning int32_t ! l_nm Length of concatenated sequence names int32_t ! names Concatenated names, each zero terminated char[l_nm] ! List of indices (n=n_ref) ! n_bin # distinct bins (for the binning index) int32_t ! List of distinct bins (n=n_bin) ! bin Distinct bin number uint32_t ! n_chunk # chunks int32_t ! List of chunks (n=n chunk) ! cnk_beg Virtual file offset of the start of the chunk uint64_t ! cnk_end Virtual file offset of the end of the chunk uint64_t ! n_intv # 16kb intervals (for the linear index) int32_t ! List of distinct intervals (n=n_intv) ! ioff File offset of the first record in the interval uint64_t ! n_no_coor (optional) # unmapped reads without coordinates set uint64_t ! ! Note that the virtual offset is an unsigned 64 bit integer which combines ! a 48 bit block start offset and a 16 bit within block offset. ! type, public :: tbi_chunk integer(kind=8), dimension(:), allocatable :: cnk_beg, cnk_end end type tbi_chunk ! type, public :: tbi_indices integer :: nbin, nintv integer, dimension(:), allocatable :: bin_number, nchunks type (hash_table) :: binhash type(tbi_chunk), dimension(:), allocatable :: chunks integer(kind=8), dimension(:), allocatable :: ioff end type tbi_indices ! type, public :: tbi_structure integer :: state = 0 character (len=256) :: filnam = ' ' integer :: nref = 0 integer :: ftyp = 0, col_seq = 0, col_beg = 0, col_end = 0, skip = 0 character (len=1) :: meta = ' ' type (hash_table) :: seqhash character (len=80), dimension(:), allocatable :: chrom type(tbi_indices), dimension(:), allocatable :: bins integer (kind=8) :: n_no_coor = 0 end type tbi_structure integer, dimension(4), parameter :: tbi_magic_number = (/ 84, 66, 73, 1 /) character (len=7), dimension(8), parameter :: tbi_fields = (/ & 'n_ref ', 'format ', 'col_seq', 'col_beg', 'col_end', & 'meta ', 'skip ', 'l_nm ' /) character (len=7), dimension(0:2), parameter :: tbi_file_type = (/ & 'Generic', 'SAM ', 'VCF ' /) type (tbi_structure) :: tbi_index contains subroutine setup_tbi(tbi_index) type (tbi_structure) :: tbi_index integer :: seq, i, j call cleanup_hash(tbi_index%seqhash) do seq=1, tbi_index%nref do i=1, tbi_index%bins(seq)%nbin deallocate(tbi_index%bins(seq)%chunks(i)%cnk_beg, & tbi_index%bins(seq)%chunks(i)%cnk_end) end do deallocate(tbi_index%bins(seq)%ioff, & tbi_index%bins(seq)%bin_number, & tbi_index%bins(seq)%nchunks, & tbi_index%bins(seq)%chunks) call cleanup_hash(tbi_index%bins(seq)%binhash) end do if (tbi_index%nref > 0) then deallocate(tbi_index%chrom, tbi_index%bins) tbi_index%nref=0 end if tbi_index%state=0 tbi_index%filnam=' ' tbi_index%ftyp=0 tbi_index%col_seq=0 tbi_index%col_end=0 tbi_index%meta=' ' tbi_index%skip=0 tbi_index%n_no_coor=0 end subroutine setup_tbi ! subroutine read_tbi(filnam, tbi_index, istat) use interrupt use iobuff use outstream use fileio character (len=*), intent(in) :: filnam type (tbi_structure) :: tbi_index integer, intent(out) :: istat type (ioport) :: port integer :: i, ich, ioerr, j, nbins, nchar, nchunks, nref, seq integer (kind=8) :: cnk_beg, cnk_end, ioff character (len=1) :: ch character (len=80), dimension(:), allocatable :: chrom istat=-1 nchar=len_trim(filnam) if (filnam((nchar-3):nchar) == '.tbi') then call fgz_open(filnam, 'rb', port, ioerr) else call fgz_open(filnam // '.tbi', 'rb', port, ioerr) end if if (ioerr /= 0) then write(outstr,'(/3a)') & 'ERROR: Could not open index file "', trim(filnam),'".' return end if #if ZLIB do i=1, 4 ich=gzgetc(port%handle) if (ich == -1) exit if (tbi_magic_number(i) /= ich) then ich=-2 exit end if end do if (ich < 0) then write(outstr,'(/3a)') & 'ERROR: file "', trim(port%filnam),'" is not a tabix index file.' call close_port(port, ioerr) return else write(outstr,'(/3a)') 'Reading tabix index file "', trim(port%filnam),'".' end if ! safe to start reading call setup_tbi(tbi_index) istat=0 tbi_index%filnam=port%filnam tbi_index%nref=0 call fgz_read_integer(port, ich, ioerr) if (ioerr /= 0) goto 999 nref=ich tbi_index%nref=ich call fgz_read_integer(port, ich, ioerr) if (ioerr /= 0) goto 999 tbi_index%ftyp=ich call fgz_read_integer(port, ich, ioerr) if (ioerr /= 0) goto 999 tbi_index%col_seq=ich call fgz_read_integer(port, ich, ioerr) if (ioerr /= 0) goto 999 tbi_index%col_beg=ich call fgz_read_integer(port, ich, ioerr) if (ioerr /= 0) goto 999 tbi_index%col_end=ich call fgz_read_integer(port, ich, ioerr) if (ioerr /= 0) goto 999 tbi_index%meta=achar(ich) call fgz_read_integer(port, ich, ioerr) if (ioerr /= 0) goto 999 tbi_index%skip=ich call fgz_read_integer(port, ich, ioerr) if (ioerr /= 0) goto 999 nchar=ich allocate(tbi_index%bins(nref)) ! each chromosome/sequence name allocate(tbi_index%chrom(nref)) tbi_index%chrom=' ' call setup_hash(HK_CHROM, nref, tbi_index%seqhash, 90) seq=1 j=0 do i=1, nchar ich=gzgetc(port%handle) if (ich > 0) then j=j+1 tbi_index%chrom(seq)(j:j)=achar(ich) else seq=seq+1 j=0 end if end do call fill_hash(tbi_index%seqhash, tbi_index%chrom) ! each sequence do seq=1, nref tbi_index%bins(seq)%nbin=0 tbi_index%bins(seq)%nintv=0 call fgz_read_integer(port, nbins, ioerr) if (ioerr == 0) then tbi_index%bins(seq)%nbin = nbins allocate(tbi_index%bins(seq)%bin_number(nbins), & tbi_index%bins(seq)%nchunks(nbins), & tbi_index%bins(seq)%chunks(nbins)) call setup_hash(HK_INT, nbins, tbi_index%bins(seq)%binhash, 90) ! bins do i=1, nbins call fgz_read_integer(port, ich, ioerr) if (ioerr /= 0) goto 999 tbi_index%bins(seq)%bin_number(i)=ich call fgz_read_integer(port, ich, ioerr) if (ioerr /= 0) goto 999 nchunks=ich tbi_index%bins(seq)%nchunks(i)=ich allocate(tbi_index%bins(seq)%chunks(i)%cnk_beg(nchunks), & tbi_index%bins(seq)%chunks(i)%cnk_end(nchunks)) tbi_index%bins(seq)%chunks(i)%cnk_beg = 0 tbi_index%bins(seq)%chunks(i)%cnk_end = 0 do j=1, nchunks call fgz_read_longint(port, tbi_index%bins(seq)%chunks(i)%cnk_beg(j), ioerr) if (ioerr /= 0) goto 999 call fgz_read_longint(port, tbi_index%bins(seq)%chunks(i)%cnk_end(j), ioerr) if (ioerr /= 0) goto 999 end do end do call fill_hash_int(tbi_index%bins(seq)%binhash, tbi_index%bins(seq)%bin_number) ! sequential 16K intervals call fgz_read_integer(port, ich, ioerr) tbi_index%bins(seq)%nintv=ich nbins=ich allocate(tbi_index%bins(seq)%ioff(nbins)) tbi_index%bins(seq)%ioff = 0 do i=1, nbins call fgz_read_longint(port, ioff, ioerr) if (ioerr /= 0) goto 999 tbi_index%bins(seq)%ioff(i)=ioff end do end if end do call fgz_read_longint(port, ioff, ioerr) if (ioerr == 0) then tbi_index%n_no_coor=ioff end if tbi_index%state=1 call fgz_error(port) #endif call close_port(port, ioerr) return 999 continue istat=-2 call close_port(port, ioerr) call setup_tbi(tbi_index) end subroutine read_tbi ! ! Test if matching tbi file available ! subroutine load_tbi(filnam, tbi_index, has_tbi) use outstream character (len=*), intent(in) :: filnam type (tbi_structure) :: tbi_index logical, intent(out) :: has_tbi integer :: stat logical :: tbi_exist stat=-99 has_tbi=.false. if (tbi_index%state > 0) then if (filnam == tbi_index%filnam(1:(len_trim(tbi_index%filnam)-4))) then has_tbi=.true. end if end if if (.not.has_tbi) then inquire(file=trim(filnam) // '.tbi', exist=tbi_exist) if (tbi_exist) then call read_tbi(trim(filnam), tbi_index, stat) if (stat == 0) has_tbi=.true. end if end if if (.not.has_tbi) then write(outstr,'(/3a)') 'No tabix index file for "', trim(filnam), '".' end if end subroutine load_tbi ! ! Summarize current tabix indices ! subroutine show_tbi(tbi_index, plevel) use interrupt use iobuff use outstream use scanner use fileio type (tbi_structure) :: tbi_index integer, intent(in) :: plevel type (ioport) :: port integer :: ferr, i, ioerr, j, nend, nintv, nref, seq integer (kind=8) :: bpos1, bpos2, boff1, boff2, pos character (len=64) :: slin character (len=20) :: chrom, coord, word if (tbi_index%state == 0) then write(outstr,'(a)') 'No tabix index available.' return end if nend=len_trim(tbi_index%filnam)-4 call open_port(tbi_index%filnam(1:nend), port, 'r', ferr) if (plevel > 0) then write(outstr,'(3a/2a)') 'File indexed : "', tbi_index%filnam(1:nend), '"', & 'File type : ', tbi_file_type(tbi_index%ftyp) if (ferr /= 0) then write(outstr,'(3a)') 'File access : Unable to open "', & tbi_index%filnam(1:nend), '"' else if (port%filtyp == PORT_BGZIPPED) then write(outstr,'(a)') 'File compression: bgzip' else if (port%filtyp == PORT_GZIPPED) then write(outstr,'(a)') 'File compression: ordinary gzip' else write(outstr,'(a)') 'File access : not bgzipped' end if end if if (tbi_index%col_seq > 0) then write(outstr,'(a,i0)') 'Sequence column : ', tbi_index%col_seq write(outstr,'(a,i0,a,i0)') 'Coordinates cols: ', tbi_index%col_beg, & ' -- ', tbi_index%col_end write(outstr,'(3a)') 'Comment char : "', tbi_index%meta, '"' write(outstr,'(a,i0)') 'Skip 1st N lines: ', tbi_index%skip end if if (tbi_index%n_no_coor > 0) then write(outstr,'(a,i0)') 'Without coords : ', tbi_index%n_no_coor end if end if nref=tbi_index%nref write(outstr,'(/a,4x)', advance='no') 'Sequence' if (plevel > 0) write(outstr,'(a)', advance='no') ' N_bins N_intervals' write(outstr,'(a/a)', advance='no')' Coordinates', repeat('-',12) if (plevel > 0) write(outstr,'(1x,a,1x,a)', advance='no') repeat('-',8), repeat('-',11) #if ZLIB write(outstr,'(2x,a)') repeat('-',24) do seq=1, nref write(outstr,'(a12)', advance='no') tbi_index%chrom(seq) if (plevel > 0) then write(outstr,'(i9,i12)', advance='no') & tbi_index%bins(seq)%nbin, & tbi_index%bins(seq)%nintv end if if (ferr == 0) then nintv=tbi_index%bins(seq)%nintv i=1 pos=tbi_index%bins(seq)%ioff(1) do while (pos == 0 .and. i < nintv) i=i+1 pos=tbi_index%bins(seq)%ioff(i) end do call tbi_virpos(pos, bpos1, boff1) i=nintv pos=tbi_index%bins(seq)%ioff(nintv) do while (pos == 0 .and. i > 1) i=i-1 pos=tbi_index%bins(seq)%ioff(i) end do if (pos == 0) pos=tbi_index%bins(seq)%ioff(max(1,nintv-1)) call tbi_virpos(pos, bpos2, boff2) call bgzf_seek(port, bpos1, boff1, ioerr) if (ioerr == 0) then pos=port_position(port) call readline(port, slin, ios=ioerr) call getword(slin, 1, chrom) write(outstr,'(3x,2a)', advance='no') trim(chrom), ':' call getword(slin, 2, coord) write(outstr,'(a)', advance='no') trim(coord) call bgzf_seek(port, bpos2, boff2, ioerr) if (ioerr == 0) then do call readline(port, slin, ios=ioerr) if (ioerr /= 0) exit call getword(slin, 1, word) if (word /= chrom) exit call getword(slin, 2, coord) end do write(outstr,'(2a)') ' -- ', trim(coord) else write(outstr,*) end if else write(outstr,*) 'ioerr=', ioerr end if else write(outstr,*) end if end do #endif call close_port(port, ioerr) if (plevel > 2) then do seq=1, nref write(outstr,'(/3a)') 'Sequence "', trim(tbi_index%chrom(seq)), '"' do i=1, tbi_index%bins(seq)%nbin write(outstr,'(a,1x,i0,1x,i0)') '+-Bin ', i, tbi_index%bins(seq)%bin_number(i) write(outstr,'(a,i0)') '| +--n_chunk ', tbi_index%bins(seq)%nchunks(i) do j=1, tbi_index%bins(seq)%nchunks(i) call tbi_virpos(tbi_index%bins(seq)%chunks(i)%cnk_beg(j), bpos1, boff1) call tbi_virpos(tbi_index%bins(seq)%chunks(i)%cnk_end(j), bpos2, boff2) write(outstr,'(8x,5(a,i0),a)') & 'chunk ', j, ': ', bpos1, ' (', boff1, ') -- ', bpos2, ' (', boff2, ')' if (irupt > 0) return end do end do write(outstr,*) do i=1, tbi_index%bins(seq)%nintv call tbi_virpos(tbi_index%bins(seq)%ioff(i), bpos1, boff1) write(outstr,'(a8,3(a,i0),a)') & tbi_index%chrom(seq) ,' 16K interval ', i, ': ', bpos1, ' (', boff1, ')' if (irupt > 0) return end do end do end if end subroutine show_tbi ! ! tabix "virtual position" ! subroutine tbi_virpos(pos, bpos, boff) integer (kind=8), intent(in) :: pos integer (kind=8), intent(out) :: bpos, boff bpos=ibits(pos, 16, 48)+1 boff=ibits(pos, 0, 16)+1 end subroutine tbi_virpos ! ! tabix index bin corresponding to region ! after the C example code by Heng Li ! function reg2bin(sta, fin1) integer :: reg2bin integer, intent(in) :: sta, fin1 integer :: fin reg2bin=0 fin=fin1-1 if (ishft(sta, -14) == ishft(fin,-14)) then reg2bin=(ishft(1,15)-1)/7 + ishft(sta,-14) else if (ishft(sta,-17) == ishft(fin,-17)) then reg2bin=(ishft(1,12)-1)/7 + ishft(sta,-17) else if (ishft(sta,-20) == ishft(fin,-20)) then reg2bin=(ishft(1,9)-1)/7 + ishft(sta,-20) else if (ishft(sta,-23) == ishft(fin,-23)) then reg2bin=(ishft(1,6)-1)/7 + ishft(sta,-23) else if (ishft(sta,-26) == ishft(fin,-26)) then reg2bin=(ishft(1,3)-1)/7 + ishft(sta,-26) end if end function reg2bin ! ! Search indexed file ! subroutine search_tbi(tbi_index, coordinates, typ) use interrupt use iobuff use outstream use scanner use fileio type (tbi_structure) :: tbi_index character(len=*), intent(in) :: coordinates integer, intent(in) :: typ type (ioport) :: port integer :: bin_id, bin_idx, bp, eol, i, ioerr, j, k, n, nend, & pos_info, sep, seq_idx, spos, stat logical :: fnd character(len=20000) :: slin character (len=16384) :: locinfo character(len=512) :: word integer(kind=8) :: boff, bpos, pos ! functions integer :: ival spos=index(coordinates, ':') if (spos == 0) then write(outstr,'(a)') 'Expected chr:pos' return end if pos_info=8 call find_hashtab(trim(coordinates(1:(spos-1))), tbi_index%chrom, & tbi_index%seqhash, seq_idx) if (seq_idx == 0) then write(outstr,'(3a)') 'ERROR: Sequence ', trim(coordinates(1:(spos-1))), ' not in index!' return end if ! avoid read overflow as treated as unsigned in reg2bin read(coordinates((spos+1):),'(i40)') pos bp=int(pos, kind=4) bin_id=reg2bin(bp, bp) call find_hashtab_int(bin_id, tbi_index%bins(seq_idx)%bin_number, & tbi_index%bins(seq_idx)%binhash, bin_idx) if (bin_idx == 0) bin_idx=1 nend=len_trim(tbi_index%filnam)-4 call open_port(tbi_index%filnam(1:nend), port, 'r', ioerr) if (ioerr < 0) then write(outstr,'(3a)') 'ERROR: Could not open "', tbi_index%filnam(1:nend), '".' return end if #if ZLIB fnd=.false. do j=1, tbi_index%bins(seq_idx)%nchunks(bin_idx) pos=tbi_index%bins(seq_idx)%chunks(bin_idx)%cnk_beg(j) call tbi_virpos(pos, bpos, boff) call bgzf_seek(port, bpos, boff, ioerr) if (ioerr == 0) then i=0 do call readline(port, slin, ios=ioerr) if (ioerr /= 0) exit i=i+1 if (i > 1000) exit call getword(slin, 2, word) if (word == coordinates((spos+1):)) then fnd=.true. write(outstr,'(a)') slin(1:72) if (typ == 2) then call getword(slin, pos_info, locinfo) eol=len_trim(locinfo) k=1 n=0 stat=0 write(outstr,'(/a/a,1x,a)') & 'INFO variable Value', & repeat('-',20), repeat('-', 10) do call nextword(k, locinfo, eol, opchar, n, word, stat, ';', SEP_CHAR) if (stat /= 0) exit sep=index(word, '=') if (sep == 0) then write(outstr,'(a20,1x,a)') word, 'present' else write(outstr,'(a20,1x,a)') word(1:(sep-1)), trim(word((sep+1):)) end if end do end if exit else if (ival(word) > bp) then exit end if end do end if if (fnd) exit end do if (.not.fnd) then write(outstr,'(3a)') 'No matching record for ', trim(coordinates), '.' end if #endif call close_port(port, ioerr) end subroutine search_tbi ! ! Move to position corresponding to genomic location in indexed VCF file ! stat= 1 greater than ! 0 exact position ! -1 not present in indices ! -2 read error ! subroutine moveto_tbi(tbi_index, chr, mappos, port, slin, stat) use iobuff use outstream use scanner use fileio type (tbi_structure) :: tbi_index character(len=*), intent(in) :: chr integer, intent(in) :: mappos type (ioport) :: port character(len=*) :: slin integer, intent(out) :: stat integer :: bin_id, bin_idx, eol, i, ioerr, j, k, n, nend, & sep, seq_idx, spos logical :: fnd character(len=512) :: word integer(kind=8) :: boff, bpos, pos ! functions integer :: ival, tobp stat=-1 call find_hashtab(trim(chr), tbi_index%chrom, tbi_index%seqhash, seq_idx) if (seq_idx == 0) then call find_hashtab('chr' // trim(chr), tbi_index%chrom, tbi_index%seqhash, seq_idx) end if ! write(*,*) 'moveto_tbi chr="', trim(chr),'" seq_idx=', seq_idx if (seq_idx == 0) return bin_id=reg2bin(mappos, mappos) ! write(*,*) 'moveto_tbi bin_id=', bin_id call find_hashtab_int(bin_id, tbi_index%bins(seq_idx)%bin_number, & tbi_index%bins(seq_idx)%binhash, bin_idx) ! write(*,*) 'moveto_tbi mappos=', mappos,' bin_idx=', bin_idx if (bin_idx == 0) bin_idx=1 stat=-2 do j=1, tbi_index%bins(seq_idx)%nchunks(bin_idx) pos=tbi_index%bins(seq_idx)%chunks(bin_idx)%cnk_beg(j) bpos=ibits(pos, 16, 48)+1 boff=ibits(pos, 0, 16)+1 call bgzf_seek(port, bpos, boff, ioerr) if (ioerr == 0) then i=1 do call readline(port, slin, ios=ioerr) if (ioerr < 0) exit i=i+1 if (i > 250000) exit call getword(slin, 2, word) if (ival(word) == mappos) then stat=0 return else if (ival(word) > mappos) then stat=1 return end if end do end if end do end subroutine moveto_tbi end module tabixtools ! ! VCF (Variant Call Format) file utilities ! module vcftools implicit none contains ! ! Open VCF file and read metainformation ! subroutine openvcf(filnam, port, lin, stat) use fileio use scanner implicit none character (len=*), intent(in) :: filnam ! file i/o port type (ioport), intent(inout) :: port character (len=*), intent(inout) :: lin integer, intent(out) :: stat ! integer :: i, ich, ii, ioerr, narg stat=-1 call open_port(filnam, port, 'r', ioerr) if (ioerr /= 0) then write(outstr,'(3a)') & 'ERROR: Could not open VCF file "', trim(filnam),'".' return end if call readline(port, lin, ios=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') & 'ERROR: Could not read VCF file "', trim(filnam),'".' call close_port(port, ioerr) return end if do i=1, len(lin) ich=ichar(lin(i:i)) if ((ich < 32 .or. ich > 126) .and. ich /= 9 .and. ich /= 10 .and. ich /=13) then write(outstr,'(3a)') & 'ERROR: Putative VCF file "', trim(filnam),'" seems to be non-ascii.' write(outstr,'(a,i0,a)', advance='no') 'Char', max(1,i-10),':' do ii=max(1, i-10), min(len(lin), i+10) ich=ichar(lin(ii:ii)) if (ich < 32 .or. ich > 126) then write(outstr,'(a,i0,a)', advance='no') '<', ich, '>' else write(outstr,'(a)', advance='no') lin(ii:ii) end if end do write(outstr,*) call close_port(port, ioerr) return end if end do if (lin(1:12) /= '##fileformat' .and. lin(1:15) /= '##SnpEffVersion') then write(outstr,'(a/8x,a,a60,a)') & 'NOTE: Expected meta-information headed by "##fileformat=..." in:', & '"', lin, '..."' end if stat=0 end subroutine openvcf ! ! Count or check INFO variables are declared in heading VCF file ! infovars contains comma separated list of variables that should be present ! subroutine metavcf_vars(port, lin, infovars, stat, plevel) use fileio use scanner type (ioport) :: port character (len=*), intent(inout) :: lin character (len=*), intent(in) :: infovars integer, intent(out) :: stat integer, intent(in) :: plevel integer, parameter :: WORDLEN=80 integer :: i, ioerr, j, k, nfnd, nvars, ninfovars logical :: fnd character (len=WORDLEN), dimension(:), allocatable :: varnames character (len=WORDLEN) :: cval1, cval2, cval stat=0 nvars=0 cval1=' ' cval2=' ' cval=' ' if (len_trim(infovars) > 0) then nvars=countsep(',', infovars)+1 allocate(varnames(nvars)) call args(infovars, nvars, varnames, ',', SEP_CHAR) end if nfnd=0 ninfovars=0 do call readline(port, lin, ios=ioerr) if (ioerr /= 0) then stat=-1 call close_port(port, ioerr) return end if if (lin(1:6) == '#CHROM') exit if (lin(1:1) /= '#') exit if (lin(1:7) == '##INFO=') then ninfovars=ninfovars+1 i=index(lin, ' 0 .and. j > 0) then cval=lin((i+4):(j-1)) do k=1, nvars if (cval == varnames(k)) then fnd=.true. nfnd=nfnd+1 exit end if end do if (cval1 == ' ') then cval1=cval else if (cval2 == ' ') then cval2=cval end if end if if (plevel > 1 .or. (plevel > 0 .and. fnd)) then write(outstr,'(a)') lin(1:80) end if else if (plevel > 1) then write(outstr,'(a)') lin(1:80) else if (lin(1:12) == '##reference=') then write(outstr,'(2a)') 'Reference Seq = ', lin(13:len_trim(lin)) else if (lin(1:15) == '##ReferenceSeq=') then write(outstr,'(2a)') 'Reference Seq = ', lin(16:len_trim(lin)) else if (lin(1:13) == '##SampleSize=') then write(outstr,'(2a)') 'Sample Size = ', lin(14:len_trim(lin)) end if end do if (nvars > 0) then if (nvars > nfnd) then stat=nvars-nfnd end if else write(outstr,'(a,i0)', advance='no') 'No. INFO vars = ', ninfovars if (ninfovars > 0) then write(outstr,'(2a)', advance='no') ' (', trim(cval1) if (ninfovars > 1) then write(outstr,'(2a)', advance='no') ' ', trim(cval2) if (ninfovars > 2) then write(outstr,'(2a)', advance='no') '...', trim(cval) end if end if write(outstr,'(a)') ')' else write(outstr,*) end if end if end subroutine metavcf_vars ! ! Update various summaries about VCF file ! subroutine increment_vcfcounts(mappos, refallele, othallele, & filter, info, newchrom, lastpos, sorted, & mapstart, mapend, nmar, nindel, npass, nstruct) integer, intent(in) :: mappos character (len=*), intent(in) :: refallele, othallele character (len=*), intent(in) :: filter, info logical, intent(in) :: newchrom logical, intent(inout) :: sorted integer, intent(inout) :: lastpos, mapstart, mapend integer, intent(inout) :: nmar, nindel, npass, nstruct nmar=nmar+1 if (mappos < lastpos .and. .not.newchrom) sorted=.false. mapstart=min(mappos, mapstart) mapend=max(mappos, mapend) lastpos=mappos if (len_trim(refallele) /= len_trim(othallele)) then nindel=nindel+1 end if if (filter == 'PASS') then npass=npass+1 end if if (index(info, 'SVTYPE') > 0) then nstruct=nstruct+1 end if end subroutine increment_vcfcounts ! ! Just number of loci ! subroutine count_vcflines(filnam, nlines, exact) use interrupt use fileio character (len=*) :: filnam integer, intent(out) :: nlines logical, optional :: exact type (ioport) :: port ! local variables character (len=10) :: slin integer :: i, ios, ndig, nsamp, typ integer (kind=8) :: filsiz, ngeno, first_act, prev_act, prev_pos logical :: approximate double precision :: comp_ratio nlines=0 approximate=.true. if (present(exact)) approximate=.not.exact inquire(file=filnam, size=filsiz) call open_port(filnam, port, 'r', ios) if (ios /= 0) return do call readline(port, slin, ios=ios) if (ios /= 0) then call close_port(port, ios) return end if if (slin /= '#') exit end do nlines=nlines+1 if (approximate .and. filsiz > 1e7) then nsamp=0 comp_ratio=1.0d0 first_act=port%actual_file_position prev_act=first_act i=0 do prev_pos=port%file_position call readline(port, slin, ios=ios) if (ios /= 0) exit if (irupt > 0) exit i=i+1 if (port%actual_file_position /= prev_act) then nsamp=nsamp+1 if (nsamp > 2500) exit prev_act=port%actual_file_position end if end do comp_ratio=dfloat(port%actual_file_position-first_act)/dfloat(i) nlines=idint(dfloat(filsiz-first_act)/comp_ratio) else do call readline(port, slin, ios=ios) if (ios /= 0) exit nlines=nlines+1 end do end if call close_port(port, ios) end subroutine count_vcflines ! ! Basic descriptives ! addloci=2: declare loci ! chrcode=1: standard codes for chromosomes, number, X, Y, Mt ! 2: and, 23=X 24=Y 25=PAR 26=Mit ! offset : usually 0, but ANNOVAR appends data after annotations ! so offset=51 for the examples I have ! subroutine queryvcf(filnam, addloci, numloc, offset, plevel) use interrupt use storage_classes use iobuff use outstream use scanner use locstring_widths use locus_types use fileio use locus_data use locus_list use contingency_table use tabixtools character (len=*) :: filnam integer, intent(in) :: addloci integer, dimension(NDATACLASS), intent(inout) :: numloc integer, intent(in) :: offset integer, intent(in) :: plevel type (ioport) :: port ! local variables integer, parameter :: WORDLEN=35 character (len=1), parameter :: tab = achar(9) integer :: i, ios, j, typ integer :: lastpos, mappos, mapstart, mapend, narg, nchrom, stat integer :: ncol, nindel, nmar, nobs, npass, nstruct, seppos, totmar integer :: bgzipped, chrcode, ndig, nsamp, start, finish logical :: tbi_exist ! CHROM POS ID REF ALT QUAL FILTER INFO type (table_cell) :: val(1) type (table_data) :: chrtable integer :: pos_chrom, pos_bp, pos_id, pos_refall, pos_altall, pos_filter, pos_info integer (kind=8) :: filsiz, ngeno, first_act, prev_act, prev_pos double precision :: comp_ratio character (len=WORDLEN), dimension(offset+9) :: words integer :: nsnps character (len=WORDLEN), dimension(:), allocatable :: snps character (len=4096) :: slin character (len=128) :: locinfo character (len=chromosome_width) :: currchrom character (len=WORDLEN) :: selchrom character (len=1) :: ch logical :: found, haschrom, interval, matchchrom, newchrom, showall, sorted ! functions logical :: isint integer :: ival, ismappos double precision :: fval narg=9 call args(lin, narg, words, ' ', SEP_WHITE) inquire(file=filnam, size=filsiz) bgzipped=isgzipped(filnam) inquire(file=filnam // '.tbi', exist=tbi_exist) mapstart=1073741824 mapend=0 nsamp=0 lastpos=0 sorted=.true. chrcode=1 start=0 finish=1073741824 typ=1 interval=.false. pos_chrom=offset+1 pos_bp=offset+2 pos_id=offset+3 pos_refall=offset+4 pos_altall=offset+5 pos_filter=offset+7 pos_info=offset+8 currchrom=' ' selchrom=' ' haschrom=.false. matchchrom=.true. ! ! one or two map positions chr:bp or bp interpreted as a map interval ! else list of locus names ! stat=3 if (offset > 0) stat=stat+1 if (addloci == 2) stat=stat+1 if (narg > stat .and. & (words(narg) == 'hum' .or. words(narg) == 'human')) then chrcode=2 narg=narg-1 end if if (narg > stat) then if ((narg-stat) < 3) then if (ismappos(words(stat+1)) > 0) then haschrom=.true. interval=.true. seppos=index(words(stat+1), ':') selchrom=words(stat+1)(1:(seppos-1)) start=ival(words(stat+1)((seppos+1):len_trim(words(stat+1)))) if (ismappos(words(stat+2)) > 0) then seppos=index(words(stat+2), ':') finish=ival(words(stat+2)((seppos+1):len_trim(words(stat+2)))) else if (isint(words(stat+2))) then finish=ival(words(stat+2)) end if else if (isint(words(stat+1)) .and. isint(words(stat+2))) then interval=.true. if (isint(words(stat+1))) then start=ival(words(stat+1)) end if finish=ival(words(stat+2)) end if end if if (.not.interval) then typ=2 nsnps=countargs(trim(lin), ' ', SEP_WHITE)-stat allocate(snps(nsnps)) do i=1, nsnps call getword(lin, stat+i, snps(i)) end do end if end if if (plevel > 0) then if (typ == 1) then ch= ' ' if (selchrom /= ' ') ch=':' write(outstr,'(/3a,i0,a,i0,a/)') & 'Selecting loci in map interval ', & trim(selchrom), ch, start, ' -- ', finish, ' bp.' else write(outstr,'(/a)') & 'Selecting loci in list:' do i=1, nsnps write(outstr,'(2x,a)') snps(i) end do write(outstr,*) end if end if call openvcf(filnam, port, lin, stat) if (stat /= 0) return call metavcf_vars(port, lin, ' ', stat, plevel) if (stat /= 0) return ncol=countargs(trim(lin), ' ', SEP_WHITE) nobs=ncol-offset-8 call getword(trim(lin), 9, words(1)) if (words(1) == 'FORMAT' .or. offset /= 0) nobs=nobs-1 ! ! Give minimal information for very large files ! if (tbi_exist .and. filsiz > 1e7 .and. addloci == 1 .and. plevel < 3) then comp_ratio=1.0d0 first_act=port%actual_file_position prev_act=first_act i=0 do prev_pos=port%file_position call readline(port, slin, ios=ios) if (ios /= 0 .or. irupt /= 0) exit i=i+1 if (port%actual_file_position /= prev_act) then nsamp=nsamp+1 if (nsamp > 2500) exit prev_act=port%actual_file_position end if end do comp_ratio=dfloat(port%actual_file_position-first_act)/dfloat(i) ndig=min(idnint(log10(dfloat(filsiz))),4) nmar=10**ndig*idnint(dfloat(filsiz-first_act)/(10.0d0**ndig*comp_ratio)) call close_port(port, ios) write(outstr,'(/2a/a,i0,a/a,i0/a,i0,a,i0,a)') & 'VCF file = ', trim(filnam), & 'File size = ', filsiz, ' bytes', & 'Number of subjects = ', nobs, & 'Number of markers = ~', nmar, ' (assuming ', nint(comp_ratio), ' bytes/record)' call read_tbi(trim(filnam), tbi_index, stat) call show_tbi(tbi_index, plevel) return end if ! ! else read right through ! nmar=0 npass=0 nindel=0 nstruct=0 totmar=0 call setup_table(1, 5, chrtable) showall=((interval .and. plevel > 0) .or. plevel > 1) if (plevel > -1) then write(outstr,'(2(/a,1x,a))') & 'Locus ','Position (bp)', & '---------------','----------------' end if if (typ == 1) then do call readline(port, slin, ios=ios) if (ios /= 0 .or. irupt /= 0) exit totmar=totmar+1 narg=offset+8 call args(slin, narg, words, tab, SEP_CHAR) mappos=ival(words(pos_bp)) if (haschrom) then matchchrom = (words(pos_chrom) == selchrom) end if if (matchchrom .and. mappos >= start .and. mappos <= finish) then newchrom=(currchrom /= words(pos_chrom)) call set_table_cell(val(1), string=trim(words(pos_chrom))) call insert_table_cells(1, val, chrtable, 1) call increment_vcfcounts(mappos, words(pos_refall), words(pos_altall), & words(pos_filter), words(pos_info), newchrom, lastpos, sorted, & mapstart, mapend, nmar, nindel, npass, nstruct) if ((plevel > -1 .and. nmar < 20) .or. showall) then if (words(pos_id) == '.') then if (words(pos_chrom)(1:3) == 'chr') then words(pos_id)= trim(words(pos_chrom)) // ':' // trim(words(pos_bp)) else words(pos_id)='chr' // trim(words(pos_chrom)) // ':' // trim(words(pos_bp)) end if end if ! ! VCF annotations can be as per ANNOVAR etc ! allele|annot|impact|gene|feature|transcript|in/ex_number|HGVS|HGVS.p|cDNA ! call getword(trim(slin), pos_info, locinfo) write(outstr,'(a15,1x,a12,4(1x,a))') & words(pos_id), trim(words(pos_chrom)) // ':' // trim(words(pos_bp)), & trim(words(pos_refall)), trim(words(pos_altall)), & trim(locinfo), trim(words(pos_filter)) end if end if currchrom = words(pos_chrom) end do if (plevel > -1 .and. plevel < 2 .and. nmar > 19) then write(outstr,'(a)') '...' end if else do call readline(port, slin, ios=ios) if (ios /= 0 .or. irupt /= 0) exit totmar=totmar+1 narg=offset+8 call args(slin, narg, words, tab, SEP_CHAR) if (words(pos_id) == '.') then if (words(pos_chrom)(1:3) == 'chr') then words(pos_chrom)=words(pos_chrom)(4:len_trim(words(pos_chrom))) end if words(pos_id)='chr' // trim(words(pos_chrom)) // ':' // trim(words(pos_bp)) end if found=.false. do i=1, nsnps if (words(pos_id) == snps(i)) then found=.true. exit end if end do if (found) then mappos=ival(words(pos_bp)) newchrom=(currchrom /= words(pos_chrom)) call set_table_cell(val(1), string=trim(words(pos_chrom))) call insert_table_cells(1, val, chrtable, 1) call increment_vcfcounts(mappos, words(pos_refall), words(pos_altall), & words(pos_filter), words(pos_info), newchrom, lastpos, sorted, & mapstart, mapend, nmar, nindel, npass, nstruct) if (plevel > -2) then call getword(trim(slin), pos_info, locinfo) write(outstr,'(a15,1x,a12,1x,5a,2(1x,a))') & words(pos_id), trim(words(pos_chrom)) // ':' // trim(words(pos_bp)), & '[',trim(words(pos_refall)), '/', trim(words(pos_altall)), ']', & trim(locinfo), trim(words(pos_filter)) end if currchrom = words(pos_chrom) if (nmar == nsnps) exit end if end do end if write(outstr,'(/2a,2(/a,i0,a))') & 'VCF file = ', trim(filnam), & 'File size = ', filsiz, ' bytes', & 'Number of subjects = ', nobs, ' (with genotype data)' if (interval) then write(outstr,'(a,i0,a,i0,a)') & 'Number of markers = ', nmar, ' (out of total ', totmar,')' else write(outstr,'(a,i0)') & 'Number of markers = ', nmar end if if (nmar > 0) then ngeno=int(nobs, kind=8)*int(nmar, kind=8) write(outstr,'(a,i0,a,f5.3,a,3(/a,i0)/a)', advance='no') & 'Number passing QC = ', npass, ' (',dble(npass)/dble(nmar),')', & 'Number indels = ', nindel, & 'Number SVs = ', nstruct, & 'Total genotypes = ', ngeno, & 'Chromosomes =' call sort_table(chrtable) j=0 do i=1, chrtable%ncells call write_table_cell(x=chrtable%categories(chrtable%idx(i),1), & advance='no') j=j+1 if (j > 10) then write(outstr,'(/20x)', advance='no') j=0 end if end do write(outstr,'(/2(a,i0))') & 'Map range (bp) = ', mapstart, ' -- ', mapend if (.not.sorted) then write(outstr,'(a)') 'NOTE: Loci are not sorted by position!' end if end if if (addloci == 2) then if (typ == 1) then if (nmar > 0) then if (selchrom(1:3) == 'chr') then selchrom=selchrom(4:len(selchrom)) end if call rdvcf(port, chrcode, nmar, selchrom, mapstart, mapend, numloc, offset) write(outstr, '(/a,i0,a)') 'Declared ', nmar, ' new loci.' end if else write(outstr, '(/a/7x,a)') & 'ERROR: No loci declared. This command subsets by map range only!', & 'One can read in all loci then later retain those required.' end if end if call clean_table(chrtable) call close_port(port, ios) end subroutine queryvcf ! ! Declare markers read from VCF file ! CHROM POS ID REF ALT QUAL FILTER INFO ! chrcode=2 if numeric X,Y,Mit ! ! If tabix indexed, then must be sorted, so do not have to (re)read entire file ! subroutine rdvcf(port, chrcode, nmark, selchrom, mapstart, mapend, numloc, offset) use storage_classes use iobuff use outstream use scanner use locus_types use locus_data use locus_list use lochash_class use fileio use tabixtools type (ioport) :: port integer, intent(in) :: chrcode integer, intent(inout) :: nmark character (len=*), intent(in) :: selchrom integer, intent(in) :: mapstart, mapend integer, dimension(NDATACLASS), intent(inout) :: numloc integer, intent(in) :: offset ! local variables integer, parameter :: WORDLEN=40 integer :: i, ios, newloci integer :: pos_chrom, pos_bp, pos_id, pos_refall, pos_altall, & pos_filter, pos_info integer :: newsiz, mappos, narg, oldsiz, stat logical :: haschrom, matchchrom logical :: has_tbi, in_selchrom character (len=WORDLEN), dimension(offset+9) :: words character (len=4096) :: slin character (len=40) :: bigword, refall, altall ! functions logical :: isint, is_strict_int integer :: ival double precision :: fval call setup_stat('Newly declared loci 1=existing 2=yes', typ=2) pos_chrom=offset+1 pos_bp=offset+2 pos_id=offset+3 pos_refall=offset+4 pos_altall=offset+5 pos_filter=offset+7 pos_info=offset+8 in_selchrom= .FALSE. haschrom = (selchrom /= ' ') matchchrom = .TRUE. newloci=0 call load_tbi(port%filnam, tbi_index, has_tbi) ! ! if adding new loci assure enough room ! does not assume nmark is actual number to expect ! newsiz=nmark+nloci+1 oldsiz=size(loc) if (newsiz > oldsiz) then newsiz=5*(1+newsiz/5) call expand_loci(newsiz-oldsiz, 0) end if call make_lochash(nloci, loc, lochash) ! ! move to first locus ! if (has_tbi .and. haschrom .and. matchchrom) then call moveto_tbi(tbi_index, selchrom, mapstart, port, lin, ios) in_selchrom=.TRUE. else call rewind_port(port, ios) do call readline(port, slin, ios=ios) if (ios /= 0) return if (slin(1:1) /= '#') exit end do end if ! ! main loop through VCF file ! do if (ios < 0) exit narg=offset+8 call args(slin, narg, words, ' ', SEP_WHITE) if (isint(words(pos_bp))) then mappos=ival(words(pos_bp)) else mappos=-1 end if if (words(pos_chrom)(1:3) == 'chr') then words(pos_chrom)=words(pos_chrom)(4:len_trim(words(pos_chrom))) end if if (words(pos_id) == '.') then words(pos_id)='chr' // trim(words(pos_chrom)) // ':' // trim(words(pos_bp)) else if (is_strict_int(words(pos_id))) then words(pos_id)='m' // trim(words(pos_id)) end if if (haschrom) then matchchrom = (words(pos_chrom) == selchrom) end if if (matchchrom .and. mappos >= mapstart .and. mappos <= mapend) then call find_hashtab(trim(words(pos_id)(1:loc_width)), loc, lochash, i) if (i > 0) then locstat(i)=1.0d0 else newloci=newloci+1 nloci=nloci+1 loc(nloci)=words(pos_id) loctyp(nloci)=LOC_CODOM+LOC_CMP if (words(pos_chrom) == 'X' .or. words(pos_chrom) == 'x') then loctyp(nloci)=LOC_XLIN+LOC_CMP else if (words(pos_chrom) == 'Y' .or. words(pos_chrom) == 'y') then loctyp(nloci)=LOC_YHA+LOC_CMP else if (words(pos_chrom) == 'MT' .or. words(pos_chrom) == 'mt' .or. & words(pos_chrom) == 'Mt') then words(pos_chrom)='MT' loctyp(nloci)=LOC_MIT+LOC_CMP else if (chrcode == 2) then if (words(pos_chrom) == '23') then words(pos_chrom)='X' loctyp(nloci)=LOC_XLIN+LOC_CMP else if (words(pos_chrom) == '24') then words(pos_chrom)='Y' loctyp(nloci)=LOC_YHA+LOC_CMP else if (words(pos_chrom) == '25') then words(pos_chrom)='XY' else if (words(pos_chrom) == '26') then words(pos_chrom)='MT' loctyp(nloci)=LOC_MIT+LOC_CMP end if end if locpos(nloci)=-(numloc(SCLASS)+1) numloc(SCLASS)=numloc(SCLASS)+2 outpos(nloci)=numloc(TCLASS)+1 numloc(TCLASS)=numloc(TCLASS)+2 call getword(slin, pos_info, bigword) refall=adjustl(words(pos_refall)) altall=adjustl(words(pos_altall)) locnotes(nloci)='[' // trim(refall(1:10)) // '/' // trim(altall(1:10)) // ']' if (words(pos_filter) /= '.' .and. words(pos_filter) /= 'PASS') then locnotes(nloci)=trim(locnotes(nloci)) // ' ' // trim(words(pos_filter)) end if locnotes(nloci)=trim(locnotes(nloci)) // ' ' // trim(bigword) group(nloci)=words(pos_chrom) map(nloci)=1.0d-6*mappos locstat(nloci)=2.0d0 end if end if if (in_selchrom .and. mappos > mapend) exit call readline(port, slin, ios=ios) end do call make_lochash(nloci, loc, lochash) nmark=newloci end subroutine rdvcf ! ! Read just the locations and INFO for existing loci ! subroutine read_vcfmap(port, nterms, terms, plevel) use storage_classes use iobuff use outstream use scanner use locus_types use locus_data use locus_list use lochash_class use fileio use tabixtools type (ioport) :: port integer, intent(in) :: nterms character (len=*), dimension(nterms), intent(in) :: terms integer, intent(in) :: plevel ! local variables integer, parameter :: WORDLEN=40 integer :: first, i, idx, ios integer :: pos_chrom, pos_bp, pos_id, pos_refall, pos_altall, & pos_filter, pos_info integer :: nmark, nmapped, mappos, narg integer :: chrcode, mapstart, mapend, offset, spos logical :: haschrom, has_tbi, in_selchrom, matchchrom character (len=WORDLEN), dimension(60) :: words character (len=WORDLEN) :: selchrom character (len=4096) :: locinfo, slin character (len=40) :: bigword, refall, altall ! functions logical :: isint, is_strict_int integer :: ival, tobp double precision :: fval call setup_stat('Reading map positions', typ=1) chrcode=1 first=0 selchrom=' ' mapstart=0 mapend=1073741824 offset=0 nmapped=0 nmark=0 do i=1, nloci if (ismarker(loctyp(i)) .and. isactive(loctyp(i))) then first=i selchrom=group(i) mapstart=max(1,tobp(map(i))-50000) exit end if end do if (first == 0) then write(outstr,'(/a)') 'No active loci!' return end if do i=first, nloci if (ismarker(loctyp(i)) .and. isactive(loctyp(i))) then nmark=nmark+1 locstat(i)=0.0d0 end if end do if (terms(nterms) == 'ann') offset=51 if (plevel > 0) then write(outstr,'(2a,a1,i0,a)') & 'Reading range ', trim(selchrom), ':', mapstart, ' -- ' end if pos_chrom=offset+1 pos_bp=offset+2 pos_id=offset+3 pos_refall=offset+4 pos_altall=offset+5 pos_filter=offset+7 pos_info=offset+8 in_selchrom= .FALSE. haschrom = (selchrom /= ' ') matchchrom = .TRUE. call load_tbi(port%filnam, tbi_index, has_tbi) ! ! move to first locus ! if (has_tbi .and. matchchrom) then call moveto_tbi(tbi_index, selchrom, mapstart, port, lin, ios) in_selchrom=.TRUE. else call rewind_port(port, ios) do call readline(port, slin, ios=ios) if (ios /= 0) return if (slin(1:1) /= '#') exit end do end if ! ! main loop through VCF file ! do if (ios < 0) exit narg=offset+8 call args(slin, narg, words, ' ', SEP_WHITE) if (isint(words(pos_bp))) then mappos=ival(words(pos_bp)) else mappos=-1 end if if (words(pos_chrom)(1:3) == 'chr') then words(pos_chrom)=words(pos_chrom)(4:len_trim(words(pos_chrom))) end if if (haschrom) then matchchrom = (words(pos_chrom) == selchrom) end if call find_hashtab(trim(words(pos_id)(1:loc_width)), loc, lochash, idx) if (plevel > 1) then write(outstr,'(3a,i0)') 'Reading "', trim(words(pos_id)), '" -> ', idx end if if (idx > 0 .and. matchchrom .and. mappos >= mapstart .and. mappos <= mapend) then nmapped=nmapped+1 locstat(idx)=1.0d0 group(idx)=words(pos_chrom) map(idx)=1.0d-6*mappos call getword(slin, pos_info, bigword) refall=adjustl(words(pos_refall)) altall=adjustl(words(pos_altall)) locnotes(idx)='[' // trim(refall(1:10)) // '/' // trim(altall(1:10)) // ']' if (words(pos_filter) /= '.' .and. words(pos_filter) /= 'PASS') then locnotes(idx)=trim(locnotes(idx)) // ' ' // trim(words(pos_filter)) end if locnotes(idx)=trim(locnotes(idx)) // ' ' // trim(bigword) if (plevel > 1) then write(outstr,'(i0,1x,a,1x,a)') nmapped, trim(words(pos_id)), words(pos_bp) end if end if if (in_selchrom .and. mappos > mapend) exit if (nmapped == nmark) exit call readline(port, slin, ios=ios) end do write(outstr,'(/a,i0,a)') & 'Matched up ', nmapped, ' loci with their map positions ' end subroutine read_vcfmap ! ! Read and find INFO variable description ! Recode subvariables in search strings to their list position ! subroutine info_description(nvars, vars, varsubsep, slin, & nfound, ninfovars, ninfosubvars, plevel) use scanner use outstream integer, intent(in) :: nvars character (len=*), dimension(nvars), intent(inout) :: vars character (len=1), intent(in) :: varsubsep character (len=*) :: slin integer, intent(inout) :: nfound, ninfovars, ninfosubvars integer, intent(in) :: plevel ! Sib-pair sub-variable separator for vcf commands ! not the same as varsubsep character (len=1), parameter :: mysubsep = ':' character (len=128) :: bigword, varnam, varsubnam character (len=16384) :: locinfo integer :: eos, fin, flen, i, j, narg, sta, varsub logical :: fnd ! functions logical :: isint if (slin(1:7) /= '##INFO=') return sta=index(slin, ' 0 .and. sta > 0) then locinfo=slin((sta+flen):eos) eos=index(locinfo,'=') if (eos > 0) then if (locinfo(1:(eos-1)) == trim(varnam)) then locinfo=locinfo((eos+1):) end if end if narg=countargs(trim(locinfo), varsubsep, SEP_CHAR) ninfosubvars=ninfosubvars+narg do i=1, narg call getword(locinfo, i, varsubnam, sep=varsubsep, style=SEP_CHAR) ! ! Subvariables are not named except in header of VCF file here, ! so replace name in request with position in list ! fnd=.false. do j=1, nvars if (trim(varnam) // mysubsep // trim(varsubnam) == vars(j)) then fnd=.true. eos=index(vars(j), mysubsep)-1 write(bigword, '(i20)') i vars(j)=vars(j)(1:eos) // mysubsep // trim(adjustl(bigword)) end if end do if (fnd) then nfound=nfound+1 write(outstr,'(5a,i0,a)') '*FOUND* "',trim(varnam), ':', trim(varsubnam), '" (', i, ')' else if (nvars == 0 .or. plevel > 0) then write(outstr,'(4a,i0,a)') trim(varnam), ':', trim(varsubnam), ' (', i, ')' end if end do write(outstr,*) else call getpairval('Description', slin, opvcfdec, locinfo) fnd=.false. do j=1, nvars if (varnam == vars(j)) then fnd=.true. exit end if end do if (fnd) then nfound=nfound+1 write(outstr,'(4a)') '*FOUND* "', trim(varnam),'": ', trim(locinfo) else if (nvars == 0 .or. plevel > 0) then write(outstr,'(4a)') '"', trim(varnam),'": ', trim(locinfo) end if end if end subroutine info_description ! ! Extract VCF INFO variables from line ! subroutine extract_annotation(nvars, vars, varsubsep, slin, res) use outstream use scanner integer, intent(in) :: nvars character (len=*), dimension(nvars), intent(in) :: vars character (len=1), intent(in) :: varsubsep character (len=*), intent(in) :: slin character (len=*), intent(inout) :: res ! local variables integer, parameter :: pos_chrom=1, pos_bp=2, pos_id=3, & pos_refall=4, pos_altall=5, pos_info=8 character (len=1), parameter :: tab = achar(9) ! integer :: eos, fin, first, fnd, hassubvar, i, idx, ioerr, & mapped, narg, sta, subvar, varpos, varsub character (len=80) :: alleles, word character (len=16384) :: bigword, locinfo first=1 if (vars(1) == 'current') then first=2 sta=index(res, '[') fin=index(res, ']') if (sta == 1 .and. fin > sta) then alleles=res(sta:fin) end if end if res=' ' do i=nvars, first, -1 word=vars(i) if (word == 'alleles') then call getword(slin, pos_altall, locinfo) res=trim(locinfo(1:10)) // '] ' // res call getword(slin, pos_refall, locinfo) res='[' // trim(locinfo(1:10)) // '/' // res else hassubvar=index(word, ':') varsub=0 if (hassubvar > 0) then word=vars(i)(1:(hassubvar-1)) read(vars(i)((hassubvar+1):len_trim(vars(i))), '(i20)') varsub end if call getword(slin, pos_info, locinfo) varpos=wordfind(word, locinfo, ';', SEP_CHAR, exact=.FALSE.) if (varpos > 0) then call getword(locinfo, varpos, bigword,';', SEP_CHAR) if (varsub > 0) then call getword(bigword, varsub, locinfo, varsubsep, SEP_CHAR) else locinfo=bigword end if if (locinfo == '') locinfo='.' res=trim(locinfo) // tabsep // res end if end if end do if (first == 2) res=trim(alleles) // tabsep // res end subroutine extract_annotation ! ! (re)scan VCF file and extract INFO variable data to locnotes (typ=1), ! locstats (typ=2), loc (typ=3), or screen (typ=4) ! include ability to extract nth value from an ANNOVAR type list variable ! In files I am currently dealing with, this variable is CSQ ! subroutine getvcfanno(typ, filnam, nterms, terms, plevel) use interrupt use storage_classes use iobuff use outstream use scanner use genetic_maps use locstring_widths use locus_types use fileio use locus_data use locus_list use tabixtools integer, intent(in) :: typ character (len=*), intent(in) :: filnam integer, intent(in) :: nterms character (len=*), dimension(:), intent(inout) :: terms integer, intent(in) :: plevel type (ioport) :: port ! local variables integer, parameter :: WORDLEN=35 character (len=1), parameter :: tab = achar(9) ! ! allow matching by map position type (hash_table) :: maphash character (len=13), dimension(nloci) :: map_str character (len=13) :: pos_str logical :: hasname, has_tbi ! active markers - if indexed VCF integer :: mpos, nmark_data, nact_data integer, dimension(nloci) :: mark integer :: pos_chrom, pos_bp, pos_id, pos_info, pos_altall, pos_refall integer :: eos, gene, hassubvar, i, idx, ioerr, j, mapped, narg, nedits, & nfound, ninfovars, ninfosubvars, nmar, offset, nter, pos character (len=WORDLEN), dimension(:), allocatable :: words character (len=WORDLEN) :: curloc character (len=1) :: subsep character (len=8192) :: slin character (len=8192) :: locinfo character (len=40) :: refall, altall ! functions character (len=8) :: wrpercent integer :: tobp double precision :: fval call open_port(filnam, port, 'r', ioerr) if (ioerr /= 0) then write(outstr,'(3a)') & 'ERROR: Could not open VCF file "', trim(filnam),'".' return end if nter=nterms subsep='|' if (len_trim(terms(nterms)) == 1) then nter=nter-1 subsep=terms(nterms) end if mapped=0 nedits=0 nfound=0 ninfovars=0 ninfosubvars=0 offset=0 pos_chrom=offset+1 pos_bp=offset+2 pos_id=offset+3 pos_refall=offset+4 pos_altall=offset+5 pos_info=offset+8 nmark_data=0 nact_data=0 do i=1, nloci if (ismarker(loctyp(i))) then nmark_data=nmark_data+1 if (isactive(loctyp(i))) then nact_data=nact_data+1 mark(nact_data)=i end if end if end do do j=1, nter if (terms(j) == 'current') nfound=nfound+1 if (terms(j) == 'alleles') nfound=nfound+1 end do do call readline(port, slin, ios=ioerr) if (ioerr /= 0) exit call info_description(nter, terms, subsep, slin, & nfound, ninfovars, ninfosubvars, plevel) if (slin(1:2) /= '##') exit end do write(outstr,'(a,i0)', advance='no') 'No. INFO vars = ', ninfovars if (ninfosubvars > 0) then write(outstr,'(1x,a,i0,a)') '(', ninfosubvars,' subvars)' else write(outstr,*) end if ! if (nfound > 0 .and. ioerr == 0) then if (.not.lochash%current) then call make_lochash(nloci, loc, lochash) end if call make_maphash(nloci, loctyp, group, map, map_str, maphash) if (typ == 2) then call setup_stat(terms(1), typ=1) end if call load_tbi(port%filnam, tbi_index, has_tbi) allocate(words(max(5, ninfovars))) mpos=0 nmar=0 do if (irupt > 0) exit if (nact_data == mapped) exit if (nmark_data == mpos) exit if (has_tbi) then mpos=mpos+1 gene=mark(mpos) call moveto_tbi(tbi_index, group(gene), tobp(map(gene)), port, slin, ioerr) if (plevel > 1) then write(outstr,'(3a,i0)') 'Seeking ', loc(gene), ' stat=', ioerr end if if ((ioerr == -1 .or. ioerr == 1) .and. mpos < nact_data) cycle else call readline(port, slin, ios=ioerr) end if if (ioerr /= 0) exit nmar=nmar+1 narg=3 call args(slin, narg, words, char(9), SEP_CHAR) if (words(pos_chrom)(1:3) == 'chr') then words(pos_chrom)=words(pos_chrom)(4:len(words(pos_chrom))) ! Kluge for dbSNP files, where chromosome fields are NC_0000nn.nn else if (words(pos_chrom)(1:3) == 'NC_') then call ncbiseq_to_chr(words(pos_chrom)) end if curloc=words(pos_id) if (curloc == '.') then curloc='chr' // trim(words(pos_chrom)) // ':' // trim(words(pos_bp)) end if call find_hashtab(trim(words(pos_id)(1:loc_width)), loc, lochash, idx) if (idx == 0) then pos_str=trim(words(pos_chrom)) // ':' // adjustl(words(pos_bp)) call find_hashtab(trim(pos_str), map_str, maphash, idx) end if if (idx > 0) then if (isactive(loctyp(idx))) then mapped=mapped+1 locinfo=locnotes(idx) call extract_annotation(nter, terms, subsep, slin, locinfo) if (typ == 1) then nedits=nedits+1 locnotes(idx)=trim(locinfo) // ' ' // locnotes(idx) else if (typ == 2) then if (locinfo /= '.') then nedits=nedits+1 locinfo=locinfo((scan(locinfo,'=')+1):len(locinfo)) pos=scan(locinfo, ',') if (pos > 0) then locinfo=locinfo(1:(pos-1)) end if locstat(idx)=fval(locinfo) end if else if (typ == 3) then if (locinfo /= ' ' .and. locinfo /= '.') then nedits=nedits+1 pos=scan(locinfo, ',&') if (pos > 0) then locinfo=locinfo(1:(pos-1)) end if loc(idx)=locinfo end if else write(outstr,'(4a,g14.6,2a)') & loc(idx), tabsep, group(idx), tabsep, map(idx), & tabsep, trim(locinfo) end if end if end if end do if (allocated(words)) deallocate(words) write(outstr,'(/a,i0/a,i0,1x,a)') & 'Total number of loci scanned = ', nmar, & 'Number of annotations updated = ', nedits, & trim(wrpercent(nedits, nmar)) end if call close_port(port, ioerr) end subroutine getvcfanno ! ! Tabulate VCF INFO variable values ! subroutine tabulate_info(filnam, nterms, terms, plevel) use interrupt use storage_classes use iobuff use outstream use scanner use fileio use contingency_table character (len=*), intent(in) :: filnam integer, intent(in) :: nterms character (len=*), dimension(:), intent(inout) :: terms integer, intent(in) :: plevel type (ioport) :: port ! local variables integer, parameter :: MISS=-9999 character (len=1), parameter :: tab = achar(9) ! type (table_cell), dimension(:), allocatable :: val type (table_data) :: info_table ! integer :: pos_chrom, pos_bp, pos_id, pos_info, & pos_refall, pos_altall integer :: eos, hassubvar, i, idx, ioerr, j, k, mapped, narg, nfound, & ninfovars, ninfosubvars, nmar, offset, & nter, varpos, varsub logical :: allreal double precision :: v character (len=1) :: subsep, varsubsep character (len=8192) :: slin character (len=8192) :: bigword, locinfo character (len=40) :: refall, altall character (len=80) :: word ! functions character (len=8) :: wrpercent logical :: is_strict_real double precision :: fval call open_port(filnam, port, 'r', ioerr) if (ioerr /= 0) then write(outstr,'(3a)') & 'ERROR: Could not open VCF file "', trim(filnam),'".' return end if nter=nterms subsep='|' if (nter > 0) then if (len_trim(terms(nterms)) == 1) then nter=nter-1 subsep=terms(nterms) end if end if offset=0 nfound=0 ninfovars=0 ninfosubvars=0 pos_chrom=offset+1 pos_bp=offset+2 pos_id=offset+3 pos_refall=offset+4 pos_altall=offset+5 pos_info=offset+8 do j=1, nter if (terms(j) == 'alleles') then nfound=nfound+1 else if (terms(j) == 'locus') then nfound=nfound+1 else if (terms(j) == 'chromosome') then nfound=nfound+1 else if (terms(j) == 'position') then nfound=nfound+1 end if end do do call readline(port, slin, ios=ioerr) if (ioerr /= 0) exit if (plevel > 1) then write(outstr,'(a)') trim(slin) end if call info_description(nter, terms, subsep, slin, & nfound, ninfovars, ninfosubvars, plevel) if (slin(1:2) /= '##') exit end do write(outstr,'(a,i0)', advance='no') 'No. INFO vars = ', ninfovars if (ninfosubvars > 0) then write(outstr,'(1x,a,i0,a)') '(', ninfosubvars,' subvars)' else write(outstr,*) end if ! if (ioerr == 0 .and. nfound > 0) then allocate(val(nter)) call setup_table(nter, 30, info_table) do j=1, nter call set_table_colname(j, terms(j), info_table) end do nmar=0 do call readline(port, slin, ios=ioerr) if (ioerr /= 0) exit if (irupt > 0) exit nmar=nmar+1 do j=1, nter call set_table_cell_type(TABLE_CELL_UNSET, val(j)) if (terms(j) == 'alleles') then call getword(slin, pos_altall, altall) call getword(slin, pos_refall, refall) locinfo=trim(refall) // '/' // trim(altall) call set_table_cell(val(j), string=trim(locinfo)) else if (terms(j) == 'locus') then call getword(slin, pos_id, locinfo) call set_table_cell(val(j), string=trim(locinfo)) else if (terms(j) == 'position') then call getword(slin, pos_bp, locinfo) call set_table_cell(val(j), string=trim(locinfo)) else if (terms(j) == 'chromosome') then call getword(slin, pos_chrom, locinfo) call set_table_cell(val(j), string=trim(locinfo)) else word=terms(j) hassubvar=index(word, ':') varsub=0 if (hassubvar > 0) then word=terms(j)(1:(hassubvar-1)) read(terms(j)((hassubvar+1):len_trim(terms(j))), '(i20)') varsub end if call getword(slin, pos_info, locinfo) varpos=wordfind(word, locinfo, ';', SEP_CHAR, exact=.TRUE.) if (varpos == 0) then varpos=wordfind(trim(word) // '=', locinfo, ';', SEP_CHAR, exact=.FALSE.) end if if (varpos > 0) then call getword(locinfo, varpos, bigword,';', SEP_CHAR) if (varsub > 0) then call getword(bigword, varsub, locinfo, subsep, SEP_CHAR) else locinfo=bigword((len_trim(word)+2):) end if if (locinfo == '') locinfo=word if (is_strict_real(locinfo)) then v=fval(trim(locinfo)) if (v /= MISS) then call set_table_cell(val(j), rvalue=fval(trim(locinfo))) end if else call set_table_cell(val(j), string=trim(locinfo)) end if end if end if end do call insert_table_cells(nter, val, info_table, 1) end do allreal = .false. if (info_table%ncat == 1) then allreal = .true. do i=1, info_table%ncells if (.not.table_cell_numeric(info_table%categories(i,1))) then allreal = .false. exit end if end do end if if (plevel > 0 .or. .not.allreal .or. info_table%ncells < 25) then call print_table(info_table) else call sort_table(info_table) call dohist(word, min(info_table%ncells,20), 1, info_table, 9, 4, ' ') call symtest(info_table, 0) end if end if call close_port(port, ioerr) end subroutine tabulate_info end module vcftools ! ! hash VCF file by locus name ! module vcfhash_class use locstring_widths use lochash_class use vcftools integer, parameter :: NO_COMP = 0, GZ_COMP = 1, BGZF_COMP = 2 character (len=21), parameter :: vcfhash_version = 'Sib-pair VCF hash V1.0' type vcfhash_table character (len=21) :: version = vcfhash_version integer :: nloci = 0 integer :: nmapped = 0 character(len=1024) :: filnam = ' ' integer :: compression_type = 0 integer :: offset = 0 integer :: nlines = 0 character(len=loc_width), dimension(:), allocatable :: loc type (hash_table) :: lochash integer (kind=8), dimension(:), allocatable :: block_address integer, dimension(:), allocatable :: line_address integer (kind=8), dimension(:), allocatable :: line_position end type vcfhash_table contains subroutine make_vcfhash(filnam, vcfhash, plevel, offset) use interrupt use outstream use locus_data use locus_list use automatic_data use lochash_class use scanner use fileio character (len=*), intent(in) :: filnam type (vcfhash_table) :: vcfhash integer, intent(in) :: plevel integer, optional, intent(in) :: offset ! type (ioport) :: port character (len=20), dimension(2) :: words(2) character (len=80) :: locnam character (len=256) :: slin integer :: i, ioerr, nmapped, nmark, nlines, pos, n_vcfloci integer :: pos_chrom, pos_bp, pos_locnam integer (kind=8) :: block_start, line_start integer :: it1, it2, ticks call system_clock(it1) call count_vcflines(filnam, n_vcfloci) n_vcfloci=n_vcfloci+n_vcfloci/5 if (plevel > 0 .or. n_vcfloci > 1000000) then write(outstr,'(a,i0,a)') & 'Hashing ~', n_vcfloci, ' loci,' end if vcfhash%filnam=filnam vcfhash%compression_type=NO_COMP vcfhash%nlines=0 vcfhash%nmapped=0 vcfhash%offset=0 vcfhash%nloci=n_vcfloci+n_vcfloci/5 call setup_hash(HK_LOCNAM, n_vcfloci, vcfhash%lochash, 90) if (allocated(vcfhash%loc)) then deallocate(vcfhash%loc, vcfhash%line_address, & vcfhash%line_position, vcfhash%block_address) end if allocate(vcfhash%loc(n_vcfloci)) allocate(vcfhash%line_address(n_vcfloci)) allocate(vcfhash%line_position(n_vcfloci)) vcfhash%line_address=0 vcfhash%line_position=0 call make_lochash(nloci, loc, lochash) call open_port(filnam, port, 'r', ioerr) if (ioerr /= 0) then write(outstr,'(3a)') & 'ERROR: Could not open VCF file "', trim(filnam),'".' return end if if (port%filtyp == PORT_BGZIPPED) then vcfhash%compression_type = BGZF_COMP allocate(vcfhash%block_address(vcfhash%nloci)) vcfhash%block_address=0 else if (port%filtyp == PORT_GZIPPED) then vcfhash%compression_type = GZ_COMP end if nmapped=0 nmark=0 nlines=0 pos_chrom=1 pos_bp=2 pos_locnam=3 if (present(offset)) then vcfhash%offset=offset pos_locnam=pos_locnam+offset pos_chrom=pos_chrom+offset pos_bp=pos_bp+offset end if do call readline(port, slin, ios=ioerr) if (ioerr /= 0) exit nlines=nlines+1 if (slin(1:6) == '#CHROM') exit end do if (ioerr == 0) then if (port%filtyp == PORT_BGZIPPED) then do block_start=port%actual_file_position line_start=zbufpos call readline(port, slin, ios=ioerr) if (ioerr /= 0) exit nmark=nmark+1 nlines=nlines+1 call getword(slin, pos_locnam, locnam) if (locnam == '.') then call getword(slin, pos_chrom, words(1)) call getword(slin, pos_bp, words(2)) if (words(1)(1:3) == 'chr') then locnam=trim(words(1)) // ':' // trim(words(2)) else locnam='chr' // trim(words(1)) // ':' // trim(words(2)) end if end if if (nmark > vcfhash%nloci) then call expand_vcfhash(vcfhash) end if vcfhash%loc(nmark)=locnam vcfhash%line_address(nmark)=nlines vcfhash%line_position(nmark)=line_start vcfhash%block_address(nmark)=block_start call find_hashtab(trim(locnam), loc, lochash, pos) if (pos > 0) nmapped=nmapped+1 if (irupt > 0) exit if (mod(nmark, 2000000) == 0) then call system_clock(it2, count_rate=ticks) write(outstr,'(a,i0,a,f20.2,a)') & 'Hashed ', nmark, ' loci...[', float(it2-it1)/float(ticks), ']' end if end do else do line_start=port_position(port) call readline(port, slin, ios=ioerr) if (ioerr /= 0) exit nmark=nmark+1 nlines=nlines+1 call getword(slin, pos_locnam, locnam) if (locnam == '.') then call getword(slin, pos_chrom, words(1)) call getword(slin, pos_bp, words(2)) if (words(1)(1:3) == 'chr') then locnam=trim(words(1)) // ':' // trim(words(2)) else locnam='chr' // trim(words(1)) // ':' // trim(words(2)) end if end if vcfhash%loc(nmark)=locnam vcfhash%line_address(nmark)=nlines vcfhash%line_position(nmark)=line_start call find_hashtab(trim(locnam), loc, lochash, pos) if (pos > 0) nmapped=nmapped+1 if (irupt > 0) exit if (mod(nmark, 2000000) == 0) then call system_clock(it2, count_rate=ticks) write(outstr,'(a,i0,a,f20.2,a)') & 'Hashed ', nmark, ' loci...[', float(it2-it1)/float(ticks), ']' end if end do end if end if call close_port(port, ioerr) vcfhash%nloci=nmark vcfhash%nmapped=nmapped vcfhash%nlines=nlines call make_lochash(nmark, vcfhash%loc, vcfhash%lochash) call system_clock(it2, count_rate=ticks) write(slin, '(f20.2)') float(it2-it1)/float(ticks) slin=adjustl(slin) write(outstr,'(a,i0,5a)') 'Hashed ', nmark, ' loci in "', & trim(vcfhash%filnam), '" (', trim(slin), 's).' if (nloci > ENVNUM) then write(outstr,'(i0,a)') nmapped, ' match to current dataset.' end if end subroutine make_vcfhash ! ! Expand vcfhash storage ! subroutine expand_vcfhash(vcfhash, expand) use interrupt use outstream type (vcfhash_table), intent(inout) :: vcfhash integer, optional :: expand real, parameter :: expfactor = 1.1 integer :: oldsiz, newsiz character(len=loc_width), dimension(:), allocatable :: loc integer (kind=8), dimension(:), allocatable :: block_address integer, dimension(:), allocatable :: line_address integer (kind=8), dimension(:), allocatable :: line_position integer :: it1, it2, ticks call system_clock(it1) oldsiz=size(vcfhash%loc) newsiz=int(expfactor*real(oldsiz)) if (present(expand)) then if (expand > 0) newsiz=oldsiz+expand end if vcfhash%nloci=newsiz allocate(loc(oldsiz)) allocate(line_address(oldsiz)) allocate(line_position(oldsiz)) loc=vcfhash%loc line_address=vcfhash%line_address line_position=vcfhash%line_position deallocate(vcfhash%loc, vcfhash%line_address, vcfhash%line_position) allocate(vcfhash%loc(newsiz)) allocate(vcfhash%line_address(newsiz)) allocate(vcfhash%line_position(newsiz)) vcfhash%loc(1:oldsiz)=loc vcfhash%line_address=0 vcfhash%line_position=0 vcfhash%line_address(1:oldsiz)=line_address vcfhash%line_position(1:oldsiz)=line_position deallocate(loc, line_address, line_position) if (vcfhash%compression_type == BGZF_COMP) then allocate(block_address(oldsiz)) block_address=vcfhash%block_address deallocate(vcfhash%block_address) allocate(vcfhash%block_address(newsiz)) vcfhash%block_address=0 vcfhash%block_address(1:oldsiz)=block_address deallocate(block_address) end if call system_clock(it2, count_rate=ticks) write(outstr,'(a,i0,a,f6.3,a)') & 'NOTE: expanded maximum number of vcfhash loci to ', newsiz, & ' [', float(it2-it1)/float(ticks), ']' end subroutine expand_vcfhash ! subroutine write_vcfhash(filnam, vcfhash) use outstream use locus_data use locus_list use lochash_class use fileio character (len=*), intent(in) :: filnam type (vcfhash_table), intent(in) :: vcfhash integer :: strm call newlun(strm) open(strm, file=filnam, access=stream_access, form=stream_form, iostat=ios) if (ios /= 0) then write(outstr,'(3a)') & 'ERROR: Could not open file "', trim(filnam),'" for writing.' return end if write(strm) vcfhash%version write(strm) vcfhash%nloci write(strm) vcfhash%nmapped write(strm) vcfhash%filnam write(strm) vcfhash%compression_type write(strm) vcfhash%offset write(strm) vcfhash%nlines if (vcfhash%nloci > 0) then write(strm) vcfhash%loc(1:vcfhash%nloci) write(strm) vcfhash%lochash%current write(strm) vcfhash%lochash%hasdups write(strm) vcfhash%lochash%keytyp write(strm) vcfhash%lochash%nrec write(strm) vcfhash%lochash%primroot write(strm) vcfhash%lochash%address if (vcfhash%compression_type == BGZF_COMP) then write(strm) vcfhash%block_address end if write(strm) vcfhash%line_address write(strm) vcfhash%line_position end if close(strm, status='keep') end subroutine write_vcfhash subroutine read_vcfhash(filnam, vcfhash, plevel) use outstream use locus_data use locus_list use lochash_class use fileio character (len=*), intent(in) :: filnam type (vcfhash_table), intent(out) :: vcfhash integer, intent(in) :: plevel integer :: i, strm call newlun(strm) open(strm, file=filnam, access=stream_access, form=stream_form, iostat=ios) if (ios /= 0) then write(outstr,'(3a)') & 'ERROR: Could not open file "', trim(filnam),'" for reading.' return end if read(strm) vcfhash%version if (vcfhash%version /= vcfhash_version) then write(outstr,'(5a)') & 'NOTE: VCF index in "', trim(filnam),'" is version "', & vcfhash%version, '".' end if read(strm) vcfhash%nloci read(strm) vcfhash%nmapped read(strm) vcfhash%filnam read(strm) vcfhash%compression_type read(strm) vcfhash%offset read(strm) vcfhash%nlines if (plevel > 0) then write(outstr,'(2a,3(/a,i0))') & 'Matching VCF file = ', trim(vcfhash%filnam), & 'File length (lines) = ', vcfhash%nlines, & 'Total loci = ', vcfhash%nloci, & 'Mapped loci = ', vcfhash%nmapped end if if (vcfhash%nloci /= nloci) then write(outstr,'(3a,i0,a,i0,a)') & 'NOTE: VCF index in "', trim(filnam),'" indexes ', & vcfhash%nloci, ' loci, not ', nloci, '.' end if if (vcfhash%nloci > 0) then if (allocated(vcfhash%loc)) then deallocate(vcfhash%loc, vcfhash%line_address, & vcfhash%line_position, & vcfhash%lochash%address) end if allocate(vcfhash%loc(vcfhash%nloci)) allocate(vcfhash%line_address(vcfhash%nloci)) allocate(vcfhash%line_position(vcfhash%nloci)) read(strm) vcfhash%loc read(strm) vcfhash%lochash%current read(strm) vcfhash%lochash%hasdups read(strm) vcfhash%lochash%keytyp read(strm) vcfhash%lochash%nrec read(strm) vcfhash%lochash%primroot if (allocated(vcfhash%lochash%address)) then deallocate(vcfhash%lochash%address) end if allocate(vcfhash%lochash%address(vcfhash%lochash%nrec)) read(strm) vcfhash%lochash%address if (vcfhash%compression_type == BGZF_COMP) then if (allocated(vcfhash%block_address)) then deallocate(vcfhash%block_address) end if allocate(vcfhash%block_address(vcfhash%nloci)) read(strm) vcfhash%block_address end if read(strm) vcfhash%line_address read(strm) vcfhash%line_position ! if (plevel > 0) then write(outstr,'(/a/a)') & 'Locus name VCF line block address', & '-------------------- ----------------------' if (vcfhash%nloci > 5) then write(outstr,'(a)') '...' do i=vcfhash%nloci-5, vcfhash%nloci write(outstr,'(a20,3(1x,i0))') & vcfhash%loc(i), vcfhash%line_address(i), & vcfhash%block_address(i), vcfhash%line_position(i) end do end if end if end if close(strm, status='keep') end subroutine read_vcfhash subroutine show_vcfhash(vcfhash) use outstream type (vcfhash_table), intent(in) :: vcfhash ! write(outstr,'(a/2x,2a,2(/2x,a,i0)/)') & 'VCF file locus position hash:', & 'VCF file = ', trim(vcfhash%filnam), & 'Total loci = ', vcfhash%nloci, & 'Mapped loci = ', vcfhash%nmapped end subroutine show_vcfhash subroutine check_vcfhash(vcfhash, plevel) use outstream use locus_data use locus_list use lochash_class use scanner use fileio type (vcfhash_table), intent(in) :: vcfhash integer, intent(in) :: plevel ! type (ioport) :: port character (len=80) :: locnam character (len=256) :: slin integer :: i, ioerr, nlines, nmapped, pos, pos_id write(outstr,'(2a,2(/a,i0))') & 'VCF file = ', trim(vcfhash%filnam), & 'Total loci = ', vcfhash%nloci, & 'Mapped loci = ', vcfhash%nmapped call open_port(vcfhash%filnam, port, 'r', ioerr) if (ioerr /= 0) then write(outstr,'(/3a)') & 'ERROR: Could not open VCF file "', trim(vcfhash%filnam),'".' return else write(outstr,'(a)', advance='no') 'File compression = ' if (port%filtyp == PORT_BGZIPPED) then write(outstr,'(a)') 'bgzip' else if (port%filtyp == PORT_GZIPPED) then write(outstr,'(a)') 'gzip' else write(outstr,'(a)') 'none' end if end if nmapped=0 nlines=0 pos_id=3+vcfhash%offset do call readline(port, slin, ios=ioerr) if (ioerr /= 0) exit nlines=nlines+1 if (slin(1:6) == '#CHROM') exit end do if (ioerr == 0) then write(outstr,'(/a/a)') & 'VCF File Locus Line Index: address block line', & '-------------------- ---- -------------------------' if (port%filtyp == PORT_BGZIPPED) then do call readline(port, slin, ios=ioerr) if (ioerr /= 0) exit nlines=nlines+1 call getword(slin, pos_id, locnam) call find_hashtab(trim(locnam), vcfhash%loc, vcfhash%lochash, pos) if (pos > 0) then nmapped=nmapped+1 if (nmapped < 5 .or. plevel > 1) then write(outstr,'(a20,4(1x,i0))') & locnam, nlines, vcfhash%line_position(pos), & vcfhash%block_address(pos), vcfhash%line_address(pos) end if else if (plevel > 1) then write(outstr,'(a20,1x,i0,a)') locnam, nlines, ' - - -' end if end do else do call readline(port, slin, ios=ioerr) if (ioerr /= 0) exit nlines=nlines+1 call getword(slin, pos_id, locnam) call find_hashtab(trim(locnam), vcfhash%loc, vcfhash%lochash, pos) if (pos > 0) then nmapped=nmapped+1 if (nmapped < 5 .or. plevel > 1) then write(outstr,'(a20,4(1x,i0))') & locnam, pos, vcfhash%line_position(pos), & vcfhash%line_address(pos), nlines end if else if (plevel > 1) then write(outstr,'(a20,a)') locnam, ' - - - -' end if end do end if end if call close_port(port, ioerr) write(outstr,'(/a,i0)') & 'Validated loci = ', nmapped end subroutine check_vcfhash ! ! Move to position corresponding to genomic location in vcfhash VCF file ! stat= 0 exact position ! -1 not present in indices ! -2 read error ! subroutine moveto_vcf(vcfhash, pos_str, port, slin, stat) use iobuff use outstream use scanner use fileio type (vcfhash_table), intent(in) :: vcfhash character(len=*), intent(in) :: pos_str type (ioport) :: port character(len=*) :: slin integer, intent(out) :: stat integer :: bin_id, bin_idx, eol, i, ioerr, j, k, n, nend, & pos, sep, seq_idx, spos logical :: fnd character(len=512) :: word integer(kind=8) :: boff, bpos ! functions integer :: ival, tobp stat=-1 if (vcfhash%compression_type == BGZF_COMP) then call find_hashtab(pos_str, vcfhash%loc, vcfhash%lochash, pos) if (pos > 0) then call bgzf_seek(port, vcfhash%block_address(pos), & vcfhash%line_position(pos), ioerr) if (ioerr == 0) then stat=ioerr return else write(outstr, '(3a,1x,i0)') & 'search_vcfhash for "', pos_str, '" failed with ioerr= ', ioerr end if end if else call find_hashtab(pos_str, vcfhash%loc, vcfhash%lochash, pos) if (pos > 0) then call seek_port(port, vcfhash%line_position(pos), ioerr) if (ioerr == 0) then stat=ioerr return else write(outstr, '(3a,1x,i0)') & 'search_vcfhash for "', pos_str, '" failed with ioerr= ', ioerr end if end if end if end subroutine moveto_vcf ! subroutine search_vcfhash(ntrget, trget, vcfhash) use outstream use locus_data use locus_list use lochash_class use scanner use fileio integer, intent(in) :: ntrget character (len=*), dimension(ntrget), intent(in) :: trget type (vcfhash_table), intent(in) :: vcfhash ! type (ioport) :: port character (len=80) :: locnam character (len=256) :: slin integer :: i, ioerr, pos ! if (vcfhash%nmapped == 0) then ! write(outstr,'(3a)') & ! 'NOTE: No mapped loci in "', trim(vcfhash%filnam),'".' ! return ! end if call open_port(vcfhash%filnam, port, 'r', ioerr) if (ioerr /= 0) then write(outstr,'(3a)') & 'ERROR: Could not open VCF file "', trim(vcfhash%filnam),'".' return end if if (vcfhash%compression_type == BGZF_COMP) then do i=1, ntrget call find_hashtab(trim(trget(i)), vcfhash%loc, vcfhash%lochash, pos) if (pos > 0) then call bgzf_seek(port, vcfhash%block_address(pos), & vcfhash%line_position(pos), ioerr) if (ioerr == 0) then call readline(port, slin, ios=ioerr) write(outstr, '(a)') slin(1:72) else write(outstr, '(3a,1x,i0)') & 'search_vcfhash for "', trim(trget(i)),'" failed with ioerr= ', ioerr end if end if end do else do i=1, ntrget call find_hashtab(trim(trget(i)), vcfhash%loc, vcfhash%lochash, pos) if (pos > 0) then call seek_port(port, vcfhash%line_position(pos), ioerr) if (ioerr == 0) then call readline(port, slin, ios=ioerr) write(outstr, '(a)') slin(1:72) else write(outstr, '(3a,1x,i0)') & 'search_vcfhash for "', trim(trget(i)),'" failed with ioerr= ', ioerr end if end if end do end if call close_port(port, ios) end subroutine search_vcfhash ! ! Get annotation from hashed VCF file ! subroutine getvcfanno2(typ, nterms, terms, vcfhash, plevel) use interrupt use storage_classes use iobuff use outstream use scanner use locstring_widths use locus_types use fileio use locus_data use locus_list integer, intent(in) :: typ integer, intent(in) :: nterms character (len=*), dimension(:), intent(inout) :: terms type (vcfhash_table), intent(in) :: vcfhash integer, intent(in) :: plevel type (ioport) :: port ! local variables integer, parameter :: WORDLEN=35 character (len=1), parameter :: tab = achar(9) ! integer :: i, ioerr, mapped, narg, nfound, & ninfovars, ninfosubvars, nmar, offset, pos, & sta, nter character (len=WORDLEN), dimension(:), allocatable :: words character (len=WORDLEN) :: curloc character (len=1) :: subsep character (len=8192) :: slin character (len=8192) :: locinfo ! functions character (len=8) :: wrpercent double precision :: fval if (vcfhash%nmapped == 0) then write(outstr,'(3a)') & 'NOTE: No mapped loci in "', trim(vcfhash%filnam),'".' return end if call open_port(vcfhash%filnam, port, 'r', ioerr) if (ioerr /= 0) then write(outstr,'(3a)') & 'ERROR: Could not open VCF file "', trim(vcfhash%filnam),'".' return end if nter=nterms subsep='|' if (len_trim(terms(nterms)) == 1) then nter=nter-1 subsep=terms(nterms) end if mapped=0 ninfovars=0 ninfosubvars=0 do j=1, nter if (terms(j) == 'current') nfound=nfound+1 if (terms(j) == 'alleles') nfound=nfound+1 end do do call readline(port, slin, ios=ioerr) if (ioerr /= 0) exit call info_description(nter, terms, subsep, slin, & nfound, ninfovars, ninfosubvars, plevel) if (slin(1:2) /= '##') exit end do write(outstr,'(a,i0)', advance='no') 'No. INFO vars = ', ninfovars if (ninfosubvars > 0) then write(outstr,'(1x,a,i0,a)') '(', ninfosubvars,' subvars)' else write(outstr,*) end if if (plevel > 0) then write(outstr,'(3a)') 'Subvar sep = "', subsep, '"' end if ! if (nfound > 0 .and. ioerr == 0) then do i=1, nloci if (isactive(loctyp(i))) then call find_hashtab(trim(loc(i)), vcfhash%loc, vcfhash%lochash, pos) if (pos > 0) then call bgzf_seek(port, vcfhash%block_address(pos), & vcfhash%line_position(pos), ioerr) if (ioerr == 0) then mapped=mapped+1 call readline(port, slin, ios=ioerr) locinfo=locnotes(i) call extract_annotation(nter, terms, subsep, slin, locinfo) if (typ == 1) then locnotes(i)=trim(locinfo) // ' ' // locnotes(i) else if (locinfo /= '.') then locinfo=locinfo((scan(locinfo,'=')+1):len(locinfo)) if (scan(locinfo, ',') > 0) then locinfo=locinfo(1:(scan(locinfo, ',')-1)) end if locstat(i)=fval(locinfo) end if end if end if end if end if end do end if write(outstr,'(a,i0)') 'Number of annotations updated = ', mapped call close_port(port, ioerr) end subroutine getvcfanno2 ! ! Reorder VCF file following Sib-pair locus order - needs to be hashed ! subroutine reorder_vcf(vcfhash, infil, outfil, liftover) use outstream use scanner use fileio use locus_types use locus_data use locus_list use automatic_data type (vcfhash_table), intent(inout) :: vcfhash character (len=*), intent(in) :: infil, outfil logical, intent(in), optional :: liftover integer, parameter :: BUFLEN=32768 character (len=BUFLEN) :: buffer type (ioport) :: iport, oport logical :: header, nextline, updatemap integer :: i, ioerr, nmark, nused integer :: newpos, oldpos, pos1, pos2 character(len=20) :: mappos call cntmark(nloci, loctyp, nmark, 3) if (nmark == 0) then write(outstr,'(3a)') 'ERROR: No active map to select/order by!' return end if ! check if readable/writeable, but need to close input file for make_vcfhash then reopen call open_port(infil, iport, 'r', ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open input VCF file "', trim(infil), '".' return end if call close_port(iport, ioerr) call open_port(outfil, oport, 'w', ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open output VCF file "', trim(outfil), '".' return end if if (vcfhash%filnam /= infil) then write(outstr,'(3a)') 'Indexing input VCF file "', trim(infil), '".' call make_vcfhash(trim(infil), vcfhash, 0) end if call open_port(infil, iport, 'r', ioerr) ! header nextline=.true. header=.true. do call readline(iport, buffer, advance='no', ios=ioerr) if (nextline) then header=(buffer(1:2) == '##') nextline=.false. end if if (ioerr == eolcode) then write(oport%fstream,'(a)') trim(buffer) if (header) then nextline=.true. cycle else exit end if else if (ioerr /= 0) then exit end if write(oport%fstream,'(a)', advance='no') buffer end do ! through active loci updatemap=.false. if (present(liftover)) updatemap=liftover nwritten=0 ! change map position in VCF file if requested if (updatemap) then do i=ENVNUM+1, nloci if (isactive(loctyp(i))) then call moveto_vcf(vcfhash, trim(loc(i)), iport, buffer, ioerr) if (ioerr == 0) then nwritten=nwritten+1 call readline(iport, buffer, advance='no', ios=ioerr) call getword(buffer, 2, mappos) oldpos=ival(mappos) newpos=nint(1.0d6*map(i)) if (oldpos /= newpos .and. newpos > 0) then write(mappos,'(i20)') newpos mappos=adjustl(mappos) pos1=wordpos(buffer, 1) pos2=wordpos(buffer, 2) if (ioerr == eolcode) then write(oport%fstream,'(3a)') & buffer(1:pos1), trim(mappos), buffer(pos2:len(buffer)) cycle else write(oport%fstream,'(3a)', advance='no') & buffer(1:pos1), trim(mappos), buffer(pos2:len(buffer)) end if else if (ioerr == eolcode) then write(oport%fstream,'(a)') trim(buffer) cycle else write(oport%fstream,'(a)', advance='no') buffer end if end if do call readline(iport, buffer, advance='no', ios=ioerr) if (ioerr == eolcode) then write(oport%fstream,'(a)') trim(buffer) exit else if (ioerr /= 0) then exit end if write(oport%fstream,'(a)', advance='no') buffer end do else write(outstr,'(3a,i0)') & 'NOTE: Could not find ', trim(loc(i)),'! ioerr=', ioerr end if end if end do else do i=ENVNUM+1, nloci if (isactive(loctyp(i))) then call moveto_vcf(vcfhash, trim(loc(i)), iport, buffer, ioerr) if (ioerr == 0) then nwritten=nwritten+1 do call readline(iport, buffer, advance='no', ios=ioerr) if (ioerr == eolcode) then write(oport%fstream,'(a)') trim(buffer) exit else if (ioerr /= 0) then exit end if write(oport%fstream,'(a)', advance='no') buffer end do else write(outstr,'(3a,i0)') & 'NOTE: Could not find ', trim(loc(i)),'! ioerr=', ioerr end if end if end do end if call close_port(iport, ioerr) call close_port(oport, ioerr) write(outstr,'(/a,i0,3a)') & 'Wrote ', nwritten, ' records to VCF file "', trim(oport%filnam), '".' end subroutine reorder_vcf end module vcfhash_class ! ! GTF (GFF, GVF) ! module gtftools contains subroutine get_varinfo(lin, locnam, refall, altall) use scanner character (len=*), intent(in) :: lin character (len=*), intent(out) :: locnam character (len=*), intent(out) :: refall, altall character (len=2048) :: locinfo character (len=64) :: word integer :: eol, i, narg, nampos, stat locnam=' ' refall=' ' altall=' ' call getword(lin, 9, locinfo, char(9)) eol=len_trim(locinfo) n=0 i=1 stat=0 do while (stat == 0) call nextword(i, locinfo, eol, opchar, n, word, stat, ';', SEP_CHAR) if (word(1:6) == 'Dbxref') then nampos=index(word, ':') if (nampos > 0) then locnam=word((nampos+1):len_trim(word)) end if else if (word(1:9) == 'marker_id') then nampos=index(word, '=') locnam=word((nampos+1):len_trim(word)) else if (word(1:14) == 'Reference_seq=') then refall=word(15:len_trim(word)) else if (word(1:11) == 'ref_allele=') then refall=word(12:len_trim(word)) else if (word(1:12) == 'Variant_seq=') then altall=word(13:len_trim(word)) else if (word(1:11) == 'alt_allele=') then altall=word(12:len_trim(word)) end if end do end subroutine get_varinfo end module gtftools ! ! FASTA .fa and .fai index file ! .fai contains 5 tab-delimited fields per record (made by faidx or Sib-pair): ! ! NAME Name of this reference sequence ! LENGTH Total length of this reference sequence, in bases ! OFFSET Offset within the FASTA file of this sequence's first base ! LINEBASES The number of bases on each line, usually 60 ! LINEWIDTH The number of bytes in each line, including the newline ! ! .fa file is description string (one line), then corresponding sequence ! module fastatools use idhash_class type fasta_data character (len=1024) :: filnam integer :: iport ! buffer containing indices integer :: number_sequences = 0 character (len=20), dimension(:), allocatable :: chrom integer (kind=8), dimension(:), allocatable :: chromlen, start integer, dimension(:), allocatable :: linlen, blen type (hash_table) :: seqhash ! current position end type fasta_data contains subroutine open_fasta(fil, fasta_container, stat) use fileio use scanner implicit none character (len=*), intent(in) :: fil type (fasta_data) :: fasta_container integer, intent(out) :: stat ! character (len=128) :: lin integer :: i, ioerr, iport, narg, nseq logical :: ios stat=-1 inquire(file=trim(fil), exist=ios) if (.not.ios) then write(outstr,'(3a)') & 'ERROR: Could not open fasta file "', trim(fil), '".' return end if call newlun(iport) open(iport, file=trim(fil) // '.fai', status='old', iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a/7x,a)') & 'ERROR: Could not open .fai index file "', trim(fil) // '.fai' ,'".', & 'Try "file fasta index".' return end if nseq=0 do read(iport,*, iostat=ioerr) if (ioerr /= 0) exit nseq=nseq+1 end do fasta_container%filnam=fil fasta_container%number_sequences=nseq allocate(fasta_container%chrom(nseq)) allocate(fasta_container%chromlen(nseq), fasta_container%start(nseq)) allocate(fasta_container%linlen(nseq), fasta_container%blen(nseq)) call setup_hash(HK_CHROM, nseq, fasta_container%seqhash, 90) rewind(iport) do i=1, nseq read(iport,*) fasta_container%chrom(i), & fasta_container%chromlen(i), fasta_container%start(i), & fasta_container%linlen(i), fasta_container%blen(i) end do call fill_hash(fasta_container%seqhash,fasta_container%chrom) close(iport, status='keep') call newlun(fasta_container%iport) open(fasta_container%iport, file=trim(fil), status='old', & form='formatted', access='stream', iostat=ioerr) if (ioerr /= 0) return stat=0 end subroutine open_fasta ! subroutine close_fasta(fasta_container) type (fasta_data) :: fasta_container integer :: iport close(fasta_container%iport, status='keep') deallocate(fasta_container%chrom) deallocate(fasta_container%chromlen, fasta_container%start) deallocate(fasta_container%linlen, fasta_container%blen) call cleanup_hash(fasta_container%seqhash) end subroutine close_fasta ! ! Retrieve reference sequence at given position ! subroutine get_fastaref(group, bp, fasta_container, refall) character (len=*), intent(in) :: group integer(kind=8), intent(in) :: bp type (fasta_data) :: fasta_container character (len=*), intent(out) :: refall integer :: nread, segment, seqlen integer(kind=8) :: bp1, idx, blen8, linlen8 refall='.' seqlen=len(refall) call find_hashtab(group, fasta_container%chrom, & fasta_container%seqhash, segment) if (segment == 0) then call find_hashtab('chr' // group, fasta_container%chrom, & fasta_container%seqhash, segment) if (segment == 0) return end if if (bp > fasta_container%chromlen(segment)) return bp1=bp-1 blen8=fasta_container%blen(segment) linlen8=fasta_container%linlen(segment) idx=fasta_container%start(segment) + & (bp1/linlen8)*blen8 + mod(bp1, linlen8) + 1 rewind(fasta_container%iport) read(fasta_container%iport,'(a)', pos=idx, err=200) refall ! if (seqlen > 1) then do nread=len_trim(refall) if (nread >= seqlen) exit if ((bp + int(nread, kind=8)) >= fasta_container%chromlen(segment)) exit read(fasta_container%iport,'(a)', err=200) refall((nread+1):seqlen) end do end if return ! 200 continue return end subroutine get_fastaref ! ! summary of FASTA file ! subroutine show_fasta(fasta_container, plevel) use outstream type (fasta_data), intent(in) :: fasta_container integer, intent(in) :: plevel integer :: i, n double precision :: totlen write(outstr,'(/2a/a,i0//a/a)') & 'FASTA file = ', trim(fasta_container%filnam), & 'Number of sequences = ', fasta_container%number_sequences, & 'Sequence Length (bp) Cumulative (Mbp)', & '-------------------- ------------ ----------------' totlen=0.0d0 n=fasta_container%number_sequences if (plevel < 1) n=min(26, n) do i=1, n totlen=totlen+1.0d-6*dble(fasta_container%chromlen(i)) write(outstr,'(a,i13,2x,g14.6)') & fasta_container%chrom(i), fasta_container%chromlen(i), totlen end do if (n < fasta_container%number_sequences) then do i=n+1, fasta_container%number_sequences totlen=totlen+1.0d-6*dble(fasta_container%chromlen(i)) end do write(outstr,'(a/a,i13,2x,g14.6)') & '...', fasta_container%chrom(fasta_container%number_sequences), & fasta_container%chromlen(fasta_container%number_sequences), & totlen end if end subroutine show_fasta ! ! wrapper for get_fastaref ! subroutine query_fastaseq(fil, mappos, seqlen) use outstream character (len=*), intent(in) :: fil character (len=*), intent(in) :: mappos integer, intent(in) :: seqlen type (fasta_data) :: fasta_container integer :: astat, reslen, seppos integer(kind=8) :: bp character(len=seqlen) :: res if (seqlen < 1) return bp=0 seppos=index(mappos, ':') if (seppos > 0) then read(mappos((seppos+1):len_trim(mappos)),'(i20)') bp if (bp > 0) then call open_fasta(fil, fasta_container, astat) if (astat /= 0) return call get_fastaref(mappos(1:(seppos-1)), bp, fasta_container, res) reslen=len_trim(res) if (reslen == 1) then write(outstr,'(3a)') trim(mappos), ': ', trim(res) else write(outstr,'(2a,i0,2a)') & trim(mappos), '-', bp+len_trim(res)-1, ': ', trim(res) end if call close_fasta(fasta_container) else write(outstr,'(3a)') & 'ERROR: Could not extract a bp position from "', & mappos((seppos+1):len_trim(mappos)), '".' end if else write(outstr,'(a)') 'ERROR: Expected a position of form seq:bp.' end if end subroutine query_fastaseq ! ! wrapper for show_fasta ! subroutine query_fasta(fil, plevel) character (len=*), intent(in) :: fil integer, intent(in) :: plevel type (fasta_data) :: fasta_container integer :: astat call open_fasta(fil, fasta_container, astat) if (astat /= 0) return call show_fasta(fasta_container, plevel) call close_fasta(fasta_container) end subroutine query_fasta ! ! Make an faindex type index file ! subroutine index_fasta(fil, stat) use fileio use outstream use scanner integer, parameter :: BUFLEN=512 character (len=*), intent(in) :: fil character (len=BUFLEN) :: lin character (len=20) :: word integer, intent(out) :: stat integer :: iport, iport_fai, linlen, newlin_width, nseq logical :: ios integer (kind=8) :: nletters, nlines, offset stat=-1 call newlun(iport) open(iport, file=trim(fil), status='old', iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') & 'ERROR: Could not open fasta file "', trim(fil), '".' return end if stat=-2 read(iport,'(a)', iostat=ioerr) lin if (lin(1:1) /= '>' .or. ioerr /= 0) then write(outstr,'(3a)') & 'ERROR: Putative FASTA file starts "', trim(lin) // '".' close(iport, status='keep') return end if ! read(iport,'(a)', iostat=ioerr) lin linlen=len_trim(lin) rewind(iport) if (linlen == BUFLEN) then write(outstr,'(a,i0,a)') & 'ERROR: Sorry, line length exceeds ', BUFLEN-1, ' characters.' close(iport, status='keep') return end if stat=-3 inquire(file=trim(fil // '.fai'), exist=ios) if (ios) then write(outstr,'(3a)') & 'NOTE: Overwriting old index file "', trim(fil) // '.fai".' end if call newlun(iport_fai) open(iport_fai, file=trim(fil) // '.fai', iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') & 'ERROR: Could not open .fai index file "', trim(fil) // '.fai".' close(iport, status='keep') return end if newlin_width=1 nlines=0 nseq=0 nletters=0 offset=0 do read(iport,'(a)', iostat=ioerr) lin if (ioerr /= 0) exit nlines=nlines+1 if (lin(1:1) /= '>') then nletters=nletters+len_trim(lin) else if (lin(1:1) == '>') then if (nseq > 0) then write(iport_fai,'(2a,i0,a,i0,a,i0,a,i0)') & trim(word), char(9), nletters, char(9), offset, char(9), & linlen, char(9), linlen+newlin_width end if nseq=nseq+1 call getword(lin, 1, word) word=word(2:len_trim(word)) // ' ' offset=offset+nletters+len_trim(lin)+nlines*newlin_width nletters=0 nlines=0 end if end do write(iport_fai,'(2a,i0,a,i0,a,i0,a,i0)') & trim(word), char(9), nletters, char(9), offset, char(9), & linlen, char(9), linlen+newlin_width close(iport, status='keep') close(iport_fai, status='keep') write(outstr,'(a,i0,a)') 'Indexed ', nseq, ' sequences.' stat=0 end subroutine index_fasta end module fastatools ! ! an object representing genotype data in a file ! module genofile_class use fileio use vcftools type genofile_data character (len=1024) :: filnam integer :: filtyp ! 1=VCF integer :: filstat ! 0=closed 1=open -1=error type (ioport) :: port ! mapping from Sib-pair ids to VCF integer, dimension(:), allocatable :: sample_idx ! buffer containing genotypes integer (kind=2), dimension(:,:), allocatable :: genotypes ! current position integer :: filpos end type genofile_data contains subroutine genofile_create(filnam, f) character (len=*) :: filnam type (genofile_data) :: f integer :: ios character (len=128) :: lin type (ioport) :: port call openvcf(filnam, port, lin, ios) if (ios == 0) then f%filstat = 1 f%port=port end if end subroutine genofile_create subroutine genofile_destroy(f) type (genofile_data) :: f integer :: ios if (f%filstat == 1) then call close_port(f%port, ios) deallocate(f%sample_idx) f%filstat = 0 end if end subroutine genofile_destroy ! ! Test if matrix allocated/active ! function genofile_active(f) logical :: genofile_active type (genofile_data) :: f genofile_active=(f%filstat==1) end function genofile_active end module genofile_class ! ! The one big pedigree data structure ! Updating size requires copying entire structure ! (hopefully maintaining contiguous storage) ! ! Preliminary work to make ID string widths adjustable ! module idstring_widths integer :: ped_width_adj = 30 integer :: id_width_adj = 35 integer, parameter :: ped_width = 30 integer, parameter :: id_width = 35 end module idstring_widths module ped_class use matrix_class use storage_classes use idstring_widths use showcomponent type ped_data integer :: nped ! number of pedigrees integer :: nact ! number of active pedigrees integer :: maxsiz ! size of largest pedigree integer :: maxact ! size of largest active pedigree integer :: nobs ! number of records integer, dimension(NDATACLASS) :: numloc ! number of columns of data integer, dimension(NDATACLASS) :: numcol ! number of available columns ! ! indicate if SNP genotype data is present and storage type 1=byte 2=bit integer :: hassnps ! pedigree level data character (len=ped_width), dimension(:), allocatable :: pedigree integer, dimension(:), allocatable :: num integer, dimension(:), allocatable :: nfound integer, dimension(:), allocatable :: actset ! individual level data integer, dimension(:), allocatable :: iped integer, dimension(:), allocatable :: imztwin character (len=id_width), dimension(:), allocatable :: id integer, dimension(:), allocatable :: fa integer, dimension(:), allocatable :: mo integer, dimension(:), allocatable :: sex ! ! phenotypes of classes 1..NDATACLASS ! SCLASS=1-byte integer ! GCLASS=2-byte integer ! PCLASS=8-byte real ! type (matrix_i1) :: slocus ! integer (kind=2), dimension(:,:), allocatable :: glocus double precision, dimension(:,:), allocatable :: plocus ! useful work arrays -- usually referring to locus being currently analysed logical, dimension(:), allocatable :: untyped end type ped_data ! ! Genotype coding scheme integer, parameter :: SNP_NIL = 0, SNP_ONE = 1, SNP_TWO = 2 integer, save :: snpstorage = SNP_ONE contains ! ! allocate pedigree data ! subroutine setup_peds(nped, nobs, numloc, numcol, & dataset, astat, plevel) use outstream integer :: nobs, nped integer, dimension(NDATACLASS) :: numloc ! number of columns of data integer, dimension(NDATACLASS) :: numcol ! number of available columns type (ped_data) :: dataset integer :: astat, plevel integer :: igeno, ipheno, isnps, sstat logical :: gfallback, pfallback, sfallback astat=-1 if (numcol(SCLASS) < numloc(SCLASS)) then write(*,'(a,i0,a,i0)') & 'ERROR: More SNPs than declared space! numloc=', numloc(SCLASS), & ' numcol=', numcol(SCLASS) return end if if (numcol(GCLASS) < numloc(GCLASS)) then write(*,'(a,i0,a,i0)') & 'ERROR: More markers than declared space! numloc=', numloc(GCLASS), & ' numcol=', numcol(GCLASS) return end if if (numcol(PCLASS) < numloc(PCLASS)) then write(*,'(a,i0,a,i0)') & 'ERROR: More phenotypes than declared space! numloc=', numloc(PCLASS), & ' numcol=', numcol(PCLASS) return end if astat=0 sstat=0 if (allocated(dataset%plocus)) then call cleanup_peds(dataset) end if isnps=numcol(SCLASS) igeno=numcol(GCLASS) ipheno=numcol(PCLASS) if (plevel > 1) then write(outstr,'(3(/a,i0))') & 'Number of declared SNPs = ', isnps/2, & 'Number of declared markers = ', igeno/2, & 'Number of declared phenotypes = ', ipheno end if dataset%nped = nped dataset%nact = nped dataset%maxsiz = 0 dataset%maxact = 0 dataset%nobs = nobs dataset%hassnps = 0 allocate(dataset%pedigree(nped)) allocate(dataset%num(0:nped)) allocate(dataset%nfound(nped)) allocate(dataset%actset(nped)) dataset%num(0)=0 allocate(dataset%iped(nobs)) allocate(dataset%imztwin(nobs)) allocate(dataset%id(nobs)) allocate(dataset%fa(nobs)) allocate(dataset%mo(nobs)) allocate(dataset%sex(nobs)) allocate(dataset%untyped(nobs)) allocate(dataset%plocus(nobs, ipheno), stat=astat) if (astat /= 0) then write(*,'(a/a,i0,a,i0,a)') & 'Unable to allocate phenotype storage array!', & 'Tried to allocate plocus(', nobs,',', ipheno,').' return else if (plevel > 1) then write(outstr,'(a,i0,a,i0,a)') & 'NOTE: Allocated plocus(', nobs, ',', ipheno, ').' end if allocate(dataset%glocus(nobs, igeno), stat=astat) if (astat /= 0) then write(*,'(a/a,i0,a,i0,a)') & 'Unable to allocate genotype storage array!', & 'Tried to allocate glocus(', nobs,',', igeno,').' return else if (plevel > 1) then write(outstr,'(a,i0,a,i0,a)') & 'NOTE: Allocated glocus(', nobs, ',', igeno, ').' end if if (isnps > 0) then dataset%hassnps = snpstorage end if call matrix_create(nobs, isnps, dataset%slocus, sstat) if (sstat /= 0) then write(*,'(a/a,i0,a,i0,a)') & 'Unable to allocate SNP genotype storage array!', & 'Tried to allocate slocus(', nobs,',', isnps,').' astat=sstat else if (plevel > 1) then write(outstr,'(a,i0,a,i0,a)') & 'NOTE: Allocated slocus(', nobs, ',', isnps, ').' end if dataset%numloc(PCLASS) = numloc(PCLASS) dataset%numcol(PCLASS) = ipheno dataset%numloc(GCLASS) = numloc(GCLASS) dataset%numcol(GCLASS) = igeno dataset%numloc(SCLASS) = numloc(SCLASS) dataset%numcol(SCLASS) = isnps dataset%numloc(TCLASS) = numloc(GCLASS)+numloc(PCLASS)+numloc(SCLASS) dataset%numcol(TCLASS) = numcol(GCLASS)+numcol(PCLASS)+numloc(SCLASS) end subroutine setup_peds ! ! copy pedigree data ! subroutine copy_peds(set1, set2) type (ped_data) :: set1, set2 integer :: i, iflag, isnps, ipheno, igeno, nobs, nped if (set1%nobs /= set2%nobs .or. set1%nped /= set2%nped) then write(*,'(a)') 'ERROR: In copy_peds, unequal dimensions!' end if nobs=min(set1%nobs, set2%nobs) nped=min(set1%nped, set2%nped) ipheno=min(set1%numloc(PCLASS), set2%numloc(PCLASS)) igeno=min(set1%numloc(GCLASS), set2%numloc(GCLASS)) isnps=min(set1%numloc(SCLASS), set2%numloc(SCLASS)) set2%nped = set1%nped set2%nact = set1%nact set2%maxsiz = set1%maxsiz set2%maxact = set1%maxact set2%nobs = set1%nobs do i=0, nped set2%num(i) = set1%num(i) end do do i=1, nped set2%pedigree(i) = set1%pedigree(i) set2%nfound(i) = set1%nfound(i) set2%actset(i) = set1%actset(i) end do do i=1, nobs set2%iped(i) = set1%iped(i) set2%imztwin(i) = set1%imztwin(i) set2%id(i) = set1%id(i) set2%fa(i) = set1%fa(i) set2%mo(i) = set1%mo(i) set2%sex(i) = set1%sex(i) end do if (isnps /= 0) then set2%hassnps = snpstorage call matrix_copy(set1%slocus, set2%slocus, iflag) end if set2%glocus(1:nobs,1:igeno) = set1%glocus(1:nobs,1:igeno) set2%plocus(1:nobs,1:ipheno) = set1%plocus(1:nobs,1:ipheno) end subroutine copy_peds ! ! deallocate pedigree structure arrays ! subroutine cleanup_peds(dataset) type (ped_data) :: dataset if (allocated(dataset%plocus)) then deallocate(dataset%pedigree) deallocate(dataset%num) deallocate(dataset%nfound) deallocate(dataset%actset) deallocate(dataset%iped) deallocate(dataset%imztwin) deallocate(dataset%id) deallocate(dataset%fa) deallocate(dataset%mo) deallocate(dataset%sex) deallocate(dataset%plocus) deallocate(dataset%untyped) end if if (allocated(dataset%glocus)) then deallocate(dataset%glocus) end if if (matrix_active(dataset%slocus)) then call matrix_destroy(dataset%slocus) end if dataset%nped=0 dataset%nact=0 dataset%maxsiz=0 dataset%maxact=0 dataset%nobs=0 dataset%hassnps=0 dataset%numloc(:)=0 dataset%numcol(:)=0 end subroutine cleanup_peds ! ! insert a new pedigree member into active dataset ! 1. unrelated, new pedigree ! 2. unrelated, existing pedigree ! 3. parent of index ! 4. offspring of mating ! ! Low level insertion of a record before/after position in same pedigree ! Pedigree level variables num and nfound are updated ! subroutine insert_new_record(pos, dataset, stat, before) integer, intent(in) :: pos type (ped_data) :: dataset integer, intent(out), optional :: stat logical, intent(in), optional :: before integer, parameter :: MISS=-9999 type (ped_data) :: tempset integer :: astat, curped, i, iflag, isnps, ipheno, igeno, & newpos, nobs, offset, oldpos, ped integer, dimension(dataset%nobs) :: idx, tmpvar character (len=id_width), dimension(dataset%nobs) :: tmpstring if (present(stat)) stat=-1 if (pos < 1 .or. pos > dataset%nobs) return nobs=dataset%nobs dataset%nobs=nobs+1 curped=dataset%iped(pos) if (dataset%num(curped)-dataset%num(curped-1) == dataset%maxsiz) then dataset%maxsiz=dataset%maxsiz+1 end if if (pos < dataset%num(curped)+dataset%nfound(curped)+1) then dataset%nfound(curped)=dataset%nfound(curped)+1 end if do ped=curped, dataset%nped dataset%num(ped)=dataset%num(ped)+1 end do ipheno=dataset%numloc(PCLASS) igeno=dataset%numloc(GCLASS) isnps=dataset%numloc(SCLASS) offset=0 if (present(before)) then if (.not.before) offset=1 end if newpos=pos+offset oldpos=pos-offset+1 do i=1, newpos-1 idx(i)=i end do do i=newpos, nobs idx(i)=i+1 end do ! shuffle memory if (isnps /= 0) then call matrix_create(nobs, isnps, tempset%slocus, astat) if (astat /= 0) then write(*,'(a/a,i0,a,i0,a)') & 'Unable to allocate temporary SNP genotype storage array!', & 'Tried to allocate slocus(', nobs,',', isnps,').' if (present(stat)) stat=-2 return end if call matrix_copy(dataset%slocus, tempset%slocus, iflag) call matrix_copy(tempset%slocus, dataset%slocus, iflag, & newrows=nobs+1, rowfilter=idx) call matrix_destroy(tempset%slocus) end if allocate(tempset%glocus(nobs, igeno), stat=astat) tempset%glocus = dataset%glocus deallocate(dataset%glocus) allocate(dataset%glocus(nobs+1, igeno)) dataset%glocus(idx,1:igeno) = tempset%glocus(1:nobs,1:igeno) dataset%glocus(newpos,1:igeno) = MISS deallocate(tempset%glocus) allocate(tempset%plocus(nobs, ipheno), stat=astat) tempset%plocus = dataset%plocus deallocate(dataset%plocus) allocate(dataset%plocus(nobs+1, ipheno)) dataset%plocus(idx,1:ipheno) = tempset%plocus(1:nobs,1:ipheno) dataset%plocus(newpos,1:ipheno) = MISS deallocate(tempset%plocus) tmpvar=dataset%iped deallocate(dataset%iped) allocate(dataset%iped(nobs+1)) dataset%iped(idx)=tmpvar dataset%iped(newpos)=curped tmpvar=dataset%imztwin deallocate(dataset%imztwin) allocate(dataset%imztwin(nobs+1)) dataset%imztwin(idx)=tmpvar dataset%imztwin(newpos)=dataset%imztwin(oldpos) tmpvar=dataset%fa deallocate(dataset%fa) allocate(dataset%fa(nobs+1)) dataset%fa(idx)=tmpvar dataset%fa(newpos)=dataset%fa(oldpos) tmpvar=dataset%mo deallocate(dataset%mo) allocate(dataset%mo(nobs+1)) dataset%mo(idx)=tmpvar dataset%mo(newpos)=dataset%mo(oldpos) tmpvar=dataset%sex deallocate(dataset%sex) allocate(dataset%sex(nobs+1)) dataset%sex(idx)=tmpvar dataset%sex(newpos)=MISS deallocate(dataset%untyped) allocate(dataset%untyped(nobs+1)) dataset%untyped=.true. tmpstring=dataset%id deallocate(dataset%id) allocate(dataset%id(nobs+1)) dataset%id(idx)=tmpstring dataset%id(newpos)=trim(dataset%id(oldpos)) // '_dup' ! ! repoint ! do i=newpos, nobs+1 if (dataset%fa(i) >= newpos) dataset%fa(i)=dataset%fa(i)+1 if (dataset%mo(i) >= newpos) dataset%mo(i)=dataset%mo(i)+1 if (dataset%imztwin(i) >= newpos) dataset%imztwin(i)=dataset%imztwin(i)+1 end do if (present(stat)) stat=newpos end subroutine insert_new_record ! ! expand phenotype storage ! subroutine expand_pheno(newcol, dataset, astat) type (ped_data) :: dataset integer, intent(in) :: newcol integer, intent(out) :: astat integer, parameter :: MISS=-9999 integer :: oldcol, oldloc double precision, dimension(:,:), allocatable :: tmp astat=0 oldcol=dataset%numcol(PCLASS) oldloc=dataset%numloc(PCLASS) allocate(tmp(dataset%nobs,oldloc), stat=astat) if (astat /= 0) then write(*,'(a)') 'Unable to allocate work array!' return end if tmp=dataset%plocus(1:dataset%nobs,1:oldloc) deallocate(dataset%plocus) allocate(dataset%plocus(dataset%nobs, newcol)) dataset%plocus(1:dataset%nobs,1:oldloc)=tmp dataset%plocus(1:dataset%nobs,(oldloc+1):newcol)=MISS dataset%numcol(PCLASS)=newcol dataset%numcol(TCLASS)=dataset%numcol(TCLASS)-oldcol+newcol end subroutine expand_pheno ! ! expand genotype storage ! subroutine expand_geno(newcol, dataset, astat) type (ped_data) :: dataset integer, intent(in) :: newcol integer, intent(out) :: astat integer, parameter :: MISS=-9999 integer :: oldloc, oldcol integer(kind=2), dimension(:,:), allocatable :: tmp astat=0 oldcol=0 oldloc=0 if (.not.allocated(dataset%glocus)) then allocate(dataset%glocus(dataset%nobs, newcol), stat=astat) if (astat /= 0) then write(*,'(a/a,i0,a,i0,a)') & 'Unable to allocate genotype storage array!', & 'Tried to allocate glocus(', dataset%nobs,',', newcol,').' return end if dataset%glocus=0 else oldcol=dataset%numcol(GCLASS) oldloc=dataset%numloc(GCLASS) if (oldloc > 0) then allocate(tmp(dataset%nobs,oldloc), stat=astat) if (astat /= 0) then write(*,'(a)') 'Unable to allocate work array!' return end if tmp=dataset%glocus(1:dataset%nobs,1:oldloc) end if deallocate(dataset%glocus) allocate(dataset%glocus(dataset%nobs, newcol), stat=astat) if (astat /= 0) then write(*,'(a/a,i0,a,i0,a)') & 'Unable to allocate genotype storage array!', & 'Tried to allocate glocus(', dataset%nobs,',', newcol,').' return end if if (oldcol > 0) then dataset%glocus(1:dataset%nobs,1:oldloc)=tmp end if dataset%glocus(1:dataset%nobs,(oldloc+1):newcol)=0 end if dataset%numcol(GCLASS)=newcol dataset%numcol(TCLASS)=dataset%numcol(TCLASS)-oldcol+newcol end subroutine expand_geno ! ! expand SNP storage ! subroutine expand_sgeno(newcol, dataset, astat) type (ped_data) :: dataset integer, intent(in) :: newcol integer, intent(out) :: astat integer, parameter :: MISS=-9999 integer :: oldcol, oldloc type (matrix_i1) :: tmp astat=0 oldcol=0 oldloc=0 if (.not.matrix_active(dataset%slocus)) then call matrix_create(dataset%nobs, newcol, dataset%slocus, astat) if (astat /= 0) then write(*,'(a/a,i0,a,i0,a)') & 'Unable to allocate genotype storage array!', & 'Tried to allocate slocus(', dataset%nobs,',', newcol,').' return end if dataset%hassnps=snpstorage else oldcol=dataset%numcol(SCLASS) oldloc=dataset%numloc(SCLASS) call matrix_create(dataset%nobs, oldcol, tmp, astat) if (astat /= 0) then write(*,'(a)') 'Unable to allocate work array!' return end if call matrix_copy(dataset%slocus, tmp, astat) if (astat == 0) then call matrix_destroy(dataset%slocus) call matrix_create(dataset%nobs, newcol, dataset%slocus, astat) end if if (astat /= 0) then write(*,'(a/a,i0,a,i0,a)') & 'Unable to allocate genotype storage array!', & 'Tried to allocate slocus(', dataset%nobs,',', newcol,').' return end if dataset%hassnps=snpstorage call matrix_copy(tmp, dataset%slocus, astat, newcols=newcol) end if dataset%numcol(SCLASS)=newcol dataset%numcol(TCLASS)=dataset%numcol(TCLASS)-oldcol+newcol end subroutine expand_sgeno ! ! Extract a genotype either stored as alleles or SNP genotypes ! subroutine get_geno(idx, gcol1, gcol2, dataset, g1, g2) integer, intent(in) :: idx integer, intent(in) :: gcol1, gcol2 type (ped_data), intent(in) :: dataset integer, intent(out) :: g1, g2 integer (kind=1) :: ig integer :: iflag integer, parameter :: MISS=-9999 integer :: imaj, imin, is, g if (gcol1 > 0) then g1=dataset%glocus(idx, gcol1) g2=dataset%glocus(idx, gcol2) else if (dataset%hassnps == 2) then imaj=(-gcol1-1)/2 + 1 imin=4*mod(-gcol1-1, 2) call matrix_get_el(idx, imaj, dataset%slocus, ig, iflag) is=2*int(ibits(ig, imin, 1)) - 1 imin=imin+1 g=int(ibits(ig, imin, 2)) g1=MISS g2=MISS if (g == 1) then g1=is g2=g1 else if (g == 2) then g1=is g2=2*is else if (g == 3) then g1=2*is g2=g1 end if ! write(*,*) ! write(*,*) 'imaj, imin=', imaj, imin ! write(*,*) 'ibits4=', ibits(ig, imin, 4) ! write(*,*) 'ibits2=', ibits(ig, imin+1, 2) ! write(*,*) 'geno=', g1, '/', g2 else call matrix_get_el(idx, -gcol1, dataset%slocus, ig, iflag) g1=int(ig) call matrix_get_el(idx, 1-gcol1, dataset%slocus, ig, iflag) g2=int(ig) ! write(*,*) idx, gcol1, gcol2, ' 1 geno=', g1, '/', g2 if (abs(g1) > 64) g1=sign(10000,g1)+g1 if (abs(g2) > 64) g2=sign(10000,g2)+g2 ! write(*,*) ' 2 geno=', g1, '/', g2 end if end subroutine get_geno ! ! Transfer genotype to internal coding ! if snptyp = 1, then one allele per byte ! subroutine encode_geno1(g1, g2, ig1, ig2) integer, intent(in) :: g1, g2 integer (kind=1), intent(out) :: ig1, ig2 integer, parameter :: MISS = -9999 ig1=0 ig2=0 if (abs(g1) > 10000) then ig1=g1-sign(10000,g1) else if (g1 /= MISS) then ig1=g1 end if if (abs(g2) > 10000) then ig2=g2-sign(10000,g2) else if (g2 /= MISS) then ig2=g2 end if end subroutine encode_geno1 ! ! Transfer genotype to internal coding ! if snptyp = 2, then one genotype per byte ! subroutine encode_geno2(g1, g2, ig, whichpos) integer, intent(in) :: g1, g2 integer (kind=1), intent(in out) :: ig integer, intent(in) :: whichpos integer, parameter :: MISS = -9999 integer :: g ig=ibclr(ig, whichpos-1) ig=ibclr(ig, whichpos) ig=ibclr(ig, whichpos+1) ! sign bit (observed or unobserved) if (g1 == MISS) return g=g1+g2 if (0 < g .and. g < 5) then ig=ibset(ig, whichpos-1) end if g=abs(g) ! genotype 01=1/1 10=1/2 11=2/2 if (g == 3) then ig=ibclr(ig, whichpos) ig=ibset(ig, whichpos+1) else if (g == 4) then ig=ibset(ig, whichpos) ig=ibset(ig, whichpos+1) else if (g == 2) then ig=ibset(ig, whichpos) ig=ibclr(ig, whichpos+1) end if end subroutine encode_geno2 ! ! Set a genotype ! subroutine set_geno(idx, gcol1, gcol2, dataset, g1, g2) integer, intent(in) :: idx integer, intent(in) :: gcol1, gcol2 type (ped_data), intent(inout) :: dataset integer, intent(in) :: g1, g2 integer, parameter :: MISS=-9999 integer :: g, imaj, iflag, imin integer (kind=1) :: ig1, ig2 if (gcol1 > 0) then dataset%glocus(idx, gcol1)=g1 dataset%glocus(idx, gcol2)=g2 else if (dataset%hassnps == 2) then imaj=(-gcol1-1)/2 + 1 imin=4*mod(-gcol1-1, 2) + 1 ! missing genotype 00 call matrix_get_el(idx, imaj, dataset%slocus, ig1, iflag) call encode_geno2(g1, g2, ig1, imin) call matrix_set_el(ig1, idx, imaj, dataset%slocus, iflag) else call encode_geno1(g1, g2, ig1, ig2) call matrix_set_el(ig1, idx, -gcol1, dataset%slocus, iflag) call matrix_set_el(ig2, idx, -gcol1+1, dataset%slocus, iflag) end if end subroutine set_geno ! ! Test if genotype is observed ! function observed(idx, gcol, dataset) logical :: observed integer, intent(in) :: idx integer, intent(in) :: gcol type (ped_data), intent(in) :: dataset integer, parameter :: KNOWN=0 integer :: iflag, imaj, imin integer (kind=1) :: ig if (gcol > 0) then observed = (dataset%glocus(idx, gcol) > KNOWN) else if (dataset%hassnps == 2) then imaj=(-gcol-1)/2 + 1 imin=4*mod(-gcol-1, 2) call matrix_get_el(idx, imaj, dataset%slocus, ig, iflag) observed=(ibits(ig, imin, 1) == 1) else call matrix_get_el(idx, -gcol, dataset%slocus, ig, iflag) observed = (ig > KNOWN) end if end function observed ! function missing(idx, gcol, dataset) logical :: missing integer, intent(in) :: idx integer, intent(in) :: gcol type (ped_data), intent(in) :: dataset integer, parameter :: KNOWN=0, MISS = -9999 integer :: g, iflag, imaj, imin integer (kind=1) :: ig if (gcol > 0) then missing = (dataset%glocus(idx, gcol) == MISS) else if (dataset%hassnps == 2) then imaj=(-gcol-1)/2 + 1 imin=4*mod(-gcol-1, 2) call matrix_get_el(idx, imaj, dataset%slocus, ig, iflag) g=int(ibits(ig, imin+1, 2)) missing=(g == 0) ! write(*,*) ! write(*,*) 'imaj, imin=', imaj, imin ! write(*,*) 'ibits4=', ibits(dataset%slocus(idx, imaj), imin, 4) ! write(*,*) 'ibits2=', ibits(dataset%slocus(idx, imaj), imin+1, 2) ! write(*,*) else call matrix_get_el(idx, -gcol, dataset%slocus, ig, iflag) missing = (ig == KNOWN) end if end function missing ! subroutine show_ped_allocation(dataset, firstloc, lastloc, nshow) type (ped_data) :: dataset integer, intent(in) :: firstloc, lastloc, nshow integer :: i, j, highest, sta, fin, ter integer (kind=1) :: i1 sta=1 if (firstloc > 0) sta=firstloc fin=3 if (lastloc > 0) fin=lastloc highest=5 if (nshow > 0) highest=nshow write(*,'(a,1x,i0)') 'nped =', dataset%nped write(*,'(a,1x,i0)') 'nact =', dataset%nact write(*,'(a,1x,i0)') 'maxsiz =', dataset%maxsiz write(*,'(a,1x,i0)') 'maxact =', dataset%maxact write(*,'(a,1x,i0)') 'nobs =', dataset%nobs write(*,'(a,1x,i0)') 'hassnps =', dataset%hassnps if (dataset%hassnps > 0) then write(*,'(2a)') 'storage = ', matrix_type(dataset%slocus) write(*,'(a,1x,i0,a,i0)') & 'buffer =', dataset%nobs, '*', dataset%slocus%bufwidth end if write(*,'(4(a,i0))') & 'numloc = ', dataset%numloc(TCLASS), ' S:', dataset%numloc(SCLASS), & ' G:', dataset%numloc(GCLASS),' P:', dataset%numloc(PCLASS) write(*,'(5(a,i0))') & 'numcol = ', dataset%numcol(TCLASS), ' (=', & matrix_ncols(dataset%slocus) + size(dataset%glocus,2) + & size(dataset%plocus,2), & ') S:', dataset%numloc(SCLASS), & ' G:', dataset%numcol(GCLASS),' P:', dataset%numcol(PCLASS) ter=min(highest, dataset%nped) write(*,'(/a/a)') & 'Array Alloc? N : Values', & '-------- --------------------' call show_one_carray('pedigree', ':', 1, ter, allocated(dataset%pedigree), dataset%pedigree) call show_one_iarray('num', ': (0)', 1, ter, allocated(dataset%num), dataset%num) call show_one_iarray('nfound', ':', 1, ter, allocated(dataset%nfound), dataset%nfound) call show_one_iarray('actset', ':', 1, ter, allocated(dataset%actset), dataset%actset) ter=min(highest,dataset%nobs) call show_one_iarray('iped', ':', 1, ter, allocated(dataset%iped), dataset%iped) call show_one_iarray('imztwin', ':', 1, ter, allocated(dataset%imztwin), dataset%imztwin) call show_one_carray('id', ':', 1, ter, allocated(dataset%id), dataset%id) call show_one_iarray('fa', ':', 1, ter, allocated(dataset%fa), dataset%fa) call show_one_iarray('mo', ':', 1, ter, allocated(dataset%mo), dataset%mo) call show_one_iarray('sex', ':', 1, ter, allocated(dataset%sex), dataset%sex) write(*,'(a8,2x,l1)', advance='no') & 'slocus', matrix_active(dataset%slocus) if (matrix_active(dataset%slocus)) then write(*,'(i12,a)', advance='no') matrix_size(dataset%slocus), ' : ' do i=1, ter do j=sta,min(fin,dataset%numloc(SCLASS)/2) call matrix_get_el(i, j, dataset%slocus, i1, iflag) write(*,'(b8.8,a)', advance='no') i1, ' ' end do if (i < ter) write(*,'(a/26x)',advance='no') ';' end do end if write(*,'(/a8,2x,l1)', advance='no') 'glocus', allocated(dataset%glocus) if (allocated(dataset%glocus)) then write(*,'(i12,a)', advance='no') size(dataset%glocus), ' :' do i=1, ter write(*,'(20(1x,i0,a,i0):)', advance='no') & (dataset%glocus(i,j),'/',dataset%glocus(i,j+1), & j=sta,min(fin,dataset%numloc(GCLASS))) if (i < ter) write(*,'(a/25x)',advance='no') ';' end do end if write(*,'(/a8,2x,l1)', advance='no') 'plocus', allocated(dataset%plocus) if (allocated(dataset%plocus)) then write(*,'(i12,a)', advance='no') size(dataset%plocus), ' :' do i=1, ter write(*,'(20(1x,g14.6):)', advance='no') & (dataset%plocus(i,j),j=sta,min(fin,dataset%numloc(PCLASS))) if (i < ter) write(*,'(a/25x)',advance='no') ';' end do end if write(*,'(/a8,2x,l1)', advance='no') 'untyped', allocated(dataset%untyped) if (allocated(dataset%untyped)) then write(*,'(i12,a,(10l2/25x,10l2):)') & size(dataset%untyped), ' : ', dataset%untyped(1:ter) else write(*,*) end if end subroutine show_ped_allocation ! subroutine show_snp(idx, gpos, dataset) integer, intent(in) :: idx, gpos type (ped_data) :: dataset integer :: imaj, imin, g1, g2 integer (kind=1) :: i1 if (gpos < 1 .or. idx < 1 .or. idx > dataset%nobs .or. & .not.matrix_active(dataset%slocus)) return call get_geno(idx, -gpos, -gpos, dataset, g1, g2) imaj=(gpos-1)/2 + 1 imin=4*mod(gpos-1, 2) call matrix_get_el(idx, imaj, dataset%slocus, i1, iflag) write(*,'(i5,i5,1x,b8.8,1x,i1,a,i1,2(1x,a,l1),2(1x,a,i0),1x,4i1)') & idx, gpos, i1, g1,'/',g2, & 'obs=', observed(idx, -gpos, dataset), & 'mis=', missing(idx, -gpos, dataset), & 'imaj=', imaj, 'imin=', imin, & ibits(i1, imin, 1), & ibits(i1, imin+1, 1), & ibits(i1, imin+2, 1), & ibits(i1, imin+3, 1) end subroutine show_snp end module ped_class ! ! Pedigree storage ! module pedigree_data use ped_class use idhash_class ! Hash table for IDs type (hash_table), save :: hashtab ! Pedigree data type (ped_data), save :: work end module pedigree_data ! ! Allele frequency data structure ! module alleles_class private public :: allele_data, allele_array, & copyfreq, expand_alleles, cleanup_alleles, genot, & calc_gtp_freqs, setup_freq, calc_naive_freq_ase, & setup_allele_array, cleanup_allele_array type allele_data integer :: numal = 0 ! number of different alleles observed for marker integer :: numgtp = 0 ! number of possible genotypes for marker integer :: typed = 0 ! number of individuals genotyped at marker integer :: untyped = 0 ! number of individuals not genotyped at marker integer :: totall = 0 ! number of alleles integer :: minall = 0 ! least frequent allele integer :: topall = 0 ! most frequent allele logical :: xlinkd = .false. ! sex-linked logical :: issnp = .false. ! compressed storage SNP marker integer, dimension(:), allocatable :: allele_names ! allele names double precision, dimension(:), allocatable :: allele_freqs ! allele freqs double precision, dimension(:), allocatable :: cum_freqs ! cumulative allele freqs double precision, dimension(:), allocatable :: gtp_freqs ! (log) genotype freqs double precision, dimension(:), allocatable :: freq_stderrs ! allele freq standard errors end type allele_data type allele_array integer :: nmark = 0 ! number of markers integer, dimension(:), allocatable :: mark ! indices mapping to loci type (allele_data), dimension(:), allocatable :: alleles ! data for each marker end type allele_array contains ! ! initialize allele_data ! subroutine setup_freq(nall, allele_buffer) integer, intent(in) :: nall type (allele_data), intent(inout) :: allele_buffer allocate(allele_buffer%allele_names(nall)) allocate(allele_buffer%allele_freqs(nall)) allocate(allele_buffer%cum_freqs(nall)) end subroutine setup_freq ! ! Copy allele frequency data from one structure to another ! subroutine copyfreq(allele_buffer, allele_buffer2) type (allele_data), intent(in) :: allele_buffer type (allele_data), intent(inout) :: allele_buffer2 integer :: numal numal=allele_buffer%numal if (allele_buffer2%numal < numal) then deallocate(allele_buffer2%allele_names) deallocate(allele_buffer2%allele_freqs) deallocate(allele_buffer2%cum_freqs) allocate(allele_buffer2%allele_names(numal)) allocate(allele_buffer2%allele_freqs(numal)) allocate(allele_buffer2%cum_freqs(numal)) end if allele_buffer2%allele_names(1:numal)=allele_buffer%allele_names(1:numal) allele_buffer2%allele_freqs(1:numal)=allele_buffer%allele_freqs(1:numal) allele_buffer2%cum_freqs(1:numal)=allele_buffer%cum_freqs(1:numal) allele_buffer2%numal=numal allele_buffer2%typed = allele_buffer%typed allele_buffer2%untyped = allele_buffer%untyped allele_buffer2%numgtp=allele_buffer%numgtp allele_buffer2%minall=allele_buffer%minall allele_buffer2%topall=allele_buffer%topall allele_buffer2%xlinkd=allele_buffer%xlinkd allele_buffer2%issnp=allele_buffer%issnp end subroutine copyfreq ! ! expand size of an allele frequency structure ! subroutine expand_alleles(allele_buffer, nextra) integer, intent(in) :: nextra type (allele_data), intent(inout) :: allele_buffer integer numal type (allele_data) :: allele_buffer2 ! allocate a buffer for old data and copy old data across numal=allele_buffer%numal allocate(allele_buffer2%allele_names(numal)) allocate(allele_buffer2%allele_freqs(numal)) allele_buffer2%allele_names=allele_buffer%allele_names allele_buffer2%allele_freqs=allele_buffer%allele_freqs ! reallocate original structure and bring old data back deallocate(allele_buffer%allele_names) deallocate(allele_buffer%allele_freqs) deallocate(allele_buffer%cum_freqs) allocate(allele_buffer%allele_names(numal+nextra)) allocate(allele_buffer%allele_freqs(numal+nextra)) allocate(allele_buffer%cum_freqs(numal+nextra)) allele_buffer%allele_names(1:numal)=allele_buffer2%allele_names(1:numal) allele_buffer%allele_freqs(1:numal)=allele_buffer2%allele_freqs(1:numal) deallocate(allele_buffer2%allele_names) deallocate(allele_buffer2%allele_freqs) end subroutine expand_alleles ! ! release memory held by an allele frequency structure ! subroutine cleanup_alleles(allele_buffer) type (allele_data), intent(inout) :: allele_buffer if (allele_buffer%numal > 0) then deallocate(allele_buffer%allele_names) deallocate(allele_buffer%allele_freqs) deallocate(allele_buffer%cum_freqs) if (allocated(allele_buffer%gtp_freqs)) then deallocate(allele_buffer%gtp_freqs) end if if (allocated(allele_buffer%freq_stderrs)) then deallocate(allele_buffer%freq_stderrs) end if end if allele_buffer%numal=0 allele_buffer%numgtp=0 allele_buffer%typed=0 allele_buffer%untyped=0 allele_buffer%totall=0 allele_buffer%minall=0 allele_buffer%topall=0 allele_buffer%xlinkd=.false. allele_buffer%issnp=.false. end subroutine cleanup_alleles ! ! produce genotype frequencies for Metropolis algorithm ! subroutine genot(allele_buffer, gfrq) type (allele_data), intent(in) :: allele_buffer double precision, dimension(allele_buffer%numgtp), intent(out) :: gfrq integer :: i, j, ngtp ngtp=0 do i=1, allele_buffer%numal do j=1, i ngtp=ngtp+1 gfrq(ngtp)=allele_buffer%allele_freqs(i)*allele_buffer%allele_freqs(j) if (i /= j) then gfrq(ngtp)=gfrq(ngtp)+gfrq(ngtp) end if end do end do end subroutine genot ! ! or for sequential imputation subroutine calc_gtp_freqs(allele_buffer) type (allele_data), intent(inout) :: allele_buffer integer :: i, j, ngtp if (allocated(allele_buffer%gtp_freqs)) then deallocate(allele_buffer%gtp_freqs) end if allocate(allele_buffer%gtp_freqs(allele_buffer%numgtp)) ngtp=0 do i=1, allele_buffer%numal do j=1, i ngtp=ngtp+1 allele_buffer%gtp_freqs(ngtp)=allele_buffer%allele_freqs(i)*allele_buffer%allele_freqs(j) if (i /= j) then allele_buffer%gtp_freqs(ngtp)=allele_buffer%gtp_freqs(ngtp)+ & allele_buffer%gtp_freqs(ngtp) end if end do end do end subroutine calc_gtp_freqs ! ! naive standard errors for allele frequencies ! subroutine calc_naive_freq_ase(allele_buffer) type (allele_data), intent(inout) :: allele_buffer integer :: i double precision :: den if (allocated(allele_buffer%freq_stderrs)) then deallocate(allele_buffer%freq_stderrs) end if allocate(allele_buffer%freq_stderrs(allele_buffer%numal)) den=0.5d0/dble(allele_buffer%typed) do i=1, allele_buffer%numal allele_buffer%freq_stderrs(i)=sqrt(den*allele_buffer%allele_freqs(i) * & (1.0d0-allele_buffer%allele_freqs(i))) end do end subroutine calc_naive_freq_ase ! ! initialize allele_array ! subroutine setup_allele_array(nmark, alleles) integer, intent(in) :: nmark type (allele_array), intent(inout) :: alleles alleles%nmark=nmark allocate(alleles%mark(nmark)) allocate(alleles%alleles(nmark)) end subroutine setup_allele_array subroutine cleanup_allele_array(alleles) type (allele_array), intent(inout) :: alleles alleles%nmark=0 deallocate(alleles%mark) deallocate(alleles%alleles) end subroutine cleanup_allele_array end module alleles_class ! ! Lists of genotypes ! module genolist_class type genolist_data integer :: ngeno ! number of members of list integer, dimension(:), allocatable :: glist ! genotype indices end type genolist_data end module genolist_class ! ! Routines to manipulate nucleotide alleles: ! numeric to letter, strand flipping, ! module nucleotides integer, parameter :: biga=10065, littlea=10097 integer, parameter :: bigb=10066, littleb=10098 integer, parameter :: bigc=10067, littlec=10099 integer, parameter :: bigg=10071, littleg=10103 integer, parameter :: bigt=10084, littlet=10116 contains ! ! each nucleotide ! function is_a(g) logical :: is_a integer, intent(in) :: g is_a=(abs(g) == littlea .or. abs(g) == biga) end function is_a function is_c(g) logical :: is_c integer, intent(in) :: g is_c=(abs(g) == littlec .or. abs(g) == bigc) end function is_c function is_g(g) logical :: is_g integer, intent(in) :: g is_g=(abs(g) == littleg .or. abs(g) == bigg) end function is_g function is_t(g) logical :: is_t integer, intent(in) :: g is_t=(abs(g) == littlet .or. abs(g) == bigt) end function is_t ! ! complement nucleotide: all ! function flip_atgc(g) integer :: flip_atgc integer, intent(in) :: g flip_atgc=g if (is_a(g)) flip_atgc=g+sign(19,g) if (is_c(g)) flip_atgc=g+sign(4,g) if (is_g(g)) flip_atgc=g-sign(4,g) if (is_t(g)) flip_atgc=g-sign(19,g) end function flip_atgc ! ! complement nucleotide: AC ! function flip_ac(g) integer :: flip_ac integer, intent(in) :: g flip_ac=g if (is_a(g)) flip_ac=g+sign(19,g) if (is_c(g)) flip_ac=g+sign(4,g) end function flip_ac ! ! complement nucleotide: AG ! function flip_ag(g) integer :: flip_ag integer, intent(in) :: g flip_ag=g if (is_a(g)) flip_ag=g+sign(19,g) if (is_g(g)) flip_ag=g-sign(4,g) end function flip_ag ! ! complement nucleotide: CT ! function flip_ct(g) integer :: flip_ct integer, intent(in) :: g flip_ct=g if (is_c(g)) flip_ct=g+sign(4,g) if (is_t(g)) flip_ct=g-sign(19,g) end function flip_ct ! ! complement nucleotide: GT ! function flip_gt(g) integer :: flip_gt integer, intent(in) :: g flip_gt=g if (is_g(g)) flip_gt=g-sign(4,g) if (is_t(g)) flip_gt=g-sign(19,g) end function flip_gt ! ! number code nucleotide ! function nttonum(g) integer :: nttonum integer, intent(in) :: g nttonum=g if (is_a(g)) then nttonum=sign(1, g) else if (is_c(g)) then nttonum=sign(2, g) else if (is_g(g)) then nttonum=sign(3, g) else if (is_t(g)) then nttonum=sign(4, g) end if end function nttonum ! ! number code nucleotide ! function numtont(g) integer :: numtont integer, intent(in) :: g numtont=g if (abs(g) == 1) numtont=sign(biga, g) if (abs(g) == 2) numtont=sign(bigc, g) if (abs(g) == 3) numtont=sign(bigg, g) if (abs(g) == 4) numtont=sign(bigt, g) end function numtont ! ! test if locus has only nucleotide alleles in consistent encoding ! 0 = no ! 1 = (1,2,3,4) ! 2 = (A,C,G,T) ! 3 = (a,c,g,t) ! function isntcode(g) implicit none integer :: isntcode integer, intent(in) :: g isntcode=0 if (g == littlea .or. g == littlec .or. & g == littleg .or. g == littlet) then isntcode=3 else if (g == biga .or. g == bigc .or. & g == bigg .or. g == bigt) then isntcode=2 else if (g > 0 .and. g < 5) then isntcode = 1 end if end function isntcode ! function allntcode(typ, gene, dataset) use ped_class implicit none integer :: allntcode integer, intent(in) :: typ integer, intent(in) :: gene type (ped_data) :: dataset ! integer :: c1, c2, g1, g2, gen2, i, ped ! functions ! integer :: isntcode allntcode=0 gen2=gene+1 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (.not.missing(i, gene, dataset)) then call get_geno(i, gene, gen2, dataset, g1, g2) c1=isntcode(g1) c2=isntcode(g2) if (c1 /= 0 .and. c1 /= c2) return if (allntcode == 0) then allntcode = c1 else if (allntcode /= c1) then allntcode = 0 return end if end if end do end if end do end function allntcode ! ! recode SNP alleles to/from numerical coding A<->1 C<->2 G<->3 T<->4 ! subroutine ntcode(typ, gene, dataset) use ped_class implicit none integer, intent(in) :: typ integer, intent(in) :: gene type (ped_data) :: dataset ! integer, parameter :: MISS=-9999 integer :: g1, g2, gen2, i, ped ! functions ! integer :: nttonum, numtont gen2=gene+1 if (typ==1) then do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (.not.missing(i, gene, dataset)) then call get_geno(i, gene, gen2, dataset, g1, g2) g1=nttonum(g1) g2=nttonum(g2) call order(g1,g2) call set_geno(i, gene, gen2, dataset, g1, g2) end if end do end if end do else do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (.not.missing(i, gene, dataset)) then call get_geno(i, gene, gen2, dataset, g1, g2) g1=numtont(g1) g2=numtont(g2) call order(g1,g2) call set_geno(i, gene, gen2, dataset, g1, g2) end if end do end if end do end if end subroutine ntcode ! ! recode 1,2 or A,B to nucleotide code based on annotation ! subroutine nuccode(gene, loctyp, locnotes, allele_buffer, dataset) use locus_types use alleles_class use ped_class implicit none integer, intent(in) :: gene integer, intent(in) :: loctyp character (len=*) :: locnotes type (ped_data), intent(inout) :: dataset type (allele_data), intent(in) :: allele_buffer character (len=1) :: ref, alt integer, dimension(2) :: alleles integer :: g1, g2, gcode, gen2, i, nall, ped ! functions integer :: aval if (allele_buffer%numal == 0 .or. allele_buffer%numal > 2) return if (allele_buffer%allele_names(1) /= 1 .and. & allele_buffer%allele_names(1) /= biga .and. & allele_buffer%allele_names(1) /= littlea .and. & allele_buffer%allele_names(1) /= bigb .and. & allele_buffer%allele_names(1) /= littleb) return if (allele_buffer%numal == 2) then if (allele_buffer%allele_names(2) /= 2 .and. & allele_buffer%allele_names(2) /= bigb .and. & allele_buffer%allele_names(2) /= littleb) return end if alt=' ' ref=' ' call get_refalleles(locnotes, ref, alt) nall=0 if (alt /= ' ') nall=nall+1 if (ref /= ' ') nall=nall+1 if (nall == 0) return if (nall == 1 .and. allele_buffer%numal > 1) return gen2=gene+1 gcode=gencode(loctyp) alleles(1)=aval(ref, gcode) alleles(2)=aval(alt, gcode) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (.not.missing(i, gene, dataset)) then call get_namedgeno(i, gene, gen2, dataset, allele_buffer, g1, g2) g1=alleles(g1) g2=alleles(g2) call order(g1,g2) call set_geno(i, gene, gen2, dataset, g1, g2) end if end do end if end do end subroutine nuccode ! ! flip allele labels in allele container to complement eg other strand A<->T G<->C ! NB allele container allele list is usually ordered by allele collation order ! subroutine flip_buffer(allele_buffer, flip_function) use alleles_class type (allele_data) :: allele_buffer integer :: j ! functions interface flip_generic function flip_function(g) integer :: flip_function integer, intent(in) :: g end function flip_function end interface flip_generic do j=1, allele_buffer%numal allele_buffer%allele_names(j)=flip_function(allele_buffer%allele_names(j)) end do end subroutine flip_buffer ! ! flip alleles in dataset to complement eg other strand A<->T G<->C ! subroutine flip(loc, gene, flip_function, dataset, plevel) use outstream use ped_class implicit none integer, intent(in) :: plevel character (len=*), intent(in) :: loc integer, intent(in) :: gene type (ped_data) :: dataset ! integer, parameter :: MISS=-9999 integer :: g1, g2, gen2, i, ped ! functions interface flip_generic function flip_function(g) integer :: flip_function integer, intent(in) :: g end function flip_function end interface flip_generic integer :: atgc ! if (plevel > -1) then write(outstr,'(/3a)') & 'Recoding alleles at "', trim(loc), '" to complement.' end if gen2=gene+1 ! do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (.not.missing(i, gene, dataset)) then call get_geno(i, gene, gen2, dataset, g1, g2) g1=flip_function(g1) g2=flip_function(g2) call order(g1,g2) call set_geno(i, gene, gen2, dataset, g1, g2) end if end do end if end do end subroutine flip ! ! Test if mix of genotypes for a locus are compatible with a strand mixup ! Either test observed genotypes or compare to reference set ! subroutine strandhet(loc, gene, dataset, allele_buffer, & nhetclasses, hetclasses, hwep, plevel) use alleles_class use ped_class implicit none character (len=*), intent(in) :: loc integer, intent(in) :: gene type (ped_data), intent(in) :: dataset type (allele_data), intent(in) :: allele_buffer integer :: nhetclasses integer, dimension(allele_buffer%numal) :: hetclasses double precision, intent(in) :: hwep integer, intent(in) :: plevel integer, parameter :: MISS = -9999 ! lists of intersegregating alleles integer, dimension(0:2) :: nhetalls character (len=3), dimension(0:2) :: hetalls integer :: i, j, n character (len=3) :: sall ! functions character (len=6) :: pstring ! nhetalls=0 hetalls=' ' do i=0, nhetclasses do j=1, allele_buffer%numal if (hetclasses(j) == i) then call wrall(allele_buffer%allele_names(j), sall) if (sall == ' A' .or. sall == ' C' .or. & sall == ' G' .or. sall == ' T') then nhetalls(i)=nhetalls(i)+1 n=nhetalls(i) hetalls(i)(n:n)=trim(adjustl(sall)) end if end if end do end do ! ! if nucleotide coding and two lists are complementary ! if (nhetalls(1) == 2 .and. nhetalls(2) == 2) then if (plevel > 0) then write(outstr,'(a14,1x,a9)', advance='no') loc, & hetalls(1) // ' ' // hetalls(2) if (hwep /= MISS) then write(outstr,'(3x,a,2x)', advance='no') trim(pstring(hwep)) else write(outstr,'(3x,a,2x)', advance='no') ' - ' end if end if if ((hetalls(1) == 'AG' .and. hetalls(2) == 'CT') .or. & (hetalls(1) == 'CT' .and. hetalls(2) == 'AG')) then if (plevel > -1) then write(outstr,'(3a)') 'Recoding "', trim(loc), '" A G to T C' end if call flip(loc, gene, flip_ag, dataset, -1) else if ((hetalls(1) == 'AC' .and. hetalls(2) == 'GT') .or. & (hetalls(1) == 'GT' .and. hetalls(2) == 'AC')) then if (plevel > -1) then write(outstr,'(3a)') 'Recoding "', trim(loc), '" A C to T G' end if call flip(loc, gene, flip_ac, dataset, -1) end if else if (nhetalls(1) == 2 .and. nhetalls(0) == 2) then if (plevel > 0) then write(outstr,'(a14,1x,a9)', advance='no') loc, & hetalls(0) // ' ' // hetalls(1) if (hwep /= MISS) then write(outstr,'(3x,a)', advance='no') trim(pstring(hwep)) else write(outstr,'(3x,a)', advance='no') ' - ' end if end if if ((hetalls(1) == 'AG' .and. hetalls(0) == 'CT') .or. & (hetalls(1) == 'CT' .and. hetalls(0) == 'AG')) then if (plevel > -1) then write(outstr,'(3a)') 'Recoding "', trim(loc), '" A G to T C' end if call flip(loc, gene, flip_ag, dataset, -1) else if ((hetalls(1) == 'AC' .and. hetalls(0) == 'GT') .or. & (hetalls(1) == 'GT' .and. hetalls(0) == 'AC')) then if (plevel > -1) then write(outstr,'(3a)') 'Recoding "', trim(loc), '" A C to T G' end if call flip(loc, gene, flip_ac, dataset, -1) end if else if (nhetalls(1) == 2 .and. nhetalls(0) == 1) then if (plevel > 0) then write(outstr,'(a14,1x,a9)', advance='no') loc, & hetalls(1) // ' ' // hetalls(0) if (hwep /= MISS) then write(outstr,'(3x,a)', advance='no') trim(pstring(hwep)) else write(outstr,'(3x,a)', advance='no') ' - ' end if end if if ((hetalls(1) == 'AG' .and. & (hetalls(0) == 'C' .or. hetalls(0) == 'T')) .or. & (hetalls(1) == 'CT' .and. & (hetalls(0) == 'A' .or. hetalls(0) == 'G'))) then if (plevel > -1) then write(outstr,'(3a)') 'Recoding "', trim(loc), '" A G to T C' end if call flip(loc, gene, flip_ag, dataset, -1) else if ((hetalls(1) == 'AC' .and. & (hetalls(0) == 'G' .or. hetalls(0) == 'T')) .or. & (hetalls(1) == 'GT' .and. & (hetalls(0) == 'A' .or. hetalls(0) == 'C'))) then if (plevel > -1) then write(outstr,'(3a)') 'Recoding "', trim(loc), '" A C to T G' end if call flip(loc, gene, flip_ac, dataset, -1) end if end if end subroutine strandhet ! ! Reconcile strand for observed genotypes to a reference set ! Use frequency information when complementary alleles within system ! typ=1 flip genotypes in current dataset ! typ=2 flip list of alleles in *reference* set, to be used to read in ! matching VCF or PLINK file ! subroutine refstrand(typ, loc, gene, dataset, allele_buffer, & ref_allele_buffer, comp_status, plevel) use alleles_class use ped_class implicit none integer, intent(in) :: typ character (len=*), intent(in) :: loc integer, intent(in) :: gene type (ped_data) :: dataset type (allele_data) :: allele_buffer, ref_allele_buffer integer, intent(out) :: comp_status integer, intent(in) :: plevel integer, parameter :: MISS = -9999 integer :: g1, g2, i, iflag, j, majall, nn, plev, rn character (len=4) :: obs_alleles, ref_alleles character (len=1) :: sall logical :: nA, nC, nG, nT, rA, rC, rG, rT double precision :: p0, z ! functions integer :: aval ! plev=-1 if (plevel == 0) plev=plevel comp_status=0 call make_ntlist(ref_allele_buffer, rA, rC, rT, rG, rn, ref_alleles, iflag) if (iflag /= 0) comp_status=-1 call make_ntlist(allele_buffer, nA, nC, nT, nG, nn, obs_alleles, iflag) if (iflag /= 0) comp_status=-1 if (plevel > 0) then write(outstr,'(a14,2(1x,a9))', advance='no') & trim(loc), trim(obs_alleles), trim(ref_alleles) end if if (comp_status == -1) then if (plevel > 0) then write(outstr,'(1x,2a)') trim(loc), ' is not a single nucleotide locus.' end if comp_status=0 return end if if (nA .and. nG .and. rC .and. rT) then if (plevel > 0) write(outstr,'(1x,a)') 'Recode A G to T C' if (typ == 1) then call flip(loc, gene, flip_ag, dataset, plev) else call flip_buffer(ref_allele_buffer, flip_ct) end if comp_status=1 else if (nC .and. nT .and. rA .and. rG) then if (plevel > 0) write(outstr,'(1x,a)') 'Recode T C to A G' if (typ == 1) then call flip(loc, gene, flip_ct, dataset, plev) else call flip_buffer(ref_allele_buffer, flip_ag) end if comp_status=1 else if (nA .and. nC .and. rG .and. rT) then if (plevel > 0) write(outstr,'(1x,a)') 'Recode A C to T G' if (typ == 1) then call flip(loc, gene, flip_ac, dataset, plev) else call flip_buffer(ref_allele_buffer, flip_gt) end if comp_status=1 else if (nG .and. nT .and. rA .and. rC) then if (plevel > 0) write(outstr,'(1x,a)') 'Recode T G to A C' if (typ == 1) then call flip(loc, gene, flip_gt, dataset, plev) else call flip_buffer(ref_allele_buffer, flip_ac) end if comp_status=1 else if ((nC .and. nG .and. rC .and. rG) .or. & (nA .and. nT .and. rA .and. rT)) then if (ref_allele_buffer%allele_names(ref_allele_buffer%topall) /= & allele_buffer%allele_names(allele_buffer%topall)) then call calc_naive_freq_ase(allele_buffer) i=allele_buffer%topall j=ref_allele_buffer%topall p0=1.0d0-ref_allele_buffer%allele_freqs(j) z=(allele_buffer%allele_freqs(i)-p0)/allele_buffer%freq_stderrs(i) if (z > 3.0d0) then if (plevel > 0) then if (nC) then write(outstr,'(1x,a,f6.1)') 'Recode C G to G C; Z=', z else write(outstr,'(1x,a,f6.1)') 'Recode A T to T A; Z=', z end if end if if (typ == 1) then call flip(loc, gene, flip_atgc, dataset, plev) else call flip_buffer(ref_allele_buffer, flip_atgc) end if comp_status=2 else if (plevel > 0) then write(outstr,'(1x,a,f6.1)') 'Left unaltered; Z=', z end if if (plevel > 1) then write(outstr,'(a)') '-------------------------' call wrall(ref_allele_buffer%allele_names(j), ref_alleles) write(outstr,*) 'External major allele: ', ref_alleles, ref_allele_buffer%allele_freqs(j) call wrall(allele_buffer%allele_names(i), ref_alleles) write(outstr,*) 'Internal major allele: ', ref_alleles, allele_buffer%allele_freqs(i) write(outstr,'(a)') '-------------------------' end if else if (plevel > 0) then write(outstr,'(1x,2a)') trim(loc) ,' is consistent' end if else if (index(trim(ref_alleles), trim(obs_alleles)) > 0) then if (plevel > 0) then write(outstr,'(1x,2a)') trim(loc) ,' is consistent' end if ! ! monomorphic and reference allele on opposite strand else if (nn == 1 .and. rn == 1) then if ((nG .and. rC) .or. (nA .and. rT) .or. & (nC .and. rG) .or. (nT .and. rA)) then if (plevel > 0) then write(outstr,'(1x,4a)') & 'Recode ', trim(obs_alleles), ' to ', trim(ref_alleles) end if if (typ == 1) then call flip(loc, gene, flip_atgc, dataset, plev) else call flip_buffer(ref_allele_buffer, flip_atgc) end if comp_status=1 else if (plevel > 0) then write(outstr,'(1x,2a)') trim(loc), ' is inconsistent' end if comp_status=-1 end if else if (plevel > 0) then write(outstr,'(1x,2a)') trim(loc), ' is inconsistent' end if comp_status=-1 end if end subroutine refstrand ! ! Suitably mung long alleles in a VCF type ALT (usually comma separated) ! to a character (similar routine for allele_data) ! subroutine extract_one_allele(str, longall, all1) character(len=*), intent(in) :: str integer, intent(inout) :: longall character(len=*), intent(out) :: all1 if (len(str) == 1) then all1=str else longall=longall+1 all1=achar(longall) end if end subroutine extract_one_allele ! subroutine extract_alt_alleles(str, all1, all2) character(len=*), intent(in) :: str character(len=*), intent(out) :: all1, all2 integer :: fin, i, j, longall character(len=1) :: allsep allsep=',' i=index(str, ',') if (i == 0) then i=index(str, ';') if (i > 0) allsep=';' end if longall=48 if (i == 0) then call extract_one_allele(str, longall, all1) all2=' ' else call extract_one_allele(str(1:(i-1)), longall, all1) fin=len(str) j=index(str((i+1):fin), allsep) if (j > 0) fin=i+j+1 call extract_one_allele(str((i+1):fin), longall, all2) end if end subroutine extract_alt_alleles ! ! Load reference alleles into an allele container ! subroutine load_refallele(refall, altall, altfreq, ref_allele_buffer) use alleles_class implicit none character(len=*) :: refall, altall double precision :: altfreq type (allele_data) :: ref_allele_buffer ! functions integer :: aval ref_allele_buffer%numal=2 if (.not.allocated(ref_allele_buffer%allele_names)) then allocate(ref_allele_buffer%allele_names(2)) allocate(ref_allele_buffer%allele_freqs(2)) allocate(ref_allele_buffer%cum_freqs(2)) end if ref_allele_buffer%allele_names(1)=aval(refall, 1) ref_allele_buffer%allele_names(2)=aval(altall, 1) ref_allele_buffer%allele_freqs(1)=1.0d0-altfreq ref_allele_buffer%allele_freqs(2)=altfreq ref_allele_buffer%topall=1 if (altfreq > 0.5d0) then ref_allele_buffer%topall=2 end if end subroutine load_refallele ! ! Load reference alleles from a line of a VCF file into an allele container ! if typ == 2 then VCF file expected to have summary allele count information ! subroutine load_vcf_refall(typ, vcf_ac, vcf_an, vcf_het, vcf_hom, & slin, vcf_alleles) use scanner use locus_types use alleles_class integer, intent(in) :: typ character (len=*), intent(in) :: vcf_ac, vcf_an, vcf_het, vcf_hom character (len=*), intent(in) :: slin type(allele_data) :: vcf_alleles integer, parameter :: MISS = -9999, WORDLEN=80 integer, parameter :: ALTPOS = 5, REFPOS=4 character (len=WORDLEN), dimension(20) :: words integer :: gcode, ioerr, j, longall, n, nalt, narg character (len=1) :: allsep character (len=WORDLEN) :: cval character (len=len(slin)) :: info ! functions integer :: aval ! read in alleles as specified by VCF file for this locus gcode=1 allsep=';' longall=0 call getword(slin, REFPOS, cval, sep='\t') if (len_trim(cval) == 1) then vcf_alleles%allele_names(1)=aval(cval, gcode) else longall=longall+1 vcf_alleles%allele_names(1)=longall end if call getword(slin, ALTPOS, cval, sep='\t') if (index(cval, ',') > 0) allsep=',' vcf_alleles%numal=countargs(trim(cval), allsep, SEP_CHAR)+1 do j=2, vcf_alleles%numal call getword(cval, j-1, words(1), sep=allsep) if (len_trim(words(1)) == 1) then vcf_alleles%allele_names(j)=aval(words(1), gcode) else longall=longall+1 vcf_alleles%allele_names(j)=longall end if end do vcf_alleles%topall=1 ! Read VCF population frequencies if (typ == 2) then call getword(slin, 8, info, sep='\t') call getpairval(trim(vcf_an), info, opsimple, cval) n=max(ival(cval),0) nalt=0 vcf_alleles%totall=n vcf_alleles%typed=vcf_alleles%totall/2 vcf_alleles%untyped=-1 if (n > 0) then dn=dble(vcf_alleles%totall) call getpairval(trim(vcf_ac), info, opsimple, cval) if (index(cval,',') > 0) then narg=vcf_alleles%numal-1 call args(cval, narg, words, ',', SEP_CHAR) else narg=1 words(1)=trim(cval) end if vcf_alleles%allele_freqs(1)=1.0d0 do j=2, vcf_alleles%numal nalt=nalt+ival(words(j-1)) vcf_alleles%allele_freqs(j)=dble(ival(words(j-1)))/dn vcf_alleles%allele_freqs(1)=vcf_alleles%allele_freqs(1)-vcf_alleles%allele_freqs(j) end do do j=2, vcf_alleles%numal if (vcf_alleles%allele_freqs(j) > vcf_alleles%allele_freqs(vcf_alleles%topall)) then vcf_alleles%topall=j end if end do ! Number of heterozygous genotypes, remembering may be multiallelic if (vcf_het /= ' ') then call getpairval(trim(vcf_het), info, opsimple, cval) if (cval /= ' ') then vcf_alleles%untyped=0 do j=2, vcf_alleles%numal call getword(cval, j-1, words(1), sep=allsep) vcf_alleles%untyped=vcf_alleles%untyped+ival(words(1)) end do end if end if if (vcf_hom /= ' ') then call getpairval(trim(vcf_hom), info, opsimple, cval) if (cval /= ' ') then vcf_alleles%untyped=0 do j=2, vcf_alleles%numal call getword(cval, j-1, words(1), sep=allsep) vcf_alleles%untyped=vcf_alleles%untyped+ival(words(1)) end do end if vcf_alleles%untyped=nalt-2*vcf_alleles%untyped end if else vcf_alleles%allele_freqs(1)=0.0d0 end if end if end subroutine load_vcf_refall ! ! List nucleotides in allele list , returning indicator variables and string ! subroutine make_ntlist(allele_buffer, A, C, T, G, numnt, ntlist, astat) use alleles_class type (allele_data) :: allele_buffer logical, intent(out) :: A, C, G, T integer, intent(out) :: numnt character (len=4) :: ntlist integer, intent(out) :: astat ! astat=0 numnt=0 ntlist=' ' A=.false. C=.false. G=.false. T=.false. do j=1, allele_buffer%numal if (isntcode(allele_buffer%allele_names(j)) > 1) then if (is_a(allele_buffer%allele_names(j))) A=.true. if (is_c(allele_buffer%allele_names(j))) C=.true. if (is_g(allele_buffer%allele_names(j))) G=.true. if (is_t(allele_buffer%allele_names(j))) T=.true. else astat=-1 end if end do if (A) then numnt=numnt+1 ntlist(numnt:numnt)='A' end if if (C) then numnt=numnt+1 ntlist(numnt:numnt)='C' end if if (G) then numnt=numnt+1 ntlist(numnt:numnt)='G' end if if (T) then numnt=numnt+1 ntlist(numnt:numnt)='T' end if end subroutine make_ntlist ! ! Complement nucleotide characters for annotation ! function complement(nt) character (len=*) :: nt character (len=len(nt)) :: complement integer :: i complement=' ' do i=1, len_trim(nt) if (nt(i:i) == 'A') then complement(i:i)='T' else if (nt(i:i) == 'T') then complement(i:i)='A' else if (nt(i:i) == 'C') then complement(i:i)='G' else if (nt(i:i) == 'G') then complement(i:i)='C' end if end do end function complement end module nucleotides ! ! Variance components data structure ! module ibd_class ! one pedigree type ibd_data integer :: iped ! pedigree index in dataset integer :: nobs ! number of useful pedigree members integer :: ncov ! nobs*(nobs+1)/2 integer :: nvar ! number of covariates incl dummy coding ! observed trait and covariate values double precision, dimension(:), allocatable :: yval double precision, dimension(:,:), allocatable :: vals ! numerator relationship matrix -- nobs x (nobs+1)/2 double precision, dimension(:), allocatable :: a ! dominance or family environment or marker IBD matrix -- nobs x (nobs+1)/2 double precision, dimension(:), allocatable :: c end type ibd_data ! ! collection of families for analysis ! integer :: vc_typ ! model type integer :: vc_invalg ! inversion algorithm control 0=LINPACK >0=Gibbs iterations integer :: vc_nfix ! number of columns in design matrix integer :: nfam ! number of families type (ibd_data), dimension(:), pointer :: families ! VC work arrays double precision, dimension(:), allocatable :: a, c, csd ! Multipoint work arrays double precision, dimension(:,:), allocatable :: mibd, mibdsd ! expected values double precision, dimension(:), allocatable :: m ! censoring indicator integer, dimension(:), allocatable :: censor contains ! Allocate a pedigree's data arrays subroutine setup_ibd(ped, nobs, nvar, family) use ped_class integer :: ped, nobs, nvar type (ibd_data) :: family family%iped = ped ! pedigree index in dataset family%nobs = nobs ! number of usable pedigree members family%ncov = nobs*(nobs+1)/2 ! number of usable pedigree members family%nvar = nvar ! number of covariates incl dummy codings allocate(family%yval(nobs)) ! yvariable (may be transformed) allocate(family%vals(nobs, nvar)) ! covariates incl dummy coding allocate(family%a(nobs*(nobs+1)/2)) ! first random effect's covariance matrix allocate(family%c(nobs*(nobs+1)/2)) ! second random effect's covariance matrix end subroutine setup_ibd ! Show a pedigree's data arrays subroutine print_ibd(family) use outstream use ped_class type (ibd_data) :: family integer :: i, idx idx=0 write(outstr,'(a,i0,a,i0,a)') & 'Pedigree ', family%iped,' (N=', family%nobs, ')' do i=1, family%nobs write(outstr,'(g9.4,(30(1x,f5.3)):)') & family%yval(i), family%a((idx+1):(idx+i)) idx=idx+i end do end subroutine print_ibd end module ibd_class ! ! hash functions for IDs ! module idhash_funs use ped_class use idhash_class public :: dohash_ped_id, dohash_id, domatch_ped_id, domatch_id, & domatch_string_ped_id, domatch_string_id contains ! pedigree + individual ID function dohash_ped_id(idx, dataset, maxkey) implicit none integer :: dohash_ped_id integer, intent(in) :: idx type (ped_data) :: dataset integer, intent(in) :: maxkey dohash_ped_id=string_hash(trim(dataset%pedigree(dataset%iped(idx))) // ' ' // & trim(dataset%id(idx)), maxkey) end function dohash_ped_id ! individual ID function dohash_id(idx, dataset, maxkey) implicit none integer :: dohash_id integer, intent(in) :: idx type (ped_data) :: dataset integer, intent(in) :: maxkey dohash_id=string_hash(trim(dataset%id(idx)), maxkey) end function dohash_id ! match pedigree + individual ID function domatch_ped_id(idx, iaddress, dataset) implicit none logical :: domatch_ped_id integer, intent(in) :: idx, iaddress type (ped_data) :: dataset domatch_ped_id = (dataset%pedigree(dataset%iped(idx)) == & dataset%pedigree(dataset%iped(iaddress)) .and. & dataset%id(idx) == dataset%id(iaddress)) end function domatch_ped_id ! match individual id function domatch_id(idx, iaddress, dataset) implicit none logical :: domatch_id integer, intent(in) :: idx, iaddress type (ped_data) :: dataset domatch_id=(dataset%id(idx) == dataset%id(iaddress)) end function domatch_id ! match search string to pedigree + individual ID function domatch_string_ped_id(pedstr, indstr, iaddress, dataset) implicit none logical :: domatch_string_ped_id character (len=*), intent(in) :: pedstr, indstr integer, intent(in) :: iaddress type (ped_data) :: dataset domatch_string_ped_id = (indstr == dataset%id(iaddress) .and. & pedstr == dataset%pedigree(dataset%iped(iaddress))) end function domatch_string_ped_id ! match search string to individual ID function domatch_string_id(idstr, iaddress, dataset) implicit none logical :: domatch_string_id character (len=*), intent(in) :: idstr integer, intent(in) :: iaddress type (ped_data) :: dataset domatch_string_id = (idstr == trim(dataset%id(iaddress))) end function domatch_string_id end module idhash_funs ! ! Types of relative pair ! module relpair_classes integer, parameter :: NCLASS=19 integer, parameter :: REL_MAR=1, REL_GRAND=2, REL_HALF=3, & REL_PO=4, REL_FS=5, REL_MZ=6, REL_FASO=7, & REL_FADA=8, REL_MOSO=9, REL_MODA=10, & REL_BROBRO=11, REL_SISSIS=12, REL_BROSIS=13, & REL_MZM=14, REL_MZF=15, REL_COZ=16, REL_DCOZ=17, & REL_AVUNC=18, REL_ALL=19 character (len=14), dimension(NCLASS) :: relclass = (/ & 'Husband Wife ', 'Gparent Gchild', 'Halfsib Hsib ', & 'Parent Off ', 'Fullsib Fsib ', 'MZ Twins ', & 'Father Son ', 'Father Dau ', 'Mother Son ', & 'Mother Dau ', 'Brothers ', 'Sisters ', & 'Brother-Sister', 'MZ Males ', 'MZ Females ', & 'Full Cousins ', 'Double Cousins', 'Avuncular ', & 'Familial ' /) logical, dimension(NCLASS) :: exchangeable = (/ & .false., .false., .true., .false., .true., .true., & .false., .false., .false., .false., .true., .true., & .false., .true., .true., .true., .true., .false., .true. /) contains ! ! function to test if jackknife sensible ! function jack_useful(npairs, iter, plevel) logical :: jack_useful integer, dimension(NCLASS) :: npairs integer, intent(in) :: iter, plevel integer :: totpairs totpairs=0 do i=1, 6 totpairs=totpairs+npairs(i) end do do i=16, 19 totpairs=totpairs+npairs(i) end do if (plevel > 1) then write(*,'(a,i10/)') 'Total Pairs', totpairs end if jack_useful=(iter > 0 .and. totpairs > 2 .and. (totpairs < 100000 .or. plevel > 0)) end function jack_useful end module relpair_classes ! ! lowess and unimodal density routines ! module smooths contains ! ! lowess routines from Cleveland 1990 ! x, y values, sorted by x ! f smoothing fraction ! nsteps iterations of robust fit, usually 2 ! delta, usually 0 if n < 100 ! ys fitted values ! weights ! res residuals ! subroutine dolowess(n, x, y, f, nsteps, delta) use sorts integer :: n, nsteps double precision :: f, delta double precision, dimension(n) :: x, y integer :: fin, sta double precision :: val double precision, dimension(n) :: rw, res, ys integer, dimension(n) :: iy do i=1, n iy(i)=i end do call srank2(n, x, y, iy) call reorder(n, iy, x) call reorder(n, iy, y) call lowess(x, y, n, f, nsteps, delta, ys, rw, res) do i=1, n y(iy(i))=ys(i) end do end subroutine dolowess subroutine lowess(x, y, n, f, nsteps, delta, ys, rw, res) use sorts integer :: n, nsteps double precision :: f, delta double precision, dimension(n) :: x, y, ys, rw, res integer :: nright, i, j, iter, last, ns, nleft integer, dimension(2) :: mid double precision :: cut, cmad, r, d1, d2 double precision :: c1, c9, alpha, denom logical :: ok if (n < 2) then ys(1) = y(1) return end if ! at least two, at most n points 1 ns = max(min(int(f*dble(n)), n), 2) iter = 1 goto 3 2 iter = iter+1 3 if (iter .gt. nsteps+1) goto 22 ! robustness iterations nleft = 1 nright = ns ! index of prev estimated point last = 0 ! index of current point i = 1 4 if (nright .ge. n) goto 5 ! move nleft, nright to right if radius decreases d1 = x(i)-x(nleft) ! if d1<=d2 with x(nright+1)==x(nright), lowest fixes d2 = x(nright+1)-x(i) if (d1 .le. d2) goto 5 ! radius will not decrease by move right nleft = nleft+1 nright = nright+1 goto 4 ! fitted value at x(i) 5 call lowest(x, y, n, x(i), ys(i), nleft, nright, res, iter > 1, rw, ok) if (.not. ok) ys(i) = y(i) ! all weights zero - copy over value (all rw==0) if (last .ge. i-1) goto 9 denom = x(i)-x(last) ! skipped points -- interpolate ! non-zero - proof? j = last+1 goto 7 6 j = j+1 7 if (j .ge. i) goto 8 alpha = (x(j)-x(last))/denom ys(j) = alpha*ys(i)+(1.D0-alpha)*ys(last) goto 6 8 continue ! last point actually estimated 9 last = i ! x coord of close points cut = x(last)+delta i = last+1 goto 11 10 i = i+1 11 if (i .gt. n) goto 13 ! find close points if (x(i) .gt. cut) goto 13 ! i one beyond last pt within cut if (x(i) .ne. x(last)) goto 12 ys(i) = ys(last) ! exact match in x last = i 12 continue goto 10 ! back 1 point so interpolation within delta, but always go forward 13 i = max(last+1, i-1) 14 if (last .lt. n) goto 4 ! residuals do 15 i = 1, n res(i) = y(i)-ys(i) 15 continue if (iter .gt. nsteps) goto 22 ! compute robustness weights except last time do 16 i = 1, n rw(i) = abs(res(i)) 16 continue call dsort(n, rw) mid(1) = n/2+1 mid(2) = n-mid(1)+1 ! 6 median abs resid cmad = 3.D0*(rw(mid(1))+rw(mid(2))) c9 = .999999D0*cmad c1 = .000001D0*cmad do 21 i = 1, n r = abs(res(i)) if (r .gt. c1) goto 17 rw(i) = 1.D0 ! near 0, avoid underflow goto 20 17 if (r .le. c9) goto 18 rw(i) = 0.D0 ! near 1, avoid underflow goto 19 18 rw(i) = (1.D0-(r/cmad)**2.D0)**2.D0 19 continue 20 continue 21 continue goto 2 22 return end subroutine lowess subroutine lowest(x, y, n, xs, ys, nleft, nright, w, userw, rw, ok) integer :: n integer :: nleft, nright double precision :: xs, ys double precision, dimension(n) :: x, y, w, rw logical :: userw, ok integer :: nrt, j double precision :: a, b, c, h, r double precision h1, h9, rang rang = x(n)-x(1) h = max(xs-x(nleft), x(nright)-xs) h9 = .999999D0*h h1 = .000001D0*h ! sum of weights a = 0.D0 j = nleft goto 2 1 j = j+1 2 if (j .gt. n) goto 7 ! compute weights (pick up all ties on right) w(j) = 0.D0 r = abs(x(j)-xs) if (r .gt. h9) goto 5 if (r .le. h1) goto 3 w(j) = (1.D0-(r/h)**3.D0)**3.D0 ! small enough for non-zero weight goto 4 3 w(j) = 1.D0 4 if (userw) w(j) = rw(j)*w(j) a = a+w(j) goto 6 5 if (x(j) .gt. xs) goto 7 ! get out at first zero wt on right 6 continue goto 1 ! rightmost pt (may be greater than nright because of ties) 7 nrt = j-1 if (a .gt. 0.D0) goto 8 ok = .false. goto 16 8 ok = .true. ! weighted least squares do 9 j = nleft, nrt ! make sum of w(j) == 1 w(j) = w(j)/a 9 continue if (h .le. 0.D0) goto 14 a = 0.D0 ! use linear fit do 10 j = nleft, nrt ! weighted center of x values a = a+w(j)*x(j) 10 continue b = xs-a c = 0.D0 do 11 j = nleft, nrt c = c+w(j)*(x(j)-a)**2 11 continue if (sqrt(c) .le. .0000001D0*rang) goto 13 b = b/c ! points are spread out enough to compute slope do 12 j = nleft, nrt w(j) = w(j)*(b*(x(j)-a)+1.D0) 12 continue 13 continue 14 ys = 0.D0 do 15 j = nleft, nrt ys = ys+w(j)*y(j) 15 continue 16 return end subroutine lowest ! ! Unimodal density estimation using modified PAVA algorithm ! adapted from code written by Mary Meyer ! Statistica Sinica 11(2001), 1159-1174 ! AN ALTERNATIVE UNIMODAL DENSITY ESTIMATOR ! WITH A CONSISTENT ESTIMATE OF THE MODE ! Mary C. Meyer ! University of Georgia ! ! starts with unimodal interval and then does LCM and GCM on either side ! Approach is a NPMLE modified to handle the unknown mode case - with penalty on mode ! subroutine unidens(num, xvals, xmode, plevel, ecdf) use outstream use sorts integer, intent(in) :: num double precision, dimension(:), intent(inout) :: xvals double precision, intent(out) :: xmode integer, intent(in) :: plevel double precision, dimension(num), intent(out), optional :: ecdf ! double precision, dimension(0:num-1) :: x, s, f double precision, dimension(num-1) :: bigs integer i, j, m, maxu1, maxu2, ms1, ms2, n, u1, u2, u, v double precision alpha, bigllh, bigsl, g, gam, xllh, xn, sl double precision :: d1, d2 call dsort(num, xvals) n = num - 1 x(0:n)=xvals(1:num) xn = dble(n) alpha = xn**(-0.6) bigllh = -10000000000.d0 ms1 = 1 ms2 = n ! ! start main loop for finding max likelihood for mode do m=ms1, ms2 ! find gamma gam = 100000.d0 do i=1, m do j=m, n if (x(j) > x(i-1)) then d1 = alpha/(2.d0*(x(j) - x(i-1))) d2 = dble(2*(j-i+1)) / xn g = sqrt(d1**2 + d1 * (1.d0-d2) + 0.25d0) + (1.d0 - d1*2.d0)/2.d0 if (g < gam) then gam = g imin = i jmin = j end if end if end do end do ! maxu1 = 0 maxu2 = 0 bigsl = 0.d0 do u1=0, m-1 do u2=m, n sl = (dble(u2-u1)/xn)/(alpha + gam*(x(u2)-x(u1))) if(sl > bigsl )then maxu1 = u1 maxu2 = u2 bigsl = sl end if end do end do ! ! now do right end of density: least concave majorant ! find slopes (estimates of density) do i=maxu1+1, maxu2 s(i) = bigsl end do do i=maxu2+1, n s(i) = 1.d0 / (xn * gam * (x(i) - x(i-1))) end do u = maxu2 v = maxu2+1 do while ( v <= n ) if (s(v) > s(u)) then do i=u, v s(i) = dble(v-u+1) / (xn * gam * (x(v) - x(u-1))) end do u = u - 1 else u = v v = v + 1 end if end do ! ! now do left end: greatest concave minorant ! find slopes (estimates of density) do i=1, maxu1 s(i) = 1.d0 / (xn * gam * (x(i) - x(i-1))) end do u = maxu1-1 v = maxu1 do while ( u >= 1 ) if (s(v) bigllh) then do i=1, n bigs(i) = s(i) end do maxm = m mu1 = maxu1 mu2 = maxu2 bigllh = xllh end if end do xmode = 0.5d0*(x(mu2) + x(mu1)) s(0)=0.d0 f(0)=0.d0 if (present(ecdf)) then ecdf(1)=f(0) j=1 do i=1, n j=j+1 s(i) = bigs(i) f(i) = f(i-1) + s(i)*(x(i) - x(i-1)) ecdf(j)=f(i) end do end if if (plevel > 1) then write(outstr, '(3(1x,a14))') 'X', 'Density', 'ECDF' write(outstr, '(3(1x,g14.8))') x(0), s(0), f(0) do i=1, n s(i) = bigs(i) f(i) = f(i-1) + s(i)*(x(i) - x(i-1)) write(outstr, '(3(1x,g14.8))') x(i), s(i), f(i) end do write(outstr,'(3(/a,g12.6)/)') & 'Penalized NPMLE of Mode = ', xmode, & 'Alpha (Likelihood penalty) = ', alpha, & 'Gamma (Lagrange multiplier) = ', gam end if end subroutine unidens end module smooths ! ! AS207 App Stat 33(3):358-362 ! ! fits a generalised loglinear model to fully or partially classified ! frequencies. Combines the EM algorithm with Darroch-Ratcliff iterative ! scaling Ann Math Stat 43:1470-1480. ! ! istop Controls max iterations 0=2 iterations ! ni No. cells in full array ! nj No. cells in the observed array ! nk No. of parameters ! scatter integer array scatter(ni) cell in observed array corr. to ith cell ! in full array ! y real array y(nj) observed frequencies ! model real array model(nid,nk+1) first nk columns is design matrix ! the nk+1th is workspace ! conv convergence parameter ! w w(4,ni) workspace ! v v(2,nkp) workspace ! e real array e(ni) expected frequencies for full array ! f real array f(nj) expected frequencies for observed array ! ifault 1= element of scatter() is outside range 1..nj ! 2= all elements of model() are equal ! plevel 0= usual level of printed output ! 1= prints out values each EM iteration ! 2= prints out values each IPF it. as well ! module AS207 contains subroutine gllm(ni, nj, nk, scatter, y, model, e, f, istop, conv, & lrts, ifault, plevel) integer :: istop, ni, nj, nk, ifault, plevel integer, dimension(ni) :: scatter double precision, intent(in) :: conv double precision, intent(out) :: lrts double precision, dimension(nj) :: y double precision, dimension(ni, nk+1) :: model double precision, dimension(ni) :: e double precision, dimension(nj) :: f integer :: it, sit, ipf double precision :: eps=0.00001d0, zero=0.0d0, one=1.0d0, cmin, csum, ctmax ! work arrays double precision, dimension(4,ni) :: w double precision, dimension(2,nk+1) :: v logical lconv, con1 if (istop <= 0) istop=1 ifault=1 ! ! check the scatter array ! do i=1, ni if (scatter(i).lt.1.or.scatter(i).gt.nj) return end do ifault=0 if (plevel > 0) write(*,'(a)') ' No values out of bound in scatter array ' ! ! initialize ! w(3,:)=zero e=one ! ! standardise the model matrix ! cmin=zero do i=1, ni do k=1, nk if (model(i,k) < cmin) cmin=model(i,k) end do end do if (cmin /= zero) then do i=1, ni do k=1, nk model(i,k)=model(i,k)-cmin end do end do end if ! ! start of until loop ! it=0 100 continue it=it+1 ctmax=zero do i=1, ni csum=zero do k=1, nk csum=csum+model(i,k) end do if (csum > ctmax) ctmax=csum w(4,i)=csum end do if (ctmax <= eps) then ifault=2 return end if ! ! condition ! if (plevel > 0) write(*,'(a,i0)') ' Scaling iteration ', it if (abs(ctmax-one) > eps) then do i=1, ni do k=1, nk model(i,k)=model(i,k)/ctmax end do end do goto 100 end if ! ! end until ! con1=.false. do i=1, ni if (abs(w(4,i)-one) > eps) con1=.true. end do if (con1) then nkk=nk+1 do i=1, ni model(i,nkk)=one-w(4,i) end do else nkk=nk end if ! ! enter the EM algorithm ! main until loop ! sit=0 200 continue sit=sit+1 do j=1,nj f(j)=zero end do do i=1, ni j=scatter(i) f(j)=f(j)+e(i) end do if (plevel > 0) then write(*,'(a,i0)') ' EM Iteration ',sit write(*,'(10(f7.1,1x))') (e(i),i=1,ni) write(*,*) end if ! ! check for convergence ! lconv=.true. do j=1,nj if (abs(f(j)-w(3,j)) > conv) lconv=.false. w(3,j)=f(j) end do ! ! condition for main loop ! if (.not.lconv.and.sit <= istop) then do i=1, ni j=scatter(i) w(1,i)=y(j) if (f(j).gt.eps) w(1,i)=e(i)*y(j)/f(j) end do do k=1, nkk v(1,k)=zero do i=1, ni v(1,k)=v(1,k)+model(i,k)*w(1,i) end do end do ! ! enter i.p.f. algorithm ! nested until loop ! ipf=0 300 continue ipf=ipf+1 do i=1, ni w(2,i)=e(i) end do do k=1, nkk v(2,k)=zero do i=1, ni v(2,k)=v(2,k)+model(i,k)*e(i) end do do i=1, ni if (model(i,k) > eps .and. v(2,k) > eps) then e(i)=e(i)*(v(1,k)/v(2,k))**model(i,k) end if end do end do if (plevel > 1) then write(*,'(a,i3)') ' IPF Iteration ',ipf write(*,'(10(f7.1,1x))') (e(i),i=1,ni) end if ! ! condition for i.p.f. loop ! do i=1, ni if (abs(e(i)-w(2,i)) > conv) goto 300 end do goto 200 ! ! end i.p.f. until loop ! end if ! ! end main loop ! lrts=0.0d0 do j=1, nj yy=y(j) ff=f(j) if (ff > eps) then if (yy > eps) lrts=lrts+yy*log(yy/ff) end if end do lrts=lrts+lrts return end subroutine gllm ! ! call gllm ! subroutine fit_gllm(scatter, y, model, e, f, maxit, conv, lrts, plevel, ifault) use outstream integer, dimension(:) :: scatter double precision, dimension(:) :: y double precision, dimension(:,:) :: model double precision, dimension(:) :: e double precision, dimension(:) :: f integer, intent(in) :: maxit double precision, intent(in) :: conv double precision, intent(out) :: lrts integer, intent(in) :: plevel integer, intent(out) :: ifault integer :: i, ni, nj, nk double precision, dimension(:,:), allocatable :: workmodel ifault=0 nj=size(y) ni=size(model,1) nk=size(model,2) ns=size(scatter) if (ni /= ns) then ifault=1 write(outstr,'(a,i0,a,i0)') 'ni=', ni, ' but ns=', ns return end if if (plevel > 0) then do i=1, ni write(outstr,'(10(f4.1):)', advance='no') model(i,:) write(outstr,'(1x,i2,1x,f5.0)') scatter(i) end do end if allocate(workmodel(ni, nk+1)) workmodel(:,1:nk)=model call gllm(ni, nj, nk, scatter, y, workmodel, e, f, maxit, conv, lrts, ifault, plevel) end subroutine fit_gllm end module AS207 ! ! Combinatorics routines module combinatorics ! public :: nexksb, nexper, twidl contains ! ! Nijenhuis and Wilf Combinatorial Algorithms 1978 P. 19 ! next k-subset subroutine nexksb(n, k, a, mtc, h, m2) integer, intent(in) :: k, n integer, dimension(k) :: a logical mtc integer :: h, m2 integer :: i, j if (k.le.0) then do i=1, n a(i)=0 end do mtc=.false. return end if if (mtc) go to 40 20 m2=0 h=k go to 50 40 if(m2.lt.n-h) h=0 h=h+1 m2=a(k+1-h) 50 do j=1, h a(k+j-h)=m2+j end do mtc=a(1).ne.n-k+1 return end subroutine nexksb ! ! Nijenhuis and Wilf Combinatorial Algorithms 1978 P. 59 ! next permutation of {1,...,n} ! subroutine nexper(n, a, mtc, even, nm3) integer :: n integer, dimension(n) :: a logical :: mtc, even integer :: s, d integer :: nm3 if (mtc) goto 10 nm3=n-3 do 1 i=1,n a(i)=i 1 continue mtc=.true. 5 even=.true. if(n.eq.1)goto 8 6 if(a(n).ne.1.or.a(1).ne.2+mod(n,2))return if(n.le.3)goto 8 do 7 i=1, nm3 if(a(i+1).ne.a(i)+1) return 7 continue 8 mtc=.false. return 10 if (n.eq.1) goto 27 if (.not.even) goto 20 ia=a(1) a(1)=a(2) a(2)=ia even=.false. goto 6 20 s=0 do 26 i1=2,n 25 ia=a(i1) i=i1-1 d=0 do 30 j=1,i if(a(j).gt.ia) d=d+1 30 continue s=d+s if (d.ne.i*mod(s,2)) goto 35 26 continue 27 a(1)=0 goto 8 35 m=mod(s+1,2)*(n+1) do 40 j=1,i if (isign(1,a(j)-ia).eq.isign(1,a(j)-m)) goto 40 m=a(j) l=j 40 continue a(l)=ia a(i1)=m even=.true. return end subroutine nexper ! ! this generates all combinations of m out of n. ! CACM algorithm 382 ! subroutine twidl(x, y, z, done, p, n2) integer :: x, y, z, n2 integer, dimension(n2) :: p logical :: done integer :: i, i1, j, j1, k, k1 j=0 1 j=j+1 if (p(j+1) <= 0) goto 1 if (p(j) /= 0) goto 4 if (j < 3) goto 3 do i=3, j p(i)=-1 end do 3 p(j+1)=0 p(2)=1 x=1 z=1 y=j goto 10 ! 4 if (j > 1) p(j)=0 5 j=j+1 j1=j+1 if (p(j1) > 0) goto 5 i=j-1 k=i 6 i=i+1 i1=i+1 if (p(i1) /= 0) goto 7 p(i1)=-1 goto 6 7 if (p(i1) /= -1) goto 8 z=p(k+1) p(i1)=z x=i y=k p(k+1)=-1 goto 10 ! 8 if (i /= p(1)) goto 9 done=.true. goto 10 ! 9 z=p(i1) p(j1)=z p(i1)=0 x=j y=i 10 return end subroutine twidl end module combinatorics ! ! Statistical functions library ! ! First, support routines for Kuonen saddlepoint approximation for ! the distribution of a quadratic form in p standard Normal variables ie ! a linear combination of p chi-squared distributions with 1 df. ! After the code in Thomas Lumley's survey package ! module kuonen_chisqsum double precision :: brent_kuonen_offset = 0.0d0 double precision, dimension(:), allocatable :: lambda contains function kuonen_k0(zeta, a) double precision :: kuonen_k0 double precision :: zeta double precision, dimension(:) :: a kuonen_k0= -0.5d0 * sum(log(1.0d0-2*zeta*a)) end function kuonen_k0 function kuonen_kp0(zeta, a) double precision :: kuonen_kp0 double precision :: zeta double precision, dimension(:) :: a kuonen_kp0= sum(a/(1.0d0 - 2*zeta*a)) end function kuonen_kp0 function kuonen_kpp0(zeta, a) double precision :: kuonen_kpp0 double precision :: zeta double precision, dimension(:) :: a kuonen_kpp0= 2*sum(a**2/(1.0d0 - 2*zeta*a)**2) end function kuonen_kpp0 ! ! And for minimizing wrt observed statistic function brent_kp0(zeta) double precision :: brent_kp0 double precision :: zeta brent_kp0= abs(sum(lambda/(1.0d0 - 2*zeta*lambda)) - brent_kuonen_offset) end function brent_kp0 end module kuonen_chisqsum ! ! All the functions ! module statfuns ! public :: betacf, binp, ibeta, gammad, alngam, & ! fp, tp, chip, dbeta, chi2nc, zp, & ! mvbvu, satterthwaite, & ! ppnd, chisqd, pchisqsum, probst, & ! fact, lfact, & ! dnorm, dpois, dweib contains ! ! betacf from Numerical Recipes, 1986 ! function betacf(a,b,x) double precision betacf double precision, intent(in) :: a double precision, intent(in) :: b double precision, intent(in) :: x double precision :: qab,qap,qam double precision :: bz,d,ap,bp,app,bpp,am,bm,az,aold,tem,em integer, parameter :: itmax=100 double precision, parameter :: eps=3.0d-7 am=1.0d0 bm=1.0d0 az=1.0d0 qab=a+b qap=a+1.0d0 qam=a-1.0d0 bz=1.0d0-qab*x/qap do m=1,itmax em=m tem=em+em d=em*(b-m)*x/((qam+tem)*(a+tem)) ap=az+d*am bp=bz+d*bm d=-(a+em)*(qab+em)*x/((a+tem)*(qap+tem)) app=ap+d*az bpp=bp+d*bz aold=az am=ap/bpp bm=bp/bpp az=app/bpp bz=1.0d0 if (dabs(az-aold) < eps*dabs(az)) go to 1 end do write(*,'(a/)') 'ERROR: In betacf().' 1 betacf=az end function betacf ! ! This function computes the beta cumulative ! distribution function at the point x. p and q are the ! exponents of x and 1-x in the beta density. see KL Majumder ! GP Bhattacharjee (1973). Algorithm AS 63 The incomplete beta ! integral. Appl Stat 22: 409-411. ! function ibeta(x, p, q) implicit none double precision :: ibeta double precision, intent(in) :: p, q, x integer :: ifault logical :: left double precision :: b, cx, first, pp, qq, sumpq, term, xx ! functions ! double precision alngam ! if (x.le.0.d0) then ibeta=1.d0 return else if (x.ge.1.d0) then ibeta=0.d0 return end if ! ! decide if x is to the left or right of the mean p/sumpq. ! sumpq=p+q if (p >= x*sumpq) then left=.true. cx=1.d0-x xx=x pp=p qq=q else left=.false. cx=x xx=1.d0-x pp=q qq=p end if ! ! initialize terms. ! b=alngam(sumpq, ifault)-alngam(pp, ifault)-alngam(qq+1.d0, ifault) term=exp((pp-1.d0)*log(xx)+qq*log(cx)+b) first=term ibeta=0.d0 ! ! use the integration by parts formula to raise pp and lower qq. ! do while (qq > 1.d0) term=xx*qq*term/(pp*cx) ibeta=ibeta+term if (term/first.lt.1.d-10) then if (left) ibeta=1.d0-ibeta return end if pp=pp+1.d0 qq=qq-1.d0 end do ! ! use Soper's formula to raise pp. ! term=qq*term do while (term/first >= 1.d-10) term=xx*term/pp ibeta=ibeta+term term=sumpq*term pp=pp+1.d0 sumpq=sumpq+1.d0 end do if (left) ibeta=1.d0-ibeta end function ibeta ! ! F-ratio P-values ! function fp(x, n1, n2) double precision :: fp double precision, intent(in) :: x integer, intent(in) :: n1, n2 ! functions ! double precision :: chip, ibeta if (n2 > 4.0d5) then if (n1 > 4.0d5) then if (x < 1) then fp=0.0d0 else if (x == 1) then fp=0.5d0 else fp=1.0d0 end if else fp=chip(x*dble(n1), n1) end if else if (n1 > 4.0d5) then fp=chip(dble(n2)/x, n2) else if (dble(n1)*x > dble(n2)) then fp=1.0d0-ibeta(dble(n2)/(dble(n2)+dble(n1)*x), 0.5d0*dble(n2), 0.5d0*dble(n1)) else fp=ibeta(dble(n1)*x/(dble(n2)+dble(n1)*x), 0.5d0*dble(n1), 0.5d0*dble(n2)) end if end function fp ! ! Wrap fp to give t-distribution P-values ! function tp(x, df) double precision :: tp double precision, intent(in) :: x integer, intent(in) :: df ! functions ! double precision :: fp tp=0.5d0*fp(x*x,1,df) end function tp ! ! Evaluate central chi-square in FORTRAN ! function chip(chisq, df) #if SUN use, intrinsic :: ieee_arithmetic use, intrinsic :: ieee_exceptions #endif double precision chip double precision, intent(in) :: chisq integer, intent(in) :: df integer :: ifault double precision :: p, v, z double precision, parameter :: onethird=1.0d0/3.0d0, twoninths=2.0d0/9.0d0 ! functions ! double precision :: gammad, zp chip=1.0d0 if (df <= 0 .or. chisq <= 0.0d0) return #if SUN if (ieee_is_nan(chisq)) return #else if (isnan(chisq)) return #endif if (df == 1) then z=sqrt(chisq) p=2*zp(z) else p=1.0d0-gammad(0.5d0*chisq, 0.5d0*dble(df), ifault) end if if (p == 0.0d0 .and. df > 1) then v=twoninths/dble(df) z=((chisq/dble(df))**onethird-1.0d0+v)/sqrt(v) p=zp(z) end if chip=p end function chip ! ! Algorithm AS239 Appl. Statist. (1988) Vol. 37, No. 3 ! ! Computation of the Incomplete Gamma Integral ! function gammad(x, p, ifault) double precision gammad double precision, intent(in) :: x double precision, intent(in) :: p integer, intent(in out) :: ifault double precision :: pn1, pn2, pn3, pn4, pn5, pn6, & arg, c, rn, a, b, an double precision, parameter :: zero = 0.d0 double precision, parameter :: one = 1.d0 double precision, parameter :: two = 2.d0 double precision, parameter :: oflo = 1.d+37 double precision, parameter :: three = 3.d0 double precision, parameter :: nine = 9.d0 double precision, parameter :: tol = 1.d-14 double precision, parameter :: xbig = 1.d+8 double precision, parameter :: plimit = 1000.d0 double precision, parameter :: elimit = -88.d0 gammad = zero ! Check that we have valid values for X and P ! if (p .le. zero .or. x .lt. zero) then ! ifault = 1 ! return ! end if ! ifault = 0 ! if (x .eq. zero) return ! Use a normal approximation if P > PLIMIT if (p > plimit) then pn1 = three * sqrt(p) * ((x / p) ** (one / three) + one / (nine * p) - one) gammad = 1.0D0-zp(pn1) return end if ! If X is extremely large compared to P then set GAMMAD = 1 if (x > xbig) then gammad = one return end if if (x <= one .or. x < p) then ! Use Pearson's series expansion. ! (Note that P is not large enough to force overflow in ALNGAM). ! No need to test IFAULT on exit since P > 0. arg = p * log(x) - x - alngam(p + one, ifault) c = one gammad = one a = p 40 a = a + one c = c * x / a gammad = gammad + c if (c > tol) go to 40 arg = arg + log(gammad) gammad = zero if (arg >= elimit) gammad = exp(arg) else ! Use a continued fraction expansion arg = p * log(x) - x - alngam(p, ifault) a = one - p b = a + x + one c = zero pn1 = one pn2 = x pn3 = x + one pn4 = x * b gammad = pn3 / pn4 60 a = a + one b = b + two c = c + one an = a * c pn5 = b * pn3 - an * pn1 pn6 = b * pn4 - an * pn2 if (abs(pn6) > zero) then rn = pn5 / pn6 if (abs(gammad - rn) <= min(tol, tol * rn)) go to 80 gammad = rn end if pn1 = pn3 pn2 = pn4 pn3 = pn5 pn4 = pn6 if (abs(pn5) >= oflo) then ! Re-scale terms in continued fraction if terms are large pn1 = pn1 / oflo pn2 = pn2 / oflo pn3 = pn3 / oflo pn4 = pn4 / oflo end if go to 60 80 arg = arg + log(gammad) gammad = one if (arg >= elimit) gammad = one - exp(arg) end if return end function gammad ! ! ALGORITHM AS245 APPL. STATIST. (1989) VOL. 38, NO. 2 ! Calculation of the logarithm of the gamma function ! function alngam(xvalue, ifault) double precision :: alngam double precision, intent(in) :: xvalue integer, intent(out) :: ifault double precision :: alr2pi, four, half, one, onep5, r1(9), r2(9), & r3(9), r4(5), twelve, x, x1, x2, xlge, xlgst, y, zero ! Coefficients of rational functions data r1/-2.66685511495D0, -2.44387534237D1, & -2.19698958928D1, 1.11667541262D1, 3.13060547623D0, 6.07771387771D-1, & 1.19400905721D1, 3.14690115749D1, 1.52346874070D1/ data r2/-7.83359299449D1, -1.42046296688D2, & 1.37519416416D2, 7.86994924154D1, 4.16438922228D0, 4.70668766060D1, & 3.13399215894D2, 2.63505074721D2, 4.33400022514D1/ DATA r3/-2.12159572323D5, 2.30661510616D5, & 2.74647644705D4, -4.02621119975D4, -2.29660729780D3, -1.16328495004D5, & -1.46025937511D5, -2.42357409629D4, -5.70691009324D2/ DATA r4/ 2.79195317918525D-1, 4.917317610505968D-1, & 6.92910599291889D-2, 3.350343815022304D0, 6.012459259764103D0/ ! Fixed constants DATA alr2pi/9.18938533204673D-1/, four/4.d0/, half/0.5D0/, & one/1.d0/, onep5/1.5D0/, twelve/12.d0/, zero/0.d0/ ! Machine-dependant constants. ! A table of values is given at the top of page 399 of the paper. ! These values are for the IEEE double-precision format for which ! B = 2, t = 53 and U = 1023 in the notation of the paper. DATA xlge/5.10D6/, xlgst/1.d+305/ x = xvalue alngam = zero ! Test for valid function argument ifault = 2 IF (x >= xlgst) RETURN ifault = 1 IF (x <= zero) RETURN ifault = 0 ! Calculation for 0 < X < 0.5 and 0.5 <= X < 1.5 combined IF (x < onep5) THEN IF (x < half) THEN alngam = -LOG(x) y = x + one ! Test whether X < machine epsilon IF (y == one) RETURN ELSE alngam = zero y = x x = (x - half) - half END IF alngam = alngam + x * ((((r1(5)*y + r1(4))*y + r1(3))*y & + r1(2))*y + r1(1)) / ((((y + r1(9))*y + r1(8))*y + r1(7))*y + r1(6)) RETURN END IF ! Calculation for 1.5 <= X < 4.0 IF (x < four) THEN y = (x - one) - one alngam = y * ((((r2(5)*x + r2(4))*x + r2(3))*x + r2(2))*x & + r2(1)) / ((((x + r2(9))*x + r2(8))*x + r2(7))*x + r2(6)) RETURN END IF ! Calculation for 4.0 <= X < 12.0 IF (x < twelve) THEN alngam = ((((r3(5)*x + r3(4))*x + r3(3))*x + r3(2))*x + r3(1)) / & ((((x + r3(9))*x + r3(8))*x + r3(7))*x + r3(6)) RETURN END IF ! Calculation for X >= 12.0 y = LOG(x) alngam = x * (y - one) - half * y + alr2pi IF (x > xlge) RETURN x1 = one / x x2 = x1 * x1 alngam = alngam + x1 * ((r4(3)*x2 + r4(2))*x2 + r4(1)) / & ((x2 + r4(5))*x2 + r4(4)) RETURN END FUNCTION alngam ! ! density of gamma = x^(a-1) e^(-x/b) / b^a Gamma(a) ! = 1/b (x/b)^(a-1) exp(-x/b) / Gamma(a) ! log density = log(x)*(a-1) + -x/b - a*log(b) - lgamma(a) ! = log(x/b)*(a-1) - log(b) - x/b - lgamma(a) ! Given m = E(x) = a*b, can rewrite as m and a (shape) ! = log(x)*(a-1) - x a/m - a*log(m/a) - lgamma(a) ! = log(x)*(a-1) - log(m) -log(a) - x a/m - lgamma(a) ! log(x * (a/m)) * (a-1) - x * (a/m) - log(a)*log(m)*lgamma(a) ! log gamma density ! function dgamma(x, mu, shap) double precision :: dgamma double precision, intent(in) :: mu, shap, x double precision, parameter :: small = 1.0d-12 integer :: ierr double precision :: b, x1 dgamma=0.0d0 if (x < 0.0d0) return x1=x if (x1 == 0.0d0) x1 = small b=mu/shap dgamma=(shap-1.0d0)*ln(x1) - x1/b - shap*ln(b) - alngam(shap, ierr) ! dgamma=(shap-1.0d0) * ln(x1) - shap*ln(mu) - r * x1/mu + shap*ln(shap) - alngam(shap, ierr) return end function dgamma ! Beta density as exp(lgamma(a+b)-lgamma(a)+lgamma(b)+ (a-1)*log(x) + (b-1)*log(1-x)) ! function dbeta(x, a, b) double precision :: dbeta double precision, intent(in) :: a, b, x double precision, parameter :: small = 1.0d-12 integer :: ierr double precision :: x1 dbeta=0.0d0 if (x < 0.0d0 .or. x > 1.0d0) return x1=x if (x1 == 1.0d0) x1 = 1.0d0-small if (x1 == 0.0d0) x1 = small dbeta=exp(alngam(a+b, ierr)-alngam(a, ierr)-alngam(b, ierr) + & (a-1.0d0)*log(x1) + (b-1.0d0)*log(1.0d0-x1)) return end function dbeta ! ! ALGORITHM AS 275 APPL.STATIST. (1992), VOL.41, NO.2 ! ! Computes the noncentral chi-square distribution function ! with positive real degrees of freedom f and nonnegative ! noncentrality parameter theta ! function chi2nc(x, f, ncp, ifault) double precision :: chi2nc double precision :: x, f, ncp integer :: ifault logical :: flag double precision :: lam, n, u, v, x2, f2, t, term, bound ! functions ! double precision :: alngam integer :: ITRMAX double precision :: ERRMAX, ZERO, ONE, TWO data ERRMAX, ITRMAX / 1.0E-6, 50 / data ZERO, ONE, TWO / 0.0d0, 1.0d0, 2.0d0 / chi2nc = x ifault = 2 if (f <= ZERO .or. ncp < ZERO) return ifault = 3 if (x < ZERO) return ifault = 0 if (x == zero) return lam = ncp / TWO ! ! Evaluate the first term ! n = ONE u = exp(-lam) v = u x2 = x / TWO f2 = f / TWO t = x2 ** f2 * exp(-x2) / exp(alngam((f2 + ONE), ifault)) ! ! There is no need to test IFAULT si ! already been checked ! term = v * t chi2nc = term ! ! Check if (f+2n) is greater than x ! flag = .false. 10 if ((f + TWO * n - x) <= ZERO) go to 30 ! ! Find the error bound and check for convergence ! flag = .true. 20 bound = t * x / (f + two * n - x) if (bound > ERRMAX .and. int(n) <= ITRMAX) go to 30 if (bound > ERRMAX) ifault = 1 return ! ! Evaluate the next term of the expansion and then the ! partial sum ! 30 u = u * lam / n v = v + u t = t * x / (f + two * n) term = v * t chi2nc = chi2nc + term n = n + one if (flag) go to 20 go to 10 end function chi2nc ! ! Normal distribution probabilities accurate to 1d-15. ! Reference: J.L. Schonfelder, Math Comp 32(1978), pp 1232-1240. ! Gives one additional digit of accuracy cf Alan Miller's ! function zp(z) double precision :: zp double precision, intent(in) :: z integer :: i double precision :: a(0:43), bm, b, bp, p, t, xa double precision, parameter :: rtwo = 1.414213562373095048801688724209D0 integer, parameter :: im = 24 save a data ( a(i), i = 0, 43 )/ 6.10143081923200417926465815756D-1, & -4.34841272712577471828182820888D-1, 1.76351193643605501125840298123D-1, & -6.0710795609249414860051215825D-2, 1.7712068995694114486147141191D-2, & -4.321119385567293818599864968D-3, 8.54216676887098678819832055D-4, & -1.27155090609162742628893940D-4, & 1.1248167243671189468847072D-5, 3.13063885421820972630152D-7, & -2.70988068537762022009086D-7, 3.0737622701407688440959D-8, & 2.515620384817622937314D-9, -1.028929921320319127590D-9, & 2.9944052119949939363D-11, 2.6051789687266936290D-11, & -2.634839924171969386D-12, -6.43404509890636443D-13, & 1.12457401801663447D-13, 1.7281533389986098D-14, & -4.264101694942375D-15, -5.45371977880191D-16, & 1.58697607761671D-16, 2.0899837844334D-17, & -5.900526869409D-18, -9.41893387554D-19, 2.14977356470D-19, & 4.6660985008D-20, -7.243011862D-21, -2.387966824D-21, & 1.91177535D-22, 1.20482568D-22, -6.72377D-25, -5.747997D-24, & -4.28493D-25, 2.44856D-25, 4.3793D-26, -8.151D-27, -3.089D-27, & 9.3D-29, 1.74D-28, 1.6D-29, -8.0D-30, -2.0D-30 / xa = ABS(z)/rtwo if ( xa > 100 ) then p = 0 else t = ( 8*xa - 30 ) / ( 4*xa + 15 ) bm = 0 b = 0 do i = im, 0, -1 bp = b b = bm bm = t*b - bp + a(i) end do p = EXP( -xa*xa )*( bm - bp )/4 end if if ( z < 0 ) p = 1 - p zp = p end function zp ! ! Nice approximation for extreme normal probabilities ! Exponentiating these large negative log values leads to underflow ! From Mizawa 2026 Practical Method for log[erfc(a)] approximation ! 10.20944/preprints202603.0686.v1 ! function mizawa_zp(z) double precision :: mizawa_zp double precision, intent(in) :: z double precision :: a, logp_lower a=z/sqrt(2.0d0) logp_lower= -a*a - log(a+sqrt(a*a+2.0d0)) mizawa_zp=(logp_lower+log(0.5d0))/log(10.0d0) ! mizawa_zp=0.5d0*exp(logp_lower) end function mizawa_zp ! ! A function for computing bivariate normal probabilities; ! developed using ! Drezner, Z. and Wesolowsky, G. O. (1989), ! On the Computation of the Bivariate Normal Integral, ! J. Stat. Comput. Simul.. 35 pp. 101-107. ! with extensive modications for double precisions by ! Alan Genz and Yihong Ge ! Department of Mathematics ! Washington State University ! Pullman, WA 99164-3113 ! Email : alangenz@wsu.edu ! ! BVN - calculate the probability that X is larger than SH and Y is ! larger than SK. ! ! Parameters ! ! SH REAL, integration limit ! SK REAL, integration limit ! R REAL, correlation coefficient ! LG INTEGER, number of Gauss Rule Points and Weights ! function mvbvu(sh, sk, r) double precision :: mvbvu double precision, intent(in) :: sh, sk, r double precision, parameter :: ZERO = 0, TWOPI = 6.283185307179586D0 integer :: i, lg, ng double precision, dimension(10, 3) :: x, w double precision :: as, a, b, c, d, rs, xs double precision :: bvn, sn, asr, h, k, bs, hs, hK save x, w ! functions ! double precision :: zp ! Gauss Legendre Points and Weights, N = 6 data ( w(i,1), x(i,1), i = 1, 3 ) / & 0.1713244923791705D+00,-0.9324695142031522D+00, & 0.3607615730481384D+00,-0.6612093864662647D+00, & 0.4679139345726904D+00,-0.2386191860831970D+00/ ! Gauss Legendre Points and Weights, N = 12 data ( W(I,2), X(I,2), I = 1, 6 ) / & 0.4717533638651177D-01,-0.9815606342467191D+00, & 0.1069393259953183D+00,-0.9041172563704750D+00, & 0.1600783285433464D+00,-0.7699026741943050D+00, & 0.2031674267230659D+00,-0.5873179542866171D+00, & 0.2334925365383547D+00,-0.3678314989981802D+00, & 0.2491470458134029D+00,-0.1252334085114692D+00/ ! Gauss Legendre Points and Weights, N = 20 data ( W(I,3), X(I,3), I = 1, 10 ) / & 0.1761400713915212D-01,-0.9931285991850949D+00, & 0.4060142980038694D-01,-0.9639719272779138D+00, & 0.6267204833410906D-01,-0.9122344282513259D+00, & 0.8327674157670475D-01,-0.8391169718222188D+00, & 0.1019301198172404D+00,-0.7463319064601508D+00, & 0.1181945319615184D+00,-0.6360536807265150D+00, & 0.1316886384491766D+00,-0.5108670019508271D+00, & 0.1420961093183821D+00,-0.3737060887154196D+00, & 0.1491729864726037D+00,-0.2277858511416451D+00, & 0.1527533871307259D+00,-0.7652652113349733D-01/ if (abs(r) < 0.3d0) then ng = 1 lg = 3 else if ( abs(r) < 0.75d0) then ng = 2 lg = 6 else ng = 3 lg = 10 end if h = sh k = sk hk = h*k bvn = 0.0d0 if ( abs(r) < 0.925d0) then hs = (h*h + k*k)/2 asr = asin(r) do i = 1, lg sn = sin(asr*( x(i,ng)+1 )/2) bvn = bvn + w(i,ng)*exp((sn*hk-hs)/(1-sn*sn)) sn = sin(asr*(-x(i,ng)+1 )/2) bvn = bvn + w(i,ng)*exp((sn*hk-hs)/(1-sn*sn)) end do bvn = bvn*asr/(2*twopi) + zp(h)*zp(k) else if (r < 0.0d0) then k = -k hk = -hk end if if (abs(r) < 1.0d0) then as = (1-r)*(1+r) a = sqrt(as) bs = (h-k)**2 c = ( 4 - hk )/8 d = ( 12 - hk )/16 bvn = a*exp( -(bs/as + hk)/2 ) & *( 1 - c*(bs - as)*(1 - d*bs/5)/3 + c*d*as*as/5 ) if (hk > -160d0) then b = sqrt(bs) bvn = bvn - exp(-hk/2)*sqrt(twopi)*zp(b/a)*b & *( 1 - c*bs*( 1 - d*bs/5 )/3 ) end if a = a/2 do i = 1, lg xs = ( a*(x(i,ng)+1) )**2 rs = sqrt(1 - xs) bvn = bvn + a*w(i,ng)* & ( exp( -bs/(2*xs) - hk/(1+rs) )/rs & - exp( -(bs/xs+hk)/2 )*( 1 + c*xs*( 1 + d*xs ) ) ) xs = as*(-x(i,ng)+1)**2/4 rs = sqrt(1 - xs) bvn = bvn + a*w(i,ng)*exp( -(bs/xs + hk)/2 ) & *( exp( -hk*(1-rs)/(2*(1+rs)) )/rs & - ( 1 + c*xs*( 1 + d*xs ) ) ) end do bvn = -bvn/twopi end if if ( r > 0.0d0) bvn = bvn + zp(max(h, k)) if ( r < 0.0d0) bvn = -bvn + max( zero, zp(h) - zp(k) ) end if mvbvu = bvn end function mvbvu ! ! From TOMS717 ! Bunch DS, Gay DM, Welsch RE. Subroutines for Maximum Likelihood and ! Quasi-Likelihood Estimation of Parameters in Nonlinear Regression Models ! ! mecdf is designed to calculate the MVN CDF using the ! Mendell-Elston procedure as described in Kamakura (1989). ! NOTE: Equation (15) in Kamakura has an error. ! ! Specifically, assume that Z is a set of random variables ! with a standard normal distribution with correlations ! stored in RHO (in packed form). Then this subroutine ! calculates Prob[Z(1)>D(1);...; Z(NDIM) > D(NDIM)]. ! ! Code converted using TO_F90 by Alan Miller ! subroutine mecdf(ndim, d, idir, rho, prob, ier) integer, intent(in) :: ndim double precision, intent(in) :: d(*) ! threshold integer, intent(in) :: idir(*) ! integrate above or below threshold double precision, intent(in) :: rho(*) ! correlation matrix double precision, intent(out) :: prob integer, intent(out) :: ier integer :: astat, i, im1, ir, j, jm1, k, km1 double precision :: dir1, dir2, probi, tmp double precision, dimension(:,:,:), allocatable :: r double precision :: sig(ndim,0:ndim-1), & u(ndim), uumz(max(1,ndim-1)), z(ndim,0:ndim-1) double precision, parameter :: one=1.d0 double precision, parameter :: zero=0.d0 ier = 0 ! Set up arrays allocate(r(ndim,ndim,0:ndim-1), stat=astat) if (astat /= 0) then ier=-1 return end if ir = 0 do i = 1, ndim dir1=dble(idir(i)) z(i,0) = sign(1.0d0, dir1)*d(i) do j = 1, i-1 dir2=dble(idir(j)) ir = ir + 1 r(j,i,0) = sign(1.0d0, dir1*dir2)*rho(ir) end do end do prob = zp(z(1,0)) if (prob <= zero) then ier = 1 return end if u(1) = phi(z(1,0), zero)/prob uumz(1) = u(1)*(u(1)-z(1,0)) ! Main loop do i = 2, ndim im1 = i-1 do j = 1, im1 jm1 = j-1 do k = 1, jm1 km1 = k-1 tmp = r(j,i,km1)-r(k,j,km1)*r(k,i,km1)*uumz(k) r(j,i,k) = tmp/sig(j,k)/sig(i,k) end do sig(i,j) = sqrt(one - uumz(j)*r(j,i,jm1)**2) z(i,j) = (z(i,jm1)-u(j)*r(j,i,jm1))/sig(i,j) end do probi = zp(z(i,im1)) if (probi <= zero) then ier = i return end if prob = prob * probi if (i < ndim) then u(i) = phi(z(i,im1), zero)/probi uumz(i) = u(i)*(u(i)-z(i,im1)) end if end do end subroutine mecdf ! function phi(x, y) double precision :: phi double precision, intent(in) :: x double precision, intent(in) :: y double precision :: arg double precision, parameter :: half = 0.5d0 double precision, parameter :: sq2p = 0.91893853320467274d0 double precision, parameter :: xlow = -87.d0 double precision, parameter :: zero = 0.d0 phi = zero arg = -half * x * x - sq2p - y if (arg > xlow) phi = exp(arg) end function phi ! ! ALGORITHM AS241 APPL. STATIST. (1988) VOL. 37, NO. 3 ! Produces the normal deviate Z corresponding to a given lower ! tail area of P. Replaces AS111 as more accurate for smaller P's. ! function ppnd(p) double precision :: ppnd double precision, intent(in) :: p double precision :: q, r double precision, parameter :: split1 = 0.425d0 double precision, parameter :: split2 = 5.0d0 double precision, parameter :: const1 = 0.180625D0 double precision, parameter :: const2 = 1.6D0 ! Coefficients for P close to 0.5 double precision, parameter :: a0 = 3.3871328727963666080D0 double precision, parameter :: a1 = 1.3314166789178437745D+2 double precision, parameter :: a2 = 1.9715909503065514427D+3 double precision, parameter :: a3 = 1.3731693765509461125D+4 double precision, parameter :: a4 = 4.5921953931549871457D+4 double precision, parameter :: a5 = 6.7265770927008700853D+4 double precision, parameter :: a6 = 3.3430575583588128105D+4 double precision, parameter :: a7 = 2.5090809287301226727D+3 double precision, parameter :: b1 = 4.2313330701600911252D+1 double precision, parameter :: b2 = 6.8718700749205790830D+2 double precision, parameter :: b3 = 5.3941960214247511077D+3 double precision, parameter :: b4 = 2.1213794301586595867D+4 double precision, parameter :: b5 = 3.9307895800092710610D+4 double precision, parameter :: b6 = 2.8729085735721942674D+4 double precision, parameter :: b7 = 5.2264952788528545610D+3 ! Coefficients for P not close to 0, 0.5 or 1. double precision, parameter :: c0 = 1.42343711074968357734D0 double precision, parameter :: c1 = 4.63033784615654529590D0 double precision, parameter :: c2 = 5.76949722146069140550D0 double precision, parameter :: c3 = 3.64784832476320460504D0 double precision, parameter :: c4 = 1.27045825245236838258D0 double precision, parameter :: c5 = 2.41780725177450611770D-1 double precision, parameter :: c6 = 2.27238449892691845833D-2 double precision, parameter :: c7 = 7.74545014278341407640D-4 double precision, parameter :: d1 = 2.05319162663775882187D0 double precision, parameter :: d2 = 1.67638483018380384940D0 double precision, parameter :: d3 = 6.89767334985100004550D-1 double precision, parameter :: d4 = 1.48103976427480074590D-1 double precision, parameter :: d5 = 1.51986665636164571966D-2 double precision, parameter :: d6 = 5.47593808499534494600D-4 double precision, parameter :: d7 = 1.05075007164441684324D-9 ! Coefficients for P near 0 or 1. double precision, parameter :: e0 = 6.65790464350110377720D0 double precision, parameter :: e1 = 5.46378491116411436990D0 double precision, parameter :: e2 = 1.78482653991729133580D0 double precision, parameter :: e3 = 2.96560571828504891230D-1 double precision, parameter :: e4 = 2.65321895265761230930D-2 double precision, parameter :: e5 = 1.24266094738807843860D-3 double precision, parameter :: e6 = 2.71155556874348757815D-5 double precision, parameter :: e7 = 2.01033439929228813265D-7 double precision, parameter :: f1 = 5.99832206555887937690D-1 double precision, parameter :: f2 = 1.36929880922735805310D-1 double precision, parameter :: f3 = 1.48753612908506148525D-2 double precision, parameter :: f4 = 7.86869131145613259100D-4 double precision, parameter :: f5 = 1.84631831751005468180D-5 double precision, parameter :: f6 = 1.42151175831644588870D-7 double precision, parameter :: f7 = 2.04426310338993978564D-15 q = (2*p - 1.0d0)/2.0d0 if ( ABS(q) <= split1 ) then r = const1 - q*q ppnd = q*( ( ( ((((a7*r + a6)*r + a5)*r + a4)*r + a3) & *r + a2 )*r + a1 )*r + a0 ) /( ( ( ((((b7*r + b6)*r + b5)*r + b4)*r + b3) & *r + b2 )*r + b1 )*r + 1 ) else r = MIN( p, 1.0d0 - p ) if ( r > 0.0d0 ) then r = SQRT( -LOG(r) ) if ( r <= split2 ) then r = r - const2 ppnd = ( ( ( ((((c7*r + c6)*r + c5)*r + c4)*r + c3) & *r + c2 )*r + c1 )*r + c0 ) & /( ( ( ((((d7*r + d6)*r + d5)*r + d4)*r + d3) *r + d2 )*r + d1 )*r + 1 ) else r = r - split2 ppnd = ( ( ( ((((e7*r + e6)*r + e5)*r + e4)*r + e3) & *r + e2 )*r + e1 )*r + e0 ) & /( ( ( ((((f7*r + f6)*r + f5)*r + f4)*r + f3) *r + f2 )*r + f1 )*r + 1 ) end if else ppnd = 9.0d0 end if if (q < 0.0d0) ppnd = - ppnd end if end function ppnd ! ! Richard Goldstein, Algorithm 451: Chi-Square Quantiles, ! Communications of the ACM, August 1973, Volume 16, Number 8, pages 483-484. ! Transcribed to machine readable form by John Burkhardt ! function chisqd(p, n) double precision :: chisqd integer, intent(in) :: n double precision, intent(in) :: p double precision :: f, f1, t double precision, dimension(19) :: A double precision, dimension(21) :: C ! functions ! double precision :: ppnd data c(1)/1.565326e-3/, c(2)/1.060438e-3/, & c(3)/-6.950356e-3/, c(4)/-1.323293e-2/, & c(5)/2.277679e-2/, c(6)/-8.986007e-3/, & c(7)/-1.513904e-2/, c(8)/2.530010e-3/, & c(9)/-1.450117e-3/, c(10)/5.169654e-3/, & c(11)/-1.153761e-2/, c(12)/1.128186e-2/, & c(13)/2.607083e-2/, c(14)/-0.2237368/, & c(15)/9.780499e-5/, c(16)/-8.426812e-4/, & c(17)/3.125580e-3/, c(18)/-8.553069e-3/, & c(19)/1.348028e-4/, c(20)/0.4713941/, c(21)/1.0000886/ data a(1)/1.264616e-2/, a(2)/-1.425296e-2/, & a(3)/1.400483e-2/, a(4)/-5.886090e-3/, & a(5)/-1.091214e-2/, a(6)/-2.304527e-2/, & a(7)/3.135411e-3/, a(8)/-2.728484e-4/, & a(9)/-9.699681e-3/, a(10)/1.316872e-2/, & a(11)/2.618914e-2/, a(12)/-0.2222222/, & a(13)/5.406674e-5/, a(14)/3.483789e-5/, & a(15)/-7.274761e-4/, a(16)/3.292181e-3/, & a(17)/-8.729713e-3/, a(18)/0.4714045/, a(19)/1./ chisqd = 0.0d0 if (n <= 0 .or. p > 1.0d0 .or. p < 0.0d0) then return else if (n == 1) then chisqd = ppnd(0.5d0*p) chisqd = chisqd*chisqd return else if (n == 2) then chisqd = -2 * log(p) return else f = n f1 = 1.0D0 / f t = ppnd(1-p) f2 = sqrt(f1) * t if ( n < (2+int(4*abs(T)))) then chisqd =(((((((c(1)*f2+c(2))*f2+c(3))*f2+c(4))*f2 & +c(5))*f2+c(6))*f2+c(7))*f1+((((((c(8)+c(9)*f2)*f2 & +c(10))*f2+c(11))*f2+c(12))*f2+c(13))*f2+c(14)))*f1 + & (((((c(15)*f2+c(16))*f2+c(17))*f2+c(18))*f2 & +c(19))*f2+c(20))*f2+c(21) else chisqd = (((a(1)+a(2)*f2)*f1+(((a(3)+a(4)*f2)*f2 & +a(5))*f2+a(6)))*f1+(((((a(7)+a(8)*f2)*f2+a(9))*f2 & +a(10))*f2+a(11))*f2+a(12)))*f1 + (((((a(13)*f2 & +a(14))*f2+a(15))*f2+a(16))*f2+a(17))*f2*f2 & +a(18))*f2+a(19) end if chisqd = chisqd*chisqd*chisqd*f return end if end function chisqd ! ! Algorithm AS 3 Appl. Statist. (1968) vol.17, p.189 ! student t probability (lower tail) ! FUNCTION probst(t, idf, ifault) DOUBLE PRECISION :: probst DOUBLE PRECISION, INTENT(IN) :: t INTEGER, INTENT(IN) :: idf INTEGER, INTENT(OUT) :: ifault INTEGER :: im2, ioe DOUBLE PRECISION :: a, b, c, f, g1, s, fk, zero, one, two, half, zsqrt, zatan ! g1 is reciprocal of pi DATA zero, one, two, half, g1 /0.0D0, 1.0D0, 2.0D0, 0.5D0, 0.3183098861838D0/ zsqrt(a) = SQRT(a) zatan(a) = ATAN(a) ifault = 1 probst = zero IF (idf < 1) RETURN ifault = 0 f = idf a = t / zsqrt(f) b = f / (f + t ** 2) im2 = idf - 2 ioe = MOD(idf, 2) s = one c = one f = one ks = 2 + ioe fk = ks IF (im2 < 2) GO TO 20 DO k = ks, im2, 2 c = c * b * (fk - one) / fk s = s + c IF (s == f) EXIT f = s fk = fk + two END DO 20 IF (ioe == 1) GO TO 30 probst = half + half * a * zsqrt(b) * s if (probst > one) probst=one RETURN 30 IF (idf == 1) s = zero probst = half + (a * b * s + zatan(a)) * g1 if (probst > one) probst=one RETURN END FUNCTION probst ! ! Satterthwaite approximation for quadratic form of normals ! function satterthwaite(q, a) double precision :: satterthwaite double precision :: q double precision, dimension(:) :: a integer :: i, n double precision df, tr, tr2, scal n=size(a) tr=sum(a)/dfloat(n) tr2=sum(a**2)/dfloat(n)/tr/tr scal=tr*tr2 df=dfloat(n)/tr2 satterthwaite=chip(q/scal, int(df)) end function satterthwaite ! ! Factorial ! function fact(n) double precision :: fact integer, intent(in) :: n integer :: i double precision :: lookup(0:20) = (/ & 1.0d0, 1.0d0, 2.0d0, 6.0d0, 2.4d1, 1.2d2, 7.2d2, 5.04d3, & 4.032d4, 3.6288d5, 3.6288d6, 3.99168d7, 4.790016d8, & 6.2270208d9, 8.71782912d10, 1.307674368d12, & 2.0922789888d13, 3.55687428096d14, 6.402373705728d15, & 1.21645100408832d17, 2.43290200817664d18 /) if (n < 21) then fact=lookup(n) else fact=exp(alngam(dble(n)+1.0d0, i)) end if return end function fact ! ! Log factorial ! function lfact(n) double precision :: lfact integer, intent(in) :: n integer :: ierr lfact=alngam(dble(n)+1.0d0, ierr) end function lfact ! ! Log gaussian density ! function dnorm(x, mu, sd) double precision :: dnorm double precision, intent(in) :: x double precision, intent(in) :: mu double precision, intent(in) :: sd double precision :: picons, xx data picons /0.91893853320467274178D0/ xx = (x-mu)/sd dnorm = -(picons + 0.5D0*xx*xx + log(sd)) return end function dnorm ! ! Log poisson density ! function dpois(x, mu) double precision :: dpois double precision, intent(in) :: x double precision, intent(in) :: mu integer :: ifault ! functions double precision :: ln dpois=0.0D0 if (mu > 0.0D0) then dpois=-mu + x*ln(mu) - alngam(x+1.0D0, ifault) end if return end function dpois ! ! Log Weibull density (with censoring) ! function dweib(x, mu, shap, cens) double precision :: dweib double precision, intent(in) :: x double precision, intent(in) :: mu double precision, intent(in) :: shap double precision, intent(in) :: cens double precision :: loghaz, logsurv ! functions double precision :: ln dweib=0.0D0 if (mu > 0.0D0) then loghaz=ln(shap) + (shap-1.0d0)*ln(x) + ln(mu) logsurv= -mu*x**shap dweib=cens*loghaz + logsurv end if return end function dweib ! ! Binomial probabilities for x,n-x with p=0.5 ! function binp(np,nq) double precision binp double precision, intent(in) :: np double precision, intent(in) :: nq integer :: i double precision :: a, b, bt if (np == nq) then binp=1.0d0 return end if if (np > nq) then a=np b=nq+1.0d0 else a=nq b=np+1.0d0 end if bt=dexp(alngam(a+b,i)-alngam(a,i)-alngam(b,i)+(a+b)*dlog(0.5d0)) binp=bt*betacf(a,b,0.5d0)/a ! two-tailed P binp=binp+binp if (binp > 1.0D0) binp=1.0D0 end function binp ! ! Saddlepoint approximation routine for ! quadratic form in normal variables ! subroutine pchisqsum(q, a, pval) #if SUN use, intrinsic :: ieee_arithmetic use, intrinsic :: ieee_exceptions #endif use kuonen_chisqsum double precision :: q double precision, dimension(:) :: a double precision :: pval logical :: usesat integer :: i, n double precision :: d, hatzeta, lmin, lmax, obj, v, w ! functions double precision :: brent n=size(a) d=maxval(a) allocate(lambda(n)) lambda=a/d q=q/d if (any(lambda < 0)) then lmin=0.99999d0/(2*minval(lambda)) else if (q > sum(lambda)) then lmin=-0.01 else lmin=-0.5d0*dble(n)/q end if lmax=0.99999d0/(2*maxval(lambda)) brent_kuonen_offset = q hatzeta=brent(lmin, lmax, brent_kp0, 1.0d-8) ! call fibmin (brent_kp0, lmin, lmax, 1.0d-8, hatzeta, obj) usesat=.false. #if SUN usesat=ieee_is_nan(hatzeta) .or. abs(hatzeta) < 1.0d-04 #else usesat=isnan(hatzeta) .or. abs(hatzeta) < 1.0d-04 #endif if (usesat) then pval=satterthwaite(q, lambda) else w=sign(1.0d0, hatzeta) * sqrt(2 * (hatzeta * q - kuonen_k0(hatzeta, lambda))) v=hatzeta * sqrt(kuonen_kpp0(hatzeta, lambda)) pval=zp(w + log(v/w)/w) end if deallocate(lambda) end subroutine pchisqsum end module statfuns ! ! Distance correlation (Székely and Rizzo) ! Nonparametric correlations that can be applied to very arbitrary data, ! including pairs of multidimensional variables of different dimensions. ! module distance_cor contains subroutine ucentre(n, nn, x) integer, intent(in) :: n, nn double precision, dimension(nn), intent(inout) :: x integer :: i, idx, j double precision, dimension(n) :: s double precision :: tot ! functions integer :: clcpos tot=0.0d0 do i=1, n s(i)=0.0d0 do j=1, n s(i)=s(i)+x(clcpos(i,j)) end do tot=tot+s(i) s(i)=s(i)/dble(n-2) end do tot=tot/dble(n-1)/dble(n-2) idx=0 do i=1, n do j=1, i-1 idx=idx+1 x(idx)=x(idx)-s(i)-s(j)+tot end do idx=idx+1 end do end subroutine ucentre ! ! Simplest (n^2) algorithm for univariate distance covariance (here L2) ! subroutine distcor(n, x, y, dcov12, dvar1, dvar2, dcor12) use symmetric_matrix use outstream use sorts integer, intent(in) :: n double precision, dimension(:,:), intent(in) :: x, y double precision, intent(out) :: dcov12, dvar1, dvar2, dcor12 integer :: astat, i, j, k, nc1, nc2, nn, pos double precision, dimension(:), allocatable :: xx, yy double precision :: aa, ab, bb, d1, d2 dcov12=0.0d0 dvar1=0.0d0 dvar2=0.0d0 dcor12=0.0d0 i=size(x,1) j=size(y,1) if (i /= j .or. i < n .or. j < n) then write(outstr,'(a,i0,a,i0,a,i0,a)') & 'ERROR: Number of rows for X, ', i, ' and Y ', j, ' (expected ', n, ').' return end if nc1=size(x,2) nc2=size(y,2) if (nc1 < 1 .or. nc2 < 1) then write(outstr,'(a,i0,a,i0,a)') & 'ERROR: number of columns for X, ', nc1, ' and Y ', nc2, '.' return end if if (n < 4) then write(outstr,'(a,i0,a)') 'ERROR: Too small N=', n, '.' return end if nn=n*(n+1)/2 allocate(xx(nn), yy(nn), stat=astat) if (astat /= 0) then write(outstr,'(a,i0,a)') & 'ERROR: Was not able to allocate memory for ', 2*nn, 'distances.' return end if pos=0 do i=1, n do j=1, i pos=pos+1 d1=0.0d0 d2=0.0d0 do k=1, nc1 d1=d1+(x(i,k)-x(j,k))**2 end do xx(pos)=sqrt(d1) do k=1, nc2 d2=d2+(y(i,k)-y(j,k))**2 end do yy(pos)=sqrt(d2) end do end do call ucentre(n, nn, xx) call ucentre(n, nn, yy) dn=dfloat(n*(n-3)) aa=0.0d0 ab=0.0d0 bb=0.0d0 pos=0 do i=1, n do j=1, i pos=pos+1 d1=xx(pos) d2=yy(pos) ab=ab+d1*d2 aa=aa+d1*d1 bb=bb+d2*d2 end do end do ab = (ab+ab)/dn aa = (aa+aa)/dn bb = (bb+bb)/dn v = aa * bb if (v > 1.0d0-16 .and. ab /= 0.0d0) dcor12 = ab/sqrt(v) dcov12=ab dvar1=aa dvar2=bb end subroutine distcor end module distance_cor ! ! Algorithm AS 164: Least Squares Subject to Linear Constraints ! Author(s): W. Douglas Stirling ! Source: Applied Statistics, Vol. 30, No. 2, (1981), pp. 204-212 ! module AS164 contains ! ! Initialize covariance matrix used by AS164 ! subroutine inicov(nter, ncov, r) integer, intent(in) :: nter integer, intent(in) :: ncov double precision, intent(inout) :: r(ncov) integer :: i, j r=0.0d0 j=0 do i=1, nter j=j+i r(j)=-1.0d0 end do end subroutine inicov ! ! Algorithm AS164 Appl. Statist. (1981) vol.30, no.2 ! Incorporate new row of data into R matrix ! subroutine givenc(r, ir, nvars, x, v, ifault) double precision, intent(in out) :: r(ir) integer, intent(in) :: ir integer, intent(in) :: nvars double precision, intent(in out) :: x(nvars) double precision, intent(in) :: v integer, intent(out) :: ifault double precision, parameter :: zero=0.0d0 double precision, parameter :: eps0=0.0d0 double precision, parameter :: eps1=0.0d0 integer :: i, ii, ij, iplus, j double precision :: c, ctemp, rtemp, s, vlocal, vnew, xi, xi2 ifault = 0 irused = nvars*(nvars+1)/2 if (ir < irused) go to 1003 if (v < zero) go to 1002 vlocal = v ! ! for each row of upper triangular r ! ii = 0 do i = 1, nvars ii = ii + i xi = x(i) xi2 = xi*xi if (xi2 <= abs(vlocal)*eps0) cycle ctemp = r(ii) ij = ii iplus = i + 1 ! ! if zero weight on row of r, simple pivot ! if (ctemp >= zero) go to 20 r(ii) = vlocal/xi2 if (i == nvars) go to 70 do j = iplus, nvars ij = ij + j - 1 r(ij) = x(j)/xi end do return ! ! if infinite weight on row of r, simple pivot ! 20 if (ctemp > eps1) go to 40 do j = iplus, nvars ij = ij + j - 1 x(j) = x(j) - xi*r(ij) end do cycle ! ! otherwise ordinary givens rotation ! 40 vnew = vlocal + ctemp*xi2 c = vlocal/vnew s = ctemp*xi/vnew vlocal = vnew r(ii) = ctemp*c if (i == nvars) go to 70 do j = iplus, nvars ij = ij + j - 1 rtemp = c*r(ij) + s*x(j) x(j) = x(j) - xi*r(ij) r(ij) = rtemp end do end do ! ! check for inconsistent or duplicated constraints ! 70 if (abs(r(irused)) <= eps1) go to 1001 if (vlocal <= eps1) ifault = -1 return ! ! error flag set ! 1001 ifault = ifault + 1 1002 ifault = ifault + 1 1003 ifault = ifault + 1 return end subroutine givenc ! ! Algorithm AS 164.1 Appl. Statist. (1981) vol.30, no.2 ! Perform back substitution to get regression coefficient estimates ! subroutine bsub(r, ir, idep, coeff, ic, ifault) double precision, intent(in) :: r(ir) integer, intent(in) :: ir integer, intent(in) :: idep double precision, intent(in out) :: coeff(ic) integer, intent(in) :: ic integer, intent(out) :: ifault double precision, parameter :: zero=0.0d0 integer :: i,ii,ij,k,nx,nxvars double precision :: temp ifault = 0 ii = idep*(idep+1)/2 nxvars = idep - 1 if (ir < ii .or. ic < nxvars) goto 1001 if (nxvars < 1) return ! back substitution k = ii nx = idep do i = 1, nxvars ii = ii - nx k = k - 1 temp = r(k) if (r(ii) < zero) ifault = ifault - 1 if (i /= 1) then ij = ii do j = nx, nxvars ij = ij + j - 1 temp = temp - r(ij)*coeff(j) end do end if nx = nx - 1 coeff(nx) = temp end do return 1001 ifault = 1 return END SUBROUTINE bsub ! Algorithm AS 164.2 Appl. Statist. (1981) Vol.30, No.2 ! Finds (icomp)th component of total sum of sqrs ! Zero-th component is residual ssq subroutine sscomp(r, ir, idep, nobs, icomp, ssq, idf, ifault) double precision, intent(in) :: r(ir) integer, intent(in out) :: ir integer, intent(in) :: idep integer, intent(in) :: nobs integer, intent(in) :: icomp double precision, intent(out) :: ssq integer, intent(out) :: idf integer, intent(out) :: ifault ! local variables integer :: i, ii, ij, nxvars double precision :: one, zero data zero/0.0d0/, one/1.0d0/ ! Small constant that the user can modify data eps1 /0.0d0/ ! Check for valid parameters ifault = 0 irused = idep*(idep + 1)/2 if (ir < irused) ifault = ifault + 1 if (icomp < 0.or.icomp >= idep) ifault = ifault + 2 if (ifault > 0) return ! Test if residual ssq required if (icomp >= 1) go to 20 nxvars = idep - 1 idf = nobs - nxvars ii = 0 do i = 1, nxvars ii = ii + i if (r(ii) <= eps1) idf = idf + 1 end do ssq = zero if (r(irused) > eps1) ssq = one/r(irused) return ! Ordinary component 20 idf = 0 ssq = zero ii = icomp*(icomp+1)/2 if (r(ii) <= eps1) return idf = 1 ij = irused - idep + icomp ssq = r(ij)*r(ij)/r(ii) return end subroutine sscomp ! ! Algorithm AS164.3 Appl. Statist. (1981) vol.30, no.2 ! Estimates var/covar matrix of regression coefficients ! subroutine var(r, ir, s, is, idep, nobs, typ, ifault) double precision, intent(in) :: r(ir) integer, intent(in) :: ir double precision, intent(inout) :: s(is) integer, intent(in) :: is integer, intent(in) :: idep integer, intent(in) :: nobs integer, intent(in) :: typ integer, intent(out) :: ifault ! double precision, parameter :: zero=0.0D0 double precision, parameter :: one=1.0D0 double precision, parameter :: eps1=0.0D0 ! integer :: idf, ij, irused, j, jj, k, ki, kj, kk, kmax,kmin, nxvars double precision :: sigma, stemp ! ! check for valid parameters ifault = 0 irused = idep*(idep+1)/2 if (ir < irused .or. is < (irused-idep)) go to 1002 nxvars = idep - 1 ! invert unit upper triangular matrix ncons = 0 ij = 0 do i=1, nxvars jj = 0 j = 0 10 j = j + 1 ij = ij + 1 jj = jj + j if (j < i) go to 20 if (r(ij) <= eps1) ncons = ncons + 1 cycle 20 stemp = -r(ij) ik = ij kj = jj kmax = i - 1 kmin = j + 1 if (kmax < kmin) go to 40 do k=kmin, kmax ik = ik + 1 kj = kj + k - 1 stemp = stemp - r(ik)*s(kj) end do 40 s(ij) = stemp go to 10 end do ! ! estimate variance and apply identifiability constraints ! idf = nobs - nxvars + ncons if (idf <= 0) go to 1001 sigma = zero if (r(irused) > zero) then if (typ == 1) then sigma = one/(r(irused)*dble(idf)) else sigma = one end if end if ii = 0 do i=1, nxvars ii = ii + i s(ii) = sigma*r(ii) if (r(ii) < zero) s(ii) = zero end do ! ! multiply matrices together to form est of var ! ii = 0 ij = 0 do i=1, nxvars ii = ii + i do j=1, i kk = ii ij = ij + 1 ki = ij kj = ii stemp = s(kk) if (i /= j) stemp = stemp*s(ij) k = i do k = k + 1 if (k > nxvars) exit kk = kk + k ki = ki + k - 1 kj = kj + k - 1 stemp = stemp + s(ki)*s(kj)*s(kk) end do s(ij) = stemp end do end do return 1001 ifault = ifault + 1 1002 ifault = ifault + 1 return end subroutine var ! ! Algorithm AS164.4 Appl. Statist. (1981) vol.30, no.2 ! Assumes any diagonal elements of d less than eps are ! rounding errors and reduces them to zero ! subroutine alias(r, ir, nvars, eps, worksp, ifault) double precision, intent(in out) :: r(ir) integer, intent(in) :: ir integer, intent(in) :: nvars double precision, intent(in) :: eps double precision, intent(out) :: worksp(nvars) integer, intent(out) :: ifault double precision, parameter :: zero=0.0d0 double precision, parameter :: one=1.0d0 double precision, parameter :: oneneg=-1.0d0 ! local integer :: i,ii,ij,iplus,irused, nxvars double precision :: v ! check for valid parameters ifault = 0 irused = nvars*(nvars+1)/2 if (ir < irused) then ifault=1 return end if nxvars = nvars - 1 ! for each row of triangular r ii = 0 do i = 1, nxvars ii = ii + i worksp(i) = zero ! ! check for weight of row near zero ! if (abs(r(ii))*eps <= one) cycle ifault = ifault - 1 v = r(ii) r(ii) = oneneg ij = ii iplus = i + 1 ! ! rotate modified row with givens ! do j = iplus, nvars ij = ij + j - 1 worksp(j) = r(ij) r(ij) = zero end do call givenc(r, ir, nvars, worksp, v, ifail) end do end subroutine alias end module AS164 ! ! Work arrays for AS164 -- allow passing of results to other routines ! module AS164_class integer :: AS164_nterms = 0 double precision, dimension(:), allocatable :: b double precision, dimension(:), allocatable :: cov double precision, dimension(:), allocatable :: r contains subroutine clean_AS164() AS164_nterms = 0 if (allocated(b)) then deallocate(b) end if if (allocated(cov)) then deallocate(cov) end if if (allocated(r)) then deallocate(r) end if end subroutine clean_AS164 end module AS164_class ! ! MVN integration control variables ! mftalgo 1=Mendell-Elston 2=Genz ! mfteval maximum number of function values allowed. This ! parameter can be used to limit the time. A sensible ! strategy is to start with MAXPTS = 1000*N, and then ! increase MAXPTS if ERROR is too large. ! abseps absolute error tolerance. ! releps relative error tolerance. ! module mftcontrol integer :: mftalgo = 1 integer :: mfteval = 2000 double precision :: abseps=5.0d-5 double precision :: releps=0.0d0 end module mftcontrol ! ! Main multivariate normal integration routines (Alan Genz) ! module mftfuns public :: mvndst, mvndfn, mvnlms, covsrt, dkswap, rcswp, dkbvrc, & dksmrc, bvnmvn, mvnuni contains ! A subroutine for computing multivariate normal probabilities. ! This subroutine uses an algorithm given in the paper ! "Numerical Computation of Multivariate Normal Probabilities", in ! J. of Computational and Graphical Stat., 1(1992), pp. 141-149, by ! Alan Genz ! Department of Mathematics ! Washington State University ! Pullman, WA 99164-3113 ! Email : AlanGenz@wsu.edu ! Parameters ! N INTEGER, the number of variables. ! LOWER REAL, array of lower integration limits. ! UPPER REAL, array of upper integration limits. ! INFIN INTEGER, array of integration limits flags: ! if INFIN(I) < 0, Ith limits are (-infinity, infinity); ! if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)]; ! if INFIN(I) = 1, Ith limits are [LOWER(I), infinity); ! if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)]. ! CORREL REAL, array of correlation coefficients; the correlation ! coefficient in row I column J of the correlation matrix ! should be stored in CORREL( J + ((I-2)*(I-1))/2 ), for J < I. ! The correlation matrix must be positive semidefinite. ! MAXPTS INTEGER, maximum number of function values allowed. This ! parameter can be used to limit the time. A sensible ! strategy is to start with MAXPTS = 1000*N, and then ! increase MAXPTS if ERROR is too large. ! ABSEPS REAL absolute error tolerance. ! RELEPS REAL relative error tolerance. ! ERROR REAL estimated absolute error, with 99% confidence level. ! VALUE REAL estimated value for the integral ! INFORM INTEGER, termination status parameter: ! if INFORM = 0, normal completion with ERROR < EPS; ! if INFORM = 1, completion with ERROR > EPS and MAXPTS ! function values used; increase MAXPTS to ! decrease ERROR; ! if INFORM = 2, N > 500 or N < 1. subroutine mvndst(n, lower, upper, infin, correl, maxpts, & abseps, releps, error, value, inform) integer, intent(in) :: n double precision, intent(in) :: lower(*) double precision, intent(in) :: upper(*) integer, intent(in) :: infin(*) double precision, intent(in) :: correl(*) integer, intent(in) :: maxpts double precision, intent(in) :: abseps double precision, intent(in) :: releps double precision, intent(out) :: error double precision, intent(out) :: value integer, intent(out) :: inform ! external :: mvndfn integer :: infis, ivls double precision :: e, d COMMON /dkblck/ivls if ( n > 500 .OR. n < 1 ) then inform = 2 value = 0 error = 1 else inform = mvndnt(n, correl, lower, upper, infin, infis, d, e) if ( n-infis == 0 ) then value = 1 error = 0 else if ( n-infis == 1 ) then value = e - d error = 2D-16 else ! Call the lattice rule integration subroutine ivls = 0 call dkbvrc( n-infis-1, ivls, maxpts, mvndfn, & abseps, releps, error, value, inform ) end if end if end subroutine mvndst ! ! Integrand subroutine ! function mvndfn( n, w ) use statfuns double precision :: mvndfn integer, intent(in) :: n double precision, intent(in) :: w(*) integer :: infin(*), infis double precision :: lower(*), upper(*), correl(*), d, e integer, parameter :: nl = 500 double precision :: cov(nl*(nl+1)/2), a(nl), b(nl), y(nl) integer :: infi(nl), i, j, ij, ik, infa, infb double precision :: sum, ai, bi, di, ei save a, b, infi, cov mvndfn = 1 infa = 0 infb = 0 ik = 1 ij = 0 do i = 1, n+1 sum = 0 do j = 1, i-1 ij = ij + 1 if ( j < ik ) sum = sum + cov(ij)*y(j) end do if ( infi(i) /= 0 ) then if ( infa == 1 ) then ai = MAX( ai, a(i) - sum ) else ai = a(i) - sum infa = 1 end if end if if ( infi(i) /= 1 ) then if ( infb == 1 ) then bi = MIN( bi, b(i) - sum ) else bi = b(i) - sum infb = 1 end if end if ij = ij + 1 if ( i == n+1 .OR. cov(ij+ik+1) > 0 ) then call mvnlms( ai, bi, 2*infa+infb-1, di, ei ) if ( di >= ei ) then mvndfn = 0 RETURN else mvndfn = mvndfn*( ei - di ) if ( i <= n ) y(ik) = ppnd( di + w(ik)*( ei - di ) ) ik = ik + 1 infa = 0 infb = 0 end if end if end do return ! ! Entry point for intialization. ! ENTRY mvndnt( n, correl, lower, upper, infin, infis, d, e ) mvndnt = 0 ! Initialization and computation of covariance Cholesky factor. call covsrt( n, lower,upper,correl,infin,y, infis,a,b,cov,infi ) if ( n - infis == 1 ) then call mvnlms( a(1), b(1), infi(1), d, e ) else if ( n - infis == 2 ) then if ( ABS( cov(3) ) > 0 ) then d = SQRT( 1 + cov(2)**2 ) if ( infi(2) /= 0 ) a(2) = a(2)/d if ( infi(2) /= 1 ) b(2) = b(2)/d e = bvnmvn( a, b, infi, cov(2)/d ) d = 0 else if ( infi(1) /= 0 ) then if ( infi(2) /= 0 ) a(1) = MAX( a(1), a(2) ) else if ( infi(2) /= 0 ) a(1) = a(2) end if if ( infi(1) /= 1 ) then if ( infi(2) /= 1 ) b(1) = MIN( b(1), b(2) ) else if ( infi(2) /= 1 ) b(1) = b(2) end if if ( infi(1) /= infi(2) ) infi(1) = 2 call mvnlms( a(1), b(1), infi(1), d, e ) end if infis = infis + 1 end if end function mvndfn ! subroutine mvnlms( a, b, infin, lower, upper ) use statfuns double precision, intent(in out) :: a double precision, intent(in out) :: b integer, intent(in) :: infin double precision, intent(out) :: lower double precision, intent(out) :: upper ! functions lower = 0 upper = 1 if ( infin >= 0 ) then if ( infin /= 0 ) lower = zp(-a) if ( infin /= 1 ) upper = zp(-b) end if upper = MAX( upper, lower ) end subroutine mvnlms ! ! Subroutine to sort integration limits and determine Cholesky factor. ! subroutine covsrt(n, lower, upper, correl, infin, y, & infis, a, b, cov, infi) integer, intent(in) :: n double precision, intent(in) :: lower(*) double precision, intent(in) :: upper(*) double precision, intent(in) :: correl(*) integer, intent(in) :: infin(*) double precision, intent(in out) :: y(*) integer, intent(out) :: infis double precision, intent(out) :: a(*) double precision, intent(out) :: b(*) double precision, intent(out) :: cov(*) integer, intent(out) :: infi(*) integer :: i, j, k, l, m, ii, ij, il, jmin double precision :: sumsq, aj, bj, sum, d, e double precision :: cvdiag, amin, bmin, dmin, emin, yl, yu double precision, parameter :: sqtwpi = 2.506628274631001D0 double precision, parameter :: eps = 1D-10 ij = 0 ii = 0 infis = 0 do i = 1, n a(i) = 0 b(i) = 0 infi(i) = infin(i) if ( infi(i) < 0 ) then infis = infis + 1 else if ( infi(i) /= 0 ) a(i) = lower(i) if ( infi(i) /= 1 ) b(i) = upper(i) end if do j = 1, i-1 ij = ij + 1 ii = ii + 1 cov(ij) = correl(ii) end do ij = ij + 1 cov(ij) = 1 end do ! ! First move any doubly infinite limits to innermost positions. ! if ( infis < n ) then outer: do i = n, n-infis+1, -1 if ( infi(i) >= 0 ) then do j = 1,i-1 if ( infi(j) < 0 ) then call rcswp( j, i, a, b, infi, n, cov ) cycle outer end if end do end if end do outer ! ! Sort remaining limits and determine Cholesky factor. ! ii = 0 do i = 1, n-infis ! ! Determine the integration limits for variable with minimum ! expected probability and interchange that variable with Ith. dmin = 0 emin = 1 jmin = i cvdiag = 0 ij = ii do j = i, n-infis if ( cov(ij+j) > eps ) then sumsq = SQRT( cov(ij+j) ) sum = 0 do k = 1, i-1 sum = sum + cov(ij+k)*y(k) end do aj = ( a(j) - sum )/sumsq bj = ( b(j) - sum )/sumsq call mvnlms( aj, bj, infi(j), d, e ) if ( emin + d >= e + dmin ) then jmin = j amin = aj bmin = bj dmin = d emin = e cvdiag = sumsq end if end if ij = ij + j end do if ( jmin > i ) call rcswp( i, jmin, a,b, infi, n, cov ) cov(ii+i) = cvdiag ! Compute Ith column of Cholesky factor. ! Compute expected value for Ith integration variable and ! scale Ith covariance matrix row and limits. if ( cvdiag > 0 ) then il = ii + i do l = i+1, n-infis cov(il+i) = cov(il+i)/cvdiag ij = ii + i do j = i+1, l cov(il+j) = cov(il+j) - cov(il+i)*cov(ij+i) ij = ij + j end do il = il + l end do if ( emin > dmin + eps ) then yl = 0 yu = 0 if ( infi(i) /= 0 ) yl = -EXP( -amin**2/2 )/sqtwpi if ( infi(i) /= 1 ) yu = -EXP( -bmin**2/2 )/sqtwpi y(i) = ( yu - yl )/( emin - dmin ) else if ( infi(i) == 0 ) y(i) = bmin if ( infi(i) == 1 ) y(i) = amin if ( infi(i) == 2 ) y(i) = ( amin + bmin )/2 end if do j = 1, i ii = ii + 1 cov(ii) = cov(ii)/cvdiag end do a(i) = a(i)/cvdiag b(i) = b(i)/cvdiag else il = ii + i do l = i+1, n-infis cov(il+i) = 0 il = il + l end do ! If the covariance matrix diagonal entry is zero, ! permute limits and/or rows, if necessary. do j = i-1, 1, -1 if ( ABS( cov(ii+j) ) > eps ) then a(i) = a(i)/cov(ii+j) b(i) = b(i)/cov(ii+j) if ( cov(ii+j) < 0 ) then call dkswap( a(i), b(i) ) if ( infi(i) /= 2 ) infi(i) = 1 - infi(i) end if do l = 1, j cov(ii+l) = cov(ii+l)/cov(ii+j) end do do l = j+1, i-1 if( cov((l-1)*l/2+j+1) > 0 ) then ij = ii do k = i-1, l, -1 do m = 1, k call dkswap( cov(ij-k+m), cov(ij+m) ) end do call dkswap( a(k), a(k+1) ) call dkswap( b(k), b(k+1) ) m = infi(k) infi(k) = infi(k+1) infi(k+1) = m ij = ij - k end do GO TO 20 end if end do GO TO 20 end if cov(ii+j) = 0 end do 20 ii = ii + i y(i) = 0 end if end do end if end subroutine covsrt ! Swap elements subroutine dkswap( x, y ) double precision, intent(in out) :: x double precision, intent(in out) :: y double precision :: t t = x x = y y = t end subroutine dkswap ! ! Swaps rows and columns P and Q in situ, with P <= Q. ! subroutine rcswp( p, q, a, b, infin, n, c ) integer, intent(in) :: p integer, intent(in) :: q double precision, intent(in out) :: a(*) double precision, intent(in out) :: b(*) integer, intent(in out) :: infin(*) integer, intent(in) :: n double precision, intent(in out) :: c(*) integer :: i, j, ii, jj call dkswap( a(p), a(q) ) call dkswap( b(p), b(q) ) j = infin(p) infin(p) = infin(q) infin(q) = j jj = ( p*( p - 1 ) )/2 ii = ( q*( q - 1 ) )/2 call dkswap( c(jj+p), c(ii+q) ) do j = 1, p-1 call dkswap( c(jj+j), c(ii+j) ) end do jj = jj + p do i = p+1, q-1 call dkswap( c(jj+p), c(ii+i) ) jj = jj + i end do ii = ii + q do i = q+1, n call dkswap( c(ii+p), c(ii+q) ) ii = ii + i end do end subroutine rcswp ! ! Automatic Multidimensional Integration Subroutine ! AUTHOR: Alan Genz ! Department of Mathematics ! Washington State University ! Pulman, WA 99164-3113 ! Email: AlanGenz@wsu.edu ! Last Change: 7/3/7 ! DKBVRC computes an approximation to the integral ! 1 1 1 ! I I ... I F(X) dx(NDIM)...dx(2)dx(1) ! 0 0 0 ! DKBVRC uses randomized Korobov rules for the first 100 variables. ! The primary references are ! "Randomization of Number Theoretic Methods for Multiple Integration" ! R. Cranley and T.N.L. Patterson, SIAM J Numer Anal, 13, pp. 904-14, ! and ! "Optimal Parameters for Multidimensional Integration", ! P. Keast, SIAM J Numer Anal, 10, pp.831-838. ! If there are more than 100 variables, the remaining variables are ! integrated using the rules described in the reference ! "On a Number-Theoretical Integration Method" ! H. Niederreiter, Aequationes Mathematicae, 8(1972), pp. 304-11. !************** Parameters ******************************************** !***** Input parameters ! NDIM Number of variables, must exceed 1, but not exceed 40 ! MINVLS Integer minimum number of function evaluations allowed. ! MINVLS must not exceed MAXVLS. If MINVLS < 0 then the ! routine assumes a previous call has been made with ! the same integrand and continues that calculation. ! MAXVLS Integer maximum number of function evaluations allowed. ! FUNCTN EXTERNALly declared user defined function to be integrated. ! It must have parameters (NDIM,Z), where Z is a real array ! of dimension NDIM. ! ABSEPS Required absolute accuracy. ! RELEPS Required relative accuracy. !***** Output parameters ! MINVLS Actual number of function evaluations used. ! ABSERR Estimated absolute accuracy of FINEST. ! FINEST Estimated value of integral. ! INFORM INFORM = 0 for normal exit, when ! ABSERR <= MAX(ABSEPS, RELEPS*ABS(FINEST)) ! and ! INTVLS <= MAXCLS. ! INFORM = 1 If MAXVLS was too small to obtain the required ! accuracy. In this case a value FINEST is returned with ! estimated absolute accuracy ABSERR. ! subroutine dkbvrc(ndim, minvls, maxvls, functn, abseps, releps, & abserr, finest, inform ) integer, intent(in) :: ndim integer, intent(in out) :: minvls integer, intent(in) :: maxvls double precision :: functn double precision, intent(in) :: abseps double precision, intent(in) :: releps double precision, intent(out) :: abserr double precision, intent(out) :: finest integer, intent(out) :: inform external functn integer :: np, klimi, sampls, i, k, intvls integer, parameter :: plim = 28 integer, parameter :: nlim = 1000 integer, parameter :: klim = 100 integer, parameter :: minsmp = 8 integer :: p(plim), c(plim,klim-1) double precision :: difint, finval, varsqr, varest, varprd, value double precision :: x(2*nlim), vk(nlim) double precision, parameter :: one = 1 save p, c, sampls, np, varest inform = 1 intvls = 0 klimi = klim if ( minvls >= 0 ) then finest = 0 varest = 0 sampls = minsmp do i = MIN( ndim, 10 ), plim np = i if ( minvls < 2*sampls*p(i) ) GO TO 10 end do sampls = MAX( minsmp, minvls/( 2*p(np) ) ) end if 10 vk(1) = one/p(np) k = 1 do i = 2, ndim if ( i <= klim ) then k = MOD( c(np, MIN(ndim-1,klim-1))*DBLE(k), DBLE(p(np)) ) vk(i) = k*vk(1) else vk(i) = INT( p(np)*2**( DBLE(i-klim)/(ndim-klim+1) ) ) vk(i) = MOD( vk(i)/p(np), one ) end if end do finval = 0 varsqr = 0 do i = 1, sampls call dksmrc( ndim, klimi, value, p(np), vk, functn, x ) difint = ( value - finval )/i finval = finval + difint varsqr = ( i - 2 )*varsqr/i + difint**2 end do intvls = intvls + 2*sampls*p(np) varprd = varest*varsqr finest = finest + ( finval - finest )/( 1 + varprd ) if ( varsqr > 0 ) varest = ( 1 + varprd )/varsqr abserr = 7*SQRT( varsqr/( 1 + varprd ) )/2 if ( abserr > MAX( abseps, ABS(finest)*releps ) ) then if ( np < plim ) then np = np + 1 else sampls = MIN( 3*sampls/2, ( maxvls - intvls )/( 2*p(np) ) ) sampls = MAX( minsmp, sampls ) end if if ( intvls + 2*sampls*p(np) <= maxvls ) GO TO 10 else inform = 0 end if minvls = intvls ! ! Optimal Parameters for Lattice Rules ! data p( 1),(c( 1,i),i = 1,99)/ 31, 12, 2*9, 13, 8*12, 3*3, 12, & 2*7, 9*12, 3*3, 12, 2*7, 9*12, 3*3, 12, 2*7, 9*12, 3*3, 12, 2*7, & 8*12, 7, 3*3, 3*7, 21*3/ data p( 2),(c( 2,i),i = 1,99)/ 47, 13, 11, 17, 10, 6*15, & 22, 2*15, 3*6, 2*15, 9, 13, 3*2, 13, 2*11, 10, 9*15, 3*6, 2*15, & 9, 13, 3*2, 13, 2*11, 10, 9*15, 3*6, 2*15, 9, 13, 3*2, 13, 2*11, & 2*10, 8*15, 6, 2, 3, 2, 3, 12*2/ data p( 3),(c( 3,i),i = 1,99)/ 73, 27, 28, 10, 2*11, 20, & 2*11, 28, 2*13, 28, 3*13, 16*14, 2*31, 3*5, 31, 13, 6*11, 7*13, & 16*14, 2*31, 3*5, 11, 13, 7*11, 2*13, 11, 13, 4*5, 14, 13, 8*5/ data p( 4),(c( 4,i),i = 1,99)/ 113, 35, 2*27, 36, 22, 2*29, & 20, 45, 3*5, 16*21, 29, 10*17, 12*23, 21, 27, 3*3, 24, 2*27, & 17, 3*29, 17, 4*5, 16*21, 3*17, 6, 2*17, 6, 3, 2*6, 5*3/ data p( 5),(c( 5,i),i = 1,99)/ 173, 64, 66, 2*28, 2*44, 55, & 67, 6*10, 2*38, 5*10, 12*49, 2*38, 31, 2*4, 31, 64, 3*4, 64, & 6*45, 19*66, 11, 9*66, 45, 11, 7, 3, 3*2, 27, 5, 2*3, 2*5, 7*2/ data p( 6),(c( 6,i),i = 1,99)/ 263, 111, 42, 54, 118, 20, & 2*31, 72, 17, 94, 2*14, 11, 3*14, 94, 4*10, 7*14, 3*11, 7*8, & 5*18, 113, 2*62, 2*45, 17*113, 2*63, 53, 63, 15*67, 5*51, 12, & 51, 12, 51, 5, 2*3, 2*2, 5/ data p( 7),(c( 7,i),i = 1,99)/ 397, 163, 154, 83, 43, 82, & 92, 150, 59, 2*76, 47, 2*11, 100, 131, 6*116, 9*138, 21*101, & 6*116, 5*100, 5*138, 19*101, 8*38, 5*3/ data p( 8),(c( 8,i),i = 1,99)/ 593, 246, 189, 242, 102, & 2*250, 102, 250, 280, 118, 196, 118, 191, 215, 2*121, & 12*49, 34*171, 8*161, 17*14, 6*10, 103, 4*10, 5/ data p( 9),(c( 9,i),i = 1,99)/ 907, 347, 402, 322, 418, & 215, 220, 3*339, 337, 218, 4*315, 4*167, 361, 201, 11*124, & 2*231, 14*90, 4*48, 23*90, 10*243, 9*283, 16, 283, 16, 2*283/ data p(10),(c(10,i),i = 1,99)/ 1361, 505, 220, 601, 644, & 612, 160, 3*206, 422, 134, 518, 2*134, 518, 652, 382, & 206, 158, 441, 179, 441, 56, 2*559, 14*56, 2*101, 56, & 8*101, 7*193, 21*101, 17*122, 4*101/ data p(11),(c(11,i),i = 1,99)/ 2053, 794, 325, 960, 528, & 2*247, 338, 366, 847, 2*753, 236, 2*334, 461, 711, 652, & 3*381, 652, 7*381, 226, 7*326, 126, 10*326, 2*195, 19*55, & 7*195, 11*132, 13*387/ data p(12),(c(12,i),i = 1,99)/ 3079, 1189, 888, 259, 1082, 725, & 811, 636, 965, 2*497, 2*1490, 392, 1291, 2*508, 2*1291, 508, & 1291, 2*508, 4*867, 934, 7*867, 9*1284, 4*563, 3*1010, 208, & 838, 3*563, 2*759, 564, 2*759, 4*801, 5*759, 8*563, 22*226/ data p(13),(c(13,i),i = 1,99)/ 4621, 1763, 1018, 1500, 432, & 1332, 2203, 126, 2240, 1719, 1284, 878, 1983, 4*266, & 2*747, 2*127, 2074, 127, 2074, 1400, 10*1383, 1400, 7*1383, & 507, 4*1073, 5*1990, 9*507, 17*1073, 6*22, 1073, 6*452, 318, 4*301, 2*86, 15/ data p(14),(c(14,i),i = 1,99)/ 6947, 2872, 3233, 1534, 2941, & 2910, 393, 1796, 919, 446, 2*919, 1117, 7*103, 2311, 3117, 1101, & 2*3117, 5*1101, 8*2503, 7*429, 3*1702, 5*184, 34*105, 13*784/ data p(15),(c(15,i),i = 1,99)/ 10427, 4309, 3758, 4034, 1963, & 730, 642, 1502, 2246, 3834, 1511, 2*1102, 2*1522, 2*3427, & 3928, 2*915, 4*3818, 3*4782, 3818, 4782, 2*3818, 7*1327, 9*1387, & 13*2339, 18*3148, 3*1776, 3*3354, 925, 2*3354, 5*925, 8*2133/ data p(16),(c(16,i),i = 1,99)/ 15641, 6610, 6977, 1686, 3819, & 2314, 5647, 3953, 3614, 5115, 2*423, 5408, 7426, 2*423, & 487, 6227, 2660, 6227, 1221, 3811, 197, 4367, 351, & 1281, 1221, 3*351, 7245, 1984, 6*2999, 3995, 4*2063, 1644, & 2063, 2077, 3*2512, 4*2077, 19*754, 2*1097, 4*754, 248, 754, & 4*1097, 4*222, 754,11*1982/ data p(17),(c(17,i),i = 1,99)/ 23473, 9861, 3647, 4073, 2535, & 3430, 9865, 2830, 9328, 4320, 5913, 10365, 8272, 3706, 6186, & 3*7806, 8610, 2563, 2*11558, 9421, 1181, 9421, 3*1181, 9421, & 2*1181, 2*10574, 5*3534, 3*2898, 3450, 7*2141, 15*7055, 2831, & 24*8204, 3*4688, 8*2831/ data p(18),(c(18,i),i = 1,99)/ 35221, 10327, 7582, 7124, 8214, & 9600, 10271, 10193, 10800, 9086, 2365, 4409, 13812, & 5661, 2*9344, 10362, 2*9344, 8585, 11114, 3*13080, 6949, & 3*3436, 13213, 2*6130, 2*8159, 11595, 8159, 3436, 18*7096, & 4377, 7096, 5*4377, 2*5410, 32*4377, 2*440, 3*1199/ data p(19),(c(19,i),i = 1,99)/ 52837, 19540, 19926, 11582, & 11113, 24585, 8726, 17218, 419, 3*4918, 15701, 17710, & 2*4037, 15808, 11401, 19398, 2*25950, 4454, 24987, 11719, & 8697, 5*1452, 2*8697, 6436, 21475, 6436, 22913, 6434, 18497, & 4*11089, 2*3036, 4*14208, 8*12906, 4*7614, 6*5021, 24*10145, 6*4544, 4*8394/ data p(20),(c(20,i),i = 1,99)/ 79259, 34566, 9579, 12654, & 26856, 37873, 38806, 29501, 17271, 3663, 10763, 18955, & 1298, 26560, 2*17132, 2*4753, 8713, 18624, 13082, 6791, & 1122, 19363, 34695, 4*18770, 15628, 4*18770, 33766, 6*20837, & 5*6545, 14*12138, 5*30483, 19*12138, 9305, 13*11107, 2*9305/ data p(21),(c(21,i),i = 1,99)/118891, 31929, 49367, 10982, 3527, & 27066, 13226, 56010, 18911, 40574, 2*20767, 9686, 2*47603, & 2*11736, 41601, 12888, 32948, 30801, 44243, 2*53351, 16016, & 2*35086, 32581, 2*2464, 49554, 2*2464, 2*49554, 2464, 81, 27260, & 10681, 7*2185, 5*18086, 2*17631, 3*18086, 37335, 3*37774, & 13*26401, 12982, 6*40398, 3*3518, 9*37799, 4*4721, 4*7067/ data p(22),(c(22,i),i = 1,99)/178349, 40701, 69087, 77576, 64590, & 39397, 33179, 10858, 38935, 43129, 2*35468, 5279, 2*61518, 27945, & 2*70975, 2*86478, 2*20514, 2*73178, 2*43098, 4701, & 2*59979, 58556, 69916, 2*15170, 2*4832, 43064, 71685, 4832, & 3*15170, 3*27679, 2*60826, 2*6187, 5*4264, 45567, 4*32269, & 9*62060, 13*1803, 12*51108, 2*55315, 5*54140, 13134/ data p(23),(c(23,i),i = 1,99)/267523, 103650, 125480, 59978, & 46875, 77172, 83021, 126904, 14541, 56299, 43636, 11655, & 52680, 88549, 29804, 101894, 113675, 48040, 113675, & 34987, 48308, 97926, 5475, 49449, 6850, 2*62545, 9440, & 33242, 9440, 33242, 9440, 33242, 9440, 62850, 3*9440, & 3*90308, 9*47904, 7*41143, 5*36114, 24997, 14*65162, 7*47650, & 7*40586, 4*38725, 5*88329/ data p(24),(c(24,i),i = 1,99)/401287, 165843, 90647, 59925, & 189541, 67647, 74795, 68365, 167485, 143918, 74912, & 167289, 75517, 8148, 172106, 126159,3*35867, 121694, & 52171, 95354, 2*113969, 76304, 2*123709, 144615, 123709, & 2*64958, 32377, 2*193002, 25023, 40017, 141605, 2*189165, & 141605, 2*189165, 3*141605, 189165, 20*127047, 10*127785, & 6*80822, 16*131661, 7114, 131661/ data p(25),(c(25,i),i = 1,99)/601943, 130365, 236711, 110235, & 125699, 56483, 93735, 234469, 60549, 1291, 93937, & 245291, 196061, 258647, 162489, 176631, 204895, 73353, & 172319, 28881, 136787,2*122081, 275993, 64673, 3*211587, & 2*282859, 211587, 242821, 3*256865, 122203, 291915, 122203, & 2*291915, 122203, 2*25639, 291803, 245397, 284047, & 7*245397, 94241, 2*66575, 19*217673, 10*210249, 15*94453/ data p(26),(c(26,i),i = 1,99)/902933, 333459, 375354, 102417, & 383544, 292630, 41147, 374614, 48032, 435453, 281493, 358168, & 114121, 346892, 238990, 317313, 164158, 35497, 2*70530, 434839, & 3*24754, 393656, 2*118711, 148227, 271087, 355831, 91034, & 2*417029, 2*91034, 417029, 91034, 2*299843, 2*413548, 308300, & 3*413548, 3*308300, 413548, 5*308300, 4*15311, 2*176255, 6*23613, & 172210, 4* 204328, 5*121626, 5*200187, 2*121551, 12*248492, 5*13942/ data p(27), (c(27,i), i = 1,99)/ 1354471, 500884, 566009, 399251, & 652979, 355008, 430235, 328722, 670680, 2*405585, 424646, & 2*670180, 641587, 215580, 59048, 633320, 81010, 20789, 2*389250, & 2*638764, 2*389250, 398094, 80846, 2*147776, 296177, 2*398094, & 2*147776, 396313, 3*578233, 19482, 620706, 187095, 620706, & 187095, 126467, 12*241663, 321632, 2*23210, 3*394484, 3*78101, & 19*542095, 3*277743, 12*457259/ data p(28), (c(28,i), i = 1, 99)/ 2031713, 858339, 918142, 501970, & 234813, 460565, 31996, 753018, 256150, 199809, 993599, 245149, & 794183, 121349, 150619, 376952, 2*809123, 804319, 67352, 969594, & 434796, 969594, 804319, 391368, 761041, 754049, 466264, 2*754049, & 466264, 2*754049, 282852, 429907, 390017, 276645, 994856, 250142, & 144595, 907454, 689648, 4*687580, 978368, 687580, 552742, 105195, & 942843, 768249, 4*307142, 7*880619, 11*117185, 11*60731, & 4*178309, 8*74373, 3*214965/ end subroutine dkbvrc ! subroutine dksmrc( ndim, klim, sumkro, prime, vk, functn, x ) integer, intent(in) :: ndim integer, intent(in) :: klim double precision, intent(out) :: sumkro integer, intent(in) :: prime double precision, intent(in out) :: vk(*) double precision :: functn double precision, intent(out) :: x(*) external functn integer :: nk, k, j, jp double precision :: xt double precision, parameter :: one = 1 sumkro = 0 nk = MIN( ndim, klim ) do j = 1, nk - 1 jp = j + mvnuni()*( nk + 1 - j ) xt = vk(j) vk(j) = vk(jp) vk(jp) = xt end do do j = 1, ndim x(ndim+j) = mvnuni() end do do k = 1, prime do j = 1, ndim x(j) = ABS( 2*MOD( k*vk(j) + x(ndim+j), one ) - 1 ) end do sumkro = sumkro + ( functn(ndim,x) - sumkro )/( 2*k - 1 ) do j = 1, ndim x(j) = 1 - x(j) end do sumkro = sumkro + ( functn(ndim,x) - sumkro )/( 2*k ) end do end subroutine dksmrc ! ! A function for computing bivariate normal probabilities. ! Parameters ! LOWER REAL, array of lower integration limits. ! UPPER REAL, array of upper integration limits. ! INFIN INTEGER, array of integration limits flags: ! if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)]; ! if INFIN(I) = 1, Ith limits are [LOWER(I), infinity); ! if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)]. ! CORREL REAL, correlation coefficient. double precision function bvnmvn( lower, upper, infin, correl ) use statfuns double precision, intent(in) :: lower(*) double precision, intent(in) :: upper(*) integer, intent(in) :: infin(*) double precision, intent(in) :: correl if ( infin(1) == 2 .AND. infin(2) == 2 ) then bvnmvn = mvbvu( lower(1), lower(2), correl ) & - mvbvu( upper(1), lower(2), correl ) & - mvbvu( lower(1), upper(2), correl ) & + mvbvu( upper(1), upper(2), correl ) else if ( infin(1) == 2 .AND. infin(2) == 1 ) then bvnmvn = mvbvu( lower(1), lower(2), correl ) & - mvbvu( upper(1), lower(2), correl ) else if ( infin(1) == 1 .AND. infin(2) == 2 ) then bvnmvn = mvbvu( lower(1), lower(2), correl ) & - mvbvu( lower(1), upper(2), correl ) else if ( infin(1) == 2 .AND. infin(2) == 0 ) then bvnmvn = mvbvu( -upper(1), -upper(2), correl ) & - mvbvu( -lower(1), -upper(2), correl ) else if ( infin(1) == 0 .AND. infin(2) == 2 ) then bvnmvn = mvbvu( -upper(1), -upper(2), correl ) & - mvbvu( -upper(1), -lower(2), correl ) else if ( infin(1) == 1 .AND. infin(2) == 0 ) then bvnmvn = mvbvu( lower(1), -upper(2), -correl ) else if ( infin(1) == 0 .AND. infin(2) == 1 ) then bvnmvn = mvbvu( -upper(1), lower(2), -correl ) else if ( infin(1) == 1 .AND. infin(2) == 1 ) then bvnmvn = mvbvu( lower(1), lower(2), correl ) else if ( infin(1) == 0 .AND. infin(2) == 0 ) then bvnmvn = mvbvu( -upper(1), -upper(2), correl ) end if end function bvnmvn ! ! Uniform (0,1) random number generator ! Reference: ! L'Ecuyer, Pierre (1996), ! "Combined Multiple Recursive Random Number Generators" ! Operations Research 44, pp. 816-822. ! double precision function mvnuni() integer :: a12, a13, a21, a23, p12, p13, p21, p23 integer :: q12, q13, q21, q23, r12, r13, r21, r23 integer :: x10, x11, x12, x20, x21, x22, z, m1, m2, h double precision :: invmp1 parameter ( m1 = 2147483647, m2 = 2145483479 ) parameter ( a12 = 63308, q12 = 33921, r12 = 12979 ) parameter ( a13 = -183326, q13 = 11714, r13 = 2883 ) parameter ( a21 = 86098, q21 = 24919, r21 = 7417 ) parameter ( a23 = -539608, q23 = 3976, r23 = 2071 ) parameter ( invmp1 = 4.656612873077392578125D-10 ) ! INVMP1 = 1/(M1+1) save x10, x11, x12, x20, x21, x22 data x10, x11, x12, x20, x21, x22 & / 15485857, 17329489, 36312197, 55911127, 75906931, 96210113 / ! Component 1 h = x10/q13 p13 = -a13*( x10 - h*q13 ) - h*r13 h = x11/q12 p12 = a12*( x11 - h*q12 ) - h*r12 if ( p13 < 0 ) p13 = p13 + m1 if ( p12 < 0 ) p12 = p12 + m1 x10 = x11 x11 = x12 x12 = p12 - p13 if ( x12 < 0 ) x12 = x12 + m1 ! Component 2 h = x20/q23 p23 = -a23*( x20 - h*q23 ) - h*r23 h = x22/q21 p21 = a21*( x22 - h*q21 ) - h*r21 if ( p23 < 0 ) p23 = p23 + m2 if ( p21 < 0 ) p21 = p21 + m2 x20 = x21 x21 = x22 x22 = p21 - p23 if ( x22 < 0 ) x22 = x22 + m2 ! Combination z = x12 - x22 if ( z <= 0 ) z = z + m1 mvnuni = z*invmp1 end function mvnuni end module mftfuns ! ! Selected BLAS routines ! module BLAS contains ! ! BLAS: Construct a plane Givens rotation. ! SUBROUTINE drotg (da, db, dc, ds) DOUBLE PRECISION, INTENT(IN OUT) :: da DOUBLE PRECISION, INTENT(IN OUT) :: db DOUBLE PRECISION, INTENT(OUT) :: dc DOUBLE PRECISION, INTENT(OUT) :: ds DOUBLE PRECISION :: u, v, r IF (ABS(da) <= ABS(db)) GO TO 10 ! *** HERE ABS(DA) .GT. ABS(DB) *** u = da + da v = db / u ! NOTE THAT U AND R HAVE THE SIGN OF DA r = SQRT(0.25D0 + v**2) * u ! NOTE THAT DC IS POSITIVE dc = da / r ds = v * (dc + dc) db = ds da = r RETURN ! *** HERE ABS(DA) .LE. ABS(DB) *** 10 IF (db == 0.0D0) GO TO 20 u = db + db v = da / u ! NOTE THAT U AND R HAVE THE SIGN OF DB ! (R IS IMMEDIATELY STORED IN DA) da = SQRT(0.25D0 + v**2) * u ! NOTE THAT DS IS POSITIVE ds = db / da dc = v * (ds + ds) IF (dc == 0.0D0) GO TO 15 db = 1.0D0 / dc RETURN 15 db = 1.0D0 RETURN ! *** HERE DA = DB = 0.0 *** 20 dc = 1.0D0 ds = 0.0D0 RETURN END SUBROUTINE drotg DOUBLE PRECISION FUNCTION ddot (n, dx, incx, dy, incy) INTEGER, INTENT(IN) :: n DOUBLE PRECISION, INTENT(IN) :: dx(*) INTEGER, INTENT(IN) :: incx DOUBLE PRECISION, INTENT(IN) :: dy(*) INTEGER, INTENT(IN) :: incy ddot = 0.0D0 IF (n <= 0) RETURN IF (incx == incy) THEN IF (incx == 0) then goto 5 ELSE IF (incx == 1) then goto 20 ELSE goto 60 END IF END IF ! Code for unequal or nonpositive increments. 5 ix = 1 iy = 1 IF (incx < 0) ix = (-n+1)*incx + 1 IF (incy < 0) iy = (-n+1)*incy + 1 DO i = 1,n ddot = ddot + dx(ix)*dy(iy) ix = ix + incx iy = iy + incy END DO RETURN ! Code for both increments equal to 1. ! Clean-up loop so remaining vector length is a multiple of 5. 20 m = MOD(n,5) IF (m == 0) GO TO 40 DO i = 1,m ddot = ddot + dx(i)*dy(i) END DO IF (n < 5) RETURN 40 mp1 = m + 1 DO i = mp1,n,5 ddot = ddot + dx(i)*dy(i) + dx(i+1)*dy(i+1) + dx(i+2)*dy(i+2) + & dx(i+3)*dy(i+3) + dx(i+4)*dy(i+4) END DO RETURN ! Code for equal, positive, non-unit increments. 60 ns = n*incx DO i = 1,ns,incx ddot = ddot + dx(i)*dy(i) END DO RETURN END FUNCTION ddot ! ! BLAS: Apply a plane Givens rotation. ! SUBROUTINE drot (n, dx, incx, dy, incy, dc, ds) INTEGER, INTENT(IN) :: n DOUBLE PRECISION, INTENT(IN OUT) :: dx(*) INTEGER, INTENT(IN) :: incx DOUBLE PRECISION, INTENT(IN OUT) :: dy(*) INTEGER, INTENT(IN) :: incy DOUBLE PRECISION, INTENT(IN) :: dc DOUBLE PRECISION, INTENT(IN) :: ds DOUBLE PRECISION :: zero, one, w, z SAVE zero, one DATA zero, one /0.0D0, 1.0D0/ IF (n <= 0 .OR. (ds == zero .AND. dc == one)) GO TO 40 IF (.NOT. (incx == incy .AND. incx > 0)) GO TO 20 ! Code for equal and positive increments. nsteps=incx*n DO i = 1,nsteps,incx w=dx(i) z=dy(i) dx(i)=dc*w+ds*z dy(i)=-ds*w+dc*z END DO GO TO 40 ! Code for unequal or nonpositive increments. 20 CONTINUE kx=1 ky=1 IF (incx < 0) kx = 1-(n-1)*incx IF (incy < 0) ky = 1-(n-1)*incy DO i = 1,n w=dx(kx) z=dy(ky) dx(kx)=dc*w+ds*z dy(ky)=-ds*w+dc*z kx=kx+incx ky=ky+incy END DO 40 CONTINUE RETURN END SUBROUTINE drot ! ! BLAS: Compute the Euclidean length (L2 norm) of a vector. ! DOUBLE PRECISION FUNCTION dnrm2 (n, dx, incx) INTEGER, INTENT(IN) :: n DOUBLE PRECISION, INTENT(IN) :: dx(*) INTEGER, INTENT(IN) :: incx INTEGER :: next DOUBLE PRECISION :: cutlo, cuthi, hitest, sum, xmax, zero, one SAVE cutlo, cuthi, zero, one DATA zero, one /0.0D0, 1.0D0/ DATA cutlo, cuthi /8.232D-11, 1.304D19/ if (n <= 0) then dnrm2 = zero return end if next = 30 sum = zero nn = n * incx ! ! Begin main loop ! i = 1 20 continue if (next == 30) then goto 30 else if (next == 50) then goto 50 else if (next == 70) then goto 70 else goto 110 end if 30 continue if (ABS(dx(i)) > cutlo) GO TO 85 next=50 xmax = zero ! ! PHASE 1. SUM IS ZERO ! 50 continue IF (dx(i) == zero) GO TO 200 IF (ABS(dx(i)) > cutlo) GO TO 85 ! ! PREPARE FOR PHASE 2. ! next=70 GO TO 105 ! ! PREPARE FOR PHASE 4. ! 100 continue i = j next = 110 sum = (sum / dx(i)) / dx(i) 105 continue xmax = ABS(dx(i)) GO TO 115 ! ! PHASE 2. SUM IS SMALL. SCALE TO AVOID DESTRUCTIVE UNDERFLOW. ! 70 continue IF (ABS(dx(i)) > cutlo) GO TO 75 ! ! COMMON CODE FOR PHASES 2 AND 4. IN PHASE 4 SUM IS LARGE. ! SCALE TO AVOID OVERFLOW. ! 110 continue IF (ABS(dx(i)) <= xmax) GO TO 115 sum = one + sum * (xmax / dx(i))**2 xmax = ABS(dx(i)) GO TO 200 115 continue sum = sum + (dx(i)/xmax)**2 GO TO 200 ! ! Prepare for phase 3. ! 75 continue sum = (sum * xmax) * xmax ! ! FOR REAL OR D.P. SET HITEST = CUTHI/N ! FOR COMPLEX SET HITEST = CUTHI/(2*N) ! 85 continue hitest = cuthi / n ! ! PHASE 3. SUM IS MID-RANGE. NO SCALING. ! DO j = i,nn,incx IF (ABS(dx(j)) >= hitest) GO TO 100 sum = sum + dx(j)**2 END DO dnrm2 = SQRT(sum) GO TO 300 200 CONTINUE i = i + incx IF (i <= nn) GO TO 20 ! ! End of main loop. ! Compute square root and adjust for scaling. ! dnrm2 = xmax * SQRT(sum) 300 CONTINUE RETURN END FUNCTION dnrm2 ! ! Compute a constant times a vector plus a vector. ! SUBROUTINE daxpy (n, da, dx, incx, dy, incy) INTEGER, INTENT(IN) :: n DOUBLE PRECISION, INTENT(IN) :: da DOUBLE PRECISION, INTENT(IN) :: dx(*) INTEGER, INTENT(IN) :: incx DOUBLE PRECISION, INTENT(OUT) :: dy(*) INTEGER, INTENT(IN) :: incy IF (n <= 0 .OR. da == 0.0D0) RETURN IF (incx == incy) THEN IF (incx == 0) then goto 5 ELSE IF (incx == 1) then goto 20 ELSE goto 60 END IF END IF ! Code for unequal or nonpositive increments. 5 ix = 1 iy = 1 IF (incx < 0) ix = (-n+1)*incx + 1 IF (incy < 0) iy = (-n+1)*incy + 1 DO i = 1,n dy(iy) = dy(iy) + da*dx(ix) ix = ix + incx iy = iy + incy END DO RETURN ! Code for both increments equal to 1. ! Clean-up loop so remaining vector length is a multiple of 4. 20 m = MOD(n,4) IF (m == 0) GO TO 40 DO i = 1,m dy(i) = dy(i) + da*dx(i) END DO IF (n < 4) RETURN 40 mp1 = m + 1 DO i = mp1,n,4 dy(i) = dy(i) + da*dx(i) dy(i+1) = dy(i+1) + da*dx(i+1) dy(i+2) = dy(i+2) + da*dx(i+2) dy(i+3) = dy(i+3) + da*dx(i+3) END DO RETURN ! Code for equal, positive, non-unit increments. 60 ns = n*incx DO i = 1,ns,incx dy(i) = da*dx(i) + dy(i) END DO RETURN END SUBROUTINE daxpy ! ! Multiply a vector by a constant. ! SUBROUTINE dscal (n, da, dx, incx) INTEGER, INTENT(IN) :: n DOUBLE PRECISION, INTENT(IN) :: da DOUBLE PRECISION, INTENT(OUT) :: dx(*) INTEGER, INTENT(IN) :: incx INTEGER :: i, ix, m, mp1 IF (n <= 0) RETURN IF (incx == 1) GO TO 20 ! Code for increment not equal to 1. ix = 1 IF (incx < 0) ix = (-n+1)*incx + 1 DO i = 1,n dx(ix) = da*dx(ix) ix = ix + incx END DO RETURN ! Code for increment equal to 1. ! Clean-up loop so remaining vector length is a multiple of 5. 20 m = MOD(n,5) IF (m == 0) GO TO 40 DO i = 1,m dx(i) = da*dx(i) END DO IF (n < 5) RETURN 40 mp1 = m + 1 DO i = mp1,n,5 dx(i) = da*dx(i) dx(i+1) = da*dx(i+1) dx(i+2) = da*dx(i+2) dx(i+3) = da*dx(i+3) dx(i+4) = da*dx(i+4) END DO RETURN END SUBROUTINE dscal ! ! Interchange two vectors. ! SUBROUTINE dswap (n, dx, incx, dy, incy) INTEGER, INTENT(IN) :: n DOUBLE PRECISION, INTENT(IN OUT) :: dx(*) INTEGER, INTENT(IN) :: incx DOUBLE PRECISION, INTENT(IN OUT) :: dy(*) INTEGER, INTENT(IN) :: incy DOUBLE PRECISION :: dtemp1, dtemp2, dtemp3 IF (n <= 0) RETURN IF (incx == incy) THEN IF (incx == 0) then goto 5 ELSE IF (incx == 1) then goto 20 ELSE goto 60 END IF END IF ! Code for unequal or nonpositive increments. 5 ix = 1 iy = 1 IF (incx < 0) ix = (-n+1)*incx + 1 IF (incy < 0) iy = (-n+1)*incy + 1 DO i = 1,n dtemp1 = dx(ix) dx(ix) = dy(iy) dy(iy) = dtemp1 ix = ix + incx iy = iy + incy END DO RETURN ! Code for both increments equal to 1. ! Clean-up loop so remaining vector length is a multiple of 3. 20 m = MOD(n,3) IF (m == 0) GO TO 40 DO i = 1,m dtemp1 = dx(i) dx(i) = dy(i) dy(i) = dtemp1 END DO IF (n < 3) RETURN 40 mp1 = m + 1 DO i = mp1,n,3 dtemp1 = dx(i) dtemp2 = dx(i+1) dtemp3 = dx(i+2) dx(i) = dy(i) dx(i+1) = dy(i+1) dx(i+2) = dy(i+2) dy(i) = dtemp1 dy(i+1) = dtemp2 dy(i+2) = dtemp3 END DO RETURN ! Code for equal, positive, non-unit increments. 60 ns = n*incx DO i = 1,ns,incx dtemp1 = dx(i) dx(i) = dy(i) dy(i) = dtemp1 END DO RETURN END SUBROUTINE dswap ! ! Find the smallest index of that component of a vector ! having the maximum magnitude. ! INTEGER FUNCTION idamax (n, dx, incx) INTEGER, INTENT(IN) :: n DOUBLE PRECISION, INTENT(IN OUT) :: dx(*) INTEGER, INTENT(IN) :: incx DOUBLE PRECISION :: dmax, xmag INTEGER :: i, ix idamax = 0 IF (n <= 0) RETURN idamax = 1 IF (n == 1) RETURN IF (incx == 1) GO TO 20 ! Code for increments not equal to 1. ix = 1 IF (incx < 0) ix = (-n+1)*incx + 1 dmax = ABS(dx(ix)) ix = ix + incx DO i = 2,n xmag = ABS(dx(ix)) IF (xmag > dmax) THEN idamax = i dmax = xmag END IF ix = ix + incx END DO RETURN ! Code for increments equal to 1. 20 dmax = ABS(dx(1)) DO i = 2,n xmag = ABS(dx(i)) IF (xmag > dmax) THEN idamax = i dmax = xmag END IF END DO RETURN END FUNCTION idamax end module BLAS ! ! Selected LINPACK subroutines ! module LINPACK use BLAS contains ! ! Linpack via SLATEC converted using TO_F90 ! See original Fortran 77 code for documentation ! SUBROUTINE dgedi (a, lda, n, ipvt, det, work, job) DOUBLE PRECISION, INTENT(IN OUT) :: a(lda,*) INTEGER, INTENT(IN OUT) :: lda INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: ipvt(*) DOUBLE PRECISION, INTENT(OUT) :: det(2) DOUBLE PRECISION, INTENT(OUT) :: work(*) INTEGER, INTENT(IN) :: job DOUBLE PRECISION :: t DOUBLE PRECISION :: ten INTEGER :: i,j,k,kb,kp1,l,nm1 ! COMPUTE DETERMINANT IF (job/10 == 0) GO TO 70 det(1) = 1.0D0 det(2) = 0.0D0 ten = 10.0D0 DO i = 1, n IF (ipvt(i) /= i) det(1) = -det(1) det(1) = a(i,i)*det(1) IF (det(1) == 0.0D0) EXIT 10 IF (ABS(det(1)) >= 1.0D0) GO TO 20 det(1) = ten*det(1) det(2) = det(2) - 1.0D0 GO TO 10 20 CONTINUE 30 IF (ABS(det(1)) < ten) GO TO 40 det(1) = det(1)/ten det(2) = det(2) + 1.0D0 GO TO 30 40 CONTINUE END DO 70 CONTINUE ! COMPUTE INVERSE(U) IF (MOD(job,10) == 0) GO TO 150 DO k = 1, n a(k,k) = 1.0D0/a(k,k) t = -a(k,k) CALL dscal(k-1,t,a(1,k),1) kp1 = k + 1 IF (n < kp1) GO TO 90 DO j = kp1, n t = a(k,j) a(k,j) = 0.0D0 CALL daxpy(k,t,a(1,k),1,a(1,j),1) END DO 90 CONTINUE END DO ! FORM INVERSE(U)*INVERSE(L) nm1 = n - 1 IF (nm1 < 1) GO TO 140 DO kb = 1, nm1 k = n - kb kp1 = k + 1 DO i = kp1, n work(i) = a(i,k) a(i,k) = 0.0D0 END DO DO j = kp1, n t = work(j) CALL daxpy(n,t,a(1,j),1,a(1,k),1) END DO l = ipvt(k) IF (l /= k) CALL dswap(n,a(1,k),1,a(1,l),1) END DO 140 CONTINUE 150 CONTINUE RETURN END SUBROUTINE dgedi ! ! Factor a matrix using Gaussian elimination. ! SUBROUTINE dgefa (a, lda, n, ipvt, info) DOUBLE PRECISION, INTENT(IN OUT) :: a(lda,*) INTEGER, INTENT(IN OUT) :: lda INTEGER, INTENT(IN) :: n INTEGER, INTENT(OUT) :: ipvt(*) INTEGER, INTENT(OUT) :: info DOUBLE PRECISION :: t INTEGER :: j,k,kp1,l,nm1 ! functions called: idamax ! GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING info = 0 nm1 = n - 1 IF (nm1 < 1) GO TO 70 DO k = 1, nm1 kp1 = k + 1 ! FIND L = PIVOT INDEX l = idamax(n-k+1,a(k,k),1) + k - 1 ipvt(k) = l ! ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED IF (a(l,k) == 0.0D0) GO TO 40 ! INTERCHANGE IF NECESSARY IF (l == k) GO TO 10 t = a(l,k) a(l,k) = a(k,k) a(k,k) = t 10 CONTINUE ! COMPUTE MULTIPLIERS t = -1.0D0/a(k,k) CALL dscal(n-k,t,a(k+1,k),1) ! ROW ELIMINATION WITH COLUMN INDEXING DO j = kp1, n t = a(l,j) IF (l == k) GO TO 20 a(l,j) = a(k,j) a(k,j) = t 20 CONTINUE CALL daxpy(n-k,t,a(k+1,k),1,a(k+1,j),1) END DO GO TO 50 40 CONTINUE info = k 50 CONTINUE END DO 70 CONTINUE ipvt(n) = n IF (a(n,n) == 0.0D0) info = n RETURN END SUBROUTINE dgefa ! ! Singular value decomposition of a rectangular matrix. ! SUBROUTINE dsvdc (x, ldx, n, p, s, e, u, ldu, v, ldv, work, job, info) DOUBLE PRECISION, INTENT(IN OUT) :: x(ldx,*) INTEGER, INTENT(IN) :: ldx INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: p DOUBLE PRECISION, INTENT(INOUT) :: s(*) DOUBLE PRECISION, INTENT(INOUT) :: e(*) DOUBLE PRECISION, INTENT(OUT) :: u(ldu,*) INTEGER, INTENT(IN) :: ldu DOUBLE PRECISION, INTENT(OUT) :: v(ldv,*) INTEGER, INTENT(IN) :: ldv DOUBLE PRECISION, INTENT(OUT) :: work(*) INTEGER, INTENT(IN) :: job INTEGER, INTENT(OUT) :: info INTEGER :: i,iter,j,jobu,k,kase,kk,l,ll,lls,lm1,lp1,ls,lu,m,maxit, & mm,mm1,mp1,nct,nctp1,ncu,nrt,nrtp1 DOUBLE PRECISION :: t DOUBLE PRECISION :: b,c,cs,el,emm1,f,g,scale,shift,sl,sm,sn, & smm1,t1,test,ztest LOGICAL :: wantu,wantv ! functions called: ddot, dnrm2 ! SET THE MAXIMUM NUMBER OF ITERATIONS. maxit = 30 ! DETERMINE WHAT IS TO BE COMPUTED. wantu = .false. wantv = .false. jobu = MOD(job,100)/10 ncu = n IF (jobu > 1) ncu = MIN(n,p) IF (jobu /= 0) wantu = .true. IF (MOD(job,10) /= 0) wantv = .true. ! REDUCE X TO BIDIAGONAL FORM, STORING THE DIAGONAL ELEMENTS ! IN S AND THE SUPER-DIAGONAL ELEMENTS IN E. info = 0 nct = MIN(n-1,p) nrt = MAX(0,MIN(p-2,n)) lu = MAX(nct,nrt) IF (lu < 1) GO TO 170 DO l = 1, lu lp1 = l + 1 IF (l > nct) GO TO 20 ! COMPUTE THE TRANSFORMATION FOR THE L-TH COLUMN AND ! PLACE THE L-TH DIAGONAL IN S(L). s(l) = dnrm2(n-l+1,x(l,l),1) IF (s(l) == 0.0D0) GO TO 10 IF (x(l,l) /= 0.0D0) s(l) = SIGN(s(l),x(l,l)) CALL dscal(n-l+1,1.0D0/s(l),x(l,l),1) x(l,l) = 1.0D0 + x(l,l) 10 CONTINUE s(l) = -s(l) 20 CONTINUE IF (p < lp1) GO TO 50 DO j = lp1, p IF (l > nct) GO TO 30 IF (s(l) == 0.0D0) GO TO 30 ! APPLY THE TRANSFORMATION. t = -ddot(n-l+1,x(l,l),1,x(l,j),1)/x(l,l) CALL daxpy(n-l+1,t,x(l,l),1,x(l,j),1) 30 CONTINUE ! PLACE THE L-TH ROW OF X INTO E FOR THE ! SUBSEQUENT CALCULATION OF THE ROW TRANSFORMATION. e(j) = x(l,j) END DO 50 CONTINUE IF (.NOT.wantu .OR. l > nct) GO TO 70 ! PLACE THE TRANSFORMATION IN U FOR SUBSEQUENT BACK ! MULTIPLICATION. DO i = l, n u(i,l) = x(i,l) END DO 70 CONTINUE IF (l > nrt) GO TO 150 ! COMPUTE THE L-TH ROW TRANSFORMATION AND PLACE THE ! L-TH SUPER-DIAGONAL IN E(L). e(l) = dnrm2(p-l,e(lp1),1) IF (e(l) == 0.0D0) GO TO 80 IF (e(lp1) /= 0.0D0) e(l) = SIGN(e(l),e(lp1)) CALL dscal(p-l,1.0D0/e(l),e(lp1),1) e(lp1) = 1.0D0 + e(lp1) 80 CONTINUE e(l) = -e(l) IF (lp1 > n .OR. e(l) == 0.0D0) GO TO 120 ! APPLY THE TRANSFORMATION. DO i = lp1, n work(i) = 0.0D0 END DO DO j = lp1, p CALL daxpy(n-l,e(j),x(lp1,j),1,work(lp1),1) END DO DO j = lp1, p CALL daxpy(n-l,-e(j)/e(lp1),work(lp1),1,x(lp1,j),1) END DO 120 CONTINUE IF (.NOT.wantv) GO TO 140 ! PLACE THE TRANSFORMATION IN V FOR SUBSEQUENT ! BACK MULTIPLICATION. DO i = lp1, p v(i,l) = e(i) END DO 140 CONTINUE 150 CONTINUE END DO 170 CONTINUE ! SET UP THE FINAL BIDIAGONAL MATRIX OR ORDER M. m = MIN(p,n+1) nctp1 = nct + 1 nrtp1 = nrt + 1 IF (nct < p) s(nctp1) = x(nctp1,nctp1) IF (n < m) s(m) = 0.0D0 IF (nrtp1 < m) e(nrtp1) = x(nrtp1,m) e(m) = 0.0D0 ! IF REQUIRED, GENERATE U. IF (.NOT.wantu) GO TO 300 IF (ncu < nctp1) GO TO 200 DO j = nctp1, ncu DO i = 1, n u(i,j) = 0.0D0 END DO u(j,j) = 1.0D0 END DO 200 CONTINUE IF (nct < 1) GO TO 290 DO ll = 1, nct l = nct - ll + 1 IF (s(l) == 0.0D0) GO TO 250 lp1 = l + 1 IF (ncu < lp1) GO TO 220 DO j = lp1, ncu t = -ddot(n-l+1,u(l,l),1,u(l,j),1)/u(l,l) CALL daxpy(n-l+1,t,u(l,l),1,u(l,j),1) END DO 220 CONTINUE CALL dscal(n-l+1,-1.0D0,u(l,l),1) u(l,l) = 1.0D0 + u(l,l) lm1 = l - 1 IF (lm1 < 1) GO TO 240 DO i = 1, lm1 u(i,l) = 0.0D0 END DO 240 CONTINUE GO TO 270 250 CONTINUE DO i = 1, n u(i,l) = 0.0D0 END DO u(l,l) = 1.0D0 270 CONTINUE END DO 290 CONTINUE 300 CONTINUE ! IF IT IS REQUIRED, GENERATE V. IF (.NOT.wantv) GO TO 350 DO ll = 1, p l = p - ll + 1 lp1 = l + 1 IF (l > nrt) GO TO 320 IF (e(l) == 0.0D0) GO TO 320 DO j = lp1, p t = -ddot(p-l,v(lp1,l),1,v(lp1,j),1)/v(lp1,l) CALL daxpy(p-l,t,v(lp1,l),1,v(lp1,j),1) END DO 320 CONTINUE DO i = 1, p v(i,l) = 0.0D0 END DO v(l,l) = 1.0D0 END DO 350 CONTINUE ! MAIN ITERATION LOOP FOR THE SINGULAR VALUES. mm = m iter = 0 360 CONTINUE ! QUIT IF ALL THE SINGULAR VALUES HAVE BEEN FOUND. IF (m == 0) GO TO 620 ! IF TOO MANY ITERATIONS HAVE BEEN PERFORMED, SET ! FLAG AND RETURN. IF (iter < maxit) GO TO 370 info = m GO TO 620 370 CONTINUE ! ! THIS SECTION OF THE PROGRAM INSPECTS FOR ! NEGLIGIBLE ELEMENTS IN THE S AND E ARRAYS. ON ! COMPLETION THE VARIABLES KASE AND L ARE SET AS FOLLOWS. ! ! KASE = 1 IF S(M) AND E(L-1) ARE NEGLIGIBLE AND L.LT.M ! KASE = 2 IF S(L) IS NEGLIGIBLE AND L.LT.M ! KASE = 3 IF E(L-1) IS NEGLIGIBLE, L.LT.M, AND ! S(L), ..., S(M) ARE NOT NEGLIGIBLE (QR STEP). ! KASE = 4 IF E(M-1) IS NEGLIGIBLE (CONVERGENCE). ! DO ll = 1, m l = m - ll IF (l == 0) EXIT test = ABS(s(l)) + ABS(s(l+1)) ztest = test + ABS(e(l)) IF (ztest /= test) GO TO 380 e(l) = 0.0D0 EXIT 380 CONTINUE END DO IF (l /= m - 1) GO TO 410 kase = 4 GO TO 480 410 CONTINUE lp1 = l + 1 mp1 = m + 1 DO lls = lp1, mp1 ls = m - lls + lp1 IF (ls == l) EXIT test = 0.0D0 IF (ls /= m) test = test + ABS(e(ls)) IF (ls /= l + 1) test = test + ABS(e(ls-1)) ztest = test + ABS(s(ls)) IF (ztest /= test) GO TO 420 s(ls) = 0.0D0 EXIT 420 CONTINUE END DO IF (ls /= l) GO TO 450 kase = 3 GO TO 470 450 CONTINUE IF (ls /= m) GO TO 460 kase = 1 GO TO 470 460 CONTINUE kase = 2 l = ls 470 CONTINUE 480 CONTINUE l = l + 1 ! PERFORM THE TASK INDICATED BY KASE. SELECT CASE ( kase ) CASE ( 1) GO TO 490 CASE ( 2) GO TO 520 CASE ( 3) GO TO 540 CASE ( 4) GO TO 570 END SELECT ! DEFLATE NEGLIGIBLE S(M). 490 CONTINUE mm1 = m - 1 f = e(m-1) e(m-1) = 0.0D0 DO kk = l, mm1 k = mm1 - kk + l t1 = s(k) CALL drotg(t1,f,cs,sn) s(k) = t1 IF (k == l) GO TO 500 f = -sn*e(k-1) e(k-1) = cs*e(k-1) 500 CONTINUE IF (wantv) CALL drot(p,v(1,k),1,v(1,m),1,cs,sn) END DO GO TO 610 ! SPLIT AT NEGLIGIBLE S(L). 520 CONTINUE f = e(l-1) e(l-1) = 0.0D0 DO k = l, m t1 = s(k) CALL drotg(t1,f,cs,sn) s(k) = t1 f = -sn*e(k) e(k) = cs*e(k) IF (wantu) CALL drot(n,u(1,k),1,u(1,l-1),1,cs,sn) END DO GO TO 610 ! PERFORM ONE QR STEP. 540 CONTINUE ! CALCULATE THE SHIFT. scale = MAX(ABS(s(m)),ABS(s(m-1)),ABS(e(m-1)), ABS(s(l)),ABS(e(l))) sm = s(m)/scale smm1 = s(m-1)/scale emm1 = e(m-1)/scale sl = s(l)/scale el = e(l)/scale b = ((smm1 + sm)*(smm1 - sm) + emm1**2)/2.0D0 c = (sm*emm1)**2 shift = 0.0D0 IF (b == 0.0D0 .AND. c == 0.0D0) GO TO 550 shift = SQRT(b**2+c) IF (b < 0.0D0) shift = -shift shift = c/(b + shift) 550 CONTINUE f = (sl + sm)*(sl - sm) - shift g = sl*el ! CHASE ZEROS. mm1 = m - 1 DO k = l, mm1 CALL drotg(f,g,cs,sn) IF (k /= l) e(k-1) = f f = cs*s(k) + sn*e(k) e(k) = cs*e(k) - sn*s(k) g = sn*s(k+1) s(k+1) = cs*s(k+1) IF (wantv) CALL drot(p,v(1,k),1,v(1,k+1),1,cs,sn) CALL drotg(f,g,cs,sn) s(k) = f f = cs*e(k) + sn*s(k+1) s(k+1) = -sn*e(k) + cs*s(k+1) g = sn*e(k+1) e(k+1) = cs*e(k+1) IF (wantu .AND. k < n) CALL drot(n,u(1,k),1,u(1,k+1),1,cs,sn) END DO e(m-1) = f iter = iter + 1 GO TO 610 ! CONVERGENCE. 570 CONTINUE ! MAKE THE SINGULAR VALUE POSITIVE. IF (s(l) >= 0.0D0) GO TO 580 s(l) = -s(l) IF (wantv) CALL dscal(p,-1.0D0,v(1,l),1) 580 CONTINUE ! ORDER THE SINGULAR VALUE. 590 IF (l == mm) GO TO 600 IF (s(l) >= s(l+1)) GO TO 600 t = s(l) s(l) = s(l+1) s(l+1) = t IF (wantv .AND. l < p) CALL dswap(p,v(1,l),1,v(1,l+1),1) IF (wantu .AND. l < n) CALL dswap(n,u(1,l),1,u(1,l+1),1) l = l + 1 GO TO 590 600 CONTINUE iter = 0 m = m - 1 610 CONTINUE GO TO 360 620 CONTINUE RETURN END SUBROUTINE dsvdc end module LINPACK ! ! Selected EISPACK subroutines ! module EISPACK use BLAS contains ! ! This subroutine calls the recommended sequence of ! subroutines from the Eigensystem Subroutine Package (EISPACK) ! to find the eigenvalues and eigenvectors (if desired) ! of a real symmetric matrix. ! subroutine rs(nm, n, a, w, matz, z, fv1, fv2, ierr) integer, intent(inout) :: nm ! Row dimension of a, z integer, intent(in) :: n ! order of a double precision, dimension(nm,n), intent(inout) :: a ! matrix double precision, dimension(n), intent(inout) :: w ! eigenvalues integer, intent(in) :: matz ! 1=eigenvectors double precision, dimension(nm,n), intent(out) :: z ! eigenvectors double precision, dimension(n), intent(inout) :: fv1 ! workspace double precision, dimension(n), intent(inout) :: fv2 ! workspace integer, intent(out) :: ierr if (n <= nm) go to 10 ierr = 10 * n go to 50 10 if (matz /= 0) go to 20 ! .......... FIND EIGENVALUES ONLY .......... call tred1(nm, n, a, w, fv1, fv2) call tqlrat(n, w, fv2, ierr) go to 50 ! .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... 20 continue call tred2(nm, n, a, w, fv1, z) call tql2(nm, n, w, fv1, z, ierr) 50 return end subroutine rs ! ! This EISPACK subroutine is a translation of the Algol procedure TRED1, ! Num. Math. 11, 181-195(1968) by Martin, Reinsch, and Wilkinson. ! Handbook for Auto. Comp., Vol.II-Linear Algebra, 212-226(1971). ! This subroutine reduces a real symmetric matrix ! to a symmetric tridiagonal matrix using ! orthogonal similarity transformations. ! subroutine tred1(nm, n, a, d, e, e2) integer, intent(inout) :: nm ! number of rows in a integer, intent(in) :: n ! order of a double precision, dimension(nm,n), intent(inout) :: a ! symmetric matrix (lower tri) double precision, dimension(n), intent(out) :: d ! diagonal elements double precision, dimension(n), intent(out) :: e ! subdiagonal elements double precision, dimension(n), intent(out) :: e2 ! e**2 integer :: i, j, k, l, ii, jp1 ! local variables double precision :: f, g, h, scal do i = 1, n d(i) = a(n, i) a(n, i) = a(i, i) end do ! .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... do ii = 1, n i = n + 1 - ii l = i - 1 h = 0.0d0 scal = 0.0d0 if (l < 1) go to 130 ! .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... do k = 1, l scal = scal + dabs(d(k)) end do if (scal /= 0.0d0) go to 140 do j = 1, l d(j) = a(l, j) a(l, j) = a(i, j) a(i, j) = 0.0d0 end do 130 e(i) = 0.0d0 e2(i) = 0.0d0 cycle 140 do k = 1, l d(k) = d(k) / scal h = h + d(k) * d(k) end do e2(i) = scal * scal * h f = d(l) g = -dsign(dsqrt(h), f) e(i) = scal * g h = h - f * g d(l) = f - g if (l == 1) go to 285 ! .......... FORM A*U .......... do j = 1, l e(j) = 0.0d0 end do do j = 1, l f = d(j) g = e(j) + a(j, j) * f jp1 = j + 1 if (l < jp1) go to 220 do k = jp1, l g = g + a(k, j) * d(k) e(k) = e(k) + a(k, j) * f end do 220 e(j) = g end do ! .......... FORM P .......... f = 0.0d0 do j = 1, l e(j) = e(j) / h f = f + e(j) * d(j) end do h = f / (h + h) ! .......... FORM Q .......... do j = 1, l e(j) = e(j) - h * d(j) end do ! .......... FORM REDUCED A .......... do j = 1, l f = d(j) g = e(j) do k = j, l a(k, j) = a(k, j) - f * e(k) - g * d(k) end do end do 285 continue do j = 1, l f = d(j) d(j) = a(l, j) a(l, j) = a(i, j) a(i, j) = f * scal end do end do return end subroutine tred1 ! ! This EISPACK subroutine is a translation of the Algol procedure TRED2, ! Num. Math. 11, 181-195(1968) by Martin, Reinsch, and Wilkinson. ! Handbook for Auto. Comp., Vol.II-Linear Algebra, 212-226(1971). ! This subroutine reduces a real symmetric matrix to a ! symmetric tridiagonal matrix using and accumulating ! orthogonal similarity transformations. ! subroutine tred2(nm, n, a, d, e, z) integer, intent(inout) :: nm integer, intent(in) :: n double precision, dimension(nm,n), intent(in) :: a double precision, dimension(n), intent(out) :: d double precision, dimension(n), intent(out) :: e double precision, dimension(nm,n), intent(out) :: z ! local variables integer :: i, j, k, l, ii, jp1 double precision :: f, g, h, hh, scal do i = 1, n do j = i, n z(j, i) = a(j, i) end do d(i) = a(n, i) end do if (n == 1) go to 510 ! .......... FOR I=N STEP -1 UNTIL 2 DO -- .......... do ii = 2, n i = n + 2 - ii l = i - 1 h = 0.0d0 scal = 0.0d0 if (l < 2) go to 130 ! .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... do k = 1, l scal = scal + dabs(d(k)) end do if (scal /= 0.0d0) go to 140 130 e(i) = d(l) do j = 1, l d(j) = z(l, j) z(i, j) = 0.0d0 z(j, i) = 0.0d0 end do go to 290 140 do k = 1, l d(k) = d(k) / scal h = h + d(k) * d(k) end do f = d(l) g = -dsign(dsqrt(h), f) e(i) = scal * g h = h - f * g d(l) = f - g ! .......... FORM A*U .......... do j = 1, l e(j) = 0.0d0 end do do j = 1, l f = d(j) z(j, i) = f g = e(j) + z(j, j) * f jp1 = j + 1 if (l < jp1) go to 220 do k = jp1, l g = g + z(k, j) * d(k) e(k) = e(k) + z(k, j) * f end do 220 e(j) = g end do ! .......... FORM P .......... f = 0.0d0 do j = 1, l e(j) = e(j) / h f = f + e(j) * d(j) end do hh = f / (h + h) ! .......... FORM Q .......... do j = 1, l e(j) = e(j) - hh * d(j) end do ! .......... FORM REDUCED A .......... do j = 1, l f = d(j) g = e(j) do k = j, l z(k, j) = z(k, j) - f * e(k) - g * d(k) end do d(j) = z(l, j) z(i, j) = 0.0d0 end do 290 d(i) = h end do ! .......... ACCUMULATION OF TRANSFORMATION MATRICES .......... do i = 2, n l = i - 1 z(n, l) = z(l, l) z(l, l) = 1.0d0 h = d(i) if (h == 0.0d0) go to 380 do k = 1, l d(k) = z(k, i) / h end do do j = 1, l g = 0.0d0 do k = 1, l g = g + z(k, i) * z(k, j) end do do k = 1, l z(k, j) = z(k, j) - g * d(k) end do end do 380 continue do k = 1, l z(k, i) = 0.0d0 end do end do 510 continue do i = 1, n d(i) = z(n, i) z(n, i) = 0.0d0 end do z(n, n) = 1.0d0 e(1) = 0.0d0 return end subroutine tred2 ! ! This EISPACK subroutine is a translation of the Algol procedure TQLRAT, ! Algorithm 464, Comm. ACM 16, 689(1973) By Reinsch. ! ! This subroutine finds the eigenvalues of a symmetric ! tridiagonal matrix by the rational QL method. ! subroutine tqlrat(n, d, e2, ierr) integer, intent(in) :: n double precision, dimension(n), intent(inout) :: d double precision, dimension(n), intent(out) :: e2 integer, intent(out) :: ierr ! local variables integer :: i, j, l, m, ii, l1, mml double precision :: b, c, f, g, h, p, r, s, t ! functions ! double precision :: epslon, pythag b = 0.0d0 c = 0.0d0 ierr = 0 if (n == 1) go to 1001 do i = 2, n e2(i-1) = e2(i) end do f = 0.0d0 t = 0.0d0 e2(n) = 0.0d0 do l = 1, n j = 0 h = dabs(d(l)) + dsqrt(e2(l)) if (t > h) go to 105 t = h b = epslon(t) c = b * b ! .......... LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT .......... 105 do m = l, n if (e2(m) <= c) go to 120 ! .......... E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT ! THROUGH THE BOTTOM OF THE LOOP .......... end do 120 if (m == l) go to 210 130 if (j == 30) go to 1000 j = j + 1 ! .......... FORM SHIFT .......... l1 = l + 1 s = dsqrt(e2(l)) g = d(l) p = (d(l1) - g) / (2.0d0 * s) r = pythag(p, 1.0d0) d(l) = s / (p + dsign(r, p)) h = g - d(l) do i = l1, n d(i) = d(i) - h end do f = f + h ! .......... RATIONAL QL TRANSFORMATION .......... g = d(m) if (g == 0.0d0) g = b h = g s = 0.0d0 mml = m - l ! .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... do ii = 1, mml i = m - ii p = g * h r = p + e2(i) e2(i+1) = s * r s = e2(i) / r d(i+1) = h + s * (h + d(i)) g = d(i) - e2(i) / g if (g == 0.0d0) g = b h = g * p / r end do e2(l) = s * g d(l) = h ! .......... GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST .......... if (h == 0.0d0) go to 210 if (dabs(e2(l)) <= dabs(c/h)) go to 210 e2(l) = h * e2(l) if (e2(l) /= 0.0d0) go to 130 210 p = d(l) + f ! .......... ORDER EIGENVALUES .......... if (l == 1) go to 250 ! .......... FOR I=L STEP -1 UNTIL 2 DO -- .......... do ii = 2, l i = l + 2 - ii if (p >= d(i-1)) go to 270 d(i) = d(i-1) end do 250 i = 1 270 d(i) = p end do go to 1001 ! .......... SET ERROR -- NO CONVERGENCE TO AN ! EIGENVALUE AFTER 30 ITERATIONS .......... 1000 ierr = l 1001 return end subroutine tqlrat ! ! This EISPACK subroutine is a translation of the Algol procedure TQL2, ! Num. Math. 11, 293-306(1968) by Bowdler, Martin, Reinsch, and Wilkinson. ! Handbook for Auto. Comp., Vol.II-Linear Algebra, 227-240(1971). ! ! This subroutine finds the eigenvalues and eigenvectors ! of a symmetric tridiagonal matrix by the ql method. ! The eigenvectors of a full symmetric matrix can also ! be found if tred2 has been used to reduce this ! full matrix to tridiagonal form. ! subroutine tql2(nm, n, d, e, z, ierr) integer, intent(inout) :: nm integer, intent(in) :: n double precision, dimension(n), intent(inout) :: d double precision, dimension(n), intent(inout) :: e double precision, dimension(nm,n), intent(inout) :: z integer, intent(out) :: ierr ! local variables integer :: i, j, k, l, m, ii, l1, l2, mml double precision :: c, c2, c3, dl1, el1, f, g, h, p, r, s, s2, tst1, tst2 ! functions ! double precision :: pythag ! D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN ! ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT ! UNORDERED FOR INDICES 1, 2, ..., IERR-1. ! E HAS BEEN DESTROYED. ! Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC ! TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE, ! Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED ! EIGENVALUES. ! IERR IS SET TO ! ZERO FOR NORMAL RETURN, ! J IF THE J-TH EIGENVALUE HAS NOT BEEN ! DETERMINED AFTER 30 ITERATIONS. ! CALLS PYTHAG FOR DSQRT(A*A + B*B) . ! QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, ! MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY ! THIS VERSION DATED AUGUST 1983. c3 = 0.0d0 s2 = 0.0d0 ierr = 0 if (n == 1) go to 1001 do i = 2, n e(i-1) = e(i) end do f = 0.0d0 tst1 = 0.0d0 e(n) = 0.0d0 do l = 1, n j = 0 h = dabs(d(l)) + dabs(e(l)) if (tst1 < h) tst1 = h ! .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... do m = l, n tst2 = tst1 + dabs(e(m)) if (tst2 == tst1) go to 120 ! .......... E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT ! THROUGH THE BOTTOM OF THE LOOP .......... end do 120 if (m == l) go to 220 130 if (j == 30) go to 1000 j = j + 1 ! .......... FORM SHIFT .......... l1 = l + 1 l2 = l1 + 1 g = d(l) p = (d(l1) - g) / (2.0d0 * e(l)) r = pythag(p, 1.0d0) d(l) = e(l) / (p + dsign(r, p)) d(l1) = e(l) * (p + dsign(r, p)) dl1 = d(l1) h = g - d(l) if (l2 > n) go to 145 do i = l2, n d(i) = d(i) - h end do 145 f = f + h ! .......... QL TRANSFORMATION .......... p = d(m) c = 1.0d0 c2 = c el1 = e(l1) s = 0.0d0 mml = m - l ! .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... do ii = 1, mml c3 = c2 c2 = c s2 = s i = m - ii g = c * e(i) h = c * p r = pythag(p, e(i)) e(i+1) = s * r s = e(i) / r c = p / r p = c * d(i) - s * g d(i+1) = h + s * (c * g + s * d(i)) ! .......... FORM VECTOR .......... do k = 1, n h = z(k, i+1) z(k, i+1) = s * z(k, i) + c * h z(k, i) = c * z(k, i) - s * h end do end do p = -s * s2 * c3 * el1 * e(l) / dl1 e(l) = s * p d(l) = c * p tst2 = tst1 + dabs(e(l)) if (tst2 > tst1) go to 130 220 d(l) = d(l) + f end do ! .......... ORDER EIGENVALUES AND EIGENVECTORS .......... do ii = 2, n i = ii - 1 k = i p = d(i) do j = ii, n if (d(j) >= p) cycle k = j p = d(j) end do if (k == i) cycle d(k) = d(i) d(i) = p do j = 1, n p = z(j, i) z(j, i) = z(j, k) z(j, k) = p end do end do go to 1001 ! .......... SET ERROR -- NO CONVERGENCE TO AN ! EIGENVALUE AFTER 30 ITERATIONS .......... 1000 ierr = l 1001 return end subroutine tql2 ! ! Finds dsqrt(A**2+B**2) without overflow or destructive underflow ! function pythag(a, b) double precision :: pythag double precision, intent(in) :: a double precision, intent(in) :: b ! local variables double precision :: p, r, s, t, u p = dmax1(dabs(a), dabs(b)) if (p /= 0.0d0) then r = (dmin1(dabs(a), dabs(b))/p)**2 do t = 4.0d0 + r if (t == 4.0d0) exit s = r/t u = 1.0d0 + 2.0d0*s p = u*p r = (s/u)**2 * r end do end if pythag = p return end function pythag ! ! estimate unit roundoff in quantities of size x ! function epslon (x) double precision :: epslon double precision :: x ! local variables double precision :: a,b,c,eps a = 4.0D0/3.0D0 10 continue b = a - 1.0D0 c = b + b + b eps = dabs(c-1.0D0) if (eps == 0.0D0) go to 10 epslon = eps*dabs(x) return end function epslon end module EISPACK ! ! Algorithm AS 319 ! variable metric function minimisation ! Algorithm AS 319 Appl Statist (1997), Vol 46, No 4 ! Converted to Fortran 90 free-format style by Alan Miller ! e-mail: Alan.Miller @ vic.cmis.csiro.au ! URL: www.ozemail.com.au/~milleraj ! module AS319 implicit none logical, save :: ler integer, save :: ig, ifn end module AS319 ! ! Pedigree MVN and MFT model loglikelihood ! mftlik_plevel controls output detail from mftlik() ! mftlik_nerrors counts number of pedigrees causing problems ! mftlik_interval is estimate of 99% interval containing likelihood (MC error) ! module likelihoods integer :: mftlik_plevel = 0 integer :: mftlik_nerrors = 0 double precision, dimension(2) :: mftlik_interval = 0.0d0 contains ! ! MVN model loglikelihood ! function mvnlik(fname, npar, parest) use outstream use AS319 use ibd_class use symmetric_matrix double precision :: mvnlik character(len=*), intent(in) :: fname integer, intent(in) :: npar double precision, dimension(:) :: parest ! local variables integer :: fam, i, ifault, nullty, pos double precision :: quad, logdet, va, ve, vq, ymean, yp ! ler = .false. ifault=0 nullty=0 mvnlik=0.0D0 ymean=parest(1) va=0.0D0 vq=0.0D0 ve=abs(parest(npar)) if (vc_typ >= 1) va=abs(parest(vc_nfix+1)) if (vc_typ == 2) vq=abs(parest(vc_nfix+2)) ! do fam=1, nfam do i=1, families(fam)%ncov a(i)=families(fam)%a(i)*va+families(fam)%c(i)*vq end do pos=0 do i=1, families(fam)%nobs pos=pos+i a(pos)=a(pos)+ve end do if (vc_invalg == 0) then call syminv(a, families(fam)%nobs, c, logdet, ifault) else ifault=0 call geninv(a, families(fam)%nobs, c, logdet, i, ifault) end if if (ifault /= 0) then write(outstr,*) fname, ' problem inverting matrix:', a(1:5), & '... IFAULT=', ifault mvnlik=-1.0D99 else pos=0 do i=1, families(fam)%nobs pos=pos+i yp=ymean do j=2, vc_nfix yp=yp+parest(j)*families(fam)%vals(i, j) end do m(i)=yp end do call quadform(families(fam)%nobs, families(fam)%yval, m, c, quad) mvnlik=mvnlik+logdet+quad end if end do end function mvnlik ! ! MFT model loglikelihood ! function mftlik(fname, npar, parest) use outstream use AS319 use ibd_class use mftcontrol use mftfuns use statfuns double precision :: mftlik character(len=*), intent(in) :: fname integer, intent(in) :: npar double precision, dimension(:) :: parest ! local variables integer :: fam, i, ii, j, jj double precision :: va, ve, vq, ymean, yp integer :: ift, maxpts double precision :: err, lik ! functions double precision :: ln ! err=0.0d0 lik=0.0d0 mftlik_nerrors = 0 mftlik=0.0D0 mftlik_interval=0.0d0 ymean=parest(1) va=0.0D0 vq=0.0D0 if (vc_typ >= 1) va=abs(parest(vc_nfix+1))/(1.0d0+abs(parest(vc_nfix+1))) if (vc_typ == 2) vq=abs(parest(vc_nfix+2))/(1.0d0+abs(parest(vc_nfix+2))) if (va < 0.0d0 .or. va > 1.0d0) return if (vq < 0.0d0 .or. vq > 1.0d0) return do fam=1, nfam ii=1 jj=0 do i=2, families(fam)%nobs do j=1, i-1 ii=ii+1 jj=jj+1 a(jj)=families(fam)%a(ii)*va+families(fam)%c(ii)*vq end do ii=ii+1 end do do i=1, families(fam)%nobs yp=ymean do j=2, vc_nfix yp=yp+parest(j)*families(fam)%vals(i, j) end do m(i)=yp censor(i)=int(families(fam)%yval(i)) end do if (mftalgo == 1) then call mecdf(families(fam)%nobs, m, 2*censor-1, a, lik, ift) if (ift /= 0) then mftlik_nerrors = mftlik_nerrors+1 if (mftlik_plevel > 0) then write(outstr,'(a,i0,a/7x,a,g12.6,a)', advance='no') & 'NOTE: mecdf failed in ', fam, 'th pedigree.', & 'likelihood=', lik, ' pars=' write(outstr,*) parest(1:(vc_nfix+1)) end if end if else maxpts=mfteval*families(fam)%nobs call mvndst(families(fam)%nobs, m, m, censor, a, & maxpts, abseps, releps, err, lik, ift) if (ift == 1) then mftlik_nerrors = mftlik_nerrors+1 if (mftlik_plevel > 0) then write(outstr,'(a,i0,a,i0,a/7x,a,g12.6,a,g12.6)') & 'NOTE: Exceeded ', maxpts, ' evaluations in ', fam, 'th pedigree.', & 'likelihood=', lik, ' absolute error=', err end if end if end if if (lik == 0.0d0) then mftlik=1.0D99 else mftlik=mftlik-ln(lik) mftlik_interval(1)=mftlik_interval(1)-ln(lik-err) mftlik_interval(2)=mftlik_interval(2)-ln(lik+err) end if end do mftlik=mftlik+mftlik mftlik_interval(1)=mftlik_interval(1)+mftlik_interval(1) mftlik_interval(2)=mftlik_interval(2)+mftlik_interval(2) if (mftlik_plevel > 1) then write(outstr,'(a)', advance='no') 'MFT Likelihood and parameter estimates = ' write(outstr,*) mftlik, '; ', parest(1:(vc_nfix+1)) end if end function mftlik end module likelihoods ! ! Algorithm AS 319 ! variable metric function minimisation ! Algorithm AS 319 Appl Statist (1997), Vol 46, No 4 ! Converted to Fortran 90 free-format style by Alan Miller ! e-mail: Alan.Miller @ vic.cmis.csiro.au ! URL: www.ozemail.com.au/~milleraj ! ! Actual varmet minimizer ! module varmet_optimizer public :: varmet, vmerr private :: grad contains subroutine varmet(fname, fun, npar, b, f0, gradtl, toler, maxfn, ifault, plevel) use outstream use AS319 use interrupt ! double precision :: fun character(len=*), intent(in) :: fname integer, intent(in) :: npar double precision, dimension(:) :: b double precision, intent(out) :: f0 double precision, intent(in) :: gradtl double precision, intent(in) :: toler integer, intent(inout) :: maxfn integer, intent(out) :: ifault integer, intent(in) :: plevel double precision :: d1, s, ck, f1, d2 integer :: i, ic, icount, ilast, j, k, np integer, parameter :: icmax=20 double precision, parameter :: w=0.2d0 double precision, dimension(npar) :: g, c, d double precision, dimension(npar, npar) :: h double precision, dimension(2*npar) :: t ! interface function fun(fname, npar, parest) use AS319 use ibd_class double precision :: fun character(len=*), intent(in) :: fname integer, intent(in) :: npar double precision, dimension(:) :: parest end function fun end interface ! ig = 0 ifn = 0 ler = .false. ifault = 0 np = npar + 1 ! if (maxfn == 0) maxfn = 1000 ! f0 = fun(fname, npar, b) if (ler) then ifault = 1 return end if ifn = ifn + 1 if (plevel > 1) then write(outstr,'(i4,1x,g12.6,(t17,10(1x,f12.6)):)') ifn, f0, (b(i),i=1, npar) end if ! call grad(fname, fun, npar, b, f0, g, t(np:), gradtl, ifault) if (ifault > 0) return ! ig = ig + 1 ifn = ifn + npar if (ifn > maxfn) then ifault = 4 return end if ! 10 continue do k = 1, npar h(k,1:npar) = 0.0d0 h(k,k) = 1.0d0 end do ilast = ig ! do do i = 1, npar d(i) = b(i) c(i) = g(i) end do ! d1 = 0.0d0 do i = 1, npar s = - dot_product( h(i,1:npar), g(1:npar) ) t(i) = s d1 = d1 - s*g(i) end do ! if (d1 <= 0.0d0) then if (ilast == ig) then return end if go to 10 else ck = 1.0d0 ic = 0 90 continue icount = 0 do i=1, npar b(i) = d(i) + ck*t(i) if (b(i) == d(i)) then icount = icount + 1 end if end do ! if (icount >= npar) then if (ilast == ig) then return end if go to 10 else f1 = fun(fname, npar, b) ifn = ifn + 1 if (plevel > 1) then write(outstr,'(i4,1x,g12.6,(t17,10(1x,f12.6)):)') ifn, f1, (b(i),i=1, npar) end if if(ifn > maxfn) then ifault = 4 return else if (irupt > 0) then ifault = 5 return else if (ler) then ck = w * ck ic = ic+1 if (ic > icmax) then ifault = 3 return end if go to 90 ! else if (f1 >= f0 - d1*ck*toler) then ck = w * ck go to 90 else f0 = f1 call grad(fname, fun, npar, b, f0, g, t(np:), gradtl, ifault) if (ifault > 0) then return end if ig = ig + 1 ifn = ifn + npar if (ifn > maxfn) then ifault = 4 return end if ! d1 = 0.0d0 do i = 1, npar t(i) = ck*t(i) c(i) = g(i) - c(i) d1 = d1 + t(i)*c(i) end do ! if (d1 <= 0.0) then go to 10 end if ! d2 = 0.0d0 do i = 1, npar s = 0.0d0 do j = 1, npar s = s + h(i,j)*c(j) end do d(i) = s d2 = d2 + s*c(i) end do d2 = 1.0d0 + d2/d1 ! do i = 1, npar do j = 1, npar h(i,j) = h(i,j) - (t(i)*d(j) + d(i)*t(j) - d2*t(i)*t(j))/d1 end do end do end if end if end if end do end subroutine varmet ! ! Calculate approximate gradient ! subroutine grad(fname, fun, npar, b, f0, g, sa, er, ifault) use AS319 ! double precision :: fun character(len=*) :: fname integer, intent(in) :: npar double precision, dimension(:) :: b double precision, intent(in) :: f0 double precision, dimension(:), intent(out) :: g double precision, dimension(:), intent(out) :: sa double precision, intent(in) :: er integer, intent(out) :: ifault ! double precision :: h, f1 integer :: i, jc, jcmax interface function fun(fname, npar, parest) use AS319 use ibd_class character(len=*), intent(in) :: fname double precision :: fun integer, intent(in) :: npar double precision, dimension(:) :: parest end function fun end interface ! jcmax=npar - 2 jc = 0 ! do i = 1, npar h =(abs(b(i)) + sqrt(er)) * sqrt(er) sa(i) = b(i) b(i) = b(i) + h f1 = fun(fname, npar, b) b(i) = sa(i) ! if(ler) then f1 = f0 + h jc = jc + 1 end if ! g(i) = (f1 - f0)/h end do ! if(jc > jcmax) ifault = 2 return end subroutine grad ! ! varmet error messages ! subroutine vmerr(ier, maxfn) use outstream integer, intent(inout) :: ier integer, intent(inout) :: maxfn if (ier == 1) then write(outstr,'(/a/)') 'ERROR: Likelihood undefined at initial value.' else if (ier == 2) then write(outstr,'(/a/)') 'ERROR: Gradient undefined in too many dims.' else if (ier == 3) then write(outstr,'(/a/)') 'ERROR: Unable to find minimum.' else if (ier == 4) then write(outstr,'(/a,i4,a/)') 'ERROR: Exceeded ',maxfn,' evaluations.' else if (ier == 5) then write(outstr,'(/a/)') 'ERROR: Terminated by user prematurely.' end if return end subroutine vmerr end module varmet_optimizer ! ! Mike Powell's BOBYQA minimizer ! module bobyqa_optimizer integer :: bobyqa_liktyp = 1 ! controls likelihood function to be evaluated integer :: bobyqa_funeval = 0 ! number of function evaluations performed public :: bobyqa_liktyp, bobyqa contains subroutine calfun(n, x, f) use likelihoods integer, intent(in) :: n double precision, dimension(*), intent(in) :: x double precision, intent(out) :: f if (bobyqa_liktyp == 1) then f=mvnlik('mvnlik', n, x(1:n)) else f=mftlik('mftlik', n, x(1:n)) end if end subroutine calfun ! ! Converted using TO_F90 by Alan Miller ! Date: 2014-03-16 Time: 15:36:02 ! ! BOBYQA seeks the least value of a function of many variables, ! by applying a trust region method that forms quadratic models by ! interpolation. There is usually some freedom in the interpolation ! conditions, which is taken up by minimizing the Frobenius norm of ! the change to the second derivative of the model, beginning with the ! zero matrix. The values of the variables are constrained by upper and ! lower bounds. The arguments of the subroutine are as follows. ! ! N must be set to the number of variables and must be at least two. ! NPT is the number of interpolation conditions. Its value must be in ! the interval [N+2,(N+1)(N+2)/2]. Choices that exceed 2*N+1 are not ! recommended. ! Initial values of the variables must be set in X(1),X(2),...,X(N). They ! will be changed to the values that give the least calculated F. ! For I=1,2,...,N, XL(I) and XU(I) must provide the lower and upper ! bounds, respectively, on X(I). The construction of quadratic models ! requires XL(I) to be strictly less than XU(I) for each I. Further, ! the contribution to a model from changes to the I-th variable is ! damaged severely by rounding errors if XU(I)-XL(I) is too small. ! RHOBEG and RHOEND must be set to the initial and final values of a trust ! region radius, so both must be positive with RHOEND no greater than ! RHOBEG. Typically, RHOBEG should be about one tenth of the greatest ! expected change to a variable, while RHOEND should indicate the ! accuracy that is required in the final values of the variables. An ! error return occurs if any of the differences XU(I)-XL(I), I=1,...,N, ! is less than 2*RHOBEG. ! The value of IPRINT should be set to 0, 1, 2 or 3, which controls the ! amount of printing. Specifically, there is no output if IPRINT=0 and ! there is output only at the return if IPRINT=1. Otherwise, each new ! value of RHO is printed, with the best vector of variables so far and ! the corresponding value of the objective function. Further, each new ! value of F with its variables are output if IPRINT=3. ! MAXFUN must be set to an upper bound on the number of calls of CALFUN. ! The array W will be used for working space. Its length must be at least ! (NPT+5)*(NPT+N)+3*N*(N+5)/2. ! ! SUBROUTINE CALFUN (N,X,F) has to be provided by the user. It must set ! F to the value of the objective function for the current values of the ! variables X(1),X(2),...,X(N), which are generated automatically in a ! way that satisfies the bounds given in XL and XU. ! ! Return if the value of NPT is unacceptable. ! SUBROUTINE bobyqa (n, npt, x, xl, xu, rhobeg, rhoend, iprint, & maxfun, w) IMPLICIT double precision (a-h,o-z) INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: npt double precision, INTENT(IN OUT) :: x(*) double precision, INTENT(IN) :: xl(*) double precision, INTENT(IN) :: xu(*) double precision, INTENT(IN) :: rhobeg double precision, INTENT(IN OUT) :: rhoend INTEGER, INTENT(IN) :: iprint INTEGER, INTENT(IN) :: maxfun double precision, INTENT(IN OUT) :: w(*) np=n+1 IF (npt < n+2 .OR. npt > ((n+2)*np)/2) THEN PRINT 10 10 FORMAT (/4X,'Return from BOBYQA because NPT is not in', & ' the required interval') GO TO 40 END IF ! ! Partition the working space array, so that different parts of it can ! be treated separately during the calculation of BOBYQB. The partition ! requires the first (NPT+2)*(NPT+N)+3*N*(N+5)/2 elements of W plus the ! space that is taken by the last array in the argument list of BOBYQB. ! ndim=npt+n ixb=1 ixp=ixb+n ifv=ixp+n*npt ixo=ifv+npt igo=ixo+n ihq=igo+n ipq=ihq+(n*np)/2 ibmat=ipq+npt izmat=ibmat+ndim*n isl=izmat+npt*(npt-np) isu=isl+n ixn=isu+n ixa=ixn+n id=ixa+n ivl=id+n iw=ivl+ndim ! ! Return if there is insufficient space between the bounds. Modify the ! initial X if necessary in order to avoid conflicts between the bounds ! and the construction of the first quadratic model. The lower and upper ! bounds on moves from the updated X are set now, in the ISL and ISU ! partitions of W, in order to provide useful and exact information about ! components of X that become within distance RHOBEG from their bounds. ! zero=0.0D0 DO j=1,n temp=xu(j)-xl(j) IF (temp < rhobeg+rhobeg) THEN PRINT 20 20 FORMAT (/4X,'Return from BOBYQA because one of the', & ' differences XU(I)-XL(I)'/6X,' is less than 2*RHOBEG.') GO TO 40 END IF jsl=isl+j-1 jsu=jsl+n w(jsl)=xl(j)-x(j) w(jsu)=xu(j)-x(j) IF (w(jsl) >= -rhobeg) THEN IF (w(jsl) >= zero) THEN x(j)=xl(j) w(jsl)=zero w(jsu)=temp ELSE x(j)=xl(j)+rhobeg w(jsl)=-rhobeg w(jsu)=DMAX1(xu(j)-x(j),rhobeg) END IF ELSE IF (w(jsu) <= rhobeg) THEN IF (w(jsu) <= zero) THEN x(j)=xu(j) w(jsl)=-temp w(jsu)=zero ELSE x(j)=xu(j)-rhobeg w(jsl)=DMIN1(xl(j)-x(j),-rhobeg) w(jsu)=rhobeg END IF END IF END DO ! ! Make the call of BOBYQB. ! CALL bobyqb (n,npt,x,xl,xu,rhobeg,rhoend,iprint,maxfun,w(ixb), & w(ixp),w(ifv),w(ixo),w(igo),w(ihq),w(ipq),w(ibmat),w(izmat), & ndim,w(isl),w(isu),w(ixn),w(ixa),w(id),w(ivl),w(iw)) 40 RETURN END SUBROUTINE bobyqa ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% bobyqb.f %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% SUBROUTINE bobyqb (n,npt,x,xl,xu,rhobeg,rhoend,iprint, & maxfun,xbase,xpt,fval,xopt,gopt,hq,pq,bmat,zmat,ndim, & sl,su,xnew,xalt,d,vlag,w) IMPLICIT double precision (a-h,o-z) INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: npt double precision, INTENT(OUT) :: x(*) double precision, INTENT(IN) :: xl(*) double precision, INTENT(IN) :: xu(*) double precision, INTENT(IN) :: rhobeg double precision, INTENT(IN) :: rhoend INTEGER, INTENT(IN) :: iprint INTEGER, INTENT(IN) :: maxfun double precision, INTENT(OUT) :: xbase(*) double precision, INTENT(IN OUT) :: xpt(npt,*) double precision, INTENT(IN OUT) :: fval(*) double precision, INTENT(OUT) :: xopt(*) double precision, INTENT(OUT) :: gopt(*) double precision, INTENT(IN OUT) :: hq(*) double precision, INTENT(IN OUT) :: pq(*) double precision, INTENT(IN OUT) :: bmat(ndim,*) double precision, INTENT(IN OUT) :: zmat(npt,*) INTEGER, INTENT(IN OUT) :: ndim double precision, INTENT(IN OUT) :: sl(*) double precision, INTENT(IN OUT) :: su(*) double precision, INTENT(OUT) :: xnew(*) double precision, INTENT(IN OUT) :: xalt(*) double precision, INTENT(OUT) :: d(*) double precision, INTENT(OUT) :: vlag(*) double precision, INTENT(IN OUT) :: w(*) ! ! The arguments N, NPT, X, XL, XU, RHOBEG, RHOEND, IPRINT and MAXFUN ! are identical to the corresponding arguments in SUBROUTINE BOBYQA. ! XBASE holds a shift of origin that should reduce the contributions ! from rounding errors to values of the model and Lagrange functions. ! XPT is a two-dimensional array that holds the coordinates of the ! interpolation points relative to XBASE. ! FVAL holds the values of F at the interpolation points. ! XOPT is set to the displacement from XBASE of the trust region centre. ! GOPT holds the gradient of the quadratic model at XBASE+XOPT. ! HQ holds the explicit second derivatives of the quadratic model. ! PQ contains the parameters of the implicit second derivatives of the ! quadratic model. ! BMAT holds the last N columns of H. ! ZMAT holds the factorization of the leading NPT by NPT submatrix of H, ! this factorization being ZMAT times ZMAT^T, which provides both the ! correct rank and positive semi-definiteness. ! NDIM is the first dimension of BMAT and has the value NPT+N. ! SL and SU hold the differences XL-XBASE and XU-XBASE, respectively. ! All the components of every XOPT are going to satisfy the bounds ! SL(I) .LEQ. XOPT(I) .LEQ. SU(I), with appropriate equalities when ! XOPT is on a constraint boundary. ! XNEW is chosen by SUBROUTINE TRSBOX or ALTMOV. Usually XBASE+XNEW is the ! vector of variables for the next call of CALFUN. XNEW also satisfies ! the SL and SU constraints in the way that has just been mentioned. ! XALT is an alternative to XNEW, chosen by ALTMOV, that may replace XNEW ! in order to increase the denominator in the updating of UPDATE. ! D is reserved for a trial step from XOPT, which is usually XNEW-XOPT. ! VLAG contains the values of the Lagrange functions at a new point X. ! They are part of a product that requires VLAG to be of length NDIM. ! W is a one-dimensional array that is used for working space. Its length ! must be at least 3*NDIM = 3*(NPT+N). ! ! Set some constants. ! half=0.5D0 one=1.0D0 ten=10.0D0 tenth=0.1D0 two=2.0D0 zero=0.0D0 np=n+1 nptm=npt-np nh=(n*np)/2 ! ! The call of PRELIM sets the elements of XBASE, XPT, FVAL, GOPT, HQ, PQ, ! BMAT and ZMAT for the first iteration, with the corresponding values of ! of NF and KOPT, which are the number of calls of CALFUN so far and the ! index of the interpolation point at the trust region centre. Then the ! initial XOPT is set too. The branch to label 720 occurs if MAXFUN is ! less than NPT. GOPT will be updated if KOPT is different from KBASE. ! CALL prelim (n,npt,x,xl,xu,rhobeg,iprint,maxfun,xbase,xpt, & fval,gopt,hq,pq,bmat,zmat,ndim,sl,su,nf,kopt) xoptsq=zero DO i=1,n xopt(i)=xpt(kopt,i) xoptsq=xoptsq+xopt(i)**2 END DO fsave=fval(1) IF (nf < npt) THEN IF (iprint > 0) PRINT 390 GO TO 720 END IF kbase=1 ! ! Complete the settings that are required for the iterative procedure. ! rho=rhobeg delta=rho nresc=nf ntrits=0 diffa=zero diffb=zero itest=0 nfsav=nf ! ! Update GOPT if necessary before the first iteration and after each ! call of RESCUE that makes a call of CALFUN. ! 20 IF (kopt /= kbase) THEN ih=0 DO j=1,n DO i=1,j ih=ih+1 IF (i < j) gopt(j)=gopt(j)+hq(ih)*xopt(i) gopt(i)=gopt(i)+hq(ih)*xopt(j) END DO END DO IF (nf > npt) THEN DO k=1,npt temp=zero DO j=1,n temp=temp+xpt(k,j)*xopt(j) END DO temp=pq(k)*temp DO i=1,n gopt(i)=gopt(i)+temp*xpt(k,i) END DO END DO END IF END IF ! ! Generate the next point in the trust region that provides a small value ! of the quadratic model subject to the constraints on the variables. ! The integer NTRITS is set to the number "trust region" iterations that ! have occurred since the last "alternative" iteration. If the length ! of XNEW-XOPT is less than HALF*RHO, however, then there is a branch to ! label 650 or 680 with NTRITS=-1, instead of calculating F at XNEW. ! 60 CALL trsbox (n,npt,xpt,xopt,gopt,hq,pq,sl,su,delta,xnew,d, & w,w(np),w(np+n),w(np+2*n),w(np+3*n),dsq,crvmin) dnorm=DMIN1(delta,DSQRT(dsq)) IF (dnorm < half*rho) THEN ntrits=-1 distsq=(ten*rho)**2 IF (nf <= nfsav+2) GO TO 650 ! ! The following choice between labels 650 and 680 depends on whether or ! not our work with the current RHO seems to be complete. Either RHO is ! decreased or termination occurs if the errors in the quadratic model at ! the last three interpolation points compare favourably with predictions ! of likely improvements to the model within distance HALF*RHO of XOPT. ! errbig=DMAX1(diffa,diffb,diffc) frhosq=0.125D0*rho*rho IF (crvmin > zero .AND. errbig > frhosq*crvmin) GO TO 650 bdtol=errbig/rho DO j=1,n bdtest=bdtol IF (xnew(j) == sl(j)) bdtest=w(j) IF (xnew(j) == su(j)) bdtest=-w(j) IF (bdtest < bdtol) THEN curv=hq((j+j*j)/2) DO k=1,npt curv=curv+pq(k)*xpt(k,j)**2 END DO bdtest=bdtest+half*curv*rho IF (bdtest < bdtol) GO TO 650 END IF END DO GO TO 680 END IF ntrits=ntrits+1 ! ! Severe cancellation is likely to occur if XOPT is too far from XBASE. ! If the following test holds, then XBASE is shifted so that XOPT becomes ! zero. The appropriate changes are made to BMAT and to the second ! derivatives of the current model, beginning with the changes to BMAT ! that do not depend on ZMAT. VLAG is used temporarily for working space. ! 90 IF (dsq <= 1.0D-3*xoptsq) THEN fracsq=0.25D0*xoptsq sumpq=zero DO k=1,npt sumpq=sumpq+pq(k) sum=-half*xoptsq DO i=1,n sum=sum+xpt(k,i)*xopt(i) END DO w(npt+k)=sum temp=fracsq-half*sum DO i=1,n w(i)=bmat(k,i) vlag(i)=sum*xpt(k,i)+temp*xopt(i) ip=npt+i DO j=1,i bmat(ip,j)=bmat(ip,j)+w(i)*vlag(j)+vlag(i)*w(j) END DO END DO END DO ! ! Then the revisions of BMAT that depend on ZMAT are calculated. ! DO jj=1,nptm sumz=zero sumw=zero DO k=1,npt sumz=sumz+zmat(k,jj) vlag(k)=w(npt+k)*zmat(k,jj) sumw=sumw+vlag(k) END DO DO j=1,n sum=(fracsq*sumz-half*sumw)*xopt(j) DO k=1,npt sum=sum+vlag(k)*xpt(k,j) END DO w(j)=sum DO k=1,npt bmat(k,j)=bmat(k,j)+sum*zmat(k,jj) END DO END DO DO i=1,n ip=i+npt temp=w(i) DO j=1,i bmat(ip,j)=bmat(ip,j)+temp*w(j) END DO END DO END DO ! ! The following instructions complete the shift, including the changes ! to the second derivative parameters of the quadratic model. ! ih=0 DO j=1,n w(j)=-half*sumpq*xopt(j) DO k=1,npt w(j)=w(j)+pq(k)*xpt(k,j) xpt(k,j)=xpt(k,j)-xopt(j) END DO DO i=1,j ih=ih+1 hq(ih)=hq(ih)+w(i)*xopt(j)+xopt(i)*w(j) bmat(npt+i,j)=bmat(npt+j,i) END DO END DO DO i=1,n xbase(i)=xbase(i)+xopt(i) xnew(i)=xnew(i)-xopt(i) sl(i)=sl(i)-xopt(i) su(i)=su(i)-xopt(i) xopt(i)=zero END DO xoptsq=zero END IF IF (ntrits == 0) GO TO 210 GO TO 230 ! ! XBASE is also moved to XOPT by a call of RESCUE. This calculation is ! more expensive than the previous shift, because new matrices BMAT and ! ZMAT are generated from scratch, which may include the replacement of ! interpolation points whose positions seem to be causing near linear ! dependence in the interpolation conditions. Therefore RESCUE is called ! only if rounding errors have reduced by at least a factor of two the ! denominator of the formula for updating the H matrix. It provides a ! useful safeguard, but is not invoked in most applications of BOBYQA. ! 190 nfsav=nf kbase=kopt CALL rescue (n,npt,xl,xu,iprint,maxfun,xbase,xpt,fval, & xopt,gopt,hq,pq,bmat,zmat,ndim,sl,su,nf,delta,kopt, vlag,w,w(n+np),w(ndim+np)) ! ! XOPT is updated now in case the branch below to label 720 is taken. ! Any updating of GOPT occurs after the branch below to label 20, which ! leads to a trust region iteration as does the branch to label 60. ! xoptsq=zero IF (kopt /= kbase) THEN DO i=1,n xopt(i)=xpt(kopt,i) xoptsq=xoptsq+xopt(i)**2 END DO END IF IF (nf < 0) THEN nf=maxfun IF (iprint > 0) PRINT 390 GO TO 720 END IF nresc=nf IF (nfsav < nf) THEN nfsav=nf GO TO 20 END IF IF (ntrits > 0) GO TO 60 ! ! Pick two alternative vectors of variables, relative to XBASE, that ! are suitable as new positions of the KNEW-th interpolation point. ! Firstly, XNEW is set to the point on a line through XOPT and another ! interpolation point that minimizes the predicted value of the next ! denominator, subject to ||XNEW - XOPT|| .LEQ. ADELT and to the SL ! and SU bounds. Secondly, XALT is set to the best feasible point on ! a constrained version of the Cauchy step of the KNEW-th Lagrange ! function, the corresponding value of the square of this function ! being returned in CAUCHY. The choice between these alternatives is ! going to be made when the denominator is calculated. ! 210 CALL altmov (n,npt,xpt,xopt,bmat,zmat,ndim,sl,su,kopt, & knew,adelt,xnew,xalt,alpha,cauchy,w,w(np),w(ndim+1)) DO i=1,n d(i)=xnew(i)-xopt(i) END DO ! ! Calculate VLAG and BETA for the current choice of D. The scalar ! product of D with XPT(K,.) is going to be held in W(NPT+K) for ! use when VQUAD is calculated. ! 230 DO k=1,npt suma=zero sumb=zero sum=zero DO j=1,n suma=suma+xpt(k,j)*d(j) sumb=sumb+xpt(k,j)*xopt(j) sum=sum+bmat(k,j)*d(j) END DO w(k)=suma*(half*suma+sumb) vlag(k)=sum w(npt+k)=suma END DO beta=zero DO jj=1,nptm sum=zero DO k=1,npt sum=sum+zmat(k,jj)*w(k) END DO beta=beta-sum*sum DO k=1,npt vlag(k)=vlag(k)+sum*zmat(k,jj) END DO END DO dsq=zero bsum=zero dx=zero DO j=1,n dsq=dsq+d(j)**2 sum=zero DO k=1,npt sum=sum+w(k)*bmat(k,j) END DO bsum=bsum+sum*d(j) jp=npt+j DO i=1,n sum=sum+bmat(jp,i)*d(i) END DO vlag(jp)=sum bsum=bsum+sum*d(j) dx=dx+d(j)*xopt(j) END DO beta=dx*dx+dsq*(xoptsq+dx+dx+half*dsq)+beta-bsum vlag(kopt)=vlag(kopt)+one ! ! If NTRITS is zero, the denominator may be increased by replacing ! the step D of ALTMOV by a Cauchy step. Then RESCUE may be called if ! rounding errors have damaged the chosen denominator. ! IF (ntrits == 0) THEN denom=vlag(knew)**2+alpha*beta IF (denom < cauchy .AND. cauchy > zero) THEN DO i=1,n xnew(i)=xalt(i) d(i)=xnew(i)-xopt(i) END DO cauchy=zero GO TO 230 END IF IF (denom <= half*vlag(knew)**2) THEN IF (nf > nresc) GO TO 190 IF (iprint > 0) PRINT 320 320 FORMAT (/5X,'Return from BOBYQA because of much', & ' cancellation in a denominator.') GO TO 720 END IF ! ! Alternatively, if NTRITS is positive, then set KNEW to the index of ! the next interpolation point to be deleted to make room for a trust ! region step. Again RESCUE may be called if rounding errors have damaged ! the chosen denominator, which is the reason for attempting to select ! KNEW before calculating the next value of the objective function. ! ELSE delsq=delta*delta scaden=zero biglsq=zero knew=0 DO k=1,npt IF (k == kopt) CYCLE hdiag=zero DO jj=1,nptm hdiag=hdiag+zmat(k,jj)**2 END DO den=beta*hdiag+vlag(k)**2 distsq=zero DO j=1,n distsq=distsq+(xpt(k,j)-xopt(j))**2 END DO temp=DMAX1(one,(distsq/delsq)**2) IF (temp*den > scaden) THEN scaden=temp*den knew=k denom=den END IF biglsq=DMAX1(biglsq,temp*vlag(k)**2) END DO IF (scaden <= half*biglsq) THEN IF (nf > nresc) GO TO 190 IF (iprint > 0) PRINT 320 GO TO 720 END IF END IF ! ! Put the variables for the next calculation of the objective function ! in XNEW, with any adjustments for the bounds. ! ! Calculate the value of the objective function at XBASE+XNEW, unless ! the limit on the number of calculations of F has been reached. ! 360 DO i=1,n x(i)=DMIN1(DMAX1(xl(i),xbase(i)+xnew(i)),xu(i)) IF (xnew(i) == sl(i)) x(i)=xl(i) IF (xnew(i) == su(i)) x(i)=xu(i) END DO IF (nf >= maxfun) THEN IF (iprint > 0) PRINT 390 390 FORMAT (/4X,'Return from BOBYQA because CALFUN has been', & ' called MAXFUN times.') GO TO 720 END IF nf=nf+1 CALL calfun (n,x,f) IF (iprint == 3) THEN PRINT 400, nf,f,(x(i),i=1,n) 400 FORMAT (/4X,'Function number',i6,' F =',1PD18.10, & ' The corresponding X is:'/(2X,5D15.6)) END IF IF (ntrits == -1) THEN fsave=f GO TO 720 END IF ! ! Use the quadratic model to predict the change in F due to the step D, ! and set DIFF to the error of this prediction. ! fopt=fval(kopt) vquad=zero ih=0 DO j=1,n vquad=vquad+d(j)*gopt(j) DO i=1,j ih=ih+1 temp=d(i)*d(j) IF (i == j) temp=half*temp vquad=vquad+hq(ih)*temp END DO END DO DO k=1,npt vquad=vquad+half*pq(k)*w(npt+k)**2 END DO diff=f-fopt-vquad diffc=diffb diffb=diffa diffa=DABS(diff) IF (dnorm > rho) nfsav=nf ! ! Pick the next value of DELTA after a trust region step. ! IF (ntrits > 0) THEN IF (vquad >= zero) THEN IF (iprint > 0) PRINT 430 430 FORMAT (/4X,'Return from BOBYQA because a trust', & ' region step has failed to reduce Q.') GO TO 720 END IF ratio=(f-fopt)/vquad IF (ratio <= tenth) THEN delta=DMIN1(half*delta,dnorm) ELSE IF (ratio <= 0.7D0) THEN delta=DMAX1(half*delta,dnorm) ELSE delta=DMAX1(half*delta,dnorm+dnorm) END IF IF (delta <= 1.5D0*rho) delta=rho ! ! Recalculate KNEW and DENOM if the new F is less than FOPT. ! IF (f < fopt) THEN ksav=knew densav=denom delsq=delta*delta scaden=zero biglsq=zero knew=0 DO k=1,npt hdiag=zero DO jj=1,nptm hdiag=hdiag+zmat(k,jj)**2 END DO den=beta*hdiag+vlag(k)**2 distsq=zero DO j=1,n distsq=distsq+(xpt(k,j)-xnew(j))**2 END DO temp=DMAX1(one,(distsq/delsq)**2) IF (temp*den > scaden) THEN scaden=temp*den knew=k denom=den END IF biglsq=DMAX1(biglsq,temp*vlag(k)**2) END DO IF (scaden <= half*biglsq) THEN knew=ksav denom=densav END IF END IF END IF ! ! Update BMAT and ZMAT, so that the KNEW-th interpolation point can be ! moved. Also update the second derivative terms of the model. ! CALL update (n,npt,bmat,zmat,ndim,vlag,beta,denom,knew,w) ih=0 pqold=pq(knew) pq(knew)=zero DO i=1,n temp=pqold*xpt(knew,i) DO j=1,i ih=ih+1 hq(ih)=hq(ih)+temp*xpt(knew,j) END DO END DO DO jj=1,nptm temp=diff*zmat(knew,jj) DO k=1,npt pq(k)=pq(k)+temp*zmat(k,jj) END DO END DO ! ! Include the new interpolation point, and make the changes to GOPT at ! the old XOPT that are caused by the updating of the quadratic model. ! fval(knew)=f DO i=1,n xpt(knew,i)=xnew(i) w(i)=bmat(knew,i) END DO DO k=1,npt suma=zero DO jj=1,nptm suma=suma+zmat(knew,jj)*zmat(k,jj) END DO sumb=zero DO j=1,n sumb=sumb+xpt(k,j)*xopt(j) END DO temp=suma*sumb DO i=1,n w(i)=w(i)+temp*xpt(k,i) END DO END DO DO i=1,n gopt(i)=gopt(i)+diff*w(i) END DO ! ! Update XOPT, GOPT and KOPT if the new calculated F is less than FOPT. ! IF (f < fopt) THEN kopt=knew xoptsq=zero ih=0 DO j=1,n xopt(j)=xnew(j) xoptsq=xoptsq+xopt(j)**2 DO i=1,j ih=ih+1 IF (i < j) gopt(j)=gopt(j)+hq(ih)*d(i) gopt(i)=gopt(i)+hq(ih)*d(j) END DO END DO DO k=1,npt temp=zero DO j=1,n temp=temp+xpt(k,j)*d(j) END DO temp=pq(k)*temp DO i=1,n gopt(i)=gopt(i)+temp*xpt(k,i) END DO END DO END IF ! ! Calculate the parameters of the least Frobenius norm interpolant to ! the current data, the gradient of this interpolant at XOPT being put ! into VLAG(NPT+I), I=1,2,...,N. ! IF (ntrits > 0) THEN DO k=1,npt vlag(k)=fval(k)-fval(kopt) w(k)=zero END DO DO j=1,nptm sum=zero DO k=1,npt sum=sum+zmat(k,j)*vlag(k) END DO DO k=1,npt w(k)=w(k)+sum*zmat(k,j) END DO END DO DO k=1,npt sum=zero DO j=1,n sum=sum+xpt(k,j)*xopt(j) END DO w(k+npt)=w(k) w(k)=sum*w(k) END DO gqsq=zero gisq=zero DO i=1,n sum=zero DO k=1,npt sum=sum+bmat(k,i)*vlag(k)+xpt(k,i)*w(k) END DO IF (xopt(i) == sl(i)) THEN gqsq=gqsq+DMIN1(zero,gopt(i))**2 gisq=gisq+DMIN1(zero,sum)**2 ELSE IF (xopt(i) == su(i)) THEN gqsq=gqsq+DMAX1(zero,gopt(i))**2 gisq=gisq+DMAX1(zero,sum)**2 ELSE gqsq=gqsq+gopt(i)**2 gisq=gisq+sum*sum END IF vlag(npt+i)=sum END DO ! ! Test whether to replace the new quadratic model by the least Frobenius ! norm interpolant, making the replacement if the test is satisfied. ! itest=itest+1 IF (gqsq < ten*gisq) itest=0 IF (itest >= 3) THEN DO i=1,MAX0(npt,nh) IF (i <= n) gopt(i)=vlag(npt+i) IF (i <= npt) pq(i)=w(npt+i) IF (i <= nh) hq(i)=zero itest=0 END DO END IF END IF ! ! If a trust region step has provided a sufficient decrease in F, then ! branch for another trust region calculation. The case NTRITS=0 occurs ! when the new interpolation point was reached by an alternative step. ! IF (ntrits == 0) GO TO 60 IF (f <= fopt+tenth*vquad) GO TO 60 ! ! Alternatively, find out if the interpolation points are close enough ! to the best point so far. ! distsq=DMAX1((two*delta)**2,(ten*rho)**2) 650 knew=0 DO k=1,npt sum=zero DO j=1,n sum=sum+(xpt(k,j)-xopt(j))**2 END DO IF (sum > distsq) THEN knew=k distsq=sum END IF END DO ! ! If KNEW is positive, then ALTMOV finds alternative new positions for ! the KNEW-th interpolation point within distance ADELT of XOPT. It is ! reached via label 90. Otherwise, there is a branch to label 60 for ! another trust region iteration, unless the calculations with the ! current RHO are complete. ! IF (knew > 0) THEN dist=DSQRT(distsq) IF (ntrits == -1) THEN delta=DMIN1(tenth*delta,half*dist) IF (delta <= 1.5D0*rho) delta=rho END IF ntrits=0 adelt=DMAX1(DMIN1(tenth*dist,delta),rho) dsq=adelt*adelt GO TO 90 END IF IF (ntrits == -1) GO TO 680 IF (ratio > zero) GO TO 60 IF (DMAX1(delta,dnorm) > rho) GO TO 60 ! ! The calculations with the current value of RHO are complete. Pick the ! next values of RHO and DELTA. ! 680 IF (rho > rhoend) THEN delta=half*rho ratio=rho/rhoend IF (ratio <= 16.0D0) THEN rho=rhoend ELSE IF (ratio <= 250.0D0) THEN rho=DSQRT(ratio)*rhoend ELSE rho=tenth*rho END IF delta=DMAX1(delta,rho) IF (iprint >= 2) THEN IF (iprint >= 3) PRINT 690 690 FORMAT (5X) PRINT 700, rho,nf 700 FORMAT (/4X,'New RHO =',1PD11.4,5X,'Number of', & ' function values =',i6) PRINT 710, fval(kopt),(xbase(i)+xopt(i),i=1,n) 710 FORMAT (4X,'Least value of F =',1PD23.15,9X, & 'The corresponding X is:'/(2X,5D15.6)) END IF ntrits=0 nfsav=nf GO TO 60 END IF ! ! Return from the calculation, after another Newton-Raphson step, if ! it is too short to have been tried before. ! IF (ntrits == -1) GO TO 360 720 IF (fval(kopt) <= fsave) THEN DO i=1,n x(i)=DMIN1(DMAX1(xl(i),xbase(i)+xopt(i)),xu(i)) IF (xopt(i) == sl(i)) x(i)=xl(i) IF (xopt(i) == su(i)) x(i)=xu(i) END DO f=fval(kopt) END IF IF (iprint >= 1) THEN PRINT 740, nf 740 FORMAT (/4X,'At the return from BOBYQA',5X, & 'Number of function values =',i6) PRINT 710, f,(x(i),i=1,n) END IF bobyqa_funeval=nf RETURN END SUBROUTINE bobyqb ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% altmov.f %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% SUBROUTINE altmov (n,npt,xpt,xopt,bmat,zmat,ndim,sl,su,kopt, & knew,adelt,xnew,xalt,alpha,cauchy,glag,hcol,w) IMPLICIT double precision (a-h,o-z) INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: npt double precision, INTENT(IN) :: xpt(npt,*) double precision, INTENT(IN) :: xopt(*) double precision, INTENT(IN) :: bmat(ndim,*) double precision, INTENT(IN) :: zmat(npt,*) INTEGER, INTENT(IN OUT) :: ndim double precision, INTENT(IN) :: sl(*) double precision, INTENT(IN) :: su(*) INTEGER, INTENT(IN OUT) :: kopt INTEGER, INTENT(IN OUT) :: knew double precision, INTENT(IN) :: adelt double precision, INTENT(OUT) :: xnew(*) double precision, INTENT(OUT) :: xalt(*) double precision, INTENT(OUT) :: alpha double precision, INTENT(OUT) :: cauchy double precision, INTENT(OUT) :: glag(*) double precision, INTENT(OUT) :: hcol(*) double precision, INTENT(OUT) :: w(*) ! ! The arguments N, NPT, XPT, XOPT, BMAT, ZMAT, NDIM, SL and SU all have ! the same meanings as the corresponding arguments of BOBYQB. ! KOPT is the index of the optimal interpolation point. ! KNEW is the index of the interpolation point that is going to be moved. ! ADELT is the current trust region bound. ! XNEW will be set to a suitable new position for the interpolation point ! XPT(KNEW,.). Specifically, it satisfies the SL, SU and trust region ! bounds and it should provide a large denominator in the next call of ! UPDATE. The step XNEW-XOPT from XOPT is restricted to moves along the ! straight lines through XOPT and another interpolation point. ! XALT also provides a large value of the modulus of the KNEW-th Lagrange ! function subject to the constraints that have been mentioned, its main ! difference from XNEW being that XALT-XOPT is a constrained version of ! the Cauchy step within the trust region. An exception is that XALT is ! not calculated if all components of GLAG (see below) are zero. ! ALPHA will be set to the KNEW-th diagonal element of the H matrix. ! CAUCHY will be set to the square of the KNEW-th Lagrange function at ! the step XALT-XOPT from XOPT for the vector XALT that is returned, ! except that CAUCHY is set to zero if XALT is not calculated. ! GLAG is a working space vector of length N for the gradient of the ! KNEW-th Lagrange function at XOPT. ! HCOL is a working space vector of length NPT for the second derivative ! coefficients of the KNEW-th Lagrange function. ! W is a working space vector of length 2N that is going to hold the ! constrained Cauchy step from XOPT of the Lagrange function, followed ! by the downhill version of XALT when the uphill step is calculated. ! ! Set the first NPT components of W to the leading elements of the ! KNEW-th column of the H matrix. ! half=0.5D0 one=1.0D0 zero=0.0D0 const=one+DSQRT(2.0D0) DO k=1,npt hcol(k)=zero END DO DO j=1,npt-n-1 temp=zmat(knew,j) DO k=1,npt hcol(k)=hcol(k)+temp*zmat(k,j) END DO END DO alpha=hcol(knew) ha=half*alpha ! ! Calculate the gradient of the KNEW-th Lagrange function at XOPT. ! DO i=1,n glag(i)=bmat(knew,i) END DO DO k=1,npt temp=zero DO j=1,n temp=temp+xpt(k,j)*xopt(j) END DO temp=hcol(k)*temp DO i=1,n glag(i)=glag(i)+temp*xpt(k,i) END DO END DO ! ! Search for a large denominator along the straight lines through XOPT ! and another interpolation point. SLBD and SUBD will be lower and upper ! bounds on the step along each of these lines in turn. PREDSQ will be ! set to the square of the predicted denominator for each line. PRESAV ! will be set to the largest admissible value of PREDSQ that occurs. ! presav=zero DO k=1,npt IF (k == kopt) CYCLE dderiv=zero distsq=zero DO i=1,n temp=xpt(k,i)-xopt(i) dderiv=dderiv+glag(i)*temp distsq=distsq+temp*temp END DO subd=adelt/DSQRT(distsq) slbd=-subd ilbd=0 iubd=0 sumin=DMIN1(one,subd) ! ! Revise SLBD and SUBD if necessary because of the bounds in SL and SU. ! DO i=1,n temp=xpt(k,i)-xopt(i) IF (temp > zero) THEN IF (slbd*temp < sl(i)-xopt(i)) THEN slbd=(sl(i)-xopt(i))/temp ilbd=-i END IF IF (subd*temp > su(i)-xopt(i)) THEN subd=DMAX1(sumin,(su(i)-xopt(i))/temp) iubd=i END IF ELSE IF (temp < zero) THEN IF (slbd*temp > su(i)-xopt(i)) THEN slbd=(su(i)-xopt(i))/temp ilbd=i END IF IF (subd*temp < sl(i)-xopt(i)) THEN subd=DMAX1(sumin,(sl(i)-xopt(i))/temp) iubd=-i END IF END IF END DO ! ! Seek a large modulus of the KNEW-th Lagrange function when the index ! of the other interpolation point on the line through XOPT is KNEW. ! IF (k == knew) THEN diff=dderiv-one step=slbd vlag=slbd*(dderiv-slbd*diff) isbd=ilbd temp=subd*(dderiv-subd*diff) IF (DABS(temp) > DABS(vlag)) THEN step=subd vlag=temp isbd=iubd END IF tempd=half*dderiv tempa=tempd-diff*slbd tempb=tempd-diff*subd IF (tempa*tempb < zero) THEN temp=tempd*tempd/diff IF (DABS(temp) > DABS(vlag)) THEN step=tempd/diff vlag=temp isbd=0 END IF END IF ! ! Search along each of the other lines through XOPT and another point. ! ELSE step=slbd vlag=slbd*(one-slbd) isbd=ilbd temp=subd*(one-subd) IF (DABS(temp) > DABS(vlag)) THEN step=subd vlag=temp isbd=iubd END IF IF (subd > half) THEN IF (DABS(vlag) < 0.25D0) THEN step=half vlag=0.25D0 isbd=0 END IF END IF vlag=vlag*dderiv END IF ! ! Calculate PREDSQ for the current line search and maintain PRESAV. ! temp=step*(one-step)*distsq predsq=vlag*vlag*(vlag*vlag+ha*temp*temp) IF (predsq > presav) THEN presav=predsq ksav=k stpsav=step ibdsav=isbd END IF END DO ! ! Construct XNEW in a way that satisfies the bound constraints exactly. ! DO i=1,n temp=xopt(i)+stpsav*(xpt(ksav,i)-xopt(i)) xnew(i)=DMAX1(sl(i),DMIN1(su(i),temp)) END DO IF (ibdsav < 0) xnew(-ibdsav)=sl(-ibdsav) IF (ibdsav > 0) xnew(ibdsav)=su(ibdsav) ! ! Prepare for the iterative method that assembles the constrained Cauchy ! step in W. The sum of squares of the fixed components of W is formed in ! WFIXSQ, and the free components of W are set to BIGSTP. ! bigstp=adelt+adelt iflag=0 100 wfixsq=zero ggfree=zero DO i=1,n w(i)=zero tempa=DMIN1(xopt(i)-sl(i),glag(i)) tempb=DMAX1(xopt(i)-su(i),glag(i)) IF (tempa > zero .OR. tempb < zero) THEN w(i)=bigstp ggfree=ggfree+glag(i)**2 END IF END DO IF (ggfree == zero) THEN cauchy=zero GO TO 200 END IF ! ! Investigate whether more components of W can be fixed. ! 120 temp=adelt*adelt-wfixsq IF (temp > zero) THEN wsqsav=wfixsq step=DSQRT(temp/ggfree) ggfree=zero DO i=1,n IF (w(i) == bigstp) THEN temp=xopt(i)-step*glag(i) IF (temp <= sl(i)) THEN w(i)=sl(i)-xopt(i) wfixsq=wfixsq+w(i)**2 ELSE IF (temp >= su(i)) THEN w(i)=su(i)-xopt(i) wfixsq=wfixsq+w(i)**2 ELSE ggfree=ggfree+glag(i)**2 END IF END IF END DO IF (wfixsq > wsqsav .AND. ggfree > zero) GO TO 120 END IF ! ! Set the remaining free components of W and all components of XALT, ! except that W may be scaled later. ! gw=zero DO i=1,n IF (w(i) == bigstp) THEN w(i)=-step*glag(i) xalt(i)=DMAX1(sl(i),DMIN1(su(i),xopt(i)+w(i))) ELSE IF (w(i) == zero) THEN xalt(i)=xopt(i) ELSE IF (glag(i) > zero) THEN xalt(i)=sl(i) ELSE xalt(i)=su(i) END IF gw=gw+glag(i)*w(i) END DO ! ! Set CURV to the curvature of the KNEW-th Lagrange function along W. ! Scale W by a factor less than one if that can reduce the modulus of ! the Lagrange function at XOPT+W. Set CAUCHY to the final value of ! the square of this function. ! curv=zero DO k=1,npt temp=zero DO j=1,n temp=temp+xpt(k,j)*w(j) END DO curv=curv+hcol(k)*temp*temp END DO IF (iflag == 1) curv=-curv IF (curv > -gw .AND. curv < -const*gw) THEN scale=-gw/curv DO i=1,n temp=xopt(i)+scale*w(i) xalt(i)=DMAX1(sl(i),DMIN1(su(i),temp)) END DO cauchy=(half*gw*scale)**2 ELSE cauchy=(gw+half*curv)**2 END IF ! ! If IFLAG is zero, then XALT is calculated as before after reversing ! the sign of GLAG. Thus two XALT vectors become available. The one that ! is chosen is the one that gives the larger value of CAUCHY. ! IF (iflag == 0) THEN DO i=1,n glag(i)=-glag(i) w(n+i)=xalt(i) END DO csave=cauchy iflag=1 GO TO 100 END IF IF (csave > cauchy) THEN DO i=1,n xalt(i)=w(n+i) END DO cauchy=csave END IF 200 RETURN END SUBROUTINE altmov ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% prelim.f %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% SUBROUTINE prelim (n,npt,x,xl,xu,rhobeg,iprint,maxfun,xbase, & xpt,fval,gopt,hq,pq,bmat,zmat,ndim,sl,su,nf,kopt) IMPLICIT double precision (a-h,o-z) INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: npt double precision, INTENT(IN OUT) :: x(*) double precision, INTENT(IN) :: xl(*) double precision, INTENT(IN) :: xu(*) double precision, INTENT(IN) :: rhobeg INTEGER, INTENT(IN) :: iprint INTEGER, INTENT(IN) :: maxfun double precision, INTENT(OUT) :: xbase(*) double precision, INTENT(OUT) :: xpt(npt,*) double precision, INTENT(OUT) :: fval(*) double precision, INTENT(OUT) :: gopt(*) double precision, INTENT(OUT) :: hq(*) double precision, INTENT(OUT) :: pq(*) double precision, INTENT(OUT) :: bmat(ndim,*) double precision, INTENT(IN OUT) :: zmat(npt,*) INTEGER, INTENT(IN) :: ndim double precision, INTENT(IN) :: sl(*) double precision, INTENT(IN) :: su(*) INTEGER, INTENT(OUT) :: nf INTEGER, INTENT(OUT) :: kopt ! ! The arguments N, NPT, X, XL, XU, RHOBEG, IPRINT and MAXFUN are the ! same as the corresponding arguments in SUBROUTINE BOBYQA. ! The arguments XBASE, XPT, FVAL, HQ, PQ, BMAT, ZMAT, NDIM, SL and SU ! are the same as the corresponding arguments in BOBYQB, the elements ! of SL and SU being set in BOBYQA. ! GOPT is usually the gradient of the quadratic model at XOPT+XBASE, but ! it is set by PRELIM to the gradient of the quadratic model at XBASE. ! If XOPT is nonzero, BOBYQB will change it to its usual value later. ! NF is maintaned as the number of calls of CALFUN so far. ! KOPT will be such that the least calculated value of F so far is at ! the point XPT(KOPT,.)+XBASE in the space of the variables. ! ! SUBROUTINE PRELIM sets the elements of XBASE, XPT, FVAL, GOPT, HQ, PQ, ! BMAT and ZMAT for the first iteration, and it maintains the values of ! NF and KOPT. The vector X is also changed by PRELIM. ! ! Set some constants. ! half=0.5D0 one=1.0D0 two=2.0D0 zero=0.0D0 rhosq=rhobeg*rhobeg recip=one/rhosq np=n+1 ! ! Set XBASE to the initial vector of variables, and set the initial ! elements of XPT, BMAT, HQ, PQ and ZMAT to zero. ! DO j=1,n xbase(j)=x(j) DO k=1,npt xpt(k,j)=zero END DO DO i=1,ndim bmat(i,j)=zero END DO END DO DO ih=1,(n*np)/2 hq(ih)=zero END DO DO k=1,npt pq(k)=zero DO j=1,npt-np zmat(k,j)=zero END DO END DO ! ! Begin the initialization procedure. NF becomes one more than the number ! of function values so far. The coordinates of the displacement of the ! next initial interpolation point from XBASE are set in XPT(NF+1,.). ! nf=0 50 nfm=nf nfx=nf-n nf=nf+1 IF (nfm <= 2*n) THEN IF (nfm >= 1 .AND. nfm <= n) THEN stepa=rhobeg IF (su(nfm) == zero) stepa=-stepa xpt(nf,nfm)=stepa ELSE IF (nfm > n) THEN stepa=xpt(nf-n,nfx) stepb=-rhobeg IF (sl(nfx) == zero) stepb=DMIN1(two*rhobeg,su(nfx)) IF (su(nfx) == zero) stepb=DMAX1(-two*rhobeg,sl(nfx)) xpt(nf,nfx)=stepb END IF ELSE itemp=(nfm-np)/n jpt=nfm-itemp*n-n ipt=jpt+itemp IF (ipt > n) THEN itemp=jpt jpt=ipt-n ipt=itemp END IF xpt(nf,ipt)=xpt(ipt+1,ipt) xpt(nf,jpt)=xpt(jpt+1,jpt) END IF ! ! Calculate the next value of F. The least function value so far and ! its index are required. ! DO j=1,n x(j)=DMIN1(DMAX1(xl(j),xbase(j)+xpt(nf,j)),xu(j)) IF (xpt(nf,j) == sl(j)) x(j)=xl(j) IF (xpt(nf,j) == su(j)) x(j)=xu(j) END DO CALL calfun (n,x,f) IF (iprint == 3) THEN PRINT 70, nf,f,(x(i),i=1,n) 70 FORMAT (/4X,'Function number',i6,' F =',1PD18.10, & ' The corresponding X is:'/(2X,5D15.6)) END IF fval(nf)=f IF (nf == 1) THEN fbeg=f kopt=1 ELSE IF (f < fval(kopt)) THEN kopt=nf END IF ! ! Set the nonzero initial elements of BMAT and the quadratic model in the ! cases when NF is at most 2*N+1. If NF exceeds N+1, then the positions ! of the NF-th and (NF-N)-th interpolation points may be switched, in ! order that the function value at the first of them contributes to the ! off-diagonal second derivative terms of the initial quadratic model. ! IF (nf <= 2*n+1) THEN IF (nf >= 2 .AND. nf <= n+1) THEN gopt(nfm)=(f-fbeg)/stepa IF (npt < nf+n) THEN bmat(1,nfm)=-one/stepa bmat(nf,nfm)=one/stepa bmat(npt+nfm,nfm)=-half*rhosq END IF ELSE IF (nf >= n+2) THEN ih=(nfx*(nfx+1))/2 temp=(f-fbeg)/stepb diff=stepb-stepa hq(ih)=two*(temp-gopt(nfx))/diff gopt(nfx)=(gopt(nfx)*stepb-temp*stepa)/diff IF (stepa*stepb < zero) THEN IF (f < fval(nf-n)) THEN fval(nf)=fval(nf-n) fval(nf-n)=f IF (kopt == nf) kopt=nf-n xpt(nf-n,nfx)=stepb xpt(nf,nfx)=stepa END IF END IF bmat(1,nfx)=-(stepa+stepb)/(stepa*stepb) bmat(nf,nfx)=-half/xpt(nf-n,nfx) bmat(nf-n,nfx)=-bmat(1,nfx)-bmat(nf,nfx) zmat(1,nfx)=DSQRT(two)/(stepa*stepb) zmat(nf,nfx)=DSQRT(half)/rhosq zmat(nf-n,nfx)=-zmat(1,nfx)-zmat(nf,nfx) END IF ! ! Set the off-diagonal second derivatives of the Lagrange functions and ! the initial quadratic model. ! ELSE ih=(ipt*(ipt-1))/2+jpt zmat(1,nfx)=recip zmat(nf,nfx)=recip zmat(ipt+1,nfx)=-recip zmat(jpt+1,nfx)=-recip temp=xpt(nf,ipt)*xpt(nf,jpt) hq(ih)=(fbeg-fval(ipt+1)-fval(jpt+1)+f)/temp END IF IF (nf < npt .AND. nf < maxfun) GO TO 50 RETURN END SUBROUTINE prelim ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% rescue.f %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% SUBROUTINE rescue (n,npt,xl,xu,iprint,maxfun,xbase,xpt, & fval,xopt,gopt,hq,pq,bmat,zmat,ndim,sl,su,nf,delta, kopt,vlag,ptsaux,ptsid,w) IMPLICIT double precision (a-h,o-z) INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: npt double precision, INTENT(IN) :: xl(*) double precision, INTENT(IN) :: xu(*) INTEGER, INTENT(IN) :: iprint INTEGER, INTENT(IN) :: maxfun double precision, INTENT(OUT) :: xbase(*) double precision, INTENT(OUT) :: xpt(npt,*) double precision, INTENT(IN OUT) :: fval(*) double precision, INTENT(IN OUT) :: xopt(*) double precision, INTENT(OUT) :: gopt(*) double precision, INTENT(OUT) :: hq(*) double precision, INTENT(IN OUT) :: pq(*) double precision, INTENT(OUT) :: bmat(ndim,*) double precision, INTENT(OUT) :: zmat(npt,*) INTEGER, INTENT(IN) :: ndim double precision, INTENT(OUT) :: sl(*) double precision, INTENT(OUT) :: su(*) INTEGER, INTENT(OUT) :: nf double precision, INTENT(IN) :: delta INTEGER, INTENT(IN OUT) :: kopt double precision, INTENT(IN OUT) :: vlag(*) double precision, INTENT(OUT) :: ptsaux(2,*) double precision, INTENT(OUT) :: ptsid(*) double precision, INTENT(OUT) :: w(*) ! ! The arguments N, NPT, XL, XU, IPRINT, MAXFUN, XBASE, XPT, FVAL, XOPT, ! GOPT, HQ, PQ, BMAT, ZMAT, NDIM, SL and SU have the same meanings as ! the corresponding arguments of BOBYQB on the entry to RESCUE. ! NF is maintained as the number of calls of CALFUN so far, except that ! NF is set to -1 if the value of MAXFUN prevents further progress. ! KOPT is maintained so that FVAL(KOPT) is the least calculated function ! value. Its correct value must be given on entry. It is updated if a ! new least function value is found, but the corresponding changes to ! XOPT and GOPT have to be made later by the calling program. ! DELTA is the current trust region radius. ! VLAG is a working space vector that will be used for the values of the ! provisional Lagrange functions at each of the interpolation points. ! They are part of a product that requires VLAG to be of length NDIM. ! PTSAUX is also a working space array. For J=1,2,...,N, PTSAUX(1,J) and ! PTSAUX(2,J) specify the two positions of provisional interpolation ! points when a nonzero step is taken along e_J (the J-th coordinate ! direction) through XBASE+XOPT, as specified below. Usually these ! steps have length DELTA, but other lengths are chosen if necessary ! in order to satisfy the given bounds on the variables. ! PTSID is also a working space array. It has NPT components that denote ! provisional new positions of the original interpolation points, in ! case changes are needed to restore the linear independence of the ! interpolation conditions. The K-th point is a candidate for change ! if and only if PTSID(K) is nonzero. In this case let p and q be the ! integer parts of PTSID(K) and (PTSID(K)-p) multiplied by N+1. If p ! and q are both positive, the step from XBASE+XOPT to the new K-th ! interpolation point is PTSAUX(1,p)*e_p + PTSAUX(1,q)*e_q. Otherwise ! the step is PTSAUX(1,p)*e_p or PTSAUX(2,q)*e_q in the cases q=0 or ! p=0, respectively. ! The first NDIM+NPT elements of the array W are used for working space. ! The final elements of BMAT and ZMAT are set in a well-conditioned way ! to the values that are appropriate for the new interpolation points. ! The elements of GOPT, HQ and PQ are also revised to the values that are ! appropriate to the final quadratic model. ! ! Set some constants. ! half=0.5D0 one=1.0D0 zero=0.0D0 np=n+1 sfrac=half/dble(np) nptm=npt-np ! ! Shift the interpolation points so that XOPT becomes the origin, and set ! the elements of ZMAT to zero. The value of SUMPQ is required in the ! updating of HQ below. The squares of the distances from XOPT to the ! other interpolation points are set at the end of W. Increments of WINC ! may be added later to these squares to balance the consideration of ! the choice of point that is going to become current. ! sumpq=zero winc=zero DO k=1,npt distsq=zero DO j=1,n xpt(k,j)=xpt(k,j)-xopt(j) distsq=distsq+xpt(k,j)**2 END DO sumpq=sumpq+pq(k) w(ndim+k)=distsq winc=DMAX1(winc,distsq) DO j=1,nptm zmat(k,j)=zero END DO END DO ! ! Update HQ so that HQ and PQ define the second derivatives of the model ! after XBASE has been shifted to the trust region centre. ! ih=0 DO j=1,n w(j)=half*sumpq*xopt(j) DO k=1,npt w(j)=w(j)+pq(k)*xpt(k,j) END DO DO i=1,j ih=ih+1 hq(ih)=hq(ih)+w(i)*xopt(j)+w(j)*xopt(i) END DO END DO ! ! Shift XBASE, SL, SU and XOPT. Set the elements of BMAT to zero, and ! also set the elements of PTSAUX. ! DO j=1,n xbase(j)=xbase(j)+xopt(j) sl(j)=sl(j)-xopt(j) su(j)=su(j)-xopt(j) xopt(j)=zero ptsaux(1,j)=DMIN1(delta,su(j)) ptsaux(2,j)=DMAX1(-delta,sl(j)) IF (ptsaux(1,j)+ptsaux(2,j) < zero) THEN temp=ptsaux(1,j) ptsaux(1,j)=ptsaux(2,j) ptsaux(2,j)=temp END IF IF (DABS(ptsaux(2,j)) < half*DABS(ptsaux(1,j))) THEN ptsaux(2,j)=half*ptsaux(1,j) END IF DO i=1,ndim bmat(i,j)=zero END DO END DO fbase=fval(kopt) ! ! Set the identifiers of the artificial interpolation points that are ! along a coordinate direction from XOPT, and set the corresponding ! nonzero elements of BMAT and ZMAT. ! ptsid(1)=sfrac DO j=1,n jp=j+1 jpn=jp+n ptsid(jp)=dble(j)+sfrac IF (jpn <= npt) THEN ptsid(jpn)=dble(j)/dble(np)+sfrac temp=one/(ptsaux(1,j)-ptsaux(2,j)) bmat(jp,j)=-temp+one/ptsaux(1,j) bmat(jpn,j)=temp+one/ptsaux(2,j) bmat(1,j)=-bmat(jp,j)-bmat(jpn,j) zmat(1,j)=DSQRT(2.0D0)/DABS(ptsaux(1,j)*ptsaux(2,j)) zmat(jp,j)=zmat(1,j)*ptsaux(2,j)*temp zmat(jpn,j)=-zmat(1,j)*ptsaux(1,j)*temp ELSE bmat(1,j)=-one/ptsaux(1,j) bmat(jp,j)=one/ptsaux(1,j) bmat(j+npt,j)=-half*ptsaux(1,j)**2 END IF END DO ! ! Set any remaining identifiers with their nonzero elements of ZMAT. ! IF (npt >= n+np) THEN DO k=2*np,npt iw=(dble(k-np)-half)/dble(n) ip=k-np-iw*n iq=ip+iw IF (iq > n) iq=iq-n ptsid(k)=dble(ip)+dble(iq)/dble(np)+sfrac temp=one/(ptsaux(1,ip)*ptsaux(1,iq)) zmat(1,k-np)=temp zmat(ip+1,k-np)=-temp zmat(iq+1,k-np)=-temp zmat(k,k-np)=temp END DO END IF nrem=npt kold=1 knew=kopt ! ! Reorder the provisional points in the way that exchanges PTSID(KOLD) ! with PTSID(KNEW). ! 80 DO j=1,n temp=bmat(kold,j) bmat(kold,j)=bmat(knew,j) bmat(knew,j)=temp END DO DO j=1,nptm temp=zmat(kold,j) zmat(kold,j)=zmat(knew,j) zmat(knew,j)=temp END DO ptsid(kold)=ptsid(knew) ptsid(knew)=zero w(ndim+knew)=zero nrem=nrem-1 IF (knew /= kopt) THEN temp=vlag(kold) vlag(kold)=vlag(knew) vlag(knew)=temp ! ! Update the BMAT and ZMAT matrices so that the status of the KNEW-th ! interpolation point can be changed from provisional to original. The ! branch to label 350 occurs if all the original points are reinstated. ! The nonnegative values of W(NDIM+K) are required in the search below. ! CALL update (n,npt,bmat,zmat,ndim,vlag,beta,denom,knew,w) IF (nrem == 0) GO TO 350 DO k=1,npt w(ndim+k)=DABS(w(ndim+k)) END DO END IF ! ! Pick the index KNEW of an original interpolation point that has not ! yet replaced one of the provisional interpolation points, giving ! attention to the closeness to XOPT and to previous tries with KNEW. ! 120 dsqmin=zero DO k=1,npt IF (w(ndim+k) > zero) THEN IF (dsqmin == zero .OR. w(ndim+k) < dsqmin) THEN knew=k dsqmin=w(ndim+k) END IF END IF END DO IF (dsqmin == zero) GO TO 260 ! ! Form the W-vector of the chosen original interpolation point. ! DO j=1,n w(npt+j)=xpt(knew,j) END DO DO k=1,npt sum=zero IF (k == kopt) THEN CONTINUE ELSE IF (ptsid(k) == zero) THEN DO j=1,n sum=sum+w(npt+j)*xpt(k,j) END DO ELSE ip=ptsid(k) IF (ip > 0) sum=w(npt+ip)*ptsaux(1,ip) iq=dble(np)*ptsid(k)-dble(ip*np) IF (iq > 0) THEN iw=1 IF (ip == 0) iw=2 sum=sum+w(npt+iq)*ptsaux(iw,iq) END IF END IF w(k)=half*sum*sum END DO ! ! Calculate VLAG and BETA for the required updating of the H matrix if ! XPT(KNEW,.) is reinstated in the set of interpolation points. ! DO k=1,npt sum=zero DO j=1,n sum=sum+bmat(k,j)*w(npt+j) END DO vlag(k)=sum END DO beta=zero DO j=1,nptm sum=zero DO k=1,npt sum=sum+zmat(k,j)*w(k) END DO beta=beta-sum*sum DO k=1,npt vlag(k)=vlag(k)+sum*zmat(k,j) END DO END DO bsum=zero distsq=zero DO j=1,n sum=zero DO k=1,npt sum=sum+bmat(k,j)*w(k) END DO jp=j+npt bsum=bsum+sum*w(jp) DO ip=npt+1,ndim sum=sum+bmat(ip,j)*w(ip) END DO bsum=bsum+sum*w(jp) vlag(jp)=sum distsq=distsq+xpt(knew,j)**2 END DO beta=half*distsq*distsq+beta-bsum vlag(kopt)=vlag(kopt)+one ! ! KOLD is set to the index of the provisional interpolation point that is ! going to be deleted to make way for the KNEW-th original interpolation ! point. The choice of KOLD is governed by the avoidance of a small value ! of the denominator in the updating calculation of UPDATE. ! denom=zero vlmxsq=zero DO k=1,npt IF (ptsid(k) /= zero) THEN hdiag=zero DO j=1,nptm hdiag=hdiag+zmat(k,j)**2 END DO den=beta*hdiag+vlag(k)**2 IF (den > denom) THEN kold=k denom=den END IF END IF vlmxsq=DMAX1(vlmxsq,vlag(k)**2) END DO IF (denom <= 1.0D-2*vlmxsq) THEN w(ndim+knew)=-w(ndim+knew)-winc GO TO 120 END IF GO TO 80 ! ! When label 260 is reached, all the final positions of the interpolation ! points have been chosen although any changes have not been included yet ! in XPT. Also the final BMAT and ZMAT matrices are complete, but, apart ! from the shift of XBASE, the updating of the quadratic model remains to ! be done. The following cycle through the new interpolation points begins ! by putting the new point in XPT(KPT,.) and by setting PQ(KPT) to zero, ! except that a RETURN occurs if MAXFUN prohibits another value of F. ! 260 DO kpt=1,npt IF (ptsid(kpt) == zero) CYCLE IF (nf >= maxfun) THEN nf=-1 EXIT END IF ih=0 DO j=1,n w(j)=xpt(kpt,j) xpt(kpt,j)=zero temp=pq(kpt)*w(j) DO i=1,j ih=ih+1 hq(ih)=hq(ih)+temp*w(i) END DO END DO pq(kpt)=zero ip=ptsid(kpt) iq=dble(np)*ptsid(kpt)-dble(ip*np) IF (ip > 0) THEN xp=ptsaux(1,ip) xpt(kpt,ip)=xp END IF IF (iq > 0) THEN xq=ptsaux(1,iq) IF (ip == 0) xq=ptsaux(2,iq) xpt(kpt,iq)=xq END IF ! ! Set VQUAD to the value of the current model at the new point. ! vquad=fbase IF (ip > 0) THEN ihp=(ip+ip*ip)/2 vquad=vquad+xp*(gopt(ip)+half*xp*hq(ihp)) END IF IF (iq > 0) THEN ihq=(iq+iq*iq)/2 vquad=vquad+xq*(gopt(iq)+half*xq*hq(ihq)) IF (ip > 0) THEN iw=MAX0(ihp,ihq)-IABS(ip-iq) vquad=vquad+xp*xq*hq(iw) END IF END IF DO k=1,npt temp=zero IF (ip > 0) temp=temp+xp*xpt(k,ip) IF (iq > 0) temp=temp+xq*xpt(k,iq) vquad=vquad+half*pq(k)*temp*temp END DO ! ! Calculate F at the new interpolation point, and set DIFF to the factor ! that is going to multiply the KPT-th Lagrange function when the model ! is updated to provide interpolation to the new function value. ! DO i=1,n w(i)=DMIN1(DMAX1(xl(i),xbase(i)+xpt(kpt,i)),xu(i)) IF (xpt(kpt,i) == sl(i)) w(i)=xl(i) IF (xpt(kpt,i) == su(i)) w(i)=xu(i) END DO nf=nf+1 CALL calfun (n,w,f) IF (iprint == 3) THEN PRINT 300, nf,f,(w(i),i=1,n) 300 FORMAT (/4X,'Function number',i6,' F =',1PD18.10, & ' The corresponding X is:'/(2X,5D15.6)) END IF fval(kpt)=f IF (f < fval(kopt)) kopt=kpt diff=f-vquad ! ! Update the quadratic model. The RETURN from the subroutine occurs when ! all the new interpolation points are included in the model. ! DO i=1,n gopt(i)=gopt(i)+diff*bmat(kpt,i) END DO DO k=1,npt sum=zero DO j=1,nptm sum=sum+zmat(k,j)*zmat(kpt,j) END DO temp=diff*sum IF (ptsid(k) == zero) THEN pq(k)=pq(k)+temp ELSE ip=ptsid(k) iq=dble(np)*ptsid(k)-dble(ip*np) ihq=(iq*iq+iq)/2 IF (ip == 0) THEN hq(ihq)=hq(ihq)+temp*ptsaux(2,iq)**2 ELSE ihp=(ip*ip+ip)/2 hq(ihp)=hq(ihp)+temp*ptsaux(1,ip)**2 IF (iq > 0) THEN hq(ihq)=hq(ihq)+temp*ptsaux(1,iq)**2 iw=MAX0(ihp,ihq)-IABS(iq-ip) hq(iw)=hq(iw)+temp*ptsaux(1,ip)*ptsaux(1,iq) END IF END IF END IF END DO ptsid(kpt)=zero END DO 350 RETURN END SUBROUTINE rescue ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% trsbox.f %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% SUBROUTINE trsbox (n,npt,xpt,xopt,gopt,hq,pq,sl,su,delta, & xnew,d,gnew,xbdi,s,hs,hred,dsq,crvmin) IMPLICIT double precision (a-h,o-z) INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: npt double precision, INTENT(IN) :: xpt(npt,*) double precision, INTENT(IN) :: xopt(*) double precision, INTENT(IN) :: gopt(*) double precision, INTENT(IN) :: hq(*) double precision, INTENT(IN) :: pq(*) double precision, INTENT(IN) :: sl(*) double precision, INTENT(IN) :: su(*) double precision, INTENT(IN) :: delta double precision, INTENT(OUT) :: xnew(*) double precision, INTENT(OUT) :: d(*) double precision, INTENT(OUT) :: gnew(*) double precision, INTENT(OUT) :: xbdi(*) double precision, INTENT(OUT) :: s(*) double precision, INTENT(IN OUT) :: hs(*) double precision, INTENT(IN OUT) :: hred(*) double precision, INTENT(OUT) :: dsq double precision, INTENT(OUT) :: crvmin ! ! The arguments N, NPT, XPT, XOPT, GOPT, HQ, PQ, SL and SU have the same ! meanings as the corresponding arguments of BOBYQB. ! DELTA is the trust region radius for the present calculation, which ! seeks a small value of the quadratic model within distance DELTA of ! XOPT subject to the bounds on the variables. ! XNEW will be set to a new vector of variables that is approximately ! the one that minimizes the quadratic model within the trust region ! subject to the SL and SU constraints on the variables. It satisfies ! as equations the bounds that become active during the calculation. ! D is the calculated trial step from XOPT, generated iteratively from an ! initial value of zero. Thus XNEW is XOPT+D after the final iteration. ! GNEW holds the gradient of the quadratic model at XOPT+D. It is updated ! when D is updated. ! XBDI is a working space vector. For I=1,2,...,N, the element XBDI(I) is ! set to -1.0, 0.0, or 1.0, the value being nonzero if and only if the ! I-th variable has become fixed at a bound, the bound being SL(I) or ! SU(I) in the case XBDI(I)=-1.0 or XBDI(I)=1.0, respectively. This ! information is accumulated during the construction of XNEW. ! The arrays S, HS and HRED are also used for working space. They hold the ! current search direction, and the changes in the gradient of Q along S ! and the reduced D, respectively, where the reduced D is the same as D, ! except that the components of the fixed variables are zero. ! DSQ will be set to the square of the length of XNEW-XOPT. ! CRVMIN is set to zero if D reaches the trust region boundary. Otherwise ! it is set to the least curvature of H that occurs in the conjugate ! gradient searches that are not restricted by any constraints. The ! value CRVMIN=-1.0D0 is set, however, if all of these searches are ! constrained. ! ! A version of the truncated conjugate gradient is applied. If a line ! search is restricted by a constraint, then the procedure is restarted, ! the values of the variables that are at their bounds being fixed. If ! the trust region boundary is reached, then further changes may be made ! to D, each one being in the two dimensional space that is spanned ! by the current D and the gradient of Q at XOPT+D, staying on the trust ! region boundary. Termination occurs when the reduction in Q seems to ! be close to the greatest reduction that can be achieved. ! ! Set some constants. ! half=0.5D0 one=1.0D0 onemin=-1.0D0 zero=0.0D0 ! ! The sign of GOPT(I) gives the sign of the change to the I-th variable ! that will reduce Q from its value at XOPT. Thus XBDI(I) shows whether ! or not to fix the I-th variable at one of its bounds initially, with ! NACT being set to the number of fixed variables. D and GNEW are also ! set for the first iteration. DELSQ is the upper bound on the sum of ! squares of the free variables. QRED is the reduction in Q so far. ! iterc=0 nact=0 sqstp=zero DO i=1,n xbdi(i)=zero IF (xopt(i) <= sl(i)) THEN IF (gopt(i) >= zero) xbdi(i)=onemin ELSE IF (xopt(i) >= su(i)) THEN IF (gopt(i) <= zero) xbdi(i)=one END IF IF (xbdi(i) /= zero) nact=nact+1 d(i)=zero gnew(i)=gopt(i) END DO delsq=delta*delta qred=zero crvmin=onemin ! ! Set the next search direction of the conjugate gradient method. It is ! the steepest descent direction initially and when the iterations are ! restarted because a variable has just been fixed by a bound, and of ! course the components of the fixed variables are zero. ITERMAX is an ! upper bound on the indices of the conjugate gradient iterations. ! 20 beta=zero 30 stepsq=zero DO i=1,n IF (xbdi(i) /= zero) THEN s(i)=zero ELSE IF (beta == zero) THEN s(i)=-gnew(i) ELSE s(i)=beta*s(i)-gnew(i) END IF stepsq=stepsq+s(i)**2 END DO IF (stepsq == zero) GO TO 190 IF (beta == zero) THEN gredsq=stepsq itermax=iterc+n-nact END IF IF (gredsq*delsq <= 1.0D-4*qred*qred) GO TO 190 ! ! Multiply the search direction by the second derivative matrix of Q and ! calculate some scalars for the choice of steplength. Then set BLEN to ! the length of the the step to the trust region boundary and STPLEN to ! the steplength, ignoring the simple bounds. ! GO TO 210 50 resid=delsq ds=zero shs=zero DO i=1,n IF (xbdi(i) == zero) THEN resid=resid-d(i)**2 ds=ds+s(i)*d(i) shs=shs+s(i)*hs(i) END IF END DO IF (resid <= zero) GO TO 90 temp=DSQRT(stepsq*resid+ds*ds) IF (ds < zero) THEN blen=(temp-ds)/stepsq ELSE blen=resid/(temp+ds) END IF stplen=blen IF (shs > zero) THEN stplen=DMIN1(blen,gredsq/shs) END IF ! ! Reduce STPLEN if necessary in order to preserve the simple bounds, ! letting IACT be the index of the new constrained variable. ! iact=0 DO i=1,n IF (s(i) /= zero) THEN xsum=xopt(i)+d(i) IF (s(i) > zero) THEN temp=(su(i)-xsum)/s(i) ELSE temp=(sl(i)-xsum)/s(i) END IF IF (temp < stplen) THEN stplen=temp iact=i END IF END IF END DO ! ! Update CRVMIN, GNEW and D. Set SDEC to the decrease that occurs in Q. ! sdec=zero IF (stplen > zero) THEN iterc=iterc+1 temp=shs/stepsq IF (iact == 0 .AND. temp > zero) THEN crvmin=DMIN1(crvmin,temp) IF (crvmin == onemin) crvmin=temp END IF ggsav=gredsq gredsq=zero DO i=1,n gnew(i)=gnew(i)+stplen*hs(i) IF (xbdi(i) == zero) gredsq=gredsq+gnew(i)**2 d(i)=d(i)+stplen*s(i) END DO sdec=DMAX1(stplen*(ggsav-half*stplen*shs),zero) qred=qred+sdec END IF ! ! Restart the conjugate gradient method if it has hit a new bound. ! IF (iact > 0) THEN nact=nact+1 xbdi(iact)=one IF (s(iact) < zero) xbdi(iact)=onemin delsq=delsq-d(iact)**2 IF (delsq <= zero) GO TO 90 GO TO 20 END IF ! ! If STPLEN is less than BLEN, then either apply another conjugate ! gradient iteration or RETURN. ! IF (stplen < blen) THEN IF (iterc == itermax) GO TO 190 IF (sdec <= 0.01D0*qred) GO TO 190 beta=gredsq/ggsav GO TO 30 END IF 90 crvmin=zero ! ! Prepare for the alternative iteration by calculating some scalars and ! by multiplying the reduced D by the second derivative matrix of Q. ! 100 IF (nact >= n-1) GO TO 190 dredsq=zero dredg=zero gredsq=zero DO i=1,n IF (xbdi(i) == zero) THEN dredsq=dredsq+d(i)**2 dredg=dredg+d(i)*gnew(i) gredsq=gredsq+gnew(i)**2 s(i)=d(i) ELSE s(i)=zero END IF END DO itcsav=iterc GO TO 210 ! ! Let the search direction S be a linear combination of the reduced D ! and the reduced G that is orthogonal to the reduced D. ! 120 iterc=iterc+1 temp=gredsq*dredsq-dredg*dredg IF (temp <= 1.0D-4*qred*qred) GO TO 190 temp=DSQRT(temp) DO i=1,n IF (xbdi(i) == zero) THEN s(i)=(dredg*d(i)-dredsq*gnew(i))/temp ELSE s(i)=zero END IF END DO sredg=-temp ! ! By considering the simple bounds on the variables, calculate an upper ! bound on the tangent of half the angle of the alternative iteration, ! namely ANGBD, except that, if already a free variable has reached a ! bound, there is a branch back to label 100 after fixing that variable. ! angbd=one iact=0 DO i=1,n IF (xbdi(i) == zero) THEN tempa=xopt(i)+d(i)-sl(i) tempb=su(i)-xopt(i)-d(i) IF (tempa <= zero) THEN nact=nact+1 xbdi(i)=onemin GO TO 100 ELSE IF (tempb <= zero) THEN nact=nact+1 xbdi(i)=one GO TO 100 END IF ratio=one ssq=d(i)**2+s(i)**2 temp=ssq-(xopt(i)-sl(i))**2 IF (temp > zero) THEN temp=DSQRT(temp)-s(i) IF (angbd*temp > tempa) THEN angbd=tempa/temp iact=i xsav=onemin END IF END IF temp=ssq-(su(i)-xopt(i))**2 IF (temp > zero) THEN temp=DSQRT(temp)+s(i) IF (angbd*temp > tempb) THEN angbd=tempb/temp iact=i xsav=one END IF END IF END IF END DO ! ! Calculate HHD and some curvatures for the alternative iteration. ! GO TO 210 150 shs=zero dhs=zero dhd=zero DO i=1,n IF (xbdi(i) == zero) THEN shs=shs+s(i)*hs(i) dhs=dhs+d(i)*hs(i) dhd=dhd+d(i)*hred(i) END IF END DO ! ! Seek the greatest reduction in Q for a range of equally spaced values ! of ANGT in [0,ANGBD], where ANGT is the tangent of half the angle of ! the alternative iteration. ! redmax=zero isav=0 redsav=zero iu=int(17.0D0*angbd+3.1D0) DO i=1, iu angt=angbd*dble(i)/dble(iu) sth=(angt+angt)/(one+angt*angt) temp=shs+angt*(angt*dhd-dhs-dhs) rednew=sth*(angt*dredg-sredg-half*sth*temp) IF (rednew > redmax) THEN redmax=rednew isav=i rdprev=redsav ELSE IF (i == isav+1) THEN rdnext=rednew END IF redsav=rednew END DO ! ! Return if the reduction is zero. Otherwise, set the sine and cosine ! of the angle of the alternative iteration, and calculate SDEC. ! IF (isav == 0) GO TO 190 IF (isav < iu) THEN temp=(rdnext-rdprev)/(redmax+redmax-rdprev-rdnext) angt=angbd*(dble(isav)+half*temp)/dble(iu) END IF cth=(one-angt*angt)/(one+angt*angt) sth=(angt+angt)/(one+angt*angt) temp=shs+angt*(angt*dhd-dhs-dhs) sdec=sth*(angt*dredg-sredg-half*sth*temp) IF (sdec <= zero) GO TO 190 ! ! Update GNEW, D and HRED. If the angle of the alternative iteration ! is restricted by a bound on a free variable, that variable is fixed ! at the bound. ! dredg=zero gredsq=zero DO i=1,n gnew(i)=gnew(i)+(cth-one)*hred(i)+sth*hs(i) IF (xbdi(i) == zero) THEN d(i)=cth*d(i)+sth*s(i) dredg=dredg+d(i)*gnew(i) gredsq=gredsq+gnew(i)**2 END IF hred(i)=cth*hred(i)+sth*hs(i) END DO qred=qred+sdec IF (iact > 0 .AND. isav == iu) THEN nact=nact+1 xbdi(iact)=xsav GO TO 100 END IF ! ! If SDEC is sufficiently small, then RETURN after setting XNEW to ! XOPT+D, giving careful attention to the bounds. ! IF (sdec > 0.01D0*qred) GO TO 120 190 dsq=zero DO i=1,n xnew(i)=DMAX1(DMIN1(xopt(i)+d(i),su(i)),sl(i)) IF (xbdi(i) == onemin) xnew(i)=sl(i) IF (xbdi(i) == one) xnew(i)=su(i) d(i)=xnew(i)-xopt(i) dsq=dsq+d(i)**2 END DO RETURN ! The following instructions multiply the current S-vector by the second ! derivative matrix of the quadratic model, putting the product in HS. ! They are reached from three different parts of the software above and ! they can be regarded as an external subroutine. ! 210 ih=0 DO j=1,n hs(j)=zero DO i=1,j ih=ih+1 IF (i < j) hs(j)=hs(j)+hq(ih)*s(i) hs(i)=hs(i)+hq(ih)*s(j) END DO END DO DO k=1,npt IF (pq(k) /= zero) THEN temp=zero DO j=1,n temp=temp+xpt(k,j)*s(j) END DO temp=temp*pq(k) DO i=1,n hs(i)=hs(i)+temp*xpt(k,i) END DO END IF END DO IF (crvmin /= zero) GO TO 50 IF (iterc > itcsav) GO TO 150 DO i=1,n hred(i)=hs(i) END DO GO TO 120 END SUBROUTINE trsbox ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% update.f %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% SUBROUTINE update (n,npt,bmat,zmat,ndim,vlag,beta,denom, knew,w) IMPLICIT double precision (a-h,o-z) INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: npt double precision, INTENT(IN OUT) :: bmat(ndim,*) double precision, INTENT(IN OUT) :: zmat(npt,*) INTEGER, INTENT(IN) :: ndim double precision, INTENT(IN OUT) :: vlag(*) double precision, INTENT(IN) :: beta double precision, INTENT(IN) :: denom INTEGER, INTENT(IN OUT) :: knew double precision, INTENT(OUT) :: w(*) ! ! The arrays BMAT and ZMAT are updated, as required by the new position ! of the interpolation point that has the index KNEW. The vector VLAG has ! N+NPT components, set on entry to the first NPT and last N components ! of the product Hw in equation (4.11) of the Powell (2006) paper on ! NEWUOA. Further, BETA is set on entry to the value of the parameter ! with that name, and DENOM is set to the denominator of the updating ! formula. Elements of ZMAT may be treated as zero if their moduli are ! at most ZTEST. The first NDIM elements of W are used for working space. ! ! Set some constants. ! one=1.0D0 zero=0.0D0 nptm=npt-n-1 ztest=zero DO k=1,npt DO j=1,nptm ztest=DMAX1(ztest,DABS(zmat(k,j))) END DO END DO ztest=1.0D-20*ztest ! ! Apply the rotations that put zeros in the KNEW-th row of ZMAT. ! jl=1 DO j=2,nptm IF (DABS(zmat(knew,j)) > ztest) THEN temp=DSQRT(zmat(knew,1)**2+zmat(knew,j)**2) tempa=zmat(knew,1)/temp tempb=zmat(knew,j)/temp DO i=1,npt temp=tempa*zmat(i,1)+tempb*zmat(i,j) zmat(i,j)=tempa*zmat(i,j)-tempb*zmat(i,1) zmat(i,1)=temp END DO END IF zmat(knew,j)=zero END DO ! ! Put the first NPT components of the KNEW-th column of HLAG into W, ! and calculate the parameters of the updating formula. ! DO i=1,npt w(i)=zmat(knew,1)*zmat(i,1) END DO alpha=w(knew) tau=vlag(knew) vlag(knew)=vlag(knew)-one ! ! Complete the updating of ZMAT. ! temp=DSQRT(denom) tempb=zmat(knew,1)/temp tempa=tau/temp DO i=1,npt zmat(i,1)=tempa*zmat(i,1)-tempb*vlag(i) END DO ! ! Finally, update the matrix BMAT. ! DO j=1,n jp=npt+j w(jp)=bmat(knew,j) tempa=(alpha*vlag(jp)-tau*w(jp))/denom tempb=(-beta*w(jp)-tau*vlag(jp))/denom DO i=1,jp bmat(i,j)=bmat(i,j)+tempa*vlag(i)+tempb*w(i) IF (i > npt) bmat(jp,i-npt)=bmat(i,j) END DO END DO RETURN END SUBROUTINE update end module bobyqa_optimizer ! ! Results of statistical tests ! ! Likelihoods and no. parameters for consecutive model fits (varcom, llm, segsim) ! whlik points to last result ! pval is P-value arising from current test ! statval is statistic and error variance (asymptotic and empirical estimates) ! or d.f. arising from current test (binreg, clreg) ! module statresults integer :: whlik = 2 character(len=80) :: mcall(2) = ' ' integer :: mpar(2) = 0 double precision :: mlik(2) = 0.0d0 double precision :: pval = 1.0d0 double precision, dimension(3) :: statval = 0.0d0 end module statresults ! ! Recast data to and from dp representation ! module recast_data public :: decgtp, encgtp, iencgtp, encchr, decchr, chr_convert contains ! ! Decode hashed genotype code ! subroutine decgtp(val, g1, g2) double precision, intent(in) :: val integer, intent(out) :: g1 integer, intent(out) :: g2 integer :: ival ival=int(val) g1=ival/10000 g2=mod(ival,10000) if (g1 > 1000) g1=9000+g1 if (g2 > 1000) g2=9000+g2 end subroutine decgtp ! ! Hash a genotype ! function encgtp(a1, a2) double precision encgtp integer, intent(in) :: a1, a2 integer g1, g2 g1=a1 g2=a2 if (g1 > 10000) g1=g1-9000 if (g2 > 10000) g2=g2-9000 encgtp=10000.0D0*dble(g1)+dble(g2) end function encgtp ! ! Hash an integer genotype ! function iencgtp(a1, a2) integer :: iencgtp integer, intent(in) :: a1, a2 integer g1, g2 g1=a1 g2=a2 if (g1 > 10000) g1=g1-9000 if (g2 > 10000) g2=g2-9000 iencgtp=10000*g1+g2 end function iencgtp ! ! Hash a chromosome retaining nice collation order ! subroutine encchr(chr, val) character(len=*), intent(in) :: chr double precision, intent(out) :: val integer :: MISS=-9999 ! functions logical :: is_strict_int integer :: ival if (chr == 'X') then val=1.0d99 else if (chr == 'Y') then val=2.0d99 else if (chr == 'XY') then val=3.0d99 else if (chr == 'MT' .or. chr == 'Mt') then val=4.0d99 else if (chr == ' ') then val=MISS else if (is_strict_int(chr)) then val=ival(chr) else val=transfer(chr,val) end if end subroutine encchr ! ! Unhash a chromosome ! subroutine decchr(val, chr) double precision :: val character(len=*) :: chr integer :: MISS=-9999 integer :: iv chr=' ' if (val == 1.0d99) then chr='X' else if (val == 2.0d99) then chr='Y' else if (val == 3.0d99) then chr='XY' else if (val == 4.0d99) then chr='MT' else if (val == MISS) then chr='Un' else if (anint(val) == val) then write(chr,'(i2)') int(val) chr=adjustl(chr) else chr=transfer(val,chr) end if end subroutine decchr ! ! read in a chromosome name - HSA chr 23-26 often are X, Y, PAR (XY), MT ! subroutine chr_convert(chrcode, string, chr) integer, intent(in) :: chrcode character(len=*), intent(in) :: string character(len=*), intent(out) :: chr integer :: n chr=string n=len(string) if (n > 3) then if (string(1:3) == 'chr') then chr=string(4:n) end if end if if (chrcode == 2) then if (chr == '23') then chr='X' else if (chr == '24') then chr='Y' else if (chr == '25') then chr='XY' else if (chr == '26') then chr='Mt' end if end if end subroutine chr_convert end module recast_data ! ! Storage for a range of map positions ! ! chromosome chromosome_name ! mapranges range_start range_end ! chromrange first_range_record last_range_record ! module maprange_class use sorts use locstring_widths use idhash_class type maprange_table integer :: nrec = 0 ! currently up to integer :: nchrom = 0 ! number of chromosomes integer, dimension(:,:), allocatable :: chromrange character(len=chromosome_width), dimension(:), allocatable :: chromosome integer (kind=8), dimension(:,:), allocatable :: mapranges type (hash_table) :: chromhash end type maprange_table contains ! ! make_mapranges takes a table of three vars: chr, lower, upper ! subroutine make_mapranges(rangetable, mr) use recast_data use contingency_table type (table_data) :: rangetable type (maprange_table) :: mr integer :: i, j, pos, tot integer, dimension(1) :: marg type (table_data) :: chrtable ! functions integer (kind=8) :: tobp8 call setup_table(1, 20, chrtable) marg(1)=1 call marginal_table(1, marg, rangetable, chrtable) mr%nchrom = chrtable%ncells mr%nrec = rangetable%ncells allocate(mr%chromosome(mr%nchrom)) allocate(mr%chromrange(mr%nchrom,2)) allocate(mr%mapranges(mr%nrec, 2)) tot=0 do j=1, mr%nchrom call decchr(chrtable%categories(chrtable%idx(j),1)%rvalue, mr%chromosome(j)) if (mr%chromosome(j) == 'Un') mr%chromosome(j)=' ' mr%chromrange(j,1)=tot+1 tot=tot+chrtable%icount(j) mr%chromrange(j,2)=tot end do do i=1, rangetable%ncells pos=rangetable%idx(i) mr%mapranges(i,1)=tobp8(rangetable%categories(pos,2)%rvalue) mr%mapranges(i,2)=tobp8(rangetable%categories(pos,3)%rvalue) end do call setup_hash(HK_CHROM, mr%nchrom, mr%chromhash, 50) call fill_hash(mr%chromhash,mr%chromosome) end subroutine make_mapranges subroutine show_mapranges(mr) type (maprange_table), intent(in) :: mr integer :: i, j do i=1, mr%nchrom if (mr%chromrange(i,1) > 0) then do j=mr%chromrange(i,1), mr%chromrange(i,2) write(*,*) mr%chromosome(i), mr%mapranges(j, 1), mr%mapranges(j, 2) end do end if end do end subroutine show_mapranges subroutine clean_mapranges(mr) type (maprange_table) :: mr call cleanup_hash(mr%chromhash) if (mr%nchrom > 0) then deallocate(mr%chromosome, mr%chromrange) end if if (mr%nrec > 0) then deallocate(mr%mapranges) end if mr%nchrom = 0 mr%nrec = 0 end subroutine clean_mapranges ! ! Test if in ranges ! subroutine in_mapranges(chr, mappos, mr, res) character (len=2), intent(in) :: chr double precision, intent(in) :: mappos type (maprange_table), intent(in) :: mr logical, intent(out) :: res integer :: i, ichrom, j integer(kind=8) :: bp ! functions integer(kind=8) :: tobp8 res = .false. call find_hashtab(trim(chr), mr%chromosome, & mr%chromhash, ichrom) if (ichrom == 0) return bp=tobp8(mappos) do j=mr%chromrange(ichrom,1), mr%chromrange(ichrom,2) if (bp >= mr%mapranges(j,1) .and. bp <= mr%mapranges(j,2)) then res=.true. return end if end do end subroutine in_mapranges end module maprange_class ! ! Subset of loci by map ranges ! ! read in range of map positions eg ! 6:112345 -- 142441 => 6:112345-6:142441 ! 6:112345-142441 => 6:112345-6:142441 ! chr6 112345 -- 142441 1424450 => 6:112345-6:142441 6:1424450-6:1424450 ! -- 6:112345 => 6:0-6:112345 ! 6:112345 -- => 6:112345-6:1e99 ! 6:112345 -- 7:142441 => 6:112345 --, -- 7:142441 => 6:112345-6:1e99, 7:0-7:142441 ! ! pos1 => " ":pos1 -- " ":pos1 ! pos2 => chr1:pos2 -- chr1:pos2 ! chr1:pos1 => chr1:pos1 -- chr1:pos1 ! chr1:pos1 -- chr1:pos2 => chr1:pos1 -- chr1:pos2 ! chr1:pos1 -- pos2 => chr1:pos1 -- chr1:pos2 ! chr1:pos1 -- => chr1:pos1 -- chr1:1e99 ! -- chr1:pos2 => chr1:0 -- chr1:pos2 ! module map_position_list contains ! ! like loadnam, but by position ! typ=1 active loci, =2 inactive loci ! subroutine loadpos(sta, fin, words, nloci, loc, lochash, loctyp, & group, map, locstat, chosen, nterms, terms, typ) use outstream use maprange_class use contingency_table use locus_types use locstring_widths use idhash_class use lochash_class use sorts use string_utilities use automatic_data use genetic_maps use recast_data integer, intent(in) :: sta ! first word of list integer, intent(in) :: fin ! last word of list character (len=40), dimension(:), intent(in) :: words integer, intent(in) :: nloci character (len=loc_width), dimension(:), intent(in) :: loc type (hash_table) :: lochash integer, dimension(:), intent(in out) :: loctyp character (len=chromosome_width), dimension(:), intent(in) :: group double precision, dimension(:), intent(in) :: map double precision, dimension(:), intent(in) :: locstat integer, dimension(:), intent(out) :: chosen integer, intent(out) :: nterms integer, dimension(:), intent(out) :: terms integer, intent(in) :: typ ! local variables double precision, parameter :: maxmap = 1.0d5 integer :: ichr, i, j, locnum, maxterms, nmark, offset, pos, span integer :: be, bymap, dir, en character (len=chromosome_width) :: currchr, thischr double precision :: lower, upper integer, dimension(nloci) :: ord type (table_data) :: choices type (maprange_table) :: mapranges double precision, dimension(3) :: choicevals logical :: found ! functions ! chfind, strfind integer :: chrnum, ival double precision :: fval call setup_table(3, 20, choices) chosen(1:nloci)=0 nterms=0 maxterms=size(terms) ! if (sta <= fin) then nranges=0 be=0 en=0 i=0 thischr=' ' currchr=' ' span=0 lower=0.0d0 upper=maxmap pos=sta do while (pos <= fin) i=index(words(pos),':') if (words(pos)(1:3) == 'chr') then if (len_trim(words(pos)) == 3) then if (pos < fin) thischr=words(pos+1) pos=pos+1 else thischr=words(pos)(4:len_trim(words(pos))) end if else if (words(pos) == 'to' .or. words(pos) == '--') then span=1 if (be == 0) span=-1 else i=index(words(pos),':') thischr=currchr if (i > 0) then thischr=words(pos)(1:(i-1)) end if if (be == 0) then be=pos lower=fval(words(pos)((i+1):len_trim(words(pos)))) if (span == -1) then en=pos upper=fval(words(pos)((i+1):len_trim(words(pos)))) end if else en=pos upper=fval(words(pos)((i+1):len_trim(words(pos)))) if (currchr /= thischr .or. span == 0) then be=pos if (span == 1) then upper=maxmap else upper=lower end if else be=0 end if end if if (en /= 0) then call encchr(currchr, choicevals(1)) choicevals(2)=mapconstant*min(lower, upper) choicevals(3)=mapconstant*max(lower, upper) call insert_table(3, choicevals, choices, 1) if (be /= 0) then lower=fval(words(pos)((i+1):len_trim(words(pos)))) else be=0 end if en=0 span=0 end if end if currchr=thischr pos=pos+1 end do if (be /= 0) then if (span == 1) then upper=maxmap else if (span == -1) then upper=lower lower=0 else upper=lower end if call encchr(currchr, choicevals(1)) choicevals(2)=mapconstant*min(lower, upper) choicevals(3)=mapconstant*max(lower, upper) call insert_table(3, choicevals, choices, 1) end if call sort_table(choices) call make_mapranges(choices, mapranges) ! call show_mapranges(mapranges) end if if (typ == 1) then do locnum=ENVNUM+1, nloci if (isactive(loctyp(locnum))) then call in_mapranges(group(locnum), map(locnum), mapranges, found) if (found) then nterms=nterms+1 chosen(locnum)=nterms end if end if end do else do locnum=ENVNUM+1, nloci if (.not.isactive(loctyp(locnum))) then call in_mapranges(group(locnum), map(locnum), mapranges, found) if (found) then nterms=nterms+1 chosen(locnum)=nterms end if end if end do end if do locnum=1, nloci if (chosen(locnum) > 0) then terms(chosen(locnum))=locnum end if end do call clean_mapranges(mapranges) end subroutine loadpos end module map_position_list ! ! Extract values from dataset ! module read_data use ped_class use locus_types use recast_data contains ! ! Count maximum number of active markers where proband and ! any of relatives is genotyped at (for autovar) ! subroutine marshare(idx, nloci, loctyp, locpos, dataset, marcom) use interrupt integer, intent(in) :: idx integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data) :: dataset integer, intent(out) :: marcom integer, parameter :: MISS=-9999 integer, parameter :: KNOWN=0 integer, dimension(nloci) :: ord integer :: i, j, nmark, nmatch marcom=0 nmark=0 do j=1, nloci if (isactdip(loctyp(j))) then if (observed(idx, locpos(j), dataset)) then nmark=nmark+1 ord(nmark)=locpos(j) end if end if end do ! break if (nmark == 0) return do i=dataset%num(dataset%iped(idx)-1)+1, dataset%num(dataset%iped(idx)) if (i /= idx) then nmatch=0 do j=1, nmark if (observed(i, ord(j), dataset)) then nmatch=nmatch+1 end if end do if (nmatch > marcom) marcom=nmatch end if end do end subroutine marshare ! ! Evaluate automatic variable ! subroutine autovar(idx, ctag, nloci, loctyp, locpos, dataset, res) use automatic_data integer, intent(in) :: idx integer, intent(in) :: ctag integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data) :: dataset double precision, intent(out) :: res integer, parameter :: KNOWN=0, MISS=-9999 integer :: g1, g2, i, j, iloc, lpos, marcom, nmark res=MISS ! female male if (ctag == ENV_SEX .or. ctag == ENV_FEMALE .or. ctag == ENV_MALE) then if (dataset%sex(idx) /= MISS) then if (ctag == ENV_SEX) then res=dble(dataset%sex(idx)) else if (ctag == ENV_FEMALE) then res=dble(dataset%sex(idx)-1) else res=dble(2-dataset%sex(idx)) end if end if ! isfou else if (ctag == ENV_ISFOU) then res=0.0d0 if (dataset%fa(idx)==MISS) res=1.0d0 ! isnon else if (ctag == ENV_ISNON) then res=0.0d0 if (dataset%fa(idx)/=MISS) res=1.0d0 ! num else if (ctag == ENV_NUM) then res=dble(dataset%num(dataset%iped(idx))-dataset%num(dataset%iped(idx)-1)) ! nfoun else if (ctag == ENV_NFOUN) then res=dble(dataset%nfound(dataset%iped(idx))) ! famnum else if (ctag == ENV_FAMNUM) then res=dble(dataset%iped(idx)) ! index else if (ctag == ENV_INDEX) then res=dble(idx) ! chosen else if (ctag == ENV_CHOSEN) then res=1.0d0 if (dataset%untyped(idx)) res=0.0d0 ! commar else if (ctag == ENV_COMMAR) then call marshare(idx, nloci, loctyp, locpos, dataset, marcom) res=dble(marcom) ! anymis else if (ctag == ENV_ANYMIS) then res=0.0d0 do i=1, nloci if (isactive(loctyp(i))) then if (ismarker(loctyp(i))) then if (.not.observed(idx, locpos(i), dataset)) then res=1.0d0 exit end if else if (.not.isspecial(loctyp(i))) then if (dataset%plocus(idx, locpos(i)) == MISS) then res=1.0d0 exit end if end if end if end do ! anytyp alltyp numtyp protyp else iloc=0 nmark=0 do i=1, nloci if (isactive(loctyp(i)) .and. ismarker(loctyp(i))) then nmark=nmark+1 if (observed(idx, locpos(i), dataset)) then iloc=iloc+1 end if end if end do res=0.0d0 if (ctag == ENV_ANYTYP) then if (iloc > 0) res=1.0d0 else if (ctag == ENV_ALLTYP) then if (iloc == nmark) res=1.0d0 else if (ctag == ENV_NUMTYP) then res=dble(iloc) else if (ctag == ENV_PROTYP) then res=dble(iloc)/dble(max(1,nmark)) end if end if end subroutine autovar ! ! Values for one individual for insertion into contingency table ! subroutine readval(mistyp, idx, nloc, loclist, nloci, loc, locpos, loctyp, & dataset, val, astat) use contingency_table integer, intent(in) :: mistyp ! tabulate missing values integer, intent(in) :: idx ! person integer, intent(in) :: nloc ! number of dimensions integer, dimension(:), intent(in) :: loclist ! variable list character (len=20), dimension(:), intent(in) :: loc integer, intent(in) :: nloci ! total loci integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp type (ped_data), intent(in) :: dataset double precision, dimension(nloc), intent(out) :: val ! data for one individual integer, intent(out) :: astat integer, parameter :: KNOWN=0, MISS=-9999 ! local variables integer :: g1, g2, j, lpos, ltyp, ped double precision :: res astat=1 if (dataset%actset(dataset%iped(idx)) <= 0) return astat=0 do j=1, nloc lpos=locpos(loclist(j)) ltyp=loctyp(loclist(j)) call readoneval(idx, lpos, ltyp, nloci, loctyp, locpos, & dataset, mistyp, res, astat) if (astat /= 0) return val(j)=res end do end subroutine readval ! ! Value for one phenotype for one individual ! subroutine readoneval(idx, lpos, ltyp, nloci, loctyp, locpos, & dataset, mistyp, val, astat) integer, intent(in) :: idx integer, intent(in) :: lpos, ltyp integer, intent(in) :: nloci integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp type (ped_data), intent(in) :: dataset integer, intent(in) :: mistyp double precision, intent(out) :: val integer, intent(out) :: astat integer, parameter :: MISS=-9999 integer :: g1, g2 double precision :: res val=MISS astat=0 if (ismarker(ltyp)) then if (.not.observed(idx, lpos, dataset)) then if (mistyp == 0) astat=1 else call get_geno(idx, lpos, lpos+1, dataset, g1, g2) val=encgtp(g1, g2) end if else if (isspecial(ltyp)) then call autovar(idx, lpos, nloci, loctyp, locpos, dataset, res) if (res == MISS .and. mistyp == 0) then astat=1 else val=res end if else if (dataset%plocus(idx,lpos) == MISS .and. mistyp == 0) then astat=1 else val=dataset%plocus(idx,lpos) end if end if end subroutine readoneval ! ! Similar to readoneval, but for regression routines ! subroutine readdatum(idx, lpos, ltyp, nloci, loctyp, locpos, dataset, val) integer, intent(in) :: idx integer, intent(in) :: lpos, ltyp integer, intent(in) :: nloci integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp type (ped_data), intent(in) :: dataset double precision, intent(out) :: val integer, parameter :: MISS=-9999 integer :: g1, g2 val=MISS if (ismarker(ltyp)) then if (observed(idx, lpos, dataset)) then call get_geno(idx, lpos, lpos+1, dataset, g1, g2) val=0.5d0*dble(g1+g2) end if else if (ltyp == LOC_AFF) then val=dataset%plocus(idx,lpos)-1.0d0 else if (isspecial(ltyp)) then call autovar(idx, lpos, nloci, loctyp, locpos, dataset, val) else val=dataset%plocus(idx,lpos) end if end subroutine readdatum ! ! Fill a crosstabulation from dataset ! subroutine maketab(mistyp, weight, nloc, loclist, nloci, loc, locpos, loctyp, & dataset, nmiss, table) use interrupt use contingency_table integer, intent(in) :: mistyp ! handling of missing values 0=drop integer, intent(in) :: weight ! sample weight MISS=0 >0=trait name integer, intent(in) :: nloc ! number of dimensions integer, dimension(:), intent(in) :: loclist ! variable list character (len=20), dimension(:), intent(in) :: loc integer, intent(in) :: nloci ! total loci integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp type (ped_data) :: dataset integer, intent(out) :: nmiss type (table_data) :: table integer, parameter :: KNOWN=0 double precision, dimension(nloc) :: val ! data for one individual ! local variables integer :: astat, i, iweight, wpos call setup_table(nloc, 100, table) do i=1, nloc call set_table_colname(i, loc(loclist(i)), table) end do nmiss=0 ! dataset%untyped=.true. wpos=0 if (weight > KNOWN) wpos=locpos(weight) ! accumulate counts do i=1, dataset%nobs call readval(mistyp, i, nloc, loclist, nloci, loc, locpos, loctyp, & dataset, val, astat) if (astat == 0) then iweight=1 if (wpos > KNOWN) then iweight=int(dataset%plocus(i,wpos)) end if call insert_table(nloc, val, table, iweight) else nmiss=nmiss+1 end if if (irupt > 0) exit end do call sort_table(table) end subroutine maketab ! ! Returns table of allele counts by stratum 1..(nloc-1)=strata levels nloc=gene ! subroutine strat_freq(nloc, loclist, nloci, loc, locpos, loctyp, & allele_buffer, dataset, nmiss, table) use interrupt use alleles_class use contingency_table implicit none integer, intent(in) :: nloc integer, dimension(:), intent(in) :: loclist integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp type (allele_data), intent(in) :: allele_buffer type (ped_data) :: dataset integer, intent(out) :: nmiss type (table_data) :: table integer, parameter :: DROPX=0, KNOWN=0, MISS=-9999 ! ! stratum levels ! type (table_data) :: martable1 ! work array: list of selected variables for table integer, dimension(nloc-1) :: chosen ! data vector double precision, dimension(nloc) :: val integer :: astat, g1, g2, i, j, k, kk, ngroups, pos logical :: xlinkd xlinkd=(same_loctyp(loctyp(nloc), LOC_XLIN)) nmiss=0 call setup_table(nloc, 100, table) do i=1, dataset%nobs call readval(DROPX, i, nloc, loclist, nloci, loc, locpos, loctyp, & dataset, val, astat) if (astat == 0) then call decgtp(val(nloc), g1, g2) val(nloc)=encgtp(g1, g1) call insert_table(nloc, val, table, 1) if (.not.xlinkd .or. dataset%sex(i) /= 1) then val(nloc)=encgtp(g2, g2) call insert_table(nloc, val, table, 1) end if else nmiss=nmiss+1 end if if (irupt > 0) exit end do do i=1, nloc-1 chosen(i)=i end do call setup_table(nloc-1, 20, martable1) call marginal_table(nloc-1, chosen, table, martable1) ngroups=martable1%ncells do k=1, ngroups pos=martable1%idx(k) do kk=1, nloc-1 val(kk)=martable1%categories(pos,kk)%rvalue end do do j=1, allele_buffer%numal val(nloc)=encgtp(allele_buffer%allele_names(j),allele_buffer%allele_names(j)) call insert_table(nloc, val, table, 0) end do end do end subroutine strat_freq end module read_data ! ! Miniscm ! module scheme_lang use extras use interrupt use outstream use fileio use iobuff use string_utilities use idhash_class #if JAPI use japi #endif private public :: cleanup_mem, get_iarray, get_rarray, get_string, get_notes, & get_var, scmfun, isafun, isahash, list_var, init_scheme, & read_scheme_image, repl_scheme, save_scheme_image, & get_string_var, append_string_var ! ! binary images of scheme workspace need to match correct version ! bump version number if eg add new procedures ! character (len=5), parameter :: scheme_version = '00018' integer, parameter :: T_FREE=0, T_STRING=1, T_NUMBER=2, T_SYMBOL=4, T_SYNTAX=8, & T_PROC=16, T_PAIR=32, T_CLOSURE=64, T_CONTINUATION=128, & T_MACRO=256, T_PROMISE=512, T_PORT=2048, T_HASHVEC=4096, & T_ATOM=16384, T_CLRATOM=49151, T_MARK=32768, T_UNMARK=32767, & T_MOVED=-1 integer, parameter :: M_LPAREN=0, M_RPAREN=1, M_DOT=2, M_ATOM=3, M_QUOTE=4, & M_COMMENT=5, M_DQUOTE=6, M_BQUOTE=7, M_COMMA=8, M_ATMARK=9, & M_SHARP=10 integer, parameter :: OP_LOAD=0, OP_T0LVL=1, OP_T1LVL=2, OP_READ=3, OP_VALUEPRINT=4, & OP_EVAL=5, OP_E0ARGS=6, OP_E1ARGS=7, OP_APPLY=8, OP_DOMACRO=9 integer, parameter :: OP_LAMBDA=10, OP_MKCLOSURE=11, OP_QUOTE=12, & OP_DEF0=13, OP_DEF1=14, OP_BEGIN=15, & OP_IF0=16, OP_IF1=17, OP_SET0=18, OP_SET1=19, & OP_LET0=20, OP_LET1=21, OP_LET2=22, & OP_LET0AST=23, OP_LET1AST=24, OP_LET2AST=25, & OP_LET0REC=26, OP_LET1REC=27, OP_LET2REC=28, & OP_COND0=29, OP_COND1=30, OP_DELAY=31, & OP_AND0=32, OP_AND1=33, OP_OR0=34, OP_OR1=35, & OP_C0STREAM=36, OP_C1STREAM=37, OP_0MACRO=38, & OP_1MACRO=39, OP_CASE0=40, OP_CASE1=41, OP_CASE2=42 integer, parameter :: OP_PEVAL=43, OP_PAPPLY=44, OP_CONTINUATION=45, OP_ADD=46, & OP_SUB=47, OP_MUL=48, OP_DIV=49, OP_INTDIV=50, OP_REM=51, & OP_MOD=52, OP_CAR=53, OP_CDR=54, OP_CONS=55, OP_SETCAR=56, & OP_SETCDR=57, OP_NOT=58, OP_BOOL=59, OP_ISINT=60, OP_ISREAL=61, & OP_NULL=62, OP_ZEROP=63, OP_POSP=64, OP_NEGP=65, & OP_NUMEQ=66, OP_LESS=67, OP_GRE=68, OP_LEQ=69, & OP_GEQ=70, OP_SYMBOL=71, OP_NUMBER=72, OP_STRING=73, & OP_PROC=74, OP_PAIR=75, OP_LIST=76, OP_EQ=77, OP_EQV=78, & OP_FORCE=79, OP_WRITE=80, OP_DISPLAY=81, OP_NEWLINE=82, OP_ERR0=83, & OP_ERR1=84, OP_REVERSE=85, OP_APPEND=86, OP_PUT=87, & OP_GET=88, OP_QUIT=89, OP_GC=90, OP_GCVERB=91, OP_NEWSEGMENT=92 integer, parameter :: OP_RDSEXPR=93, OP_RDLIST=94, OP_RDDOT=95, OP_RDQUOTE=96, OP_RDQQUOTE=97, & OP_RDUNQUOTE=98, OP_RDUQTSP=99 integer, parameter :: OP_P0LIST=100, OP_P1LIST=101, OP_LIST_LENGTH=102, OP_ASSQ=103, & OP_PRINT_WIDTH=104, OP_P0_WIDTH=105, OP_P1_WIDTH=106, & OP_GET_CLOSURE=107, OP_CLOSUREP=108, OP_MACROP=109 integer, parameter :: OP_EXP=110, OP_LOG=111, OP_SIN=112, OP_COS=113, & OP_TAN=114, OP_ASIN=115, OP_ACOS=116, OP_ATAN=117, & OP_SQRT=118, OP_TRUNCATE=119, OP_ROUND=120, & OP_ABS=121, OP_EXPT=122 integer, parameter :: OP_MIN=123, OP_MAX=124, OP_INTOEX=125, OP_EXTOIN=126, & OP_RANDOM=127 integer, parameter :: OP_MKSTRING=128, OP_STRLEN=129, OP_STRREF=130, OP_STRSET=131, & OP_SUBSTR=132, OP_STRAPPEND=133, OP_STRSPLIT=134, & OP_STREQ=135, OP_STRLT=136, OP_STRGT=137, & OP_STRLE=138, OP_STRGE=139, OP_STRFIND=140, & OP_CHAR2INT=141, OP_INT2CHAR=142, & OP_UPCASE=143, OP_DOWNCASE=144, & OP_STR2NUM=145, OP_NUM2STR=146, & OP_SYM2STR=147, OP_STR2SYM=148 integer, parameter :: OP_SYSTEM=149, OP_IPORT=150, OP_OPORT=151, & OP_CLPORT=152, OP_CURR_INPORT=153, & OP_CURR_OUTPORT=154, OP_RDLINE=155, OP_FORMAT=156, & OP_FDATE=157, OP_TIME=158, OP_SYSCLOCK=159, & OP_GETENV=160, OP_INQUIRE=161, OP_ISATTY=162, & OP_LISTENV=163, OP_APROPOS=164, OP_HELP=165, & OP_VERSION=166, OP_GENSYM=167, OP_BOUND=168, & OP_READCH=169, OP_PEEKCH=170, OP_DELETE=171, & OP_DIR=172, OP_REGEXP=173, OP_PEEKMEM=174, & OP_DELVAR=175, OP_BIGOPS=176, OP_HASHOPS=177, & OP_DEBUG=178 integer, parameter :: OP_PNORM=401, OP_QNORM=402, OP_PCHISQ=403, & OP_QCHISQ=404, OP_PFDIST=405, OP_BIVNOR=406, & OP_GAMMAD=407, OP_ALNGAM=408, OP_PMVN=409, & OP_RNORM=410, OP_PCHISUM=411, OP_DBETA=412, & OP_LOGPNORM=413 #if !(FREESTANDING_SCHEME) integer, parameter :: OP_RUNCMD=501, OP_LSLOCI=502, OP_NLOCI=503, & OP_LOCNAM=504, OP_SETLOC=505, OP_LOCTYP=506, & OP_SETTYP=507, OP_LOCORD=508, OP_LOCSTAT=509, & OP_SETSTAT=510, OP_LOCNOTE=511, OP_SETNOTE=512, & OP_LOCRANK=513, OP_MAPPOS=514, OP_SETMAP=515, & OP_CHROM=516, OP_SETCHROM=517, OP_STATRES=518, & OP_INITSTAT=519, OP_LOCPOS=520, OP_SETPOS=521, & OP_HASHLOCI=522, OP_TYPSTAT=523 integer, parameter :: OP_NOBS=601, OP_NPEDS=602, OP_NACTPEDS=603, & OP_ACTPEDS=604, OP_ACTIVE=605, OP_SETACTIVE=606, & OP_PEDLIST=607, OP_PEDSIZE=608, OP_PEDMEMBERS=609, & OP_PEDIDX=610, OP_IDLIST=611, OP_IDIDX=612, & OP_FATHER=613, OP_MOTHER=614, OP_GETSEX=615, & OP_IMZTWIN=616, OP_GETDATA=617, OP_GETCOUNTS=618, & OP_GETALLELES=619, OP_IDSET=620, OP_PEDSET=621, & OP_SETSEX=622, OP_SETDATA=623, OP_SETFA=624, & OP_SETMO=625, OP_SETTWIN=626, OP_INSRECORD=627, & OP_SETCHOSEN=628 #endif integer, parameter :: OP_LISTTAIL=701, OP_LISTREF=702, OP_LISTSEL=703, & OP_MKLIST=704, OP_SAMPLE=705, OP_WHICH=706, & OP_GENSEQ=707, OP_ORDER=708, OP_SORT=709, & OP_RANK=710, OP_SUMSTATS=711, OP_QUANTILES=712, & OP_DIFFS=713, OP_CEILING=714, OP_FLOOR=715, & OP_LOG10=716, OP_LOWESS=717, OP_MODE=718, & OP_GLLM=719, OP_MAXIMIZE=720, OP_PROPER=721, & OP_CIRC=722 integer, parameter :: OP_CAAR=801, OP_CADR=802, OP_CDAR=803, OP_CDDR=804, & OP_CAAAR=805, OP_CAADR=806, OP_CADAR=807, OP_CADDR=808, & OP_CDAAR=809, OP_CDADR=810, OP_CDDAR=811, OP_CDDDR=812, & OP_CAAAAR=813, OP_CAAADR=814, OP_CAADAR=815, OP_CAADDR=816, & OP_CADAAR=817, OP_CADADR=818, OP_CADDAR=819, OP_CADDDR=820, & OP_CDAAAR=821, OP_CDAADR=822, OP_CDADAR=823, OP_CDADDR=824, & OP_CDDAAR=825, OP_CDDADR=826, OP_CDDDAR=827, OP_CDDDDR=828 integer, parameter :: OP_DUPS=901, OP_UNIQUE=902, OP_INTERSECT=903, & OP_SETDIFF=904, OP_BITAND=905, OP_BITIOR=906, & OP_BITXOR=907, OP_BITSHIFT=908, OP_BITSETP=909, & OP_BITFIELD=910, OP_BITNOT=911, OP_POPCNT=912 #if JAPI integer, parameter :: OP_JSTART=1001, OP_JQUIT=1002, OP_JFRAME=1003, & OP_JPANEL=1004, OP_JBORDERPANEL=1005, & OP_JDIALOG=1006, OP_JBUTTON=1007, & OP_JRADIOBUTTON=1008, OP_JRADIOGROUP=1009, & OP_JCHECKBOX=1010, OP_JLIST=1011, OP_JADD=1012, & OP_JSETCOLOR=1013, OP_JSETCOLORBG=1014, & OP_JSETNAMEDCOLORBG=1015, OP_JGETSELECT=1016, & OP_JSELECT=1017, OP_JDESELECT=1018, & OP_JFILESELECT=1019, OP_JFILEDIALOG=1020, & OP_JENABLE=1021, OP_JDISABLE=1022, OP_JADDITEM=1023, & OP_JSEPARATOR=1024, OP_JTEXTFIELD=1025, & OP_JTEXTAREA=1026, OP_JSETBORDERPOS=1027, & OP_JSETROWS=1028, OP_JSETCOLUMNS=1029, & OP_JGETROWS=1030, OP_JGETCOLUMNS=1031, & OP_JGETLENGTH=1032, OP_JGETSELSTART=1033, & OP_JGETSELEND=1034, OP_JSELECTTEXT=1035, & OP_JGETTEXT=1036, OP_JGETSELTEXT=1037, & OP_JGETITEM=1038, OP_JLABEL=1039, OP_JGETCURPOS=1040, & OP_JSETCURPOS=1041, OP_JSETFONT=1042, & OP_JSETTEXT=1043, OP_JINSERTTEXT=1044, & OP_JREPLACETEXT=1045, OP_JDELETE=1046, & OP_JDISPOSE=1047, OP_JMENUBAR=1048, OP_JMENU=1049, & OP_JMENUITEM=1050, OP_JPACK=1051, OP_JSHOW=1052, & OP_JHIDE=1053, OP_JKEYLISTENER=1054, & OP_JGETKEYCODE=1055, OP_JGETKEYCHAR=1056, & OP_JMOUSELISTENER=1057, OP_JGETMOUSEBUTTON=1058, & OP_JNEXTACTION=1059, OP_JGETWIDTH=1060, & OP_JGETHEIGHT=1061, OP_JGETPOS=1062, OP_JSETPOS=1063, & OP_JSETSIZE=1064, OP_JSETALIGN=1065, & OP_JSETBORDERLAYOUT=1066, OP_JSETGRIDLAYOUT=1067, & OP_JSETFLOWLAYOUT=1068 #endif #if EGGX integer, parameter :: OP_EGGETDISPLAYINFO=2001, OP_EGGOPEN=2002, & OP_EGGCLOSE=2003, OP_EGGCLOSEALL=2004, & OP_EGGNEWCOORDINATE=2005, OP_EGGNEWWINDOW=2006, & OP_EGGLAYER=2007, OP_EGGCOPYLAYER=2008, & OP_EGGSETBGCOLOR=2009, OP_EGGCLR=2010, & OP_EGGTCLR=2011, OP_EGGNEWPENCOLOR=2012, & OP_EGGNEWCOLOR=2013, OP_EGGNEWRGBCOLOR=2014, & OP_EGGNEWHSVCOLOR=2015, OP_EGGMAKECOLOR=2016, & OP_EGGNEWLINEWIDTH=2017, OP_EGGNEWLINESTYLE=2018, & OP_EGGPSET=2019, OP_EGGDRAWLINE=2020, & OP_EGGMOVETO=2021, OP_EGGDRAWPTS=2022, & OP_EGGDRAWLINES=2023, OP_EGGDRAWPOLY=2024, & OP_EGGFILLPOLY=2025, OP_EGGDRAWRECT=2026, & OP_EGGFILLRECT=2027, OP_EGGDRAWCIRC=2028, & OP_EGGFILLCIRC=2029, OP_EGGDRAWARC=2030, & OP_EGGFILLARC=2031, OP_EGGDRAWSYM=2032, & OP_EGGDRAWSYMS=2033, OP_EGGDRAWARROW=2034, & OP_EGGNEWFONTSET=2035, OP_EGGDRAWSTR=2036, & OP_EGGDRAWNUM=2037, OP_EGGPUTIMG24=2038, & OP_EGGSAVEIMG=2039, OP_EGGSETNONBLOCK=2040, & OP_EGGETCH=2041, OP_EGGETEVENT=2042, & OP_EGGETXPRESS=2043, OP_EGGLINETO=2044 #endif ! ! Base for bignum storage ! integer, parameter :: bigbase = 18 integer (kind=8), parameter :: rbase = 10_8 ** bigbase double precision, parameter :: rbigbase = 10.0d0 ** bigbase double precision, parameter :: lbigbase = log(10.0d0 ** bigbase) character (len=8), parameter :: bigbase_fmt = '(i18.18)' integer :: cell_segment = 5000 integer :: gc_verbosity = 0 integer (kind=8):: cpu_t1, cpu_t2 integer :: infp=STDIN integer :: outfp=STDOUT integer :: currentline=0, eol=0 ! ! Scheme memory cell ! iflag is cell type T_FREE..T_MOVED ! value is number, either integer or transfer()'ed real ! slength, svalue is a character string ! keynum is procedure number or number type ! car, cdr point to preceding and succeeding cells ! type mcell integer :: iflag integer (kind=8) :: value integer :: slength character, dimension(:), allocatable :: svalue integer :: keynum integer :: car integer :: cdr end type mcell ! Special addresses integer :: nil=1 ! special cell representing empty cell integer :: t=2 ! special cell representing #t integer :: f=3 ! special cell representing #f integer :: un=4 ! special cell representing #unspecified integer :: global_env=1 ! pointer to global environment integer :: lambda=1 ! pointer to syntax lambda integer :: quote=1 integer :: qquote=1 integer :: unquote=1 integer :: unquotesp=1 integer :: feedto=1 ! registers integer :: scm_args=1 integer :: code=1 integer :: dump=1 integer :: envir=1 ! additional registers for native routines notably bignum arithmetic integer :: reg1=1 integer :: reg2=1 integer :: reg3=1 integer :: reg4=1 integer :: reg5=1 integer :: reg6=1 integer :: reg7=1 integer :: reg8=1 integer :: reg9=1 integer :: reg10=1 ! save state integer :: cont=1 ! pointer to symbol table integer :: oblist=1 ! ! Evaluator globals ! integer :: oper=1 ! current operation integer :: tok=1 ! current token integer :: value=1 ! value of current expression integer :: print_flag=1 ! print expression ! ! Memory is memsiz array of mcells: mem(memsiz) ! ! memsiz = current maximum allocatable cells ! nextfree= address of next free cell ! fcells = number of free cells ! integer :: memsiz type (mcell), dimension(:), allocatable :: mem integer :: nextfree integer :: fcells ! ! hash of symbol table type (hash_table) :: objhash ! ! Array of hash objects ! type scm_ht type (hash_table) :: ht character(len=:), allocatable :: note integer :: nrecords = 0 integer, dimension(:,:), allocatable :: m_address end type scm_ht integer :: n_scmhash = 0 type (scm_ht), dimension(:), allocatable :: scmhash integer :: nexthash = 0 ! ! i/o streams ! integer, parameter :: MAXPORT=5 integer, dimension(5) :: portaddress = (/21, 22, 23, 24, 25/) integer :: nports = 0 integer :: nloaded = 0 character (len=512) :: loadfil integer, dimension(0:5) :: loadaddress = (/STDIN,0,0,0,0,0/) type(mcell), dimension(5) :: rest_of_lin ! ! interactive debugging ! integer :: scm_debug = 0 contains ! Memory management ! ! copy contents of a to b subroutine copy_mem(a, b) type (mcell), dimension(:) :: a, b integer :: siza, sizb, slen siza=size(a) sizb=size(b) if (siza > sizb) return do j=1, siza b(j)%iflag=a(j)%iflag b(j)%value=a(j)%value slen=a(j)%slength b(j)%slength=slen if (slen > 0) then allocate(b(j)%svalue(slen)) b(j)%svalue=a(j)%svalue end if b(j)%keynum=a(j)%keynum b(j)%car=a(j)%car b(j)%cdr=a(j)%cdr end do end subroutine copy_mem ! subroutine init_mem(a, sta, fin) type (mcell), dimension(:) :: a integer, intent(in) :: sta, fin integer :: j, siza siza=size(a) do j=max(1, sta), min(siza, fin) a(j)%iflag=T_FREE a(j)%value=0 a(j)%slength=0 a(j)%keynum=0 a(j)%car=nil a(j)%cdr=nil end do end subroutine init_mem ! ! allocate cells for main memory object mem ! subroutine setup_mem(siz) integer, intent(in) :: siz type (mcell), dimension(:), allocatable :: tmpmem integer :: j, slen if (.not.allocated(mem)) then memsiz=siz allocate(mem(memsiz)) call init_mem(mem, 1, siz) mem(nil)%iflag=ior(T_ATOM, T_MARK) mem(t)%iflag=ior(T_ATOM, T_MARK) mem(f)%iflag=ior(T_ATOM, T_MARK) mem(un)%iflag=ior(T_ATOM, T_MARK) nextfree=5 fcells=memsiz-5 else if (siz > memsiz) then allocate(tmpmem(memsiz)) call copy_mem(mem, tmpmem) call cleanup_mem() allocate(mem(siz)) call copy_mem(tmpmem,mem) call cleanup_bank(memsiz+1, siz) call init_mem(mem, memsiz+1, siz) deallocate(tmpmem) if (nextfree == nil) then nextfree=memsiz+1 fcells=siz-memsiz end if memsiz=siz end if end subroutine setup_mem ! ! Clean up memory arrays ! ! Zero a block of cells, including deallocating strings ! subroutine cleanup_bank(sta, fin) integer, intent(in) :: fin, sta integer :: j do j=sta, fin if (allocated(mem(j)%svalue)) then deallocate(mem(j)%svalue) mem(j)%slength=0 end if mem(j)%iflag=T_FREE mem(j)%value=0 mem(j)%keynum=0 mem(j)%car=nil mem(j)%cdr=nil end do end subroutine cleanup_bank ! ! Free all memory ! subroutine cleanup_mem() call cleanup_bank(1, memsiz) deallocate(mem) end subroutine cleanup_mem ! ! free up registers subroutine cleanup_regs() reg1=nil reg2=nil reg3=nil reg4=nil reg5=nil reg6=nil reg7=nil reg8=nil reg9=nil reg10=nil cont=nil end subroutine cleanup_regs ! subroutine setup_scmhash(siz) integer, intent(in) :: siz integer :: old type (scm_ht), dimension(:), allocatable :: tmp integer :: i if (allocated(scmhash)) then old=n_scmhash n_scmhash = siz call move_alloc(scmhash, tmp) allocate(scmhash(n_scmhash)) do i=1, min(old, n_scmhash) scmhash(i)=tmp(i) end do deallocate(tmp) if (nexthash > n_scmhash) nexthash=n_scmhash else allocate (scmhash(siz)) n_scmhash = siz nexthash=1 end if end subroutine setup_scmhash subroutine cleanup_scmhash(which) integer, intent(in) :: which if (which == 0) then do i=1, n_scmhash call cleanup_hash(scmhash(i)%ht) deallocate(scmhash(i)%note) deallocate(scmhash(i)%m_address) end do n_scmhash=0 nexthash=0 else call cleanup_hash(scmhash(which)%ht) deallocate(scmhash(which)%note) deallocate(scmhash(which)%m_address) if (which < n_scmhash) then do i=which+1, n_scmhash scmhash(i-1)=scmhash(i) end do end if nexthash=nexthash-1 end if end subroutine cleanup_scmhash ! ! Save memory image ! subroutine save_scheme_image(strm, ios) integer, intent(in) :: strm integer, intent(out) :: ios integer :: i ios=0 write(strm, iostat=ios) 'Sib-pair Scheme ' // scheme_version if (ios /= 0) return write(strm, iostat=ios) memsiz, nextfree, fcells if (ios /= 0) return write(strm) nil, t, f, un, & global_env, lambda, quote, qquote, unquote, unquotesp, feedto, & scm_args, code, dump, envir, oblist, oper, tok, value, & print_flag do i=1, memsiz write(strm) mem(i)%iflag, mem(i)%value, mem(i)%slength if (mem(i)%slength > 0) then write(strm) mem(i)%svalue(1:mem(i)%slength) end if write(strm) mem(i)%keynum, mem(i)%car, mem(i)%cdr end do end subroutine save_scheme_image ! ! Read memory image ! subroutine read_scheme_image(strm, ios) integer, intent(in) :: strm integer, intent(out) :: ios character (len=21) :: slin integer :: i, newmemsiz, newfree, newcells ! old dataset images do not contain a Scheme image - quietly abort read(strm, iostat=ios) slin if (ios /= 0 .or. slin /= 'Sib-pair Scheme ' // scheme_version) then ios=0 return end if call cleanup_mem() read(strm, iostat=ios) newmemsiz, newfree, newcells if (ios /= 0) return call setup_mem(newmemsiz) nextfree=newfree fcells=newcells read(strm) nil, t, f, un, & global_env, lambda, quote, qquote, unquote, unquotesp, feedto, & scm_args, code, dump, envir, oblist, oper, tok, value, & print_flag do i=1, memsiz read(strm) mem(i)%iflag, mem(i)%value, mem(i)%slength if (mem(i)%slength > 0) then allocate(mem(i)%svalue(mem(i)%slength)) read(strm) mem(i)%svalue(1:mem(i)%slength) end if read(strm) mem(i)%keynum, mem(i)%car, mem(i)%cdr end do end subroutine read_scheme_image ! ! inspect memory ! subroutine show_mem(plevel) integer, intent(in) :: plevel integer :: i logical :: check write(*,'(/3a,i0)') 'prompt "', prompt_string, '" input stream=', infp write(*,'(3a,i0)') 'curr cmd "', scheme_lin(1:eol), '" at ', currentline write(*,'(a,i0)') 'current op ', oper write(*,'(a,i0)') 'curr token ', tok write(*,'(a,i0)') 'curr value ', value write(*,'(a,i0)') 'memsiz ', memsiz write(*,'(a,i0)') 'free cells ', fcells call show_mdata('oblist ', oblist) call show_mdata('global_env ', car(global_env)) call show_mdata('envir ', car(envir)) call show_mdata('value ', value) call show_mdata('scm_args ', scm_args) call show_mdata('code ', code) call show_mdata('dump ', dump) call show_mdata('reg1 ', reg1, 1) call show_mdata('reg2 ', reg2, 1) call show_mdata('reg3 ', reg3, 1) call show_mdata('reg4 ', reg4, 1) call show_mdata('reg5 ', reg5, 1) call show_mdata('reg6 ', reg6, 1) call show_mdata('reg7 ', reg7, 1) call show_mdata('reg8 ', reg8, 1) call show_mdata('reg9 ', reg9, 1) call show_mdata('reg10 ', reg10, 1) call show_mdata('cont ', cont, 1) if (plevel > 0) then write(*,'(a)') 'Looking for circular lists...' do i=1, memsiz if (ispair(i)) then check=iscirc(i) if (check) then write(*,'(a,i0,a)') 'Circular list at cell ', i,'!' end if end if end do end if end subroutine show_mem subroutine show_mdata(note, i, drop_nil) character(len=*) :: note integer, intent(in) :: i integer, intent(in), optional :: drop_nil integer :: isiz, j, n, x logical :: show character (len=9) :: mempos show=.true. if (present(drop_nil)) then show=.not.(drop_nil > 0) end if if (show .or. i /= nil) then write(mempos,'(a,i0,a)') '<', i, '>' write(*,'(2a)', advance='no') note, mempos if (isbignum(i)) then call bigprint(i, advance='yes') else if (isstring(i)) then write(*,'(1x,3a)') '"', get_string(i), '"' else isiz=object_size(i) write(*,'(i0,a)', advance='no') isiz, ' cell' if (isiz /= 1) write(*,'(a1)',advance='no') 's' if (ispair(i)) then n=get_listlen(i) write(*,'(a,i0)',advance='no') ' len=', n x=i do j=1, min(3, n-1) x=cdr(x) write(*,'(a,i0,a)', advance='no') ' <', x, '>' end do if (n > 4) write(*,'(a)', advance='no') '...' end if write(*,*) end if end if end subroutine show_mdata function show_memcell(i, depth) integer :: show_memcell integer, intent(in) :: i integer, intent(in), optional :: depth integer :: icell, j, n, nb, maxdepth, icar, typ integer, dimension(10) :: iback logical :: follow character(len=256) :: str character(len=8) :: val double precision :: rv if (i == 1) then write(*,'(a)') 'nil' return end if call update_env() n=0 nb=1 icell=i iback(nb)=nil maxdepth=10 if (present(depth)) then maxdepth=depth end if do while (icell /= nil .and. n < maxdepth) follow=.true. str='' typ=mem(icell)%iflag if (icell == oblist) then write(*,'(a8,1x,i6)', advance='no') 'oblist', typ else if (icell == global_env) then write(*,'(a8,1x,i6)', advance='no') 'env', typ else write(*,'(i8,1x,i6)', advance='no') icell, typ end if if (and(mem(icell)%iflag, T_ATOM) == T_ATOM) then typ=xor(typ,T_ATOM) str='at,' end if if (typ == 0) then str=trim(str) // 'free' else if (typ == 1) then str=trim(str) // 'string' else if (btest(typ,1)) then if (btest(mem(icell)%keynum,2)) then str=trim(str) // 'bignum' else str=trim(str) // 'number' end if else if (btest(typ,2)) then str=trim(str) // 'symbol' else if (btest(typ,3)) then str=trim(str) // 'syntax' else if (btest(typ,4)) then str=trim(str) // 'proc' else if (btest(typ,11)) then str=trim(str) // 'hash' else if (typ == 32) then str=trim(str) // 'pair' else if (typ == 64) then str=trim(str) // 'closure' else if (typ == 128) then str=trim(str) // 'contin' else if (typ == 256) then str=trim(str) // 'macro' else if (typ == 512) then str=trim(str) // 'prom' else if (typ == 2048) then str=trim(str) // 'port' end if write(*,'(1x,a12)', advance='no') str if (mem(icell)%keynum /= 0) then write(*,'(1x,a,i0)', advance='no') 'key=', mem(icell)%keynum end if write(*,'(2(1x,a,i0))', advance='no') & 'car=', mem(icell)%car, 'cdr=', mem(icell)%cdr if (btest(typ,1)) then write(*,'(t10,a)', advance='no') 'value=' follow=.not.btest(mem(icell)%keynum,2) call printatom(icell, 0, -1, 0, ' ') write(*,*) else if (btest(typ,2)) then icar=mem(icell)%car write(*,'(t10,a,40a1:)') 'value=', (mem(icar)%svalue(j), j=1,mem(icar)%slength) follow=.false. else if (mem(icell)%slength > 0) then write(*,'(t10,a,40a1:)') 'value="', (mem(icell)%svalue(j), j=1,mem(icell)%slength),'"' else write(*,*) end if if (follow .and. mem(icell)%car /= nil) then if (mem(icell)%cdr /= nil) then nb=nb+1 iback(nb)=mem(icell)%cdr end if icell=mem(icell)%car else if (follow .and. mem(icell)%cdr /= nil) then icell=mem(icell)%cdr else icell=iback(nb) nb=nb-1 end if n=n+1 end do show_memcell=icell end function show_memcell ! ! interactively browse memory ! subroutine mem_browse() use scanner character(len=80) :: lin character(len=20), dimension(4) :: words integer :: curr, i, j, narg logical :: is_strict_int curr=1 do write(*,'(a)', advance='no') '-> ' read(*,'(a)') lin narg=size(words) call args(lin, narg, words, ' ', SEP_WHITE) if (words(1) == 'c') exit if (words(1) == 'q') exit if (words(1)(1:3) == 'pee') then if (narg == 1) then call show_mem(1) curr=1 else if (words(2) == 'dump') then curr=show_memcell(i, dump) else if (words(2) == 'dir') then call list_objects(1) else if (is_strict_int(words(2))) then i=ival(words(2)) if (narg == 3) then j=ival(words(3)) curr=show_memcell(i, j) else curr=show_memcell(i) end if end if else if (words(1) == ' ' .and. curr /= 1) then curr=show_memcell(curr) end if end do end subroutine mem_browse ! ! Mark-sweep garbage collector ! ! Mark cells to be saved ! subroutine gc_mark(a) integer, intent(in) :: a integer :: p, q, t t=nil p=a 20 continue call setmark(p) if (isatom(p)) goto 60 q=car(p) if (q /= nil .and. .not.ismark(q)) then call setatom(p) call set_car(p, t) t=p p=q goto 20 end if 50 continue q=cdr(p) if (q /= nil .and. .not.ismark(q)) then call set_cdr(p, t) t=p p=q goto 20 end if 60 continue if (t == nil) return q=t if (isatom(q)) then call clratom(q) t=car(q) call set_car(q, p) p=q goto 50 else t=cdr(q) call set_cdr(q, p) p=q goto 60 end if end subroutine gc_mark ! ! Copy all registers to free memory ! Reset pointers from old addresses to new addresses ! subroutine gc(a, b, plevel, note) integer :: a, b integer, intent(in) :: plevel character(len=*), optional :: note integer :: i logical :: check integer :: nh integer, dimension(:), allocatable :: hlists if (plevel > 0 .and. present(note)) then write(outstr,'(3a)') 'GC triggered due ', note, '.' end if call system_clock(cpu_t1) nextfree=1 call gc_mark(nil) call gc_mark(t) call gc_mark(f) call gc_mark(un) call gc_mark(oblist) call gc_mark(global_env) call gc_mark(envir) call gc_mark(value) call gc_mark(scm_args) call gc_mark(code) call gc_mark(dump) call gc_mark(reg1) call gc_mark(reg2) call gc_mark(reg3) call gc_mark(reg4) call gc_mark(reg5) call gc_mark(reg6) call gc_mark(reg7) call gc_mark(reg8) call gc_mark(reg9) call gc_mark(reg10) call gc_mark(cont) call gc_mark(a) call gc_mark(b) call clrmark(nil) fcells=0 nextfree=nil nh=0 allocate(hlists(n_scmhash)) do i=1, memsiz if (ismark(i)) then call clrmark(i) if (ishash(i)) then nh=nh+1 hlists(nh)=i end if else call cleanup_bank(i, i) call set_cdr(i, nextfree) nextfree = i fcells=fcells+1 end if end do ! have to repoint symbol table hash and other hash-tables call hash_env() if (plevel > 1) then write(outstr,'(a,i0,a)') ';; Updating ', nh, ' hash tables.' end if do i=1, nh call rehash_scmhash(hlists(i)) end do deallocate(hlists) if (plevel > 0) then call system_clock(cpu_t2) write(outstr,'(a,i0,a,i0,a,i0,a)') & ';; GC recovered ', fcells, ' of ', memsiz, ' cells in ', & (cpu_t2-cpu_t1)/1000000, ' ms.' end if end subroutine gc ! ! Get next free cell ! function getcell(a, b, note) integer :: getcell integer, intent(in) :: a, b character (len=*) :: note integer :: newsiz, x if (nextfree == nil) then call gc(a, b, gc_verbosity, note) if (fcells < memsiz/2) then newsiz=memsiz+cell_segment call setup_mem(newsiz) call gc(a, b, gc_verbosity, note) end if end if x=nextfree nextfree=cdr(x) fcells=fcells-1 call set_car(x, nil) call set_cdr(x, nil) getcell=x end function getcell ! ! Cell type operations ! subroutine copy_cell(x, y) integer, intent(in) :: x, y integer :: slen mem(y)%iflag=mem(x)%iflag mem(y)%value=mem(x)%value slen=mem(x)%slength mem(y)%slength=slen if (slen > 0) then allocate(mem(y)%svalue(slen)) mem(y)%svalue=mem(x)%svalue end if mem(y)%keynum=mem(x)%keynum mem(y)%car=mem(x)%car mem(y)%cdr=mem(x)%cdr end subroutine copy_cell ! ! Setting values ! subroutine set_type(p, iflag) integer, intent(in) :: p integer, intent(in) :: iflag mem(p)%iflag=iflag end subroutine set_type subroutine set_ivalue(p, ivalue) integer, intent(in) :: p integer (kind=8), intent(in) :: ivalue mem(p)%value=ivalue mem(p)%keynum=1 end subroutine set_ivalue subroutine set_value(p, val) integer, intent(in) :: p double precision, intent(in) :: val mem(p)%value=transfer(val, mem(p)%value) mem(p)%keynum=2 end subroutine set_value subroutine set_as_number(p) integer, intent(in) :: p mem(p)%iflag=ior(T_ATOM, T_NUMBER) mem(p)%keynum=1 end subroutine set_as_number subroutine set_sign(p, i) integer, intent(in) :: i, p if (btest(mem(p)%keynum,2)) then mem(p)%keynum=4 if (i < 0) mem(p)%keynum=mem(p)%keynum+8 else mem(p)%value=sign(mem(p)%value,int(i,kind=8)) end if end subroutine set_sign subroutine set_as_bigval(p) integer, intent(in) :: p mem(p)%iflag=ior(T_PAIR, T_NUMBER) mem(p)%keynum=4 end subroutine set_as_bigval subroutine set_string(p, str) integer, intent(in) :: p character (len=*), intent(in) :: str integer :: i, slen if (allocated(mem(p)%svalue)) then deallocate(mem(p)%svalue) end if slen=len(str) mem(p)%slength=slen allocate(mem(p)%svalue(slen)) do i=1, slen mem(p)%svalue(i)=str(i:i) end do end subroutine set_string subroutine set_substring(p, sta, fin, str) integer, intent(in) :: p integer, intent(in) :: fin, sta character (len=*), intent(in) :: str integer :: i, pos pos=0 do i=sta, min(mem(p)%slength, fin) pos=pos+1 mem(p)%svalue(i)=str(pos:pos) end do end subroutine set_substring ! subroutine set_car(p, icar) integer, intent(in) :: icar, p mem(p)%car=icar end subroutine set_car subroutine set_cdr(p, icdr) integer, intent(in) :: icdr, p mem(p)%cdr=icdr end subroutine set_cdr subroutine set_caar(p, icaar) integer, intent(in) :: icaar, p mem(mem(p)%car)%car=icaar end subroutine set_caar subroutine set_cadr(p, icadr) integer, intent(in) :: icadr, p mem(mem(p)%cdr)%car=icadr end subroutine set_cadr subroutine set_cdar(p, icdar) integer, intent(in) :: icdar, p mem(mem(p)%car)%cdr=icdar end subroutine set_cdar subroutine set_syntaxnum(p, op) integer :: op, p mem(p)%keynum=op end subroutine set_syntaxnum ! ! Getting values ! function get_ivalue(p) integer (kind=8) :: get_ivalue integer, intent(in) :: p get_ivalue=mem(p)%value end function get_ivalue ! function rvalue(p) double precision :: rvalue integer, intent(in) :: p double precision :: base, res integer :: x if (btest(mem(p)%keynum,1)) then rvalue=transfer(mem(p)%value, rvalue) else if (btest(mem(p)%keynum,2)) then base=1.0d0 res=0.0d0 x=p do while (ispair(x)) res=res + base*dfloat(mem(mem(x)%car)%value) base=base*rbigbase x=cdr(x) end do rvalue=getsign(p)*res else rvalue=real(mem(p)%value, kind=8) end if end function rvalue function getsign(p) integer :: getsign integer, intent(in) :: p integer :: sgn sgn=1 if (btest(mem(p)%keynum,2)) then if (btest(mem(p)%keynum,3)) then sgn=-1 end if else sgn=int(sign(1_8, mem(p)%value), kind=4) end if getsign=sgn end function getsign ! ! Strings ! function get_string(p) integer, intent(in) :: p character (len=mem(p)%slength) :: get_string integer :: i get_string=' ' if (mem(p)%slength > 0) then do i=1, mem(p)%slength get_string(i:i)=mem(p)%svalue(i) end do end if end function get_string ! ! Append to existing string ! subroutine append_string(p, str) integer, intent(in) :: p character (len=*), intent(in) :: str character (len=mem(p)%slength) :: buff integer :: i, slen, sta slen=len(str) if (.not.allocated(mem(p)%svalue)) then sta=0 mem(p)%slength=slen allocate(mem(p)%svalue(slen)) else buff=get_string(p) sta=mem(p)%slength mem(p)%slength=sta+slen deallocate(mem(p)%svalue) allocate(mem(p)%svalue(sta+slen)) end if do i=1, sta mem(p)%svalue(i)=buff(i:i) end do do i=1, slen mem(p)%svalue(sta+i)=str(i:i) end do end subroutine append_string #if !(FREESTANDING_SCHEME) ! ! Append to existing Scheme string from table cell string ! subroutine append_cell_string(p, cell) use contingency_table integer, intent(in) :: p type (table_cell), intent(in) :: cell character (len=mem(p)%slength) :: buff integer :: i, slen, sta slen=cell%slength if (.not.allocated(mem(p)%svalue)) then sta=0 mem(p)%slength=slen allocate(mem(p)%svalue(slen)) else buff=get_string(p) sta=mem(p)%slength mem(p)%slength=sta+slen deallocate(mem(p)%svalue) allocate(mem(p)%svalue(sta+slen)) end if do i=1, sta mem(p)%svalue(i)=buff(i:i) end do do i=1, slen mem(p)%svalue(sta+i)=cell%svalue(i) end do end subroutine append_cell_string #endif ! ! substring ! function get_substr(p, sta, fin) integer, intent(in) :: p, sta, fin character (len=(fin-sta)) :: get_substr integer :: i, j, slen get_substr=' ' slen=mem(p)%slength if (slen > 0) then j=0 do i=sta, min(slen,fin)-1 j=j+1 get_substr(j:j)=mem(p)%svalue(i+1) end do end if end function get_substr ! String length function get_strlen(p) integer :: get_strlen integer, intent(in) :: p get_strlen=mem(p)%slength end function get_strlen ! ! Is proper list? ! function isproper(p) logical :: isproper integer :: p integer :: lag, x x=p lag=p isproper=isproper2(x, lag) end function isproper recursive function isproper2(x, lag) result (res) logical :: res integer :: x, y, z, lag if (ispair(x)) then y=cdr(x) if (ispair(y)) then z=cdr(y) lag=cdr(lag) res=(z /= lag) if (res) res=isproper2(z, lag) else res=(y == nil) end if else res=(x == nil) end if end function isproper2 ! ! Is circ list? ! function iscirc(p) logical :: iscirc integer :: p integer :: lag, x x=p lag=p iscirc=iscirc2(x, lag) end function iscirc recursive function iscirc2(x, lag) result (res) logical :: res integer :: x, y, z, lag res=ispair(x) if (res) then y=cdr(x) res=ispair(y) if (res) then z=cdr(y) lag=cdr(lag) res=(z == lag) if (.not.res) res=iscirc2(z, lag) end if end if end function iscirc2 function object_size(p) integer :: object_size integer, intent(in) :: p integer :: i, n n=0 object_size=n if (p < 1 .or. p > memsiz) return call gc_mark(p) do i=1, memsiz if (ismark(i)) then n=n+1 call clrmark(i) end if end do object_size=n end function object_size ! ! List length ! function get_listlen(p) integer :: get_listlen integer :: p integer :: l, x l=0 x=p do while (ispair(x)) l=l+1 x=cdr(x) end do if (x /= nil) l=-1 get_listlen=l end function get_listlen ! ! memory location of kth list item ! function get_listtail(p, idx) integer :: get_listtail integer :: p, idx integer :: l, x l=0 x=p do while (ispair(x) .and. l < idx) l=l+1 x=cdr(x) end do get_listtail=x end function get_listtail ! ! is homogenous list of given type? ! function ishomog(p, typfun) logical :: ishomog integer :: p logical :: typfun integer :: x ishomog=.true. x=p do while (ispair(x)) if (.not.typfun(car(x))) then ishomog=.false. return end if x=cdr(x) end do end function ishomog ! ! homogenous list to Fortran array ! subroutine get_carray(p, n, strings, width) integer, intent(in) :: p integer, intent(in) :: n, width character (len=width), dimension(n), intent(out) :: strings integer :: i, x strings=' ' i=0 x=p do while (ispair(x) .and. i < n) i=i+1 strings(i)=get_string(car(x)) x=cdr(x) end do end subroutine get_carray ! subroutine get_iarray(p, n, r) integer, intent(in) :: p integer, intent(in) :: n integer, dimension(n), intent(out) :: r integer :: i, x r=0 i=0 x=p do while (ispair(x) .and. i < n) i=i+1 r(i)=get_ivalue(car(x)) x=cdr(x) end do end subroutine get_iarray ! ! Can drop or include missing values defined as nan or non-numeric ! subroutine get_rarray(p, n, r, missing, drop_missing) #if SUN use, intrinsic :: ieee_arithmetic use, intrinsic :: ieee_exceptions #endif integer, intent(in) :: p integer, intent(inout) :: n double precision, dimension(n), intent(out) :: r double precision, intent(in), optional :: missing logical, intent(in), optional :: drop_missing integer :: i, x logical :: drop double precision :: misval, val misval=0.0d0 drop=.false. if (present(drop_missing)) drop=drop_missing r=misval i=0 x=p if (present(missing)) then misval=missing do while (ispair(x) .and. i < n) i=i+1 if (isnumber(car(x))) then val=rvalue(car(x)) #if SUN if (ieee_is_nan(val)) val=misval #else if (isnan(val)) val=misval #endif r(i)=val end if x=cdr(x) end do else if (drop) then do while (ispair(x) .and. i < n) if (isnumber(car(x))) then val=rvalue(car(x)) #if SUN if (.not.ieee_is_nan(val)) then #else if (.not.isnan(val)) then #endif i=i+1 r(i)=rvalue(car(x)) end if end if x=cdr(x) end do n=i else do while (ispair(x) .and. i < n) i=i+1 r(i)=rvalue(car(x)) x=cdr(x) end do end if end subroutine get_rarray ! ! append fortran integer array values to list ! subroutine append_iarray(ivals, res) integer :: res integer, dimension(:) :: ivals integer :: i, tmp do i=size(ivals), 1, -1 tmp=getcell(res, nil, 'append_iarray') call set_type(tmp, ior(T_NUMBER, T_ATOM)) call set_ivalue(tmp, int(ivals(i), kind=8)) res=cons(tmp, res) end do end subroutine append_iarray ! ! append fortran double precision array values to list ! subroutine append_rarray(rvals, res) integer :: res double precision, dimension(:) :: rvals integer :: i, nvals, tmp nvals=size(rvals) call gc(res, nil, gc_verbosity) if (nvals > fcells) then call setup_mem(nvals+memsiz) end if do i=size(rvals), 1, -1 tmp=getcell(res, nil, 'append_rarray') call set_type(tmp, ior(T_NUMBER, T_ATOM)) call set_value(tmp, rvals(i)) res=cons(tmp, res) end do end subroutine append_rarray #if !(FREESTANDING_SCHEME) ! ! allowing access to Scheme environment from Sib-pair ! accessible variables are atomic or list of atomic variables ! result inserted into passed string ! subroutine get_var(string, pos, fin, istat) character (len=*), intent(inout) :: string integer, intent(inout) :: pos, fin integer, intent(out) :: istat integer :: eos, i, idx, j, k, newlen, reslen, slen, tmp, & varend, varsta, x, y character (len=1) :: ch character (len=40) :: cbuff, srch_str slen=len(string) eos=len_trim(string) idx=0 istat=0 srch_str=' ' varsta=pos+1 varend=fin if (string(varsta:varsta) == '(') varsta=varsta+1 if (string(varend:varend) == ')') varend=varend-1 k=fin+1 ch=string(k:k) do while (ch == ' ' .and. k < eos) k=k+1 ch=string(k:k) end do if (ch == '[') then i=k call findbracket('[',']',string, i, j, istat) if (istat==0 .and. i > 1 .and. j > (i+1)) then fin=j i=i+1 j=j-1 do while (string(i:i) == ' ') i=i+1 end do if (string(i:i) == '"') i=i+1 do while (string(j:j) == ' ') j=j-1 end do if (string(j:j) == '"') j=j-1 srch_str=string(i:j) if (verify(string(i:j), '0123456789') == 0) then read(string(i:j), '(i20)') idx end if end if end if if (varsta <= varend) then x=whereis(string(varsta:varend)) y=x if (x /= nil) then if (ishash(x)) then if (srch_str /= ' ') then i=get_ivalue(x) y=find_scmhash(scmhash(i), string=trim(srch_str)) if (y == 0) then y=1 istat=-4 goto 999 else y=scmhash(i)%m_address(y,2) end if else istat=-5 goto 999 end if else if (ispair(x)) then if (idx > 0) then y=get_listtail(x, idx-1) if (y == nil) then istat=-4 goto 999 else y=car(y) end if else istat=-5 goto 999 end if end if reslen=0 cbuff=' ' if (isstring(y) .or. isport(y)) then istat=1 reslen=get_strlen(y) else if (isnumber(y)) then istat=2 if (isinteger(y)) then write(cbuff, '(i20)') get_ivalue(y) reslen=len_trim(adjustl(cbuff)) else write(cbuff, '(g20.12)') rvalue(y) reslen=len_trim(adjustl(cbuff)) end if else if (x == t) then cbuff='1' reslen=1 else if (x == f) then cbuff='0' reslen=1 end if newlen=reslen+eos-fin+pos-1 if (slen > newlen) then if (istat==1) then string=string(1:(pos-1)) // & get_string(y) // & string((fin+1):eos) else string=string(1:(pos-1)) // & trim(adjustl(cbuff)) // & string((fin+1):eos) end if pos=pos+reslen+2 else istat=-2 end if else istat=-1 end if else istat=-3 end if ! ! If failed substitution, close up variable in input string ! 999 continue if (istat < 0) then string=string(1:(pos-1)) // string((fin+1):eos) pos=pos-1 end if end subroutine get_var #endif ! ! Call a Scheme function from fortran ! returns one real number ! function scmfun(fname, npar, pars) result (res) use iobuff double precision :: res character(len=*), intent(in) :: fname integer, intent(in) :: npar double precision, dimension(:) :: pars integer :: curval, i, x character(len=80) :: buff cont=cons(envir, dump) cont=cons(scm_args, cont) cont=cons(code, cont) cont=cons(mk_number(int(oper, kind=8)), cont) cont=cons(value, cont) call save_linbuffer(ioerr) scheme_lin='(define scm_fun_result (list (' // fname // ' (list ' do i=1, npar write(buff,*) pars(i) scheme_lin=trim(scheme_lin) // ' ' // trim(buff) end do scheme_lin=trim(scheme_lin) // ')) ' // fname // ' (list ' do i=1, npar write(buff,*) pars(i) scheme_lin=trim(scheme_lin) // ' ' // trim(buff) end do scheme_lin=trim(scheme_lin) // ')))' call repl_scheme(4,0) call restore_linbuffer(ioerr) infp=loadaddress(nloaded) value = car(cont) x=cdr(cont) oper = get_ivalue(car(x)) x=cdr(x) scm_args = car(x) x=cdr(x) code = car(x) x=cdr(x) envir = car(x) dump = cdr(x) i=find_objhash('scm_fun_result', 'e') res=rvalue(car(i)) cont=nil end function scmfun #if !(FREESTANDING_SCHEME) ! ! Direct access to scheme string atoms from fortran ! subroutine get_string_var(vname, string, cell, length, istat) use contingency_table character (len=*), intent(in) :: vname character (len=*), intent(out), optional :: string type (table_cell), intent(out), optional :: cell integer, intent(out), optional :: length integer, intent(out), optional :: istat integer :: i, obj, s, w, x, y if (present(istat)) istat=0 if (present(length)) length=0 if (present(string)) string='' if (present(cell)) then call set_table_cell(cell, string='') end if obj=oblist do while (obj /= nil) s=car(obj) x=global_env do while (x /= nil) y=car(x) do while (y /= nil) if (caar(y) == s) then if (isstring(cdar(y))) then if (get_string(car(s)) == vname) then if (present(length)) then length=get_strlen(cdar(y)) end if if (present(string)) then string=get_string(cdar(y)) end if if (present(cell)) then call set_table_cell(cell, string=get_string(cdar(y))) end if return end if end if exit end if y=cdr(y) end do if (y /= nil) exit x=cdr(x) end do obj=cdr(obj) end do if (present(istat)) istat=-1 end subroutine get_string_var ! ! from fortran directly append to a scheme string atom ! subroutine append_string_var(vname, string, cell) use contingency_table character (len=*), intent(in) :: vname character (len=*), intent(in), optional :: string type (table_cell), intent(in), optional :: cell integer :: i, obj, s, w, x, y obj=oblist do while (obj /= nil) s=car(obj) x=global_env do while (x /= nil) y=car(x) do while (y /= nil) if (caar(y) == s) then if (isstring(cdar(y))) then if (get_string(car(s)) == vname) then if (present(string)) then call append_string(cdar(y), string) else call append_cell_string(cdar(y), cell) end if return end if end if exit end if y=cdr(y) end do if (y /= nil) exit x=cdr(x) end do obj=cdr(obj) end do end subroutine append_string_var ! ! Extract annotations from locnotes or from macro variable ! Can escape a sensitive character, eg ';' if writing script. ! Moved here from categorical_data module ! function get_notes(loc, locnote) use string_utilities character (len=:), allocatable :: get_notes character (len=*), intent(in) :: loc, locnote integer :: fin, istat, nchar istat=-1 call get_string_var('labels_' // trim(loc), length=nchar, istat=istat) if (istat == 0) then allocate(character(len=nchar) :: get_notes) call get_string_var('labels_' // trim(loc), string=get_notes, istat=istat) if (get_notes == ' ') istat = -1 end if if (istat == -1) then if (allocated(get_notes)) deallocate(get_notes) nchar=len_trim(locnote) allocate(character(len=nchar) :: get_notes) get_notes=trim(locnote) end if end function get_notes #endif ! ! hash addressing a hash-table ! ! hash the contents of a scmhash eg after a garbage collection ! as a side effect, purges duplicates ! ! subroutine rehash_scmhash(p, newsiz) integer, intent(in) :: p integer, intent(in), optional :: newsiz integer :: i, idx, n, n2, w, wp, x, y, yp, z character (len=1) :: ch character (len=20) :: string i=get_ivalue(p) n=scmhash(i)%nrecords n2=get_listlen(car(p)) if (present(newsiz)) then n=newsiz end if if (n < n2) n=n2 call cleanup_hash(scmhash(i)%ht) call setup_hash(HK_ID, n+10, scmhash(i)%ht, 90) if (scmhash(i)%ht%nrec > size(scmhash(i)%m_address,1)) then deallocate(scmhash(i)%m_address) allocate(scmhash(i)%m_address(0:scmhash(i)%ht%nrec,2)) scmhash(i)%m_address=nil end if n=0 w=car(p) y=cadr(p) wp=w yp=y do while (w /= nil .and. y /= nil) x=car(w) z=car(y) idx=find_scmhash(scmhash(i), x) if (idx == 0) then n=n+1 if (isstring(x)) then call insert_hash(scmhash(i)%ht, get_string(x), n) else if (isnumber(x)) then call insert_hash_int(scmhash(i)%ht, int(get_ivalue(x),kind=4), n) end if scmhash(i)%m_address(n,1)=x scmhash(i)%m_address(n,2)=z else call set_cdr(wp, cdr(w)) call set_cdr(yp, cdr(y)) end if wp=w yp=y w=cdr(w) y=cdr(y) end do scmhash(i)%ht%current=.true. end subroutine rehash_scmhash ! ! hashes the global environment versus the symbol table ! subroutine hash_env() integer :: obj, n, s, w, x, y character (len=1) :: ch character (len=20) :: string call cleanup_hash(objhash) call setup_hash(HK_ID, 700, objhash, 90) n=0 obj=oblist do while (obj /= nil) n=n+1 s=car(obj) x=global_env do while (x /= nil) y=car(x) do while (y /= nil) if (caar(y) == s) then call insert_hash(objhash, get_string(car(s)), y) exit end if y=cdr(y) end do if (y /= nil) exit x=cdr(x) end do obj=cdr(obj) end do objhash%current=.true. end subroutine hash_env ! ! drop a variable from symbol table and global environment ! subroutine delete_var(nam, istat) character(len=*), intent(in) :: nam integer, intent(out) :: istat integer :: obj, n, prevobj, prevenv, s, w, x, y character (len=1) :: ch character (len=20) :: string n=0 istat=1 obj=oblist prevobj=obj do while (obj /= nil) n=n+1 s=car(obj) if (nam == get_string(car(s))) then istat=istat+1 call set_cdr(prevobj, cddr(prevobj)) exit end if prevobj=obj obj=cdr(obj) end do x=global_env env: do while (x /= nil) y=car(x) prevenv=x do while (y /= nil) s=caar(y) if (isstring(car(s))) then if (get_string(car(s)) == nam) then call set_cdr(prevenv, cdr(y)) s=find_objhash(get_string(car(s)), 'd') istat=istat+2 exit env end if end if prevenv=y y=cdr(y) end do x=cdr(x) end do env end subroutine delete_var ! ! Find any novel symbols in global environment ! subroutine update_env() integer :: s, x, y x=global_env do while (x /= nil) y=car(x) do while (y /= nil) s=caar(y) if (issymbol(s)) then if (whereis(trim(get_string(car(s)))) /= nil) return ! else hash this symbol call insert_hash(objhash, get_string(car(s)), y) exit end if y=cdr(y) end do x=cdr(x) end do objhash%current=.true. end subroutine update_env ! ! find key in global environment hash table ! function find_objhash(str, typ) result (res) integer :: res character(len=*), intent(in) :: str character(len=1), intent(in) :: typ integer :: iaddress, idx, iprobe, j integer :: x res=nil if (typ == 'd') res=f if (objhash%nrec == 0) return idx=string_hash(str, objhash%nrec) iprobe=objhash%primroot j=idx do iaddress=objhash%address(j+1) if (iaddress == 0) return x=car(caar(iaddress)) if (str == get_string(x)) then if (typ == 'e') then res=cdar(iaddress) else if (typ == 'd') then objhash%address(j+1)=0 res=t else res=iaddress end if return end if j=mod(idx+iprobe, objhash%nrec) iprobe=mod(iprobe*objhash%primroot, objhash%nrec) end do end function find_objhash ! ! find key in scmhash table ! function find_scmhash(hashtab, address, string) result (res) integer :: res integer, intent(in), optional :: address character(len=*), intent(in), optional :: string type (scm_ht), intent(in) :: hashtab integer :: iaddress, idx, iprobe, i, iv, j, n, typ integer :: x double precision :: rv typ=1 res=0 if (hashtab%ht%nrec == 0) return if (present(string)) then typ=3 idx=string_hash(string, hashtab%ht%nrec) else if (isstring(address)) then idx=string_hash(get_string(address), hashtab%ht%nrec) else if (isfloat(address)) then typ=5 rv=rvalue(address) idx=string_hash(floathex(rv), hashtab%ht%nrec) else if (isnumber(address)) then typ=2 iv=get_ivalue(address) idx=integer_hash(iv, hashtab%ht%nrec) else if (address == t) then idx=string_hash('TRUE', hashtab%ht%nrec) typ=4 else if (address == f) then idx=string_hash('FALSE', hashtab%ht%nrec) typ=4 else call error0('load -- hash key is not atomic') return end if n=0 iprobe=hashtab%ht%primroot j=idx do n=n+1 iaddress=hashtab%ht%address(j+1) if (iaddress == 0) return x=hashtab%m_address(iaddress,1) if (typ == 1) then if (get_string(address) == get_string(x)) then res=iaddress return end if else if (typ == 2) then if (iv == get_ivalue(x)) then res=iaddress return end if else if (typ == 5) then if (rv == rvalue(x)) then res=iaddress return end if else if (typ == 3) then if (string == get_string(x)) then res=iaddress return end if else if (typ == 4) then if ((address == f .and. get_string(x) == 'FALSE') .or. & (address == t .and. get_string(x) == 'TRUE')) then res=iaddress return end if end if j=mod(idx+iprobe, hashtab%ht%nrec) iprobe=mod(iprobe*hashtab%ht%primroot, hashtab%ht%nrec) end do end function find_scmhash ! ! print out scmhash-table ! subroutine print_scmhash(x, plevel) integer, intent(in) :: x integer, intent(in) :: plevel integer :: i, j, n i=get_ivalue(x) write(outstr,'(a,i0,a,l1,a,l1,2(a,i0),3a)') & ';; hash-table ', i, ' current=', scmhash(i)%ht%current, & ' hasdups=', scmhash(i)%ht%hasdups, ' maxrec=', scmhash(i)%ht%nrec, & ' nrecords=', scmhash(i)%nrecords,' note="', scmhash(i)%note, '"' n=scmhash(i)%nrecords if (plevel < 1) n=min(3, scmhash(i)%nrecords) do j=1, n write(outstr,'(a,i0,1x)', advance='no') ';; ', j call printatom(scmhash(i)%m_address(j,1), 0, -1, 0, ' ') write(outstr,'(1x)', advance='no') call printatom(scmhash(i)%m_address(j,2), 0, -1, 0, ' ') write(outstr,*) end do end subroutine print_scmhash ! ! return nth entry in hash table ! function get_scmhash(x, idx) integer :: get_scmhash integer, intent(in) :: x integer, intent(in) :: idx integer :: i, y, z i=get_ivalue(x) if (idx > 0 .and. idx <= scmhash(i)%nrecords) then y=scmhash(i)%m_address(idx,1) z=scmhash(i)%m_address(idx,2) get_scmhash=cons(y,z) else get_scmhash=nil end if end function get_scmhash ! ! List Sib-pair accessible (atomic or pair) variables ! subroutine list_objects(typ) integer, intent(in) :: typ integer :: i, j, obj, n, s, w, x, y character (len=1) :: ch character (len=20) :: string integer, dimension(:), allocatable :: key call update_env() ! insertion sort symbols allocate(key(objhash%nrec)) n=0 do i=1, objhash%nrec y=objhash%address(i) if (y /= 0) then string=get_string(car(caar(y))) j=1 do while (j <= n) x=key(j) if (get_string(car(caar(x))) >= string) exit j=j+1 end do n=n+1 key((j+1):n)=key(j:(n-1)) key(j)=y end if end do do i=1, n w=key(i) x=car(caar(w)) y=cdar(w) if (isstring(y)) then write(outstr, '(4a)') & get_string(x), ' = "', get_string(y), '"' else if (isnumber(y)) then write(outstr, '(2a)', advance='no') get_string(x), ' = ' if (isbignum(y)) then call bigprint(y, advance='yes') else if (isfloat(y)) then write(outstr,*) rvalue(y) else write(outstr, '(i0)') get_ivalue(y) end if else if (ispair(y)) then w=get_listlen(y) if (w > 5) then write(outstr, '(2a,i0)') & get_string(x), ' = list of length ', w else write(outstr, '(2a)', advance='no') & get_string(x), ' = ( ' do j=1, w call printatom(car(y), 1, -1, 0, ' ') write(outstr, '(a)', advance='no') ' ' y=cdr(y) end do write(outstr, '(a)') ')' end if else if (ismacro(y) .and. typ > 0) then write(outstr, '(2a)') get_string(x), ' = macro' else if (isclosure(y) .and. typ > 0) then write(outstr, '(2a)') get_string(x), ' = closure' else if (isproc(y) .and. typ == 1) then write(outstr, '(2a)') get_string(x), ' = procedure' else if (issyntax(y) .and. typ == 1) then write(outstr, '(2a)') get_string(x), ' = syntax' else if (isatom(y) .and. typ == 1) then write(outstr, '(2a)') get_string(x), ' = atom' else if (y > 0 .and. typ == 1) then write(outstr, '(2a,i0)') get_string(x), ' is type ', typeof(y) end if end do end subroutine list_objects ! ! search closure documentation strings for term ! subroutine help_objects(sstring) character(len=*), intent(in) :: sstring character(len=512) :: buff integer :: i, j, w, x, y call update_env() do i=1, objhash%nrec w=objhash%address(i) if (w /= 0) then x=car(caar(w)) y=cdar(w) if (isclosure(y)) then j=car(cdr(car(y))) buff=get_string(j) if (strfind(sstring, trim(buff), 2)) then write(outstr,'(3a)') get_string(x), ': ', trim(buff) end if end if end if end do end subroutine help_objects ! ! List Sib-pair accessible (atomic or pair) variables ! subroutine list_var(typ, ple) integer, intent(in) :: typ, ple integer :: i, obj, s, w, x, y, z character (len=1) :: ch character (len=20) :: string obj=oblist do while (obj /= nil) s=car(obj) x=global_env do while (x /= nil) y=car(x) do while (y /= nil) if (caar(y) == s) then if (typ == 1) then z=cdar(y) if (isstring(z)) then write(outstr, '(4a)') & get_string(car(s)), ' = "', get_string(z), '"' else if (isnumber(z)) then if (isbignum(z)) then write(outstr, '(2a)', advance='no') & get_string(car(s)), ' = ' call bigprint(z, advance='yes') else write(string, '(i20)') get_ivalue(z) write(outstr, '(3a)') & get_string(car(s)), ' = ', adjustl(trim(string)) end if else if (ispair(z)) then if (.not.ceqstr('*sp-fun*', car(z))) then w=get_listlen(z) write(outstr, '(2a)', advance='no') & get_string(car(s)), ' = ( ' do j=1, min(5,w) call printatom(car(z), 1, -1, 0, ' ') write(outstr, '(a)', advance='no') ' ' z=cdr(z) end do if (w > 5) then write(outstr, '(a)', advance='no') ' ' end if write(outstr, '(a)') ')' end if end if else if (typ == 2) then if (ceqstr('*sp-fun*', car(cdar(y)))) then if (ple < 1) then write(outstr, '(a)') get_string(car(s)) else write(outstr, '(2a/a)', advance='no') & get_string(car(s)), ':', ' ' s=cdr(cdar(y)) do i=1, get_strlen(s) ch=get_substr(s, i-1, i) if (ch == ';') then write(outstr,'(/a)', advance='no') ' ' else write(outstr,'(a)', advance='no') ch end if end do write(outstr,*) end if end if end if exit end if y=cdr(y) end do if (y /= nil) exit x=cdr(x) end do obj=cdr(obj) end do end subroutine list_var ! ! test if a name is bound in the top environment ! function whereis(nam) integer :: whereis character (len=*), intent(in) :: nam integer :: tmp, x, y whereis=find_objhash(nam,'e') end function whereis function isbound(nam) logical :: isbound character (len=*), intent(in) :: nam isbound=(whereis(nam) /= nil) end function isbound ! ! Test if a macro function exists, and return address of body ! function isafun(nam) integer :: isafun character (len=*), intent(in) :: nam integer :: tmp, x, y isafun=0 x=whereis(nam) if (x /= nil) then if (ceqstr('*sp-fun*', car(x))) then isafun=cdr(x) end if end if end function isafun ! ! hash-tables are also accessible ! function isahash(nam) logical :: isahash character (len=*), intent(in) :: nam integer :: x isahash=.false. x=whereis(trim(nam)) if (x /= nil) isahash=ishash(x) end function isahash ! function procnum(p) integer :: procnum integer :: p procnum=mem(p)%value end function procnum function syntaxnum(p) integer :: syntaxnum integer :: p syntaxnum=mem(p)%keynum end function syntaxnum ! ! Underlying primitives for Scheme ! function typeof(p) integer :: typeof integer, intent(in) :: p typeof=mem(p)%iflag end function typeof function isstring(p) logical :: isstring integer, intent(in) :: p isstring=(iand(typeof(p), T_STRING) /= 0) end function isstring function isnumber(p) logical :: isnumber integer, intent(in) :: p isnumber=(iand(typeof(p), T_NUMBER) /= 0) end function isnumber function ispair(p) logical :: ispair integer, intent(in) :: p ispair=(iand(typeof(p), T_PAIR) /= 0) end function ispair ! ! car, cdr etc ! function car(p) integer :: car integer, intent(in) :: p car = mem(p)%car end function car function cdr(p) integer :: cdr integer, intent(in) :: p cdr = mem(p)%cdr end function cdr ! function caar(p) integer :: caar integer, intent(in) :: p caar = mem(p)%car caar = mem(caar)%car end function caar function cadr(p) integer :: cadr integer, intent(in) :: p cadr = mem(p)%cdr cadr = mem(cadr)%car end function cadr function cdar(p) integer :: cdar integer, intent(in) :: p cdar = mem(p)%car cdar = mem(cdar)%cdr end function cdar function cddr(p) integer :: cddr integer, intent(in) :: p cddr = mem(p)%cdr cddr = mem(cddr)%cdr end function cddr function cadar(p) integer :: cadar integer, intent(in) :: p cadar = mem(p)%car cadar = mem(cadar)%cdr cadar = mem(cadar)%car end function cadar function caddr(p) integer :: caddr integer, intent(in) :: p caddr = mem(p)%cdr caddr = mem(caddr)%cdr caddr = mem(caddr)%car end function caddr function cadaar(p) integer :: cadaar integer, intent(in) :: p cadaar = mem(p)%car cadaar = mem(cadaar)%car cadaar = mem(cadaar)%cdr cadaar = mem(cadaar)%car end function cadaar function cadddr(p) integer :: cadddr integer, intent(in) :: p cadddr = mem(p)%cdr cadddr = mem(cadddr)%cdr cadddr = mem(cadddr)%cdr cadddr = mem(cadddr)%car end function cadddr function cddddr(p) integer :: cddddr integer, intent(in) :: p cddddr = mem(p)%cdr cddddr = mem(cddddr)%cdr cddddr = mem(cddddr)%cdr cddddr = mem(cddddr)%cdr end function cddddr ! function issymbol(p) logical :: issymbol integer, intent(in) :: p issymbol=(iand(typeof(p), T_SYMBOL) /= 0) end function issymbol function issyntax(p) logical :: issyntax integer, intent(in) :: p issyntax=(iand(typeof(p), T_SYNTAX) /= 0) end function issyntax function isproc(p) logical :: isproc integer, intent(in) :: p isproc=(iand(typeof(p), T_PROC) /= 0) end function isproc function isclosure(p) logical :: isclosure integer, intent(in) :: p isclosure=(iand(typeof(p), T_CLOSURE) /= 0) end function isclosure function ismacro(p) logical :: ismacro integer, intent(in) :: p ismacro=(iand(typeof(p), T_MACRO) /= 0) end function ismacro function iscontinuation(p) logical :: iscontinuation integer, intent(in) :: p iscontinuation=(iand(typeof(p), T_CONTINUATION) /= 0) end function iscontinuation function ispromise(p) logical :: ispromise integer, intent(in) :: p ispromise=(iand(typeof(p), T_PROMISE) /= 0) end function ispromise function isport(p) logical :: isport integer, intent(in) :: p isport=(iand(typeof(p), T_PORT) /= 0) end function isport ! hash or vector function ishash(p) logical :: ishash integer, intent(in) :: p ishash=((iand(typeof(p), T_HASHVEC) /= 0) .and. btest(mem(p)%keynum,0)) end function ishash function isvector(p) logical :: isvector integer, intent(in) :: p isvector=((iand(typeof(p), T_HASHVEC) /= 0) .and. btest(mem(p)%keynum,1)) end function isvector ! true or false value functions function istrue(p) logical :: istrue integer :: p istrue=(p /= nil .and. p /= f) end function istrue function isfalse(p) logical :: isfalse integer :: p isfalse=(p /= nil .and. p == f) end function isfalse ! ! tower of numbers ! function isinteger(p) logical :: isinteger integer :: p isinteger=(isnumber(p) .and. btest(mem(p)%keynum,0)) end function isinteger function isfloat(p) logical :: isfloat integer :: p isfloat=(isnumber(p) .and. btest(mem(p)%keynum,1)) end function isfloat function isbignum(p) logical :: isbignum integer :: p isbignum=(isnumber(p) .and. btest(mem(p)%keynum,2)) end function isbignum ! ! Garbage collection ! function isatom(p) logical :: isatom integer, intent(in) :: p isatom=(iand(typeof(p), T_ATOM) /= 0) end function isatom subroutine setatom(p) integer, intent(in) :: p call set_type(p, ior(typeof(p), T_ATOM)) end subroutine setatom subroutine clratom(p) integer, intent(in) :: p call set_type(p, iand(typeof(p), T_CLRATOM)) end subroutine clratom function ismark(p) logical :: ismark integer, intent(in) :: p ismark=(iand(typeof(p), T_MARK) /= 0) end function ismark subroutine setmark(p) integer, intent(in) :: p call set_type(p, ior(typeof(p), T_MARK)) end subroutine setmark subroutine clrmark(p) integer, intent(in) :: p call set_type(p, iand(typeof(p), T_UNMARK)) end subroutine clrmark ! ! Cons ! function cons(x, y) integer cons integer :: x, y cons=getcell(x, y, 'cons') call set_type(cons, T_PAIR) mem(cons)%car = x mem(cons)%cdr = y end function cons ! ! Memory usage diagnostic cons ! ! function cons1(x, y, note) ! integer cons ! integer :: x, y ! character(len=*) :: note ! cons1=getcell(x, y, 'cons ' // note) ! call set_type(cons1, T_PAIR) ! mem(cons1)%car = x ! mem(cons1)%cdr = y ! end function cons1 ! ! Contents of a Lisp string cell equal to a Fortran string ! function ceqstr(cstr, reg) logical :: ceqstr character (len=*) :: cstr integer, intent(in) :: reg integer :: i ceqstr=.true. if (mem(reg)%slength /= len(cstr)) then ceqstr=.false. return else do i=1, len(cstr) if (cstr(i:i) /= mem(reg)%svalue(i)) then ceqstr=.false. return end if end do end if end function ceqstr ! ! Contents of a Lisp string equal to a Lisp string ! function streq(a, b) logical :: streq integer, intent(in) :: a, b integer :: i, slen streq=.true. slen=mem(a)%slength if (slen /= mem(b)%slength) then streq=.false. else do i=1, slen if (mem(a)%svalue(i) /= mem(b)%svalue(i)) then streq=.false. return end if end do end if end function streq ! ! Declare a hash ! function mk_scmhash(typ) integer :: mk_scmhash integer, intent(in) :: typ integer :: n integer :: icdr, tmp character (len=8) :: d character (len=10) :: t call date_and_time(date=d, time=t) allocate(character(len=19) :: scmhash(nexthash)%note) scmhash(nexthash)%note=d // ' ' // t n=60 call setup_hash(HK_ID, n, scmhash(nexthash)%ht, 90) allocate(scmhash(nexthash)%m_address(0:scmhash(nexthash)%ht%nrec,2)) scmhash(nexthash)%m_address=nil scmhash(nexthash)%nrecords=0 tmp=getcell(nil, nil, 'mk_scmhash') call set_type(tmp, ior(T_HASHVEC, T_PAIR)) mem(tmp)%keynum=typ call set_ivalue(tmp, int(nexthash,kind=8)) nexthash=nexthash+1 if (nexthash > n_scmhash) then call setup_scmhash(n_scmhash+2) end if icdr=getcell(tmp, nil, 'mk_scmhash') call set_type(icdr, T_PAIR) call set_cdr(tmp, icdr) mk_scmhash=tmp end function mk_scmhash ! ! Declare a number ! function mk_number(num) integer :: mk_number integer (kind=8), intent(in) :: num integer :: tmp tmp=getcell(nil, nil, 'mk_number') call set_type(tmp, ior(T_NUMBER, T_ATOM)) call set_ivalue(tmp, num) mk_number=tmp end function mk_number ! ! Declare a bignum ! function mk_bignumber(str) integer :: mk_bignumber character (len=*), intent(in) :: str integer :: i, nc, ndig, sgn, tmp, res integer (kind=8) :: iv, iexponent integer :: fracexp, hasexponent, haspoint, iostat character (len=len(str)) :: fracpart, exppart character (len=1) :: ch, numsign, expsign nc=len(str) iostat=0 numsign=' ' fracexp=0 iexponent=0 fracpart=str ch=fracpart(1:1) if (scan('+-', ch) > 0) then numsign=ch fracpart=fracpart(2:nc) end if expsign=' ' exppart=' ' hasexponent=scan(fracpart, 'DdEe') if (hasexponent > 0) then exppart=fracpart((hasexponent+1):nc) fracpart=fracpart(1:(hasexponent-1)) ch=exppart(1:1) if (scan('+-', ch) > 0) then expsign=ch exppart=exppart(2:nc) end if end if haspoint=scan(fracpart, '.') if (haspoint > 0) then fracexp=len_trim(fracpart)-haspoint fracpart=fracpart(1:(haspoint-1)) // fracpart((haspoint+1):nc) end if ! See if a proper number ndig=len_trim(fracpart) if (verify(fracpart(1:ndig),'0123456789') /= 0) then write(*,'(5a)') & 'Cannot parse "', fracpart(1:ndig), '" from "', trim(str), '".' iostat=-1 return end if if (len_trim(exppart) > 0) then if (verify(trim(exppart),'0123456789') /= 0) then write(*,'(5a)') & 'Cannot parse "', trim(exppart),'" from "', trim(str), '".' iostat=-2 return end if read(exppart,*) iexponent if (expsign == "-") iexponent=-iexponent iexponent=iexponent-fracexp end if if (iexponent < 0) then write(*,'(3a)') '"', trim(str), '" will be truncated.' iostat=1 end if ! i=ndig reg9=nil do while (i > 0) read(fracpart(max(1,i-bigbase+1):i),*, iostat=ioerr) iv reg9=cons(mk_number(iv), reg9) i=i-bigbase end do ! reg9=reverse(reg9) reg9=non_alloc_rev(nil,reg9) call set_as_bigval(reg9) ! set sign sgn=1 if (numsign == '-') sgn=-1 call set_sign(reg9, sgn) if (iexponent /= 0) then iv=10_8**abs(iexponent) tmp=bignum_expt(int2big(10_8),abs(iexponent)) if (iexponent > 0) then reg9=bignum_multiply(reg9, tmp) else reg9=car(bignum_divide(reg9, tmp)) end if end if mk_bignumber=reg9 end function mk_bignumber ! function int2big(i) integer :: int2big integer (kind=8), intent(in) :: i integer :: sgn, tmp integer (kind=8) :: iv, rem sgn=1 iv=abs(i) ! use a register if (iv == 0) then reg1=mk_number(int(0,kind=8)) else reg1=nil sgn=int(sign(1_8,i),kind=4) do while (iv > 0) rem=mod(iv, rbase) iv=iv/rbase tmp=mk_number(int(rem,kind=8)) reg1=cons(tmp, reg1) end do ! reg1=reverse(reg1) reg1=non_alloc_rev(nil,reg1) end if call set_as_bigval(reg1) call set_sign(reg1, sgn) int2big=reg1 end function int2big ! function real2big(rv) integer :: real2big double precision, intent(in) :: rv integer :: sgn, tmp double precision :: val double precision, parameter :: zero=0.0d0, one = 1.0d0 integer (kind=8) :: iv, rem sgn=1 val=abs(rv) ! use a register if (val == zero) then reg1=mk_number(int(0,kind=8)) else reg1=nil sgn=int(sign(one,val),kind=4) do while (val > zero) rem=mod(val, rbigbase) val=val/rbigbase tmp=mk_number(int(rem,kind=8)) reg1=cons(tmp, reg1) end do ! reg1=reverse(reg1) reg1=non_alloc_rev(nil,reg1) end if call set_as_bigval(reg1) reg1=bignum_normalize(reg1) call set_sign(reg1, sgn) real2big=reg1 end function real2big ! ! as bignum ! function asbignum(x) integer :: asbignum integer :: x if (isbignum(x)) then asbignum=x else if (isinteger(x)) then asbignum=int2big(get_ivalue(x)) end if end function asbignum ! ! reduce to ordinary integer if possible ! function simplest_int(x) integer :: simplest_int integer :: sgn, x if (isbignum(x)) then sgn=getsign(x) if (get_listlen(x) == 1) then x=car(x) call set_sign(x, sgn) end if end if simplest_int=x end function simplest_int ! Declare a real ! function mk_real(num) integer :: mk_real double precision, intent(in) :: num integer :: tmp tmp=getcell(nil, nil, 'mk_real') call set_type(tmp, ior(T_NUMBER, T_ATOM)) call set_value(tmp, num) mk_real=tmp end function mk_real ! ! Declare a string ! function mk_string(str) integer :: mk_string character (len=*), intent(in) :: str integer :: tmp tmp=getcell(nil, nil, 'mk_string') call set_type(tmp, ior(T_STRING, T_ATOM)) call set_string(tmp, str) mk_string=tmp end function mk_string ! ! Declare a symbol ! function mk_symbol(nam) integer :: mk_symbol character (len=*), intent(in) :: nam integer :: tmp tmp=oblist do while (tmp /= nil) if (ceqstr(trim(nam), caar(tmp))) exit tmp=cdr(tmp) end do if (tmp /= nil) then mk_symbol=car(tmp) else tmp=cons(mk_string(nam), nil) call set_type(tmp, T_SYMBOL) oblist=cons(tmp, oblist) mk_symbol=tmp end if end function mk_symbol ! ! cons string to list function append_one_string(str, l, protect) integer :: append_one_string character (len=*), intent(in) :: str integer, intent(in out) :: l integer, intent(in out), optional :: protect integer :: tmp if (present(protect)) then tmp=getcell(l, protect, 'append_one_string') else tmp=getcell(l, nil, 'append_one_string') end if call set_type(tmp, ior(T_STRING, T_ATOM)) call set_string(tmp, str) append_one_string=cons(tmp, l) end function append_one_string ! ! cons real to list function append_one_real(num, l, protect) integer :: append_one_real double precision, intent(in) :: num integer, intent(in out) :: l integer, intent(in out), optional :: protect integer :: tmp if (present(protect)) then tmp=getcell(l, protect, 'append_one_real') else tmp=getcell(l, nil, 'append_one_real') end if call set_type(tmp, ior(T_NUMBER, T_ATOM)) call set_value(tmp, num) append_one_real=cons(tmp, l) end function append_one_real ! ! cons integer to list function append_one_number(num, l, protect) integer :: append_one_number integer, intent(in) :: num integer, intent(in out) :: l integer, intent(in out), optional :: protect integer :: tmp if (present(protect)) then tmp=getcell(l, protect,'append_one_number') else tmp=getcell(l, nil,'append_one_number') end if call set_type(tmp, ior(T_NUMBER, T_ATOM)) call set_ivalue(tmp, int(num, kind=8)) append_one_number=cons(tmp, l) end function append_one_number ! ! make matrix from 1-D array ! function make_real_matrix(nvals, vals, nr, protect) integer :: make_real_matrix integer, intent(in) :: nvals double precision, dimension(nvals), intent(in) :: vals integer, intent(in) :: nr integer, intent(in), optional :: protect integer :: i, j, nc, pcell, pos, tmp, res pcell=nil if (present(protect)) pcell=protect nc=nvals/nr if (nc == 0 .or. nr == 0 .or. nvals /= nc*nr) then make_real_matrix=nil return end if pos=0 do i=nc, 1, -1 res=nil pos=(i-1)*nr do j=1, nr pos=pos+1 tmp=getcell(res, pcell,'make_real_matrix') call set_type(tmp, ior(T_NUMBER, T_ATOM)) call set_value(tmp, vals(pos)) res=cons(tmp, res) end do dump=cons(res, dump) end do res=nil do i=1, nc res=cons(car(dump), res) dump=cdr(dump) end do make_real_matrix=res end function make_real_matrix ! ! automatically generate a unique symbol ! function gensym() use rngs integer :: gensym integer :: tmp character (len=10) :: nam do call uniqnam(10, nam) tmp=oblist do while (tmp /= nil) if (ceqstr(trim(nam), caar(tmp))) exit tmp=cdr(tmp) end do if (tmp == nil) exit end do tmp=cons(mk_string(nam), nil) call set_type(tmp, T_SYMBOL) oblist=cons(tmp, oblist) gensym=tmp end function gensym ! ! make symbol or number atom from string ! function mk_atom(str) integer :: mk_atom character (len=*), intent(in) :: str integer :: letpos, i, ich, slen integer (kind=8) :: x logical :: hasdot, isnum ! functions integer :: ival double precision :: fval slen=len(str) letpos=0 hasdot=.false. isnum=.true. do i=1, slen ich = ichar(str(i:i)) if (ich < 48 .or. ich > 57) then if ((ich == 43 .or. ich == 45) .and. & (i == 1 .or. i == (letpos+1)) .and. slen>1) then continue else if ((ich == 100 .or. ich == 101 .or. ich == 68 .or. & ich == 69) .and. letpos == 0 .and. i>1) then letpos=i else if (ich == 46 .and. .not.hasdot) then hasdot=.true. else isnum=.false. exit end if end if end do if (isnum) then if (hasdot .or. letpos>0) then mk_atom=mk_real(fval(str)) elseif (slen > bigbase) then mk_atom=mk_bignumber(str) else read(str,'(i40)',err=999) x mk_atom=mk_number(x) end if else mk_atom=mk_symbol(str) end if return 999 continue mk_atom=f end function mk_atom ! ! Make a constant ! function mk_const(nam) integer :: mk_const character (len=*) :: nam integer :: nchar integer (kind=8) :: x character (len=3) :: width character (len=10) :: fstring nchar=len_trim(nam) write(width,'(i0)') nchar if (nam == 't') then mk_const=t else if (nam == 'f') then mk_const=f else if (nam(1:1) == 'b') then fstring='(1x,b' // trim(width) // ')' read(nam, fstring, err=999) x mk_const=mk_number(x) else if (nam(1:1) == 'd') then fstring='(1x,i' // trim(width) // ')' read(nam, fstring, err=999) x mk_const=mk_number(x) else if (nam(1:1) == 'o') then fstring='(1x,o' // trim(width) // ')' read(nam, fstring, err=999) x mk_const=mk_number(x) else if (nam(1:1) == 'x') then fstring='(1x,z' // trim(width) // ')' read(nam, fstring, err=999) x mk_const=mk_number(x) #if defined (WIN32) || defined (IFORT) || defined (NOESCAPE) else if (nam(1:1) == '\') then #else else if (nam(1:1) == '\\') then #endif if (nchar == 2) then mk_const=mk_string(nam(2:2)) else if (nam(2:nchar) == 'space') then mk_const=mk_string(' ') else if (nam(2:nchar) == 'newline') then mk_const=mk_string(char(10)) else if (nam(2:nchar) == 'return') then mk_const=mk_string(char(13)) else if (nam(2:nchar) == 'tab') then mk_const=mk_string(char(9)) else if (nchar == 1) then mk_const=mk_string(' ') else mk_const=nil end if else mk_const=nil end if return 999 continue mk_const=nil end function mk_const ! ! make closure, c is code, e is environment ! function mk_closure(c, e) integer :: mk_closure integer :: c, e integer :: x x=getcell(c, e, 'mk_closure') call set_type(x, T_CLOSURE) call set_car(x, c) call set_cdr(x, e) mk_closure=x end function mk_closure ! ! make continuation ! function mk_continuation(d) integer :: mk_continuation integer :: d integer :: x x=getcell(nil, d, 'mk_continuation') call set_type(x, T_CONTINUATION) call set_cdr(x, d) mk_continuation=x end function mk_continuation ! ! make a port ! function mk_port(iport, nam) integer :: mk_port integer (kind=8), intent(in) :: iport character (len=*), intent(in) :: nam integer :: tmp tmp=getcell(nil, nil, 'mk_port') call set_type(tmp, ior(T_PORT, T_ATOM)) call set_ivalue(tmp, iport) call set_string(tmp, nam) mk_port=tmp end function mk_port ! ! Test a port - return location in portaddress function test_port(iport) integer :: test_port integer, intent(in) :: iport integer :: i do i=1, nports if (portaddress(i) == iport) then test_port=i return end if end do test_port=0 end function test_port ! ! Reverse list ! function reverse(a) integer :: reverse integer, intent(in) :: a integer :: p, tmp integer :: i p=nil tmp=a i=0 do while (ispair(tmp)) i=i+1 p=cons(car(tmp), p) tmp=cdr(tmp) end do reverse=p end function reverse ! ! Reverse list -- no new cell generated ! function non_alloc_rev(term, list) integer :: non_alloc_rev integer, intent(in) :: term, list integer :: i, p, res, q i=0 p=list res=term do while (p /= nil) i=i+1 q=cdr(p) call set_cdr(p, res) res=p p=q end do non_alloc_rev=res end function non_alloc_rev ! ! append list -- make new cells ! function append(a, b) integer :: append integer, intent(in) :: a, b integer :: p, q, tmp p=b tmp=a if (tmp /= nil) then tmp = reverse(tmp) do while (tmp /= nil) q = cdr(tmp) call set_cdr(tmp, p) p = tmp tmp = q end do end if append=p end function append ! ! equivalence of atoms ! function eqv(a, b) logical :: eqv integer, intent(in) :: a, b eqv=.false. if (isstring(a)) then if (isstring(b)) then eqv=streq(a, b) end if else if (isnumber(a)) then if (isnumber(b)) then eqv=(get_ivalue(a) == get_ivalue(b)) end if else eqv=(a == b) end if end function eqv ! ! save or restore command line buffer (f95 compatible) ! subroutine save_linbuffer(ios) integer, intent(out) :: ios integer :: i, pos ios=-1 if (nloaded == MAXPORT) return ios=0 nloaded=nloaded+1 i=len_trim(scheme_lin)-currentline rest_of_lin(nloaded)%slength=i if (allocated(rest_of_lin(nloaded)%svalue)) deallocate(rest_of_lin(nloaded)%svalue) allocate(rest_of_lin(nloaded)%svalue(i)) pos=currentline do i=1, rest_of_lin(nloaded)%slength pos=pos+1 rest_of_lin(nloaded)%svalue(i)=scheme_lin(pos:pos) end do currentline=0 scheme_lin='' end subroutine save_linbuffer ! subroutine restore_linbuffer(ios) integer, intent(out) :: ios integer :: i ios=-1 if (nloaded == 0) return ios=0 scheme_lin='' do i=1, rest_of_lin(nloaded)%slength scheme_lin(i:i)=rest_of_lin(nloaded)%svalue(i) end do deallocate(rest_of_lin(nloaded)%svalue) nloaded=nloaded-1 eol=len_trim(scheme_lin) currentline=0 end subroutine restore_linbuffer ! ! get a new character from input file or stdin ! subroutine inchar(ch) character (len=1) :: ch integer :: ios if (eol==0 .or. currentline > eol) then read(infp, '(a)', iostat=ios) scheme_lin if (ios /= 0 .and. infp /= STDIN) then write(outstr,'(3a)') 'Closing "', trim(loadfil), '".' close(infp, status='keep') ios=0 call restore_linbuffer(ios) infp=loadaddress(nloaded) if (len_trim(scheme_lin) == 0) then write(outstr, '(a)', advance='no') prompt_string read(infp, '(a)', iostat=ios) scheme_lin end if end if if (ios /= 0) then write(*, '(a)') 'Exiting!' return end if currentline=0 eol=len_trim(scheme_lin) end if currentline=currentline+1 if (currentline > eol) then ch=' ' else ch=scheme_lin(currentline:currentline) end if end subroutine inchar ! ! clear input buffer ! subroutine clearinput() currentline=eol end subroutine clearinput ! ! back to standard input ! subroutine flushinput() if (infp /= STDIN) then close(infp, status='keep') infp=STDIN end if call clearinput() end subroutine flushinput ! ! backstep one character in input buffer ! subroutine backchar() currentline=currentline-1 end subroutine backchar ! ! skip whitespace ! subroutine skipspace() do currentline=currentline+1 if (currentline > eol) exit if (scheme_lin(currentline:currentline)/=' ' .or. & scheme_lin(currentline:currentline)/=achar(9)) then exit end if end do currentline=currentline-1 end subroutine skipspace ! ! get next token ! function token() integer :: token character (len=1) :: ch integer :: ich do call skipspace() call inchar(ch) if (ch /= ' ' .and. ch /= achar(9)) exit end do ich = ichar(ch) if (ch == '(') then token=M_LPAREN else if (ch == ')') then token=M_RPAREN else if (ch == '.') then call inchar(ch) if (ch == ' ' .or. ch == achar(9) .or. ch == achar(10)) then token=M_DOT else call backchar() call backchar() token=M_ATOM end if else if (ich == 39) then token=M_QUOTE else if (ch == ';') then token=M_COMMENT else if (ch == '"') then token=M_DQUOTE else if (ch == '`') then token=M_BQUOTE else if (ch == ',') then call inchar(ch) if (ch == '@') then token=M_ATMARK else call backchar() token=M_COMMA end if else if (ch == '#') then token=M_SHARP else call backchar() token=M_ATOM end if end function token ! ! read characters to delimiter -- hard coded to work on Windows as well ! function scheme_delim(ch) logical :: scheme_delim character(len=1) :: ch integer :: ich ich=ichar(ch) scheme_delim=(ich == 9 .or. ich == 10 .or. & ich == 32 .or. ich== 40 .or. ich == 41) end function scheme_delim ! subroutine readstr(res) character (len=*) :: res integer :: pos, reslen character (len=1) :: ch logical :: backslash backslash=.false. reslen=len(res) res=' ' pos=0 rdloop: do call inchar(ch) if (currentline > eol) exit rdloop if (scheme_delim(ch) .and. .not.backslash) exit rdloop pos=pos+1 if (pos <= reslen) res(pos:pos)=ch #if defined (WIN32) || defined (IFORT) || defined (NOESCAPE) backslash=(.not.backslash .and. (ch == '\')) #else backslash=(.not.backslash .and. (ch == '\\')) #endif end do rdloop call backchar() end subroutine readstr ! ! read rest of a quoted string ! subroutine readstrexp(res, reslen) character (len=*) :: res character (len=1) :: ch integer, intent(out) :: reslen integer :: pos reslen=len(res) res=' ' pos=0 do call inchar(ch) #if defined (WIN32) || defined (IFORT) || defined (NOESCAPE) if (ch == '\') then #else if (ch == '\\') then #endif call inchar(ch) else if (ch == '"') then exit end if pos=pos+1 if (pos <= reslen) res(pos:pos)=ch end do reslen=min(pos, reslen) end subroutine readstrexp ! ! print an atom ! subroutine printatom(l, space, ndigits, commainterval, style, padchar) integer, intent(in) :: commainterval, l, ndigits, space character (len=1), intent(in) :: style character (len=1), intent(in), optional :: padchar integer :: i double precision :: rv character (len=1) :: ch, padch character (len=64) :: str character (len=8) :: fstring padch=' ' if (present(padchar)) padch=padchar if (l == nil) then write(outfp, '(a)', advance='no') '()' else if (l == t) then write(outfp, '(a)', advance='no') '#t' else if (l == f) then write(outfp, '(a)', advance='no') '#f' else if (l == un) then continue else if (isnumber(l)) then if (isbignum(l)) then call bigprint(l) else if (isinteger(l)) then fstring='(i40)' if (scan(style, 'bBoO') > 0) then fstring='(' // style // '40)' else if (scan(style, 'xX') > 0) then fstring='(z40)' end if if (scan(style, 'fF') > 0 .and. ndigits > 0) then write(fstring, '(i8)') ndigits fstring='(f40.' // trim(adjustl(fstring)) // ')' write(str, fstring) dble(get_ivalue(l)) else write(str, fstring) get_ivalue(l) end if call padprint(trim(adjustl(str)), space, commainterval, padch) else if (isfloat(l)) then rv=rvalue(l) if (scan(style, 'bB') > 0) then write(fstring,'(a)') '(b64.64)' else if (scan(style, 'oO') > 0) then write(fstring,'(a)') '(o64.64)' else if (scan(style, 'xX') > 0) then write(fstring,'(a)') '(z64.64)' else if (ndigits < 0) then if (anint(rv) == rv .and. rv < 1.0d18) then write(fstring,'(a)') '(f40.0)' else write(fstring,'(a)') '(g40.12)' end if else if (scan(style, 'gG') > 0 .and. ndigits > 0) then write(fstring, '(i8)') ndigits fstring='(g40.' // trim(adjustl(fstring)) // ')' else write(fstring, '(i8)') ndigits fstring='(f40.' // trim(adjustl(fstring)) // ')' end if write(str, fstring) rv call padprint(trim(adjustl(str)), space, 0, padch) end if else if (isstring(l)) then ! could be nonprinting character if (get_strlen(l) == 1) then ch=get_string(l) i=ichar(ch) if (i == 10 .or. i == 13) then if (print_flag==1) then if (i == 10) then write(outfp,'(a)',advance='no') '#\newline' else write(outfp,'(a)',advance='no') '#\return' end if else write(outfp,*) end if else if (i < 32) then if (print_flag==1) then write(outfp,'(a,i0)',advance='no') '#\', i else write(outfp,'(a)',advance='no') ch end if else if (print_flag==1) then write(outfp,'(3a)',advance='no') '"', ch, '"' else call padprint(ch, space, 0, padch) end if end if else if (print_flag==1) then write(outfp,'(3a)',advance='no') '"', get_string(l), '"' else call padprint(get_string(l), space, 0, padch) end if end if else if (issymbol(l)) then write(outfp,'(a)',advance='no') get_string(car(l)) ! // ' ' else if (isproc(l)) then write(outfp,'(3a)', advance='no') '<', get_string(l), '>' else if (ismacro(l)) then i=car(cdr(car(l))) if (isstring(i)) then write(outfp,'(3a)',advance='no') '#' else write(outfp,'(a)',advance='no') '#' end if else if (isclosure(l)) then i=car(cdr(car(l))) if (isstring(i)) then write(outfp,'(3a)',advance='no') '#' else write(outfp,'(a)',advance='no') '#' end if else if (iscontinuation(l)) then write(outfp,'(a)',advance='no') '#' else if (isport(l)) then write(outfp,'(a,i0,3a)',advance='no') '#' else if (ispair(l)) then write(outfp,'(a)',advance='no') '#' end if end subroutine printatom ! ! Pad printing of an atom ! subroutine padprint(str, space, commainterval, padchar) character (len=*), intent(in) :: str integer, intent(in) :: space integer, intent(in) :: commainterval character (len=1), intent(in) :: padchar integer :: fin, ilen, nch, sta if (space /= 0) then ilen=len(str) if (commainterval > 0) ilen=ilen+ilen/commainterval end if if (space < 0) then if (ilen < -space) then write(outfp, '(a)', advance='no') repeat(padchar,-space-ilen) end if end if if (commainterval == 0) then write(outfp, '(a)', advance='no') str else nch=len(str) sta=1 fin=mod(nch,commainterval) if (fin == 0) fin=commainterval fin=min(nch,fin) commaloop: do write(outfp, '(a)', advance='no') str(sta:fin) if (fin == nch) exit write(outfp, '(a)', advance='no') ',' fin=min(nch,fin+commainterval) sta=fin-commainterval+1 end do commaloop end if if (space > 0) then if (ilen < space) then write(outfp, '(a)', advance='no') repeat(' ',space-ilen) end if end if end subroutine padprint ! ! printing bignum ! subroutine bigprint(l, advance) integer :: l integer :: denom, i, ios, j, n, ndig, sgn, x integer(kind=8) :: first integer(kind=8), dimension(:), allocatable :: digit character(len=*), intent(in), optional :: advance integer, parameter :: scinot = 18/bigbase if (l == nil) then write(outfp,'(a)') 'nil' return end if if (iscirc(l)) then write(outfp,'(a)') 'Is a circular list!' return end if n = get_listlen(l) if (n == 0) then write(outfp,'(a)') 'zero length bignum!' return end if sgn=getsign(l) allocate(digit(n)) ndig=0 x=l i=n do while (ispair(x)) digit(i)=get_ivalue(car(x)) if (digit(i) > 0) ndig=ndig+1 i=i-1 x=cdr(x) end do if (sgn < 0) then write(outfp,'(a1)',advance='no') '-' end if if (n > scinot .and. ndig == 1 .and. digit(1) /= 0) then denom=0 first=digit(1) do while (mod(first,10) == 0) first=first/10 denom=denom+1 end do write(outfp, '(i0,a,i0)', advance='no') & first,' x 10^', (n-1)*bigbase+denom else write(outfp, '(i0)', advance='no') digit(1) do i=2, n write(outfp, fmt=bigbase_fmt, advance='no', iostat=ios) digit(i) end do end if if (present(advance)) then if (advance /= 'no') then write(outfp, *) end if end if end subroutine bigprint ! ! The number of digits to base b ! function bignum_digits_base(big1, b) integer :: bignum_digits_base integer :: big1 integer, intent(in) :: b double precision :: tmp, invlogb invlogb=1.0d0/log10(real(b,kind=8)) tmp=bignum_log10(big1) bignum_digits_base=int(floor(invlogb*tmp))+1 end function bignum_digits_base function big2str(l, outbase) result(res) character(len=:), allocatable :: res integer :: l integer, intent(in), optional :: outbase integer :: i, ob, obase, n, siz, x, y character(len=16), parameter :: digs='0123456789ABCDEF' character(len=1) :: ch obase=10 if (present(outbase)) obase=outbase if (obase == 10) then res=big2str10(l) else sgn=getsign(l) siz=bignum_digits_base(l, obase) if (sgn < 0) siz=siz+1 allocate(character(len=siz) :: res) res=repeat(' ',siz) reg9=int2big(int(obase,kind=8)) reg10=l i=siz if (sgn < 0) then res(1:1)='-' end if do while (.not.(bignum_zerop(reg10))) reg10=bignum_divide(reg10, reg9) n=get_ivalue(simplest_int(cadr(reg10))) res(i:i)=digs((n+1):(n+1)) reg10=car(reg10) i=i-1 end do end if end function big2str ! function big2str10(l, outbase) result(res) character(len=:), allocatable :: res integer :: l integer, intent(in), optional :: outbase integer :: i, j, lstr, n, obase, sgn, x character(len=bigbase) :: str integer, dimension(:), allocatable :: address n = get_listlen(l) if (n == 0) then write(outfp,'(a)') 'zero length bignum!' return end if sgn=getsign(l) allocate(address(n)) x=l i=n j=0 do while (ispair(x)) address(i)=car(x) i=i-1 x=cdr(x) end do write(str, '(i0)') get_ivalue(address(1)) ! last "digit" is the one with variable length lstr=bigbase*(n-1)+len_trim(str) if (sgn < 0) lstr=lstr+1 allocate(character(len=lstr) :: res) res=repeat(' ',lstr) if (sgn < 0) then res(1:1)='-' j=j+1 end if i=1 do lstr=len_trim(str) res((j+1):(j+lstr))=trim(str) j=j+lstr i=i+1 if (i > n) exit write(str, fmt=bigbase_fmt) get_ivalue(address(i)) end do end function big2str10 ! function ok_abbrev(x) logical :: ok_abbrev integer :: x ok_abbrev=(ispair(x) .and. cdr(x) /= nil) end function ok_abbrev ! subroutine s_save(a, b, c) integer :: a, b, c dump = cons(envir, cons(c, dump)) dump = cons(b, dump) dump = cons(mk_number(int(a, kind=8)), dump) end subroutine s_save subroutine s_return(a) integer :: a value = a oper = get_ivalue(car(dump)) scm_args = cadr(dump) envir = caddr(dump) code = cadddr(dump) dump = cddddr(dump) end subroutine s_return subroutine s_retbool(tf) logical :: tf if (tf) then call s_return(t) else call s_return(f) end if end subroutine s_retbool ! ! Apply Scheme commands - split into opexe0 to opexe14 ! load -- let* ! subroutine opexe0(op, inline) integer :: op integer :: inline integer :: x, y integer :: ioerr logical :: ios ! load if (op == OP_LOAD) then if (.not.isstring(car(scm_args))) then call error0('load -- argument is not string') return else loadfil=trim(get_string(car(scm_args))) inquire(file=trim(loadfil), exist=ios) if (.not.ios) then loadfil=' ' call error1('Unable to find file ', car(scm_args)) return else if (nloaded == MAXPORT) then call error1('Too many open input streams opening', car(scm_args)) return else call newlun(infp) open(infp, file=trim(loadfil), status='old', iostat=ioerr) if (ioerr == 0) then write(outstr, '(3a)') 'Loading "', trim(loadfil), '".' call save_linbuffer(ioerr) loadaddress(nloaded)=infp else loadfil=' ' call error1('Failed opening', car(scm_args)) return end if end if end if oper=OP_T0LVL ! top level else if (op == OP_T0LVL) then if (inline /= 3 .and. inline /= 4) write(outstr,*) dump = nil envir = global_env call s_save(OP_VALUEPRINT, nil, nil); call s_save(OP_T1LVL, nil, nil); if (inline == 1 .and. infp == STDIN) then write(*, '(a)', advance='no') prompt_string end if oper=OP_READ else if (op == OP_T1LVL) then code=value oper=OP_EVAL ! read else if (op == OP_READ) then tok=token() oper=OP_RDSEXPR ! print evaluation result else if (op == OP_VALUEPRINT) then print_flag=1 outfp=outstr scm_args=value call s_save(OP_T0LVL, nil, nil) oper=OP_P0LIST ! main part of evaluation else if (op == OP_EVAL) then ! symbol if (issymbol(code)) then x=envir do while (x /= nil) y=car(x) do while (y /= nil) if (caar(y) == code) exit y=cdr(y) end do if (y /= nil) exit x=cdr(x) end do if (x /= nil) then call s_return(cdar(y)) else call error1('Unbound variable', code) end if else if (ispair(code) .and. .not.isnumber(code)) then ! syntax x = car(code) if (issyntax(x)) then code = cdr(code); oper=syntaxnum(x) ! first, eval top element and eval arguments else call s_save(OP_E0ARGS, nil, code) code = car(code) oper=OP_EVAL end if else call s_return(code) end if ! eval arguments else if (op == OP_E0ARGS) then if (ismacro(value)) then call s_save(OP_DOMACRO, nil, nil) scm_args = cdr(code) code = value oper=OP_APPLY else code=cdr(code) oper=OP_E1ARGS end if else if (op == OP_E1ARGS) then scm_args=cons(value, scm_args) ! continue if (ispair(code)) then call s_save(OP_E1ARGS, scm_args, cdr(code)) code=car(code) scm_args=nil oper=OP_EVAL ! end else scm_args=reverse(scm_args) code=car(scm_args) scm_args=cdr(scm_args) oper=OP_APPLY end if ! apply code to args else if (op == OP_APPLY) then if (isproc(code)) then oper=procnum(code) else if (isclosure(code)) then envir= cons(nil, cdr(code)) x=car(car(code)) y=scm_args do while (ispair(x)) if (y == nil) then call error0('Too few arguments') return else call set_car(envir, cons(cons(car(x), car(y)), car(envir))) end if x=cdr(x) y=cdr(y) end do if (x == nil) then continue else if (issymbol(x)) then call set_car(envir, cons(cons(x,y), car(envir))) else call error0('Syntax error in closure') return end if code=cdar(code) scm_args=nil oper=OP_BEGIN ! continuation else if (iscontinuation(code)) then dump=cdr(code) if (scm_args /= nil) then call s_return(car(scm_args)) else call s_return(nil) end if else call error0('Illegal function') return end if ! do macro else if (op == OP_DOMACRO) then code=value oper=OP_EVAL ! lambda else if (op == OP_LAMBDA) then call s_return(mk_closure(code, envir)) ! make-closure else if (op == OP_MKCLOSURE) then x=car(scm_args) if (car(x) == lambda) then x=cdr(x) end if if (cdr(scm_args) == nil) then y=envir else y=cadr(scm_args) end if call s_return(mk_closure(x, y)) ! quote else if (op == OP_QUOTE) then call s_return(car(code)) ! define else if (op == OP_DEF0) then if (ispair(car(code))) then x=caar(code) code=cons(lambda, cons(cdar(code), cdr(code))) else x=car(code) code=cadr(code) end if if (.not.issymbol(x)) then call error0('Variable is not symbol') return end if call s_save(OP_DEF1, nil, x) oper=OP_EVAL ! define else if (op == OP_DEF1) then x=car(envir) do while (x /= nil) if (caar(x) == code) exit x=cdr(x) end do if (x /= nil) then call set_cdar(x, value) else call set_car(envir, cons(cons(code, value), car(envir))) call update_env() end if call s_return(code) ! set! else if (op == OP_SET0) then call s_save(OP_SET1, nil, car(code)) code=cadr(code) oper=OP_EVAL ! set! else if (op == OP_SET1) then x=envir do while (x /= nil) y=car(x) do while (y /= nil) if (caar(y) == code) exit y=cdr(y) end do if (y /= nil) exit x=cdr(x) end do if (x /= nil) then call set_cdar(y, value) call s_return(value) else call error1('Unbound variable', code) end if ! begin else if (op == OP_BEGIN) then if (.not.ispair(code)) then call s_return(code) else if (cdr(code) /= nil) then call s_save(OP_BEGIN, nil, cdr(code)) end if code = car(code) oper=OP_EVAL end if ! if else if (op == OP_IF0) then call s_save(OP_IF1, nil, cdr(code)) code = car(code) oper=OP_EVAL else if (op == OP_IF1) then if (istrue(value)) then code=car(code) else code=cadr(code) end if oper=OP_EVAL ! let else if (op == OP_LET0) then scm_args=nil value=code if (issymbol(car(code))) then code=cadr(code) else code=car(code) end if oper=OP_LET1 ! let (calculate parameters) else if (op == OP_LET1) then scm_args=cons(value, scm_args) if (ispair(code)) then call s_save(OP_LET1, scm_args, cdr(code)) code=cadar(code) scm_args=nil oper=OP_EVAL else scm_args=reverse(scm_args) code=car(scm_args) scm_args=cdr(scm_args) oper=OP_LET2 end if else if (op == OP_LET2) then envir=cons(nil, envir) if (issymbol(car(code))) then x=cadr(code) else x=car(code) end if y=scm_args do while (y /= nil) call set_car(envir, cons(cons(caar(x), car(y)), car(envir))) x=cdr(x) y=cdr(y) end do ! named let if (issymbol(car(code))) then x=cadr(code) scm_args=nil do while (x /= nil) scm_args=cons(caar(x), scm_args) x=cdr(x) end do x=mk_closure(cons(reverse(scm_args), cddr(code)), envir) call set_car(envir, cons(cons(car(code), x), car(envir))) code=cddr(code) scm_args=nil else code=cdr(code) scm_args=nil end if oper=OP_BEGIN ! let* else if (op == OP_LET0AST) then if (car(code) == nil) then envir = cons(nil, envir) code=cdr(code) oper=OP_BEGIN else call s_save(OP_LET1AST, cdr(code), car(code)) code=cadaar(code) oper=OP_EVAL end if ! let* (make new frame) else if (op == OP_LET1AST) then envir=cons(nil, envir) oper=OP_LET2AST ! let* (calculate parameters) else if (op == OP_LET2AST) then call set_car(envir, cons(cons(caar(code), value), car(envir))) code = cdr(code) ! continue if (ispair(code)) then call s_save(OP_LET2AST, scm_args, code) code = cadar(code) scm_args = nil oper=OP_EVAL ! end else code = scm_args scm_args = nil oper=OP_BEGIN end if else write(*, '(i3,a)') oper, ' is an illegal operator' end if end subroutine opexe0 ! ! Scheme procedures letrc -- call/cc ! subroutine opexe1(op) integer :: op integer :: x, y ! letrec if (op == OP_LET0REC) then envir = cons(nil, envir) scm_args = nil value = code code = car(code) oper=OP_LET1REC ! letrec calculate parameters else if (op == OP_LET1REC) then scm_args = cons(value, scm_args) if (ispair(code)) then ! continue call s_save(OP_LET1REC, scm_args, cdr(code)) code=cadar(code) scm_args=nil oper=OP_EVAL else ! end scm_args = reverse(scm_args) code = car(scm_args) scm_args = cdr(scm_args) oper=OP_LET2REC end if ! letrec else if (op == OP_LET2REC) then x=car(code) y=scm_args do while (y /= nil) call set_car(envir, cons(cons(caar(x), car(y)), car(envir))) x=cdr(x) y=cdr(y) end do code=cdr(code) scm_args=nil oper=OP_BEGIN ! cond else if (op == OP_COND0) then if (.not.ispair(code)) then call error0('Syntax error in cond') return end if call s_save(OP_COND1, nil, code) code=caar(code) oper=OP_EVAL else if (op == OP_COND1) then if (istrue(value)) then code= cdar(code) if (code == nil) then call s_return(value) else if (car(code) == feedto) then if (.not.ispair(cdr(code))) then call error0('Syntax error in cond') return end if x=cons(quote, cons(value, nil)) code=cons(cadr(code), cons(x, nil)) oper=OP_EVAL else oper=OP_BEGIN end if end if else code=cdr(code) if (code == nil) then call s_return(nil) else call s_save(OP_COND1, nil, code) code=caar(code) oper=OP_EVAL end if end if ! delay else if (op == OP_DELAY) then x=mk_closure(cons(nil, code), envir) call set_type(x, ior(T_PROMISE, typeof(x))) call s_return(x) ! and else if (op == OP_AND0) then if (code==nil) then call s_return(t) else call s_save(OP_AND1, nil, cdr(code)) code=car(code) oper=OP_EVAL end if ! and else if (op == OP_AND1) then if (isfalse(value)) then call s_return(value) else if (code == nil) then call s_return(value) else call s_save(OP_AND1, nil, cdr(code)) code=car(code) oper=OP_EVAL end if ! or else if (op == OP_OR0) then if (code==nil) then call s_return(f) end if call s_save(OP_OR1, nil, cdr(code)) code=car(code) oper=OP_EVAL ! or else if (op == OP_OR1) then if (istrue(value)) then call s_return(value) else if (code == nil) then call s_return(value) else call s_save(OP_OR1, nil, cdr(code)) code=car(code) oper=OP_EVAL end if ! cons-stream else if (op == OP_C0STREAM) then call s_save(OP_C1STREAM, nil, cdr(code)) code=car(code) oper=OP_EVAL ! cons-stream else if (op == OP_C1STREAM) then scm_args=value x=mk_closure(cons(nil, code), envir) call set_type(x, ior(T_PROMISE, typeof(x))) call s_return(cons(scm_args, x)) ! define-macro else if (op == OP_0MACRO) then x = car(code) code = cadr(code) if (.not.issymbol(x)) then call error0('Variable is not symbol') return end if call s_save(OP_1MACRO, nil, x) oper=OP_EVAL else if (op == OP_1MACRO) then call set_type(value, ior(T_MACRO, typeof(value))) x=car(envir) do while (x /= nil) if (caar(x) == code) exit x = cdr(x) end do if (x /= nil) then call set_cdar(x, value) else call set_car(envir, cons(cons(code, value), car(envir))) end if call s_return(code) ! case else if (op == OP_CASE0) then call s_save(OP_CASE1, nil, cdr(code)) code=car(code) oper=OP_EVAL ! case else if (op == OP_CASE1) then x=code do while (x /= nil) y=caar(x) if (.not.ispair(y)) then exit end if do while (y /= nil) if (eqv(car(y), value)) then exit end if y=cdr(y) end do if (y /= nil) exit x = cdr(x) end do if (x /= nil) then if (ispair(caar(x))) then code = cdar(x) oper=OP_BEGIN ! else else call s_save(OP_CASE2, nil, cdar(x)) code=caar(x) oper=OP_EVAL end if else call s_return(nil) end if ! case else if (op == OP_CASE2) then if (istrue(value)) then oper=OP_BEGIN else call s_return(nil) end if ! apply else if (op == OP_PAPPLY) then code=car(scm_args) if (cddr(scm_args) /= nil) then y = cdr(scm_args) x = cdr(y) do while (cdr(x) /= nil) y=cdr(y) x=cdr(x) end do call set_cdr(y, car(x)) x=car(x) scm_args=cdr(scm_args) else scm_args=cadr(scm_args) end if oper=OP_APPLY ! eval else if (op == OP_PEVAL) then code=car(scm_args) scm_args=nil oper=OP_EVAL ! call-with-current-continuation else if (op == OP_CONTINUATION) then code=car(scm_args) scm_args=cons(mk_continuation(dump), nil) oper=OP_APPLY else write(outstr, '(2a)') oper, 'is an illegal operator!' end if end subroutine opexe1 ! ! Scheme procedures plus -- set-cdr! ! subroutine opexe2(op) integer :: op integer :: x, y logical :: int_op, bigint_op integer :: ios, denom, res, sgn, wrk integer (kind=8) :: d, i, tmp, v character (len=40) :: str double precision :: rv int_op=.true. bigint_op=.false. ! + if (op == OP_ADD) then x = scm_args v = 0 rv= 0.0d0 do while (x /= nil) if (.not.isnumber(car(x))) then call error1('Argument to + is not a number: ', car(x)) return else if (isbignum(car(x))) then if (.not.bigint_op) then bigint_op=.true. if (int_op) then int_op=.false. write(str,'(i40)', iostat=ios) v if (ios /= 0) then call error1('Intermediate result in +: ', car(x)) return end if else write(str,'(i40)', iostat=ios) int(rv, kind=8) if (ios /= 0) then call error1('Intermediate result in +: ', car(x)) return end if end if res=mk_bignumber(adjustl(str)) ! call bigprint(res, advance='yes') end if res=bignum_addsub(1, res, car(x)) else if (isfloat(car(x))) then if (int_op) then int_op=.false. rv=v else if (bigint_op) then bigint_op=.false. rv=rvalue(res) end if rv=rv+rvalue(car(x)) else if (bigint_op) then res=bignum_addsub(1, res, int2big(get_ivalue(car(x)))) else if (int_op) then v=v+get_ivalue(car(x)) else rv=rv+rvalue(car(x)) end if x=cdr(x) end do if (bigint_op) then call s_return(res) call cleanup_regs() else if (int_op) then call s_return(mk_number(v)) else call s_return(mk_real(rv)) end if ! - else if (op == OP_SUB) then x = cdr(scm_args) if (.not.isnumber(car(scm_args))) then call error1('Argument to - is not a number: ', car(scm_args)) return else if (isbignum(car(scm_args))) then int_op=.false. bigint_op=.true. res=car(scm_args) else if (isfloat(car(scm_args))) then int_op=.false. rv = rvalue(car(scm_args)) else v = get_ivalue(car(scm_args)) end if i = 1 do while (x /= nil) i=i+1 if (.not.isnumber(car(x))) then call error1('Argument to - is not a number: ', car(x)) return else if (isbignum(car(x))) then if (bigint_op) then res=bignum_addsub(-1, res, car(x)) else if (int_op) then bigint_op=.true. int_op=.false. res=int2big(v) res=bignum_addsub(-1, res, int2big(get_ivalue(car(x)))) else rv=rv-rvalue(car(x)) end if else if (isfloat(car(x))) then if (bigint_op) then bigint_op=.not.bigint_op rv=rvalue(res) else if (int_op) then int_op=.false. rv=v end if rv=rv-rvalue(car(x)) else if (bigint_op) then res=bignum_addsub(-1, res, int2big(get_ivalue(car(x)))) else if (int_op) then v=v-get_ivalue(car(x)) else rv=rv-rvalue(car(x)) end if x=cdr(x) end do if (i==1) then if (int_op) then v=-v else if (bigint_op) then call set_sign(res, -1) else rv=-rv end if end if if (bigint_op) then call s_return(res) call cleanup_regs() else if (int_op) then call s_return(mk_number(v)) else call s_return(mk_real(rv)) end if ! * else if (op == OP_MUL) then x = scm_args v = 1 rv = 1.0d0 do while (x /= nil) if (.not.isnumber(car(x))) then call error1('Argument to * is not a number: ', car(x)) return else if (int_op) then if (isbignum(car(x))) then int_op=.false. bigint_op=.true. res=int2big(v) res=bignum_multiply(res, car(x)) else if (isinteger(car(x))) then tmp=get_ivalue(car(x)) ! test if * will overflow if (log(real(tmp, kind=8))+log(real(v,kind=8)) > lbigbase) then int_op=.false. bigint_op=.true. res=int64_multiply(v, tmp) call set_sign(res, int(sign(1_8,v)*sign(1_8,tmp),kind=4)) else v=v*tmp end if else int_op=.false. rv=real(v,kind=8)*rvalue(car(x)) end if else if (bigint_op) then if (isbignum(car(x))) then res=bignum_multiply(res, car(x)) else if (isinteger(car(x))) then res=bignum_multiply(res, int2big(get_ivalue(car(x)))) else bigint_op=.false. rv=rvalue(res)*rvalue(car(x)) end if else if (isfloat(car(x))) then if (bigint_op) then bigint_op=.false. rv=rvalue(res) end if rv=rv*rvalue(car(x)) else rv=rv*rvalue(car(x)) end if x=cdr(x) end do if (bigint_op) then call s_return(res) call cleanup_regs() else if (int_op) then call s_return(mk_number(v)) else call s_return(mk_real(rv)) end if ! / else if (op == OP_DIV) then x = cdr(scm_args) if (.not.isnumber(car(scm_args))) then call error1('Argument to / is not a number: ', car(scm_args)) return else rv = rvalue(car(scm_args)) end if if (x == nil) then rv=1.0d0/rv else do while (x /= nil) if (.not.isnumber(car(x))) then call error1('Argument to / is not a number: ', car(x)) return else if (rvalue(car(x)) /= 0.0d0) then rv=rv/rvalue(car(x)) else call error0('Divided by zero!') return end if end if x=cdr(x) end do end if call s_return(mk_real(rv)) ! quotient else if (op == OP_INTDIV) then x = cdr(scm_args) if (.not.isnumber(car(scm_args))) then call error1('Argument to quotient is not a number: ', car(scm_args)) return else if (isbignum(car(scm_args))) then bigint_op=.true. res=car(scm_args) else if (isfloat(car(scm_args))) then v = int(rvalue(car(scm_args)), kind=8) else v = get_ivalue(car(scm_args)) end if do while (x /= nil) if (.not.isnumber(car(x))) then call error1('Argument to quotient is not a number: ', car(x)) return else if (isbignum(car(x))) then if (.not.bigint_op) then res=int2big(v) end if bigint_op=.true. end if if (bigint_op) then if (isbignum(car(x))) then denom=car(x) elseif (isfloat(car(x))) then denom=int2big(int(rvalue(car(x)), kind=8)) else denom=int2big(get_ivalue(car(x))) end if if (bignum_zerop(denom)) then call error0('Divided by zero!') return else res=car(bignum_divide(res, denom)) call cleanup_regs() end if else if (isbignum(car(x))) then d=int(rvalue(car(x)), kind=8) else if (isfloat(car(x))) then d=int(rvalue(car(x)), kind=8) else d=get_ivalue(car(x)) end if if (d /= 0) then v=v/d else call error0('Divided by zero!') return end if end if x=cdr(x) end do if (bigint_op) then res=simplest_int(res) call s_return(res) call cleanup_regs() else call s_return(mk_number(v)) end if ! remainder else if (op == OP_REM) then x = cdr(scm_args) if (.not.isnumber(car(scm_args))) then call error1('Argument to rem is not a number: ', car(scm_args)) return else if (isbignum(car(scm_args))) then int_op=.false. bigint_op=.true. res=car(scm_args) else if (isfloat(car(scm_args))) then int_op=.false. rv = rvalue(car(scm_args)) else v = get_ivalue(car(scm_args)) end if do while (x /= nil) if (.not.isnumber(car(x))) then call error1('Argument to rem is not a number: ', car(x)) return else if (isbignum(car(x))) then if (bignum_zerop(car(x))) then call error0('Divided by zero!') return else if (int_op) then int_op=.false. bigint_op=.true. res=int2big(v) end if if (bigint_op) then res=cadr(bignum_divide(res, car(x))) call cleanup_regs() else rv=mod(rv, rvalue(car(x))) end if else if (isfloat(car(x))) then if (int_op) then int_op=.false. rv=v else if (bigint_op) then bigint_op=.false. rv=rvalue(res) end if if (rvalue(car(x)) /= 0) then rv=mod(rv, rvalue(car(x))) else call error0('Divided by zero!') return end if else if (bigint_op) then res=cadr(bignum_divide(res, asbignum(car(x)))) call cleanup_regs() else if (int_op) then if (get_ivalue(car(x)) /= 0) then v=mod(v, int(get_ivalue(car(x)), kind=8)) else call error0('Divided by zero!') return end if else if (get_ivalue(car(x)) /= 0) then rv=mod(rv, dble(get_ivalue(car(x)))) else call error0('Divided by zero!') return end if end if x=cdr(x) end do if (int_op) then call s_return(mk_number(v)) elseif (bigint_op) then res=simplest_int(res) call s_return(res) else call s_return(mk_real(rv)) end if ! modulo else if (op == OP_MOD) then if (isinteger(car(scm_args)) .and. isinteger(cadr(scm_args))) then x=car(scm_args) y=cadr(scm_args) i = get_ivalue(y) if (i /= 0) then v = mod(get_ivalue(x), i) if (v*i < 0) then i=abs(i) if (v > 0) then v=v-i else v=v+i end if end if call s_return(mk_number(v)) else call error0('Modulo x 0 not allowed!') end if else if (isbignum(car(scm_args)) .or. isbignum(cadr(scm_args))) then x=asbignum(car(scm_args)) y=asbignum(cadr(scm_args)) if (bignum_zerop(y)) then call error0('Modulo x 0 not allowed!') else res=bignum_divide(x, y) res=cadr(res) sgn=getsign(res)*getsign(cadr(scm_args)) if (sgn == -1) then if (.not.(bignum_zerop(res))) then res=bignum_addsub(-sgn, res, asbignum(cadr(scm_args))) end if end if res=simplest_int(res) call s_return(res) call cleanup_regs() end if else call error0('Arguments must be integer!') end if ! car else if (op == OP_CAR) then if (ispair(car(scm_args))) then call s_return(caar(scm_args)) else call error0('Unable to car for a non-cons cell!') end if ! cdr else if (op == OP_CDR) then if (ispair(car(scm_args))) then call s_return(cdar(scm_args)) else call error0('Unable to cdr for a non-cons cell!') end if ! cons else if (op == OP_CONS) then call set_cdr(scm_args, cadr(scm_args)) call s_return(scm_args) ! set-car! else if (op == OP_SETCAR) then if (ispair(car(scm_args))) then call set_caar(scm_args, cadr(scm_args)) call s_return(car(scm_args)) else call error0('Unable to set-car! for a non-cons cell!') end if ! set-cdr! else if (op == OP_SETCDR) then if (ispair(car(scm_args))) then call set_cdar(scm_args, cadr(scm_args)) call s_return(car(scm_args)) else call error0('Unable to set-cdr! for a non-cons cell!') end if else write(outstr, '(2a)') oper, 'is an illegal operator!' end if end subroutine opexe2 ! ! Scheme procedures not -- eqv? ! subroutine opexe3(op) integer :: op integer :: ic, w, x double precision :: v logical :: comp, bigint_op bigint_op=.false. ! not if (op == OP_NOT) then call s_retbool(isfalse(car(scm_args))) ! boolean? else if (op == OP_BOOL) then call s_retbool(car(scm_args) == f .or. car(scm_args) == t) ! integer? else if (op == OP_ISINT) then call s_retbool(isinteger(car(scm_args)) .or. isbignum(car(scm_args))) ! real? else if (op == OP_ISREAL) then call s_retbool(isfloat(car(scm_args))) ! null else if (op == OP_NULL) then call s_retbool(car(scm_args) == nil) ! zero? else if (op == OP_ZEROP) then call s_retbool(rvalue(car(scm_args)) == 0.0d0) ! positive? else if (op == OP_POSP) then call s_retbool(rvalue(car(scm_args)) > 0.0d0) ! negative? else if (op == OP_NEGP) then call s_retbool(rvalue(car(scm_args)) < 0.0d0) ! =, <, >, <=, >= else if (op >= OP_NUMEQ .and. op <= OP_GEQ) then x = cdr(scm_args) if (.not.isnumber(car(scm_args))) then call error1('Comparison argument is not a number: ', car(scm_args)) return else if (isbignum(car(scm_args))) then bigint_op=.true. w=car(scm_args) else v = rvalue(car(scm_args)) end if do while (x /= nil) if (.not.isnumber(car(x))) then call error1('Comparison argument is not a number: ', car(x)) return else if (bigint_op) then if (.not.isbignum(car(x))) then bigint_op=.false. v=rvalue(w) end if end if if (bigint_op) then ic=bignum_cmp(w, car(x)) if (op == OP_NUMEQ) then comp=(ic == 0) else if (op == OP_LESS) then comp=(ic == -1) else if (op == OP_GRE) then comp=(ic == 1) else if (op == OP_LEQ) then comp=(ic < 1) else if (op == OP_GEQ) then comp=(ic > -1) end if else if (op == OP_NUMEQ) then comp=(v==rvalue(car(x))) else if (op == OP_LESS) then comp=(vrvalue(car(x))) else if (op == OP_LEQ) then comp=(v<=rvalue(car(x))) else if (op == OP_GEQ) then comp=(v>=rvalue(car(x))) end if end if if (.not.comp) exit end if x=cdr(x) end do call s_retbool(comp) ! symbol? else if (op == OP_SYMBOL) then call s_retbool(issymbol(car(scm_args))) ! number? else if (op == OP_NUMBER) then call s_retbool(isnumber(car(scm_args))) ! string? else if (op == OP_STRING) then call s_retbool(isstring(car(scm_args))) ! procedure? else if (op == OP_PROC) then call s_retbool(isproc(car(scm_args)) .or. isclosure(car(scm_args)) .or. & iscontinuation(car(scm_args))) ! pair? else if (op == OP_PAIR) then call s_retbool(ispair(car(scm_args))) ! list? else if (op == OP_LIST) then comp=isproper(car(scm_args)) if (comp) comp=(get_listlen(car(scm_args)) >= 0) call s_retbool(comp) ! eq? else if (op == OP_EQ) then call s_retbool(car(scm_args) == cadr(scm_args)) ! eqv? else if (op == OP_EQV) then call s_retbool(eqv(car(scm_args),cadr(scm_args))) else write(outstr, '(2a)') oper, 'is an illegal operator!' end if end subroutine opexe3 ! ! Scheme procedures force -- gc -- new-segment ! subroutine opexe4(op, plevel) integer, intent(in) :: op integer, intent(in) :: plevel integer :: x, y ! force if (op == OP_FORCE) then code = car(scm_args) if (ispromise(code)) then scm_args=nil oper=OP_APPLY else call s_return(code) end if ! write or display else if (op == OP_WRITE .or. op == OP_DISPLAY) then print_flag=0 if (op == OP_WRITE) print_flag=print_flag+1 outfp=outstr if (ispair(cdr(scm_args))) then if (isport(cadr(scm_args))) then outfp=get_ivalue(cadr(scm_args)) end if end if scm_args=car(scm_args) oper=OP_P0LIST ! newline else if (op == OP_NEWLINE) then outfp=outstr if (ispair(scm_args)) then if (isport(car(scm_args))) then outfp=get_ivalue(car(scm_args)) end if end if if (plevel >= 0) write(outfp,*) call s_return(un) ! error else if (op == OP_ERR0) then if (.not.isstring(car(scm_args))) then call error0('Error -- first argument must be a string') end if write(outstr, '(2a)', advance='no') 'Error: ', get_string(car(scm_args)) scm_args=cdr(scm_args) oper=OP_ERR1 ! error else if (op == OP_ERR1) then write(outstr, '(a)', advance='no') ' ' if (scm_args /= nil) then call s_save(OP_ERR1, cdr(scm_args), nil) scm_args=car(scm_args) print_flag=1 oper=OP_P0LIST else write(outstr,*) call flushinput() oper=OP_T0LVL end if ! reverse else if (op == OP_REVERSE) then if (get_listlen(car(scm_args)) < 0) then call error0('argument of reverse must be a list') return end if call s_return(reverse(car(scm_args))) ! append else if (op == OP_APPEND) then if (scm_args == nil) then call s_return(nil) end if x=car(scm_args) y=cdr(scm_args) if (y == nil) then call s_return(x) else do while (y /= nil) x=append(x, car(y)) y=cdr(y) end do call s_return(x) end if ! gc else if (op == OP_GC .or. op == OP_GCVERB) then if (op == OP_GC .or. scm_args == nil) then call gc(nil, nil, 1) ! memory-allocate else if (.not.isnumber(car(scm_args))) then call error0('memory-allocate -- argument must be a number!') return else #if ALL_DOUBLEINT call setup_mem(get_ivalue(car(scm_args))) #else call setup_mem(int(get_ivalue(car(scm_args)), kind=4)) #endif end if call s_return(t) ! new segment size else if (op == OP_NEWSEGMENT) then if (scm_args == nil) then continue else if (.not.isnumber(car(scm_args))) then call error0('new segment -- argument must be a number!') return else cell_segment=get_ivalue(car(scm_args)) end if write(outstr, '(a,i0,a)') & 'Allocation of new memory in increments of ', cell_segment, ' cells' call s_return(mk_number(int(cell_segment, kind=8))) end if end subroutine opexe4 ! ! Scheme procedures read expression ! subroutine opexe5(op, plevel) integer, intent(in) :: op integer, intent(in) :: plevel integer :: x integer :: strlen character (len=10000) :: str character (len=1) :: ch if (op == OP_RDSEXPR) then if (tok == M_COMMENT) then do call inchar(ch) if (currentline > eol) exit end do tok = token() oper=OP_RDSEXPR else if (tok == M_LPAREN) then tok = token() if (tok == M_RPAREN) then call s_return(nil) else if (tok == M_DOT) then call error0('Syntax error -- illegal dot expression') else call s_save(OP_RDLIST, nil, nil) oper=OP_RDSEXPR end if else if (tok == M_QUOTE) then call s_save(OP_RDQUOTE, nil, nil) tok=token() oper=OP_RDSEXPR else if (tok == M_BQUOTE) then call s_save(OP_RDQQUOTE, nil, nil) tok=token() oper=OP_RDSEXPR else if (tok == M_COMMA) then call s_save(OP_RDUNQUOTE, nil, nil) tok=token() oper=OP_RDSEXPR else if (tok == M_ATMARK) then call s_save(OP_RDUQTSP, nil, nil) tok=token() oper=OP_RDSEXPR else if (tok == M_ATOM) then call readstr(str) call s_return(mk_atom(trim(str))) else if (tok == M_DQUOTE) then call readstrexp(str, strlen) call s_return(mk_string(str(1:strlen))) else if (tok == M_SHARP) then call readstr(str) x=mk_const(str) if (x == nil) then call error0('Undefined sharp expression') else call s_return(x) end if else call error0('syntax error -- illegal token') end if else if (op == OP_RDLIST) then scm_args = cons(value, scm_args) tok = token() if (tok == M_COMMENT) then do call inchar(ch) if (currentline > eol) exit end do tok = token() end if if (tok == M_RPAREN) then call s_return(non_alloc_rev(nil, scm_args) ) else if (tok == M_DOT) then call s_save(OP_RDDOT, scm_args, nil) tok=token() oper=OP_RDSEXPR else call s_save(OP_RDLIST, scm_args, nil) oper=OP_RDSEXPR end if else if (op == OP_RDDOT) then if (token() /= M_RPAREN) then call error0('syntax error -- illegal dot expression') end if call s_return(non_alloc_rev(value, scm_args)) else if (op == OP_RDQUOTE) then call s_return(cons(quote, cons(value, nil))) else if (op == OP_RDQQUOTE) then call s_return(cons(qquote, cons(value, nil))) else if (op == OP_RDUNQUOTE) then call s_return(cons(unquote, cons(value, nil))) else if (op == OP_RDUQTSP) then call s_return(cons(unquotesp, cons(value, nil))) else if (op == OP_P0LIST) then if (.not.ispair(scm_args) .or. isbignum(scm_args)) then if (plevel >= 0) call printatom(scm_args, 0, -1, 0, ' ') call s_return(un) else if (car(scm_args) == quote .and. ok_abbrev(cdr(scm_args))) then if (plevel >= 0) write(outfp, '(a)', advance='no') '"' scm_args=cadr(scm_args) oper=OP_P0LIST else if (car(scm_args) == qquote .and. ok_abbrev(cdr(scm_args))) then if (plevel >= 0) write(outfp, '(a)', advance='no') '`' scm_args=cadr(scm_args) oper=OP_P0LIST else if (car(scm_args) == unquote .and. ok_abbrev(cdr(scm_args))) then if (plevel >= 0) write(outfp, '(a)', advance='no') ',' scm_args=cadr(scm_args) oper=OP_P0LIST else if (car(scm_args) == unquotesp .and. ok_abbrev(cdr(scm_args))) then if (plevel >= 0) write(outfp, '(a)', advance='no') ',@' scm_args=cadr(scm_args) oper=OP_P0LIST else if (plevel >= 0) write(outfp, '(a)', advance='no') '(' if (iscirc(scm_args)) then call s_save(OP_P1LIST, nil, nil) else call s_save(OP_P1LIST, cdr(scm_args), nil) end if scm_args=car(scm_args) oper=OP_P0LIST end if else if (op == OP_P1LIST) then if (ispair(scm_args)) then call s_save(OP_P1LIST, cdr(scm_args), nil) if (plevel >= 0) write(outfp, '(a)', advance='no') ' ' scm_args=car(scm_args) oper=OP_P0LIST else if (scm_args /= nil) then if (plevel >= 0) then write(outfp, '(a)', advance='no') ' . ' call printatom(scm_args, 0, -1, 0, ' ') end if end if if (plevel >= 0) write(outfp, '(a)', advance='no') ')' call s_return(un) end if else write(outstr, '(2a)') oper, 'is an illegal operator!' end if end subroutine opexe5 ! ! Scheme procedures length -- macro? ! subroutine opexe6(op) integer :: op integer :: w, x, y ! list-length if (op == OP_LIST_LENGTH) then w=get_listlen(car(scm_args)) if (w < 0) then call error1('Not a list:', car(scm_args)) else call s_return(mk_number(int(w, kind=8))) end if ! assq else if (op == OP_ASSQ) then x=car(scm_args) y=cadr(scm_args) do while (ispair(y)) if (.not.ispair(car(y))) then call error0('Unable to handle non-pair element') return end if if (x == caar(y)) exit y=cdr(y) end do if (ispair(y)) then call s_return(car(y)) else call s_return(f) end if ! get-closure-code else if (op == OP_GET_CLOSURE) then scm_args=car(scm_args) if (scm_args == nil) then call s_return(f) else if (isclosure(scm_args)) then call s_return(cons(lambda, car(value))) else if (ismacro(scm_args)) then call s_return(cons(lambda, car(value))) else call s_return(f) end if ! closure? else if (op == OP_CLOSUREP) then if (car(scm_args) == nil) then call s_return(f) end if call s_retbool(isclosure(car(scm_args))) ! macro? else if (op == OP_MACROP) then if (car(scm_args) == nil) then call s_return(f) end if call s_retbool(ismacro(car(scm_args))) else write(outstr, '(2a)') oper, 'is an illegal operator!' end if end subroutine opexe6 ! ! Mathematical functions ! subroutine opexe7(op) integer :: op integer :: res, x, y integer (kind=8) :: v double precision :: rv x = car(scm_args) if (.not.isnumber(x)) then call error0('Math functions require numbers!') return end if ! exponentiation if (op == OP_EXP) then rv=exp(rvalue(x)) call s_return(mk_real(rv)) ! natural log else if (op == OP_LOG) then rv = log(rvalue(x)) call s_return(mk_real(rv)) ! sine else if (op == OP_SIN) then rv = sin(rvalue(x)) call s_return(mk_real(rv)) ! cosine else if (op == OP_COS) then rv = cos(rvalue(x)) call s_return(mk_real(rv)) ! tan else if (op == OP_TAN) then rv = tan(rvalue(x)) call s_return(mk_real(rv)) ! arcsine else if (op == OP_ASIN) then rv = asin(rvalue(x)) call s_return(mk_real(rv)) ! arcosine else if (op == OP_ACOS) then rv = acos(rvalue(x)) call s_return(mk_real(rv)) ! arctan else if (op == OP_ATAN) then rv = atan(rvalue(x)) call s_return(mk_real(rv)) ! sqrt else if (op == OP_SQRT) then if (isbignum(x)) then res=bignum_sqrt(x) res=simplest_int(res) call s_return(res) call cleanup_regs() else rv = sqrt(rvalue(x)) if (isinteger(x) .and. anint(rv) == rv) then call s_return(mk_number(int(rv, kind=8))) else call s_return(mk_real(rv)) end if end if ! truncate else if (op == OP_TRUNCATE) then rv = int(rvalue(x)) call s_return(mk_real(rv)) ! round else if (op == OP_ROUND) then rv = anint(rvalue(x)) call s_return(mk_real(rv)) ! abs else if (op == OP_ABS) then if (isinteger(x)) then v=abs(get_ivalue(x)) call s_return(mk_number(v)) else if (isbignum(x)) then call s_return(bignum_abs(x)) else rv = abs(rvalue(x)) call s_return(mk_real(rv)) end if else if (op == OP_EXPT) then y = cadr(scm_args) if (isnumber(y)) then rv = log(rvalue(x)) * rvalue(y) if (.not.isfloat(x) .and. .not.isfloat(y) .and. rvalue(y) >= 0) then if (rv > lbigbase .or. isbignum(x)) then call s_return(bignum_expt(asbignum(x),get_ivalue(y))) call cleanup_regs() else if (isinteger(x) .and. isinteger(y)) then v = get_ivalue(x) ** get_ivalue(y) call s_return(mk_number(v)) else call error0('expt ( )|( )|( )') return end if else rv = rvalue(x) ** rvalue(y) call s_return(mk_real(rv)) end if else call error0('expt requires numbers!') return end if end if end subroutine opexe7 ! ! A few other library functions eg min, max ! subroutine opexe8(op) use rngs integer :: op integer :: x logical :: int_op integer (kind=8) :: v double precision :: rv int_op=.true. ! min if (op == OP_MIN) then if (isnumber(car(scm_args))) then int_op=isinteger(car(scm_args)) if (int_op) then v=get_ivalue(car(scm_args)) else rv=rvalue(car(scm_args)) end if x = cdr(scm_args) do while (x /= nil) if (isfloat(car(x))) then if (int_op) then int_op=.false. rv=dble(v) end if rv=min(rv,rvalue(car(x))) else if (int_op) then v=min(v,get_ivalue(car(x))) else rv=min(rv,rvalue(car(x))) end if x=cdr(x) end do if (int_op) then call s_return(mk_number(v)) else call s_return(mk_real(rv)) end if else call error0('Min needs at least one argument!') end if ! max else if (op == OP_MAX) then if (isnumber(car(scm_args))) then int_op=isinteger(car(scm_args)) if (int_op) then v=get_ivalue(car(scm_args)) else rv=rvalue(car(scm_args)) end if x = cdr(scm_args) do while (x /= nil) if (isfloat(car(x))) then if (int_op) then int_op=.false. rv=dble(v) end if rv=max(rv,rvalue(car(x))) else if (int_op) then v=max(v,get_ivalue(car(x))) else rv=max(rv,rvalue(car(x))) end if x=cdr(x) end do if (int_op) then call s_return(mk_number(v)) else call s_return(mk_real(rv)) end if else call error0('Max needs at least one argument!') end if ! inexact->exact else if (op == OP_INTOEX) then if (isnumber(car(scm_args))) then rv=rvalue(car(scm_args)) if (rv > rbigbase) then call s_return(real2big(rv)) else if (rv == anint(rv)) then call s_return(mk_number(int(rv, kind=8))) else call error0('inexact->exact needs an integral numerical argument!') end if else call error0('inexact->exact needs a numerical argument!') end if ! exact->inexact else if (op == OP_EXTOIN) then if (isbignum(car(scm_args))) then rv=rvalue(car(scm_args)) call s_return(mk_real(rv)) else if (isnumber(car(scm_args))) then rv=real(get_ivalue(car(scm_args))) call s_return(mk_real(rv)) else call error0('exact->inexact needs an integer argument!') end if ! random else if (op == OP_RANDOM) then if (isnumber(car(scm_args))) then v=get_ivalue(car(scm_args)) if (v > 0) then #if ALL_DOUBLEINT call s_return(mk_number(irandom(1, v))) #else call s_return(mk_number(int(irandom(1, int(v, kind=4)), kind=8))) #endif else call s_return(mk_real(dble(random()))) end if else call s_return(mk_real(dble(random()))) end if end if end subroutine opexe8 ! ! string functions ! subroutine opexe9(op) integer :: op integer :: i, ioerr, j, k, l, seplen, v, x logical :: bigresult, comp, inword, intresult integer(kind=8) :: iv double precision :: rv character (len=1) :: ch character (len=40) :: str, sep character (len=200) :: bigstr ch=' ' ! make-string if (op == OP_MKSTRING) then l=get_ivalue(car(scm_args)) ch=' ' if (cdr(scm_args) /= nil) then ch=get_substr(cadr(scm_args), 0, 1) end if call s_return(mk_string(repeat(ch,l))) ! string-length else if (op == OP_STRLEN) then call s_return(mk_number(int(get_strlen(car(scm_args)), kind=8))) ! string-ref else if (op == OP_STRREF) then l=get_strlen(car(scm_args))-1 i=get_ivalue(cadr(scm_args)) if (i > l) then call error1('string-ref position out of bounds:', cadr(scm_args)) return end if call s_return(mk_string(get_substr(car(scm_args), i, i+1))) ! string-set! else if (op == OP_STRSET) then i=get_ivalue(cadr(scm_args))+1 if (i > get_strlen(car(scm_args))) then call error1('ERROR: string-set! out of bounds:', cadr(scm_args)) return end if call set_substring(car(scm_args), i, i, get_substr(caddr(scm_args), 0, 1)) call s_return(car(scm_args)) ! substring else if (op == OP_SUBSTR) then l=get_strlen(car(scm_args)) i=get_ivalue(cadr(scm_args)) if (i > l) then call error1('substring start out of bounds:', cadr(scm_args)) return end if if (cddr(scm_args) /= nil) then j=get_ivalue(caddr(scm_args)) if (j > l .or. j < i) then call error1('substring end out of bounds:', caddr(scm_args)) return end if else j=l end if call s_return(mk_string(get_substr(car(scm_args), i, j))) ! string-append else if (op == OP_STRAPPEND) then l=0 x=scm_args do while (x /= nil) l=l+get_strlen(car(x)) x=cdr(x) end do v=mk_string(repeat(' ',l)) i=0 l=0 x=scm_args do while (x /= nil) l=l+get_strlen(car(x)) call set_substring(v, i+1, l, get_string(car(x))) i=l x=cdr(x) end do call s_return(v) ! string-split else if (op == OP_STRSPLIT) then v=car(scm_args) l=get_strlen(v) sep=' ' seplen=1 inword=.false. if (l == 0) inword=.true. if (cdr(scm_args) /= nil) then sep=get_string(cadr(scm_args)) seplen=get_strlen(cadr(scm_args)) inword=.true. end if x=nil if (seplen == 0) then do i=1, l x=cons(mk_string(get_substr(v, i-1, i)), x) end do else j=1 do i=1, l ch=get_substr(v, i-1, i) if (scan(ch, sep(1:seplen)) > 0 .or. (sep == ' ' .and. ichar(ch) == 9)) then if (inword) then x=cons(mk_string(get_substr(v, j-1, i-1)), x) if (sep /= ' ') then j=i+1 else inword=.false. end if end if else if (.not.inword) then inword=.true. j=i end if end if end do if (inword) x=cons(mk_string(get_substr(v, j-1, l)), x) end if call s_return(non_alloc_rev(nil, x)) ! string=?, string?, string<=?, string>=?, substring? else if (op >= OP_STREQ .and. op <= OP_STRGE) then x = cdr(scm_args) if (.not.isstring(car(scm_args))) then call error1('Argument to string=? is not a string: ', car(scm_args)) return else bigstr=get_string(car(scm_args)) end if do while (x /= nil) if (.not.isstring(car(x))) then call error1('Argument to string=? is not a string: ', car(x)) return else if (op == OP_STREQ) then comp=(bigstr==get_string(car(x))) else if (op == OP_STRLT) then comp=(bigstrget_string(car(x))) else if (op == OP_STRLE) then comp=(bigstr<=get_string(car(x))) else if (op == OP_STRGE) then comp=(bigstr>=get_string(car(x))) end if if (.not.comp) exit end if x=cdr(x) end do call s_retbool(comp) ! substring? else if (op == OP_STRFIND) then if (.not.isstring(car(scm_args))) then call error1('First argument to substring? is not a string: ', car(scm_args)) return else if (.not.isstring(cadr(scm_args))) then call error1('Second argument to substring? is not a string: ', cadr(scm_args)) return end if i=index(get_string(cadr(scm_args)), get_string(car(scm_args))) if (i == 0) then call s_return(f) else call s_return(mk_number(int(i-1, kind=8))) end if ! char->integer else if (op == OP_CHAR2INT) then if (.not.isstring(car(scm_args))) then call error1('Argument to char->int is not a string: ', car(scm_args)) return end if str=get_string(car(scm_args)) i = ichar(str(1:1)) call s_return(mk_number(int(i,kind=8))) ! integer->char else if (op == OP_INT2CHAR) then i=get_ivalue(car(scm_args)) call s_return(mk_string(char(i))) ! char-upcase and char-downcase else if (op == OP_UPCASE .or. op == OP_DOWNCASE) then if (.not.isstring(car(scm_args))) then call error1('Non-character argument: ', car(scm_args)) return end if l=get_strlen(car(scm_args)) if (op == OP_UPCASE) then do i=1, l ch=get_substr(car(scm_args), i-1, i) ich=ichar(ch) if (ich > 96 .and. ich < 123) then ch=achar(ich-32) call set_substring(car(scm_args), i, i, ch) end if end do else do i=1, l ch=get_substr(car(scm_args), i-1, i) ich=ichar(ch) if (ich > 64 .and. ich < 91) then ch=achar(ich+32) call set_substring(car(scm_args), i, i, ch) end if end do end if call s_return(car(scm_args)) ! string->number else if (op == OP_STR2NUM) then if (.not.isstring(car(scm_args))) then call error1('Argument to string->number is not a string: ', & car(scm_args)) return end if v=car(scm_args) l=get_strlen(v) j=10 bigresult=.false. intresult=.true. str=get_string(v) bigstr=get_string(v) if (cdr(scm_args) /= nil) then j=get_ivalue(cadr(scm_args)) end if if (j == 0) then ioerr=0 bigresult=.true. else if (j == 2) then read(bigstr,'(b200)', iostat=ioerr) iv else if (j == 8) then read(bigstr,'(o200)', iostat=ioerr) iv else if (j == 16) then read(str,'(z200)', iostat=ioerr) iv else if (l > bigbase .and. verify(get_string(v),'0123456789') == 0) then ioerr=0 bigresult=.true. else read(str,'(i40)', iostat=ioerr) iv if (ioerr /= 0) then read(str,'(f40.0)', iostat=ioerr) rv if (ioerr /= 0) then ioerr=0 bigresult=.true. else if (anint(rv) == rv) then if (abs(rv) < real(huge(0_8),kind=8)) then iv=int(rv) else bigresult=.true. end if else intresult=.false. end if end if end if if (ioerr /= 0) then call s_return(f) else if (bigresult) then call s_return(mk_bignumber(get_string(v))) else if (intresult) then call s_return(mk_number(iv)) else call s_return(mk_real(rv)) end if ! number->string else if (op == OP_NUM2STR) then x=car(scm_args) j=0 if (cdr(scm_args) /= nil) then j=get_ivalue(cadr(scm_args)) end if if (isnumber(x)) then if (isbignum(x)) then if (j == 0) then call s_return(mk_string(big2str10(x))) else if (j > 1 .and. j < 17) then call s_return(mk_string(big2str(x, outbase=j))) else call s_return(f) end if else if (isinteger(x)) then iv=get_ivalue(x) if (j == 0 .or. j == 10) then write(bigstr,'(i200)') iv else if (j == 2) then write(bigstr,'(b200)', iostat=ioerr) iv else if (j == 8) then write(bigstr,'(o200)', iostat=ioerr) iv else if (j == 16) then write(bigstr,'(z200)', iostat=ioerr) iv else call error0('Radix not 2,8,10,16!') return end if call s_return(mk_string(trim(adjustl(bigstr)))) else write(str,'(g40.12)') rvalue(x) call s_return(mk_string(trim(adjustl(str)))) end if end if else call s_return(f) end if ! string->symbol else if (op == OP_STR2SYM) then call s_return(mk_symbol(get_string(car(scm_args)))) ! symbol->string else if (op == OP_SYM2STR) then call s_return(mk_string(get_string(caar(scm_args)))) end if end subroutine opexe9 ! ! Simple character to integer conversion cf ival() ! subroutine getint(pos, slen, string, res) integer, intent(inout) :: pos integer, intent(in) :: slen character (len=*), intent(in) :: string integer, intent(out) :: res integer :: j character (len=6) :: fstring j=pos ich=ichar(string(j:j)) do while (j <= slen .and. ich >= 48 .and. ich <= 57) j=j+1 ich=ichar(string(j:j)) end do write(fstring, '(a,i0,a)') '(i', j-pos+1, ')' read(string(pos:(j-1)),fstring) res pos=j end subroutine getint ! ! Nonstandard library additions for system interface such as system, read-line ! Extensions for i/o and accessing system facilities eg inquire, time, date ! subroutine opexe10(op, plevel) use directory_utilities use string_utilities use iocodes use timelib integer :: op integer, intent(in) :: plevel integer, parameter :: MISS = -9999 integer :: commainterval, d, i, idx, imod, ioerr, iport, j, k, l, n, & strm, tmp, typ, res, w, x, y, z integer (kind=8) :: t0 logical :: filexist, ios character (len=1) :: letter character (len=20) :: str character (len=256) :: buff double precision :: val ! file-listing character (len=:), dimension(:), allocatable :: files ! read-char, peek-char logical, save :: peeked = .false. character (len=1), save :: ch = ' ' ! functions ! logical :: strfind #if IFORT || SUN || OPEN64 logical :: isatty #endif ! system command from within scheme str=' ' if (op == OP_SYSTEM) then if (.not.isstring(car(scm_args))) then call error0('Error -- first argument must be a string') else call system(get_string(car(scm_args))) call s_return(t) end if else if (op == OP_IPORT .or. op == OP_OPORT) then if (isstring(car(scm_args))) then buff=get_string(car(scm_args)) end if if (plevel >= 0) then write(outstr, '(3a)') '# Opening "', trim(buff), '"' end if inquire(file=trim(buff), exist=filexist) if (.not.filexist .and. op == OP_IPORT) then call error0('Cannot open "' // trim(buff) //'"!') else if (nports < MAXPORT) then nports=nports+1 iport=portaddress(nports) inquire(iport, opened=ios) if (ios) close(iport, status='keep') open(iport, file=trim(buff), status='unknown', iostat=ioerr) if (ioerr /= 0) then call error0('ERROR: Cannot open "' // trim(buff) // '"!') else call s_return(mk_port(int(iport, kind=8), trim(buff))) end if else call error0('Too many open files!') call s_return(f) end if else if (op == OP_CLPORT) then if (isport(car(scm_args))) then iport=get_ivalue(car(scm_args)) j=test_port(iport) if (j > 0) then close(iport) tmp=portaddress(nports) portaddress(nports)=portaddress(j) portaddress(j)=tmp nports=nports-1 call set_ivalue(car(scm_args), 0_8) call s_return(t) else call error0('Closed port!') end if else call error0('Not a port!') end if else if (op == OP_CURR_INPORT) then call s_return(mk_number(int(infp, kind=8))) else if (op == OP_CURR_OUTPORT) then call s_return(mk_number(int(outstr, kind=8))) else if (op == OP_RDLINE) then if (car(scm_args) == nil) then i=mk_string('') do read(*, '(a)', advance='no', iostat=ioerr) buff if (ioerr == eolcode) then call append_string(i, trim(buff)) call s_return(i) exit else if (ioerr /= 0) then call s_return(f) exit else call append_string(i, buff) end if end do else if (isport(car(scm_args))) then iport=get_ivalue(car(scm_args)) j=test_port(iport) if (j > 0) then i=mk_string('') do read(iport, '(a)', advance='no', iostat=ioerr) buff if (ioerr == eolcode) then call append_string(i, trim(buff)) call s_return(i) exit else if (ioerr /= 0) then call s_return(f) exit else call append_string(i, buff) end if end do else call error0('Closed port!') end if else call error0('Not a port!') end if ! read-char etc else if (op == OP_READCH .or. op == OP_PEEKCH) then if (car(scm_args) == nil) then if (.not.peeked) then read(*, '(a1)', advance='no') ch end if peeked = (op == OP_PEEKCH) call s_return(mk_string(ch)) else if (isport(car(scm_args))) then iport=get_ivalue(car(scm_args)) j=test_port(iport) if (j > 0) then ioerr=0 if (.not.peeked) then read(iport, '(a1)', advance='no', iostat=ioerr) ch end if if (ioerr == 0 .or. ioerr == eolcode) then peeked = (op == OP_PEEKCH) call s_return(mk_string(ch)) else call s_return(f) end if else call error0('Closed port!') end if else call error0('Not a port!') end if ! internal simple format else if (op == OP_FORMAT) then typ=car(scm_args) if (((typ == t .or. typ == f .or. isport(typ)) .and. & isstring(cadr(scm_args))) .or. isstring(typ)) then outfp=outstr if (isport(typ)) outfp=get_ivalue(typ) if (isstring(typ)) then buff=get_string(typ) l=get_strlen(typ) typ=t x = cdr(scm_args) else buff=get_string(cadr(scm_args)) l=get_strlen(cadr(scm_args)) x = cddr(scm_args) end if ! scan the format string and match up to arguments ! may be a fortran format statement if (buff(1:1) == '(' .and. buff(l:l) == ')') then if (isstring(car(x)) .and. fcheck(buff, 1, 'a')) then write(outfp, buff, advance='no') get_string(car(x)) else if (isnumber(car(x))) then if (isinteger(car(x)) .and. fcheck(buff, 1, 'i')) then write(outfp, buff, advance='no') get_ivalue(car(x)) else if (fcheck(buff, 1, 'b')) then write(outfp, buff, advance='no') get_ivalue(car(x)) else if (isfloat(car(x)) .and. (fcheck(buff, 1, 'f') .or. & fcheck(buff, 1, 'g'))) then write(outfp, buff, advance='no') rvalue(car(x)) else call printatom(car(x), 0, -1, 0, ' ') end if else call printatom(car(x), 0, -1, 0, ' ') end if x=cdr(x) if (x /= nil) then call error0('Fortran format takes a single argument!') end if else i=1 commainterval=0 do while (i <= l) ch=buff(i:i) if (ch == '~' .and. i < l) then imod=1 d=-1 n=0 i=i+1 ch=buff(i:i) ich=ichar(ch) ! if a number, this is a modifier count, so read in if (ich >= 48 .and. ich <= 57) then call getint(i, l, buff, n) if (i > l) exit ch=buff(i:i) if (ch == ',' .and. i < l) then i=i+1 call getint(i, l, buff, d) ch=buff(i:i) end if end if ! if ":", this is a modifier, toggling commas in printing of integers if (ch == ':' .and. i 0) then print_flag=0 if (commainterval > 0) commainterval=4 call printatom(car(x), -n, d, commainterval, ch) x=cdr(x) else if (scan(ch, 'dDeEfFgG') > 0) then print_flag=0 call printatom(car(x), -n, d, commainterval, ch) x=cdr(x) else if (scan(ch, '%&') > 0) then do j=1, max(1, n) write(outfp,*) end do else if (scan(ch, 'tT') > 0) then do j=1, max(1, n) write(outfp, '(a)', advance='no') char(9) end do else if (scan(ch, 'cC') > 0) then if (n > 0 .and. n < 256) then write(outfp, '(a)', advance='no') char(n) end if else if (ch == '_') then do j=1, max(1, n) write(outfp, '(a)', advance='no') ' ' end do else if (ch == '~') then do j=1, max(1, n) write(outfp, '(a)', advance='no') '~' end do else write(outfp, '(a)', advance='no') '~' end if else write(outfp, '(a)', advance='no') ch end if i=i+1 end do if (x /= nil) then call error0('Too few ~ in format string "' // trim(buff) // '"') return end if end if else call error0('Expected [] args...!') return end if call s_return(un) ! date, getenv, clocks else if (op == OP_FDATE) then call date_and_time(date=buff, time=str) call s_return(mk_string(trim(buff) // ' ' // trim(str))) else if (op == OP_TIME) then call s_return(mk_number(time_since_epoch())) else if (op == OP_SYSCLOCK) then call system_clock(t0) call s_return(mk_number(t0)) else if (op == OP_GETENV) then if (isstring(car(scm_args))) then call getenv(get_string(car(scm_args)), buff) if (len_trim(buff) > 0) then call s_return(mk_string(trim(buff))) else call s_return(f) end if else call error0('Expected !') end if else if (op == OP_INQUIRE) then inquire(file=get_string(car(scm_args)), exist=ios) call s_retbool(ios) else if (op == OP_DELETE) then call delfile(get_string(car(scm_args)), -1) call s_return(t) else if (op == OP_DIR) then call list_files(get_string(car(scm_args)), files) n=size(files) res=nil if (n > 0) then do i=1, n res=append_one_string(trim(files(i)), res) end do deallocate(files) end if call s_return(res) else if (op == OP_ISATTY) then #if !OPEN64 && !FLANG call s_retbool(isatty(5)) #else call s_return(t) #endif ! list top level environment else if (op == OP_LISTENV) then i=0 x = car(scm_args) if (issymbol(x)) then letter=get_string(car(x)) if (letter == 'a') then i=1 else if (letter == 'c') then i=2 end if end if call list_objects(i) call s_return(un) ! test if bound to environment else if (op == OP_BOUND) then if (isstring(car(scm_args))) then call s_retbool(isbound(trim(get_string(car(scm_args))))) else if (issymbol(car(scm_args))) then call s_retbool(isbound(trim(get_string(caar(scm_args))))) else call error0('Expected !') end if ! Scheme specific help else if (op == OP_APROPOS) then str=' ' if (isstring(car(scm_args))) then str='*' // trim(get_string(car(scm_args))) // '*' end if tmp=oblist do while (tmp /= nil) if (strfind(trim(str), get_string(caar(tmp)), 1)) then write(outstr, '(a)') get_string(caar(tmp)) end if tmp=cdr(tmp) end do call s_return(un) else if (op == OP_HELP) then typ=1 strm=outstr x=car(scm_args) ! closures can be self documented if (isclosure(x)) then i=car(cdr(car(x))) if (isstring(i)) then typ=10 write(outstr, '(a)') get_string(i) else write(outstr, '(a)') & 'Function not self-documented. Try (help "")' typ=100 end if else if (isstring(x) .or. issymbol(x) .or. x == nil) then if (isstring(x)) then str=get_string(x) else str=get_string(car(x)) end if call help_objects('*' // trim(str) // '*') if (strfind('stats', trim(str), 2)) then typ=3 else if (strfind('*grap*', trim(str), 2)) then typ=4 else if (strfind('*egg*', trim(str), 2)) then typ=4 else if (strfind('*jap*', trim(str), 2)) then typ=4 else if (strfind('loci', trim(str), 2)) then typ=5 else if (strfind('phenos', trim(str), 2)) then typ=6 else if (strfind('bit', trim(str), 2)) then typ=7 else typ=2 nports=nports+1 strm=portaddress(nports) open(strm,file='sib-pair.hlp',status='unknown') end if else write(outstr, '(a)') 'Try (help) or (help "")' typ=100 end if if (typ == 1 .or. typ == 2) then write(strm, '(a)') & 'Sib-pair Scheme (' // scheme_version // ') is a minimal scheme interpreter.', & 'It implements bignum integer flonum arithmetic and strings.', & ' (version) prints Sib-pair version.', & ' (apropos ) lists commands containing that string.', & ' (environment-bound? ) test if bound variable.', & ' (dir [''a|''c]) list variables in top environment.', & ' (delete "") delete a variable from top environment.', & ' (help []) displays documentation for commands or topics.', & ' (file-exists? ) test file.', & ' (file-list ) list contents of a directory.', & ' (file-delete ) delete a file.', & ' (open-input-file ) open a port.', & ' (close-input-port ) close a port.', & ' (read-line []) reads in next line from stdin or open file.', & ' (format [] "{~[[,]][@][:][~%&]}" ...) formatted output.', & ' (format "....") where ch in "AIBFGOSTXC".', & ' (string-split []) splits string on white space or optional char.', & ' (substring? ) returns start of substring in string.', & ' (seq [] []) generate sequence.', & ' (hash ''make|''set!|''ref etc) create, access etc a hash table.', & ' (make-list ) generate list of length N.', & ' (list-select ) select sublist using indices.', & ' (which ) generate indices of non-null elements of list.', & ' (sample-seq [''replace]) sample sequence of length N.', & ' (sample [''replace]) sample a list.', & ' (sort ) sort list of numbers.', & ' (rank ) rank of numbers in list.', & ' (order ) order of numbers in list.', & ' (differences ) lag-1 differences in list.', & ' (filter ) filter contents of list.', & ' (duplicated ) index duplicated elements of list.', & ' (unique ) unique elements of list.', & ' (intersect ) common elements of lists.', & ' (setdiff ) elements unique to first list.', & ' (union ) elements of lists.', & ' (system ) passes command to shell.', & ' (getenv ) returns value of environment variable.', & ' (isatty?) tests if interactive session.', & ' (date) returns current date and time.', & ' (current-second) returns current time as seconds since epoch.', & ' (system-clock) returns current time as nanoseconds since epoch.', & ' (peek [""| []]) inspect Scheme memory cells.', & ' (memory-allocate ) allocate n memory cells.' end if if (typ == 1 .or. typ == 2 .or. typ == 5) then write(strm, '(a)') & 'Sib-pair locus dataset accessors (topic "loci"):', & ' (ls []) creates a list of locus names (of given type "adhmqx").', & ' (nloci []) returns number of loci.', & ' (loc ) returns locus at that position in the locus list.', & ' (loc-set! ) set name of locus at that position in the locus list.', & ' (lochash-update!) update hash of locus names.', & ' (locord ) returns position of a locus in the locus list.', & ' (locnotes ) returns notes for a locus.', & ' (locnotes-set! ) rewrites notes for a locus.', & ' (loctyp ) evaluates type of a locus ("adhmqx").', & ' (loctyp-set! ) sets type of a locus ("adhmqx").', & ' (locrank ) returns rank of locus test statistic.', & ' (map-position ) returns map position for locus.', & ' (map-position-set! ) sets map position for a locus.', & ' (chromosome ) returns locus chromosome.', & ' (chromosome-set! ) sets locus chromosome.', & ' (locstat ) returns last P-value for a locus.', & ' (locstat-set! ) writes P-value for a locus.', & ' (locstat-init! [""]) initializes all locus P-values.', & ' (locstat-type! [<typ>]) show/set type of statistic eg "P-value".', & ' (stat-result ["pval|lik|npar|lrt|df|stat|var"]) returns result of last model.' end if if (typ == 1 .or. typ == 2 .or. typ == 6) then write(strm, '(a)') & 'Sib-pair phenotype dataset accessors (topic "phenos"):', & ' (nobs) number of pedigree records.', & ' (npeds) number of pedigrees.', & ' (nactpeds) number of active pedigrees.', & ' (active-status) activity status of pedigrees.', & ' (set-active-status! <idx> <lev>) set activity status of pedigree.', & ' (active-pedigrees [<idx>...]) list of active pedigree names.', & ' (pedigrees [<idx>...]) list of pedigree names.', & ' (pedigree-size [<idx>...]) size of ith pedigree.', & ' (pedigree-members [<idx>...]) list of indices of pedigree members', & ' (individual-pedigree [<idx>...]) give pedigree ID for index', & ' (individual-name [<idx>...]) give ID for index.', & ' (set-individual-name! <idx>|(<ped> <id>) <newid>) set ID for index.', & ' (individual-index [(<id>|<idx>)...]) give index for ID', & ' (insert-record! <idx>|(<ped> <id>) [''after]) insert data row before index.', & ' (father [<idx>...]) father indices.', & ' (set-father! <idx> <new>) set father pointer for individual.', & ' (mother [<idx>...]) mother indices.', & ' (set-mother! <idx> <new>) set mother pointer for individual.', & ' (imztwin [<idx>...]) MZ twin pointer.', & ' (set-imztwin! <idx> <new>) set MZ twin pointer for individual.', & ' (sex [<idx>...]) sex value for individual.', & ' (set-sex! [<idx>...] <sex>) set sex value for individual.', & ' (data <loc> [<idx>...]) phenotype for individual.', & ' (set-data! <idx> <loc> <val>) phenotype for individual.', & ' (data-counts <loc> [...<loc>] [''weight <loc>]) tabulation of phenotype levels.', & ' (allele-freqs <loc>) tabulation of alleles.', & ' (stats <loc>) N, miss, mean, variance, min, max for trait.', & ' (quantile <loc> <p>) quantile(s) for trait.', & ' (run <cmd> ...) runs a Sib-pair command.', & ' (pass-command <cmd> ...) stores Sib-pair commands to the buffer', & ' for evaluation once you return to the usual Sib-pair prompt.' end if if (typ == 1 .or. typ == 2 .or. typ == 3) then write(strm, '(a)') & 'Statistical procedures (topic "stats"):', & ' (stats <y>) N, miss, mean, variance, min, max of list of numbers.', & ' (gllm <y> <X> [''s <S>] [''m <N>] [''c <C>] [''v]) log-linear model.', & ' (lowess <x> <y> [''f <f> [''nsteps <n> [''delta <d>]]]) local regression y on x.', & ' (mode <list> [''v] [''e]) NPMLE mode of list of numbers.', & ' (quantile <y> <p>) quantile(s) of list of numbers.', & ' (pnorm <z>) (qnorm <p>) (pf <f> <df1> <df2>)', & ' (pchisq <x2> <df> [<ncp>]) (qchisq <p> <df>)', & ' (bivnor <p1> <p2> <r>) (pmvnorm <p> <dir> <cor> [''genz])', & ' (pgamma <x> <p>) (lgamma <x>) (dbeta <x> <a> <b>)', & ' (pchisqsum <x> ''(<a1>..<aN>))', & ' (random [<M>]) returns integer from 1..M or float from 0..1', & ' (rnorm [<N>]) returns N draws from standardized normal', & ' (maximize! <fun> <arg_list> [''nstep <n>] [''tol <delta>]) maximize a function' end if if (typ == 1 .or. typ == 2 .or. typ == 7) then write(strm, '(a)') & ' (bitwise-not <i>) logical not for each bit of integer', & ' (bitwise-and <i> <j> [<k>..]) logical and for matching bits', & ' (bitwise-ior <i> <j> [<k>..]) logical or for matching bits', & ' (bitwise-xor <i> <j> [<k>..]) logical xor for matching bits', & ' (arithmetic-shift <i> <count>) left or right bit shift', & ' (bit-set? <index> <i>) test if selected bit is set', & ' (bit-field <i> <start> <end>) return selected bits', & ' (bit-count <i>) popcnt/population count of 1-bits' end if if (typ == 1 .or. typ == 2 .or. typ == 4) then #if JAPI write(strm, '(a)') & 'JAPI AWT GUI procedures (topic "graphics"):', & ' (j_start) (j_quit) (j_frame) (j_show <o>) (j_hide <o>)', & ' (j_list <o> <nr>) (j_label <o> <str>) (j_additem <o> <str>)', & ' (j_textarea <o> <nr> <nc>) (j_menu <o>) (j_gettext <o>)', & ' (j_button <o> <str>) (j_fileselect <o> <dir> <filter> <file>)' #endif #if EGGX write(strm, '(a)') & 'EGGX/proCALL graphical procedures (topic "graphics"):', & ' (ggetdisplayinfo) (gopen) (gclose) (gcloseall) (newcoordinate) (newwindow)', & ' (layer) (copylayer) (gsetbgcolor) (gclr) (tclr) (newpencolor) (newcolor)', & ' (newlinewidth) (newlinestyle) (pset) (drawline) (moveto) (lineto)', & ' (drawrect) (fillrect) (drawcirc) (fillcirc) (drawarc) (fillarc)', & ' (drawsym) (drawstr) (drawnum) (ggetevent) (ggetxpress)' #endif end if if (typ == 2) then rewind(strm) ! global search str='*' // trim(str) // '*' n=0 write(outstr,*) do read(strm,'(a)', iostat=ioerr) buff if (ioerr /= 0) exit if (strfind(str, buff, 2)) then n=n+1 write(outstr,'(a)') trim(buff) end if end do rewind(strm) ! search for exact command if (n > 1) then str=' (' // str(2:len_trim(str)-1) j=len_trim(str) do read(strm,'(a)', iostat=ioerr) buff if (ioerr /= 0) exit i=index(buff, trim(str)) if (i > 0) then if (scan(buff(i+j:i+j), ') ') > 0) then write(outstr,'(/a)') trim(buff) end if end if end do end if nports=nports-1 close(strm,status='delete') end if call s_return(un) else if (op == OP_REGEXP) then if (isstring(car(scm_args)) .and. isstring(cadr(scm_args))) then call s_retbool(strfind(get_string(car(scm_args)), & get_string(cadr(scm_args)),1)) else call error0('Expected <search_string> <string>!') return end if else if (op == OP_VERSION) then call s_return(mk_string(trim(version) // ' Scheme ' // scheme_version)) else if (op == OP_GENSYM) then call s_return(gensym()) else if (op == OP_PEEKMEM) then x = car(scm_args) if (issymbol(x)) x=car(x) if (isstring(x) .or. isinteger(x)) then if (isstring(x)) then if (trim(get_string(x)) == 'oblist') then i=oblist else if (trim(get_string(x)) == 'cont') then i=cont else i=find_objhash(get_string(x),'a') end if else i=get_ivalue(x) end if if (cdr(scm_args) /= nil) then j=get_ivalue(cadr(scm_args)) j=show_memcell(i,j) call s_return(mk_number(int(j,kind=8))) else j=show_memcell(i) call s_return(mk_number(int(j,kind=8))) end if else if (x == nil) then call show_mem(plevel) call s_return(un) else call error0('Expected integer memory cell address.') end if else if (op == OP_DELVAR) then x = car(scm_args) if (isstring(x) .or. issymbol(x)) then if (isstring(x)) then str=get_string(x) else str=get_string(car(x)) end if call delete_var(trim(str), i) call s_return(mk_number(int(i,kind=8))) else call error0('Expected variable name.') end if else if (op == OP_BIGOPS) then buff='big ''big?|''base|(''(pro|de)mote <x> <n>)|''norm <x>|''integer.' x = car(scm_args) if (isstring(x) .or. issymbol(x)) then if (isstring(x)) then str=get_string(x) else str=get_string(car(x)) end if res=nil if (str == 'base') then call s_return(mk_number(rbase)) elseif (str == 'integer') then x = cadr(scm_args) if (isbignum(x)) then call s_return(x) else call s_return(int2big(get_ivalue(x))) end if else if (str == 'big?') then x = cadr(scm_args) call s_retbool(isbignum(x)) else if (str == 'norm') then x = cadr(scm_args) call s_return(bignum_normalize(x)) else if (str == 'promote' .or. str == 'demote') then x = cadr(scm_args) y = caddr(scm_args) if (isnumber(y) .and. isbignum(x)) then if (str == 'promote') then res=bignum_basemult(get_ivalue(y), x) else res=bignum_basediv(get_ivalue(y), x) end if call s_return(res) else call error0('(big ''promote <x> <n>)') return end if else if (str == 'halve!') then x = cadr(scm_args) call bignum_halve(x) call s_return(t) else if (str == 'quotient') then x = cadr(scm_args) y = caddr(scm_args) if (isbignum(x) .and. isbignum(y)) then res=bignum_divide(x, y) call s_return(res) else call error0('(big ''quotient <x> <y>)') return end if else if (str == 'intmult') then x = cadr(scm_args) y = caddr(scm_args) res = int64_multiply(get_ivalue(x), get_ivalue(y)) call s_return(res) else if (str == 'simplest') then x = cadr(scm_args) res=simplest_int(x) call s_return(res) else if (str == 'addition' .or. str == 'subtraction') then x = cadr(scm_args) y = caddr(scm_args) if (isbignum(x) .and. isbignum(y)) then i=-1 if (str == 'addition') i=1 res=bignum_addsub(i, x, y) call s_return(res) else call error0('(big ''addition <x> <y>)') return end if else if (str == 'size') then x = cadr(scm_args) i=object_size(int(get_ivalue(x),kind=4)) call s_return(mk_number(int(i,kind=8))) else if (str == 'digits') then x = cadr(scm_args) y = caddr(scm_args) i = 10 if (y /= nil) i=int(get_ivalue(y),kind=4) if (isbignum(x)) then call s_return(mk_number(int(bignum_digits_base(x, i),kind=8))) else val=floor(log(rvalue(x))/log(real(i,kind=8)))+1 call s_return(mk_number(int(val, kind=8))) end if else call error0(trim(buff)) return end if else call error0(trim(buff)) return end if else if (op == OP_HASHOPS) then buff='hash ''make|''hash?|''get|''ref|''set!|''count|''print|''clear!.' x = car(scm_args) if (isstring(x) .or. issymbol(x)) then if (isstring(x)) then str=get_string(x) else str=get_string(car(x)) end if res=nil if (str == 'hash?') then x = cadr(scm_args) call s_retbool(ishash(x)) return else if (str == 'make') then call s_return(mk_scmhash(1)) return else if (str == 'objhash') then call print_hash(objhash) end if x = cadr(scm_args) if (.not.ishash(x)) then call error0('Not a hash!') return else if (str == 'count') then i=get_ivalue(x) call s_return(mk_number(int(scmhash(i)%nrecords,kind=8))) else if (str == 'get') then y = caddr(scm_args) if (isnumber(y)) then i=get_ivalue(y) call s_return(get_scmhash(x, i)) else call error0('Index must be integer!') return end if else if (str == 'print') then call print_scmhash(x, plevel) call s_return(un) else if (str == 'set!') then i=get_ivalue(x) if (isatom(caddr(scm_args))) then idx=find_scmhash(scmhash(i), caddr(scm_args)) if (idx == 0) then if (caddr(scm_args) == t) then y=mk_string('TRUE') else if (caddr(scm_args) == f) then y=mk_string('FALSE') else y=getcell(x, nil, 'hash-set') call copy_cell(caddr(scm_args), y) end if z=getcell(x, y, 'hash-set') call copy_cell(cadddr(scm_args), z) scmhash(i)%nrecords=scmhash(i)%nrecords+1 if (scmhash(i)%nrecords >= scmhash(i)%ht%nrec) then call rehash_scmhash(x, scmhash(i)%nrecords+10) end if idx=scmhash(i)%nrecords if (isstring(y)) then call insert_hash(scmhash(i)%ht, get_string(y), idx) else if (isfloat(y)) then call insert_hash(scmhash(i)%ht, floathex(rvalue(y)), idx) else if (y == t) then call insert_hash(scmhash(i)%ht, 'TRUE', idx) else if (y == f) then call insert_hash(scmhash(i)%ht, 'FALSE', idx) else call insert_hash_int(scmhash(i)%ht, int(get_ivalue(y)), idx) end if scmhash(i)%m_address(idx,1)=y scmhash(i)%m_address(idx,2)=z call set_car(x, cons(y,car(x))) res=cdr(x) call set_car(res, cons(z, car(res))) else scmhash(i)%ht%hasdups=.true. z=scmhash(i)%m_address(idx,2) call copy_cell(cadddr(scm_args), z) end if call s_return(t) else call error0('Only atomic keys!') return end if else if (str == 'ref') then x = cadr(scm_args) if (ishash(x)) then i=get_ivalue(x) y = caddr(scm_args) idx=find_scmhash(scmhash(i), y) call s_return(scmhash(i)%m_address(idx,2)) else call error0('hash ''ref <hash_table> <key>') return end if else if (str == 'clear!') then i=get_ivalue(x) call cleanup_scmhash(i) else call error0(trim(buff)) return end if else call error0(trim(buff)) return end if else if (op == OP_DEBUG) then scm_debug=1-scm_debug call s_return(un) end if end subroutine opexe10 ! ! Statistical library ! subroutine opexe11(op) use statfuns use mftcontrol use mftfuns use rngs integer :: op integer :: i, ifault, res, tmp, w, x, y, z integer (kind=8) :: v double precision :: rv, rerr integer :: method, n, nn integer, dimension(:), allocatable :: threshdir double precision, dimension(:), allocatable :: thresh, cormat ! gaussian if (op == OP_PNORM) then if (isnumber(car(scm_args))) then rv=zp(rvalue(car(scm_args))) call s_return(mk_real(rv)) else call error0('pnorm needs a numerical argument!') end if else if (op == OP_LOGPNORM) then if (isnumber(car(scm_args))) then rv=rvalue(car(scm_args)) if (rv < 37.0d0) then rv=log10(zp(rvalue(car(scm_args)))) else rv=mizawa_zp(rv) end if call s_return(mk_real(rv)) else call error0('logpnorm needs a numerical argument!') end if else if (op == OP_QNORM) then x = car(scm_args) if (isnumber(x)) then rv=ppnd(1.0d0-rvalue(x)) call s_return(mk_real(rv)) else call error0('qnorm needs a numerical argument!') end if ! chi-square else if (op == OP_PCHISQ) then x = car(scm_args) y = cadr(scm_args) z = caddr(scm_args) if (isnumber(x) .and. isnumber(y)) then if (isnumber(z)) then rv=1.0d0-chi2nc(rvalue(x), rvalue(y), rvalue(z), ifault) else rv=chip(rvalue(x), int(rvalue(y))) end if call s_return(mk_real(rv)) else call error0('pchisq needs at least two numerical arguments!') end if else if (op == OP_QCHISQ) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x) .and. isnumber(y)) then rv=chisqd(rvalue(x), int(rvalue(y))) call s_return(mk_real(rv)) else call error0('qchisq needs two numerical arguments!') end if ! F-distribution else if (op == OP_PFDIST) then x = car(scm_args) y = cadr(scm_args) z = caddr(scm_args) if (isnumber(x) .and. isnumber(y) .and. isnumber(z)) then rv=fp(rvalue(x), int(rvalue(y)), int(rvalue(z))) call s_return(mk_real(rv)) else call error0('pf needs F, df1, df2!') end if ! bivariate gaussian else if (op == OP_BIVNOR) then x = car(scm_args) y = cadr(scm_args) z = caddr(scm_args) if (isnumber(x) .and. isnumber(y) .and. isnumber(z)) then rv=mvbvu(rvalue(x), rvalue(y), rvalue(z)) call s_return(mk_real(rv)) else call error0('bivnor needs z1, z2 and r!') end if ! MVN else if (op == OP_PMVN) then x = car(scm_args) y = cadr(scm_args) z = caddr(scm_args) w = cadddr(scm_args) if (ispair(x) .and. ispair(z)) then method=1 if (issymbol(w)) then if (get_string(car(w)) == 'genz') method=2 end if n=get_listlen(x) nn=get_listlen(z) if (n*(n-1)/2 == nn) then allocate(thresh(n), threshdir(n), cormat(nn)) threshdir=0 call get_rarray(x, n, thresh) if (ispair(y)) then call get_iarray(y, n, threshdir) end if call get_rarray(z, nn, cormat) if (method == 1) then call mecdf(n, thresh, threshdir, cormat, rv, ifault) else call mvndst(n, thresh, thresh, threshdir, cormat, & mfteval*n, abseps, releps, rerr, rv, ifault) end if call s_return(mk_real(rv)) else call error0('pmvnorm expects n thresholds and n*(n-1)/2 correlations!') end if else call error0('pmvnorm needs thresholds, directions, correlation matrix!') end if ! gamma else if (op == OP_GAMMAD) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x) .and. isnumber(y)) then rv=gammad(rvalue(x), rvalue(y), ifault) call s_return(mk_real(rv)) else call error0('pgamma needs two numerical arguments!') end if else if (op == OP_ALNGAM) then x = car(scm_args) if (isnumber(x)) then rv=alngam(rvalue(x), ifault) call s_return(mk_real(rv)) else call error0('lgamma needs a numerical argument!') end if ! normal random numbers else if (op == OP_RNORM) then x = car(scm_args) if (isnumber(x)) then n=get_ivalue(x) res=nil do i=1, n res=append_one_real(dble(randn()), res) end do call s_return(res) else call s_return(mk_real(dble(randn()))) end if ! quadratic form in normal variables else if (op == OP_PCHISUM) then x = car(scm_args) y = cadr(scm_args) if (ispair(y)) then n=get_listlen(y) allocate(thresh(n)) call get_rarray(y, n, thresh) call pchisqsum(rvalue(x), thresh, rv) call s_return(mk_real(rv)) else call error0('pchisqsum needs an array second argument!') end if ! beta density function else if (op == OP_DBETA) then x = car(scm_args) y = cadr(scm_args) z = caddr(scm_args) if (isnumber(x) .and. isnumber(y) .and. isnumber(z)) then rv=dbeta(rvalue(x), rvalue(y), rvalue(z)) call s_return(mk_real(rv)) else call error0('dbeta needs x, a and b!') end if end if end subroutine opexe11 #if !(FREESTANDING_SCHEME) ! ! Procedures that interact with Sib-pair ! subroutine opexe12(op, plevel) use statresults use locus_data use locus_types use pedigree_data use string_utilities use automatic_data integer :: op integer, intent(in) :: plevel integer, parameter :: MISS = -9999 integer :: d, i, imod, ioerr, j, l, n, strm, tmp, typ, res, v, x logical :: filexist, ios character (len=1) :: ch character (len=20) :: str character (len=256) :: buff double precision :: val ! functions ! logical :: strfind ! run a Sib-pair command if (op == OP_RUNCMD) then l=0 x=scm_args do while (x /= nil) if (isnumber(car(x))) then write(str, '(i20)') get_ivalue(car(x)) str=adjustl(str) l=l+len_trim(str)+1 else l=l+get_strlen(car(x))+1 end if x=cdr(x) end do v=mk_string(repeat(' ',l)) i=0 l=0 x=scm_args do while (x /= nil) if (isnumber(car(x))) then write(str, '(i20)') get_ivalue(car(x)) str=adjustl(str) l=l+len_trim(str) call set_substring(v, i+1, l, trim(str)) else l=l+get_strlen(car(x)) call set_substring(v, i+1, l, get_string(car(x))) end if l=l+1 i=l call set_substring(v, i, i, ';') x=cdr(x) end do commands=get_string(v) // trim(commands) if (ilevel /= 0) ilevold=ilevel ilevel=0 call s_return(un) ! Scheme specific locus list else if (op == OP_LSLOCI .or. op == OP_NLOCI) then typ=0 if (isnumber(car(scm_args))) then typ = get_ivalue(car(scm_args)) else if (isstring(car(scm_args)) .or. issymbol(car(scm_args))) then if (isstring(car(scm_args))) then x=car(scm_args) else x=caar(scm_args) end if ch=get_substr(x, 0, 1) if (ch == 'A') then typ=-1 else typ=loccode(ch) if (.not.isactive(typ) .and. len_trim(get_string(x)) == 2) then i=loccode(get_substr(x, 1, 2)) if (i > 0 .and. i < LOC_DEL) typ=typ+i end if end if end if if (op == OP_NLOCI) then n=0 if (typ == 0) then call s_return(mk_number(int(nloci-ENVNUM, kind=8))) else if (typ == -1 .or. typ == LOC_DEL) then do i=ENVNUM+1, nloci if (isactive(loctyp(i))) then n=n+1 end if end do if (typ == -1) then call s_return(mk_number(int(n, kind=8))) else call s_return(mk_number(int(nloci-ENVNUM-n, kind=8))) end if else do i=ENVNUM+1, nloci if (same_loctyp(loctyp(i), typ)) then n=n+1 end if end do call s_return(mk_number(int(n, kind=8))) end if else res=nil if (typ == 0) then do i=nloci, ENVNUM+1, -1 res=append_one_string(trim(loc(i)), res) end do else if (typ == -1) then do i=nloci, ENVNUM+1, -1 if (isactive(loctyp(i))) then res=append_one_string(trim(loc(i)), res) end if end do else if (typ == LOC_DEL) then do i=nloci, ENVNUM+1, -1 if (.not.isactive(loctyp(i))) then res=append_one_string(trim(loc(i)), res) end if end do else do i=nloci, ENVNUM+1, -1 if (same_loctyp(loctyp(i), typ)) then res=append_one_string(trim(loc(i)), res) end if end do end if call s_return(res) end if ! Return or set information about locus else if (op >= OP_LOCNAM .and. op <= OP_SETCHROM) then n=0 res=nil x=scm_args if (x == nil) then n=nloci if (op == OP_LOCNAM) then do i=1, nloci res=append_one_string(trim(loc(i)), res) end do else if (op == OP_LOCTYP) then do i=ENVNUM+1, nloci j=mod(loctyp(i), LOC_CMP) if (j < LOC_DEL) then str=typloc(j) else str='d' str(2:2)=typloc(j-LOC_DEL) end if res=append_one_string(trim(str), res) end do else if (op == OP_LOCSTAT) then do i=ENVNUM+1, nloci if (locstat(i) /= MISS) then res=append_one_real(locstat(i), res) else res=cons(f, res) end if end do else if (op == OP_MAPPOS) then do i=ENVNUM+1, nloci res=append_one_real(map(i), res) end do else if (op == OP_CHROM) then do i=ENVNUM+1, nloci res=append_one_string(trim(group(i)), res) end do end if else do while (x /= nil) n=n+1 i=0 if (isnumber(car(x))) then i = get_ivalue(car(x)) + ENVNUM else if (isstring(car(x))) then str=trim(get_string(car(x))) call find_hashtab(trim(str), loc, lochash, i) end if if (i > 0 .and. i <= nloci) then if (op == OP_LOCNAM) then res=append_one_string(trim(loc(i)), res) else if (op == OP_SETLOC) then if (isstring(cadr(scm_args))) then loc(i)=trim(get_string(cadr(scm_args))) lochash%current=.false. call s_return(t) else call error0('Expected a locus name!') end if return else if (op == OP_LOCTYP) then i=mod(loctyp(i), LOC_CMP) if (i < LOC_DEL) then str=typloc(i) else str='d' str(2:2)=typloc(i-LOC_DEL) end if res=append_one_string(trim(str), res) else if (op == OP_SETTYP) then typ=mod(loctyp(i), LOC_CMP+LOC_DEL) if (isstring(cadr(scm_args))) then ch=get_string(cadr(scm_args)) j=loccode(ch) if (j /= 0) then if ((istrait(typ) .and. istrait(j)) .or. & (ismarker(typ) .and. ismarker(j))) then loctyp(i)=loctyp(i)-typ+j call s_return(mk_string(typloc(j))) else if (j == 12) then loctyp(i)=j call s_return(mk_string(typloc(j))) else call s_return(f) end if else call error0('Expected locus type: character in [mqcaxyih]!') end if else call error0('Expected locus type: character in [mqcaxyih]!') end if return else if (op == OP_LOCORD) then res=append_one_number(i, res) else if (op == OP_LOCSTAT) then if (locstat(i) /= MISS) then res=append_one_real(locstat(i), res) else res=cons(f, res) end if else if (op == OP_SETSTAT) then x=cadr(scm_args) if (isnumber(x)) then locstat(i)=rvalue(x) call s_return(t) else if (x == nil .or. isstring(x)) then locstat(i)=MISS call s_return(t) else call error0('Expected a number!') end if return else if (op == OP_LOCNOTE) then res=append_one_string(trim(locnotes(i)), res) else if (op == OP_SETNOTE) then if (isstring(cadr(scm_args))) then locnotes(i)=trim(get_string(cadr(scm_args))) call s_return(t) else call error0('Expected a string annotation !') end if return else if (op == OP_LOCRANK) then v=0 j=1 do while (wloc(j) > 0) if (wloc(j)==i) then v=j exit end if j=j+1 end do if (v /= 0) then res=append_one_number(v, res) else res=cons(f, res) end if else if (op == OP_MAPPOS) then res=append_one_real(map(i), res) else if (op == OP_SETMAP) then if (isnumber(cadr(scm_args))) then map(i)=rvalue(cadr(scm_args)) call s_return(t) else call error0('Expected a number!') end if return else if (op == OP_CHROM) then res=append_one_string(trim(group(i)), res) else if (op == OP_SETCHROM) then if (isstring(cadr(scm_args))) then group(i)=trim(get_string(cadr(scm_args))) call s_return(t) else call error0('Expected a string!') end if return end if end if x=cdr(x) end do end if if (n == 1) then call s_return(res) else call s_return(reverse(res)) end if ! ! access results from Sib-pair statistical procedures else if (op == OP_STATRES) then if (scm_args == nil) then call s_return(mk_real(pval)) else if (isstring(car(scm_args)) .or. issymbol(car(scm_args))) then if (issymbol(car(scm_args))) then str=trim(get_string(caar(scm_args))) else str=trim(get_string(car(scm_args))) end if if (str == 'lik') then call s_return(mk_real(mlik(whlik))) else if (str == 'npar') then call s_return(mk_number(int(mpar(whlik), kind=8))) else if (str == 'pval') then call s_return(mk_real(pval)) else if (str == 'stat') then call s_return(mk_real(statval(1))) else if (str == 'var') then call s_return(mk_real(statval(2))) else if (str == 'lrt' .or. str == 'df') then val=mlik(whlik)-mlik(3-whlik) n=mpar(3-whlik)-mpar(whlik) if (n < 0) then n=-n val=-val end if if (str == 'lrt') then call s_return(mk_real(val)) else call s_return(mk_number(int(n, kind=8))) end if else call s_return(f) end if else if (isnumber(car(scm_args))) then i = get_ivalue(car(scm_args)) if (i > 0 .and. i < 4) then call s_return(mk_real(statval(i))) else call s_return(f) end if else call s_return(f) end if ! initialize locstat else if (op == OP_INITSTAT) then x=scm_args typ=0 if (scm_args == nil) then call setup_stat(' ') else if (isstring(car(scm_args))) then if (cadr(scm_args) /= nil) then if (isnumber(cadr(scm_args))) then typ = get_ivalue(cadr(scm_args)) end if end if call setup_stat(trim(get_string(car(scm_args))), typ=typ) else call setup_stat(' ') end if call s_return(t) else if (op == OP_TYPSTAT) then if (scm_args == nil) then call s_return(mk_string(trim(locstat_type_string(locstat_typ)))) else str=trim(get_string(car(scm_args))) if (str == '0' .or. str(1:1) == 'p' .or. str(1:1) == 'P') then locstat_typ=0 else if (str == '1' .or. str(1:3) == 'con') then locstat_typ=1 else if (str == '2' .or. str(1:3) == 'cat') then locstat_typ=2 end if call s_return(mk_string(trim(locstat_type_string(locstat_typ)))) end if ! change which position locpos points to else if (op == OP_LOCPOS .or. op == OP_SETPOS) then i=0 if (isnumber(car(scm_args))) then i = get_ivalue(car(scm_args)) else if (isstring(car(scm_args))) then str=trim(get_string(car(scm_args))) call find_hashtab(trim(str), loc, lochash, i) end if if (i > 0 .and. i <= nloci) then if (op == OP_LOCPOS) then call s_return(mk_number(int(locpos(i), kind=8))) else if (isnumber(cadr(scm_args))) then j=rvalue(cadr(scm_args)) locpos(i)=j call s_return(mk_number(int(j, kind=8))) else call error0('Expected a number!') end if else call error0('Expected a locus index 1..nloci!') end if else if (op == OP_HASHLOCI) then if (.not.lochash%current) then call make_lochash(nloci, loc, lochash) call s_return(t) else call s_return(f) end if end if end subroutine opexe12 ! ! Manipulate Sib-pair dataset ! subroutine opexe13(op, plevel) use locus_data use locus_types use pedigree_data use read_data use scanner use contingency_table use keyval use alleles_class use automatic_data integer :: op integer, intent(in) :: plevel integer, parameter :: DROPX=0, MISS = -9999 integer :: i, idx, j, n, nobs, tmp, tmp2, x, y, res integer :: g1, g2, gcode, isobs, lpos, ped ! data-counts can use sample weights integer :: sampleweight logical :: before, elig character (len=1) :: ch character (len=3) :: sall character (len=40) :: buff, vbuff character (len=:), allocatable :: cbuff double precision :: val ! contingency table type (table_data) :: table ! Categorical trait levels ! integer, dimension(1) :: catidx ! type (cat_data) :: categories ! marker alleles type (allele_data) :: allele_buffer double precision, dimension(:), allocatable :: freqs ! functions integer :: aval interface subroutine freq(gene, loctyp, fndr, dataset, allele_buffer) use ped_class use alleles_class integer, intent(in) :: gene integer, intent(in) :: loctyp integer, intent(in) :: fndr type (ped_data), intent(in) :: dataset type (allele_data), intent(inout) :: allele_buffer end subroutine freq end interface n=0 res=nil x=scm_args if (op == OP_GETDATA .or. op == OP_GETSEX) then nobs=work%nobs ! allocate enough memory call gc(nil, nil, plevel) if (nobs > fcells) then call setup_mem(nobs+memsiz) end if j=0 if (op == OP_GETDATA) then y=car(x) x=cdr(x) if (isnumber(y)) then j = get_ivalue(y) + ENVNUM else if (isstring(y)) then buff=get_string(y) call find_hashtab(trim(buff(1:20)), loc, lochash, j) end if if (j < 1 .or. j > nloci) then call error0('Expected locus name or index!') return else if (iscattrait(loctyp(j))) then cbuff=get_notes(loc(j), locnotes(j)) end if end if if (x == nil) then if (op == OP_GETSEX) then do ped=1, work%nped if (work%actset(ped) > 0) then do i=work%num(ped-1)+1, work%num(ped) n=n+1 call wrsex(work%sex(i),ch) res=append_one_string(ch, res) end do end if end do else lpos=locpos(j) if (iscattrait(loctyp(j))) then call extract_kv(cbuff, table, i) end if do ped=1, work%nped if (work%actset(ped) > 0) then do i=work%num(ped-1)+1, work%num(ped) n=n+1 if (ismarker(loctyp(j))) then call get_geno(i, lpos, lpos+1, work, g1, g2) call wrgtp(g1, g2, buff, '/', '', 3) res=append_one_string(trim(adjustl(buff)), res) else if (isspecial(loctyp(j))) then call autovar(i, lpos, nloci, loctyp, locpos, work, val) res=append_one_number(int(val), res) else val=work%plocus(i,lpos) if (val == MISS) then res=cons(f, res) else if (iscattrait(loctyp(j))) then res=append_one_string(search_kv(table, int(val)), res) else if (isqtrait(loctyp(j))) then res=append_one_real(val, res) else if (isafftrait(loctyp(j))) val=val-1.0d0 res=append_one_number(int(val), res) end if end if end do end if end do end if else lpos=locpos(j) do while (x /= nil) n=n+1 y=car(x) x=cdr(x) if (isnumber(y) .or. isstring(y)) then i=0 if (isnumber(y)) then i = get_ivalue(y) else if (.not.hashtab%current) then call hashids(HK_ID, work, hashtab, 80, plevel-1) end if call matchid(HK_ID, ' ', get_string(y), work, hashtab, i, plevel-1) end if if (i > 0 .and. i <= work%nobs) then if (plevel > 0) then write(*,*) '## ', n, i, work%id(i), j, loc(j) end if val=work%plocus(i,lpos) if (val == MISS) then res=cons(f, res) else if (op == OP_GETSEX) then call wrsex(work%sex(i),ch) res=append_one_string(ch, res, protect=x) else if (ismarker(loctyp(j))) then call get_geno(i, lpos, lpos+1, work, g1, g2) call wrgtp(g1, g2, buff, '/', '', 3) res=append_one_string(trim(adjustl(buff)), res, protect=x) else if (iscattrait(loctyp(j))) then call getpairval(int2str(int(val)), cbuff, opsimple, buff) res=append_one_string(trim(adjustl(buff)), res, protect=x) else if (isqtrait(loctyp(j))) then res=append_one_real(val, res, protect=x) else if (isspecial(loctyp(j))) then call autovar(i, lpos, nloci, loctyp, locpos, work, val) res=append_one_real(val, res, protect=x) else res=append_one_number(int(val,kind=4), res, protect=x) end if else res=cons(f, res) end if end if end do end if if (n == 1) then call s_return(car(res)) else call s_return(non_alloc_rev(nil, res)) end if else if (op == OP_GETCOUNTS .or. op == OP_GETALLELES) then sampleweight=0 nord=0 x=scm_args do while (x /= nil) i=0 y=car(x) if (isnumber(y)) then j = get_ivalue(y) else if (issymbol(y)) then buff=get_string(car(y)) if (trim(buff) == 'weight') then sampleweight=-1 end if else if (isstring(y)) then buff=get_string(y) call find_hashtab(trim(buff), loc, lochash, i) end if if (i > 0 .and. i <= nloci) then if (sampleweight == -1) then sampleweight=i else nord=nord+1 locord(nord)=i end if end if x=cdr(x) end do if (nord > 0) then res=nil idx=locord(nord) elig=ismarker(loctyp(idx)) if (elig) then call freq(locpos(idx), loctyp(idx), 0, work, allele_buffer) if (allele_buffer%issnp) then call get_snpallele2(locnotes(idx), allele_buffer) end if end if if (op == OP_GETALLELES) then if (.not.elig) then call error0('Expected a marker locus!') return else ! sequence of allele frequencies if (nord == 1) then x=nil do i=allele_buffer%numal, 1, -1 x=append_one_real(allele_buffer%allele_freqs(i), x) end do x=cons(x, nil) dump=cons(x, dump) ! matrix of allele frequencies else call strat_freq(nord, locord, nloci, loc, locpos, loctyp, & allele_buffer, work, n, table) allocate(freqs(table%ncells)) idx=0 do i=table%ncells, 1, -allele_buffer%numal n=0 do j=1, allele_buffer%numal n=n+table%icount(i-j+1) end do do j=1, allele_buffer%numal val=dble(table%icount(i-j+1))/dble(n) idx=idx+1 freqs(idx)=val end do end do x=make_real_matrix(table%ncells, freqs, allele_buffer%numal) x=cons(x, nil) dump=cons(x, dump) ! and stratum labels x=nil do i=table%ncells,1,-allele_buffer%numal tmp=table_label(i, nord-1, table, protect=x) x=cons(tmp, x) end do ! x=cons(x, nil) tmp=car(dump) x=cons(x, tmp) dump=cdr(dump) dump=cons(x, dump) end if ! allele labels x=nil do i=allele_buffer%numal, 1, -1 call wrall(allele_buffer%allele_names(i), sall) x=append_one_string(trim(adjustl(sall)), x) end do ! x=cons(x, nil) tmp=car(dump) res=cons(x, tmp) dump=cdr(dump) end if else call maketab(DROPX, sampleweight, nord, locord, nloci, loc, & locpos, loctyp, work, n, table) x=nil do i=table%ncells,1,-1 x=append_one_number(table%icount(table%idx(i)), x) end do x=cons(x, nil) dump=cons(x, dump) ! cell labels x=nil do i=table%ncells,1,-1 tmp=table_label(i, nord, table, protect=x) x=cons(tmp, x) end do tmp=car(dump) res=cons(x, tmp) dump=cdr(dump) end if call s_return(res) else call error0('No eligible loci!') end if else if (op == OP_NOBS) then call s_return(mk_number(int(work%nobs, kind=8))) else if (op == OP_NPEDS) then call s_return(mk_number(int(work%nped, kind=8))) else if (op == OP_NACTPEDS) then call s_return(mk_number(int(work%nact, kind=8))) else if (op == OP_ACTIVE) then do i=1, work%nped res=append_one_number(work%actset(i), res) end do call s_return(non_alloc_rev(nil, res)) else if (op == OP_SETACTIVE) then i=0 if (isnumber(car(x))) then i=get_ivalue(car(x)) else if (isstring(car(x))) then buff=get_string(car(x)) do j=1, work%nped if (buff == work%pedigree(j)) then i=j exit end if end do end if if (i > 0 .and. isnumber(cadr(x))) then j=get_ivalue(cadr(x)) work%actset(i)=j if (j < 1) then work%nact=work%nact-1 else if (j > 0) then work%nact=work%nact+1 work%maxact=max(work%maxact, work%num(i)-work%num(i-1)) end if call s_return(t) else call error0('Expected pedigree index and activity level!') end if else if (op == OP_PEDLIST .or. op == OP_ACTPEDS) then if (x == nil) then if (op == OP_PEDLIST) then do i=1, work%nped res=append_one_string(trim(work%pedigree(i)), res) end do else do i=1, work%nped if (work%actset(i) > 0) then res=append_one_string(trim(work%pedigree(i)), res) end if end do end if else do while (x /= nil) if (isnumber(car(x))) then i=get_ivalue(car(x)) if (i > 0 .and. i <= work%nped) then if (op == OP_PEDLIST .or. & (op == OP_ACTPEDS .and. work%actset(i) > 0)) then res=append_one_string(trim(work%pedigree(i)), res, protect=x) else res=cons(f, res) end if else res=cons(f, res) end if else if (isstring(car(x))) then res=cons(car(x), res) end if x=cdr(x) end do end if call s_return(non_alloc_rev(nil, res)) else if (op == OP_PEDSET) then y=car(x) if (isnumber(y)) then i=get_ivalue(y) else if (isstring(y)) then buff=get_string(y) do j=1, work%nped if (buff == work%pedigree(j)) then i=j exit end if end do end if if (i > 0 .and. i <= work%nped) then y=cadr(x) if (isstring(y)) then work%pedigree(i)=get_string(y) call s_return(t) else call error0('Expected replacement pedigree ID string!') end if else call error0('Expected pedigree ID or index!') end if else if (op == OP_PEDSIZE) then if (x == nil) then do i=1, work%nped res=append_one_number(work%num(i)-work%num(i-1), res) end do else do while (x /= nil) i=0 if (isnumber(car(x))) then i=get_ivalue(car(x)) else if (isstring(car(x))) then buff=get_string(x) do j=1, work%nped if (buff == work%pedigree(j)) then i=j exit end if end do end if if (i > 0 .and. i <= work%nped) then res=append_one_number(work%num(i)-work%num(i-1), res, protect=x) else res=cons(f, res) end if x=cdr(x) end do end if call s_return(non_alloc_rev(nil, res)) else if (op == OP_PEDMEMBERS) then if (x == nil) then call alldata(res, extract_ped) else do while (x /= nil) i=0 if (isnumber(car(x))) then i=get_ivalue(car(x)) else if (isstring(car(x))) then buff=get_string(x) do j=1, work%nped if (buff == work%pedigree(j)) then i=j exit end if end do end if if (i > 0 .and. i <= work%nped) then do j=work%num(i-1)+1, work%num(i) res=append_one_number(j, res) end do end if x=cdr(x) end do end if call s_return(non_alloc_rev(nil, res)) else if (op == OP_IDLIST .or. op == OP_IDIDX) then if (x == nil) then if (op == OP_IDLIST) then call alldata(res, extract_id) else call alldata(res, extract_ped) end if else do while (x /= nil) i=0 y=car(x) if (isnumber(y)) then i=get_ivalue(y) else if (isstring(y)) then if (.not.hashtab%current) then call hashids(HK_ID, work, hashtab, 80, plevel-1) end if call matchid(HK_ID, ' ', get_string(y), work, hashtab, i, plevel-1) ! write(*,*) 'Looking for ', get_string(y), i end if if (i > 0 .and. i <= work%nobs) then if (op == OP_IDLIST) then res=append_one_string(trim(work%id(i)), res) else if (work%actset(work%iped(i)) > 0) then res=append_one_number(i, res) else res=cons(f, res) end if end if else res=cons(f, res) end if x=cdr(x) end do end if call s_return(non_alloc_rev(nil, res)) else if (op == OP_IDSET .or. op == OP_SETSEX .or. & op == OP_SETFA .or. op == OP_SETMO .or. op == OP_SETTWIN .or. & op == OP_SETDATA .or. op == OP_INSRECORD .or. & op == OP_SETCHOSEN) then y=car(x) if (isnumber(y)) then i=get_ivalue(y) else if (issymbol(y)) then buff=get_string(car(y)) if (buff == 'append' .or. buff == 'last') then i=work%nobs else call error0('Expected insertion position! Only allowed symbol here is ''append') return end if else if (isstring(y)) then if (.not.hashtab%current) then call hashids(HK_ID, work, hashtab, 80, plevel-1) end if call matchid(HK_ID, ' ', get_string(y), work, hashtab, i, plevel-1) else if (ispair(y)) then if (isstring(car(y)) .and. isstring(cadr(y))) then if (.not.hashtab%current .or. (hashtab%keytyp /= HK_PED_ID)) then call hashids(HK_PED_ID, work, hashtab, 80, plevel-1) end if call matchid(HK_PED_ID, get_string(car(y)), get_string(cadr(y)), & work, hashtab, i, plevel-1) else call error0('Expected pedigree and individual ID strings!') return end if end if if (i > 0 .and. i <= work%nobs) then y=cadr(x) if (op == OP_INSRECORD) then if (isstring(y) .or. issymbol(y) .or. y == nil) then buff=' ' if (isstring(y)) then buff=get_string(y) else if (issymbol(y)) then buff=get_string(car(y)) end if before=(buff /= 'after') call insert_new_record(i, work, stat=j, before=before) call cleanup_hash(hashtab) call hashids(HK_ID, work, hashtab, 80, 0) if (j > 0) then call s_return(mk_number(int(j, kind=8))) else call error0('Could not insert new record!') end if else call error0('Expected position then "before"|"after"!') end if else if (op == OP_IDSET) then if (isstring(y)) then work%id(i)=get_string(y) hashtab%current=.false. call s_return(t) else call error0('Expected replacement ID string!') end if else if (op == OP_SETSEX) then if (isstring(y)) then ch=get_string(y) if (ch == 'm' .or. ch == '1') then work%sex(i)=1 call s_return(t) else if (ch == 'f' .or. ch == '2') then work%sex(i)=2 call s_return(t) else if (ch == 'x') then work%sex(i)=MISS call s_return(f) else call error0('Expected [mfx]!') end if else call error0('Expected replacement sex string!') end if else if (op == OP_SETFA) then if (isnumber(y)) then j=get_ivalue(y) if (j < 0 .or. j >= i) then call error0('Expected in-range index for new father!') else if (j == 0) then work%fa(i)=MISS call s_return(t) else work%fa(i)=j call s_return(t) end if else call error0('Expected index for new father!') end if else if (op == OP_SETMO) then if (isnumber(y)) then j=get_ivalue(y) if (j < 0 .or. j >= i) then call error0('Expected in-range index for new mother!') else if (j == 0) then work%mo(i)=MISS call s_return(t) else work%mo(i)=j call s_return(t) end if else call error0('Expected index for new father!') end if else if (op == OP_SETTWIN) then if (isnumber(y)) then j=get_ivalue(y) if (j < 0 .or. j > work%nobs) then call error0('Expected in-range index for twin!') else if (j == 0) then work%imztwin(i)=MISS call s_return(t) else work%imztwin(i)=j call s_return(t) end if else call error0('Expected index for new twin!') end if else if (op == OP_SETCHOSEN) then if (isnumber(y)) then j=get_ivalue(y) work%untyped(i)=(j /= 1) else work%untyped(i)=.false. end if else if (isnumber(y)) then j=get_ivalue(y) + ENVNUM else if (isstring(y)) then buff=get_string(y) call find_hashtab(trim(buff(1:20)), loc, lochash, j) end if if (j < 1 .or. j > nloci) then call error0('Expected locus name or index!') else y=caddr(x) if (same_loctyp(loctyp(j), LOC_QUA) .or. & same_loctyp(loctyp(j), LOC_CAT)) then if (iscattrait(loctyp(j))) then cbuff=get_notes(loc(j), locnotes(j)) end if if (isnumber(y)) then work%plocus(i,locpos(j))=rvalue(y) call s_return(t) else if (isstring(y)) then if (get_string(y) == 'x') then work%plocus(i,locpos(j))=MISS call s_return(f) else call getpairval(get_string(y), cbuff, opsimple, & vbuff, forward=.false.) read(vbuff, *) val work%plocus(i,locpos(j))=val call s_return(t) end if else call error0('Expected a number!') end if return else if (loctyp(j) == LOC_AFF) then if (isstring(y)) then buff=get_string(y) if (buff == 'y') then work%plocus(i,locpos(j))=2.0d0 call s_return(t) else if (buff == 'n') then work%plocus(i,locpos(j))=1.0d0 call s_return(t) else if (buff == 'x') then work%plocus(i,locpos(j))=MISS call s_return(t) else call error0('Expected [ynx]!') end if else call error0('Expected [ynx]!') end if return else if (ismarker(loctyp(j))) then if (isstring(y)) then isobs=1 buff=get_string(y) tmp=index(buff, '/') if (tmp == 0) then isobs=-1 tmp=index(buff, ':') end if if (tmp > 0) then gcode=gencode(loctyp(j)) g1=isobs*aval(buff(1:(tmp-1)), gcode) g2=isobs*aval(buff(tmp+1:len_trim(buff)), gcode) call set_geno(i, locpos(j), locpos(j)+1, work, g1, g2) call s_return(t) else call error0('Expected a genotype!') end if else call error0('Expected a genotype!') end if return else if (isspecial(loctyp(j))) then call error0('Cannot set computed variables!') return end if end if end if else call error0('Expected individual ID or index!') end if else if (op == OP_FATHER .or. op == OP_MOTHER .or. & op == OP_IMZTWIN .or. op == OP_PEDIDX) then if (x == nil) then if (op == OP_FATHER) then call alldata(res, extract_fa) else if (op == OP_MOTHER) then call alldata(res, extract_mo) else if (op == OP_IMZTWIN) then call alldata(res, extract_imztwin) else call alldata(res, extract_iped) end if else do while (x /= nil) if (isnumber(car(x))) then i=get_ivalue(car(x)) if (i > 0 .and. i <= work%nobs) then idx=0 if (op == OP_FATHER) then idx=work%fa(i) else if (op == OP_MOTHER) then idx=work%mo(i) else if (op == OP_IMZTWIN) then idx=work%imztwin(i) else idx=work%iped(i) end if if (idx < 0) idx=0 res=append_one_number(idx, res) else res=cons(res, f) end if end if x=cdr(x) end do end if call s_return(non_alloc_rev(nil, res)) end if end subroutine opexe13 ! function table_label(i, ncol, table, protect) use locus_data use locus_types use contingency_table integer :: table_label integer, intent(in) :: i, ncol type (table_data) :: table integer, intent(in), optional :: protect integer :: idx, j, pcell, tmp, tpos character (len=40) :: buff character (len=20000) :: get_notes0 pcell=nil if (present(protect)) pcell=protect idx=table%idx(i) tmp=getcell(pcell, nil, 'table_label') call set_type(tmp, ior(T_STRING, T_ATOM)) do j=1, ncol tpos=locord(j) call wrtrait(table%categories(idx,j)%rvalue, buff, & loctyp(tpos), get_notes0(loc(tpos), locnotes(tpos)), 9, 4) buff=adjustl(buff) if (j > 1) buff=' ' // buff call append_string(tmp, trim(buff)) end do table_label=tmp end function table_label ! ! pedigree data accessor ! subroutine alldata(res, extractor) use locus_data use locus_types use pedigree_data integer, intent(inout) :: res integer :: extractor integer :: i, ped reg1=res call gc(nil, nil, gc_verbosity) if (work%nobs > fcells) then call setup_mem(work%nobs+memsiz) end if do ped=1, work%nped if (work%actset(ped) > 0) then do i=work%num(ped-1)+1, work%num(ped) reg1=extractor(i, reg1) end do end if end do res=reg1 end subroutine alldata ! ! extractors for different pedigree data fields ! extract ith pedigree number ! function extract_ped(i, res) use pedigree_data integer :: extract_ped integer, intent(in) :: i integer, intent(in) :: res integer :: j j=work%iped(i) extract_ped=cons(mk_string(work%pedigree(j)),res) end function extract_ped ! ! extract ith id string ! function extract_id(i, res) use pedigree_data integer :: extract_id integer, intent(in) :: i integer, intent(in) :: res extract_id=cons(mk_string(trim(work%id(i))), res) end function extract_id ! ! extract ith pedigree number ! function extract_iped(i, res) use pedigree_data integer :: extract_iped integer, intent(in) :: i integer, intent(in) :: res extract_iped=cons(mk_number(int(max(0,work%iped(i)), kind=8)), res) end function extract_iped ! ! extract ith father number ! function extract_fa(i, res) use pedigree_data integer :: extract_fa integer, intent(in) :: i integer, intent(in) :: res extract_fa=cons(mk_number(int(max(0,work%fa(i)), kind=8)), res) end function extract_fa ! ! extract ith mother number ! function extract_mo(i, res) use pedigree_data integer :: extract_mo integer, intent(in) :: i integer, intent(in) :: res extract_mo=cons(mk_number(int(max(0,work%mo(i)), kind=8)), res) end function extract_mo ! ! extract ith cotwin number ! function extract_imztwin(i, res) use pedigree_data integer :: extract_imztwin integer, intent(in) :: i integer, intent(in) :: res extract_imztwin=cons(mk_number(int(max(0,work%imztwin(i)), kind=8)), res) end function extract_imztwin #endif ! ! Scheme and xlispstat list procedures ! subroutine opexe14(op, plevel) use rngs use smooths use AS207 use sorts #if !(FREESTANDING_SCHEME) use statresults use locus_data use locus_types use pedigree_data integer, parameter :: MISS=-9999 #endif integer :: op integer, intent(in) :: plevel integer :: i, j, l, n, nf, nsteps, m, res, tmp, verbosity, w, x, y, z integer, dimension(:), allocatable :: idx, rnk double precision, dimension(:), allocatable :: expvals, fulvals, rvals, yvals integer, dimension(2) :: matshape logical :: get_ecdf, incomplete, replace integer (kind=8) :: v character(len=8) :: cbuff character(len=40) :: buff double precision :: delta, frac, maxv, mean, minv, dev, rv, ss, val ! list-tail if (op == OP_LISTTAIL .or. op == OP_LISTREF) then x=car(scm_args) y=cadr(scm_args) if (ispair(x) .and. isnumber(y)) then n=get_ivalue(y) res=get_listtail(x, n) if (res == nil) then call error0('List too short!') else if (op == OP_LISTREF) res=car(res) call s_return(res) end if else call error0('list-ref/tail: expected list and numerical index!') end if ! list-select <list> <indices> else if (op == OP_LISTSEL) then if (ispair(car(scm_args))) then y=cadr(scm_args) if (ispair(y)) then m=get_listlen(y) allocate(idx(m)) l=1 m=0 do while (ispair(y)) if (isnumber(car(y))) then m=m+1 idx(m)=get_ivalue(car(y)) end if l=l+1 y=cdr(y) end do call gc(nil, nil, gc_verbosity) if (m > fcells) then call setup_mem(m+memsiz) end if res=nil do i=1, m x=get_listtail(car(scm_args), idx(i)) if (x == nil .or. idx(i) < 0) then call error0('Index out of range!') return else res = cons(car(x), res) end if end do call s_return(reverse(res)) else if (isnumber(y)) then n=get_ivalue(y) x=get_listtail(car(scm_args), n) if (x == nil .or. n < 0) then call error0('list-select: index out of range!') else call s_return(car(x)) end if else if (y == nil) then call s_return(nil) else call error0('list-select: expected list and one or more indices!') end if end if else if (car(scm_args) == nil .and. cadr(scm_args) == nil) then call s_return(nil) else call error0('list-select: expected list and one or more indices!') end if else if (op == OP_MKLIST) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x)) then n=get_ivalue(x) if (n <= 0) then res=y else res=nil do i=1, n res=cons(y, res) end do end if call s_return(res) else call error0('make-list: need a number of repeats for element!') end if else if (op == OP_PROPER) then call s_retbool(isproper(car(scm_args))) else if (op == OP_CIRC) then call s_retbool(iscirc(car(scm_args))) else if (op == OP_SAMPLE) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x) .and. isnumber(y)) then replace=.false. n=get_ivalue(x) m=get_ivalue(y) z = caddr(scm_args) if (z /= nil .and. z /= f) replace=.true. allocate(idx(n)) if (replace) then do i=1, m idx(i)=irandom(1,n) end do else do i=1, n idx(i)=i end do do i=1, m j=irandom(1,n) k=idx(i) idx(i)=idx(j) idx(j)=k end do end if res=nil do i=1, m res=append_one_number(idx(i)-1, res) end do call s_return(res) else call error0('Expected two numbers (sample-seq <m> <n> [''replace]) !') end if else if (op == OP_WHICH) then x = car(scm_args) if (ispair(x)) then n=get_listlen(x) allocate(idx(n)) m=0 i=0 do while (ispair(x)) if (car(x) /= nil .and. car(x) /= f) then m=m+1 idx(m)=i end if i=i+1 x=cdr(x) end do res=nil do i=m, 1, -1 res=append_one_number(idx(i), res) end do call s_return(res) else if (x == nil) then call s_return(nil) else call error0('Expected a list!') end if ! ! seq [<sta>] <end> [<step>] else if (op == OP_GENSEQ) then x = car(scm_args) y = cadr(scm_args) z = caddr(scm_args) if (isnumber(x)) then x=get_ivalue(x) if (isnumber(y)) then y=get_ivalue(y) else y=x x=1 end if res=nil if (z == nil) then z=1 else z=get_ivalue(z) end if j=mod(y-x, z) do i=y-j, x, -z res=append_one_number(i, res) end do call s_return(res) else call error0('seq needs 1-3 numerical arguments!') end if ! ! order: a sequence of the indices of elements in the sequence of numbers ! else if (op >= OP_ORDER .and. op <= OP_RANK) then x=scm_args res=nil if (ispair(car(x))) x=car(x) n=get_listlen(x) m=n allocate(rvals(n)) call get_rarray(x, n, rvals, missing=-9999.0d0) if (op == OP_ORDER .or. op == OP_RANK) then allocate(idx(n)) do i=1, n idx(i)=i end do call srank(m, rvals, idx) if (op == OP_RANK) then allocate(rnk(n)) rnk=0 do i=1, m rnk(idx(i))=i end do call append_iarray(rnk, res) else call append_iarray(idx, res) end if else call dsort(n, rvals) call append_rarray(rvals, res) end if call s_return(res) ! quantiles else if (op == OP_QUANTILES) then x = car(scm_args) y = cadr(scm_args) #if !(FREESTANDING_SCHEME) if (isstring(x)) then buff=get_string(x) call find_hashtab(trim(buff), loc, lochash, j) if (j < 1 .or. j > nloci) then call error0('Expected locus name!') return else allocate(rvals(work%nobs)) n=0 j=locpos(j) do l=1, work%nped if (work%actset(l) > 0) then do i=work%num(l-1)+1, work%num(l) val=work%plocus(i,j) if (val /= MISS) then n=n+1 rvals(n)=val end if end do end if end do end if else if (ispair(x)) then #else if (ispair(x)) then #endif n=get_listlen(x) allocate(rvals(n)) call get_rarray(x, n, rvals, drop_missing=.true.) else call error0('Expected a list of numbers!') return end if if (.not.(isnumber(y) .or. ispair(y))) then call error0('Expected a single quantile or list of quantiles!') return end if call dsort(n, rvals) if (isnumber(y)) then call get_quantile(rvalue(y), n, rvals, val, ifault) if (ifault == 0) then call s_return(mk_real(val)) else call error0('Requested quantile outside of 0..1!') end if else res=nil do while (ispair(y)) if (isnumber(car(y))) then call get_quantile(rvalue(car(y)), n, rvals, val, ifault) if (ifault == 0) then res=append_one_real(val, res) else call error0('Requested quantile outside of 0..1!') end if else call error0('Expected a quantile!') end if y=cdr(y) end do call s_return(reverse(res)) end if ! else if (op == OP_DIFFS) then x=scm_args res=nil ifault=-1 if (ispair(car(x))) x=car(x) do while (x /= nil .and. ifault == -1) if (isnumber(car(x))) then val=rvalue(car(x)) ifault=0 end if x=cdr(x) end do if (ifault == 0) then do while (x /= nil) if (isnumber(car(x))) then dev=rvalue(car(x))-val val=rvalue(car(x)) res=append_one_real(dev, res) end if x=cdr(x) end do end if call s_return(reverse(res)) ! ! univariate summary statistics else if (op == OP_SUMSTATS) then n=0 m=0 mean=0.0d0 minv=1.0d99 maxv=-1.0d99 ss=0.0d0 res=nil x=scm_args if (ispair(car(x))) x=car(x) #if !(FREESTANDING_SCHEME) if (isstring(car(x))) then buff=get_string(car(x)) call find_hashtab(trim(buff), loc, lochash, j) if (j < 1 .or. j > nloci) then call error0('stats: expected locus name!') return else j=locpos(j) do l=1, work%nped if (work%actset(l) > 0) then do i=work%num(l-1)+1, work%num(l) val=work%plocus(i,j) if (val /= MISS) then n=n+1 call moment(n, val, mean, ss) if (val < minv) minv=val if (val > maxv) maxv=val else m=m+1 end if end do end if end do end if else do while (x /= nil) call accum_stats(car(x), n, m, mean, ss, minv, maxv) x=cdr(x) end do end if #else do while (x /= nil) call accum_stats(car(x), n, m, mean, ss, minv, maxv) x=cdr(x) end do #endif res=append_one_number(n, res) res=append_one_number(m, res) if (n > 0) then res=append_one_real(mean, res) res=append_one_real(ss/dble(max(n,1)), res) res=append_one_real(minv, res) res=append_one_real(maxv, res) else do i=1, 4 res=cons(f, res) end do end if call s_return(reverse(res)) else if (op == OP_LOWESS) then res=nil x = car(scm_args) y = cadr(scm_args) z = cddr(scm_args) frac=0.67d0 nsteps=2 delta = 0.0d0 do while (z /= nil) w=car(z) if (issymbol(w)) then cbuff=get_string(car(w)) if (cbuff(1:5) == 'nstep') then nsteps=get_ivalue(cadr(z)) else if (cbuff(1:5) == 'delta') then delta=rvalue(cadr(z)) else if (cbuff(1:1) == 'f') then frac=rvalue(cadr(z)) end if end if z=cdr(z) end do if (ispair(x) .and. ispair(y)) then n=get_listlen(x) if (n == get_listlen(y)) then allocate(rvals(n), yvals(n)) call get_rarray(x, n, rvals) call get_rarray(y, n, yvals) call dolowess(n, rvals, yvals, frac, nsteps, delta) call append_rarray(yvals, res) call s_return(res) else call error0('lowess: x and y must be same length!') end if else call error0('lowess: x and y must be lists of numbers!') end if else if (op == OP_GLLM) then incomplete=.false. res=nil x = car(scm_args) y = cadr(scm_args) z = cddr(scm_args) if (ispair(x) .and. ispair(y)) then nf=0 n=get_listlen(x) m=get_listlen(y) allocate(rvals(m), yvals(n)) call get_rarray(x, n, yvals) call get_rarray(y, m, rvals) nsteps=500 verbosity=0 delta = 0.00001d0 do while (z /= nil) w=car(z) if (issymbol(w)) then cbuff=get_string(car(w)) if (cbuff(1:1) == 'm') then nsteps=get_ivalue(cadr(z)) else if (cbuff(1:1) == 'v') then verbosity=verbosity+1 else if (cbuff(1:1) == 'c') then delta=rvalue(cadr(z)) else if (cbuff(1:1) == 's') then if (ispair(cadr(z))) then nf=get_listlen(cadr(z)) allocate(idx(nf)) call get_iarray(cadr(z), nf, idx) incomplete=.true. else call error0('gllm: scatter must be a list of numbers!') end if end if end if z=cdr(z) end do if (nf == 0) then nf=n allocate(idx(nf)) do i=1, nf idx(i)=i end do end if matshape(1)=nf matshape(2)=m/nf allocate(expvals(n), fulvals(nf)) call fit_gllm(idx, yvals, reshape(rvals, matshape), & fulvals, expvals, nsteps, delta, val, verbosity, i) if (i == 0) then reg1=nil if (incomplete) then tmp=nil call append_rarray(fulvals, tmp) reg1=cons(tmp,reg1) end if tmp=nil call append_rarray(expvals, tmp) reg1=cons(tmp,reg1) res=append_one_real(val, reg1) call s_return(reverse(res)) else call error0('gllm: all elements of design matrix equal!') end if else call error0('(gllm <y> <M> [''s <S>] [''v] [''m <N>] [''c <D>])') end if else if (op == OP_MODE) then x = car(scm_args) z = cdr(scm_args) get_ecdf=.false. i = 0 do while (z /= nil) w=car(z) if (issymbol(w)) then cbuff=get_string(car(w)) if (cbuff(1:1) == 'v') then i=2 else if (cbuff(1:1) == 'e') then get_ecdf=.true. end if end if z=cdr(z) end do if (ispair(x)) then n=get_listlen(x) allocate(rvals(n)) call get_rarray(x, n, rvals) if (get_ecdf) then res=nil allocate(yvals(n)) call unidens(n, rvals, rv, i, ecdf=yvals) call append_rarray(yvals, res) call s_return(res) else call unidens(n, rvals, rv, i) call s_return(mk_real(rv)) end if else call error0('mode: x must be a list of numbers! (mode <x> [''verbose] [''ecdf])') end if else if (op == OP_CEILING) then x = car(scm_args) v = ceiling(rvalue(x), kind=8) call s_return(mk_number(v)) else if (op == OP_FLOOR) then x = car(scm_args) v = floor(rvalue(x), kind=8) call s_return(mk_number(v)) else if (op == OP_LOG10) then x = car(scm_args) if (isbignum(x)) then rv=bignum_log10(x) else rv = log10(rvalue(x)) end if call s_return(mk_real(rv)) else if (op == OP_MAXIMIZE) then res=nil x = car(scm_args) y = cadr(scm_args) z = cddr(scm_args) nsteps=5000 delta=1.0d-6 do while (z /= nil) w=car(z) if (issymbol(w)) then cbuff=get_string(car(w)) if (cbuff(1:5) == 'nstep') then nsteps=get_ivalue(cadr(z)) else if (cbuff(1:1) == 'tol') then delta=rvalue(cadr(z)) end if end if z=cdr(z) end do if (isstring(x)) then buff=get_string(x) else if (issymbol(x)) then buff=get_string(car(x)) end if w=find_objhash(trim(buff), 'e') if (isproc(w) .or. isclosure(w)) then if (ispair(y)) then n=get_listlen(y) allocate(rvals(n)) call get_rarray(y, n, rvals) call domaximize(trim(buff), n, rvals, delta, nsteps, val, plevel) call s_return(mk_real(val)) else call error0('maximize!: y must be list of parameters!') end if else call error0('maximize!: x must be a function taking one argument!') end if end if end subroutine opexe14 ! ! univariate summary stats - accumulate one observation ! n=obs m=missing mean=mean ss=sum-of-squares minv=min maxv=max ! subroutine accum_stats(x, n, m, mean, ss, minv, maxv) #if SUN use, intrinsic :: ieee_arithmetic use, intrinsic :: ieee_exceptions #endif integer, intent(in) :: x integer, intent(inout) :: n double precision, intent(inout) :: mean, ss, minv, maxv double precision :: val if (isnumber(x)) then val=rvalue(x) #if SUN if (ieee_is_nan(val)) then #else if (isnan(val)) then #endif m=m+1 else n=n+1 dev=val-mean mean=mean+dev/dble(n) ss=ss+dev*dev*dble(n-1)/dble(n) if (val < minv) minv=val if (val > maxv) maxv=val end if else m=m+1 end if end subroutine accum_stats ! ! ith quantile ! subroutine get_quantile(q, n, rvals, val, ifault) double precision, intent(in) :: q integer, intent(in) :: n double precision, dimension(n) :: rvals double precision, intent(out) :: val integer, intent(out) :: ifault double precision :: q1 val=0.0d0 ifault=-1 if (q > 1.0d0 .or. q < 0.0d0) return ifault=0 if (q == 1.0d0) then val=rvals(n) else q1=q*dble(n) if (q1 < 1.0d0) then val=rvals(1) else val=0.5d0*(rvals(floor(q1+1))+rvals(ceiling(q1))) end if end if end subroutine get_quantile ! ! Call varmet maximizer ! subroutine domaximize(fname, npar, parest, toler, maxfn, lik, plevel) use varmet_optimizer character(len=*), intent(in) :: fname integer, intent(in) :: npar double precision, dimension(:) :: parest double precision, intent(in) :: toler integer :: maxfn double precision, intent(out) :: lik integer, intent(in) :: plevel double precision, parameter :: gradtl = 1.0D-12 integer :: ier, ios ier=0 lik=0.0d0 if (plevel > 0) then write(outstr,'(3a,i0)') ';; Maximizing "', fname, '" npar=', npar end if call varmet(fname, scmfun, npar, parest, lik, gradtl, toler, maxfn, ier, plevel) if (ier /= 0) call vmerr(ier, maxfn) lik=scmfun(fname, npar, parest) end subroutine domaximize ! ! car-cdr compositions ! subroutine opexe17(op) integer :: op integer :: x integer :: np, pattern x=car(scm_args) np=1 pattern=op - OP_CAAR if (op >= OP_CAAAR .and. op <= OP_CDDDR) then np=2 pattern=op - OP_CAAAR else if (op >= OP_CAAAAR .and. op <= OP_CDDDDR) then np=3 pattern=op - OP_CAAAAR end if do i= 0, np if (.not.ispair(x)) then call error0('Expected pair!') return else if (btest(pattern,i)) then x=cdr(x) else x=car(x) end if end if end do call s_return(x) end subroutine opexe17 ! ! set procedures ! subroutine opexe18(op) integer :: op integer :: i, n1, n2, res, tmp, x, y, z integer(kind=8) :: iv integer, dimension(:), allocatable :: idx1, idx2, idx12 n1=0 n2=0 if (ispair(car(scm_args))) then n1=get_listlen(car(scm_args)) if (ispair(cadr(scm_args))) then n2=get_listlen(cadr(scm_args)) end if end if if (op == OP_DUPS .or. op == OP_UNIQUE) then allocate(idx1(n1)) idx1=0 x=cdar(scm_args) do i=2, n1 y=car(scm_args) do j=1, i-1 if (eqv(car(x),car(y))) then idx1(i)=j exit end if y=cdr(y) end do x=cdr(x) end do res=nil if (op == OP_DUPS) then do i=n1, 1, -1 if (idx1(i) > 0) then tmp=getcell(res, nil, 'dup') call set_type(tmp, ior(T_NUMBER, T_ATOM)) call set_ivalue(tmp, int(idx1(i)-1, kind=8)) res=cons(tmp, res) else res=cons(f, res) end if end do else do i=n1, 1, -1 if (idx1(i) == 0) then res=cons(t, res) else res=cons(f, res) end if end do end if call s_return(res) else if (op == OP_INTERSECT .or. op == OP_SETDIFF) then allocate(idx1(n1)) allocate(idx2(n2)) idx1=0 idx2=0 x=car(scm_args) do i=1, n1 y=cadr(scm_args) do j=1, n2 if (eqv(car(x),car(y))) then if (idx2(j) == 0) then idx1(i)=j idx2(j)=i end if exit end if y=cdr(y) end do x=cdr(x) end do res=nil x=f y=t if (op == OP_SETDIFF) then x=t y=f end if do i=n1, 1, -1 if (idx1(i) == 0) then res=cons(x, res) else res=cons(y, res) end if end do call s_return(res) else if (op == OP_BITXOR) then x=car(scm_args) y=cdr(scm_args) iv=get_ivalue(x) do while (y /= nil) iv=ieor(iv,get_ivalue(car(y))) y=cdr(y) end do call s_return(mk_number(iv)) else if (op == OP_BITIOR) then x=car(scm_args) y=cdr(scm_args) iv=get_ivalue(x) do while (y /= nil) iv=ior(iv,get_ivalue(car(y))) y=cdr(y) end do call s_return(mk_number(iv)) else if (op == OP_BITAND) then x=car(scm_args) y=cdr(scm_args) iv=get_ivalue(x) do while (y /= nil) iv=iand(iv,get_ivalue(car(y))) y=cdr(y) end do call s_return(mk_number(iv)) else if (op == OP_BITNOT) then x=car(scm_args) iv=get_ivalue(x) call s_return(mk_number(not(iv))) else if (op == OP_BITSHIFT) then x=car(scm_args) y=cadr(scm_args) call s_return(mk_number(ishft(get_ivalue(x),get_ivalue(y)))) else if (op == OP_BITSETP) then x=car(scm_args) y=cadr(scm_args) call s_retbool(btest(get_ivalue(y), get_ivalue(x))) else if (op == OP_BITFIELD) then x=car(scm_args) y=cadr(scm_args) z=caddr(scm_args) i=get_ivalue(x) j=get_ivalue(y) n1=get_ivalue(z)-j call s_return(mk_number(int(ibits(i, j, n1),kind=8))) else if (op == OP_POPCNT) then x=car(scm_args) if (isbignum(x)) then call s_return(mk_number(bignum_popcnt(x))) else call s_return(mk_number(int(popcnt(get_ivalue(x)),kind=8))) end if end if end subroutine opexe18 ! ! GUI library (japi) ! #if JAPI subroutine opexe15(op) use japi integer :: op integer :: i, j, k, l, typ, v, w, x, y, z logical :: lstat character(len=256) :: buff1, buff2 i=0 if (op == OP_JSTART) then if (j_start()) then call s_return(t) else call s_return(f) end if else if (op == OP_JQUIT) then call j_quit() call s_return(t) else if (op == OP_JFRAME) then x = car(scm_args) if (isstring(x)) then i=j_frame(get_string(x)) else i=j_frame(' ') end if call s_return(mk_number(int(i, kind=8))) else if (op == OP_JPANEL) then x = car(scm_args) if (isnumber(x)) then i=j_panel(int(get_ivalue(x),kind=4)) else call error0('j_panel needs a frame handle!') end if call s_return(mk_number(int(i, kind=8))) else if (op == OP_JBORDERPANEL) then x = car(scm_args) y = car(scm_args) typ=0 if (isnumber(x)) then if (isnumber(y)) then typ=get_ivalue(y) else if (isstring(y)) then if (get_string(y) == 'linedown') then typ=j_linedown else if (get_string(y) == 'lineup') then typ=j_lineup else if (get_string(y) == 'areadown') then typ=j_areadown else if (get_string(y) == 'areaup') then typ=j_areaup end if end if i=j_borderpanel(int(get_ivalue(x), kind=4), int(typ, kind=4)) else call error0('j_borderpanel needs a frame handle and optional style!') return end if call s_return(mk_number(int(i, kind=8))) else if (op == OP_JDIALOG) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x)) then if (isstring(y)) then i=j_dialog(int(get_ivalue(x),kind=4), get_string(y)) else i=j_dialog(int(get_ivalue(x),kind=4), ' ') end if call s_return(mk_number(int(i, kind=8))) else call error0('j_dialog needs a frame handle!') end if else if (op == OP_JBUTTON) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x)) then if (isstring(y)) then i=j_button(int(get_ivalue(x),kind=4), get_string(y)) else i=j_button(int(get_ivalue(x),kind=4), ' ') end if call s_return(mk_number(int(i, kind=8))) else call error0('j_button needs a frame handle!') end if else if (op == OP_JRADIOBUTTON) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x)) then if (isstring(y)) then i=j_radiobutton(int(get_ivalue(x),kind=4), get_string(y)) else i=j_radiobutton(int(get_ivalue(x),kind=4), ' ') end if call s_return(mk_number(int(i, kind=8))) else call error0('j_radiobutton needs a handle!') end if else if (op == OP_JRADIOGROUP) then x = car(scm_args) if (isnumber(x)) then i=j_radiogroup(int(get_ivalue(x),kind=4)) call s_return(mk_number(int(i, kind=8))) else call error0('j_radiogroup needs a frame handle!') end if else if (op == OP_JCHECKBOX) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x)) then if (isstring(y)) then i=j_checkbox(int(get_ivalue(x),kind=4), get_string(y)) else i=j_checkbox(int(get_ivalue(x),kind=4), ' ') end if call s_return(mk_number(int(i, kind=8))) else call error0('j_checkbox needs a frame handle!') end if else if (op == OP_JLIST) then x = car(scm_args) y = car(scm_args) if (isnumber(x) .and. isnumber(y)) then i=j_list(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4)) call s_return(mk_number(int(i, kind=8))) else call error0('j_list needs an object handle and number of rows!') end if else if (op == OP_JADD) then x = car(scm_args) y = car(scm_args) if (isnumber(x) .and. isnumber(y)) then call j_add(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4)) call s_return(t) else call error0('j_list needs an object handle and number of rows!') end if else if (op == OP_JSETCOLOR .or. op == OP_JSETCOLORBG) then x = car(scm_args) w = car(scm_args) y = car(scm_args) z = car(scm_args) if (isnumber(x) .and. isnumber(w) .and. & isnumber(y) .and. isnumber(z)) then if (op == OP_JSETCOLOR) then call j_setcolor(int(get_ivalue(x),kind=4), & int(get_ivalue(w),kind=4), & int(get_ivalue(y),kind=4), & int(get_ivalue(z),kind=4)) else call j_setcolorbg(int(get_ivalue(x),kind=4), & int(get_ivalue(w),kind=4), & int(get_ivalue(y),kind=4), & int(get_ivalue(z),kind=4)) end if call s_return(un) else call error0('j_setcolor needs handle, R, G, B!') end if else if (op == OP_JSETNAMEDCOLORBG) then x = car(scm_args) y = car(scm_args) if (isnumber(x) .and. isnumber(y)) then call j_setnamedcolorbg(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4)) call s_return(un) else call error0('j_setnamedcolorbg needs an object handle and color (0-7)!') end if else if (op == OP_JGETSELECT) then x = car(scm_args) if (isnumber(x)) then i=j_getselect(int(get_ivalue(x),kind=4)) call s_return(mk_number(int(i, kind=8))) else call error0('j_getselect needs a list or choice handle!') end if else if (op == OP_JSELECT .or. op == OP_JDESELECT) then x = car(scm_args) y = car(scm_args) if (isnumber(x) .and. isnumber(y)) then if (op == OP_JSELECT) then call j_select(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4)) else call j_deselect(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4)) end if call s_return(un) else call error0('j_deselect needs a list handle and item!') end if else if (op == OP_JFILESELECT .or. op == OP_JFILEDIALOG) then x = car(scm_args) w = cadr(scm_args) y = caddr(scm_args) z = cadddr(scm_args) if (isnumber(x) .and. isstring(w) .and. & isstring(y) .and. isstring(z)) then buff1=get_string(y) buff2=get_string(z) if (op == OP_JFILESELECT) then call j_fileselect(int(get_ivalue(x),kind=4), get_string(y), & buff1, buff2) else call j_filedialog(int(get_ivalue(x),kind=4), get_string(y), & buff1, buff2) end if x=nil x=cons(mk_string(trim(buff1)), x) x=cons(mk_string(trim(buff2)), x) call s_return(reverse(x)) else call error0('j_fileselect needs handle, title, filter, filename!') end if else if (op == OP_JENABLE) then x = car(scm_args) if (isnumber(x)) then call j_enable(int(get_ivalue(x),kind=4)) call s_return(un) else call error0('j_enable needs an object handle!') end if else if (op == OP_JDISABLE) then x = car(scm_args) if (isnumber(x)) then call j_disable(int(get_ivalue(x),kind=4)) call s_return(un) else call error0('j_disable needs an object handle!') end if else if (op == OP_JADDITEM) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x) .and. isstring(y)) then call j_additem(int(get_ivalue(x),kind=4), get_string(y)) call s_return(un) else call error0('j_additem needs an object handle and string to be added!') end if else if (op == OP_JSEPARATOR) then x = car(scm_args) if (isnumber(x)) then call j_seperator(int(get_ivalue(x),kind=4)) call s_return(un) else call error0('j_seperator needs an object handle!') end if else if (op == OP_JTEXTFIELD) then x = car(scm_args) y = car(scm_args) if (isnumber(x) .and. isnumber(y)) then i=j_textfield(int(get_ivalue(x),kind=4), int(get_ivalue(y),kind=4)) call s_return(mk_number(int(i, kind=8))) else call error0('j_textfield needs an object handle and width!') end if else if (op == OP_JTEXTAREA) then x = car(scm_args) y = car(scm_args) z = car(scm_args) if (isnumber(x) .and. isnumber(y) .and. isnumber(z)) then i=j_textarea(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4), & int(get_ivalue(z),kind=4)) call s_return(mk_number(int(i, kind=8))) else call error0('j_textarea needs an object handle, nrows, ncols !') end if else if (op == OP_JSETBORDERPOS) then x = car(scm_args) y = cadr(scm_args) typ=1 if (isnumber(x)) then if (isnumber(y)) then typ=get_ivalue(y) else if (isstring(y)) then typ=aligntype(get_string(y)) end if call j_setborderpos(int(get_ivalue(x),kind=4), & int(typ, kind=4)) call s_return(un) else call error0('j_setborderpos needs text/grid handle and direction!') end if else if (op == OP_JSETROWS .or. op == OP_JSETCOLUMNS) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x) .and. isnumber(y)) then if (op == OP_JSETROWS) then call j_setrows(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4)) else call j_setcolumns(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4)) end if call s_return(un) else call error0('j_setrows/columns needs text/grid handle and NR/NC!') end if else if (op == OP_JGETROWS .or. op == OP_JGETCOLUMNS) then x = car(scm_args) if (isnumber(x)) then if (op == OP_JGETROWS) then i=j_getrows(int(get_ivalue(x),kind=4)) else i=j_getcolumns(int(get_ivalue(x),kind=4)) end if call s_return(mk_number(int(i, kind=8))) else call error0('j_getrows/columns needs a text handle!') end if else if (op == OP_JGETLENGTH) then x = car(scm_args) if (isnumber(x)) then i=j_getlength(int(get_ivalue(x),kind=4)) call s_return(mk_number(int(i, kind=8))) else call error0('j_getlength needs a text handle!') end if else if (op == OP_JGETSELSTART .or. op == OP_JGETSELEND) then x = car(scm_args) if (isnumber(x)) then if (op == OP_JGETSELSTART) then i=j_getselstart(int(get_ivalue(x),kind=4)) else i=j_getselend(int(get_ivalue(x),kind=4)) end if call s_return(mk_number(int(i, kind=8))) else call error0('j_getselstart/end needs a text handle!') end if else if (op == OP_JSELECTTEXT) then x = car(scm_args) y = cadr(scm_args) z = caddr(scm_args) if (isnumber(x) .and. isnumber(y) .and. isnumber(z)) then call j_selecttext(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4), & int(get_ivalue(z),kind=4)) call s_return(un) else call error0('j_settext needs textarea handle, text, pos!') end if else if (op == OP_JGETTEXT .or. op == OP_JGETSELTEXT) then x = car(scm_args) if (isnumber(x)) then if (op == OP_JGETTEXT) then call j_gettext(int(get_ivalue(x),kind=4), buff1) else call j_getseltext(int(get_ivalue(x),kind=4), buff1) end if call s_return(mk_string(trim(buff1))) else call error0('j_gettext needs text handle!') end if else if (op == OP_JGETITEM) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x) .and. isnumber(y)) then call j_getitem(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4), buff1) call s_return(mk_string(trim(buff1))) else call error0('j_getitem needs handle, item!') end if else if (op == OP_JLABEL) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x)) then if (isstring(y)) then i=j_button(int(get_ivalue(x),kind=4), get_string(y)) else i=j_button(int(get_ivalue(x),kind=4), ' ') end if call s_return(mk_number(int(i, kind=8))) else call error0('j_label needs an object handle!') end if else if (op == OP_JGETCURPOS) then x = car(scm_args) if (isnumber(x)) then i=j_getcurpos(int(get_ivalue(x),kind=4)) else call error0('j_getitem needs an object handle!') end if call s_return(mk_number(int(i, kind=8))) else if (op == OP_JSETCURPOS) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x) .and. isnumber(y)) then call j_setcurpos(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4)) call s_return(un) else call error0('j_setcurpos needs handle and pos!') end if else if (op == OP_JSETFONT) then x = car(scm_args) w = cadr(scm_args) y = caddr(scm_args) z = cadddr(scm_args) typ=0 if (isnumber(x) .and. (isnumber(w) .or. isstring(w)) .and. & (isnumber(y) .or. isstring(y)) .and. isnumber(z)) then if (isnumber(w)) then typ=get_ivalue(w) else typ=fonttype(get_string(w)) end if if (isnumber(y)) then k=get_ivalue(y) else k=fonttype(get_string(y)) end if call j_setfont(int(get_ivalue(x), kind=4), & int(typ, kind=4), & int(k, kind=4), & int(get_ivalue(z), kind=4)) call s_return(un) else call error0('j_setfont needs handle, name, style, size!') end if else if (op == OP_JSETTEXT) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x) .and. isstring(y)) then call j_settext(int(get_ivalue(x),kind=4), get_string(y)) call s_return(un) else call error0('j_settext needs handle and string!') end if else if (op == OP_JINSERTTEXT) then x = car(scm_args) y = cadr(scm_args) z = caddr(scm_args) if (isnumber(x) .and. isstring(y) .and. isnumber(z)) then call j_inserttext(int(get_ivalue(x),kind=4), & get_string(y), & int(get_ivalue(z),kind=4)) call s_return(un) else call error0('j_settext needs textarea handle, text, pos!') end if else if (op == OP_JREPLACETEXT) then x = car(scm_args) w = cadr(scm_args) y = caddr(scm_args) z = cadddr(scm_args) if (isnumber(x) .and. isstring(w) .and. & isnumber(y) .and. isnumber(z)) then call j_replacetext(int(get_ivalue(x),kind=4), & get_string(w), & int(get_ivalue(y),kind=4), & int(get_ivalue(z),kind=4)) call s_return(un) else call error0('j_replacetext needs textarea handle, text, start, end!') end if else if (op == OP_JDELETE) then x = car(scm_args) y = cadr(scm_args) z = caddr(scm_args) if (isnumber(x) .and. isnumber(y) .and. isnumber(z)) then call j_delete(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4), & int(get_ivalue(z),kind=4)) call s_return(un) else call error0('j_delete needs textarea handle, start, end!') end if else if (op == OP_JDISPOSE) then x = car(scm_args) if (isnumber(x)) then call j_dispose(int(get_ivalue(x),kind=4)) call s_return(t) else call error0('j_dispose needs a handle!') end if else if (op == OP_JMENUBAR) then x = car(scm_args) if (isnumber(x)) then i=j_menubar(int(get_ivalue(x),kind=4)) call s_return(mk_number(int(i, kind=8))) else call error0('j_menubar needs a frame handle!') end if else if (op == OP_JMENU) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x)) then if (isstring(y)) then i=j_menu(int(get_ivalue(x),kind=4), get_string(y)) else i=j_menu(int(get_ivalue(x),kind=4), ' ') end if call s_return(mk_number(int(i, kind=8))) else call error0('j_menu needs an object handle!') end if else if (op == OP_JMENUITEM) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x)) then if (isstring(y)) then i=j_menuitem(int(get_ivalue(x),kind=4), get_string(y)) else i=j_menuitem(int(get_ivalue(x),kind=4), ' ') end if call s_return(mk_number(int(i, kind=8))) else call error0('j_menuitem needs a menubar handle!') end if else if (op == OP_JPACK) then x = car(scm_args) if (isnumber(x)) then call j_pack(get_ivalue(x)) call s_return(un) else call error0('j_pack needs an object handle!') end if else if (op == OP_JSHOW) then x = car(scm_args) if (isnumber(x)) then call j_show(int(get_ivalue(x),kind=4)) call s_return(un) else call error0('j_show needs an object handle!') end if else if (op == OP_JHIDE) then x = car(scm_args) if (isnumber(x)) then call j_hide(int(get_ivalue(x),kind=4)) call s_return(un) else call error0('j_hide needs an object handle!') end if else if (op == OP_JKEYLISTENER) then x = car(scm_args) if (isnumber(x)) then i=j_keylistener(int(get_ivalue(x),kind=4)) call s_return(mk_number(int(i, kind=8))) else call error0('j_hide needs an object handle!') end if else if (op == OP_JGETKEYCODE) then x = car(scm_args) if (isnumber(x)) then i=j_getkeycode(int(get_ivalue(x),kind=4)) call s_return(mk_number(int(i, kind=8))) else call error0('j_getkeycode needs an object handle!') end if else if (op == OP_JGETKEYCHAR) then x = car(scm_args) if (isnumber(x)) then i=j_getkeychar(int(get_ivalue(x),kind=4)) call s_return(mk_number(int(i, kind=8))) else call error0('j_getkeychar needs an object handle!') end if else if (op == OP_JMOUSELISTENER) then x = car(scm_args) y = cadr(scm_args) typ = j_doubleclick if (isnumber(x)) then if (isstring(y)) then buff1=get_string(y) if (buff1 == 'entered') then typ=j_entererd else if (buff1 == 'moved') then typ=j_moved else if (buff1 == 'exited') then typ=j_exited else if (buff1 == 'pressed') then typ=j_pressed else if (buff1 == 'dragged') then typ=j_dragged else if (buff1 == 'released') then typ=j_released else if (buff1 == 'doubleclicked') then typ=j_doubleclick end if else if (isnumber(x)) then typ=get_ivalue(x) if (typ < j_moved .or. typ > j_doubleclicked) typ=j_doubleclick end if i=j_mouselistener(int(get_ivalue(x), kind=4), int(typ, kind=4)) call s_return(mk_number(int(i, kind=8))) else call error0('j_mouselistener needs an object handle!') end if else if (op == OP_JGETMOUSEBUTTON) then x = car(scm_args) if (isnumber(x)) then i=j_getmousebutton(int(get_ivalue(x),kind=4)) else call error0('j_getmousebutton needs an object handle!') end if call s_return(mk_number(int(i, kind=8))) else if (op == OP_JNEXTACTION) then i=j_nextaction() call s_return(mk_number(int(i, kind=8))) else if (op == OP_JGETWIDTH) then x = car(scm_args) if (isnumber(x)) then i=j_getwidth(int(get_ivalue(x),kind=4)) else call error0('j_getwidth needs an object handle!') end if call s_return(mk_number(int(i, kind=8))) else if (op == OP_JGETHEIGHT) then x = car(scm_args) if (isnumber(x)) then i=j_getheight(int(get_ivalue(x),kind=4)) else call error0('j_getheight needs an object handle!') end if call s_return(mk_number(int(i, kind=8))) else if (op == OP_JGETPOS) then x = car(scm_args) if (isnumber(x)) then call j_getpos(int(get_ivalue(x),kind=4), i, j) x=nil x=cons(mk_number(int(i,kind=8)), x) x=cons(mk_number(int(j,kind=8)), x) call s_return(reverse(x)) else call error0('j_getpos needs an object handle!') end if else if (op == OP_JSETPOS .or. op == OP_JSETSIZE) then x = car(scm_args) y = cadr(scm_args) z = caddr(scm_args) if (isnumber(x) .and. isnumber(y) .and. isnumber(z)) then if (op == OP_JSETPOS) then call j_setpos(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4), & int(get_ivalue(z),kind=4)) else call j_setsize(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4), & int(get_ivalue(z),kind=4)) end if call s_return(t) else call error0('j_setpos/size needs handle, x and y coordinates!') end if else if (op == OP_JSETALIGN) then x = car(scm_args) y = cadr(scm_args) typ=1 if (isnumber(x)) then if (isnumber(y)) then typ=get_ivalue(y) else if (isstring(y)) then typ=aligntype(get_string(y)) end if call j_setalign(int(get_ivalue(x), kind=4), & int(typ, kind=4)) call s_return(un) else call error0('j_setalign needs handle, direction!') end if else if (op == OP_JSETBORDERLAYOUT) then x = car(scm_args) if (isnumber(x)) then call j_setborderlayout(int(get_ivalue(x),kind=4)) call s_return(t) else call error0('j_setborderlayout needs handle!') end if else if (op == OP_JSETGRIDLAYOUT) then x = car(scm_args) y = cadr(scm_args) z = caddr(scm_args) if (isnumber(x) .and. isnumber(y) .and. isnumber(z)) then call j_setgridlayout(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4), & int(get_ivalue(z),kind=4)) call s_return(t) else call error0('j_setgridlayout needs handle, NR, NC !') end if else if (op == OP_JSETFLOWLAYOUT) then x = car(scm_args) typ = j_vertical if (isnumber(x)) then if (isnumber(y)) then typ=get_ivalue(x) else if (isstring(y)) then if (get_string(y) == 'vertical') then typ=j_vertical else typ=j_horizontal end if end if call j_setflowlayout(int(get_ivalue(x), kind=4), & int(typ, kind=4)) call s_return(t) else call error0('j_setflowlayout needs handle and alignment!') end if end if end subroutine opexe15 #endif ! ! eggx graphics library ! #if EGGX subroutine opexe16(op) integer :: op integer :: i, ix, iy, j, k, l, n, typ, v, w, x, y, z character (len=11) :: colour real :: siz, val, xpos, ypos, xpos2, ypos2 logical :: active_window = .FALSE. if (op == OP_EGGETDISPLAYINFO) then call ggetdisplayinfo(j, k, l) x=nil x=cons(mk_number(int(i,kind=8)), x) x=cons(mk_number(int(j,kind=8)), x) x=cons(mk_number(int(k,kind=8)), x) call s_return(reverse(x)) else if (op == OP_EGGOPEN) then active_window = .TRUE. ix=800 iy=800 x = car(scm_args) y = cadr(scm_args) if (isnumber(x)) ix=int(get_ivalue(x), kind=4) if (isnumber(y)) iy=int(get_ivalue(y), kind=4) call gopen(ix, iy, i) call s_return(mk_number(int(i, kind=8))) else if (op == OP_EGGCLR .or. op == OP_EGGCLOSE) then x = car(scm_args) if (isnumber(x)) then i=int(get_ivalue(x), kind=4) if (op == OP_EGGCLR) then call gclr(i) else call gclose(i) end if call s_return(t) else call error0('gclr/gclose needs handle!') end if else if (op == OP_EGGCLOSEALL) then active_window = .FALSE. call gcloseall() call s_return(t) else if (op == OP_EGGNEWWINDOW) then active_window = .TRUE. w = car(scm_args) x = cadr(scm_args) y = caddr(scm_args) i = cadddr(scm_args) j = car(cddddr(scm_args)) if (isnumber(w) .and. isnumber(x) .and. isnumber(y) .and. & isnumber(i) .and. isnumber(j)) then call newwindow(int(get_ivalue(w), kind=4), & rvalue(x), rvalue(y), & rvalue(i), rvalue(j)) call s_return(t) else call error0('newwindow needs handle, x0, y0 (bottom left), x1, y1 (top right)!') end if else if (op == OP_EGGLAYER .or. op == OP_EGGCOPYLAYER) then w = car(scm_args) i = cadr(scm_args) j = caddr(scm_args) if (isnumber(w) .and. isnumber(i) .and. isnumber(j)) then w=int(get_ivalue(w), kind=4) i=int(get_ivalue(i), kind=4) j=int(get_ivalue(j), kind=4) if (i >= 0 .and. i <= 7 .and. j >= 0 .and. j <=7) then if (op == OP_EGGLAYER) then call layer(w, i, j) else call copylayer(w, i, j) end if call s_return(t) else call error0('display_layer or draw_layer outside range 0-7!') end if else call error0('layer needs handle, display_layer, draw_layer!)') end if else if (op == OP_EGGSETBGCOLOR .or. op == OP_EGGNEWCOLOR) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x) .and. isstring(y)) then if (op == OP_EGGSETBGCOLOR) then call gsetbgcolor(int(get_ivalue(x),kind=4), get_string(y) // CHAR(0)) else call newcolor(int(get_ivalue(x),kind=4), get_string(y) // CHAR(0)) end if call s_return(t) else call error0('gsetbgcolor needs handle, colour name!') end if else if (op == OP_EGGNEWRGBCOLOR) then w = car(scm_args) x = cadr(scm_args) y = caddr(scm_args) z = cadddr(scm_args) if (isnumber(w) .and. isnumber(x) .and. isnumber(y) .and. & isnumber(z)) then call newrgbcolor(int(get_ivalue(w), kind=4), & int(get_ivalue(x), kind=4), & int(get_ivalue(y), kind=4), & int(get_ivalue(z), kind=4)) call s_return(t) else call error0('newrgbcolor needs handle, R, G, B!') end if else if (op == OP_EGGTCLR) then call tclr() call s_return(t) else if (op == OP_EGGNEWPENCOLOR) then x = car(scm_args) y = cadr(scm_args) i = 0 if (isnumber(x)) then if (isnumber(y)) then i=get_ivalue(y) if (i < 0 .or. i > 15) i=0 else if (isstring(y)) then colour=get_string(y) if (colour == 'black') then i=0 else if (colour == 'white') then i=1 else if (colour == 'red') then i=2 else if (colour == 'green') then i=3 else if (colour == 'blue') then i=4 else if (colour == 'cyan') then i=5 else if (colour == 'magenta') then i=6 else if (colour == 'yellow') then i=7 else if (colour == 'dimgray') then i=8 else if (colour == 'gray') then i=9 else if (colour == 'darkred') then i=10 else if (colour == 'darkgreen') then i=11 else if (colour == 'darkblue') then i=12 else if (colour == 'darkcyan') then i=13 else if (colour == 'darkmagenta') then i=14 else if (colour == 'darkyellow') then i=15 end if end if call newpencolor(int(get_ivalue(x),kind=4), i) call s_return(t) else call error0('newpencolor needs handle, colour number!') end if else if (op == OP_EGGNEWLINEWIDTH .or. op == OP_EGGNEWLINESTYLE) then x = car(scm_args) y = cadr(scm_args) if (isnumber(x) .and. isnumber(y)) then if (op == OP_EGGNEWLINEWIDTH) then call newlinewidth(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4)) else call newlinestyle(int(get_ivalue(x),kind=4), & int(get_ivalue(y),kind=4)) end if call s_return(t) else call error0('newlinewidth/style needs handle, width or style number!') end if else if (op == OP_EGGPSET .or. op == OP_EGGMOVETO .or. & op == OP_EGGLINETO) then w = car(scm_args) x = cadr(scm_args) y = caddr(scm_args) if (isnumber(w) .and. isnumber(x) .and. isnumber(y)) then xpos=real(rvalue(x), kind=4) ypos=rvalue(y) if (op == OP_EGGPSET) then call pset(int(get_ivalue(w),kind=4), xpos, ypos) else if (op == OP_EGGMOVETO) then call moveto(int(get_ivalue(w),kind=4), xpos, ypos) else call lineto(int(get_ivalue(w),kind=4), xpos, ypos) end if call s_return(t) else call error0('pset/moveto/lineto needs handle, x, y!') end if else if (op == OP_EGGDRAWLINE) then w = car(scm_args) x = cadr(scm_args) y = caddr(scm_args) i = cadddr(scm_args) j = car(cddddr(scm_args)) if (isnumber(w) .and. isnumber(x) .and. isnumber(y) .and. & isnumber(i) .and. isnumber(j)) then xpos=real(rvalue(x), kind=4) ypos=real(rvalue(y), kind=4) xpos2=real(rvalue(i), kind=4) ypos2=real(rvalue(j), kind=4) call drawline(int(get_ivalue(w), kind=4), xpos, ypos, xpos2, ypos2) call s_return(t) else call error0('drawline needs handle, x0, y0 (start), x1, y1 (end)!') end if else if (op == OP_EGGDRAWRECT .or. op == OP_EGGFILLRECT) then w = car(scm_args) x = cadr(scm_args) y = caddr(scm_args) i = cadddr(scm_args) j = car(cddddr(scm_args)) if (isnumber(w) .and. isnumber(x) .and. isnumber(y) .and. & isnumber(i) .and. isnumber(j)) then xpos=real(rvalue(x), kind=4) ypos=real(rvalue(y), kind=4) xpos2=real(rvalue(i), kind=4) ypos2=real(rvalue(j), kind=4) if (op == OP_EGGDRAWRECT) then call drawrect(int(get_ivalue(w), kind=4), xpos, ypos, xpos2, ypos2) else call fillrect(int(get_ivalue(w), kind=4), xpos, ypos, xpos2, ypos2) end if call s_return(t) else call error0('draw/fillrect needs handle, x0, y0 (start), w, h!') end if else if (op == OP_EGGDRAWCIRC .or. op == OP_EGGFILLCIRC) then w = car(scm_args) x = cadr(scm_args) y = caddr(scm_args) i = cadddr(scm_args) j = car(cddddr(scm_args)) if (isnumber(w) .and. isnumber(x) .and. isnumber(y) .and. & isnumber(i) .and. isnumber(j)) then xpos=real(rvalue(x), kind=4) ypos=real(rvalue(y), kind=4) xpos2=real(rvalue(i), kind=4) ypos2=real(rvalue(j), kind=4) if (op == OP_EGGDRAWCIRC) then call drawcirc(int(get_ivalue(w), kind=4), & xpos, ypos, xpos2, ypos2) else call fillcirc(int(get_ivalue(w), kind=4), & xpos, ypos, xpos2, ypos2) end if call s_return(t) else call error0('draw/fillcirc needs handle, x0, y0 (start), w, h!') end if else if (op == OP_EGGDRAWSYM) then w = car(scm_args) x = cadr(scm_args) y = caddr(scm_args) if (isnumber(w) .and. isnumber(x) .and. isnumber(y)) then xpos=rvalue(x) ypos=rvalue(y) typ=1 siz=16.0 i = cadddr(scm_args) if (isnumber(i)) then typ=get_ivalue(i) if (typ < 0 .or. typ > 10) typ=1 end if j = car(cddddr(scm_args)) if (isnumber(j)) siz=rvalue(j) call drawsym(int(get_ivalue(w), kind=4), xpos, ypos, siz, typ) call s_return(t) else call error0('drawsym needs handle, x, y [,type (1-10) [,size]]!') end if else if (op == OP_EGGDRAWSTR) then w = car(scm_args) x = cadr(scm_args) y = caddr(scm_args) i = cadddr(scm_args) j = car(cddddr(scm_args)) if (isnumber(w) .and. isnumber(x) .and. isnumber(y) .and. & isstring(i)) then xpos=rvalue(x) ypos=rvalue(y) siz=14.0 if (isnumber(j)) siz=rvalue(j) call drawstr(int(get_ivalue(w), kind=4), & xpos, ypos, siz, & get_string(i) // CHAR(0), 0.0, get_strlen(i)) call s_return(t) else call error0('drawstr needs handle, x, y, string [, size]!') end if else if (op == OP_EGGDRAWNUM) then w = car(scm_args) x = cadr(scm_args) y = caddr(scm_args) v = cadddr(scm_args) i = car(cddddr(scm_args)) j = cadr(cddddr(scm_args)) if (isnumber(w) .and. isnumber(x) .and. isnumber(y) .and. & isnumber(v)) then xpos=rvalue(x) ypos=rvalue(y) siz=14.0 if (isnumber(i)) siz=rvalue(i) n=4 if (isnumber(j)) n=rvalue(j) val=rvalue(v) call drawnum(int(get_ivalue(w), kind=4), & xpos, ypos, siz, val, 0.0, n) call s_return(t) else call error0('drawnum needs handle, x, y, val [, size [, ndig]]!') end if else if (op == OP_EGGSETNONBLOCK) then i=0 x = car(scm_args) if (isstring(x)) then if (get_string(x) == 'on') i=1 else if (isnumber(x)) then i=get_ivalue(x) end if call gsetnonblock(i) if (i == 1) then call s_return(t) else call s_return(f) end if else if (op == OP_EGGETCH) then call ggetch(i) call s_return(mk_number(int(i, kind=8))) else if (op == OP_EGGETEVENT) then if (active_window) then call ggetevent(w, i, j, k, xpos, ypos) x=nil x=cons(mk_number(int(w,kind=8)), x) x=cons(mk_number(int(i,kind=8)), x) x=cons(mk_number(int(j,kind=8)), x) x=cons(mk_number(int(k,kind=8)), x) x=cons(mk_real(real(xpos, kind=8)), x) x=cons(mk_real(real(ypos, kind=8)), x) call s_return(reverse(x)) else call error0('ggetevent requires open window!') end if end if end subroutine opexe16 #endif ! ! bignum arithmetic ! ! bignum popcnt function bignum_popcnt(big1) integer(kind=8) :: bignum_popcnt integer, intent(in) :: big1 integer(kind=8) :: n reg9=int2big(4294967296_8) reg10=big1 n=0 do while (.not.(bignum_zerop(reg10))) reg10=bignum_divide(reg10, reg9) n=n+popcnt(get_ivalue(simplest_int(cadr(reg10)))) reg10=car(reg10) end do bignum_popcnt=n end function bignum_popcnt ! remove leading zeroes function bignum_normalize(big1) integer :: bignum_normalize integer, intent(in) :: big1 integer :: x, y x=big1 y=x do while (x /= nil) if (get_ivalue(car(x)) /= 0) y=x x=cdr(x) end do call set_cdr(y, nil) bignum_normalize=big1 end function bignum_normalize ! ! compare ! function bignum_cmp(big1, big2) integer :: bignum_cmp integer, intent(in) :: big1, big2 integer(kind=8) :: tmp1, tmp2 integer :: res, x, y res=0 x=big1 y=big2 do while (.not.(x == nil .and. y == nil)) if (x /= nil) then tmp1=get_ivalue(car(x)) x=cdr(x) else tmp1=0 end if if (y /= nil) then tmp2=get_ivalue(car(y)) y=cdr(y) else tmp2=0 end if if (tmp1 > tmp2) then res=1 else if (tmp1 < tmp2) then res=-1 end if end do bignum_cmp=res end function bignum_cmp ! ! Copy a bignum ! function bignum_copy(big1) integer :: bignum_copy integer, intent(in) :: big1 integer :: x, sgn, tmp sgn=getsign(big1) x=big1 reg1=nil do while (x /= nil) tmp=mk_number(get_ivalue(car(x))) reg1=cons(tmp, reg1) x=cdr(x) end do ! cannot use non_alloc_rev here - slows right down reg1=reverse(reg1) call set_as_bigval(reg1) call set_sign(reg1, sgn) bignum_copy=reg1 end function bignum_copy ! function bignum_zerop(big1) logical :: bignum_zerop integer, intent(in) :: big1 integer :: x x=big1 do while (x /= nil) if (get_ivalue(car(x)) /= 0) then bignum_zerop=.false. return end if x=cdr(x) end do bignum_zerop=.true. end function bignum_zerop ! ! number of digits ! function bignum_digits(big1) integer :: bignum_digits integer, intent(in) :: big1 integer(kind=8) :: i integer :: wrk i=0 wrk=big1 do while (cdr(wrk) /= nil) i=i+bigbase wrk=cdr(wrk) end do i=i+int(log10(rvalue(car(wrk))),kind=8) bignum_digits=i end function bignum_digits ! ! log10 for bignums 17 decimal digits of precision ! y = 10^(ndigits-20) = 10^(floor(log10(x))-16) ! x = y*z ! function bignum_log10(big1) double precision :: bignum_log10 integer, intent(in) :: big1 integer(kind=8) :: i double precision :: res, rem reg9=big1 i=max(1_8, bignum_digits(reg9)-16) if (i > 1) then reg10=bignum_expt(int2big(10_8), i) reg9=bignum_divide(reg9, reg10) res=rvalue(car(reg9)) if (res /= 0.0d0) res=log10(res) bignum_log10=real(i, kind=8) + res reg10=nil else bignum_log10=log10(rvalue(reg9)) end if reg9=nil end function bignum_log10 ! ! abs for bignums ! function bignum_abs(big1) integer :: bignum_abs integer, intent(in) :: big1 integer :: res res=bignum_copy(big1) call set_sign(res,1) bignum_abs=res end function bignum_abs ! ! Addition ! subroutine bignum_incr(big1, i) integer :: big1 integer(kind=8) :: i integer(kind=8) :: tmp integer :: wk tmp=get_ivalue(car(big1))+i if (tmp <= rbase) then call set_ivalue(car(big1), tmp) else call set_ivalue(car(big1), 0_8) if (cdr(big1) /= nil) then tmp=get_ivalue(cadr(big1)) call set_ivalue(cadr(big1), tmp+1) else wk=getcell(big1, nil, 'bignum_incr') call set_as_number(wk) call set_ivalue(wk, 1_8) big1=cons(big1, wk) big1=non_alloc_rev(nil,big1) call set_as_bigval(big1) end if end if end subroutine bignum_incr ! ! Main (schoolbook) addition routine ! function bignum_add(big1, big2) integer :: bignum_add integer, intent(in) :: big1, big2 integer(kind=8) :: carry, i, res, tmp, tmp1, tmp2 integer :: wk, len1, len2 character (len=1) :: ch carry=0 reg5=nil reg1=big1 reg2=big2 i=0 do while (.not.(reg1 == nil .and. reg2 == nil)) i=i+1 tmp1=0 tmp2=0 if (ispair(reg1)) then tmp1=get_ivalue(car(reg1)) reg1=cdr(reg1) end if if (ispair(reg2)) then tmp2=get_ivalue(car(reg2)) reg2=cdr(reg2) end if tmp= tmp1 + tmp2 + carry carry=0 if (tmp >= rbase) then carry=carry+1 tmp=tmp-rbase end if wk=mk_number(int(tmp,kind=8)) reg5=cons(wk, reg5) end do if (carry /= 0) then wk=mk_number(int(carry,kind=8)) reg5=cons(wk, reg5) end if reg5=non_alloc_rev(nil,reg5) call set_as_bigval(reg5) bignum_add=reg5 end function bignum_add function bignum_sub(big1, big2) integer :: bignum_sub integer, intent(in) :: big1, big2 integer(kind=8) :: borrow, tmp, tmp1, tmp2 integer :: i, j, wk character (len=1) :: ch if (.not.isbignum(big1)) then write(*,'(a)') 'First argument in subtraction not a bignum!' bignum_sub=nil return else if (.not.isbignum(big2)) then write(*,'(a)') 'Second argument in subtraction not a bignum!' bignum_sub=nil return end if reg1=big1 reg2=big2 reg5=nil borrow=0 do while (.not.(reg1 == nil .and. reg2 == nil)) if (reg1 /= nil) then tmp1=get_ivalue(car(reg1)) reg1=cdr(reg1) else tmp1=0 end if if (reg2 /= nil) then tmp2=get_ivalue(car(reg2)) + borrow reg2=cdr(reg2) else tmp2=borrow end if borrow=0 if (tmp1 < tmp2) then tmp1=tmp1+rbase borrow=1 end if tmp=tmp1 - tmp2 wk=mk_number(int(tmp,kind=8)) reg5=cons(wk, reg5) end do ! reg5=reverse(reg5) reg5=non_alloc_rev(nil,reg5) reg5=bignum_normalize(reg5) call set_as_bigval(reg5) !write(*,'(a)', advance='no') 'bignum_sub res=' !call bigprint(reg5, advance='yes') !if (get_ivalue(car(reg5)) == 122) then ! write(*,*) 'Where sticking!' !! call show_mem(2) ! do ! write(*,'(a)', advance='no') 'cell? ' ! read(*,*) i ! if (i < 1) exit ! call show_memcell(i) ! end do !end if bignum_sub=reg5 end function bignum_sub ! ! Signed addition and subtraction ! function bignum_addsub(sop, big1, big2) integer bignum_addsub integer, intent(in) :: big1, big2, sop integer :: opsign, res, sgn1, sgn2 sgn1=getsign(big1) sgn2=getsign(big2) opsign=sop*sgn1*sgn2 if (opsign == 1) then res=bignum_add(big1, big2) else if (bignum_cmp(big1, big2) > -1) then res=bignum_sub(big1, big2) else res=bignum_sub(big2, big1) sgn1=-sgn1 end if end if call set_sign(res, sgn1) bignum_addsub=res end function bignum_addsub function bignum_basemult (n, big1) integer :: bignum_basemult integer (kind=8), intent(in) :: n integer, intent(in) :: big1 integer(kind=8) :: i reg5=big1 do i=1, n reg5=cons(mk_number(int(0,kind=8)), reg5) end do call set_as_bigval(reg5) bignum_basemult=reg5 end function bignum_basemult function bignum_basediv (n, big1) integer :: bignum_basediv integer (kind=8), intent(in) :: n integer, intent(in) :: big1 integer(kind=8) :: i integer :: x if (get_listlen(big1) > n) then x=big1 do i=1, n x=cdr(x) end do call set_as_bigval(x) bignum_basediv=x else write(*,'(a)') 'Integer smaller than divisor!' bignum_basediv=nil end if end function bignum_basediv ! ! In-place halving of a bignum ! subroutine bignum_halve (big1) integer, intent(in) :: big1 integer :: x integer(kind=8) :: borrow, dig, next_dig, tmp integer (kind=8), parameter :: bhalf = rbase / 2 if (isbignum(big1)) then x=big1 dig=get_ivalue(car(x)) do while (cdr(x) /= nil) next_dig=get_ivalue(cadr(x)) borrow=mod(next_dig,2) tmp=bhalf*borrow+rshift(dig,1) call set_ivalue(car(x), mod(tmp, rbase)) dig=next_dig x=cdr(x) end do call set_ivalue(car(x), rshift(dig,1)) else write(*,'(a,1x,i0)') 'bignum_halve requires a bignum!', big1 end if end subroutine bignum_halve ! ! Karatsuba for multiplying two kind=8 integers ! returning a bignum if overflow ! function int64_multiply (a, b) integer :: int64_multiply integer :: tmp integer (kind=8), intent(in) :: a, b integer (kind=8) :: a0, a1, b0, b1, c0, c1, c2, carry, s integer (kind=8), parameter :: k = 10 ** (bigbase/2) a1=a/k b1=b/k a0=mod(a,k) b0=mod(b,k) c0=a0*b0 c1=a1*b1 s=sign(1_8,a0-a1)*sign(1_8,b0-b1) c2=abs(a0-a1)*abs(b0-b1) s=(c0+c1-s*c2) carry=s/k s=mod(s,k) reg1=cons(mk_number(c0+k*s), nil) if (c1+carry > 0) then reg1=cons(mk_number(c1+carry), reg1) end if ! reg1=reverse(reg1) reg1=non_alloc_rev(nil,reg1) call set_as_bigval(reg1) int64_multiply=reg1 end function int64_multiply function bignum_multiply (big1, big2) integer :: bignum_multiply integer, intent(in) :: big1, big2 integer :: res, sgn, wrk integer (kind=8) :: i, j, tmp1, tmp2 if (big1 == nil .or. big2 == nil) then bignum_multiply=nil return end if sgn=getsign(big1)*getsign(big2) i=0 reg3=big1 reg8=int2big(0_8) do while (reg3 /= nil) j=0 reg4=big2 do while (reg4 /= nil) tmp1=get_ivalue(car(reg3)) tmp2=get_ivalue(car(reg4)) wrk=int64_multiply(tmp1, tmp2) wrk=bignum_basemult(i+j, wrk) reg8=bignum_add(reg8, wrk) j=j+1 reg4=cdr(reg4) end do reg3=cdr(reg3) i=i+1 end do call set_as_bigval(reg8) call set_sign(reg8, sgn) bignum_multiply=reg8 end function bignum_multiply ! ! bignum exponentiation 3,4,5,6,7,8 ! function bignum_expt (big1, iex) integer :: bignum_expt integer, intent(in) :: big1 integer :: sgn integer(kind=8), intent(in) :: iex integer(kind=8) :: iexp if (iex == 0) then bignum_expt=int2big(1_8) return end if iexp=iex sgn=getsign(big1) if (sgn == -1) then if (mod(iexp,2) == 0) sgn=-sgn end if reg7=big1 reg6=int2big(1_8) do while (iexp /= 0) if (mod(iexp,2) == 1) then reg6=bignum_multiply(reg6,reg7) iexp=iexp-1 else reg7=bignum_multiply(reg7, reg7) iexp=iexp/2 end if end do call set_sign(reg6, sgn) bignum_expt=reg6 end function bignum_expt ! ! Apparently due to Cohen 1993 ! function bignum_sqrt (big1) integer :: bignum_sqrt integer, intent(in) :: big1 integer :: sgn integer(kind=8) :: i if (getsign(big1) == -1) then bignum_sqrt=nil return end if i=0 reg10=big1 do i=i+1 reg9=reg10 reg10=bignum_add(reg9, car(bignum_divide(big1,reg9))) call bignum_halve(reg10) if (bignum_cmp(reg10, reg9) > -1) exit end do reg9=bignum_normalize(reg9) bignum_sqrt=reg9 end function bignum_sqrt ! ! uses regs 1,2,3,4,5,6,7,8 ! sign of divisor and remainder x = quotient*y + rem ! function bignum_divide (big1, big2) integer :: bignum_divide integer, intent(in) :: big1, big2 integer :: sgn1, sgn2 integer :: i sgn1=getsign(big1) sgn2=getsign(big2) reg8=int2big(1_8) reg3=bignum_copy(big1) reg4=bignum_copy(big2) do while (bignum_cmp(reg4, reg3) < 1) reg8=bignum_add(reg8, reg8) reg4=bignum_add(reg4,reg4) end do reg6=int2big(0_8) reg7=reg3 i=0 do while (.not.bignum_zerop(reg8)) i=i+1 if (bignum_cmp(reg7, reg4) > -1) then reg7=bignum_sub(reg7, reg4) reg6=bignum_add(reg6, reg8) end if call bignum_halve(reg8) call bignum_halve(reg4) ! write(*,'(a,i0,a)', advance='no') 'i=', i, ' reg6=' ! call bigprint(reg6, advance='yes') ! write(*,'(a)', advance='no') 'reg7=' ! call bigprint(reg7, advance='yes') ! write(*,'(a)', advance='no') 'reg8=' ! call bigprint(reg4, advance='yes') ! write(*,'(a)', advance='no') 'reg4=' ! call bigprint(reg8, advance='yes') end do call set_sign(reg7, sgn1) call set_sign(reg6, sgn1*sgn2) bignum_divide=cons(reg6,cons(reg7,nil)) end function bignum_divide ! ! Initialization of internal keywords ! subroutine mk_syntax(op, nam) integer :: op character (len=*) :: nam integer :: x x=cons(mk_string(nam), nil) call set_type(x, ior(T_SYNTAX, T_SYMBOL)) call set_syntaxnum(x, op) oblist=cons(x, oblist) end subroutine mk_syntax ! subroutine mk_proc(op, nam) integer :: op character (len=*) :: nam integer :: x, y x=mk_symbol(nam) y=getcell(nil, nil, 'mk_proc') call set_type(y, ior(T_PROC, T_ATOM)) call set_ivalue(y, int(op, kind=8)) call set_string(y, nam) call set_car(global_env, cons(cons(x, y), car(global_env))) end subroutine mk_proc ! ! Initiate global environment ! subroutine init_vars_global() integer :: x infp=STDIN outp=STDOUT global_env=cons(nil, nil) x=mk_symbol('else') call set_car(global_env, cons(cons(x, t), car(global_env))) end subroutine init_vars_global ! ! Initiate syntax ! subroutine init_syntax() call mk_syntax(OP_LAMBDA, 'lambda') call mk_syntax(OP_MKCLOSURE, 'make-closure') call mk_syntax(OP_QUOTE, 'quote') call mk_syntax(OP_DEF0, 'define') call mk_syntax(OP_IF0, 'if') call mk_syntax(OP_BEGIN, 'begin') call mk_syntax(OP_SET0, 'set!') call mk_syntax(OP_LET0, 'let') call mk_syntax(OP_LET0AST, 'let*') call mk_syntax(OP_LET0REC, 'letrec') call mk_syntax(OP_COND0, 'cond') call mk_syntax(OP_DELAY, 'delay') call mk_syntax(OP_AND0, 'and') call mk_syntax(OP_OR0, 'or') call mk_syntax(OP_C0STREAM, 'cons-stream') call mk_syntax(OP_0MACRO, 'define-macro') call mk_syntax(OP_CASE0, 'case') end subroutine init_syntax ! ! Initiate procedures ! subroutine init_procs() call mk_proc(OP_PEVAL, 'eval') call mk_proc(OP_PAPPLY, 'apply') call mk_proc(OP_CONTINUATION, 'call-with-current-continuation') call mk_proc(OP_FORCE, 'force') call mk_proc(OP_CAR, 'car') call mk_proc(OP_CDR, 'cdr') call mk_proc(OP_CONS, 'cons') call mk_proc(OP_SETCAR, 'set-car!') call mk_proc(OP_SETCDR, 'set-cdr!') call mk_proc(OP_ADD, '+') call mk_proc(OP_SUB, '-') call mk_proc(OP_MUL, '*') call mk_proc(OP_DIV, '/') call mk_proc(OP_INTDIV, 'quotient') call mk_proc(OP_REM, 'remainder') call mk_proc(OP_MOD, 'modulo') call mk_proc(OP_NOT, 'not') call mk_proc(OP_BOOL, 'boolean?') call mk_proc(OP_ISINT, 'integer?') call mk_proc(OP_ISREAL, 'real?') call mk_proc(OP_SYMBOL, 'symbol?') call mk_proc(OP_NUMBER, 'number?') call mk_proc(OP_STRING, 'string?') call mk_proc(OP_PROC, 'procedure?') call mk_proc(OP_PAIR, 'pair?') call mk_proc(OP_LIST, 'list?') call mk_proc(OP_PROPER, 'proper-list?') call mk_proc(OP_CIRC, 'circular-list?') call mk_proc(OP_EQV, 'eqv?') call mk_proc(OP_EQ, 'eq?') call mk_proc(OP_NULL, 'null?') call mk_proc(OP_ZEROP, 'zero?') call mk_proc(OP_POSP, 'positive?') call mk_proc(OP_NEGP, 'negative?') call mk_proc(OP_NUMEQ, '=') call mk_proc(OP_LESS, '<') call mk_proc(OP_GRE, '>') call mk_proc(OP_LEQ, '<=') call mk_proc(OP_GEQ, '>=') call mk_proc(OP_READ, 'read') call mk_proc(OP_WRITE, 'write') call mk_proc(OP_DISPLAY, 'display') call mk_proc(OP_NEWLINE, 'newline') call mk_proc(OP_LOAD, 'load') call mk_proc(OP_ERR0, 'error') call mk_proc(OP_REVERSE, 'reverse') call mk_proc(OP_APPEND, 'append') call mk_proc(OP_GC, 'gc') call mk_proc(OP_GCVERB, 'memory-allocate') call mk_proc(OP_NEWSEGMENT, 'new-segment') call mk_proc(OP_LIST_LENGTH, 'length') call mk_proc(OP_ASSQ, 'assq') call mk_proc(OP_GET_CLOSURE, 'get-closure-code') call mk_proc(OP_CLOSUREP, 'closure?') call mk_proc(OP_MACROP, 'macro?') call mk_proc(OP_QUIT, 'quit') call mk_proc(OP_EXP, 'exp') call mk_proc(OP_LOG, 'log') call mk_proc(OP_SIN, 'sin') call mk_proc(OP_COS, 'cos') call mk_proc(OP_TAN, 'tan') call mk_proc(OP_ASIN, 'asin') call mk_proc(OP_ACOS, 'acos') call mk_proc(OP_ATAN, 'atan') call mk_proc(OP_SQRT, 'sqrt') call mk_proc(OP_TRUNCATE, 'truncate') call mk_proc(OP_ROUND, 'round') call mk_proc(OP_CEILING, 'ceiling') call mk_proc(OP_FLOOR, 'floor') call mk_proc(OP_LOG10, 'log10') call mk_proc(OP_ABS, 'abs') call mk_proc(OP_EXPT, 'expt') call mk_proc(OP_MIN, 'min') call mk_proc(OP_MAX, 'max') call mk_proc(OP_INTOEX, 'inexact->exact') call mk_proc(OP_EXTOIN, 'exact->inexact') call mk_proc(OP_RANDOM, 'random') call mk_proc(OP_RNORM, 'rnorm') call mk_proc(OP_PCHISUM, 'pchisqsum') call mk_proc(OP_DBETA, 'dbeta') call mk_proc(OP_MKSTRING, 'make-string') call mk_proc(OP_STRLEN, 'string-length') call mk_proc(OP_STRREF, 'string-ref') call mk_proc(OP_STRSET, 'string-set!') call mk_proc(OP_SUBSTR, 'substring') call mk_proc(OP_STRAPPEND, 'string-append') call mk_proc(OP_STRSPLIT, 'string-split') call mk_proc(OP_STREQ, 'string=?') call mk_proc(OP_STRLT, 'string<?') call mk_proc(OP_STRGT, 'string>?') call mk_proc(OP_STRLE, 'string<=?') call mk_proc(OP_STRGE, 'string>=?') call mk_proc(OP_STRFIND, 'substring?') call mk_proc(OP_CHAR2INT, 'char->integer') call mk_proc(OP_INT2CHAR, 'integer->char') call mk_proc(OP_UPCASE, 'char-upcase') call mk_proc(OP_DOWNCASE, 'char-downcase') call mk_proc(OP_STR2NUM, 'string->number') call mk_proc(OP_NUM2STR, 'number->string') call mk_proc(OP_STR2SYM, 'string->symbol') call mk_proc(OP_SYM2STR, 'symbol->string') call mk_proc(OP_SYSTEM, 'system') call mk_proc(OP_IPORT, 'open-input-file') call mk_proc(OP_CLPORT, 'close-input-port') call mk_proc(OP_OPORT, 'open-output-file') call mk_proc(OP_CLPORT, 'close-output-port') call mk_proc(OP_CURR_INPORT, 'current-input-port') call mk_proc(OP_CURR_OUTPORT, 'current-output-port') call mk_proc(OP_RDLINE, 'read-line') call mk_proc(OP_FORMAT, 'format') #if !(FREESTANDING_SCHEME) call mk_proc(OP_RUNCMD, 'pass-command') call mk_proc(OP_LSLOCI, 'ls') call mk_proc(OP_NLOCI, 'nloci') call mk_proc(OP_LOCNAM, 'loc') call mk_proc(OP_SETLOC, 'loc-set!') call mk_proc(OP_LOCTYP, 'loctyp') call mk_proc(OP_SETTYP, 'loctyp-set!') call mk_proc(OP_LOCORD, 'locord') call mk_proc(OP_LOCSTAT, 'locstat') call mk_proc(OP_SETSTAT, 'locstat-set!') call mk_proc(OP_STATRES, 'stat-result') call mk_proc(OP_INITSTAT, 'locstat-init!') call mk_proc(OP_LOCNOTE, 'locnotes') call mk_proc(OP_SETNOTE, 'locnotes-set!') call mk_proc(OP_LOCRANK, 'locrank') call mk_proc(OP_MAPPOS, 'map-position') call mk_proc(OP_SETMAP, 'map-position-set!') call mk_proc(OP_CHROM, 'chromosome') call mk_proc(OP_SETCHROM, 'chromosome-set!') call mk_proc(OP_LOCPOS, 'locpos') call mk_proc(OP_SETPOS, 'locpos-set!') call mk_proc(OP_HASHLOCI, 'lochash-update!') call mk_proc(OP_TYPSTAT, 'locstat-type!') #endif ! utilities call mk_proc(OP_FDATE, 'date') call mk_proc(OP_TIME, 'current-second') call mk_proc(OP_SYSCLOCK, 'system-clock') call mk_proc(OP_GETENV, 'getenv') call mk_proc(OP_INQUIRE, 'file-exists?') call mk_proc(OP_DELETE, 'file-delete') call mk_proc(OP_DIR, 'file-list') call mk_proc(OP_ISATTY, 'isatty?') call mk_proc(OP_LISTENV, 'dir') call mk_proc(OP_APROPOS, 'apropos') call mk_proc(OP_HELP, 'help') call mk_proc(OP_VERSION, 'version') call mk_proc(OP_GENSYM, 'gensym') call mk_proc(OP_PEEKMEM, 'peek') call mk_proc(OP_BOUND, 'environment-bound?') call mk_proc(OP_DELVAR, 'delete') call mk_proc(OP_REGEXP, 'regexp') call mk_proc(OP_READCH, 'read-char') call mk_proc(OP_PEEKCH, 'peek-char') call mk_proc(OP_HASHOPS , 'hash') call mk_proc(OP_DEBUG , 'debug') call mk_proc(OP_BIGOPS , 'big') #if !(FREESTANDING_SCHEME) ! dataset procedures call mk_proc(OP_NOBS, 'nobs') call mk_proc(OP_NPEDS, 'npeds') call mk_proc(OP_NACTPEDS, 'nactpeds') call mk_proc(OP_ACTIVE, 'active-status') call mk_proc(OP_SETACTIVE, 'set-active-status!') call mk_proc(OP_ACTPEDS, 'active-pedigrees') call mk_proc(OP_PEDLIST, 'pedigrees') call mk_proc(OP_PEDSET, 'set-pedigree-name!') call mk_proc(OP_PEDSIZE, 'pedigree-size') call mk_proc(OP_PEDMEMBERS, 'pedigree-members') call mk_proc(OP_PEDIDX, 'individual-pedigree') call mk_proc(OP_IDLIST, 'individual-name') call mk_proc(OP_IDIDX, 'individual-index') call mk_proc(OP_IDSET, 'set-individual-name!') call mk_proc(OP_FATHER, 'father') call mk_proc(OP_SETFA, 'set-father!') call mk_proc(OP_MOTHER, 'mother') call mk_proc(OP_SETMO, 'set-mother!') call mk_proc(OP_GETSEX, 'sex') call mk_proc(OP_SETSEX, 'set-sex!') call mk_proc(OP_IMZTWIN, 'imztwin') call mk_proc(OP_SETTWIN, 'set-imztwin!') call mk_proc(OP_GETDATA, 'data') call mk_proc(OP_SETDATA, 'set-data!') call mk_proc(OP_SETCHOSEN, 'set-chosen!') call mk_proc(OP_INSRECORD, 'insert-record!') call mk_proc(OP_GETCOUNTS, 'data-counts') call mk_proc(OP_GETALLELES, 'allele-freqs') #endif ! statistical procedure call mk_proc(OP_PNORM, 'pnorm') call mk_proc(OP_LOGPNORM, 'logpnorm') call mk_proc(OP_QNORM, 'qnorm') call mk_proc(OP_PCHISQ, 'pchisq') call mk_proc(OP_QCHISQ, 'qchisq') call mk_proc(OP_PFDIST, 'pf') call mk_proc(OP_BIVNOR, 'bivnor') call mk_proc(OP_GAMMAD, 'pgamma') call mk_proc(OP_ALNGAM, 'lgamma') call mk_proc(OP_PMVN, 'pmvnorm') ! list manipulation procedures call mk_proc(OP_LISTTAIL, 'list-tail') call mk_proc(OP_LISTREF, 'list-ref') call mk_proc(OP_LISTSEL, 'list-select') call mk_proc(OP_MKLIST, 'make-list') call mk_proc(OP_SAMPLE, 'sample-seq') call mk_proc(OP_WHICH, 'which') call mk_proc(OP_GENSEQ, 'seq') call mk_proc(OP_ORDER, 'order') call mk_proc(OP_SORT, 'sort') call mk_proc(OP_RANK, 'rank') call mk_proc(OP_QUANTILES, 'quantile') call mk_proc(OP_DIFFS, 'differences') call mk_proc(OP_SUMSTATS, 'stats') call mk_proc(OP_LOWESS, 'lowess') call mk_proc(OP_MAXIMIZE, 'maximize!') call mk_proc(OP_MODE, 'mode') call mk_proc(OP_GLLM, 'gllm') ! car/cdr compositions call mk_proc(OP_CAAR , 'caar') call mk_proc(OP_CADR , 'cadr') call mk_proc(OP_CDAR , 'cdar') call mk_proc(OP_CDDR , 'cddr') call mk_proc(OP_CAAAR, 'caaar') call mk_proc(OP_CAADR, 'caadr') call mk_proc(OP_CADAR, 'cadar') call mk_proc(OP_CADDR, 'caddr') call mk_proc(OP_CDAAR, 'cdaar') call mk_proc(OP_CDADR, 'cdadr') call mk_proc(OP_CDDAR, 'cddar') call mk_proc(OP_CDDDR, 'cdddr') call mk_proc(OP_CAAAAR, 'caaaar') call mk_proc(OP_CADAAR, 'cadaar') call mk_proc(OP_CDAAAR, 'cdaaar') call mk_proc(OP_CDDAAR, 'cddaar') call mk_proc(OP_CAAADR, 'caaadr') call mk_proc(OP_CADADR, 'cadadr') call mk_proc(OP_CDAADR, 'cdaadr') call mk_proc(OP_CDDADR, 'cddadr') call mk_proc(OP_CAADAR, 'caadar') call mk_proc(OP_CADDAR, 'caddar') call mk_proc(OP_CDADAR, 'cdadar') call mk_proc(OP_CDDDAR, 'cdddar') call mk_proc(OP_CAADDR, 'caaddr') call mk_proc(OP_CADDDR, 'cadddr') call mk_proc(OP_CDADDR, 'cdaddr') call mk_proc(OP_CDDDDR, 'cddddr') ! set procedures call mk_proc(OP_DUPS, 'duplicated') call mk_proc(OP_UNIQUE, 'unique-indices') call mk_proc(OP_INTERSECT, 'intersect-indices') call mk_proc(OP_SETDIFF, 'setdiff-indices') ! bitwise procedures call mk_proc(OP_BITAND, 'bitwise-and') call mk_proc(OP_BITNOT, 'bitwise-not') call mk_proc(OP_BITIOR, 'bitwise-ior') call mk_proc(OP_BITXOR, 'bitwise-xor') call mk_proc(OP_BITSHIFT, 'arithmetic-shift') call mk_proc(OP_BITSETP, 'bit-set?') call mk_proc(OP_BITFIELD, 'bit-field') call mk_proc(OP_POPCNT, 'bit-count') #if JAPI ! JAPI GUI procedures call mk_proc(OP_JSTART, "j_start") call mk_proc(OP_JQUIT, "j_quit") call mk_proc(OP_JFRAME, "j_frame") call mk_proc(OP_JPANEL, "j_panel") call mk_proc(OP_JBORDERPANEL, "j_borderpanel") call mk_proc(OP_JDIALOG, "j_dialog") call mk_proc(OP_JBUTTON, "j_button") call mk_proc(OP_JRADIOBUTTON, "j_radiobutton") call mk_proc(OP_JRADIOGROUP, "j_radiogroup") call mk_proc(OP_JCHECKBOX, "j_checkbox") call mk_proc(OP_JLIST, "j_list") call mk_proc(OP_JADD, "j_add") call mk_proc(OP_JSETCOLOR, "j_setcolor") call mk_proc(OP_JSETCOLORBG, "j_setcolorbg") call mk_proc(OP_JSETNAMEDCOLORBG, "j_setnamedcolorbg") call mk_proc(OP_JGETSELECT, "j_getselect") call mk_proc(OP_JSELECT, "j_select") call mk_proc(OP_JDESELECT, "j_deselect") call mk_proc(OP_JFILESELECT, "j_fileselect") call mk_proc(OP_JFILEDIALOG, "j_filedialog") call mk_proc(OP_JENABLE, "j_enable") call mk_proc(OP_JDISABLE, "j_disable") call mk_proc(OP_JADDITEM, "j_additem") call mk_proc(OP_JSEPARATOR, "j_separator") call mk_proc(OP_JTEXTFIELD, "j_textfield") call mk_proc(OP_JTEXTAREA, "j_textarea") call mk_proc(OP_JSETBORDERPOS, "j_setborderpos") call mk_proc(OP_JSETROWS, "j_setrows") call mk_proc(OP_JSETCOLUMNS, "j_setcolumns") call mk_proc(OP_JGETROWS, "j_getrows") call mk_proc(OP_JGETCOLUMNS, "j_getcolumns") call mk_proc(OP_JGETLENGTH, "j_getlength") call mk_proc(OP_JGETSELSTART, "j_getselstart") call mk_proc(OP_JGETSELEND, "j_getselend") call mk_proc(OP_JSELECTTEXT, "j_selecttext") call mk_proc(OP_JGETTEXT, "j_gettext") call mk_proc(OP_JGETSELTEXT, "j_getseltext") call mk_proc(OP_JGETITEM, "j_getitem") call mk_proc(OP_JLABEL, "j_label") call mk_proc(OP_JGETCURPOS, "j_getcurpos") call mk_proc(OP_JSETCURPOS, "j_setcurpos") call mk_proc(OP_JSETFONT, "j_setfont") call mk_proc(OP_JSETTEXT, "j_settext") call mk_proc(OP_JINSERTTEXT, "j_inserttext") call mk_proc(OP_JREPLACETEXT, "j_replacetext") call mk_proc(OP_JDELETE, "j_delete") call mk_proc(OP_JDISPOSE, "j_dispose") call mk_proc(OP_JMENUBAR, "j_menubar") call mk_proc(OP_JMENU, "j_menu") call mk_proc(OP_JMENUITEM, "j_menuitem") call mk_proc(OP_JPACK, "j_pack") call mk_proc(OP_JSHOW, "j_show") call mk_proc(OP_JHIDE, "j_hide") call mk_proc(OP_JKEYLISTENER, "j_keylistener") call mk_proc(OP_JGETKEYCODE, "j_getkeycode") call mk_proc(OP_JGETKEYCHAR, "j_getkeychar") call mk_proc(OP_JMOUSELISTENER, "j_mouselistener") call mk_proc(OP_JGETMOUSEBUTTON, "j_getmousebutton") call mk_proc(OP_JNEXTACTION, "j_nextaction") call mk_proc(OP_JGETWIDTH, "j_getwidth") call mk_proc(OP_JGETHEIGHT, "j_getheight") call mk_proc(OP_JGETPOS, "j_getpos") call mk_proc(OP_JSETPOS, "j_setpos") call mk_proc(OP_JSETSIZE, "j_setsize") call mk_proc(OP_JSETALIGN, "j_setalign") call mk_proc(OP_JSETBORDERLAYOUT, "j_setborderlayout") call mk_proc(OP_JSETGRIDLAYOUT, "j_setgridlayout") call mk_proc(OP_JSETFLOWLAYOUT, "j_setflowlayout") #endif #if EGGX call mk_proc(OP_EGGETDISPLAYINFO,"ggetdisplayinfo") call mk_proc(OP_EGGOPEN,"gopen") call mk_proc(OP_EGGCLOSE,"gclose") call mk_proc(OP_EGGCLOSEALL,"gcloseall") call mk_proc(OP_EGGNEWCOORDINATE,"newcoordinate") call mk_proc(OP_EGGNEWWINDOW,"newwindow") call mk_proc(OP_EGGLAYER,"layer") call mk_proc(OP_EGGCOPYLAYER,"copylayer") call mk_proc(OP_EGGSETBGCOLOR,"gsetbgcolor") call mk_proc(OP_EGGCLR,"gclr") call mk_proc(OP_EGGTCLR,"tclr") call mk_proc(OP_EGGNEWPENCOLOR,"newpencolor") call mk_proc(OP_EGGNEWCOLOR,"newcolor") call mk_proc(OP_EGGNEWRGBCOLOR,"newrgbcolor") call mk_proc(OP_EGGNEWHSVCOLOR,"newhsvcolor") call mk_proc(OP_EGGMAKECOLOR,"makecolor") call mk_proc(OP_EGGNEWLINEWIDTH,"newlinewidth") call mk_proc(OP_EGGNEWLINESTYLE,"newlinestyle") call mk_proc(OP_EGGPSET,"pset") call mk_proc(OP_EGGDRAWLINE,"drawline") call mk_proc(OP_EGGMOVETO,"moveto") call mk_proc(OP_EGGLINETO,"lineto") call mk_proc(OP_EGGDRAWPTS,"drawpts") call mk_proc(OP_EGGDRAWLINES,"drawlines") call mk_proc(OP_EGGDRAWPOLY,"drawpoly") call mk_proc(OP_EGGFILLPOLY,"fillpoly") call mk_proc(OP_EGGDRAWRECT,"drawrect") call mk_proc(OP_EGGFILLRECT,"fillrect") call mk_proc(OP_EGGDRAWCIRC,"drawcirc") call mk_proc(OP_EGGFILLCIRC,"fillcirc") call mk_proc(OP_EGGDRAWARC,"drawarc") call mk_proc(OP_EGGFILLARC,"fillarc") call mk_proc(OP_EGGDRAWSYM,"drawsym") call mk_proc(OP_EGGDRAWSYMS,"drawsyms") call mk_proc(OP_EGGDRAWARROW,"drawarrow") call mk_proc(OP_EGGNEWFONTSET,"newfontset") call mk_proc(OP_EGGDRAWSTR,"drawstr") call mk_proc(OP_EGGDRAWNUM,"drawnum") call mk_proc(OP_EGGPUTIMG24,"putimg24") call mk_proc(OP_EGGSAVEIMG,"saveimg") call mk_proc(OP_EGGSETNONBLOCK,"gsetnonblock") call mk_proc(OP_EGGETCH,"ggetch") call mk_proc(OP_EGGETEVENT,"ggetevent") call mk_proc(OP_EGGETXPRESS,"ggetxpress") #endif end subroutine init_procs ! ! Inlined init.scm ! subroutine init_scm() scheme_lin='(define nil #f) (define t #t)' call repl_scheme(3,0) scheme_lin='(define call/cc call-with-current-continuation)' call repl_scheme(3,0) scheme_lin='(define exact inexact->exact) (define inexact exact->inexact)' call repl_scheme(3,0) scheme_lin='(define get-environment-variable getenv)' call repl_scheme(3,0) scheme_lin='(define (list . x) x)' call repl_scheme(3,0) scheme_lin='(define string string-append)' call repl_scheme(3,0) scheme_lin='(define char=? string=?) (define char<? string<?) ' // & '(define char>? string>?) (define char<=? string<=?) ' // & '(define char>=? string>=?)' call repl_scheme(3,0) scheme_lin='(define (char-ci=? x y) (string=? (char-upcase x) ' // & '(char-upcase y)))' call repl_scheme(3,0) scheme_lin='(define (char-ci<? x y) (string<? (char-upcase x) ' // & '(char-upcase y)))' call repl_scheme(3,0) scheme_lin='(define (char-ci>? x y) (string>? (char-upcase x) ' // & '(char-upcase y)))' call repl_scheme(3,0) scheme_lin='(define (char-ci<=? x y) (string<=? (char-upcase x) ' // & '(char-upcase y)))' call repl_scheme(3,0) scheme_lin='(define (char-ci>=? x y) (string>=? (char-upcase x) ' // & '(char-upcase y)))' call repl_scheme(3,0) scheme_lin='(define (char-upper-case? x) (let ((c (char->integer x))) ' // & '(and (> c 64) (< c 91))))' call repl_scheme(3,0) scheme_lin='(define (char-lower-case? x) (let ((c (char->integer x))) ' // & '(and (> c 96) (< c 123))))' call repl_scheme(3,0) scheme_lin='(define (char-alphabetic? x) (or (char-upper-case? x) ' // & '(char-lower-case? x)))' call repl_scheme(3,0) scheme_lin='(define (char-numeric? x) (let ((c (char->integer x))) ' // & '(and (> c 47) (< c 58))))' call repl_scheme(3,0) scheme_lin='(define (char-whitespace? x) (let ((c (char->integer x))) ' // & '(or (= c 32) (= c 9) (= c 10) (= c 12) (= c 13))))' call repl_scheme(3,0) scheme_lin='(define (list->string x) (apply string-append x))' call repl_scheme(3,0) scheme_lin='(define (unzip1-with-cdr . lists) ' // & '(unzip1-with-cdr-iterative lists ' // char(39) // '()' // & char(39) // '()))' call repl_scheme(3,0) scheme_lin='(define (unzip1-with-cdr-iterative lists cars cdrs) ' // & '(if (null? lists) (cons cars cdrs) ' // & '(let ((car1 (caar lists)) (cdr1 (cdar lists)))' // & '(unzip1-with-cdr-iterative (cdr lists) ' // & ' (append cars (list car1)) (append cdrs (list cdr1))))))' call repl_scheme(3,0) scheme_lin='(define (map proc . lists) (if (null? lists) (apply proc)' // & '(if (null? (car lists)) ' // char(39) // '() ' // & '(let* ((unz (apply unzip1-with-cdr lists)) (cars (car unz)) ' // & '(cdrs (cdr unz))) (cons (apply proc cars) ' // & '(apply map (cons proc cdrs)))))))' call repl_scheme(3,0) scheme_lin='(define (for-each proc list) (if (pair? list) ' // & '(begin (proc (car list)) (for-each proc (cdr list))) #t ))' call repl_scheme(3,0) scheme_lin='(define (atom? x) (not (pair? x)))' call repl_scheme(3,0) scheme_lin='(define (string->list x) (string-split x ""))' call repl_scheme(3,0) scheme_lin='(define (memq obj lst) (cond ((null? lst) #f) ' // & '((eq? obj (car lst)) lst) (else (memq obj (cdr lst)))))' call repl_scheme(3,0) scheme_lin='(define (equal? x y) (if (pair? x) (and (pair? y)' // & '(equal? (car x) (car y)) (equal? (cdr x) (cdr y)))' // & '(and (not (pair? y)) (eqv? x y))))' call repl_scheme(3,0) scheme_lin='(define (unique x) (list-select x (which (unique-indices x))))' call repl_scheme(3,0) scheme_lin='(define (intersect x y) (list-select x (which (intersect-indices x y))))' call repl_scheme(3,0) scheme_lin='(define (setdiff x y) (let ((ux (unique x))) ' // & '(list-select ux (which (setdiff-indices ux y)))))' call repl_scheme(3,0) scheme_lin='(define (union x y) (append (setdiff x y) (unique y)))' call repl_scheme(3,0) scheme_lin='(define (even? x) (if (integer? x) (zero? (remainder x 2))))' call repl_scheme(3,0) scheme_lin='(define (odd? x) (if (integer? x) (= (remainder x 2) 1)))' call repl_scheme(3,0) scheme_lin='(define (gcd2 a b) (let ((aa (abs a)) (bb (abs b)))' // & '(if (zero? bb) aa (gcd2 bb (remainder aa bb)))))' call repl_scheme(3,0) scheme_lin='(define (gcd . args) (if (null? args) 0' // & '(let ((n (length args))) (if (= n 1) (car args)' // & '(let ((res (gcd2 (car args) (cadr args)))) (if (= n 2)' // & 'res (apply gcd (cons res (cddr args)))))))))' call repl_scheme(3,0) scheme_lin='(define (lcm2 a b) (if (or (zero? a) (zero? b)) 0 ' // & '(abs (* (quotient a (gcd2 a b)) b))))' call repl_scheme(3,0) scheme_lin='(define (lcm . args) (if (null? args) 1' // & '(let ((n (length args))) (if (= n 1) (car args)' // & '(let ((res (lcm2 (car args) (cadr args)))) (if (= n 2)' // & 'res (apply lcm (cons res (cddr args)))))))))' call repl_scheme(3,0) scheme_lin='(define (log2 x) (/ (log10 x) (log10 2)))' call repl_scheme(3,0) scheme_lin='(define (generic-member cmp obj lst) (cond ((null? lst) #f)' // & '((cmp obj (car lst)) lst)' // & '(else (generic-member cmp obj (cdr lst)))))' call repl_scheme(3,0) scheme_lin='(define (memq obj lst) (generic-member eq? obj lst))' call repl_scheme(3,0) scheme_lin='(define (memv obj lst) (generic-member eqv? obj lst))' call repl_scheme(3,0) scheme_lin='(define (member obj lst) (generic-member equal? obj lst))' call repl_scheme(3,0) scheme_lin='(define (generic-assoc cmp obj alst)' // & '(cond ((null? alst) #f) ((cmp obj (caar alst))' // & '(car alst)) (else (generic-assoc cmp obj (cdr alst)))))' call repl_scheme(3,0) scheme_lin='(define (assq obj alst) (generic-assoc eq? obj alst))' call repl_scheme(3,0) scheme_lin='(define (assv obj alst) (generic-assoc eqv? obj alst))' call repl_scheme(3,0) scheme_lin='(define (assoc obj alst) (generic-assoc equal? obj alst))' call repl_scheme(3,0) scheme_lin='(define exact? integer?) (define inexact? real?)' call repl_scheme(3,0) scheme_lin='(define (char? c) (if (string? c) (if (= (string-length c) 1) #t #f) #f))' call repl_scheme(3,0) scheme_lin='(define (sample . args) "(sample <list> <n> [''replace])"' // & ' (let ((l (length args))' // & ' (n (length (car args)))) (list-select (car args)' // & ' (sample-seq n (cadr args) (if (> l 2) (caddr args))))))' call repl_scheme(3,0) scheme_lin='(define (filter pred lis) "(filter <test> <list>)"' // & ' (let recur ((lis lis))' // & ' (if (null? lis) lis (let ((head (car lis)) (tail (cdr lis)))' // & ' (if (pred head) (let ((new-tail (recur tail)))' // & ' (if (eq? tail new-tail) lis (cons head new-tail))) (recur tail))))))' call repl_scheme(3,0) #if !(FREESTANDING_SCHEME) scheme_lin='(define (exit) ((pass-command "exit") (quit)))' #else scheme_lin='(define exit quit)' #endif call repl_scheme(3,0) #if !(FREESTANDING_SCHEME) scheme_lin='(define (run cmd) "run a Sib-pair command"' // & ' (begin (pass-command (string-append cmd "; eval resume")) (quit) #t))' #else scheme_lin='(define run system)' #endif call repl_scheme(3,0) scheme_lin='(define-macro quasiquote (lambda (form) (letrec ((qq-cons' // & '(lambda (a b) (cond ((and (pair? a) (eq? ''unquote-splicing (car a)))' // & '(if (and (pair? b) (eq? ''quote (car b)) (null? (cadr b))) (cadr a)' // & '(list ''append (cadr a) b))) (else (list ''cons a b))))) (qq-expand' // & '(lambda (x) (cond ((not (pair? x)) (list ''quote x))' // & ' ((and (eq? ''unquote (car x)) (pair? (cdr x))) (cadr x))' // & ' ((and (eq? ''unquote-splicing (car x)) (pair? (cdr x)))' // & '(list ''unquote-splicing (cadr x))) ((and (eq? ''quasiquote (car x))' // & '(pair? (cdr x))) (error "quasiquote: may not be nested"))' // & '(else (qq-cons (qq-expand (car x)) (qq-expand (cdr x))))))))' // & '(qq-expand form))))' call repl_scheme(3,0) scheme_lin='(define-macro do (lambda (vars test . body)' // & ' (let ((v (map car vars)) (i (map cadr vars))' // & ' (s (map (lambda (x) (if (null? (cddr x)) (car x) (caddr x)))' // & ' vars)) (o (gensym))) `(letrec ((,o (lambda ,v (if ,(car test)' // & '(begin ,@(cdr test)) (begin ,@body (,o ,@s)))))) (,o ,@i)))))' call repl_scheme(3,0) scheme_lin='(define (as-string x) (cond ((number? x) (number->string x))' // & ' ((symbol? x) (symbol->string x)) ((equal? #t x) "#t")' // & ' ((equal? #f x) "#f") (else x)))' call repl_scheme(3,0) scheme_lin='(define PASTE-SEPARATOR " ") (define (paste . x)' // & ' "Convert list[s] to string - flattens sublists [sep PASTE-SEPARATOR]"' // & ' (if (null? x) x (string-append (if (list? (car x))' // & ' (apply paste (car x)) (as-string (car x)))' // & ' (apply string-append (map (lambda (x)' // & ' (string-append PASTE-SEPARATOR (if (list? x) (apply paste x)' // & ' (as-string x)))) (cdr x))))))' call repl_scheme(3,0) scheme_lin='(define (quicksort x) "quicksort list of heterogenous elements"' // & '(define (compare-values a b) (cond ((and (number? a) (number? b))' // & ' (if (< a b) ''less-than (if (> a b) ''greater-than ''equal-to)))' // & ' ((and (string? a) (string? b)) (if (string<? a b) ''less-than' // & ' (if (string>? a b) ''greater-than ''equal-to))) ((and (symbol? a)' // & ' (symbol? b)) (let ((a (symbol->string a)) (b (symbol->string b)))' // & ' (if (string<? a b) ''less-than (if (string>? a b) ''greater-than' // & ' ''equal-to)))) ((and (equal? a #f) (equal? b #f)) ''equal-to)' // & ' ((equal? a #f) ''greater-than) ((equal? b #f) ''less-than)' // & ' ((and (equal? a #t) (equal? b #t)) ''equal-to)' // & ' ((equal? a #t) ''greater-than) ((equal? b #t) ''less-than)' // & ' ((and (list? a) (list? b)) ''equal-to) ((list? a)' // & ' ''greater-than) ((list? b) ''less-than)' // & ' ((symbol? a) ''greater-than) ((symbol? b) ''less-than)' // & ' ((string? a) ''greater-than) ((string? b)' // & ' ''less-than) (else ''greater-than))) (if (or (null? x) (atom? x))' // & ' x (let* ((pivot (car x)) (smaller ''()) (equal ''()) (larger ''())' // & ' (classify (lambda (item) (case (compare-values item pivot)' // & ' ((less-than) (set! smaller (cons item smaller))) ((equal-to)' // & ' (set! equal (cons item equal))) ((greater-than) (set! larger' // & ' (cons item larger))))))) (for-each classify x) (append (quicksort' // & ' smaller compare-values) equal (quicksort larger compare-values)))))' call repl_scheme(3,0) scheme_lin='(define (time x) (let ((t0 (system-clock))) x' // & ' (format "~D us~%" (quotient (- (system-clock) t0) 1000))))' call repl_scheme(3,0) end subroutine init_scm ! ! Initiate procedures ! subroutine init_globals() call system_clock(cpu_t1) call init_vars_global() call init_syntax() call init_procs() ! init global pointers to special symbols lambda=mk_symbol('lambda') quote=mk_symbol('quote') qquote=mk_symbol('quasiquote') unquote=mk_symbol('unquote') unquotesp=mk_symbol('unquote-splicing') feedto=mk_symbol('=>') call init_scm() call hash_env() end subroutine init_globals ! ! Error handling, printing error message ! subroutine error0(s) character (len=*) :: s scm_args=cons(mk_string(s), nil) oper=OP_ERR0 write(*,'(/5a)') ' At: "', scheme_lin(1:currentline), '^', & trim(scheme_lin(currentline+1:eol)) , '"' end subroutine error0 ! ! Error handling, printing error message including variable ! subroutine error1(s, a) integer :: a character (len=*) :: s scm_args=cons(a, nil) scm_args=cons(mk_string(s), scm_args) oper=OP_ERR0 write(*,'(/5a)') ' At: "', scheme_lin(1:currentline), '^', & trim(scheme_lin(currentline+1:eol)) , '"' end subroutine error1 ! ! initialize interpreter - setup memory and globals ! subroutine init_scheme() call setup_mem(100) call setup_scmhash(2) call init_globals() end subroutine init_scheme ! ! Scheme read-eval-print loop ! subroutine repl_scheme(inline, ple) integer, intent(in) :: inline integer, intent(in) :: ple integer :: i, it, op, plevel integer, save :: mlevel = 1 gc_verbosity=ple-1 plevel=max(-1, ple) prompt_string='%% ' if (inline == 1) then mlevel=inline oper = OP_T0LVL currentline=0 scheme_lin=' ' else if (inline == 2) then mlevel=inline oper = OP_T0LVL currentline=0 i=1 do while (lin(i:i) == ' ') i=i+1 end do do while (lin(i:i) /= ' ') i=i+1 end do i=i+1 scheme_lin=lin(i:len_trim(lin)) // ' (quit)' if (ple < -1) plevel=-1 else if (inline == 3 .or. inline == 4) then mlevel=inline plevel=ple-1 oper = OP_T0LVL currentline=0 scheme_lin=trim(scheme_lin) // ' (quit)' else if (ple > 1) then i=len_trim(scheme_lin) write(*,*) 'Resuming at ', currentline, ' of ', eol, ' characters, in' write(*,*) '"', scheme_lin(1:(currentline-1)), '^', & scheme_lin(currentline:i), '"' end if oper=OP_EVAL end if eol=len_trim(scheme_lin) ! do op=oper if (scm_debug > 0) then call mem_browse() end if if (op == OP_ERR0 .or. op == OP_ERR1) then if (mlevel==2) exit mlevel=1 end if if (op == OP_QUIT .or. irupt > 0) then if (inline==1) write(*, '(a)') 'Leaving scheme!' exit else if (op >= OP_LOAD .and. op <= OP_LET2AST) then call opexe0(op, mlevel) else if (op >= OP_LET0REC .and. op <= OP_CONTINUATION) then call opexe1(op) else if (op >= OP_ADD .and. op <= OP_SETCDR) then call opexe2(op) else if (op >= OP_NOT .and. op <= OP_EQV) then call opexe3(op) else if (op >= OP_FORCE .and. op <= OP_NEWSEGMENT) then call opexe4(op, plevel) else if (op >= OP_RDSEXPR .and. op <= OP_P1LIST) then call opexe5(op, plevel) else if (op >= OP_LIST_LENGTH .and. op <= OP_MACROP) then call opexe6(op) else if (op >= OP_EXP .and. op <= OP_EXPT) then call opexe7(op) else if (op >= OP_MIN .and. op <= OP_RANDOM) then call opexe8(op) else if (op >= OP_MKSTRING .and. op <= OP_STR2SYM) then call opexe9(op) else if (op >= OP_SYSTEM .and. op <= OP_DEBUG) then call opexe10(op, plevel) else if (op >= OP_PNORM .and. op <= OP_LOGPNORM) then call opexe11(op) #if !(FREESTANDING_SCHEME) else if (op >= OP_RUNCMD .and. op <= OP_TYPSTAT) then call opexe12(op, plevel) else if (op >= OP_NOBS .and. op <= OP_SETCHOSEN) then call opexe13(op, plevel) #endif else if (op >= OP_LISTTAIL .and. op <= OP_CIRC) then call opexe14(op, plevel) #if JAPI else if (op >= OP_JSTART .and. op <= OP_JSETFLOWLAYOUT) then call opexe15(op) #endif #if EGGX else if (op >= OP_EGGETDISPLAYINFO .and. op <= OP_EGGLINETO) then call opexe16(op) #endif else if (op >= OP_CAAR .and. op <= OP_CDDDDR) then call opexe17(op) else if (op >= OP_DUPS .and. op <= OP_POPCNT) then call opexe18(op) else write(*, '(a)') 'Bad op code! Exiting!' exit end if end do if (inline /= 4) then prompt_string='>> ' else mlevel=1 end if end subroutine repl_scheme end module scheme_lang ! ! Factor type representations for categorical data ! Currently factor labels are recorded in locnotes ! module categorical_data use contingency_table use scheme_lang type cat_data integer :: ncatvars ! number of categorical variables in dataset integer, dimension(:), allocatable :: catvars integer, dimension(:), allocatable :: longest_label type (table_data), dimension(:), allocatable :: cat_tables end type cat_data contains ! subroutine setup_cats(categories, catidx) use automatic_data use locus_types use locus_data type (cat_data) :: categories integer, dimension(:), optional, intent(in) :: catidx integer :: i, ncatvars integer, dimension(nloci) :: idx if (present(catidx)) then ncatvars=size(catidx) else ncatvars=0 do i=ENVNUM+1, nloci if (iscattrait(loctyp(i))) then ncatvars=ncatvars+1 idx(ncatvars)=i end if end do end if categories%ncatvars=ncatvars if (ncatvars /= 0) then allocate(categories%catvars(ncatvars)) allocate(categories%longest_label(ncatvars)) allocate(categories%cat_tables(ncatvars)) if (present(catidx)) then categories%catvars(1:ncatvars)=catidx(1:ncatvars) else categories%catvars(1:ncatvars)=idx(1:ncatvars) end if do i=1, ncatvars call setup_table(1, 20, categories%cat_tables(i)) call set_table_colname(1, loc(categories%catvars(i)), & categories%cat_tables(i)) categories%longest_label(i)=0 end do end if end subroutine setup_cats ! subroutine clean_cats(categories) type (cat_data) :: categories do i=1, categories%ncatvars call clean_table(categories%cat_tables(i)) end do if (allocated(categories%catvars)) deallocate(categories%catvars) if (allocated(categories%longest_label)) deallocate(categories%longest_label) categories%ncatvars=0 end subroutine clean_cats ! ! recode levels so they match collation order of labels ! subroutine relevel_cats(categories, dataset) use scheme_lang use locus_data use ped_class type (cat_data) :: categories type (ped_data) :: dataset integer :: i, idx logical :: allinteger ! levels are already integers type (table_cell) :: annotation do i=1, categories%ncatvars call sort_table(categories%cat_tables(i)) !!!! call print_table(categories%cat_tables(i)) idx=categories%catvars(i) call reorder_cat(categories%cat_tables(i), locpos(idx), dataset, allinteger) call copystring('', annotation) call copystring(get_notes(loc(idx), locnotes(idx)), annotation) if (.not.allinteger .or. annotation%slength == 0) then call annotate_cat(categories%cat_tables(i), annotation, allinteger) end if if (annotation_width > table_cell_len_trim(annotation)) then call get_table_cell(annotation, string=locnotes(idx)) else call add_scheme_annotation(loc(idx), cell=annotation) end if end do end subroutine relevel_cats ! subroutine reorder_cat(table, trait, dataset, allinteger) use ped_class type (table_data) :: table integer, intent(in) :: trait type (ped_data) :: dataset logical, intent(out) :: allinteger integer, parameter :: MISS = -9999 integer, dimension(:), allocatable :: idx integer :: i, j, pos allocate(idx(table%ncells)) idx=0 allinteger = .true. do i=1, table%ncells if (.not.table_cell_string_int(table%categories(i,1))) then allinteger = .false. exit end if end do if (allinteger) then do i=1, table%ncells call get_table_cell(table%categories(i,1), ivalue=idx(i)) end do else do i=1, table%ncells idx(table%idx(i))=i end do end if do i=1, dataset%nobs if (dataset%plocus(i,trait) /= MISS) then pos=int(dataset%plocus(i,trait)) dataset%plocus(i,trait)=dble(idx(pos)) end if end do deallocate(idx) call sort_table(table) end subroutine reorder_cat ! ! List levels of categorical trait for annotation ! subroutine append_annotation(cell, annotation, spaces) type (table_cell), intent(in) :: cell type (table_cell) :: annotation integer, optional :: spaces integer :: j, newlen, pos, sta, slen character, dimension(:), allocatable :: tstring if (cell%slength < 1) return slen=annotation%slength sta=table_cell_len_trim(annotation) if (sta == 0) then sta=1 else if (present(spaces)) then sta=min(sta+spaces, slen) end if if (cell%slength+sta > slen) then newlen=cell%slength+sta allocate(character(len=1) :: tstring(annotation%slength)) tstring=annotation%svalue deallocate(annotation%svalue) allocate(character(len=1) :: annotation%svalue(newlen)) annotation%svalue(1:annotation%slength)=tstring do i=annotation%slength+1, newlen annotation%svalue(i)=' ' end do annotation%slength=newlen deallocate(tstring) end if annotation%svalue((sta+1):annotation%slength)=cell%svalue end subroutine append_annotation ! subroutine annotate_cat(table, annotation, allinteger) type (table_data) :: table type (table_cell) :: annotation logical, intent(in) :: allinteger integer :: i, pos character (len=10) :: lev if (allinteger) then do i=1, table%ncells pos=table%idx(i) call append_annotation(table%categories(pos,1), annotation, spaces=1) call appendstring('="', annotation) call append_annotation(table%categories(pos,1), annotation) call appendstring('" ', annotation) end do else do i=1, table%ncells pos=table%idx(i) write(lev, '(i10)') i call appendstring(' ' // trim(adjustl(lev)), annotation) call appendstring('="', annotation) call append_annotation(table%categories(pos,1), annotation) call appendstring('" ', annotation) end do end if end subroutine annotate_cat ! subroutine add_scheme_annotation(loc, string, cell) use iobuff use string_utilities ! use scheme_lang character(len=*), intent(in) :: loc character(len=*), optional, intent(in) :: string type (table_cell), optional, intent(in) :: cell integer :: ifail if (present(cell)) then scheme_lin='(define labels_' // loc // ' "")' call repl_scheme(3,0) call append_string_var('labels_' // trim(loc), cell=cell) else scheme_lin=string call escape(scheme_lin, '"', ifail=ifail) if (ifail == 0) then scheme_lin=' (define labels_' // loc // ' "' // trim(scheme_lin) // '")' call repl_scheme(3,0) end if end if end subroutine add_scheme_annotation ! ! Extract existing level-label pairs from annotation ! subroutine extract_cat(annotation, cat_table, longest) use keyval character(len=*) :: annotation type (table_data) :: cat_table integer, intent(out) :: longest call extract_kv(annotation, cat_table, longest) end subroutine extract_cat ! ! read categorical trait levels recorded in annotations back into tables ! subroutine load_cat_levels(ncatvars, catidx, categories, longest) use locus_types use locus_data ! use scanner use scheme_lang integer, intent(in) :: ncatvars integer, dimension(ncatvars), intent(in) :: catidx type (cat_data) :: categories integer, intent(out), optional :: longest integer :: i, icat, j, k, nchar, pos character (len=40) :: cval character (len=:), allocatable :: cbuff categories%ncatvars=0 if (ncatvars > 0) then categories%ncatvars=ncatvars allocate(categories%catvars(ncatvars)) allocate(categories%cat_tables(ncatvars)) allocate(categories%longest_label(ncatvars)) categories%catvars=catidx do j=1, ncatvars i=catidx(j) istat=-1 call get_string_var('labels_' // trim(loc(i)), length=nchar, istat=istat) if (istat == 0) then allocate(character(len=nchar) :: cbuff) call get_string_var('labels_' // trim(loc(i)), string=cbuff, istat=istat) if (cbuff == ' ') istat = -1 end if if (istat == -1) then if (allocated(cbuff)) deallocate(cbuff) nchar=len_trim(locnotes(i)) allocate(character(len=nchar) :: cbuff) cbuff=trim(locnotes(i)) end if call extract_cat(cbuff, categories%cat_tables(j), & categories%longest_label(j)) if (allocated(cbuff)) deallocate(cbuff) end do end if end subroutine load_cat_levels ! ! Extract matching category level from locus annotation, ! adding category label with a new largest level if not present ! subroutine get_whichcat(word, trait, val) use scanner use scheme_lang use locus_types use locus_data character (len=*), intent(in) :: word integer, intent(in) :: trait double precision, intent(out) :: val integer, parameter :: MISS=-9999 type (table_data) :: cat_table integer :: fin, istat, j, longest, maxcat, nchar, sta character (len=40) :: cval character (len=:), allocatable :: cbuff ! functions logical :: isint double precision :: fval val=MISS if (isint(word)) then val=fval(word) return end if istat=-1 call get_string_var('labels_' // trim(loc(trait)), length=nchar, istat=istat) if (istat == 0) then allocate(character(len=nchar) :: cbuff) call get_string_var('labels_' // trim(loc(trait)), string=cbuff, istat=istat) if (cbuff == ' ') istat = -1 end if if (istat == -1) then nchar=len_trim(locnotes(trait)) allocate(character(len=nchar) :: cbuff) cbuff=trim(locnotes(trait)) end if call getpairval(word, cbuff, opsimple, cval, forward=.false.) if (cval /= ' ') then val=fval(cval) else maxcat=MISS call extract_cat(cbuff, cat_table, longest) if (cat_table%ncells > 0) then call get_table_cell(cat_table%categories(cat_table%ncells,1), ivalue=maxcat) end if if (maxcat == MISS) then ival=1 else ival=maxcat+1 end if val=real(ival, kind=8) write(cval, '(i40)') ival cbuff=trim(cbuff) // ' ' // trim(adjustl(cval)) // '="' // trim(word) // '"' if (len_trim(cbuff) <= len(locnotes(trait))) then locnotes(trait)=cbuff else call add_scheme_annotation(loc(trait), string=trim(cbuff)) end if end if end subroutine get_whichcat ! ! Get matching label from table of key-value pairs ! subroutine get_label_tab(val, cat_table, str) double precision, intent(in) :: val type (table_data) :: cat_table character (len=*), intent(out) :: str type (table_cell) :: labellev integer :: ndec, slen, pos character (len=10) :: fstring str=' ' call set_table_cell(labellev, ivalue=int(val)) pos=search_table_key(labellev, cat_table) if (pos > 0) then call get_table_cell(cat_table%categories(pos,2), string=str) end if end subroutine get_label_tab end module categorical_data ! ! Simple regression formula structure and parser ! ! formula and design matrix ! formula is: a b c a*b a*c b*c a*b*c ! T1 1 2 3 1 1 2 1 ! T2 . . . 2 3 3 2 ! T3 . . . . . . 3 ! TERMDIM 1 1 1 2 2 2 3 ! ! Effects 1 2 3 ! NLEV n1 n2 n3 ! STA 1 n1+1 n1+n2+1 ! FIN n1 n1+n2 n1+n2+n3 ! INFORM 1 1 1 ! module formula_class type formula_data logical :: intercept ! add an intercept term integer :: nterms ! number of model terms integer :: maxlev ! maximum number of effects in an interaction integer :: neff ! number of main effects integer :: mainlen ! number of main effects columns integer :: maxrows ! maximum rows in design matrix integer, dimension(:), allocatable :: effects ! included effects integer, dimension(:), allocatable :: nlev ! no. levels of each effect integer, dimension(:), allocatable :: nrows ! full levels of each effect (eg genotypes v. alleles) integer, dimension(:), allocatable :: inform ! if/how included in model formula integer, dimension(:), allocatable :: sta ! start of effect in main effects design matrix integer, dimension(:), allocatable :: fin ! end of effect in main effects design matrix integer, dimension(:,:), allocatable :: termlist ! matrix storing term components integer, dimension(:), allocatable :: termdim ! interaction order integer, dimension(:), allocatable :: termlev ! no. levels of each interaction term integer :: designcols ! total number of design matrix columns end type formula_data contains ! ! expand symbolic formulas involving brackets, exponentiation ! subroutine expand_form(sta, fin, terms, ios) use outstream use combinatorics integer :: sta, fin character (len=*), dimension(:), intent(inout) :: terms integer, intent(out) :: ios character (len=1), parameter :: lbrack = '(', rbrack = ')', & cross = '*', expt = '^' character (len=40) :: wterm integer :: bter, nel, nl, lpos, nter, lev, pos, rpos integer :: expand, j, jj, k, kk, lb, ncr, newlb, newrb, numer, rb integer :: ix, iy, iz integer, dimension(:), allocatable :: idx, iw logical :: done ! integer :: ival i=sta do if (terms(i) == '+') then do j=i, fin terms(j)=terms(j+1) end do fin=fin-1 end if i=i+1 if (i > fin) exit end do ! write(outstr,'(a)', advance='no') trim(terms(sta)) ! do i=sta+1, fin ! write(outstr,'(1x,a)', advance='no') trim(terms(i)) ! end do write(outstr,*) nter=size(terms) ios=0 lpos=0 rpos=0 pos=sta do while (pos <= fin) call find_brackets(pos, fin, terms, lb, rb, ios) ! write(outstr,*) 'sta=', sta, ' fin=', fin, ' pos=', pos, ' ios=', ios ! write(outstr,'(a)', advance='no') trim(terms(sta)) ! do i=sta+1, fin ! write(outstr,'(1x,a)', advance='no') trim(terms(i)) ! end do ! write(outstr,*) if (ios <= 0) exit done=.false. if (rb == fin) then done=.true. else if (terms(rb+1) /= expt .and. terms(rb+1) /= cross) then if (lb > 1) then if (terms(lb-1) /= cross) done=.true. else done=.true. end if end if if (done) then do i=lb+1, rb-1 terms(i-1)=terms(i) end do do i=rb+1, fin terms(i-2)=terms(i) end do fin=fin-2 if (ios == 1) ios=0 pos=sta cycle end if nel=rb-lb-1 if (nel < 1) then ios=-2 exit end if pos=rb+1 ! exponentiation if (terms(pos) == expt) then pos=pos+1 if (pos > fin) then ios=-2 exit end if lev=ival(terms(pos)) if (lev < 1) lev=1 if (lev > nel) lev=nel ! expanded interaction terms bter=0 do i=1, lev ncr=nel numer=nel-1 do j=2, i ncr=ncr*numer/j numer=numer-1 end do bter=bter+ncr*(2*i-1) end do ! newrb=lb+bter+1 expand=bter-nel-2 if (fin+expand > nter) then write(outstr,'(a,i0,a)') & 'ERROR: Expanded formula exceeds ', nter, '!' ios=-3 exit end if do i=fin, rb+3, -1 terms(expand+i)=terms(i) end do fin=fin+expand nmax2=nel+2 allocate(idx(nel), iw(nmax2)) pos=lb+nel do k=2, lev m=nel-k do j=1, nel idx(j)=nel-j+1 end do iw(1)=nel+1 iw(nel+2)=-2 kk=m+1 do j=2, kk iw(j)=0 end do do j=1, k jj=kk+j iw(jj)=j end do done=.false. comb: do pos=pos+1 terms(pos)=trim(terms(lb+idx(1))) do j=2, k pos=pos+1 terms(pos)='*' pos=pos+1 terms(pos)=terms(lb+idx(j)) end do call twidl(ix,iy,iz,done,iw,nmax2) if (done) exit comb do j=1, k if (idx(j)==iy) then idx(j)=ix exit end if end do end do comb end do deallocate(idx, iw) pos=pos+1 terms(pos)=rbrack pos=sta else if (terms(pos) == cross) then if (terms(pos+1) /= expt .and. & terms(pos+1) /= lbrack .and. & terms(pos+1) /= rbrack) then bter=3*nel newrb=lb+bter+1 expand=bter-nel-2 ! write(*,*) 'nel=', nel, ' bter=', bter, ' lb=', lb, ' newrb=', lb+bter+1, ' expand=', expand if (fin+expand > nter) then write(outstr,'(a,i0,a)') & 'ERROR: Expanded formula exceeds ', nter, '!' ios=-3 exit end if do i=fin, rb+3, -1 terms(expand+i)=terms(i) end do fin=fin+expand wterm=terms(rb+2) ! write(*,*) 'newrb=', newrb, ' fin=', fin, ' lb=', lb terms(newrb)=rbrack j=lb+nel do i=newrb-1, lb+1, -3 terms(i)=wterm terms(i-1)=cross terms(i-2)=terms(j) j=j-1 end do pos=sta end if else if (lb > (sta+2)) then if (terms(lb-1) == cross .and. & terms(lb-2) /= expt .and. & terms(lb-2) /= lbrack .and. & terms(lb-2) /= rbrack) then bter=3*nel newlb=lb-2 newrb=newlb+bter+1 expand=bter-nel-2 ! write(*,*) 'nel=', nel, ' bter=', bter, ' lb=', lb, ' newrb=', lb+bter+1, ' expand=', expand if (fin+expand > nter) then write(outstr,'(a,i0,a)') & 'ERROR: Expanded formula exceeds ', nter, '!' ios=-3 exit end if do i=fin, rb+1, -1 terms(expand+i)=terms(i) end do fin=fin+expand wterm=terms(newlb) ! write(*,*) 'newrb=', newrb, ' fin=', fin, ' lb=', lb terms(newlb)=lbrack terms(newrb)=rbrack j=lb+1 do i=newlb+1, rb-2, -3 terms(i)=wterm terms(i+1)=cross terms(i+2)=terms(j) j=j+1 end do pos=sta end if end if end do end subroutine expand_form ! subroutine find_brackets(sta, fin, terms, lb, rb, ios) use outstream integer :: sta, fin character (len=*), dimension(:), intent(in) :: terms integer, intent(out) :: lb, rb integer, intent(out) :: ios character (len=1), parameter :: lbrack = '(', rbrack = ')' integer :: nl, pos lb=0 rb=0 ios=0 pos=sta nl=0 do while (pos <= fin) if (terms(pos) == lbrack) then lb=pos nl=nl+1 ios=ios+1 end if if (terms(pos) == rbrack) then if (nl == 0) then write(outstr,'(a)') 'ERROR: Unmatched R bracket!' ios=-1 return end if rb=pos exit end if pos=pos+1 end do end subroutine find_brackets ! ! read commands and write appropriate formula structure ! subroutine create_form(sta, fin, terms, nloci, loc, lochash, formula) use outstream use lochash_class use sorts integer :: sta, fin character (len=*), dimension(:), intent(in) :: terms integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc type (hash_table) :: lochash type (formula_data) :: formula integer, dimension(fin-sta+1) :: tmpeff integer, dimension(:), allocatable :: fkey, fidx integer :: fpos, i, lev, locnum, pos, prev logical :: fnd, interact character (len=1) :: cross = '*', minus = '-', plus = '+' integer :: ifail ifail=0 formula%intercept=.true. formula%nterms=0 formula%maxrows=0 formula%maxlev=1 formula%neff=0 formula%designcols=0 interact=.false. lev=1 prev=0 pos=sta ! prev=0 between terms ! prev=1 reading an interaction (prev symbol = *) ! prev=2 read a variable name do while (pos <= fin) if (terms(pos) == cross) then if (prev == 2) then lev=lev+1 interact=.true. if (lev > formula%maxlev) formula%maxlev=lev prev=1 else ifail=-1 write(outstr,'(3a)') & 'ERROR: In model formula "*" requires two arguments.' end if else if (terms(pos) == plus) then prev=0 else if (terms(pos) == minus) then if (pos < fin) then if (terms(pos+1) == '1') then pos=pos+1 else ifail=-2 write(outstr,'(3a)') & 'ERROR: In model formula "-', trim(terms(pos+1)), '" not allowed.' end if end if prev=0 else call find_hashtab(trim(terms(pos)(1:loc_width)), loc, lochash, locnum) if (locnum /= 0) then fnd=.false. do i=1, formula%neff if (locnum == tmpeff(i)) then fnd=.true. exit end if end do if (.not.fnd) then formula%neff=formula%neff+1 tmpeff(formula%neff)=locnum end if if (interact) then prev=2 interact=.false. else formula%nterms=formula%nterms+1 prev=2 lev=1 end if else ifail=-3 write(outstr,'(3a)') & 'ERROR: In model formula "', trim(terms(pos)), '" is not a locus.' end if end if pos=pos+1 end do if (ifail /= 0) then formula%nterms=0 return end if allocate(formula%effects(formula%neff)) allocate(formula%nlev(formula%neff)) allocate(formula%nrows(formula%neff)) allocate(formula%inform(formula%neff)) allocate(formula%sta(formula%neff)) allocate(formula%fin(formula%neff)) allocate(formula%termlist(formula%nterms, formula%maxlev)) allocate(formula%termdim(formula%nterms)) allocate(formula%termlev(formula%nterms)) allocate(fkey(formula%nterms), fidx(formula%nterms)) formula%effects=tmpeff(1:formula%neff) formula%mainlen=0 formula%nlev=0 formula%nrows=0 formula%inform=0 formula%sta=0 formula%fin=0 formula%termlist=0 formula%termdim=0 formula%termlev=0 fpos=0 interact=.false. prev=0 pos=sta do while (pos <= fin) if (terms(pos)==cross) then if (prev == 2) then formula%termdim(fpos)=formula%termdim(fpos)+1 interact=.true. prev=1 end if else if (terms(pos)==plus) then prev=0 else if (terms(pos)==minus) then if (pos < fin) then if (terms(pos+1) == '1') then formula%intercept=.false. pos=pos+1 end if end if prev=0 else call find_hashtab(trim(terms(pos)(1:loc_width)), loc, lochash, locnum) if (locnum /= 0) then if (prev /= 1) then prev=2 fpos=fpos+1 formula%termdim(fpos)=1 end if do i=1, formula%neff if (locnum == formula%effects(i)) then formula%termlist(fpos,formula%termdim(fpos))=i exit end if end do prev=2 if (interact) then interact=.false. end if end if end if pos=pos+1 end do do fpos=1, formula%nterms if (formula%termdim(fpos)==1) then formula%inform(formula%termlist(fpos,1))=1 end if end do ! sort model terms do fpos=1, formula%nterms call isort(1, formula%termdim(fpos), & formula%termlist(fpos,1:formula%termdim(fpos)), tmpeff, 1) fkey(fpos)=formula%termlist(fpos,1) fidx(fpos)=fpos do i=2, formula%maxlev ! write(*,*) formula%neff, formula%neff**(i-1), formula%termlist(fpos,i) fkey(fpos)=fkey(fpos)+ formula%neff**(i-1) * formula%termlist(fpos,i) end do end do ! write(*,*) fidx ! write(*,*) fkey ! call isort(1, formula%nterms, fkey, fidx, 2) ! write(*,*) 'sorted:' ! write(*,*) fidx ! write(*,*) fkey end subroutine create_form ! subroutine cleanup_form(formula) type (formula_data) :: formula formula%intercept=.false. formula%nterms=0 formula%maxlev=0 formula%neff=0 formula%mainlen=0 formula%maxrows=0 formula%designcols=0 deallocate(formula%effects, formula%nlev, formula%nrows, formula%sta, formula%fin) deallocate(formula%termlist, formula%termdim, formula%termlev) end subroutine cleanup_form ! ! If levels available, evaluate total number of model parameters ! subroutine sumcols_form(formula) type (formula_data) :: formula integer :: i, j, df, hasmain, lpos, off, pos logical :: anymain, firstterm off=0 if (formula%intercept) off=-1 formula%designcols=0 formula%designcols=formula%designcols-off formula%maxrows=1 pos=0 do i=1, formula%neff formula%sta(i)=pos+1 formula%fin(i)=pos+formula%nlev(i) formula%mainlen=formula%mainlen+formula%nlev(i) formula%maxrows=formula%maxrows*formula%nrows(i) pos=pos+formula%nlev(i) end do do i=1, formula%nterms firstterm=.false. anymain=.false. df=1 do j=1, formula%termdim(i) lpos=formula%termlist(i,j) if (formula%nlev(lpos) > 0) then hasmain=0 if (formula%inform(lpos)==1) then anymain=.true. hasmain=1 if (.not.firstterm) then firstterm=.true. if (.not.formula%intercept) hasmain=hasmain-1 end if end if df=df*(formula%nlev(lpos)-hasmain) end if end do if (.not.anymain) df=df+off formula%termlev(i)=df formula%designcols=formula%designcols+df end do end subroutine sumcols_form ! subroutine show_form(formula) type (formula_data) :: formula integer :: i write(*,*) 'Intercept : ', formula%intercept write(*,*) 'Nterms : ', formula%nterms write(*,*) 'Maxlev : ', formula%maxlev write(*,*) 'Neff : ', formula%neff write(*,*) 'Mainlen : ', formula%mainlen write(*,*) 'Maxrows : ', formula%maxrows write(*,*) 'DesignCols: ', formula%designcols write(*,*) 'Effects : ', formula%effects write(*,*) 'Nlev : ', formula%nlev write(*,*) 'Nrows : ', formula%nrows write(*,*) 'Sta : ', formula%sta write(*,*) 'Fin : ', formula%fin write(*,*) 'InFormula : ', formula%inform write(*,*) 'Termlist : ', formula%termlist(1:formula%nterms,1) do i=2, formula%maxlev write(*,*) ' ', formula%termlist(1:formula%nterms,i) end do write(*,*) 'Termdim : ', formula%termdim write(*,*) 'Termlev : ', formula%termlev end subroutine show_form subroutine test_form(sta, fin, terms, nloci, loc, lochash) use outstream use lochash_class integer :: sta, fin character (len=*), dimension(:) :: terms integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc type (hash_table) :: lochash type (formula_data) :: formula integer :: endarg, ifail endarg=fin call expand_form(sta, endarg, terms, ifail) if (ifail /= 0) then write(outstr,'(a,i0)') 'ERROR: Badly formed formula ifail=', ifail end if call create_form(sta, endarg, terms, nloci, loc, lochash, formula) if (formula%nterms == 0) then write(outstr,'(a)') 'ERROR: No usable terms in formula.' else call show_form(formula) end if end subroutine test_form end module formula_class ! ! GLM model types ! module glm_types integer, parameter :: GLM_GAUSS=1, GLM_BINOM=2, GLM_POISS=3, GLM_WEIB=4, GLM_EXPON=5, & GLM_EVD=6, GLM_GAMMA=7 integer, parameter :: LINK_UNSPEC=0, LINK_ID=1, LINK_LOGIT=2, & LINK_PROBIT=3, LINK_MFT=4, LINK_LOG=5 ! GLMs character (len=8) :: densid(7) = (/ 'Gaussian', 'Binomial', 'Poisson ', & 'Weibull ', 'Expntial', 'EVD ', & 'Gamma ' /) character (len=8) :: linkid(5) = (/ 'Identity', 'Logit ', 'Probit ', & 'MFT ', 'Log '/) end module glm_types ! ! Mixed model analysis parameters ! ! linkf=link function 1=identity 2=logit 3=probit 4=MFT 5=log ! modtyp=likelihood family (1=gaussian, 2=binomial, 3=poisson) ! nqtl=trait loci in model ! nfix=number of fixed effects ! MAXPAR=maximum number of segregation model parameters ! RANPAR=number of random effects model parameters ! Model parameters ! model pars 1=P(all) 2=a 3=d 4=AA 5=AB 6=BB ! 7=mu 8=totvar 9=VA 10=VD 11=VG 12=VC 13=VS 14=VE ! 15=sdG 16=sdC 17=sdM 18=sdE ! 19=a2 20=d2 21=h2 22=c2 23=m2 24=e2 ! 25..MAXPAR=Betas ! Random Effects: ! QTL: ! 1=P(all) 2=a 3=d ! 4=muAA 5=muAB 6=muBB ! 7=mu 8=totvar 9=VA 10=VD ! Polygenes: ! 11=VG 14=sdG ! Familial environment ! 12=VC 15=sdC ! Maternal/sibship effect ! 13=VS 17=sdS ! Error ! 14=VE 18=sdE ! Proportions of variance ! 19=a2 20=d2 21=h2 22=c2 23=s2 24=e2 ! Fixed Effects: ! 25...MAXPAR ! ! parnam = parameter name ! paract = status ! 0=excluded ! 1=estimated ! 2=fixed ! 3=function of estimated parameter ! par = parameter estimate ! parscal = scale size for MCMC proposal distribution ! (usually approx standard error) ! module mcmc_model use idstring_widths use glm_types integer, parameter :: MAXPAR=50 integer, parameter :: RANPAR=24 integer, parameter :: MISS=-9999 integer, parameter :: OLD=1, NEW=2 integer, parameter :: MAXPEN=3 integer, parameter :: SLMAX=10 double precision, parameter :: BADLIK=-1.0D99 ! integer, parameter :: P_EXCL=0, P_FREE=1, P_FIX=2, P_DERIV=3 ! list of active random and fixed effects integer :: nterms integer, dimension(MAXPAR) :: terms ! Segregation model parameter names integer, parameter :: PTYP_pa = 1, PTYP_a = 2, PTYP_d = 3, & PTYP_AA = 4, PTYP_AB = 5, PTYP_BB = 6, PTYP_mu = 7, PTYP_VT = 8, & PTYP_VA = 9, PTYP_VD = 10, & PTYP_VG = 11, PTYP_VC = 12, PTYP_VS = 13, PTYP_VE = 14, & PTYP_sdG = 15, PTYP_sdC = 16, PTYP_sdS = 17, PTYP_sdE = 18, & PTYP_a2 = 19, PTYP_d2 = 20, & PTYP_h2 = 21, PTYP_c2 = 22, PTYP_s2 = 23, PTYP_e2 = 24 character (len=14) :: parnam(MAXPAR) = (/ & 'pA ', 'a ', 'd ', & 'AA ', 'AB ', 'BB ', & 'mu ', 'VT ', 'VA ', & 'VD ', 'VG ', 'VC ', & 'VS ', 'VE ', 'sdG ', & 'sdC ', 'sdS ', 'sdE ', & 'a2 ', 'd2 ', 'h2 ', & 'c2 ', 's2 ', 'e2 ', & ' ', ' ', ' ', & ' ', ' ', ' ', & ' ', ' ', ' ', & ' ', ' ', ' ', & ' ', ' ', ' ', & ' ', ' ', ' ', & ' ', ' ', ' ', & ' ', ' ', ' ', & ' ', ' ' /) integer :: paract(MAXPAR) double precision, dimension(MAXPAR) :: par, parscal double precision, dimension(MAXPAR) :: blpar, bupar, epar, sdpar integer :: gprop, grate integer, dimension(MAXPAR) :: proprate, proptyp double precision, dimension(MAXPAR) :: covbat1, batchse ! Mean parameter estimates for batch -- MAXPAR+3 x nbatch double precision, dimension(:,:), allocatable :: batch ! MCMC proposal types character (len=1) :: algid(2) = (/'S','M'/) ! ! Proposal arrays ! integer :: nchanges integer, dimension(:), allocatable :: changes integer :: nsim integer, dimension(:), allocatable :: sim ! QTL genotype proposals integer, dimension(:,:), allocatable :: set ! familial/breeding/maternal effect value proposals double precision :: newfmu double precision, dimension(:), allocatable :: newbval, newmval ! ! one pedigree's worth of observed and imputed data ! data for multiple MCMC chains may be present ! type mixed_data integer :: iped ! pedigree index in dataset integer:: num, nfound ! number of pedigree members and founders integer :: nchain ! number of MCMC chains being run integer :: nqtl ! number of QTLs integer :: nvar ! number of covariates incl dummy coding ! Family likelihood -- nchain values double precision, dimension(:), allocatable :: famlik ! Genotypic contribution to likelihood -- nchain values double precision, dimension(:), allocatable :: gtplik ! individual level data -- id pointer to dataset%id ! locally pointing parental indicator integer, dimension(:), allocatable :: pid integer, dimension(:), allocatable :: fa integer, dimension(:), allocatable :: mo integer, dimension(:), allocatable :: imztwin ! observed trait and covariate values double precision, dimension(:), allocatable :: yval double precision, dimension(:,:), allocatable :: vals ! segregation standard deviation double precision, dimension(:), allocatable :: rsd ! breeding value -- num x nchain double precision, dimension(:,:), allocatable :: bval double precision, dimension(:), allocatable :: blup ! maternal effect -- num x nchain double precision, dimension(:,:), allocatable :: mval ! QTL genotypes -- num x nchain x nqtl x 2 integer, dimension(:,:,:,:), allocatable :: hset ! pedigree effect -- nchain double precision, dimension(:), allocatable :: fammu end type mixed_data contains ! ! Allocate or deallocate work arrays ! subroutine setup_props(maxsiz) integer :: maxsiz allocate(changes(maxsiz), sim(maxsiz), set(maxsiz,2)) allocate(newbval(maxsiz), newmval(maxsiz)) end subroutine setup_props subroutine clean_props() deallocate(changes, sim, set, newbval, newmval) end subroutine clean_props ! ! Allocate a pedigree's data arrays ! subroutine setup_mix(ped, dataset, nchain, nqtl, nvar, family) use ped_class integer :: ped, nchain, nqtl, nvar type (ped_data) :: dataset type (mixed_data) :: family integer, parameter :: MISS = -9999 integer :: i, ii, num, pedoffset pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset family%iped = ped ! pedigree index in dataset family%num = num ! number of pedigree members family%nfound = dataset%nfound(ped) ! number of pedigree founders family%nchain = nchain ! number of MCMC chains being run family%nqtl = nqtl ! number of QTLs family%nvar = nvar ! number of covariates incl dummy codings allocate(family%famlik(nchain)) ! likelihood for family allocate(family%gtplik(nchain)) ! likelihood contribution due genotypes ! allocate(family%pid(num)) ! points to dataset%id allocate(family%fa(num)) ! points to fathers family%pid allocate(family%mo(num)) ! points to mothers family%pid allocate(family%imztwin(num)) ! points to MZ twin's family%pid allocate(family%yval(num)) ! yvariable (may be transformed) allocate(family%rsd(num)) ! segregation error allocate(family%vals(num, nvar)) ! covariates incl dummy coding ! allocate(family%blup(num)) ! expected breeding value allocate(family%bval(num, nchain)) ! breeding values allocate(family%mval(num, nchain)) ! maternal effect allocate(family%hset(num, nchain, nqtl, 2)) ! QTL genotypes allocate(family%fammu(nchain)) ! pedigree effect ii=pedoffset do i=1, dataset%nfound(ped) ii=ii+1 family%pid(i)=ii family%fa(i)=MISS family%mo(i)=MISS family%imztwin(i)=MISS end do do i=dataset%nfound(ped)+1, num ii=ii+1 family%pid(i)=ii family%fa(i)=dataset%fa(ii)-pedoffset family%mo(i)=dataset%mo(ii)-pedoffset family%imztwin(i)=MISS if (dataset%imztwin(ii) /= MISS) then family%imztwin(i)=dataset%imztwin(ii)-pedoffset end if end do family%blup(1:num)=0.0d0 family%bval(1:num, 1:nchain)=0.0d0 family%mval(1:num, 1:nchain)=0.0d0 family%fammu(1:nchain)=0.0d0 family%famlik(1:nchain)=-1.0D99 family%gtplik(1:nchain)=-1.0D99 end subroutine setup_mix end module mcmc_model ! ! expandable ordered list of (unique) pairs of integers ! new entries are either inserted ! or appended after comparison to most recent addition ! ! npairs=#pairs ! pairs=set of pairs ! module pairlist_class type pairlist_data integer :: npairs ! number of pairs integer, dimension(:,:), allocatable :: pairs end type pairlist_data contains ! ! allocate space for pairlist ! subroutine setup_pairs(npairs, pairlist) integer :: npairs type (pairlist_data) :: pairlist pairlist%npairs = 0 if (allocated(pairlist%pairs)) then deallocate(pairlist%pairs) end if allocate(pairlist%pairs(0:max(10,npairs),2)) pairlist%pairs(0,1)=0 pairlist%pairs(0,2)=0 end subroutine setup_pairs ! ! deallocate space ! subroutine clean_pairs(pairlist) type (pairlist_data) :: pairlist pairlist%npairs = 0 if (allocated(pairlist%pairs)) then deallocate(pairlist%pairs) end if end subroutine clean_pairs ! ! increase available space ! subroutine expand_pairs(nextra, pairlist) integer :: nextra type (pairlist_data) :: pairlist type (pairlist_data) :: pairlist2 integer :: np, oldsiz np = pairlist%npairs oldsiz = size(pairlist%pairs,1)+1 call setup_pairs(oldsiz, pairlist2) pairlist2%npairs = np pairlist2%pairs(1:np,1:2) = pairlist%pairs(1:np,1:2) call clean_pairs(pairlist) call setup_pairs(oldsiz+nextra, pairlist) pairlist%npairs = pairlist2%npairs pairlist%pairs(1:np,1:2) = pairlist2%pairs(1:np,1:2) call clean_pairs(pairlist2) end subroutine expand_pairs ! ! append data, testing only latest entry for uniqueness ! subroutine append_pair(key1, key2, pairlist) integer, intent(in) :: key1, key2 type (pairlist_data) :: pairlist if (pairlist%pairs(pairlist%npairs,1) /= key1 .or. & pairlist%pairs(pairlist%npairs,2) /= key2) then ! if not enough room, expand pairlist if (pairlist%npairs == size(pairlist%pairs, 1)) then call expand_pairs(10, pairlist) end if pairlist%npairs=pairlist%npairs+1 pairlist%pairs(pairlist%npairs,1)=key1 pairlist%pairs(pairlist%npairs,2)=key2 end if end subroutine append_pair ! ! insert data ! subroutine insert_pair(key1, key2, pairlist) integer, intent(in) :: key1, key2 type (pairlist_data) :: pairlist ! local variables integer :: hi, i, k, lo, pos integer, dimension(2) :: key key(1)=key1 key(2)=key2 hi=pairlist%npairs lo=1 pos=lo search: do while (hi >= lo) pos=lo+(hi-lo)/2 ! test if higher do i=1, 2 if (key(i) > pairlist%pairs(pos,i)) then lo=pos+1 cycle search else if (key(i) < pairlist%pairs(pos,i)) then exit end if end do ! test if lower do i=1, 2 if (key(i) < pairlist%pairs(pos,i)) then hi=pos-1 cycle search else if (key(i) > pairlist%pairs(pos,i)) then exit end if end do ! just right return end do search ! ! else if not found ! if not enough room, expand pairlist ! if ((pairlist%npairs + 1) == size(pairlist%pairs, 1)) then call expand_pairs(10, pairlist) end if ! insert new record do k=pairlist%npairs, lo, -1 pairlist%pairs(k+1,1:2)=pairlist%pairs(k,1:2) end do pairlist%npairs=pairlist%npairs+1 pairlist%pairs(lo,1:2)=key(1:2) end subroutine insert_pair ! ! find a pair ! function find_pair(key1, key2, pairlist) integer :: find_pair integer, intent(in) :: key1, key2 type (pairlist_data) :: pairlist ! local variables integer, parameter :: NOT_FOUND=0 integer :: hi, i, lo, pos integer, dimension(2) :: key find_pair=NOT_FOUND key(1)=key1 key(2)=key2 hi=pairlist%npairs lo=1 pos=lo search: do while (hi >= lo) pos=lo+(hi-lo)/2 ! test if higher do i=1, 2 if (key(i) > pairlist%pairs(pos,i)) then lo=pos+1 cycle search else if (key(i) < pairlist%pairs(pos,i)) then exit end if end do ! test if lower do i=1, 2 if (key(i) < pairlist%pairs(pos,i)) then hi=pos-1 cycle search else if (key(i) > pairlist%pairs(pos,i)) then exit end if end do ! just right find_pair=pos return end do search end function find_pair end module pairlist_class ! ! Accessory routines and structure to store information about variables in formula ! module covariate_data use alleles_class use ped_class use locus_types use contingency_table integer, parameter :: ALL_OBS = 1, COMPLETE_OBS = 2 type variable_data integer :: ncatvars ! number of categorical variables in formula integer, dimension(:), allocatable :: catvars type (table_data), dimension(:), allocatable :: martable integer :: totvars ! number of variables in design matrix (incl dummies) double precision, dimension(:), allocatable :: means, sds end type variable_data ! contains ! ! test if complete data for i'th individual ! function complete(useimp, idx, nvar, terms, locpos, loctyp, dataset) logical complete logical, intent(in) :: useimp ! utilize imputed genotypes integer, intent(in) :: idx integer, intent(in) :: nvar integer, dimension(:), intent(in) :: terms integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp type (ped_data) :: dataset integer, parameter :: KNOWN=0, MISS=-9999 integer :: j, lpos, ltyp complete=.true. do j=1, nvar lpos=locpos(terms(j)) ltyp=loctyp(terms(j)) if (ismarker(ltyp)) then if (.not.useimp .and. .not.observed(idx, lpos, dataset)) then complete=.false. exit end if else if (isspecial(ltyp)) then if (lpos < 4 .and. dataset%sex(idx) == MISS) then complete=.false. exit end if else if (dataset%plocus(idx,lpos) == MISS) then complete=.false. exit end if end if end do end function complete ! ! Collect necessary information to create dummy variables encoding a categorical trait ! allocates necessary marginal table storage ! subroutine varlevels(typ, gene, numal, nvar, varlist, & loc, loctyp, locpos, dataset, covariates, plevel) use outstream integer, intent(in) :: typ ! jointly or marginally nonmissing integer, intent(in) :: gene ! marker locus for allelic coding integer, intent(in) :: numal ! number of alleles at marker locus integer, intent(in) :: nvar integer, dimension(:), intent(in) :: varlist character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data), intent(in) :: dataset type (variable_data), intent(inout) :: covariates integer, intent(in) :: plevel integer, parameter :: MISS=-9999 integer :: i, icat, ilev, ityp, j, ncatvars, ped, pos, totvars ncatvars=0 totvars=0 do j=1, nvar-1 if (iscattrait(loctyp(varlist(j)))) then ncatvars=ncatvars+1 else totvars=totvars+1 end if end do if (ncatvars /= 0) then covariates%ncatvars=ncatvars allocate(covariates%catvars(ncatvars)) allocate(covariates%martable(ncatvars)) ncatvars=0 do j=1, nvar-1 if (iscattrait(loctyp(varlist(j)))) then ncatvars=ncatvars+1 covariates%catvars(ncatvars)=locpos(varlist(j)) call setup_table(1, 20, covariates%martable(ncatvars)) end if end do if (typ == COMPLETE_OBS) then do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (complete(.false., i, nvar, varlist, locpos, loctyp, dataset)) then do j=1, ncatvars call insert_table(1, dataset%plocus(i, covariates%catvars(j)), & covariates%martable(j), 1) end do end if end do end if end do else do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) do j=1, ncatvars if (dataset%plocus(i, covariates%catvars(j)) /= MISS) then call insert_table(1, dataset%plocus(i, covariates%catvars(j)), & covariates%martable(j), 1) end if end do end do end if end do end if do j=1, ncatvars totvars=totvars+covariates%martable(j)%ncells-1 end do end if covariates%totvars=totvars if (plevel > 0 .and. ncatvars > 0) then write(outstr, '(/4x,a/2x,a)') 'Variable Levels', repeat('-', 26) icat=0 do j=1, nvar-1 pos=varlist(j) ityp=min(12, mod(loctyp(pos), LOC_CMP)) ilev=1 if (loctyp(pos) == LOC_CAT) then icat=icat+1 ilev=covariates%martable(icat)%ncells else if (loctyp(pos) == LOC_AFF) then ilev=2 else if (pos == gene) then ilev=numal end if write(outstr,'(2x,a20,1x,a1,1x,i4)') loc(pos), typloc(ityp), ilev end do end if end subroutine varlevels ! ! One row of the design matrix for the fixed effects part of model for varcom and segsim. ! Possibly including one marker for full dummy encoding, which may be imputed ! Possibly including an intercept. ! Missing x values replaced by overall mean ! NB (20150813): if intercept present, then covariates off by one - repaired ! ! Values may be stand=1: untransformed ! stand=2: rescaled, affecting only quantitative traits ! subroutine fixeff(idx, designpos, interc, gene, genemod, allele_buffer, useimp, & nvar, varlist, nloci, loctyp, locpos, covariates, & dataset, vals, stand) use alleles_class use ped_class use locus_types use read_data implicit none integer, intent(in) :: idx integer, intent(in) :: designpos integer, intent(in) :: interc integer, intent(in) :: gene integer, intent(in) :: genemod type (allele_data) :: allele_buffer logical, intent(in) :: useimp integer, intent(in) :: nvar integer, dimension(:), intent(in) :: varlist integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (variable_data), intent(inout) :: covariates type (ped_data) :: dataset double precision, dimension(:,:), intent(inout) :: vals integer, intent(in) :: stand ! integer, parameter :: KNOWN=0, MISS=-9999 integer :: a1, a2, genelevels, ii, icat, j, k, ncat, pos, vpos double precision :: freq, res type (table_cell), dimension(1) :: values ! functions integer :: clcpos, getnam icat=0 vpos=0 if (interc == 1) then vpos=1 vals(designpos,vpos)=1.0d0 end if if (genemod == 1) then genelevels=allele_buffer%numal-1 else genelevels=allele_buffer%numgtp-1 end if do j=1, nvar-1 pos=varlist(j) if (pos == gene) then if (useimp .or. observed(idx, locpos(gene), dataset)) then do k=1, genelevels vals(designpos,vpos+k)=0.0d0 end do call get_geno(idx, locpos(gene), locpos(gene)+1, dataset, a1, a2) if (useimp) then if (a1 /= MISS .and. a1 /= KNOWN) then a1=abs(a1) a2=abs(a2) a1=getnam(a1, allele_buffer)-1 a2=getnam(a2, allele_buffer)-1 else a1=0 a2=0 end if else a1=getnam(a1, allele_buffer)-1 a2=getnam(a2, allele_buffer)-1 end if if (genemod == 1) then if (a1 > 0) vals(designpos,vpos+a1)=vals(designpos,vpos+a1) + 1.0d0 if (loctyp(pos) /= LOC_HAP) then if (a2 > 0) vals(designpos,vpos+a2)=vals(designpos,vpos+a2) + 1.0d0 end if else k=clcpos(a1+1 ,a2+1)-1 if (k > 0) vals(designpos,vpos+k)=vals(designpos,vpos+k) + 1.0d0 end if else if (genemod == 1) then do k=1, allele_buffer%numal-1 vals(designpos,vpos+k)=2*allele_buffer%allele_freqs(k+1) end do else a1=1 a2=1 do k=1, genelevels a2=a2+1 if (a2 > allele_buffer%numal) then a1=a1+1 a2=a1 end if freq=allele_buffer%allele_freqs(a1)*allele_buffer%allele_freqs(a2) if (a1 == a2) freq=freq+freq vals(designpos,vpos+k)=freq end do end if end if vpos=vpos+genelevels else if (ismarker(loctyp(pos))) then vpos=vpos+1 if (observed(idx, locpos(pos), dataset)) then call get_geno(idx, locpos(pos), locpos(pos)+1, dataset, a1, a2) vals(designpos,vpos)=0.5d0*dble(a1+a2) else if (useimp) then call get_geno(idx, locpos(pos), locpos(pos)+1, dataset, a1, a2) if (a1 /= MISS .and. a1 /= KNOWN) then vals(designpos,vpos)=0.5d0*dble(abs(a1)+abs(a2)) else vals(designpos,vpos)=covariates%means(vpos-interc) end if else vals(designpos,vpos)=covariates%means(vpos-interc) end if else if (loctyp(pos) == LOC_AFF) then vpos=vpos+1 if (dataset%plocus(idx, locpos(pos)) /= MISS) then vals(designpos,vpos)=dataset%plocus(idx,locpos(pos))-1.0d0 else vals(designpos,vpos)=covariates%means(vpos-interc) end if else if (loctyp(pos) == LOC_CAT) then icat=icat+1 ncat=covariates%martable(icat)%ncells-1 if (dataset%plocus(idx, locpos(pos)) /= MISS) then do k=1, ncat vals(designpos,vpos+k)=0.0d0 end do call set_table_cell(values(1), rvalue=dataset%plocus(idx,locpos(pos))) ii=search_table(1, values, covariates%martable(icat), 0)-1 if (ii > 0) vals(designpos,vpos+ii)=vals(designpos,vpos+ii)+1.0d0 else do k=1, ncat vals(designpos,vpos+k)=covariates%means(vpos+k-interc) end do end if vpos=vpos+ncat else vpos=vpos+1 if (loctyp(pos) == LOC_SPECIAL) then call autovar(idx, locpos(pos), nloci, loctyp, locpos, dataset, res) else res=dataset%plocus(idx,locpos(pos)) end if if (res /= MISS) then if (stand == 2) then res = (res-covariates%means(vpos-interc))/covariates%sds(vpos-interc) end if vals(designpos,vpos)=res else if (stand == 2) then vals(designpos,vpos)=0.0d0 else vals(designpos,vpos)=covariates%means(vpos-interc) end if end if end if end do end subroutine fixeff ! ! Means for set of variables (incl dummies) in formula ! subroutine xmeans(nvar, varlist, nloci, loctyp, locpos, dataset, covariates) use ped_class use locus_types use read_data implicit none ! position of y and x variables integer, intent(in) :: nvar integer, dimension(:), intent(in) :: varlist integer, intent(in) :: nloci integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp type (ped_data) :: dataset type (variable_data) :: covariates ! local variables integer, parameter :: KNOWN=0, MISS=-9999 ! N's -- not restricted to complete cases integer, dimension(covariates%totvars+1) :: nobs ! ! local variables integer :: g1, g2, i, icat, ii, j, k, nmeans, ncat, ped, pos, vpos double precision :: res type (table_cell), dimension(1) :: values nmeans=covariates%totvars+1 allocate(covariates%means(nmeans)) allocate(covariates%sds(nmeans)) do vpos=1, nmeans nobs(vpos)=0 covariates%means(vpos)=0.0d0 covariates%sds(vpos)=0.0d0 end do do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) icat=0 vpos=0 do j=1, nvar pos=varlist(j) if (isactdip(loctyp(pos))) then vpos=vpos+1 if (observed(i, locpos(pos), dataset)) then call get_geno(i, locpos(pos), locpos(pos)+1, dataset, g1, g2) nobs(vpos)=nobs(vpos)+1 call moment(nobs(vpos), 0.5d0*dble(g1+g2), & covariates%means(vpos), covariates%sds(vpos)) end if else if (loctyp(pos) == LOC_AFF) then vpos=vpos+1 if (dataset%plocus(i,locpos(pos)) /= MISS) then nobs(vpos)=nobs(vpos)+1 call moment(nobs(vpos), dataset%plocus(i,locpos(pos))-1.0d0, & covariates%means(vpos), covariates%sds(vpos)) end if else if (loctyp(pos) == LOC_CAT) then icat=icat+1 ncat=covariates%martable(icat)%ncells-1 if (dataset%plocus(i,locpos(pos)) /= MISS) then call set_table_cell(values(1), rvalue=dataset%plocus(i,locpos(pos))) ii=search_table(1, values, covariates%martable(icat),0)-1 if (ii > 0) then do k=1, ncat res=0.0d0 if (k == ii) res=1.0d0 nobs(vpos+k)=nobs(vpos+k)+1 call moment(nobs(vpos+k), res, & covariates%means(vpos+k), covariates%sds(vpos+k)) end do else if (ii < 0) then write(*,*) 'ERROR: Category ', dataset%plocus(i,locpos(pos)), & ' not found.' end if end if vpos=vpos+ncat else vpos=vpos+1 if (loctyp(pos) == LOC_SPECIAL) then call autovar(i, locpos(pos), nloci, loctyp, locpos, dataset, res) else res=dataset%plocus(i,locpos(pos)) end if if (res /= MISS) then nobs(vpos)=nobs(vpos)+1 call moment(nobs(vpos), res, & covariates%means(vpos), covariates%sds(vpos)) end if end if end do end do end if end do do vpos=1, nmeans if (nobs(vpos) > 0) then covariates%sds(vpos)=sqrt(covariates%sds(vpos)/dble(max(1,nobs(vpos)-1))) end if end do end subroutine xmeans end module covariate_data ! ! Data to be passed to function called by brent() ! ! MVN profile likelihood ! module brent_vcdata integer :: ppar ! parameter to profile integer :: totpar ! total parameters double precision :: totvar ! total variance double precision, dimension(:), allocatable :: profpars double precision :: boundlik end module brent_vcdata ! ! MFT bivariate normal likelihood ! module brent_mft ! Binary trait model double precision :: dev, obsp ! RxC table integer :: obs_table_nr, obs_table_nc double precision, dimension(:), allocatable :: col_thresh, row_thresh double precision, dimension(:,:), allocatable :: obs_table, obs_table_probs end module brent_mft ! ! Cockerham-like multi-locus variance components ! module popgen_vcdata integer :: gen_nloci double precision :: gen_h0, gen_hs, gen_ht contains subroutine popgen_init() gen_nloci=0 gen_h0=0.0d0 gen_hs=0.0d0 gen_ht=0.0d0 end subroutine popgen_init subroutine popgen_summary(outstr, plevel) use statresults integer, intent(in) :: outstr, plevel double precision :: gen_fst, gen_fit, gen_fis gen_fis=(gen_hs-gen_h0)/gen_hs gen_fit=(gen_ht-gen_h0)/gen_ht gen_fst=(gen_ht-gen_hs)/gen_ht gen_h0=gen_h0/dble(max(1,gen_nloci)) gen_hs=gen_hs/dble(max(1,gen_nloci)) gen_ht=gen_ht/dble(max(1,gen_nloci)) statval(1)=gen_fis statval(2)=gen_fit statval(3)=gen_fst if (plevel < -2) then continue else if (plevel <= 0) then write(outstr,'(a20,20x,a21/a20,20x,3(1x,f6.4),a,i0,a)') & '--------------------', ' ------ ------ ------', & 'Multilocus ', gen_fis, gen_fit, gen_fst, ' (N=', gen_nloci, ')' else write(outstr,'(/a/a,1x,i0/2(/a,3(3x,f6.4)))') & 'Results from combination of locus F statistics', & ' Number of markers used =', gen_nloci, & ' Mean Ho, Hs, Ht =', gen_h0, gen_hs, gen_ht, & ' Multilocus Fis, Fit, Fst =', gen_fis, gen_fit, gen_fst end if end subroutine popgen_summary ! subroutine popgen_homoz(outstr, plevel) use statresults integer, intent(in) :: outstr, plevel double precision :: gen_fis gen_fis=(gen_hs-gen_h0)/gen_hs statval(1)=gen_fis statval(2)=0.0d0 statval(3)=0.0d0 if (plevel <= 0) then write(outstr,'(a20,22x,a6/a20,22x,f6.4,a,i0,a)') & '--------------------', '------', & 'Multilocus ', gen_fis, ' (N=', gen_nloci, ')' else write(outstr,'(/a/a,i0/a,3(3x,f6.4))') & 'Results from combination of locus F statistics', & ' No. markers used =', gen_nloci, & ' Multilocus Fis =', gen_fis end if end subroutine popgen_homoz end module popgen_vcdata ! ! Large dense empirical kinship matrix, ! its latest active subset and corresponding inverse ! and a hash of the ids of the dropped rows ! module popgen_kinship integer (kind=8) :: kinmat_nobs = 0 double precision, dimension(:), allocatable :: kinmat logical :: keep_kin = .false. integer :: subset_hash = 5381 integer :: subset_size = 0 ! ! file stored matrices ! integer, parameter :: MAX_MEMO = 50 integer :: n_matrices_hashed = 0 integer, dimension(MAX_MEMO) :: matrix_hash = 0 integer, dimension(MAX_MEMO) :: matrix_size = 0 integer, dimension(MAX_MEMO) :: matrix_utilization = 0 contains subroutine setup_kinmat(nobs, ncov, ridge_constant, plevel, ifail) use outstream integer (kind=8), intent(in) :: nobs, ncov double precision, intent(in) :: ridge_constant integer, intent(in) :: plevel integer, intent(out) :: ifail integer :: astat character (len=8) :: slin integer (kind=8) :: i, j double precision :: dval ifail=0 if (allocated(kinmat)) deallocate(kinmat) allocate(kinmat(ncov), stat=astat) if (astat /= 0) then write(outstr,'(a,i0,a)') & 'ERROR: Could not allocate kinship matrix of ', ncov, ' elements.' ifail=-1 return else if (plevel > 1) then write(slin, '(f8.1)') size(kinmat)*(storage_size(kinmat)/8)*1.0e-6 slin=adjustl(slin) write(outstr,'(a,i0,a,i0,3a)') & 'NOTE: Allocated ', nobs, '*', nobs, ' kinship matrix (', & trim(slin), ' MB)' end if kinmat_nobs=nobs kinmat=0.0d0 dval=1.0d0+ridge_constant j=0 do i=1, nobs j=j+i kinmat(j)=dval end do end subroutine setup_kinmat ! ! hash identifying particular subset of kinship matrix ! used to memoise inverses etc. ! subset_hash, subset_size are globals in module popgen_kinship ! subroutine hash_kinship(nfull, active) integer, intent(in) :: nfull logical, dimension(nfull), intent(in) :: active integer (kind=8) :: i, j, k, ncov, nn, pos subset_size=nfull subset_hash=5381 do i=1, nfull if (.not.active(i)) then subset_size=subset_size-1 subset_hash = (ishft(subset_hash,5) + subset_hash) + i end if end do end subroutine hash_kinship ! function ismemoizedinv() integer :: ismemoizedinv integer :: i ismemoizedinv=0 do i=1, n_matrices_hashed if (subset_hash == matrix_hash(i)) then ismemoizedinv=i return end if end do end function ismemoizedinv ! ! write inverse kinship matrix to file ! subroutine save_kininv(nrows, logdet, ainv, stat) use fileio use outstream integer, intent(in) :: nrows double precision, intent(in) :: logdet double precision, dimension(:), intent(in) :: ainv integer, intent(out) :: stat character (len=256) :: fil integer :: i, idx stat=1 if (ismemoizedinv() > 0) then return end if stat=0 if (n_matrices_hashed == MAX_MEMO) then idx=1 do i=1, n_matrices_hashed if (matrix_utilization(i) < matrix_utilization(idx)) then idx=i end if end do write(fil, '(z8.8)') matrix_hash(idx) fil='sp-' // trim(adjustl(fil)) // '.kin' call delfile(fil, -1) else n_matrices_hashed=n_matrices_hashed+1 idx=n_matrices_hashed end if matrix_hash(idx)=subset_hash matrix_size(idx)=subset_size matrix_utilization(idx)=1 write(fil, '(z8.8)') subset_hash fil='sp-' // trim(adjustl(fil)) // '.kin' call newlun(kinstrm) open(kinstrm, form='unformatted', file=trim(fil), iostat=ioerr) if (ioerr /= 0) then stat=-1 write(outstr,'(a)') 'ERROR: Unable to write kinship inverse!' return end if write(kinstrm) nrows, subset_size, logdet write(kinstrm) ainv close(kinstrm) end subroutine save_kininv ! ! read kinship inverse from file ! subroutine load_kininv(nrows, logdet, ainv, stat) use fileio use outstream integer, intent(in) :: nrows double precision, intent(inout) :: logdet double precision, dimension(:), intent(inout) :: ainv integer, intent(out) :: stat character (len=256) :: fil integer :: idx, kinstrm, n, nr integer (kind=8) :: filsiz logical :: filexist stat=1 idx=ismemoizedinv() if (idx == 0) return stat=0 write(fil, '(z8.8)') subset_hash fil='sp-' // trim(adjustl(fil)) // '.kin' inquire(file=fil, exist=filexist) inquire(file=fil, size=filsiz) call newlun(kinstrm) open(kinstrm, form='unformatted', file=trim(fil), iostat=ioerr) if (ioerr /= 0) then stat=-1 write(outstr,'(a)') 'ERROR: Unable to read kinship inverse!' goto 999 end if read(kinstrm) nr, n, logdet if (n /= subset_size .or. nrows /= nr) then stat=-2 write(outstr,'(a,i0,a,i0/7x,a,i0,a,i0)') & 'ERROR: Kinship inverse size incorrect! n=', n, '; Should be ', subset_size, & 'and nobs=', nr, '; Should be ', nrows goto 999 end if read(kinstrm, iostat=ioerr) ainv if (ioerr /= 0) then write(outstr,'(a,i0,a,i0)') & 'ERROR: Problem while reading kinship inverse, ioerr=', ioerr close(kinstrm) goto 999 end if matrix_utilization(idx)=matrix_utilization(idx)+1 999 close(kinstrm) end subroutine load_kininv ! ! Remove work files ! subroutine cleanup_memoized_kininv() integer :: i character (len=256) :: fil do i=1, n_matrices_hashed write(fil, '(z8.8)') subset_hash fil='sp-' // trim(adjustl(fil)) // '.kin' call delfile(fil, 1) end do n_matrices_hashed = 0 end subroutine cleanup_memoized_kininv end module popgen_kinship ! ! Higher level i/o routines for popgen_kinship ! module kinship_io contains ! function has_kinmat() use popgen_kinship integer :: has_kinmat has_kinmat=-1 if (allocated(kinmat)) has_kinmat=0 end function has_kinmat ! ! Indices for subset of active individuals ! subroutine subset_active(dataset, nwanted, nreturned, indices) use outstream use popgen_kinship use ped_class type (ped_data) :: dataset integer, intent(in) :: nwanted integer, intent(out) :: nreturned integer, dimension(:) :: indices integer :: i, ped nreturned=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1,dataset%num(ped) nreturned=nreturned+1 indices(nreturned)=i if (nreturned == nwanted) return end do end if end do end subroutine subset_active ! ! head kinmat ! subroutine showkin(nrows, dataset, plevel) use outstream use popgen_kinship use ped_class type (ped_data) :: dataset integer, intent(in) :: nrows integer, intent(in) :: plevel integer (kind=8) :: i, j, pos integer :: k, k2 character (len=10), dimension(6) :: countlevels = & (/ 'Zero ', '0--1/16 ', '1/16--9/20', & '0.45--0.55', '11/20--1 ', '1 ' /) integer (kind=8), dimension(6) :: counts integer (kind=8) :: ndiag double precision :: diagmean integer :: nidx integer, dimension(nrows) :: idx counts=0 ndiag=0 diagmean=0.0d0 if (n_matrices_hashed > 0) then write(outstr,'(a,i0,a)') & 'NOTE: There are ', n_matrices_hashed, ' stored kinship matrices.' end if if (allocated(kinmat)) then write(outstr,'(a,i0,a)') & 'Kinship matrix of ', size(kinmat), ' elements.' call subset_active(dataset, nrows, nidx, idx) if (nidx == 0) then pos=0 do i=1, min(int(nrows, kind=8), kinmat_nobs) write(outstr,'(10(1x,f6.4))') kinmat((pos+1):(pos+i)) pos=pos+i end do else do k=1, nidx i=int(idx(k), kind=8) write(outstr,'(a)', advance='no') dataset%id(i) do k2=1, k j=int(idx(k2), kind=8) write(outstr,'(1x,f6.4)', advance='no') kinmat(i*(i-1)/2+j) end do write(outstr,*) end do end if if (plevel > 0) then if (nrows < kinmat_nobs) write(outstr,'(a)') '...' pos=0 do i=1, kinmat_nobs do j=1, i-1 if (kinmat(pos+j) == 0.0d0) then counts(1)=counts(1)+1 else if (kinmat(pos+j) == 1.0d0) then counts(6)=counts(6)+1 else if (kinmat(pos+j) < 0.125d0) then counts(2)=counts(2)+1 else if (kinmat(pos+j) < 0.45d0) then counts(3)=counts(3)+1 else if (kinmat(pos+j) < 0.55d0) then counts(4)=counts(4)+1 else counts(5)=counts(5)+1 end if end do pos=pos+i if (kinmat(pos) /= 0.0d0) then ndiag=ndiag+1 diagmean=diagmean+(kinmat(pos)-diagmean)/dble(ndiag) end if end do write(outstr, '(/a,f6.4,a,i0,a)') & 'Mean value on diagonal = ', diagmean, ' (N_nonzero=', ndiag, ')' write(outstr, '(/a)') 'Kinship Number of pairs' do k=1, 6 write(outstr, '(a,3x,i0)') countlevels(k), counts(k) end do end if else write(outstr,'(a)') 'Kinship matrix unallocated.' end if end subroutine showkin ! ! Show high kinships ! subroutine highkin(dataset, plevel) use outstream use ped_class use popgen_kinship type (ped_data) :: dataset integer, intent(in) :: plevel integer, parameter :: MISS=-9999 integer(kind=8) :: i, j, pos integer :: nhigh double precision :: k1, k12, k2 character (len=2) :: zyg if (kinmat_nobs == 0) then if (plevel > -1) then write(outstr,'(a)') 'No currently active kinship matrix!' end if return end if write(outstr,'(6x,a25,1x,a25,1x,a)') & 'Individual-1', 'Individual-2', 'kin F1 F2 r' nhigh=0 pos=1 do i=2, kinmat_nobs k1=kinmat(pos) if (k1 > 0.0d0) then do j=1, i-1 k12=kinmat(pos+j) if (k12 == 1.0d0 .or. k12/k1 > 0.95d0) then nhigh=nhigh+1 k2=kinmat(pos+i) zyg=' *' if (dataset%imztwin(j) /= MISS) zyg='MZ' write(outstr,'(i5,2(1x,a25),4(1x,f6.4),1x,a)') nhigh, & adjustl(trim(dataset%pedigree(dataset%iped(i))) // ' ' // & trim(dataset%id(i))), & adjustl(trim(dataset%pedigree(dataset%iped(j))) // ' ' // & trim(dataset%id(j))), k12, k1, k2, k12/sqrt(k1)/sqrt(k2), zyg end if end do end if pos=pos+i end do end subroutine highkin ! ! Add ridge constant ! subroutine kinridge(ridge_constant) use ped_class use popgen_kinship double precision, intent(in) :: ridge_constant integer (kind=8) :: i, pos if (allocated(kinmat)) then pos=0 do i=1, kinmat_nobs pos=pos+i kinmat(pos)=kinmat(pos)+ridge_constant end do end if end subroutine kinridge ! ! Set large C matrix ! subroutine setup_bigC(dataset, plevel) use outstream use ped_class use popgen_kinship type (ped_data) :: dataset integer, intent(in) :: plevel integer, parameter :: MISS=-9999 integer :: num, ped, pedoffset integer (kind=8) :: i, j, ncov, nobs, pos nobs=int(dataset%nobs, kind=8) ncov=nobs*(nobs+1)/2 write(outstr,'(a,i0,a,i0,a)') & 'Initializing covariance matrix to ', nobs, ' * ', nobs, ' C.' call setup_kinmat(nobs, ncov, 0.0d0, plevel, ifail) if (ifail /= 0) return pos=0 do ped=1, dataset%nped pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset do i=1, num pos=pos+pedoffset do j=1, i-1 pos=pos+1 kinmat(pos)=1.0d0 end do pos=pos+1 end do end do end subroutine setup_bigC ! ! Set large A matrix ! subroutine setup_bigA(dataset, plevel) use outstream use ped_class use popgen_kinship type (ped_data) :: dataset integer, intent(in) :: plevel integer, parameter :: MISS=-9999 double precision, dimension(:), allocatable :: tmpkin integer :: ifail, num, ped, pedoffset integer (kind=8) :: i, j, kpos, ncov, nobs, pos interface subroutine kinship(ped, dataset, kin) use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(in) :: dataset double precision, dimension(:), intent(inout) :: kin end subroutine kinship end interface ncov=int(dataset%maxsiz, kind=8)*(int(dataset%maxsiz, kind=8)+1)/2 allocate(tmpkin(ncov)) nobs=int(dataset%nobs, kind=8) ncov=nobs*(nobs+1)/2 write(outstr,'(a,i0,a,i0,a)') & 'Initializing covariance matrix to ', nobs, ' * ', nobs, ' A.' call setup_kinmat(nobs, ncov, 0.0d0, plevel, ifail) if (ifail /= 0) return pos=0 do ped=1, dataset%nped call kinship(ped, dataset, tmpkin) pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset kpos=0 do i=1, num pos=pos+pedoffset do j=1, i kpos=kpos+1 pos=pos+1 kinmat(pos)=tmpkin(kpos) end do end do end do end subroutine setup_bigA ! ! Read a kinship matrix in from a file, allocating kinmat ! ped1 id1 ped2 id2 ... kin ! uses untyped() to filter useable values ! subroutine readkin(fil, ridge_constant, hashtab, dataset, ifail, plevel) use fileio use outstream use idhash_class use locstring_widths use scanner use ped_class use popgen_kinship use symmetric_matrix character (len=*), intent(in) :: fil ! Hash table for IDs type (hash_table) :: hashtab type (ped_data) :: dataset double precision, intent(in) :: ridge_constant integer, intent(out) :: ifail integer, intent(in) :: plevel integer, parameter :: MISS=-9999 integer, parameter :: BUFLEN=1024 character (len=BUFLEN) :: buff character (len=40), dimension(11) :: words type (ioport) :: port integer :: astat, i, ioerr, kpos, nlin, nread, ped, & peri, perj, unmatched integer (kind=8) :: nobs, ncov, pos logical :: inheader double precision :: logdet, val ! timing character (len=20) :: slin integer :: it1, it2, ticks ! functions integer :: findword integer(kind=8) :: big_clcpos double precision :: fval call system_clock(it1) ifail=0 nobs=int(dataset%nobs, kind=8) ncov=nobs*(nobs+1)/2 call setup_kinmat(nobs, ncov, ridge_constant, plevel, ifail) if (ifail /= 0) return ! call open_port(fil, port, 'r', ioerr) if (ioerr /= 0) then write(outstr,'(3a,i0,a)') & 'ERROR: Cannot open "', trim(fil), '" ioerr=', ioerr, '.' deallocate(kinmat) ifail=-2 return end if ! Look for header inheader=.false. nlin=0 do call readline(port, buff, ios=ioerr) if (ioerr /= 0) exit nlin=nlin+1 narg=11 call args(buff, narg, words, ' ', SEP_WHITE) if (plevel > 1 .and. nlin < 10) then write(outstr,'(i2,2a)') nlin, ':', trim(buff) end if if (words(1) == 'ped1' .and. words(2) == 'id1') then kpos=findword('kin', 3, narg, narg, words) if (kpos > 0) then inheader = .true. exit end if end if end do if (.not. inheader) then write(outstr,'(3a,i0,a)') & 'ERROR: Could not find header line of form "ped1 id1 ped2 id2...kin"!' call close_port(port, ioerr) deallocate(kinmat) ifail=-3 return end if if (.not.hashtab%current .or. (hashtab%keytyp /= HK_PED_ID)) then call hashids(HK_PED_ID, dataset, hashtab, 80, plevel-1) end if nlin=0 nread=0 unmatched=0 do call readline(port, buff, ios=ioerr) if (ioerr /= 0) exit nlin=nlin+1 narg=11 call args(buff, narg, words, ' ', SEP_WHITE) if (narg == 0) exit call matchid(HK_PED_ID, words(1), words(2), dataset, & hashtab, peri, plevel-2) call matchid(HK_PED_ID, words(3), words(4), dataset, & hashtab, perj, plevel-2) if (peri > 0 .and. perj > 0) then nread=nread+1 val = fval(words(kpos)) if (val /= MISS .and. abs(val) <= 2.0d0) then kinmat(big_clcpos(peri,perj)) = val end if else unmatched=unmatched+1 if (plevel > 1) then write(outstr,'(3a)') 'NOTE: No match for "', trim(buff(1:72)), '".' end if end if end do call close_port(port, ioerr) subset_hash = 5381 if (plevel > 0) then call system_clock(it2, count_rate=ticks) write(slin, '(f20.2)') float(it2-it1)/float(ticks) slin=adjustl(slin) i=ncov-nobs if (nread > i) i=ncov write(outstr,'(/a,i0,a,i0,3a)') & 'Read in ', nread, ' kinship coefficients of a possible ', i, & ' (', trim(slin), 's).' if (unmatched > 0) then write(outstr,'(a,i0,a)') 'Skipped ', unmatched, ' unmatchable IDs in file.' end if if (plevel > 1) then write(outstr,*) pos=0 do i=1, 5 write(outstr,*) dataset%id(i), kinmat((pos+1):(pos+i)) pos=pos+i end do end if end if end subroutine readkin ! ! Write out kinship matrix as typ=1 square matrix typ=2 pairwise ! subroutine writekin(typ, fil, trait, dataset, plevel) use fileio use outstream use locstring_widths use scanner use ped_class use popgen_kinship use symmetric_matrix integer, intent(in) :: typ character (len=*), intent(in) :: fil integer, intent(in) :: trait type (ped_data) :: dataset integer, intent(in) :: plevel integer, parameter :: MISS=-9999 integer, parameter :: BUFLEN=1024 character (len=BUFLEN) :: buff character (len=40), dimension(2) :: words type (ioport) :: port character(len=256) :: idfil, numfil, grmfil integer :: strm integer :: astat, i, ios, n, narg integer (kind=8) :: nobs, ncov, nn, pos integer, dimension(dataset%nobs) :: idx ! functions integer(kind=8) :: big_clcpos if (.not.allocated(kinmat)) then write(outstr,'(a)') 'ERROR: No kinship matrix presently in memory!' return end if nobs=int(dataset%nobs, kind=8) ncov=nobs*(nobs+1)/2 n=0 nn=0 call filter_snp(trait, dataset) do i=1, nobs if (.not.dataset%untyped(i)) then n=n+1 idx(n)=i end if end do nn=int(n, kind=8)*(int(n, kind=8)) call newlun(strm) open(strm, file=fil, iostat=ios) if (ios /= 0) then write(*, '(3a)') 'ERROR: Cannot open "', trim(fil), '".' return else if (plevel > -2) then write(outstr, '(a,i0,3a)') & 'Writing ', nn,' kinships to "', trim(fil), '".' end if if (typ == 1) then do i=1, n write(strm, '(1x,a)', advance='no') trim(dataset%id(idx(i))) end do write(strm,*) do i=1, n do j=1, n pos=big_clcpos(idx(i),idx(j)) write(strm,'(1x,f9.6)', advance='no') kinmat(pos) end do write(strm,*) end do else do i=1, n do j=1, n pos=big_clcpos(idx(i),idx(j)) write(strm,'(4(a,1x),f9.6)') & trim(dataset%pedigree(dataset%iped(idx(i)))), & trim(dataset%id(idx(i))), & trim(dataset%pedigree(dataset%iped(idx(j)))), & trim(dataset%id(idx(j))), kinmat(pos) end do write(strm,*) end do end if close(strm) end subroutine writekin ! ! Read in GCTA binary format GRM ! mapping from grm to pedigree 1 0 2 3 10 4 0 ... ! subroutine readgrm(file_prefix, ridge_constant, hashtab, dataset, ifail, plevel) use fileio use outstream use idhash_class use locstring_widths use scanner use ped_class use popgen_kinship use symmetric_matrix character (len=*), intent(in) :: file_prefix double precision, intent(in) :: ridge_constant ! Hash table for IDs type (hash_table) :: hashtab type (ped_data) :: dataset integer, intent(out) :: ifail integer, intent(in) :: plevel integer, parameter :: MISS=-9999 integer, parameter :: BUFLEN=1024 character (len=BUFLEN) :: buff character (len=40), dimension(2) :: words type (ioport) :: port integer, dimension(dataset%nobs) :: idx integer, dimension(:), allocatable :: grmidx real, dimension(:), allocatable :: tmpkinmat character(len=256) :: idfil, numfil, grmfil integer :: strm integer :: astat, i, ios, narg, peri integer (kind=8) :: matched, nobs, ncov, n, nn, num0, num1, nuse, pos logical :: ordered integer :: minn, maxn double precision :: meann ! functions integer :: clcpos ifail=0 call newlun(strm) nobs=int(dataset%nobs, kind=8) ncov=nobs*(nobs+1)/2 dataset%untyped=.true. call setup_kinmat(nobs, ncov, ridge_constant, plevel, ifail) n=0 nn=0 num0=0 num1=0 nuse=0 matched=0 idfil=trim(file_prefix) // '.grm.id' numfil=trim(file_prefix) // '.grm.N.bin' grmfil=trim(file_prefix) // '.grm.bin' open(strm, file=idfil, status='old', iostat=ios) if (ios /= 0) then write(*, '(3a)') 'ERROR: Cannot open "', trim(idfil), '".' return end if if (.not.hashtab%current .or. (hashtab%keytyp /= HK_PED_ID)) then call hashids(HK_PED_ID, dataset, hashtab, 80, plevel-1) end if idx=0 do read(strm,'(a)', iostat=ios) buff if (ios /= 0) exit n=n+1 narg=2 call args(buff, narg, words, ' ', SEP_WHITE) if (narg == 0) exit call matchid(HK_PED_ID, words(1), words(2), dataset, & hashtab, peri, plevel-2) if (peri > 0) then matched=matched+1 idx(peri)=n if (plevel > 1) then write(outstr,'(3a)') 'NOTE: Matched "', trim(buff(1:72)), '".' end if else if (plevel > 1) then write(outstr,'(3a)') 'NOTE: No match for "', trim(buff(1:72)), '".' end if end if end do close(strm) write(outstr,'(a,i0,a,i0,3a)') & 'Matched ', matched, ' IDs of ', n, ' from "', trim(idfil), '".' if (matched == 0) return ordered=.true. do i=2, nobs if (idx(i) /= 0 .and. idx(i) < idx(i-1)) then ordered=.false. exit end if end do nn=n*(n+1)/2 allocate(tmpkinmat(nn), stat=astat) if (astat /= 0) then write(*, '(a,i0,a)') & 'ERROR: Cannot allocate a real matrix of ', nn, ' elements.' return end if open(strm, file=numfil, access='stream', form='unformatted', & status='old', iostat=ios) if (ios /= 0) then write(*, '(3a)') 'ERROR: Cannot open "', trim(numfil), '".' return else if (plevel > 0) then write(outstr, '(a,i0,3a)') & 'Reading ', nn,' Ns from "', trim(numfil), '".' end if call readbigreal(strm, nn, tmpkinmat) close(strm) maxn=0 minn=2147483647 meann=0.0d0 pos=0 do i=1, n if (tmpkinmat(pos+i) == 0) then num0=num0+1 pos=pos+int(i, kind=8) else do j=1, i pos=pos+1 if (anint(tmpkinmat(pos)) > maxn) maxn=anint(tmpkinmat(pos)) if (anint(tmpkinmat(pos)) < minn) minn=anint(tmpkinmat(pos)) nuse=nuse+1 meann=meann+(dble(tmpkinmat(pos))-meann)/dble(nuse) end do end if end do write(outstr, '(a,i0/a,i0,a,i0,a,i0,a)') & 'Total usable individuals = ', n-num0, & 'Mean pairwise N (range) = ', int(meann), ' (', minn, ' -- ', maxn, ')' open(strm, file=grmfil, access='stream', form='unformatted', & status='old', iostat=ios) if (ios /= 0) then write(*, '(3a)') 'ERROR: Cannot open "', trim(grmfil), '".' return else if (plevel > 0) then write(outstr, '(a,i0,3a)') & 'Reading ', nn,' kinships from "', trim(grmfil), '".' end if call readbigreal(strm, nn, tmpkinmat) close(strm) if (matched == nobs .and. ordered) then kinmat=dble(tmpkinmat) pos=0 do i=1, n do j=1, i-1 if (tmpkinmat(pos+j) == 1.0) then num1=num1+1 if (plevel > 1) then write(strm,'(9a)') & 'NOTE: Individuals ', & trim(dataset%pedigree(dataset%iped(i))), '--', & trim(dataset%id(i)), ' and ', & trim(dataset%pedigree(dataset%iped(j))), '--', & trim(dataset%id(j)), ' appear genetically identical.' end if end if end do pos=pos+int(i, kind=8) end do else allocate(grmidx(0:n)) grmidx=0 do i=1, nobs grmidx(idx(i))=i end do pos=0 do i=1, n if (grmidx(i) /= 0) then do j=1, i-1 if (grmidx(j) /= 0) then kinmat(clcpos(grmidx(i), grmidx(j)))=dble(tmpkinmat(pos+j)) if (tmpkinmat(pos+j) == 1.0) then num1=num1+1 if (plevel > 1) then write(strm,'(9a)') & 'NOTE: Individuals ', & trim(dataset%pedigree(dataset%iped(grmidx(i)))), '--', & trim(dataset%id(grmidx(i))), ' and ', & trim(dataset%pedigree(dataset%iped(grmidx(j)))), '--', & trim(dataset%id(grmidx(j))), ' appear genetically identical.' end if end if end if end do kinmat(clcpos(grmidx(i), grmidx(i)))=dble(tmpkinmat(pos+i)) end if pos=pos+int(i, kind=8) end do end if deallocate(tmpkinmat) write(outstr,'(a,i0,3a)') & 'Read ', matched*(matched+1)/2, ' kinships from "', trim(grmfil), '".' if (num1 > 0) then write(outstr,'(a,i0,a)') & 'There were ', num1, ' MZ twin pairs or duplications.' end if end subroutine readgrm ! ! Write out GCTA binary format GRM ! subroutine writegrm(file_prefix, trait, dataset, plevel) use fileio use outstream use locstring_widths use scanner use ped_class use popgen_kinship use symmetric_matrix character (len=*), intent(in) :: file_prefix integer, intent(in) :: trait type (ped_data) :: dataset integer, intent(in) :: plevel integer, parameter :: MISS=-9999 integer, parameter :: BUFLEN=1024 character (len=BUFLEN) :: buff character (len=40), dimension(2) :: words type (ioport) :: port character(len=256) :: idfil, numfil, grmfil integer :: strm integer :: astat, i, ios, n, narg integer (kind=8) :: nobs, ncov, nn, pos real :: xn if (.not.allocated(kinmat)) then write(outstr,'(a)') 'ERROR: No kinship matrix presently in memory!' return end if nobs=int(dataset%nobs, kind=8) ncov=nobs*(nobs+1)/2 n=0 nn=0 idfil=trim(file_prefix) // '.grm.id' numfil=trim(file_prefix) // '.grm.N.bin' grmfil=trim(file_prefix) // '.grm.bin' call filter_snp(trait, dataset) call newlun(strm) open(strm, file=idfil, iostat=ios) if (ios /= 0) then write(*, '(3a)') 'ERROR: Cannot open "', trim(idfil), '".' return end if do i=1, nobs if (.not.dataset%untyped(i)) then n=n+1 write(strm,'(a,1x,a)') & dataset%pedigree(dataset%iped(i)), dataset%id(i) end if end do close(strm) write(outstr,'(a,i0,a,i0,3a)') & 'Wrote ', n, ' IDs of ', nobs, ' to "', trim(idfil), '".' ! write Ns nn=int(n, kind=8)*(int(n, kind=8)+1)/2 xn=float(n) open(strm, file=numfil, access='stream', form='unformatted', iostat=ios) if (ios /= 0) then write(*, '(3a)') 'ERROR: Cannot open "', trim(numfil), '".' return else if (plevel > 0) then write(outstr, '(a,i0,3a)') & 'Writing ', nn,' Ns to "', trim(numfil), '".' end if do i=1, nn write(strm) xn end do close(strm) ! write GRM open(strm, file=grmfil, access='stream', form='unformatted', iostat=ios) if (ios /= 0) then write(*, '(3a)') 'ERROR: Cannot open "', trim(grmfil), '".' return else if (plevel > -2) then write(outstr, '(a,i0,3a)') & 'Writing ', nn,' kinships to "', trim(grmfil), '".' end if pos=0 do i=1, nobs if (.not.dataset%untyped(i)) then do j=1, i-1 if (.not.dataset%untyped(j)) then write(strm) real(kinmat(pos+j), kind=4) end if end do write(strm) real(kinmat(pos+i), kind=4) end if pos=pos+i end do close(strm) end subroutine writegrm ! ! hash identifying particular subset of kinship matrix ! used to memoise inverses etc. ! subset_hash, subset_size are globals in module popgen_kinship ! this version aimed at big kinship matrix, but is ! same as popgen_kinship::hash_kinship ! subroutine big_hash_kinship(nfull, active) use popgen_kinship integer, intent(in) :: nfull logical, dimension(nfull), intent(in) :: active integer (kind=8) :: i, j, k, ncov, nn, pos subset_size=nfull subset_hash=5381 do i=1, nfull if (.not.active(i)) then subset_size=subset_size-1 subset_hash = (ishft(subset_hash,5) + subset_hash) + i end if end do end subroutine big_hash_kinship ! ! Subset full kinship matrix, writing to A ! subroutine get_kinship(nfull, nreduced, active, a) use outstream use popgen_kinship integer, intent(in) :: nfull integer, intent(in) :: nreduced logical, dimension(nfull), intent(in) :: active double precision, dimension(:) :: a integer :: stat integer (kind=8) :: i, j, k, ncov, nn, pos logical, dimension(:), allocatable :: keep integer, parameter :: MISS=-9999 if (nreduced == nfull) then if (kinmat_nobs /= nfull) then write(outstr,'(a,i0,a,i0,a)') & 'kinship matrix nobs ', kinmat_nobs, ' /= ', nfull, '!' end if a=kinmat return end if ! ! else extract subset from the full kinship matrix ! call hash_kinship(nfull, active) ncov=int(nfull,kind=8)*(int(nfull,kind=8)+1)/2 allocate(keep(ncov)) keep=.true. pos=0 do i=1, nfull if (.not.active(i)) then do j=1, i-1 keep(pos+j)=.false. end do k=pos do j=i, nfull keep(k+i)=.false. k=k+j end do end if pos=pos+i end do pos=1 do i=1, nfull*(nfull+1)/2 if (keep(i)) then a(pos)=kinmat(i) pos=pos+1 end if end do end subroutine get_kinship ! subroutine protect_kin(on) use popgen_kinship logical, intent(in) :: on keep_kin=on end subroutine protect_kin ! subroutine free_kin(plevel) use outstream use popgen_kinship integer, intent(in) :: plevel character (len=256) :: fil if (keep_kin) then if (plevel > 1) then write(outstr,'(a)') & 'NOTE: Kinship matrix is persistent. Use "set kin on|off" to alter.' end if return end if subset_hash=5381 subset_size=0 subset_inverse=0 if (allocated(kinmat)) deallocate(kinmat) if (plevel > 1) then write(outstr,*) end if do i=1, n_matrices_hashed write(fil, '(z8.8)') matrix_hash(i) fil='sp-' // trim(adjustl(fil)) // '.kin' if (plevel > 1) then write(outstr,'(i0,1x,i0,1x,3a,1x,i0)') & i, matrix_hash(i), '"', trim(fil), '"', matrix_utilization(i) end if call delfile(fil, plevel-2) end do kinmat_nobs=0 n_matrices_hashed=0 akinmat_logdet=0.0d0 if (plevel > 1) then write(outstr,'(a)') 'Deallocated kinship matrix.' end if end subroutine free_kin end module kinship_io ! ! The grapheps Postscript functions ! See http://swiss.csail.mit.edu/~jaffer/Docupage/grapheps ! module grapheps use timelib integer, parameter :: GSTRM = 22 contains subroutine pre_grapheps(outstr, xbound, ybound) integer, intent(in) :: outstr, xbound, ybound character (len=5) :: def0 def0='0 def' write(outstr,'(a)') '%!PS-Adobe-3.0 EPSF-3.0' write(outstr,'(a,2(1x,i5))') '%%BoundingBox: 0 0', xbound, ybound write(outstr,'(a)') '%%Title: Sib-pair plot via grapheps' write(outstr,'(2a)') '%%CreationDate: ', current_time() write(outstr,'(a)') '%%EndComments' write(outstr,'(2i2,2(1x,i6))') 0, 0, xbound, ybound write(outstr,'(a)') '/plotdict 100 dict def' write(outstr,'(a)') 'plotdict begin' write(outstr,'(a)') '% Get dimensions the preamble left on the stack.' write(outstr,'(a)') '4 array astore /whole-page exch def' write(outstr,'(a)') '% Definitions so that internal assignments are bound before setting.' write(outstr,'(2a)') '/DATA ', def0 write(outstr,'(2a)') '/DEN ', def0 write(outstr,'(2a)') '/DIAG ', def0 write(outstr,'(2a)') '/DIAG2 ', def0 write(outstr,'(2a)') '/DLTA ', def0 write(outstr,'(2a)') '/EXPSN ', def0 write(outstr,'(2a)') '/GPROCS ', def0 write(outstr,'(a)') '/GD 6 def' write(outstr,'(a)') '/GR 3 def' write(outstr,'(2a)') '/IDX ', def0 write(outstr,'(2a)') '/ISIZ ', def0 write(outstr,'(2a)') '/MAX ', def0 write(outstr,'(2a)') '/MIN ', def0 write(outstr,'(2a)') '/NUM ', def0 write(outstr,'(2a)') '/PLOT-bmargin ', def0 write(outstr,'(2a)') '/PLOT-lmargin ', def0 write(outstr,'(2a)') '/PLOT-rmargin ', def0 write(outstr,'(2a)') '/PLOT-tmargin ', def0 write(outstr,'(2a)') '/PROC ', def0 write(outstr,'(2a)') '/ROW ', def0 write(outstr,'(2a)') '/TXT ', def0 write(outstr,'(2a)') '/WPAGE ', def0 write(outstr,'(2a)') '/X-COORD ', def0 write(outstr,'(2a)') '/XDX ', def0 write(outstr,'(2a)') '/XOFF ', def0 write(outstr,'(2a)') '/XPARTS ', def0 write(outstr,'(2a)') '/XRNG ', def0 write(outstr,'(2a)') '/XSCL ', def0 write(outstr,'(2a)') '/XSTEP ', def0 write(outstr,'(2a)') '/XSTEPH ', def0 write(outstr,'(2a)') '/XTSCL ', def0 write(outstr,'(2a)') '/XWID ', def0 write(outstr,'(2a)') '/Y-COORD ', def0 write(outstr,'(2a)') '/YDX ', def0 write(outstr,'(2a)') '/YHIT ', def0 write(outstr,'(2a)') '/YOFF ', def0 write(outstr,'(2a)') '/YPARTS ', def0 write(outstr,'(2a)') '/YRNG ', def0 write(outstr,'(2a)') '/YSCL ', def0 write(outstr,'(2a)') '/YSTEP ', def0 write(outstr,'(2a)') '/YSTEPH ', def0 write(outstr,'(2a)') '/YTSCL ', def0 write(outstr,'(2a)') '/graphrect ', def0 write(outstr,'(2a)') '/plotrect ', def0 write(outstr,'(a)') '% Here are the procedure-arrays for passing as the third argument to' write(outstr,'(a)') '% plot-column. Plot-column moves to the first coordinate before' write(outstr,'(a)') '% calls to the first procedure. Thus both line and scatter graphs are' write(outstr,'(a)') '% supported. Many additional glyph types can be produced as' write(outstr,'(a)') '% combinations of these types. This is best accomplished by calling' write(outstr,'(a)') '% plot-column with each component.' write(outstr,'(a)') '% GD and GR are the graphic-glyph diameter and radius.' write(outstr,'(a)') '% DIAG and DIAG2, used in /cross are diagonal and twice diagonal.' write(outstr,'(a)') '% gtrans maps x, y coordinates on the stack to 72dpi page coordinates.' write(outstr,'(a)') '% Render line connecting points' write(outstr,'(a)') '/line [{} {lineto} {}] bind def' write(outstr,'(a)') '/mountain [{currentpoint 2 copy pop bottomedge moveto lineto}' write(outstr,'(a)') ' {lineto}' write(outstr,'(a)') ' {currentpoint pop bottomedge lineto closepath fill}] bind def' write(outstr,'(a)') '/cloud [{currentpoint 2 copy pop topedge moveto lineto}' write(outstr,'(a)') ' {lineto}' write(outstr,'(a)') ' {currentpoint pop topedge lineto closepath fill}] bind def' write(outstr,'(a)') '% Render lines from x-axis to points' write(outstr,'(a)') '/impulse [{} {moveto XRNG 0 get 0 gtrans exch pop' write(outstr,'(a)') ' currentpoint pop exch lineto} {}] bind def' write(outstr,'(a)') '/bargraph [{} {exch GR sub exch dup' write(outstr,'(a)') ' XRNG 0 get 0 gtrans exch pop % y=0' write(outstr,'(a)') ' exch sub GD exch rectstroke} {}] bind def' write(outstr,'(a)') '% Solid round dot.' write(outstr,'(a)') '/disc [{GD setlinewidth 1 setlinecap}' write(outstr,'(a)') ' {moveto 0 0 rlineto} {}] bind def' write(outstr,'(a)') '% Minimal point -- invisible if linewidth is 0.' write(outstr,'(a)') '/point [{1 setlinecap} {moveto 0 0 rlineto} {}] bind def' write(outstr,'(a)') '% Square box.' write(outstr,'(a)') '/square [{} {GR sub exch GR sub exch GD dup rectstroke} {}] bind def' write(outstr,'(a)') '% Square box at 45.o' write(outstr,'(a)') '/diamond [{}' write(outstr,'(a)') ' {2 copy GR add moveto' write(outstr,'(a)') ' GR neg GR neg rlineto GR GR neg rlineto' write(outstr,'(a)') ' GR GR rlineto GR neg GR rlineto' write(outstr,'(a)') ' closepath}' write(outstr,'(a)') ' {}] bind def' write(outstr,'(a)') '% Plus Sign' write(outstr,'(a)') '/plus [{}' write(outstr,'(a)') ' { GR sub moveto 0 GD rlineto' write(outstr,'(a)') ' GR neg GR neg rmoveto GD 0 rlineto}' write(outstr,'(a)') ' {}] bind def' write(outstr,'(a)') '% X Sign' write(outstr,'(a)') '/cross [{/DIAG GR .707 mul def /DIAG2 DIAG 2 mul def}' write(outstr,'(a)') ' {exch DIAG sub exch DIAG add moveto DIAG2 dup neg rlineto' write(outstr,'(a)') ' DIAG2 neg 0 rmoveto DIAG2 dup rlineto}' write(outstr,'(a)') ' {}] bind def' write(outstr,'(a)') '% Triangle pointing upward' write(outstr,'(a)') '/triup [{}' write(outstr,'(a)') ' {GR 1.12 mul add moveto GR neg GR -1.62 mul rlineto' write(outstr,'(a)') ' GR 2 mul 0 rlineto GR neg GR 1.62 mul rlineto' write(outstr,'(a)') ' closepath}' write(outstr,'(a)') ' {}] bind def' write(outstr,'(a)') '% Triangle pointing downward' write(outstr,'(a)') '/tridown [{}' write(outstr,'(a)') ' {GR 1.12 mul sub moveto GR neg GR 1.62 mul rlineto' write(outstr,'(a)') ' GR 2 mul 0 rlineto GR neg GR -1.62 mul rlineto' write(outstr,'(a)') ' closepath}' write(outstr,'(a)') ' {}] bind def' write(outstr,'(a)') '/pentagon [{}' write(outstr,'(a)') ' {gsave translate 0 GR moveto 4 {72 rotate 0 GR lineto} repeat' write(outstr,'(a)') ' closepath stroke grestore}' write(outstr,'(a)') ' {}] bind def' write(outstr,'(a)') '/circle [{stroke} {GR 0 360 arc stroke} {}] bind def' write(outstr,'(a)') '% ( TITLE ) ( SUBTITLE )' write(outstr,'(a)') '/title-top' write(outstr,'(a)') '{ dup stringwidth pop -2 div plotrect 0 get plotrect 2 get 2 div add add' write(outstr,'(a)') ' plotrect 1 get plotrect 3 get add pointsize .4 mul add moveto show' write(outstr,'(a)') ' dup stringwidth pop -2 div plotrect 0 get plotrect 2 get 2 div add add' write(outstr,'(a)') ' plotrect 1 get plotrect 3 get add pointsize 1.4 mul add moveto show' write(outstr,'(a)') '} bind def' write(outstr,'(a)') '% ( TITLE ) ( SUBTITLE )' write(outstr,'(a)') '/title-bottom' write(outstr,'(a)') '{ dup stringwidth pop -2 div plotrect 0 get plotrect 2 get 2 div add add' write(outstr,'(a)') ' plotrect 1 get pointsize -2 mul add moveto show' write(outstr,'(a)') ' dup stringwidth pop -2 div plotrect 0 get plotrect 2 get 2 div add add' write(outstr,'(a)') ' plotrect 1 get pointsize -1 mul add moveto show' write(outstr,'(a)') '} bind def' write(outstr,'(a)') '% Plots column K against column J of given two-dimensional ARRAY.' write(outstr,'(a)') '% The arguments are:' write(outstr,'(a)') '% [ ARRAY J K ] J and K are column-indexes into ARRAY' write(outstr,'(a)') '% [ PREAMBLE RENDER POSTAMBLE ] Plotting procedures:' write(outstr,'(a)') '% PREAMBLE - Executed once before plotting row' write(outstr,'(a)') '% RENDER - Called with each pair of coordinates to plot' write(outstr,'(a)') '% POSTAMBLE - Called once after plotting row (often does stroke)' write(outstr,'(a)') '/plot-column' write(outstr,'(a)') '{ /GPROCS exch def aload pop /YDX exch def /XDX exch def /DATA exch def' write(outstr,'(a)') ' /GD glyphsize def' write(outstr,'(a)') ' /GR GD .5 mul def' write(outstr,'(a)') ' gsave' write(outstr,'(a)') ' /ROW DATA 0 get def ROW XDX get ROW YDX get gtrans moveto' write(outstr,'(a)') ' GPROCS 0 get exec % preamble' write(outstr,'(a)') ' /PROC GPROCS 1 get def DATA {dup XDX get exch YDX get gtrans PROC} forall' write(outstr,'(a)') ' GPROCS 2 get exec stroke % postamble' write(outstr,'(a)') ' grestore' write(outstr,'(a)') '} bind def' write(outstr,'(a)') '/partition-page' write(outstr,'(a)') '{ /YPARTS exch def /XPARTS exch def /WPAGE exch def' write(outstr,'(a)') ' /XWID WPAGE 2 get XPARTS div def /YHIT WPAGE 3 get YPARTS div def' write(outstr,'(a)') ' /Y-COORD WPAGE 1 get def' write(outstr,'(a)') ' YPARTS' write(outstr,'(a)') ' { /X-COORD WPAGE 0 get WPAGE 2 get add XWID sub def' write(outstr,'(a)') ' XPARTS {[X-COORD Y-COORD XWID YHIT]' write(outstr,'(a)') ' /X-COORD X-COORD XWID sub def} repeat' write(outstr,'(a)') ' /Y-COORD Y-COORD YHIT add def' write(outstr,'(a)') ' } repeat' write(outstr,'(a)') '} bind def' write(outstr,'(a)') '% The arguments are:' write(outstr,'(a)') '% [ MIN-X MIN-Y DELTA-X DELTA-Y ] whole graph rectangle' write(outstr,'(a)') '% [ MIN-COLJ MAX-COLJ ] Numerical range of plot data' write(outstr,'(a)') '% [ MIN-COLK MAX-COLK ] Numerical range of plot data' write(outstr,'(a)') '% and the implicit current clippath' write(outstr,'(a)') '/setup-plot' write(outstr,'(a)') '{ /YRNG exch def /XRNG exch def /graphrect exch def' write(outstr,'(a)') ' /PLOT-bmargin pointsize 2.4 mul def' write(outstr,'(a)') ' /PLOT-tmargin pointsize 2.4 mul def' write(outstr,'(a)') ' /PLOT-lmargin lmargin-template stringwidth pop pointsize 1.2 mul add def' write(outstr,'(a)') ' /PLOT-rmargin rmargin-template stringwidth pop pointsize 1.2 mul add def' write(outstr,'(a)') ' /plotrect [ graphrect 0 get PLOT-lmargin add' write(outstr,'(a)') ' graphrect 1 get PLOT-bmargin add' write(outstr,'(a)') ' graphrect 2 get PLOT-lmargin sub PLOT-rmargin sub' write(outstr,'(a)') ' graphrect 3 get PLOT-bmargin sub PLOT-tmargin sub ] def' write(outstr,'(a)') ' /XOFF XRNG 0 get def /YOFF YRNG 0 get def' write(outstr,'(a)') ' /XSCL plotrect 2 get XRNG aload pop exch sub div def' write(outstr,'(a)') ' /YSCL plotrect 3 get YRNG aload pop exch sub div def' write(outstr,'(a)') ' /XOFF XOFF plotrect 0 get XSCL div sub def' write(outstr,'(a)') ' /YOFF YOFF plotrect 1 get YSCL div sub def' write(outstr,'(a)') ' /YTSCL plotrect 3 get YRNG aload pop exch sub find-tick-scale def' write(outstr,'(a)') ' /YSTEP YTSCL 0 get 3 mod 0 eq {6} {8} ifelse 5 mul yuntrans def' write(outstr,'(a)') ' /XTSCL plotrect 2 get XRNG aload pop exch sub find-tick-scale def' write(outstr,'(a)') ' /XSTEP XTSCL 0 get 3 mod 0 eq {12} {10} ifelse 5 mul xuntrans def' write(outstr,'(a)') ' /YSTEPH YSTEP 2 div def' write(outstr,'(a)') ' /XSTEPH XSTEP 2 div def' write(outstr,'(a)') '} bind def' write(outstr,'(a)') '% gtrans is the utility routine mapping data coordinates to view space.' write(outstr,'(a)') '% plot-column sets up XOFF, XSCL, and YSCL and uses it.' write(outstr,'(a)') '/gtrans {exch XOFF sub XSCL mul exch YOFF sub YSCL mul} bind def' write(outstr,'(a)') '%/guntrans {exch XSCL div XOFF add exch YSCL div YOFF add} bind def' write(outstr,'(a)') '% /ytrans {YTSCL aload pop div mul} bind def' write(outstr,'(a)') '% /xtrans {XTSCL aload pop div mul} bind def' write(outstr,'(a)') '/yuntrans {YTSCL aload pop exch div mul} bind def' write(outstr,'(a)') '/xuntrans {XTSCL aload pop exch div mul} bind def' write(outstr,'(a)') '/zero-in-range? {dup 0 get 0 le exch 1 get 0 ge and} bind def' write(outstr,'(a)') '/y-axis' write(outstr,'(a)') '{ XRNG zero-in-range?' write(outstr,'(a)') ' { 0 YRNG 0 get gtrans moveto 0 YRNG 1 get gtrans lineto stroke} if' write(outstr,'(a)') '} bind def' write(outstr,'(a)') '/x-axis' write(outstr,'(a)') '{ YRNG zero-in-range?' write(outstr,'(a)') ' {XRNG 0 get 0 gtrans moveto XRNG 1 get 0 gtrans lineto stroke} if' write(outstr,'(a)') '} bind def' write(outstr,'(a)') '% Find data range in column K of two-dimensional ARRAY.' write(outstr,'(a)') '% ARRAY' write(outstr,'(a)') '% K is the column-index into ARRAY' write(outstr,'(a)') '/column-range' write(outstr,'(a)') '{ /IDX exch def dup /MIN exch 0 get IDX get def /MAX MIN def' write(outstr,'(a)') ' {IDX get dup dup MIN lt {/MIN exch def} {pop} ifelse' write(outstr,'(a)') ' dup MAX gt {/MAX exch def} {pop} ifelse} forall' write(outstr,'(a)') ' [MIN MAX]' write(outstr,'(a)') '} bind def' write(outstr,'(a)') '/min {2 copy lt {pop} {exch pop} ifelse} bind def' write(outstr,'(a)') '/max {2 copy gt {pop} {exch pop} ifelse} bind def' write(outstr,'(a)') '/combine-ranges' write(outstr,'(a)') '{ aload pop 3 2 roll aload pop exch 4 3 roll min 3 1 roll max 2 array astore}' write(outstr,'(a)') 'bind def' write(outstr,'(a)') '/pad-range' write(outstr,'(a)') '{ exch aload pop /MAX exch def /MIN exch def' write(outstr,'(a)') ' /EXPSN exch 100 div MAX MIN sub mul def' write(outstr,'(a)') ' [ MIN EXPSN sub MAX EXPSN add ]' write(outstr,'(a)') '} bind def' write(outstr,'(a)') '/snap-range' write(outstr,'(a)') '{dup aload pop exch sub 1 exch find-tick-scale aload pop' write(outstr,'(a)') ' /DEN exch def /NUM exch def 1 NUM div DEN mul /DLTA exch def' write(outstr,'(a)') ' aload pop /MAX exch def /MIN exch def' write(outstr,'(a)') ' [ DLTA MAX MIN sub sub 2 div dup MIN exch sub exch MAX add ]' write(outstr,'(a)') '} bind def' write(outstr,'(a)') '% Given the width (or height) and the data-span, returns an array of' write(outstr,'(a)') '% numerator and denominator (NUM DEN)' write(outstr,'(a)') '%' write(outstr,'(a)') '% NUM will be 1, 2, 3, 4, 5, 6, or 8 times a power of ten.' write(outstr,'(a)') '% DEN will be a power of ten.' write(outstr,'(a)') '%' write(outstr,'(a)') '% NUM ISIZ' write(outstr,'(a)') '% === < ====' write(outstr,'(a)') '% DEN DLTA' write(outstr,'(a)') '/find-tick-scale' write(outstr,'(a)') '{/DLTA exch def /ISIZ exch def' write(outstr,'(a)') ' /DEN 1 def' write(outstr,'(a)') ' {DLTA ISIZ le {exit} if /DEN DEN 10 mul def /ISIZ ISIZ 10 mul def} loop' write(outstr,'(a)') ' /NUM 1 def' write(outstr,'(a)') ' {DLTA 10 mul ISIZ ge {exit} if /NUM NUM 10 mul def /DLTA DLTA 10 mul def} loop' write(outstr,'(a)') ' [[8 6 5 4 3 2 1] {/MAX exch def MAX DLTA mul ISIZ le {MAX exit} if} forall' write(outstr,'(a)') ' NUM mul DEN]' write(outstr,'(a)') '} bind def' write(outstr,'(a)') '/rule-vertical' write(outstr,'(a)') '{ /XWID exch def' write(outstr,'(a)') ' /TXT exch def' write(outstr,'(a)') ' /X-COORD exch def' write(outstr,'(a)') ' X-COORD type [] type eq {/X-COORD X-COORD 0 get def} if' write(outstr,'(a)') ' gsave' write(outstr,'(a)') ' X-COORD plotrect 1 get plotrect 3 get 2 div add translate' write(outstr,'(a)') ' TXT stringwidth pop -2 div' write(outstr,'(a)') ' XWID 0 gt { 90 rotate PLOT-lmargin} {-90 rotate PLOT-rmargin} ifelse' write(outstr,'(a)') ' pointsize 1.2 mul sub moveto TXT show' write(outstr,'(a)') ' grestore' write(outstr,'(a)') ' YRNG 0 get YSTEP div ceiling YSTEP mul YSTEP YRNG 1 get' write(outstr,'(a)') ' { /YDX exch def 0 YDX gtrans /Y-COORD exch def pop' write(outstr,'(a)') ' X-COORD Y-COORD moveto XWID 0 rlineto stroke' write(outstr,'(a)') ' /TXT YDX 20 string cvs def' write(outstr,'(a)') ' X-COORD' write(outstr,'(a)') ' XWID 0 gt {TXT stringwidth pop sub ( ) stringwidth pop sub' write(outstr,'(a)') ' Y-COORD pointsize .3 mul sub moveto}' write(outstr,'(a)') ' {Y-COORD pointsize .3 mul sub moveto ( ) show} ifelse' write(outstr,'(a)') ' TXT show} for' write(outstr,'(a)') ' YRNG 0 get YSTEPH div ceiling YSTEPH mul YSTEPH YRNG 1 get' write(outstr,'(a)') ' { /YDX exch def 0 YDX gtrans /Y-COORD exch def pop' write(outstr,'(a)') ' X-COORD Y-COORD moveto XWID 2 div 0 rlineto stroke} for' write(outstr,'(a)') '} bind def' write(outstr,'(a)') '/rule-horizontal' write(outstr,'(a)') '{ /YHIT exch def' write(outstr,'(a)') ' /TXT exch def' write(outstr,'(a)') ' /Y-COORD exch def' write(outstr,'(a)') ' Y-COORD type [] type eq {/Y-COORD Y-COORD 1 get def} if' write(outstr,'(a)') ' plotrect 0 get plotrect 2 get 2 div add TXT stringwidth pop -2 div add' write(outstr,'(a)') ' Y-COORD' write(outstr,'(a)') ' YHIT 0 gt {pointsize -2 mul} {pointsize 1.4 mul} ifelse add moveto TXT show' write(outstr,'(a)') ' XRNG 0 get XSTEP div ceiling XSTEP mul XSTEP XRNG 1 get' write(outstr,'(a)') ' { dup 0 gtrans pop /X-COORD exch def' write(outstr,'(a)') ' X-COORD Y-COORD moveto 0 YHIT rlineto stroke' write(outstr,'(a)') ' /TXT exch 10 string cvs def' write(outstr,'(a)') ' X-COORD TXT stringwidth pop 2.0 div sub' write(outstr,'(a)') ' Y-COORD YHIT 0 gt {pointsize sub} {pointsize .3 mul add} ifelse' write(outstr,'(a)') ' moveto TXT show' write(outstr,'(a)') ' } for' write(outstr,'(a)') ' XRNG 0 get XSTEPH div ceiling XSTEPH mul XSTEPH XRNG 1 get' write(outstr,'(a)') ' { 0 gtrans pop Y-COORD moveto 0 YHIT 2 div rlineto stroke} for' write(outstr,'(a)') '} bind def' write(outstr,'(a)') '/grid-verticals' write(outstr,'(a)') '{ XRNG 0 get XSTEPH div ceiling XSTEPH mul XSTEPH XRNG 1 get' write(outstr,'(a)') ' { 0 gtrans pop /X-COORD exch def' write(outstr,'(a)') ' X-COORD plotrect 1 get moveto 0 plotrect 3 get rlineto} for' write(outstr,'(a)') ' stroke' write(outstr,'(a)') '} bind def' write(outstr,'(a)') '/grid-horizontals' write(outstr,'(a)') '{ YRNG 0 get YSTEPH div ceiling YSTEPH mul YSTEPH YRNG 1 get' write(outstr,'(a)') ' { 0 exch gtrans /Y-COORD exch def pop' write(outstr,'(a)') ' plotrect 0 get Y-COORD moveto plotrect 2 get 0 rlineto} for' write(outstr,'(a)') ' stroke' write(outstr,'(a)') '} bind def' write(outstr,'(a)') '/leftedge {plotrect 0 get} bind def' write(outstr,'(a)') '/rightedge {plotrect dup 0 get exch 2 get add} bind def' write(outstr,'(a)') '/topedge {plotrect dup 1 get exch 3 get add} bind def' write(outstr,'(a)') '/bottomedge {plotrect 1 get} bind def' write(outstr,'(a)') '/outline-rect {aload pop rectstroke} bind def' write(outstr,'(a)') '/fill-rect {aload pop rectfill} bind def' write(outstr,'(a)') '/clip-to-rect {aload pop rectclip} bind def' write(outstr,'(a)') '/gstack [] def' write(outstr,'(a)') '/gpush {gsave /gstack [ gstack pointsize glyphsize ] def} bind def' write(outstr,'(a)') '/gpop {/gstack gstack aload pop /glyphsize exch def /pointsize exch def def grestore} bind def' write(outstr,'(a)') '% Default parameters' write(outstr,'(a)') '% The legend-templates are strings used to reserve horizontal space' write(outstr,'(a)') '/lmargin-template (-.0123456789) def' write(outstr,'(a)') '/rmargin-template (-.0123456789) def' write(outstr,'(a)') '% glyphsize is the graphic-glyph size; GR, graphic radius, is' write(outstr,'(a)') '% glyphsize/2. Line width, set by "setlinewidth", must be much less' write(outstr,'(a)') '% than glyphsize for readable glyphs.' write(outstr,'(a)') '/glyphsize 6 def' write(outstr,'(a)') '% pointsize is the height of text characters in "points", 1/72 inch; 0.353.mm' write(outstr,'(a)') '/pointsize 12 def' write(outstr,'(a)') '% Set default font' write(outstr,'(a)') '/Helvetica pointsize selectfont' write(outstr,'(a)') 'gsave' end subroutine pre_grapheps ! ! Draw simple plot ! ! typ 1=scatterplot 2=jittered dotplot 3=mountain 4=bargraph ! 10=square Q-Q plot ! subroutine xy_grapheps(outstr, nvals, xvals, yvals, & xlab, ylab, title, gstyle, gratio, typ) use rngs integer, intent(in) :: outstr integer, intent(in) :: nvals double precision, dimension(nvals), intent(inout) :: xvals, yvals character (len=*), intent(in) :: xlab, ylab, title character (len=*), intent(in) :: gstyle double precision, intent(in) :: gratio integer, intent(in) :: typ ! integer :: i, linewidth character (len=len(gstyle)) :: style double precision :: rang, xmin, xmax, ymin, ymax integer :: xwid, ywid linewidth=1 style=gstyle ywid=500 xwid=int(gratio*dble(ywid)) if (style==' ') style='point' xmax=-1.0d99 xmin=+1.0d99 ymax=-1.0d99 ymin=+1.0d99 do i=1, nvals xmin=min(xmin, xvals(i)) xmax=max(xmax, xvals(i)) ymin=min(ymin, yvals(i)) ymax=max(ymax, yvals(i)) end do if (typ == 10) then xmax=max(ymax, xmax) ymax=xmax xmin=min(ymin, xmin) ymin=xmin linewidth=2 if (nvals < 50000) linewidth=5 end if rang=xmax-xmin ! jitter if (typ == 2) then do i=1, nvals xvals(i)=xvals(i)+dble(0.1*(random()-0.5)) end do xmax=xmax+1.0d0 xmin=xmin-1.0d0 else if (typ == 4) then xmax=xmax+0.1d0*rang xmin=xmin-0.1d0*rang else xmax=xmax+0.03d0*rang xmin=xmin-0.03d0*rang end if rang=ymax-ymin ymax=ymax+0.03d0*rang ymin=ymin-0.03d0*rang if (typ == 3) then ymin=0.0d0 ymax=max(4.0d0, ymax) else if (typ == 4) then ymin=0.0d0 end if call pre_grapheps(outstr, xwid, ywid) if (typ == 2) then write(outstr,'(a)') '/vlines', '[' write(outstr,*) '[', 1, 2, ymin, ']' write(outstr,*) '[', 1, 2, ymax, ']' write(outstr,'(a)') '] def' else if (typ == 4) then write(outstr,*) '/glyphsize', 320/nvals, ' def' else if (typ == 10) then write(outstr,'(a)') '/identity', '[' write(outstr,*) '[', xmin, ymin, ']' write(outstr,*) '[', xmax, ymax, ']' write(outstr,'(a)') '] def' end if write(outstr,'(a)') '/Data', '[' do i=1, nvals write(outstr,*) '[', xvals(i), yvals(i), ']' end do write(outstr,'(a)') '] def' write(outstr,*) 'whole-page [ ', xmin, xmax, ' ] [', ymin, ymax, '] setup-plot' if (typ /= 4) then write(outstr,*) & '(', trim(title), ') (', trim(ylab) ,' versus ', trim(xlab),') title-top' else write(outstr,*) & '(Frequency bargraph for "', trim(xlab),'") (', trim(title), ') title-top' end if write(outstr,'(a)') 'plotrect outline-rect' write(outstr,*) 'leftedge (', ylab, ') 5 rule-vertical' write(outstr,'(a)') 'gpush' write(outstr,'(a)') 'plotrect clip-to-rect' if (trim(style) == 'mountain') then write(outstr,'(a)') '.9 .9 .9 setrgbcolor' end if write(outstr,'(i0,a)') linewidth, ' setlinewidth' write(outstr,'(3a)') '[ Data 0 1 ] ', trim(style), ' plot-column' write(outstr,'(a)') '1 setlinewidth' write(outstr,'(a)') 'gpop' write(outstr,*) 'bottomedge (', trim(xlab), ') 5 rule-horizontal' ! Vertical guidelines at "n" and "y" if (typ == 2) then write(outstr,'(a)') 'gpush', '[ 5 2 ] 0 setdash', '.9 .9 .9 setrgbcolor' write(outstr,'(a)') '[ vlines 0 2 ] line plot-column' write(outstr,'(a)') '[ vlines 1 2 ] line plot-column', 'gpop' ! Line of identity else if (typ == 10) then write(outstr,'(a)') 'gpush', '[ 5 2 ] 0 setdash', '.9 .9 .9 setrgbcolor' write(outstr,'(a)') '[ identity 0 1 ] line plot-column', 'gpop' end if ! write(outstr,'(a)') 'grestore', 'end', 'showpage' end subroutine xy_grapheps ! ! Draw scatterplot with different glyphs for each category ! subroutine scatter_grapheps(outstr, nvals, symbols, xvals, yvals, & slab, xlab, ylab, title, gratio) integer, intent(in) :: outstr integer, intent(in) :: nvals integer, dimension(nvals), intent(inout) :: symbols double precision, dimension(nvals), intent(inout) :: xvals, yvals character (len=*), intent(in) :: slab, xlab, ylab, title double precision, intent(in) :: gratio ! integer :: i double precision :: rang, xmin, xmax, ymin, ymax integer :: xwid, ywid integer, dimension(10) :: slevels character (len=8), dimension(10) :: style = (/ & 'circle ', 'disc ', 'square ', 'triup ', 'plus ', & 'diamond ', 'cross ', 'pentagon', 'tridown ', 'point ' /) ywid=500 xwid=int(gratio*dble(ywid)) xmax=-1.0d99 xmin=+1.0d99 ymax=-1.0d99 ymin=+1.0d99 do i=1, nvals xmin=min(xmin, xvals(i)) xmax=max(xmax, xvals(i)) ymin=min(ymin, yvals(i)) ymax=max(ymax, yvals(i)) end do rang=xmax-xmin xmax=xmax+0.03d0*rang xmin=xmin-0.03d0*rang rang=ymax-ymin ymax=ymax+0.03d0*rang ymin=ymin-0.03d0*rang call pre_grapheps(outstr, xwid, ywid) do j=1, 10 slevels(j)=0 write(outstr,'(a,i0/a)') '/Data', j, '[' do i=1, nvals if (symbols(i) == j) then slevels(j)=slevels(j)+1 write(outstr,*) '[', xvals(i), yvals(i), ']' end if end do write(outstr,'(a)') '] def' end do write(outstr,*) & 'whole-page [ ', xmin, xmax, ' ] [', ymin, ymax, '] setup-plot' write(outstr,*) & '(', trim(title), ') ("', trim(ylab) ,'" versus "', trim(xlab), & '" \(symbol type represents "', trim(slab), '"\) ) title-top' write(outstr,'(a)') 'plotrect outline-rect' write(outstr,*) 'leftedge (', ylab, ') 5 rule-vertical' write(outstr,'(a)') 'gpush' write(outstr,'(a)') 'plotrect clip-to-rect' do j=1, 10 if (slevels(j) > 0) then write(outstr,'(a,i0,3a)') & '[ Data', j, ' 0 1 ] ', trim(style(j)), ' plot-column' end if end do write(outstr,'(a)') 'gpop' write(outstr,*) 'bottomedge (', trim(xlab), ') 5 rule-horizontal' write(outstr,'(a)') 'grestore', 'end', 'showpage' end subroutine scatter_grapheps end module grapheps ! ! Tools to use system dictionary ! module wordtools use locstring_widths use idhash_class type dict_data logical :: current=.false. #if TERMUX character(len=256) :: & dictfil='/data/data/com.termux/files/usr/share/dict/words_alpha.txt' integer :: nwordlist=370105 #else character(len=256) :: dictfil='/usr/share/dict/words_alpha.txt' integer :: nwordlist=370104 #endif character(len=loc_width), dimension(:), allocatable :: wordlist integer, dimension(:), allocatable :: wordidx logical :: sorted=.false. integer, dimension(27) :: first_letter ! Hash table for words type (hash_table) :: wordhash end type dict_data type (dict_data) :: dictionary contains subroutine readdict(dictionary, ioerr) use outstream use idhash_class type (dict_data) :: dictionary integer, intent(out) :: ioerr integer :: TWRK=7 integer :: i, j, nw character(len=1) :: ch ioerr=0 open(TWRK,file=dictionary%dictfil,status='old', iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(dictionary%dictfil), '"' return end if nw=dictionary%nwordlist if (nw < 1) then nw=0 do read(TWRK,'(a)', iostat=ioerr) ch if (ioerr /= 0) exit nw=nw+1 end do rewind(TWRK) end if dictionary%nwordlist=nw if (allocated(dictionary%wordlist)) then deallocate(dictionary%wordlist, dictionary%wordidx) end if allocate(dictionary%wordlist(nw), & dictionary%wordidx(nw)) do i=1, nw read(TWRK,'(a)') dictionary%wordlist(i) end do call setup_hash(HK_ID, nw, dictionary%wordhash, 90) call fill_hash(dictionary%wordhash, dictionary%wordlist) dictionary%current=.true. dictionary%sorted=.true. do i=2, nw if (dictionary%wordlist(i) < dictionary%wordlist(i-1)) then dictionary%sorted=.false. exit end if end do if (dictionary%sorted) then dictionary%first_letter(1)=1 dictionary%first_letter(27)=nw ch='b' j=2 do i=1, nw if (dictionary%wordlist(i)(1:1) == ch) then dictionary%first_letter(j)=i j=j+1 ch=achar(96+j) end if end do end if end subroutine readdict ! ! Sort letters of word ! function order_letters(word) use sorts character(len=*) :: word character(len=1), dimension(len(word)) :: letters integer, dimension(len(word)) :: idx character(len=len(word)) :: order_letters integer :: i, nc nc=len_trim(word) do i=1, nc letters(i)=word(i:i) end do call csort(nc, letters, idx) do i=1, nc order_letters(i:i)=letters(i) end do end function order_letters ! ! Legal anagrams of word and subwords ! subroutine anagrams(word, letter, shortest, noplurals, dictionary, plevel) use outstream use combinatorics use idhash_class character(len=*) :: word character(len=1) :: letter integer, intent(in) :: shortest logical, intent(in) :: noplurals type (dict_data) :: dictionary integer, intent(in) :: plevel integer :: iaddress, ioerr, nc, nw, ssize ! work variables for nxtksb and nexper integer :: h, m2, nm3 logical :: checkperm, elig, even, more, mtc integer, dimension(:), allocatable :: a, b character(len=len(word)) :: candidate nc=len_trim(word) if (nc == 0 .or. nc < shortest) return if (.not.dictionary%current) then call readdict(dictionary, ioerr) if (ioerr /= 0) return end if dictionary%wordidx=0 allocate(a(nc), b(nc)) even=.false. nw=0 if (plevel > 0) then write(*,'(3a,i0,3a)') 'Target="', word(1:nc), & '" subset length >=', shortest, ' letter to contain="', letter, '"' end if ! Loop through different size subsets (N..4) do ssize=nc, shortest, -1 if (plevel > 0) then write(outstr,'(a,i0)') 'Subsets of size ', ssize end if ii=0 more=.false. 10 continue ii=ii+1 call nexksb(nc, ssize, a, more, h, m2) checkperm=.true. if (letter /= ' ') then do i=1, ssize candidate(i:i) = word(a(i):a(i)) end do checkperm=index(candidate(1:ssize), letter) > 0 end if if (checkperm) then mtc=.false. jj=0 110 continue jj=jj+1 call nexper(ssize, b, mtc, even, nm3) if (b(1) /= 0) then do i=1, ssize candidate(i:i) = word(a(b(i)):a(b(i))) end do elig=.true. if (noplurals) then elig=.not.(candidate(ssize:ssize) == 's' .and. & index('siu', candidate((ssize-1):(ssize-1))) == 0) end if if (elig) then call find_hashtab(candidate(1:ssize), dictionary%wordlist, & dictionary%wordhash, iaddress) if (iaddress > 0) then if (dictionary%wordidx(iaddress) == 0) then nw=nw+1 if (plevel > 0) then write(outstr,'(i0,1x)', advance='no') nw end if write(outstr,'(a)') candidate(1:ssize) dictionary%wordidx(iaddress)=1 end if end if end if end if if (mtc) goto 110 end if if (more) goto 10 end do end subroutine anagrams ! ! Legal multiword anagrams of a set of letters ! ! Need to recursively go through words ! ie subsets size w1 for first word ! then subsets size w2 of remaining letters... ! subroutine ana_each(word, dictionary, plevel) use interrupt use outstream use combinatorics use idhash_class character(len=*), intent(in) :: word type (dict_data) :: dictionary integer, intent(in) :: plevel integer :: cursize, i, j, k, nc, nlet, nw, nextss, nwords, ssize integer, dimension(:), allocatable :: restlen, wordlen, w1, w2, w3 integer, dimension(:,:), allocatable :: a, b, ibounds logical, dimension(:), allocatable :: even, more, mtc character(len=len(word)) :: candidate, words character(len=len(word)), dimension(:), allocatable :: thisword logical :: inword, novel nc=len_trim(word) if (nc == 0) return if (.not.dictionary%current) then call readdict(dictionary, ioerr) if (ioerr /= 0) return end if allocate(ibounds(nc,2)) nlet=0 words='' nwords=0 ibounds=0 inword=.false. do i=1, nc if (word(i:i) == '/' .or. word(i:i) == ' ') then inword=.false. else nlet=nlet+1 words(nlet:nlet)=word(i:i) if (.not.inword) then nwords=nwords+1 ibounds(nwords,1)=nlet end if ibounds(nwords,2)=nlet inword=.true. end if end do allocate(thisword(nwords)) allocate(a(nwords,nlet), b(nwords, nlet)) allocate(wordlen(nwords), restlen(nwords)) allocate(w1(nwords), w2(nwords), w3(nwords)) allocate(even(nwords), more(nwords), mtc(nwords)) do j=1, nwords wordlen(j)=ibounds(j,2)-ibounds(j,1)+1 end do restlen(nwords)=0 do j=nwords-1, 1, -1 restlen(j)=restlen(j+1)+wordlen(j) end do ! ! generate the next subset of letters for the 1st word nw=0 ilev=1 thisword='' thisword(ilev)=words ! ! recursively generate the next subset of letters for the current word ! dictionary%wordidx=0 more=.false. 5 continue if (irupt /= 0) return dictionary%wordidx=ibclr(dictionary%wordidx,ilev) ssize=wordlen(ilev) cursize=ssize+restlen(ilev) 10 continue call nexksb(cursize, ssize, a(ilev,1:nlet), more(ilev), w1(ilev), w2(ilev)) mtc(ilev)=.false. ! permute that subset fact(ssize) times 110 continue call nexper(ssize, b(ilev,1:nlet), mtc(ilev), even(ilev), w3(ilev)) ! if this permutation a known word, recurse to do the next subset call known_subset(ilev, thisword(ilev), a(ilev,1:cursize), b(ilev,1:ssize), dictionary, novel) if (novel) then ! either push stack and anagrammatize next word if (ilev < nwords) then call other_letters(ssize, a(ilev,1:cursize), b(ilev,1:cursize), cursize, & thisword(ilev), thisword(ilev+1)) ilev=ilev+1 goto 5 ! or print words else nw=nw+1 nlet=0 do j=1, nwords do i=1, wordlen(j) nlet=nlet+1 k=a(j, b(j,i)) candidate(nlet:nlet)=thisword(j)(k:k) end do if (j < nwords) then nlet=nlet+1 candidate(nlet:nlet)=' ' end if end do if (plevel > 0) then write(outstr,'(i0,1x)', advance='no') nw end if write(outstr,'(a)') candidate(1:nlet) end if end if if (mtc(ilev)) goto 110 if (more(ilev)) goto 10 do ilev=ilev-1 if (ilev > 0) then if (more(ilev)) goto 5 else exit end if end do end subroutine ana_each ! ! subroutine other_letters(na, a, b, wlen, word, complement) use combinatorics use idhash_class integer, intent(in) :: na, wlen character(len=*) :: word, complement integer, dimension(:), intent(in) :: a, b integer :: i, j, k, n j=0 n=0 scan: do while (n < wlen) j=j+1 do i=1, na if (j == a(b(i))) cycle scan end do n=n+1 complement(n:n)=word(j:j) end do scan end subroutine other_letters ! subroutine known_subset(ilev, word, a, b, dictionary, novel) use combinatorics use idhash_class integer, intent(in) :: ilev character(len=*), intent(in) :: word integer, dimension(:), intent(in) :: a, b type (dict_data) :: dictionary logical, intent(out) :: novel integer :: iaddress, ssize character(len=len(word)) :: candidate novel=.false. if (b(1) /= 0) then ssize=size(b) do i=1, ssize candidate(i:i) = word(a(b(i)):a(b(i))) end do call find_hashtab(candidate(1:ssize), dictionary%wordlist, & dictionary%wordhash, iaddress) if (iaddress > 0) then novel=.not.btest(dictionary%wordidx(iaddress),ilev-1) dictionary%wordidx(iaddress)=ibset(dictionary%wordidx(iaddress),ilev-1) end if end if end subroutine known_subset ! ! Anagrams by comparing sorted set of letters ! Efficient if large word? ! subroutine set_anagram(word, dictionary, plevel) use outstream use combinatorics use idhash_class character(len=*) :: word type (dict_data) :: dictionary integer, intent(in) :: plevel integer :: i, nc, nw character(len=len_trim(word)) :: candidate nc=len_trim(word) if (nc == 0 .or. nc < shortest) return if (.not.dictionary%current) then call readdict(dictionary, ioerr) if (ioerr /= 0) return end if candidate=order_letters(trim(word)) if (plevel > 0) then write(outstr,'(5a)') 'Target="', trim(word), '" => "', candidate, '"' end if nw=0 do i=1, dictionary%nwordlist if (len_trim(dictionary%wordlist(i)) == nc) then if (candidate == order_letters(trim(dictionary%wordlist(i)))) then nw=nw+1 if (plevel > 0) then write(outstr,'(i0,1x)', advance='no') nw end if write(outstr,'(a)') trim(dictionary%wordlist(i)) end if end if end do end subroutine set_anagram ! ! Wild-card search of dictionary allowing equality and ! inequality constraints across positions ! eg "* /11231" -> "eerie" ! eg "*/..l /11231/114/" -> "eerie eel" ! subroutine dict_search(lin, dictionary, plevel) use string_utilities use scanner character(len=*), intent(in) :: lin type (dict_data), intent(in) :: dictionary integer, intent(in) :: plevel integer :: i, n character (len=1024) :: word, word2 call getword(lin, 3, word2) if (word2(1:1) == '/') then n=len_trim(word2) if (word2(n:n) == '/') n=n-1 call getword(lin, 2, word) call word_search(trim(word), dictionary, plevel, & pattern=word2(2:n)) else i=2 do call getword(lin, i, word) if (word == ' ') exit call word_search(trim(word), dictionary, plevel) i=i+1 end do end if end subroutine dict_search ! subroutine word_search(word, dictionary, plevel, pattern) use interrupt use outstream use combinatorics use idhash_class use string_utilities use scanner character(len=*) :: word type (dict_data) :: dictionary integer, intent(in) :: plevel character (len=*), optional :: pattern logical :: elig, inword integer :: i, ib1, ib2, ich, ilev, ioerr, it, iw, nc, nw, & nwords, w1, w2, wsize integer, dimension(:), allocatable :: curit integer, dimension(:,:), allocatable :: ibounds, patbounds character(len=:), allocatable :: candidate ! list of individually acceptable words integer, dimension(:), allocatable :: nsuccess integer, dimension(:,:), allocatable :: success nc=len_trim(word) if (nc == 0) return wsize=len(word) if (present(pattern)) then wsize=max(wsize, len(pattern)) end if allocate(character(len=wsize) :: candidate) if (.not.dictionary%current) then call readdict(dictionary, ioerr) if (ioerr /= 0) return end if allocate(ibounds(nc,2)) if (present(pattern)) then allocate(patbounds(wsize,2)) end if nwords=0 ibounds=0 call wordbounds(word, '/ ', nwords, ibounds) if (plevel > 0) then write(outstr,'(a,i0,a)') 'Searching for ', nwords, ' word target.' end if if (present(pattern)) then call wordbounds(pattern, '/ ', nw, patbounds) if (nwords /= nw) then write(outstr,'(a,i0,a,i0,a)') & 'ERROR: ', nwords, ' word target but ', nw, ' patterns!' return end if end if allocate(nsuccess(nwords), success(nwords,dictionary%nwordlist)) allocate(curit(nwords)) nw=0 nsuccess=0 success=0 ! initialize search type for each word do iw=1, nwords ib1=ibounds(iw,1) ib2=ibounds(iw,2) nc=ib2-ib1+1 candidate=word(ib1:ib2) if (scan(candidate(1:nc),'.*[') > 0) then nw=0 w1=1 w2=dictionary%nwordlist if (dictionary%sorted) then ich=ichar(candidate(1:1)) if (ich >= 96 .and. ich <= 123) then w1=dictionary%first_letter(ich-96) w2=dictionary%first_letter(ich-95)-1 end if end if do i=w1, w2 if (strfind(candidate(1:nc), dictionary%wordlist(i), 1)) then elig=.true. if (present(pattern)) then elig=strmold(dictionary%wordlist(i), & pattern(patbounds(iw,1):patbounds(iw,2))) end if if (elig) then nw=nw+1 success(iw,nw)=i if (plevel > 2) then write(outstr,'(i0,1x,a)') & nw, trim(dictionary%wordlist(i)) end if end if end if end do nsuccess(iw)=nw else call find_hashtab(candidate(1:nc), dictionary%wordlist, & dictionary%wordhash, i) if (i > 0) then elig=.true. if (present(pattern)) then elig=strmold(dictionary%wordlist(i), & pattern(patbounds(iw,1):patbounds(iw,2))) end if if (elig) then success(iw,1)=i nsuccess(iw)=1 end if end if end if end do if (plevel > 1) then write(outstr,'(i0)', advance='no') nsuccess(1) do iw=2, nwords write(outstr,'(a,i0)', advance='no') ' x ', nsuccess(iw) end do write(outstr,'(a)') ' to search.' end if ! simulated nested do loops it=0 nw=0 curit=0 ilev=1 iter: do while (irupt == 0 .and. ilev > 0) curit(ilev)=curit(ilev)+1 if (curit(ilev) > nsuccess(ilev)) then curit(ilev)=1 ilev=ilev-1 cycle iter end if it=it+1 if (ilev < nwords) then ilev=ilev+1 cycle iter end if elig=.true. candidate=trim(dictionary%wordlist(success(1,curit(1)))) do iw=2, nwords candidate=trim(candidate) // ' ' // & trim(dictionary%wordlist(success(iw,curit(iw)))) end do if (present(pattern)) then elig=strmold(trim(candidate), trim(pattern)) end if if (elig) then nw=nw+1 if (plevel > -1) then if (plevel > 0) then write(outstr,'(i0,1x)', advance='no') nw end if write(outstr,'(a)') trim(candidate) end if end if end do iter if (plevel /= 0) then write(outstr,'(/i0,a)') nw, ' matches.' if (plevel > 1) then write(outstr,'(i0,a)') it, ' words tested.' end if end if end subroutine word_search ! ! Does word match a pattern eg letters at various positions are equal ! eg 11231. is six-letter word with three letters the same ! function strmold(word, pattern) logical :: strmold character (len=*), intent(in) :: word character (len=*), intent(in) :: pattern integer :: i, idx, j, nc character (len=1) :: cand, cand2, ch, ch2 strmold=.false. nc=len_trim(word) if (len_trim(pattern) /= nc) return do i=1, nc-1 ch=word(i:i) if (ch /= '.') then cand=pattern(i:i) if (cand /= '.') then do j=i+1,nc ch2=word(j:j) cand2 = pattern(j:j) if (ch2 /= '.' .and. cand2 /= '.') then if (cand == cand2) then if (ch /= ch2) return else if (ch == ch2) return end if end if end do end if end if end do strmold=.true. end function strmold end module wordtools ! ! Main ! program nsp #if IFORT use ifport #endif #if FLANG use posix_utils #endif use extras use rngs use genetic_maps use julian_epoch use timelib use interrupt use outstream use iobuff use scanner use popgen_vcdata use glm_types use AS164_class use formula_class use parser_data use comp_ops use ped_class use alleles_class use locstring_widths use locus_types use locus_data use locus_list use nucleotides use fileio use mftcontrol use statfuns use statresults use string_utilities use tabixtools use vcftools use vcfhash_class use fastatools use scheme_lang use categorical_data use map_position_list use kinship_io use popgen_kinship use wordtools ! ! Pedigree storage ! use pedigree_data ! ! Storage for marker allele frequency for one locus ! type (allele_data) :: allele_buffer, allele_buffer2 ! For MCMC imputation, can be either observed or prespecified allele frequencies type (allele_data) :: fixfreq_buffer, mcmc_buffer ! to allow openmp ! type (allele_data) :: mp_buffer integer, parameter :: MISS=-9999 integer :: INSTRM=3, OSTR=7, OSTR2=8, & WRK=1, WRK2=2, TWRK=7, TWRK2=8, LSTR=9, ALTOUT=11 character(len=256) :: datdir=' ', wrkdir=' ' character(len=256) :: locfil=' ', outfil=' ', pedfil=' ', stdfil=' ', wrkfil=' ' character(len=256) :: logfil = 'sib-pair.log' ! Standard output redirection indicator logical :: sink ! Indicator whether reading an inline (temporary) file logical :: inline_input = .false. ! IO port type(ioport) :: port ! ! mask for outputting pedigree information logical, dimension(5) :: pedmask character (len=3), dimension(5), parameter :: pedvar = & (/ 'ped', 'id ', 'fa ', 'mo ', 'sex' /) ! format for outputting real numbers and categorical variables integer :: nwid=9, ndec=4, ncatwid=9 ! field separator, and missing data token for sib-pair and "CSV" files character (len=1) :: inputsep=' ', fieldsep=',' character (len=3) :: cmisval=' ', gmisval=' ', misval='x' ! sexcodes used by pedout character (len=1), dimension(2) :: sexcode = (/ 'm', 'f' /) ! width of longest pedigree name integer :: longnam=20 ! number of pedigree and mendel errors ! number of genotyped dropped so at to resolve these integer inconsist, ndiscard, pedincon ! ! addummy=a dummy trait in pedigree output ! assfnd=assoc in founders only, ! fbatimp=restrict imputation of children's genotypes, ! cltyp=stratum for conditional logistic regression (1=pedigree, 2=sibship) ! chek=check mendelisms, conibd=marker to ibd-condition gene-dropping, ! droperr=delete genotypes causing mendel errors, ! fndr=freq in founders only, ! fndr=2 only count alleles in founders ! fndr=1 weight count in this pedigree by number of founders ! gt=side of threshold (0=nil, 15='<', 16='>', 17='ge', 18='le', ! 19='ne',20='eq') ! jdraw is size of jackknife deletion draw (usually set locally eg in famcor) ! hasid=id included in case-control data or a CSV file (when might include ped and id) ! hassex=sex included in case-control data ! hasgeno=genotypes included in case-control data ! header=print locus names at top of file ! last=last of a list, link=Linkage format, prompt=show a prompt, ! mapf=Map function (Haldane/Kosambi), mapunits=cM/Mbp/kbp/bp, ! red=file read, mcp=MC P-val for H-E regression etc, ! fixshape=fix the shape parameter for Weibull etc, ! gene=marker in analysis, trait=trait in analysis, off=offset trait, ! nbatch=number of MC batches to estimate MC error ! norder=order statistic of simulated values used to extrapolate tail P-values ! nmix=number of distributions, ! histcat=number of bins for histogram ! renumall=recoding of alleles for writing pedigree files, ! renumall=0 none ! renumall=1 recode to 1..n ! renumall=2 recode to A->1, C->2, G->3, T->4 ! namechek=check for duplicate locus names ! sexchek=check/impute missing sexes ! skipduploc=ignore duplicate locus declarations (default is to modify name) ! use2=restrict TDT to cases both parents typed, ! useimp=treat (hidden) imputed genotypes as observed ! xlin xlinkd=x-linked markers, zrec=assume zero recomb for haps ! optim=selects optimizer 2=VARMET 3=BOBYQA ! logical :: assfnd=.false., chek=.true., & fbatimp=.true., fixshape=.false., hassex=.true., hasgeno=.true., & last=.false., mcp=.false., namechek=.true., sexchek=.true., & skipduploc=.false., useimp=.false., xlinkd=.false. integer :: hasid=1 integer :: burnin=100, emiter=20, invalg=0, iter=200, jdraw=MISS, & maxtry=5000, mincnt=20, nbatch, norder integer :: addummy, cltyp, conibd, cutoff, droperr, fndr, gt, header, & histcat, link, mapf, maxsibs, nmix, nwarn, & off, optim, prob, renumall, showorig, & skipline, tnum, use2, wrknum, xlin, zrec ! ! censor=censoring variable for survival analysis, ! fixfreq=marker with prespecified allele frequencies ! gene=marker locus for analysis ! genemod=allelic (=1) or genotypic (=2) model for gene ! liab=binary trait locus associated with a liability class ! liabclass=quantitative trait representing liability class ! mark=marker locus for ibd evaluation ! prevalence=default trait prevalence ! ridge_constant=constant for ridge regression/augmenting covariance matrix ! robvar=hwe (=1) or robust (=2) null variance for MQLS ! sumtyp=type of summary statistic usually 0=P-value ! qprev=prevalence used by MQLS procedure ! trait=trait locus for analysis ! weight=variable containing weight for weighted H-E ! integer :: censor, fixfreq, gene, genemod, mark, robvar, sumtyp, trait, weight double precision :: prevalence, qprev double precision :: ridge_constant = 0.0d0 integer :: liabclass, liab, nliabclass ! ! vcf_an=VCF file information variable holding alternate allele count for a reference population ! vcf_ac=VCF file information variable holding total allele count for a reference population ! vcf_het=VCF file information variable holding total heterozygote count for a reference population ! vcf_hom=VCF file information variable holding homozygote count for a reference population ! used by the vcfcascon procedure ! character (len=40) :: vcf_ac, vcf_an, vcf_het, vcf_hom type (vcfhash_table) :: vcfhash ! ! maximum number of haplotypes integer :: maxhap ! ! nmarklist, marklist=list of markers for multipoint procedure ! maxcluster=maximum cluster size ! closedist=intermarker distance to define marker clusters for multipoint ! integer, parameter :: MAXMULT=10 integer :: nmarklist integer, dimension(MAXMULT) :: marklist integer :: maxcluster=MAXMULT double precision :: closedist=0.1d0 ! simulations integer :: ngen, nminoff, nmaxoff ! SML model double precision, dimension(2) :: smlfreq double precision, dimension(3) :: smlpen ! heritability, sib correlations, intermarker recombination distances double precision :: h2, sibm, sibr, sibv, th1 ! sexcrit=threshold for marker diagnosis of sex double precision :: sexcrit=0.999d0 ! threshold for many different kinds of selection double precision :: thresh ! twin_mistyping=threshold for marker diagnosis of monozygosity or duplication integer :: twin_minmarkers = 100 double precision :: twin_mistyping = 0.005d0 ! tolerances for different optimizers (VARMET toler, BOBYQA rhobeg, rhoend) double precision, dimension(3) :: toler(3) ! heterror=overall error rate true X homozygote -> apparent X heterozygote double precision :: heterror=0.001d0 ! significantly long run of homozygosity double precision :: long_roh = 1.5d0 ! data tabulation integer, parameter :: DROPX=0, SHOWX=1 integer :: xtab_ordering = 1 integer :: xtab_missing = DROPX integer :: xtab_sample_weight = MISS ! ! Unspecified parental ID prefix ! character (len=8) :: unspecified='ZZ' ! ! time (time stamp and procedure timings) timer=1 prints procedure timings ! integer :: t0, timer real :: t1 ! ! parser (evaluate algebraic expressions) ! actn=0 error; =1 purely arithmetic; =2 legal ! ! status reports integer :: actn, error ! list for evaluation of expressions (typ1,tag1,value1)...(typNTERM,tagNTERM,valueNTERM) integer :: nterm integer (kind=1), dimension(:), allocatable :: wtyp integer, dimension(:), allocatable :: wtag double precision, dimension(:,:), allocatable :: expr ! ! work array representing every column of locus data ! and paired locus information integer, dimension(:), allocatable :: coltyp integer, dimension(:,:), allocatable :: pairs ! ! candidate allele integer :: candal ! ! command counters: ! linlen=length of current command ! narg=no. arguments, nlin=no. lines of commands so far ! nord=number of selected loci (20200629 now in module locus_data) ! numcmd=stored command buffer empty, echo=echo input, ! prompt=show prompt, more=additional commands in buffer ! hascmds=number of command line argument present ! ! gui=0 usual interface; =1 gtk2; 2=japi ! plevel =0 normal; =-1 quiet; =-2 really quiet; ! =1 verbose; =2 more verbose; =3 too much detail ! pstyle =1 normal print format; =2 <variable name>=<value> style ! silent =T no messages when opening and closing output files ! allsep = character separating alleles in a (diploid) genotype ! tabsep = character separating columns in summary tables ! show_cat =1 as levels; =2 as labels ! integer :: linlen=0, narg=0, nlin=0, numcmd=0, plevel=0, pstyle=1, show_cat=2 integer :: ioerr=0, imp=0, nrc=0, sigstat=0 integer :: gui=0 logical :: echo=.true., more=.false., & prompt=.true., red=.false., silent=.false. logical :: filexist=.false., oldnam=.false. character (len=1) :: allsep='/' ! allele values eg for edit double precision :: all1, all2 ! ! dclass=storage class of current locus, currently SCLASS..PCLASS ! numloc[0..2]=number of columns of total, genotype, phenotype data integer :: dclass integer, dimension(NDATACLASS) :: numloc=0 ! assorted counters integer :: hascmds=0 integer :: imputd=0, newtyp=0, nhis=0 integer :: nobs=0, nped=0, nprob=0, nsimped=0 integer :: ngeno=0, nmark=0, ntyped=0, tottyp=0 ! no. declared marker and trait loci integer :: ndec_m=0, ndec_t=0, new=0 logical :: addref, reading double precision :: tmp integer :: eos, fin, gen2, gcode, i, j, htyp, k, ktyp, length, ltyp, n, & ncovars, numal, numal2, pos, sta, typ, typ1, typ2 logical :: invert, isbin, skipcomments integer (kind=8) :: bigi, bigj ! ! afftrait and liabtrait for Linkage locus and pedigree files ! fixmarker is a marker with prespecified allele frequencies ! character (len=20) :: afftrait=' ', cutnam=' ', & liabtrait=' ', fixmarker=' ' ! ! line crossings, node separation, rank separation and box/circle size for ! dot pedigree drawings ! logical :: dotfixedsep = .true. double precision :: dotcrossings=2.0d0, & dotnodesep=0.1d0, & dotranksep=0.5d0, & dotboxsize=0.8d0 ! ! nrepl controls *multiple imputation* ! meanp is average P-value over nrepl replicates ! pcrit is P-value to compare pval or locstat(i) to ! dist, gap, hival, loval are working variables eg criteria to include/exclude ! loci ! pars() stores model parameter values from the command line to be passed to ! subroutines ! integer :: df=0, nrepl=1 double precision :: meanstat, meanp, varstat, withinvar double precision :: dist, gap, hival, loval, pcrit double precision :: pars(8) ! ! shap=shape parameter of likelihood function eg Weibull, Gamma ! double precision :: shap ! ! MCMC fpm stuff ! linkf=link function 1=identity 2=logit 3=probit 4=MFT 5=log ! modtyp=likelihood family (1=gaussian, 2=binomial, 3=poisson, 4=weibull) ! nqtl=trait loci in model ! tune=adjustment parameter for MCMC proposal distributions, ! mcalg=Metropolis algorithm ! 1=Slice sampler for global parameters ! 2="Plain" Metropolis sampler for all parameters ! 3=Slice sampler for all (continuous) parameters ! nchain=number of random effect chains (actually clones of families) ! priran=print random effects (segsim) ! shap=shape parameter of likelihood function eg Weibull ! integer :: linkf, mcalg, modtyp, nchain, nfix, nqtl, nsamples, priran double precision :: tune ! ! Likelihoods and no. parameters for model fits ! last_result contains result of last algebraic evaluation ! integer :: mdf double precision :: baslik, lrts, meanlik, ncp double precision :: last_result ! ! recode (combine alleles, adjust quant variables) ! integer :: nf, nto double precision, dimension(:), allocatable :: recto, recfro ! ! columns to read from a map file integer :: pos_chrom, pos_bp, pos_id integer :: MAXLOCI = 1000 ! ! line buffer and words integer :: maxwords = 1000 character (len=40), dimension(:), allocatable :: words character (len=3) :: keyword, keyw2 character (len=chromosome_width) :: currchr character (len=1) :: ch character (len=10) :: charnum character (len=7) :: mapfmt ! ! macro variables and functions -- Sib-pair side ! buffers for name of macro (body goes into scheme_lin) ! character (len=40) :: macname ! ! qualstat is the name of a locus quality score, usually read from a VCF file, ! that can be used to include/exclude loci ! character (len=20) :: qualstat = ' ' ! ! functions ! chfind, strfind ! integer :: tid, omp_get_thread_num, omp_get_num_threads ! logical :: compop ! character (len=2) :: compsign integer :: aval, tobp, findwh, findword, ival logical :: iscomment, is_strict_int, isint, isreal logical :: nextped, nonextped external :: nextped, nonextped character (len=6) :: pstring character (len=8) :: wrpercent double precision :: bonf, fval, isaff, tetcor #if !defined(GFORTRAN) && !defined (IFORT) && !defined (SUN) && !defined (FLANG) intrinsic :: signal #endif #if SUN && !defined (FLANG) integer :: hostnm, signal logical :: isatty #endif ! ! alias for different association chi-square functions: currently pearson, gibbs ! integer :: assoc_stat_typ = 2 ! ! external subroutines interfaces ! interface function pearson(sta, fin, nlev, nca, cntall) double precision pearson integer, intent(in) :: sta, fin, nlev integer, dimension(:), intent(in) :: nca integer, dimension(:,:), intent(in) :: cntall end function pearson function gibbs(sta, fin, nlev, nca, cntall) double precision gibbs integer, intent(in) :: sta, fin, nlev integer, dimension(:), intent(in) :: nca integer, dimension(:,:), intent(in) :: cntall end function gibbs end interface interface subroutine quantnorm(nloc, loclist, loc, locpos, loctyp, & dataset, plevel) use outstream use ped_class use locus_types use sorts implicit none integer, intent(in) :: nloc ! number of dimensions integer, intent(in) :: loclist(nloc) ! variable list character (len=*), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp type (ped_data) :: dataset integer, intent(in) :: plevel end subroutine quantnorm end interface interface subroutine recode(loc, gene, loctyp, nto, recto, nf, recfro, dataset, plevel) use ped_class implicit none character (len=*), intent(in) :: loc integer, intent(in) :: gene integer, intent(in) :: loctyp integer, intent(in) :: nto double precision, dimension(:), intent(inout) :: recto integer, intent(in) :: nf double precision, dimension(:), intent(in) :: recfro type (ped_data) :: dataset integer, intent(in) :: plevel end subroutine recode subroutine combine(crit, recto, nf, recfro, allele_buffer) use alleles_class implicit none double precision, intent(in) :: crit double precision, dimension(:), intent(out) :: recto integer, intent(out) :: nf double precision, dimension(:), intent(out) :: recfro type (allele_data), intent(in) :: allele_buffer end subroutine combine end interface interface subroutine ascend(n, ia) integer, intent(in) :: n integer, dimension(:), intent(inout) :: ia end subroutine ascend subroutine asstyp(nloci, loctyp, locpos, totloc, coltyp) integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos integer, intent(in) :: totloc integer, dimension(:), intent(out) :: coltyp end subroutine asstyp end interface interface subroutine rdlinloc(port, lin, words, numloc) use fileio use parser_data use locus_data use storage_classes type (ioport) :: port character (len=*), intent(inout) :: lin character (len=*), dimension(:), intent(inout) :: words integer, dimension(NDATACLASS), intent(out) :: numloc end subroutine rdlinloc subroutine ordvar(twrk, nloci, loc, loctyp, locpos, outpos, nord, locord, & group, map, locstat, locnotes, ord) use locus_types integer, intent(inout) :: twrk integer, intent(inout) :: nloci character (len=*), dimension(:), intent(inout) :: loc integer,dimension(:), intent(inout) :: loctyp integer,dimension(:), intent(inout) :: locpos, outpos integer, intent(in) :: nord integer, dimension(:), intent(in) :: locord character (len=*), dimension(:), intent(inout) :: group double precision, dimension(:), intent(inout) :: map double precision, dimension(:), intent(inout) :: locstat character (len=*), dimension(:), intent(inout) :: locnotes integer, dimension(:), intent(inout) :: ord end subroutine ordvar subroutine packer(typ, wrk, wrk2, nloci, loc, loctyp, locpos, & group, map, locnotes, numloc, dataset, plevel) use ped_class integer, intent(in) :: typ integer, intent(in) :: wrk, wrk2 integer, intent(inout) :: nloci character (len=*), dimension(:), intent(inout) :: loc integer,dimension(:), intent(inout) :: loctyp integer,dimension(:), intent(inout) :: locpos character (len=*), dimension(:), intent(inout) :: group double precision, dimension(:), intent(inout) :: map character (len=*), dimension(:), intent(inout) :: locnotes integer, dimension(NDATACLASS), intent(inout) :: numloc type (ped_data) :: dataset integer, intent(inout) :: plevel end subroutine packer subroutine packloci(nloci, loc, loctyp, locpos, group, map, locnotes, numloc, plevel) use outstream use locus_types use storage_classes integer, intent(inout) :: nloci character (len=*), dimension(:), intent(inout) :: loc integer,dimension(:), intent(inout) :: loctyp integer,dimension(:), intent(inout) :: locpos character (len=*), dimension(:), intent(inout) :: group double precision, dimension(:), intent(inout) :: map character (len=*), dimension(:), intent(inout) :: locnotes integer, dimension(NDATACLASS) :: numloc integer, intent(inout) :: plevel end subroutine packloci subroutine rdmerloc(port, xli, nloci, loc, locpos, outpos, loctyp, locnotes, & numloc, twinning, twintype, twintrait, nread, plevel) use fileio use storage_classes use parser_data type (ioport) :: port integer, intent(in) :: xli integer, intent(inout) :: nloci character (len=*), dimension(:), intent(out) :: loc integer,dimension(:), intent(out) :: locpos, outpos integer,dimension(:), intent(out) :: loctyp character (len=*), dimension(:), intent(out) :: locnotes integer, dimension(NDATACLASS), intent(out) :: numloc integer, intent(out) :: twinning integer, intent(out) :: twintype character (len=*), intent(out) :: twintrait integer, intent(out) :: nread integer, intent(in) :: plevel end subroutine rdmerloc subroutine rdloci(port, typ, chrcode, namechek, nloci, loc, lochash, & locpos, outpos, loctyp, locnotes, numloc, group, map, nread) use iobuff use outstream use scanner use recast_data use parser_data use storage_classes use locus_types use lochash_class use locus_list use fileio type (ioport) :: port integer, intent(in) :: typ, chrcode logical, intent(in) :: namechek integer, intent(inout) :: nloci character (len=20), dimension(:), intent(inout) :: loc type (hash_table) :: lochash integer,dimension(:), intent(inout) :: locpos, outpos integer,dimension(:), intent(inout) :: loctyp character (len=annotation_width), dimension(:), intent(inout) :: locnotes ! Number of columns of data for each data class integer, dimension(NDATACLASS), intent(inout) :: numloc character (len=chromosome_width), dimension(:), intent(inout) :: group double precision, dimension(:), intent(inout) :: map integer, intent(out) :: nread end subroutine rdloci subroutine rdfreq(typ, sta, fin, words, allele_buffer) use outstream use alleles_class implicit none integer, intent(in) :: typ integer, intent(in) :: sta integer, intent(in) :: fin character (len=*), dimension(:), intent(in) :: words type (allele_data), intent(inout) :: allele_buffer end subroutine rdfreq subroutine readstats(port, namcol, statcol, lin, words, plevel) use locus_types use locus_data use outstream use fileio use scanner use locus_list implicit none type(ioport) :: port integer, intent(in) :: namcol, statcol character (len=*), intent(inout) :: lin character (len=40), dimension(:), intent(inout) :: words integer, intent(in) :: plevel end subroutine readstats subroutine readmap(port, units, filehint, lin, words, plevel) use locus_types use locus_data use outstream use fileio type (ioport) :: port integer, intent(in) :: units integer, intent(in) :: filehint character (len=*), intent(inout) :: lin character (len=40), dimension(:), intent(inout) :: words integer, intent(in) :: plevel end subroutine readmap subroutine readnames(port, nloci, loc, lochash, chosen, plevel, colpos) use fileio use outstream use idhash_class type (ioport) :: port integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc type (hash_table) :: lochash integer, dimension(:), intent(out) :: chosen integer, intent(in) :: plevel integer, optional, intent(in) :: colpos end subroutine readnames subroutine readcases(port, hassid, hassex, hasgeno, inputsep, skipline, numloc, coltyp, & locnotes, dataset, longnam, longest, nwarn, plevel) use outstream use fileio use string_utilities use locus_types use ped_class type (ioport) :: port integer, intent(in) :: hassid logical, intent(in) :: hassex logical, intent(in) :: hasgeno character(len=1), intent(in) :: inputsep integer, intent(in) :: skipline integer, dimension(NDATACLASS), intent(in) :: numloc integer, dimension(:), intent(in) :: coltyp character (len=*), dimension(:), intent(inout) :: locnotes type (ped_data), intent(inout) :: dataset integer, intent(inout) :: longnam integer, intent(in) :: longest integer, intent(inout) :: nwarn integer, intent(in) :: plevel end subroutine readcases subroutine readpeds(port, wrk, wrk2, inputsep, skipline, link, unspecified, & mztwin, gt, thresh, sexchek, hassex, nextped, & numloc, coltyp, dataset, longnam, longest, nwarn, plevel) use fileio use string_utilities use ped_class type (ioport) :: port integer, intent(in) :: wrk, wrk2 character (len=1), intent(in) :: inputsep integer, intent(in) :: skipline integer, intent(in) :: link character (len=*), intent(in) :: unspecified integer, intent(in) :: mztwin integer, intent(in) :: gt double precision, intent(in) :: thresh logical , intent(in) :: sexchek logical , intent(in) :: hassex logical :: nextped external :: nextped integer, dimension(NDATACLASS), intent(in) :: numloc integer, dimension(:), intent(in) :: coltyp type (ped_data), intent(inout) :: dataset integer, intent(inout) :: longnam integer, intent(in) :: longest integer, intent(inout) :: nwarn integer, intent(in) :: plevel end subroutine readpeds end interface interface subroutine tidydata(nloci, loctyp, locpos, dataset, tottyp) use ped_class integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data), intent(inout) :: dataset integer, intent(out) :: tottyp end subroutine tidydata end interface interface subroutine testhap(typ, nloci, loc, loctyp, locpos, & dataset, inconsist, plevel) use outstream use ped_class use locus_types implicit none integer, intent(in) :: typ integer, intent(in) :: nloci character(len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data), intent(inout) :: dataset integer, intent(inout) :: inconsist integer, intent(in) :: plevel end subroutine testhap subroutine testsex(seximpute, sexcrit, sexmarker, heterror, & nloci, loc, lochash, loctyp, locpos, & dataset, allele_buffer, inconsist, plevel) use outstream use ped_class use alleles_class use locus_types use idhash_class implicit none ! impute sex where possible integer, intent(in) :: seximpute double precision, intent(in) :: sexcrit character(len=20), intent(in) :: sexmarker double precision, intent(in) :: heterror integer, intent(in) :: nloci character(len=20), dimension(:), intent(in) :: loc type (hash_table) :: lochash integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data), intent(inout) :: dataset type (allele_data), intent(inout) :: allele_buffer integer, intent(inout) :: inconsist integer, intent(in) :: plevel end subroutine testsex subroutine testmap(typ, thresh, nloci, loc, loctyp, locpos, locnotes, & group, map, locstat, dataset, plevel) use outstream use sorts use locstring_widths use locus_types use locus_list use genetic_maps use contingency_table use ped_class integer, intent(in) :: typ double precision, intent(in) :: thresh integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=annotation_width), dimension(:), intent(inout) :: locnotes character (len=chromosome_width), dimension(:), intent(in) :: group double precision, dimension(:), intent(in) :: map double precision, dimension(:), intent(inout) :: locstat type (ped_data) :: dataset integer, intent(in) :: plevel end subroutine testmap subroutine mzgtp(mztwin, gt, thresh, nloci, loc, loctyp, locpos, dataset, & inconsist, plevel) use ped_class integer, intent(in) :: mztwin integer, intent(in) :: gt double precision, intent(in) :: thresh integer, intent(in) :: nloci character(len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data), intent(inout) :: dataset integer, intent(inout) :: inconsist integer, intent(in) :: plevel end subroutine mzgtp subroutine mzfind(typ, mztwin, mistyping, minmarkers, nloci, loc, loctyp, locpos, & locstat, dataset, plevel) use outstream use ped_class use locus_types implicit none integer, intent(in) :: typ integer, intent(in) :: mztwin integer, intent(in) :: nloci double precision, intent(in) :: mistyping integer, intent(in) :: minmarkers character(len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos double precision, dimension(:), intent(out) :: locstat type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel end subroutine mzfind subroutine duptest(typ, nloci, loc, loctyp, locpos, dataset, thresh, mintyp, plevel) use outstream use ped_class use locus_list integer, intent(in) :: typ, nloci character(len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data) :: dataset double precision, intent(in) :: thresh ! threshold integer, intent(in) :: mintyp integer, intent(in) :: plevel end subroutine duptest subroutine prdiscord(id1, id2, nloci, loc, loctyp, locpos, locnotes, & dataset, plevel) use interrupt use outstream use alleles_class use ped_class use locus_types use comp_ops use sorts implicit none integer, intent(in) :: id1, id2 integer, intent(in) :: nloci character(len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=*), dimension(:), intent(in out) :: locnotes type (ped_data), intent(in) :: dataset integer, intent(in) :: plevel end subroutine prdiscord subroutine ckibs(nloci, loctyp, locpos, allele_buffer, dataset) use alleles_class use ped_class implicit none integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (allele_data) :: allele_buffer type (ped_data), intent(in) :: dataset end subroutine ckibs subroutine dropt2(mztwin, gt, thresh, typ, & nloci, loc, loctyp, locpos, dataset, plevel) use ped_class implicit none integer, intent(in) :: mztwin integer, intent(in) :: gt double precision, intent(in) :: thresh integer, intent(in) :: typ integer, intent(in) :: nloci character(len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel end subroutine dropt2 subroutine genmatch(tped, tid, nloci, loc, loctyp, locpos, dataset) use ped_class character (len=ped_width), intent(in) :: tped character (len=id_width), intent(in) :: tid integer, intent(in) :: nloci character(len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data), intent(inout) :: dataset end subroutine genmatch end interface interface subroutine check(checkall, nloci, loc, loctyp, locpos, locnotes, locstat, & dataset, droperr, ndiscard, inconsist, plevel) use interrupt use outstream use sorts use ped_class use locstring_widths use locus_types use locus_list logical, intent(in) :: checkall integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=annotation_width), dimension(:), intent(in) :: locnotes double precision, dimension(:), intent(inout) :: locstat type (ped_data) :: dataset integer, intent(in) :: droperr integer, intent(inout) :: ndiscard integer, intent(inout) :: inconsist integer, intent(in) :: plevel end subroutine check end interface interface subroutine start(maxtry, nloci, loc, loctyp, locpos, dataset, allele_buffer, inconsist, plevel) use ped_class use alleles_class integer, intent(in) :: maxtry integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data) :: dataset type (allele_data), intent(inout) :: allele_buffer integer, intent(inout) :: inconsist integer, intent(in) :: plevel end subroutine start subroutine exclude(imp, nloci, loc, loctyp, locpos, dataset, & inconsist, imputd, plevel) use ped_class use alleles_class implicit none integer, intent(in) :: imp integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data) :: dataset integer, intent(inout) :: inconsist integer, intent(out) :: imputd integer, intent(in) :: plevel end subroutine exclude end interface interface subroutine lorder(typ, addummy, liab, liabclass, & nloci, loctyp, nord, locord) use locus_types integer, intent(in) :: typ integer, intent(in) :: addummy integer, intent(in) :: liab, liabclass integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, intent(out) :: nord integer, dimension(:), intent(out) :: locord end subroutine lorder subroutine pedout(strm, header, pedmask, fieldsep, allsep, imp, nwid, ndec, & ncatwid, sexcode, misval, nrc, skip, filter, show_cat, & nloci, loc, loctyp, locpos, locnotes, dataset) use ped_class integer, intent(in) :: strm integer, intent(in) :: header logical, dimension(:), intent(in) :: pedmask character (len=1), intent(in) :: fieldsep character (len=1), intent(in) :: allsep integer, intent(in) :: imp integer, intent(in) :: ncatwid, nwid integer, intent(in) :: ndec character (len=*), dimension(2), intent(in) :: sexcode character (len=*), intent(in) :: misval integer, intent(in) :: nrc, skip, filter, show_cat integer, intent(in) :: nloci character (len=*), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=*), dimension(:), intent(in) :: locnotes type (ped_data) :: dataset end subroutine pedout subroutine wrphe(strm, typ, nwid, ndec, & nloci, loc, loctyp, locpos, dataset) use ped_class implicit none integer, intent(in) :: strm integer, intent(in) :: typ integer, intent(in) :: nwid integer, intent(in) :: ndec integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data) :: dataset end subroutine wrphe subroutine wrcsv(strm, typ, pedmask, imp, nwid, ndec, sep, allsep, misval, gmisval, & twinning, twintype, nloci, loc, loctyp, locpos, locnotes, & nord, locord, dataset) use ped_class implicit none integer, intent(in) :: strm integer, intent(in) :: typ logical, dimension(:), intent(in) :: pedmask integer, intent(in) :: imp integer, intent(in) :: nwid integer, intent(in) :: ndec character(len=1), intent(in) :: sep character(len=1), intent(in) :: allsep character(len=*), intent(in) :: misval, gmisval integer, intent(in) :: twinning, twintype integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=*), dimension(:), intent(in) :: locnotes integer, intent(in) :: nord integer, intent(in) :: locord(nord) type (ped_data) :: dataset end subroutine wrcsv subroutine wrmorg(strm, typ, nwid, ndec, nloci, loc, loctyp, locpos, & smlfreq, smlpen, dataset) use ped_class use alleles_class implicit none integer, intent(in) :: strm integer, intent(in) :: typ integer, intent(in) :: nwid integer, intent(in) :: ndec integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos double precision, dimension(2) :: smlfreq double precision, dimension(3) :: smlpen type (ped_data) :: dataset end subroutine wrmorg subroutine wrarl(strm, popind, typ, nloci, loc, loctyp, locpos, dataset) use ped_class use locus_types use outstream use contingency_table implicit none integer, intent(in) :: strm integer, intent(in) :: popind integer, intent(in) :: typ integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data) :: dataset end subroutine wrarl subroutine wrprd(strm, typ, trait, nloci, loc, loctyp, locpos, dataset) use ped_class implicit none integer, intent(in) :: strm integer, intent(in) :: typ integer, intent(in) :: trait integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data) :: dataset end subroutine wrprd subroutine wrbeagle(strm, typ, dataset) use ped_class use locus_types use locus_data implicit none integer, intent(in) :: strm integer, intent(in) :: typ type (ped_data) :: dataset end subroutine wrbeagle subroutine wrlink(strm, typ, imp, addummy, liabclass, & renumall, twinning, twintype, nwid, ndec, & nloci, loctyp, locpos, nord, locord, dataset) use alleles_class use ped_class use locus_types use nucleotides integer, intent(in) :: strm integer, intent(in) :: typ integer, intent(in) :: imp integer, intent(in) :: addummy integer, intent(in) :: liabclass integer, intent(in) :: renumall integer, intent(in) :: twinning integer, intent(in) :: twintype integer, intent(in) :: nwid, ndec integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos integer, intent(in) :: nord integer, dimension(:), intent(in) :: locord type (ped_data) :: dataset end subroutine wrlink subroutine wrpap(trip, phen, nloci, loc, loctyp, locpos, dataset) use ped_class use alleles_class use locus_types implicit none integer, intent(in) :: trip, phen integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data) :: dataset end subroutine wrpap subroutine wrfish(strm, ndec, twinning, twintype, & nloci, loctyp, locpos, nord, locord, dataset, & fstyle, plevel) use ped_class integer, intent(in) :: strm integer, intent(in) :: ndec integer, intent(in) :: twinning integer, intent(in) :: twintype integer, intent(in) :: nloci integer, dimension(nloci), intent(in) :: loctyp integer, dimension(nloci), intent(in) :: locpos integer, intent(in) :: nord integer, intent(in) :: locord(nord) type (ped_data) :: dataset integer, intent(in) :: fstyle integer, intent(in) :: plevel end subroutine wrfish subroutine wrcri(strm, nloci, loc, loctyp, locpos, locord, dataset) use ped_class use alleles_class use locus_types implicit none integer, intent(in) :: strm integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(inout) :: locord type (ped_data) :: dataset end subroutine wrcri subroutine joinped(wrk, wrk2, typ, farg, larg, words, & nloci, loc, locpos, loctyp, locnotes, locstat, & dataset, chek, droperr, plevel) use ped_class implicit none integer, intent(in) :: wrk, wrk2 integer, intent(in) :: typ integer, intent(in) :: farg, larg character (len=*), dimension(:), intent(inout) :: words integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp character (len=*), dimension(:), intent(in) :: locnotes double precision, dimension(:), intent(inout) :: locstat type (ped_data), intent(inout) :: dataset logical, intent(in) :: chek integer, intent(in) :: droperr integer, intent(in) :: plevel end subroutine joinped subroutine replacedata(port, typ, inputsep, nloci, loc, lochash, loctyp, locpos, & wloc, hashtab, dataset, longest, plevel) use locus_types use outstream use fileio use ped_class use idhash_class use lochash_class implicit none type (ioport) :: port integer, intent(in) :: typ character (len=1), intent(in) :: inputsep integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc type (hash_table) :: lochash integer,dimension(:), intent(in) :: loctyp integer,dimension(:), intent(in) :: locpos integer,dimension(:), intent(in) :: wloc type (hash_table) :: hashtab type (ped_data) :: dataset integer, intent(in) :: longest integer, intent(out) :: plevel end subroutine replacedata end interface interface subroutine nextcmd(commands, numcmd, linlen, s, more) character(len=*), intent(inout) :: commands integer, intent(out) :: numcmd integer, intent(out) :: linlen character(len=*), intent(out) :: s logical, intent(out) :: more end subroutine nextcmd end interface interface subroutine fprinter(nwords, words, linbuf, plevel) use outstream use fileio integer, intent(in) :: nwords character (len=40), dimension(:), intent(inout) :: words character (len=*), intent(inout) :: linbuf integer, intent(in) :: plevel integer :: ioerr integer :: narg, nchosen, nrec, sta logical :: printn integer, dimension(nwords-4) :: chosen character (len=40) :: fil, fstring end subroutine fprinter subroutine coutyp(nloci, loctyp, locpos, dataset, eligible, typed) use ped_class integer, intent(in) :: nloci integer, intent(in) :: loctyp(:) integer, intent(in) :: locpos(:) type (ped_data) :: dataset integer, intent(out) :: eligible integer, intent(out) :: typed(:) end subroutine coutyp subroutine actped(typ, red, pedfil, nloci, loc, loctyp, locpos, & outpos, locnotes, typed, locstat, dataset, plevel) use interrupt use outstream use locstring_widths use automatic_data use ped_class use locus_types use locus_list use contingency_table integer, intent(in) :: typ logical, intent(in out) :: red character (len=*), intent(in) :: pedfil integer, intent(in) :: nloci character (len=*), dimension(:), intent(in out) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in out) :: locpos, outpos character (len=annotation_width), dimension(:), intent(in out) :: locnotes integer, dimension(:), intent(inout) :: typed double precision, dimension(:), intent(inout) :: locstat type (ped_data) :: dataset integer, intent(in) :: plevel end subroutine actped subroutine sumped(nloci, loctyp, locpos, dataset) use ped_class integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data) :: dataset end subroutine sumped subroutine freq(gene, loctyp, fndr, dataset, allele_buffer) use ped_class use alleles_class integer, intent(in) :: gene integer, intent(in) :: loctyp integer, intent(in) :: fndr type (ped_data), intent(in) :: dataset type (allele_data), intent(inout) :: allele_buffer end subroutine freq subroutine typwords(farg, larg, words, nloci, loc, lochash, loctyp, & wtyp, wtag, expr, actn) use lochash_class use parser_data integer, intent(in) :: farg integer, intent(in) :: larg character (len=*), dimension(:), intent(in out) :: words integer, intent(in) :: nloci character (len=*), dimension(nloci), intent(in) :: loc type (hash_table) :: lochash integer, dimension(nloci), intent(in) :: loctyp integer (kind=1), dimension(:), intent(inout) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(inout) :: expr integer, intent(out) :: actn end subroutine typwords subroutine dryrun(farg, larg, wtyp) use parser_data integer, intent(in) :: farg integer, intent(in) :: larg integer (kind=1), dimension(:), intent(inout) :: wtyp end subroutine dryrun subroutine macloop(lin, nloci, loc, loctyp, commands, plevel) implicit none character (len=*), intent(in) :: lin integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp character (len=*), intent(inout) :: commands integer, intent(in) :: plevel end subroutine macloop subroutine parser(nterm, wtyp, wtag, expr, error) use parser_data integer, intent(inout) :: nterm integer (kind=1), dimension(:), intent(inout) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(inout) :: expr integer, intent(out) :: error end subroutine parser subroutine evalped(narg, words, nloci, loc, lochash, loctyp, locpos, & locnotes, locstat, wtyp, wtag, expr, allele_buffer, & dataset, chek, imp, maxtry, droperr, plevel) use outstream use parser_data use ped_class use alleles_class use locus_types use lochash_class integer, intent(in) :: narg character (len=*), dimension(:), intent(in out) :: words integer, intent(in out) :: nloci character (len=*), dimension(:), intent(in out) :: loc type (hash_table) :: lochash integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=*), dimension(:), intent(in) :: locnotes double precision, dimension(:), intent(inout) :: locstat integer (kind=1), dimension(:), intent(inout) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(inout) :: expr type (allele_data), intent(inout) :: allele_buffer type (ped_data) :: dataset logical, intent(in) :: chek integer, intent(in) :: imp integer, intent(in) :: maxtry integer, intent(in) :: droperr integer, intent(in) :: plevel end subroutine evalped subroutine showdata(fped, fid, larg, words, near, & nloci, loc, loctyp, locpos, locnotes, & dataset, pedmask, nwid, ndec, ncatwid, sexcode, misval, & show_cat, fieldsep, allsep, pstyle, plevel) use ped_class integer, intent(in) :: fped integer, intent(in) :: fid integer, intent(in) :: larg character (len=*), dimension(larg), intent(in) :: words integer, intent(in) :: near integer, intent(in) :: nloci character (len=*), dimension(nloci), intent(in) :: loc integer, dimension(nloci), intent(in) :: loctyp integer, dimension(nloci), intent(in) :: locpos character (len=*), dimension(nloci), intent(in) :: locnotes type (ped_data) :: dataset logical, dimension(:), intent(in) :: pedmask integer, intent(in) :: nwid, ndec, ncatwid character (len=*), dimension(2), intent(in) :: sexcode character (len=*), intent(in) :: misval integer, intent(in) :: show_cat character (len=1), intent(in) :: fieldsep character (len=1), intent(in) :: allsep integer, intent(in) :: pstyle, plevel end subroutine showdata subroutine doselect(typ, nprob, farg, larg, words, & nloci,loc, lochash, loctyp, locpos, wtyp, wtag, expr, & dataset, nobs, plevel) use parser_data use ped_class use lochash_class integer, intent(in) :: typ integer, intent(in) :: nprob integer, intent(in) :: farg, larg character (len=*), dimension(:), intent(in out) :: words integer, intent(in out) :: nloci character (len=*), dimension(:), intent(in out) :: loc type (hash_table) :: lochash integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos integer (kind=1), dimension(:), intent(inout) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(in out) :: expr type (ped_data) :: dataset integer, intent(inout) :: nobs integer, intent(in) :: plevel end subroutine doselect subroutine selped(typ, farg, larg, words, dataset, plevel) use ped_class integer, intent(in) :: typ integer, intent(in) :: farg integer, intent(in) :: larg character (len=*), dimension(:), intent(in out) :: words type (ped_data) :: dataset integer, intent(in) :: plevel end subroutine selped subroutine wrans(prefix, nterm, expr, wtyp, wtag, val) use parser_data character (len=*), intent(in) :: prefix integer, intent(in) :: nterm double precision, dimension(:,:), intent(in) :: expr integer (kind=1), dimension(:), intent(in) :: wtyp integer, dimension(:), intent(in) :: wtag double precision, intent(out) :: val end subroutine wrans subroutine docount(typ, farg, larg, words, & nloci, loc, lochash, loctyp, locpos, locnotes, & wtyp, wtag, expr, dataset, & pedmask, nwid, ncatwid, ndec, sexcode, misval, & fieldsep, allsep, show_cat, pstyle, plevel) use parser_data use ped_class use lochash_class integer, intent(in) :: typ integer, intent(in) :: farg integer, intent(in) :: larg character (len=40), dimension(:), intent(in out) :: words integer, intent(in out) :: nloci character (len=20), dimension(:), intent(in out) :: loc type (hash_table) :: lochash integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=*), dimension(nloci), intent(in) :: locnotes integer (kind=1), dimension(:), intent(inout) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(in out) :: expr type (ped_data) :: dataset logical, dimension(:), intent(in) :: pedmask integer, intent(in) :: ncatwid, nwid, ndec character (len=*), dimension(2), intent(in) :: sexcode character (len=*), intent(in) :: misval character (len=1), intent(in) :: fieldsep character (len=1), intent(in) :: allsep integer, intent(in) :: show_cat,pstyle, plevel end subroutine docount subroutine strattyp(trait, nloci, loc, loctyp, locpos, locnotes, & locord, dataset, locstat, plevel) use outstream use ped_class use contingency_table use locus_types integer, intent(in) :: trait integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=40), dimension(:), intent(in) :: locnotes integer, dimension(:), intent(inout) :: locord type (ped_data) :: dataset double precision, dimension(:), intent(inout) :: locstat integer, intent(in) :: plevel end subroutine strattyp subroutine xtab(analys, table_order, mistyp, sample_weight, nloc, loclist, & nloci, loc, locpos, loctyp, locnotes, & dataset, iter, ndec, nwid, pval, plevel) use ped_class use contingency_table use read_data integer, intent(in) :: analys integer, intent(in) :: table_order integer, intent(in) :: sample_weight integer, intent(in) :: mistyp integer, intent(in) :: nloc ! number of dimensions integer, intent(in) :: loclist(nloc) ! variable list character (len=*), dimension(:), intent(in) :: loc integer, intent(in) :: nloci ! total loci integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp character (len=*), dimension(:), intent(in) :: locnotes type (ped_data) :: dataset integer, intent(in) :: iter integer, intent(in) :: nwid, ndec double precision, intent(out) :: pval integer, intent(in) :: plevel end subroutine xtab subroutine pedtab(trait, nloci, loc, loctyp, locpos, locnotes, & dataset, nwid, ndec, plevel) use outstream use locus_types use contingency_table use ped_class integer, intent(in) :: trait integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=40), dimension(:), intent(in) :: locnotes type (ped_data) :: dataset integer, intent(in) :: nwid, ndec integer, intent(in) :: plevel end subroutine pedtab subroutine histogram(trait, nloci, loc, locpos, loctyp, histcat, dataset, & nwid, ndec, outfil, plevel) use outstream use ped_class use contingency_table use read_data use locus_types integer, intent(in) :: trait integer, intent(in) :: nloci character (len=*), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp integer, intent(in) :: histcat type (ped_data) :: dataset integer, intent(in) :: nwid, ndec character (len=*), intent(in) :: outfil integer, intent(in) :: plevel end subroutine histogram subroutine logrank(typ, nloc, loclist, nloci, loc, loctyp, locpos, locnotes, & dataset, nwid, ndec, lrstat, df, pval, plevel) use outstream use ped_class use contingency_table use locus_types integer, intent(in) :: typ integer, intent(in) :: nloc integer, dimension(:), intent(in) :: loclist integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=40), dimension(:), intent(in) :: locnotes type (ped_data) :: dataset integer, intent(in) :: nwid, ndec double precision, intent(out) :: lrstat integer, intent(out) :: df double precision, intent(out) :: pval integer, intent(in) :: plevel end subroutine logrank subroutine fitloglin(sta, fin, terms, nloci, loc, lochash, loctyp, locpos, & locnotes, dataset, mlik, mpar, pval, & nwid, ndec, plevel) use outstream use ped_class use lochash_class use formula_class use contingency_table integer, intent(in) :: sta, fin character (len=*), dimension(:), intent(inout) :: terms integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc type (hash_table) :: lochash integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=40), dimension(:), intent(in) :: locnotes type (ped_data) :: dataset double precision, intent(out) :: mlik integer, intent(out) :: mpar double precision, intent(out) :: pval integer, intent(in) :: nwid, ndec integer, intent(in) :: plevel end subroutine fitloglin subroutine edit(tped, tid, gene, loc, loctyp, all1, all2, dataset, plevel) use ped_class character (len=ped_width), intent(in) :: tped character (len=id_width), intent(in) :: tid integer, intent(in) :: gene character(len=20), intent(in) :: loc integer, intent(in) :: loctyp double precision, intent(in) :: all1, all2 type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel end subroutine edit subroutine copydata(typ, ped1, id1, ped2, id2, & nloci, loc, loctyp, locpos, & dataset, hashtab, plevel) use outstream use idhash_class use ped_class use locus_types implicit none integer, intent(in) :: typ character (len=*), intent(in) :: ped1, ped2 character (len=*), intent(in) :: id1, id2 integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data), intent(inout) :: dataset type (hash_table) :: hashtab integer, intent(in) :: plevel end subroutine copydata subroutine mergeloci(first, second, thresh, nloci, loc, loctyp, locpos, & locnotes, group, map, dataset, plevel) use outstream use nucleotides use alleles_class use ped_class use locstring_widths use locus_types implicit none integer, intent(in) :: first, second double precision, intent(in) :: thresh integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=*), dimension(:), intent(inout) :: locnotes character (len=*), dimension(:), intent(in) :: group double precision, dimension(:), intent(in) :: map type (ped_data) :: dataset integer, intent(in) :: plevel end subroutine mergeloci subroutine seldel(nord, locord, farg, larg, words, & nloci, loc, lochash, loctyp, locpos, wtyp, wtag, expr, & dataset, plevel) use parser_data use ped_class use lochash_class integer, intent(in) :: nord integer, dimension(:), intent(in) :: locord integer, intent(in) :: farg, larg character (len=*), dimension(:), intent(in out) :: words integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc type (hash_table) :: lochash integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos integer (kind=1), dimension(:), intent(inout) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(in out) :: expr type (ped_data) :: dataset integer, intent(in out) :: plevel end subroutine seldel end interface interface subroutine docov(typ, nterms, terms, nloci, loc, loctyp, locpos, dataset) use ped_class implicit none integer, intent(in) :: typ integer, intent(in) :: nterms integer, dimension(:), intent(inout) :: terms integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data) :: dataset end subroutine docov subroutine dodist(division, nterms, terms, nloci, loc, loctyp, locpos, dataset, plevel) use outstream use read_data use covariate_data use distance_cor implicit none integer, intent(in) :: division, nterms integer, dimension(:), intent(inout) :: terms integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data) :: dataset integer, intent(in) :: plevel end subroutine dodist subroutine regress(typ, nterms, terms, nloci, loc, loctyp, locpos, & gene, genemod, allele_buffer, dataset, & mlik, mpar, pval, plevel) use alleles_class use ped_class integer, intent(in) :: typ integer, intent(in) :: nterms integer, dimension(:), intent(inout) :: terms integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp integer, intent(in) :: gene integer, intent(in) :: genemod type (allele_data), intent(inout) :: allele_buffer type (ped_data) :: dataset double precision, intent(out) :: mlik integer, intent(out) :: mpar double precision, intent(out) :: pval integer, intent(in) :: plevel end subroutine regress subroutine binreg(ilink, nterms, terms, nloci, loc, loctyp, locpos, & offset, censor, gene, genemod, allele_buffer, & mcp, useimp, fixshape, iter, mincnt, & dataset, wshap, mlik, mpar, statval, pval, plevel) use interrupt use AS164_class use alleles_class use ped_class implicit none integer, intent(in) :: ilink ! position of y and x variables integer, intent(in) :: nterms integer, dimension(:), intent(inout) :: terms integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp integer, intent(in) :: offset integer, intent(in) :: censor integer, intent(in) :: gene ! first codominant marker is model integer, intent(in) :: genemod ! using allelic or genotypic encoding type (allele_data), intent(inout) :: allele_buffer logical, intent(in) :: mcp ! MC P-value for first marker logical, intent(in) :: useimp ! Utilize imputed genotypes logical, intent(in) :: fixshape ! Shape parameter fixed integer, intent(in) :: iter, mincnt type (ped_data) :: dataset double precision, intent(inout) :: wshap ! model likelihood and degrees of freedom double precision, intent(out) :: mlik integer, intent(out) :: mpar double precision, dimension(3), intent(out) :: statval double precision, intent(out) :: pval integer, intent(in) :: plevel end subroutine binreg ! subroutine clreg(typ, styp, nterms, terms, nloci, loc, loctyp, locpos, & gene, genemod, allele_buffer, useimp, & dataset, mlik, mpar, statval, pval, plevel) use interrupt use outstream use AS164_class use alleles_class use ped_class use locus_types implicit none ! stratifying variable 1=pedigree 2=sibship (3=TDT) integer, intent(in) :: styp, typ ! position of y and x variables integer, intent(in) :: nterms integer, dimension(:), intent(inout) :: terms integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp integer, intent(in) :: gene integer, intent(in) :: genemod ! alleles for first marker (will generate numal-1 dummy variables) type (allele_data), intent(inout) :: allele_buffer logical, intent(in) :: useimp type (ped_data) :: dataset ! model likelihood and degrees of freedom double precision, intent(out) :: mlik integer, intent(out) :: mpar double precision, intent(out) :: pval double precision, dimension(3), intent(out) :: statval integer, intent(in) :: plevel end subroutine clreg ! subroutine doassoc(trait, loc, loctyp, locnotes, locnam, gene, genetyp, & assoc_stat, iter, mincnt, & norder, assfnd, gt, thresh, conibd, dataset, & freqfnd, use_fixfreq, fixfreq_buffer, allele_buffer2, & prevalence, pval, sumstat, plevel, typ) use interrupt use outstream use popgen_vcdata use alleles_class use contingency_table use ped_class use locus_types implicit none !!! external :: assoc_stat integer, intent(in) :: trait character (len=*), intent(in) :: loc integer, intent(in) :: loctyp character (len=*), intent(in) :: locnotes character (len=*), intent(in) :: locnam integer, intent(in) :: gene, genetyp !!! double precision :: assoc_stat integer, intent(in) :: iter integer, intent(in) :: mincnt, norder logical, intent(in) :: assfnd integer, intent(in) :: gt double precision, intent(in) :: thresh integer, intent(in) :: conibd type (ped_data) :: dataset integer, intent(in) :: freqfnd logical, intent(in) :: use_fixfreq type (allele_data), intent(in) :: fixfreq_buffer type (allele_data), intent(in) :: allele_buffer2 double precision, intent(in) :: prevalence double precision, intent(out) :: pval integer, intent(in) :: sumstat integer, intent(in) :: plevel integer, intent(in) :: typ interface function assoc_stat(sta, fin, nlev, nca, cntall) double precision assoc_stat integer, intent(in) :: sta, fin, nlev integer, dimension(:), intent(in) :: nca integer, dimension(:,:), intent(in) :: cntall end function assoc_stat subroutine freq(gene, loctyp, fndr, dataset, allele_buffer) use ped_class use alleles_class integer, intent(in) :: gene integer, intent(in) :: loctyp integer, intent(in) :: fndr type (ped_data), intent(in) :: dataset type (allele_data), intent(inout) :: allele_buffer end subroutine freq subroutine simped(ped, dataset, allele_buffer, set) use alleles_class use ped_class integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data), intent(in) :: allele_buffer integer, dimension(:,:), intent(out) :: set end subroutine simped subroutine xsimped(ped, dataset, allele_buffer, set) use alleles_class use ped_class integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data), intent(in) :: allele_buffer integer, dimension(:,:), intent(out) :: set end subroutine xsimped subroutine cisimped(ped, gene, allele_buffer, allele_buffer2, dataset, set) use alleles_class use ped_class implicit none integer, intent(in) :: ped ! pedigree to simulate integer, intent(in) :: gene ! position of marker conditioned on type (allele_data), intent(in) :: allele_buffer ! marker to be simulated type (allele_data), intent(in) :: allele_buffer2 ! marker to condition ibd on type (ped_data) :: dataset ! all the observed data integer, dimension(:,:), intent(out) :: set ! the new simulated marker end subroutine cisimped end interface end subroutine doassoc subroutine hapassoc(nmark, markers, & loc, loctyp, locpos, locnotes, dataset, pval, plevel) use outstream use alleles_class use ped_class use locus_types use AS164_class implicit none integer, intent(in) :: nmark integer, dimension(:), intent(inout) :: markers character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=40), dimension(:), intent(in) :: locnotes type (ped_data), intent(in) :: dataset double precision, intent(out) :: pval integer, intent(in) :: plevel end subroutine hapassoc subroutine rctdt(trait, locnam, gene, genetyp, iter, mincnt, gt, thresh, & fbatimp, freqfnd, dataset, plevel) use alleles_class use ped_class implicit none integer, intent(in) :: trait character (len=*), intent(in) :: locnam integer, intent(in) :: gene, genetyp integer, intent(in) :: iter integer, intent(in) :: mincnt integer, intent(in) :: gt double precision, intent(in) :: thresh logical, intent(in) :: fbatimp integer, intent(in) :: freqfnd type (ped_data) :: dataset integer, intent(in) :: plevel end subroutine rctdt subroutine clumpld(typ, alpha, ldradius, window, maxhap, dataset, plevel) use interrupt use outstream use locstring_widths use genetic_maps use sorts use alleles_class use ped_class use locus_types implicit none integer, intent(in) :: typ double precision, intent(in) :: alpha, ldradius, window integer, intent(in) :: maxhap type (ped_data) :: dataset integer, intent(in) :: plevel end subroutine clumpld subroutine moskvina(window, alpha, maxhap, nloci, loc, loctyp, & locpos, locord, map, dataset, efftests, plevel) use interrupt use outstream use alleles_class use ped_class implicit none double precision, intent(in) :: window, alpha integer, intent(in) :: maxhap integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(inout) :: locord double precision, dimension(:), intent(in) :: map type (ped_data) :: dataset double precision, intent(out) :: efftests integer, intent(in) :: plevel end subroutine moskvina end interface interface subroutine blutab(nloc, loclist, filter, nloci, loc, locpos, loctyp, locnotes, & dataset, iter, nwid, ndec, pval, plevel) use outstream use ped_class use alleles_class use contingency_table use read_data use locus_types use comp_ops integer, intent(in) :: nloc ! number of dimensions integer, intent(in) :: loclist(nloc) ! variable list integer, intent(in) :: filter ! temporary for stratum membership integer, intent(in) :: nloci ! total loci character (len=*), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp character (len=*), dimension(:), intent(in) :: locnotes type (ped_data) :: dataset integer, intent(in) :: iter integer, intent(in) :: nwid, ndec double precision, intent(out) :: pval integer, intent(in) :: plevel end subroutine blutab end interface interface subroutine haploid_freq(nloc, loclist, loc, locpos, loctyp, & dataset, plevel, typ) use interrupt use outstream use contingency_table use ped_class use locus_types implicit none integer, intent(in) :: nloc ! number of markers integer, intent(in) :: loclist(nloc) ! haplotype list character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp type (ped_data) :: dataset integer, intent(in) :: plevel integer, intent(in) :: typ end subroutine haploid_freq subroutine haploid_ass(trait, nloc, loclist, loc, locpos, loctyp, & locnotes, assoc_stat, iter, mincnt, dataset, & pval, plevel, typ) use interrupt use outstream use contingency_table use ped_class use locus_types implicit none external :: assoc_stat integer, intent(in) :: trait integer, intent(in) :: nloc ! number of markers integer, intent(in) :: loclist(nloc) ! haplotype list character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp character (len=40), dimension(:), intent(in) :: locnotes double precision :: assoc_stat integer, intent(in) :: iter integer, intent(in) :: mincnt type (ped_data) :: dataset double precision, intent(out) :: pval integer, intent(in) :: plevel integer, intent(in) :: typ end subroutine haploid_ass subroutine haploid_aov(trait, nloc, loclist, loc, locpos, loctyp, & iter, mincnt, dataset, pval, plevel, typ) use interrupt use outstream use contingency_table use ped_class use locus_types implicit none integer, intent(in) :: trait integer, intent(in) :: nloc ! number of markers integer, intent(in) :: loclist(nloc) ! haplotype list character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp integer, intent(in) :: iter integer, intent(in) :: mincnt type (ped_data) :: dataset double precision, intent(out) :: pval integer, intent(in) :: plevel integer, intent(in) :: typ end subroutine haploid_aov end interface interface subroutine mulhom(trait, gt, thresh, xlinkd, iter, mincnt, & nloci, loc, loctyp, locpos, map, dataset, plevel) use alleles_class use ped_class implicit none integer, intent(inout) :: trait integer, intent(inout) :: gt double precision, intent(in) :: thresh logical, intent(inout) :: xlinkd integer, intent(in) :: iter integer, intent(inout) :: mincnt integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp double precision, dimension(:), intent(in) :: map type (ped_data) :: dataset integer, intent(in) :: plevel end subroutine end interface interface subroutine sibqtl(tranam, trait, locnam, gene, & allele_buffer, dataset, pval, plevel, invalg, toler) use interrupt use alleles_class use ped_class use ibd_class use AS319 implicit none character (len=*), intent(inout) :: tranam integer, intent(inout) :: trait character (len=*), intent(inout) :: locnam integer, intent(in) :: gene type (allele_data) :: allele_buffer type (ped_data), intent(inout) :: dataset double precision, intent(out) :: pval integer, intent(in) :: plevel integer, intent(in) :: invalg double precision, dimension(3), intent(in) :: toler end subroutine sibqtl subroutine varcom(modtyp, nterms, terms, nloci, loc, loctyp, locpos, & gene, genemod, allele_buffer, & nmark, mark, dataset, & totobs, mlik, mpar, pval, plevel, burnin, iter, typ, & invalg, optim, toler) use interrupt use outstream use alleles_class use ped_class use ibd_class use covariate_data use AS164_class use AS319 use likelihoods use varmet_optimizer use bobyqa_optimizer use statfuns use glm_types implicit none integer, intent(in) :: modtyp ! 1=Gaussian, 2=MFT integer, intent(in) :: nterms ! no. variables in model integer, dimension(:), intent(in) :: terms ! variable integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc ! all locus names integer, dimension(:), intent(in) :: loctyp ! locus types integer, dimension(:), intent(in) :: locpos ! locus column integer, intent(in) :: gene ! marker as covariate integer, intent(in) :: genemod ! allelic or genotypic model type (allele_data) :: allele_buffer ! covariate marker information integer, intent(in) :: nmark ! number of markers for ibd estimate integer, dimension(:), intent(in) :: mark ! markers for ibd estimate type (ped_data), intent(inout) :: dataset integer, intent(out) :: totobs ! number of contributing records double precision, intent(out) :: mlik integer, intent(out) :: mpar double precision, intent(out) :: pval integer, intent(in) :: plevel integer, intent(in) :: burnin integer, intent(in) :: iter integer, intent(inout) :: typ integer, intent(in) :: invalg integer, intent(in) :: optim double precision, dimension(3), intent(in) :: toler end subroutine varcom end interface interface subroutine nearloc(pos, thresh, maxcluster, nloci, loc, loctyp, & group, map, nmark, mark, plevel) use interrupt use locus_types use outstream implicit none integer, intent(inout) :: pos ! index marker double precision, intent(in) :: thresh ! criterion for close integer, intent(in) :: maxcluster ! max no of markers integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc ! all locus names integer, dimension(:), intent(in) :: loctyp ! locus types character (len=2), dimension(:), allocatable :: group ! genetic map double precision, dimension(:), intent(in) :: map integer, intent(out) :: nmark ! number of markers in set integer, dimension(:), intent(out) :: mark ! marker list integer, intent(in) :: plevel end subroutine nearloc end interface interface subroutine wribd(nmark, mark, loc, loctyp, locpos, dataset, & burnin, iter, typ, plevel) use interrupt use outstream use alleles_class use ped_class use ibd_class implicit none integer, intent(in) :: nmark ! number of markers for ibd estimate integer, dimension(:), intent(in) :: mark ! markers for ibd estimate character (len=20), dimension(:), intent(in) :: loc ! all locus names integer, dimension(:), intent(in) :: loctyp ! locus types integer, dimension(:), intent(in) :: locpos ! locus column type (ped_data), intent(inout) :: dataset integer, intent(in) :: burnin integer, intent(in) :: iter integer, intent(in) :: typ integer, intent(in) :: plevel end subroutine wribd end interface interface subroutine wribs(trait, gt, thresh, nloci, loc, loctyp, locpos, & dataset, plevel) use interrupt use outstream use locus_types use ped_class implicit none integer, intent(in) :: trait integer, intent(in) :: gt double precision, intent(in) :: thresh integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc ! all locus names integer, dimension(:), intent(in) :: loctyp ! locus types integer, dimension(:), intent(in) :: locpos ! locus column type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel end subroutine wribs subroutine momentibs(typ, trait, gt, thresh, nloci, loc, loctyp, locpos, & dataset, plevel) use outstream use alleles_class use ped_class use locus_types implicit none integer, intent(in) :: typ integer, intent(in) :: trait integer, intent(in) :: gt double precision, intent(in) :: thresh integer, intent(in) :: nloci character(len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data), intent(in) :: dataset integer, intent(in) :: plevel end subroutine momentibs subroutine ibskin(typ, trait, gt, thresh, nloci, loc, loctyp, locpos, & dataset, plevel) use outstream use alleles_class use ped_class use locus_types implicit none integer, intent(in) :: typ integer, intent(in) :: trait integer, intent(in) :: gt double precision, intent(in) :: thresh integer, intent(in) :: nloci character(len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data), intent(in) :: dataset integer, intent(in) :: plevel end subroutine ibskin subroutine empkin(ped, dataset, kin, plevel) use interrupt use outstream use alleles_class use ped_class use locus_types use locus_data implicit none integer, intent(in) :: ped type (ped_data), intent(in) :: dataset double precision, dimension(:), intent(out) :: kin integer, intent(in) :: plevel end subroutine empkin subroutine ibspca(typ, nloci, loc, loctyp, locpos, & ncomps, loadvars, dataset, plevel) use interrupt use outstream use locus_types use ped_class implicit none integer, intent(in) :: typ integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc ! all locus names integer, dimension(:), intent(in) :: loctyp ! locus types integer, dimension(:), intent(in) :: locpos ! locus column integer, intent(in) :: ncomps ! no. of factors integer, dimension(:), intent(inout) :: loadvars ! where to save loadings type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel end subroutine ibspca end interface interface subroutine getclassval(stratvar, trait, sumval, summary, & nloci, loc, locpos, loctyp, locnotes, dataset, plevel) use outstream use ped_class use contingency_table use read_data use locus_types implicit none integer, intent(in) :: stratvar, trait, sumval character (len=3), intent(in) :: summary integer, intent(in) :: nloci character (len=*), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp character (len=*), dimension(:), intent(in) :: locnotes type (ped_data) :: dataset integer, intent(in) :: plevel end subroutine getclassval end interface interface subroutine mksegmod(narg, words, trait, gt, thresh, offset, censor, & nvar, varlist, nloci, loc, lochash, loctyp, & priran, nqtl, linkf, modtyp, shap) use mcmc_model use locus_types use idhash_class integer, intent(in) :: narg character (len=*), dimension(:), intent(in) :: words integer, intent(in) :: trait integer, intent(out) :: gt double precision, intent(out) :: thresh integer, intent(out) :: offset integer, intent(out) :: censor integer, intent(out) :: nvar integer, dimension(:), intent(out) :: varlist integer, intent(inout) :: nloci character (len=20), dimension(:), intent(inout) :: loc type (hash_table) :: lochash integer, dimension(:), intent(inout) :: loctyp integer, intent(out) :: priran integer, intent(out) :: nqtl integer, intent(out) :: linkf integer, intent(out) :: modtyp double precision, intent(out) :: shap end subroutine mksegmod subroutine segsim(linkf, modtyp, shap, trait, gt, thresh, offset, censor, & nvar, fixed, gene, genemod, allele_buffer, & nloci, loc, loctyp, locpos, & burnin, iter, nbatch, nsamples, tune, nchain, nqtl, dataset, & mlik, mpar, priran, mcalg, plevel) use interrupt use alleles_class use mcmc_model use ped_class implicit none integer, intent(in) :: linkf integer, intent(in) :: modtyp double precision, intent(in) :: shap integer, intent(in) :: trait integer, intent(in) :: gt double precision, intent(in) :: thresh integer, intent(in) :: offset integer, intent(in) :: censor integer, intent(in) :: nvar integer, dimension(:), intent(inout) :: fixed integer, intent(in) :: gene integer, intent(in) :: genemod type (allele_data) :: allele_buffer integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos integer, intent(in) :: burnin integer, intent(in) :: iter integer, intent(in) :: nbatch integer, intent(in) :: nsamples double precision, intent(in) :: tune integer, intent(in) :: nchain integer, intent(in) :: nqtl type (ped_data), intent(inout) :: dataset double precision, intent(out) :: mlik integer, intent(out) :: mpar integer, intent(in) :: priran integer, intent(in) :: mcalg integer, intent(in) :: plevel end subroutine segsim subroutine hashprint(hashtab, dataset, loc, plevel) use outstream use ped_class use idhash_class type (hash_table) :: hashtab type (ped_data) :: dataset character (len=20), dimension(:) :: loc integer, intent(in) :: plevel end subroutine hashprint subroutine searchid(sstrings, dataset) use outstream use ped_class use string_utilities integer, parameter :: MISS = -9999 character (len=*), dimension(:), intent(in) :: sstrings type (ped_data) :: dataset end subroutine searchid end interface ! ! number of words and terms in expressions ! allocate(words(maxwords)) allocate(wtyp(maxwords)) allocate(wtag(maxwords)) allocate(expr(maxwords,2)) ! ! number of locus records ! call setup_loci(MAXLOCI) ! ! number of alleles ! call setup_freq(100, allele_buffer) call setup_freq(100, allele_buffer2) call setup_freq(10, fixfreq_buffer) call setup_freq(10, mcmc_buffer) ! ! initiate Scheme ! call init_scheme() logstr = 0 outstr = STDOUT call system_clock(t0) call init_rng(t0) #if defined WIN32 datdir='Windows' #else i=hostnm(datdir) #endif write(outstr, '(a/2a/a/5a/)') & '|||| SIB-PAIR: A program for simple genetic analysis', & #if WIN32 || NOESCAPE '|\/| Version : ', trim(version), & '|/\| Author : David L Duffy (c) 1995-2021', & #else '|\\/| Version : ', trim(version), & '|/\\| Author : David L Duffy (c) 1995-2021', & #endif '|||| Job run : ', current_time(), ' (', trim(datdir),')' write(outstr, '(a/)') & 'Type "help" for help, "quit" to quit, "ctrl-C" to interrupt.' #if WIN32 || OPEN64 || FLANG prompt=.true. #else prompt=isatty(5) #endif allsep = '/' burnin=100 datdir=' ' dist=0.0 echo=.false. sink=.false. emiter=20 epoch=2440588.0D0 ilevel=1 ilevold=1 toplevel=1 imp=0 iter=200 jdraw=MISS ! check if command line arguments hascmds=command_argument_count() mapf=1 mapunits=3 mapconstant=1.d0 maxhap=100 maxtry=5000 mcalg=1 mincnt=20 ndec=4 nbatch=int(sqrt(10*float(iter))) nchain=1 norder=10 nsamples=256 nwid=9 nhis=0 nlin=0 optim=2 pedmask(1:5)=.true. plevel=0 pstyle=1 priran=0 shap=1.0D0 prevalence=MISS showorig=2 smlfreq(1)=0.05d0 smlfreq(2)=1.0d0-smlfreq(1) smlpen(1)=0.50d0 smlpen(2)=0.50d0 smlpen(3)=0.05d0 tabsep = ' ' toler(1)=1.0D-6 toler(2)=0.1d0 toler(3)=0.001d0 tune=0.3 vcf_ac='AC' vcf_an='AN' vcf_het='AC_Het' vcf_hom='AC_Hom' wrkdir=' ' if (prompt) call openlog(LSTR, logfil, nhis) ! ! intercept and act on SIGINT ! #if defined (FLANG) #elif SUN || IFORT i=signal(2, handler, -1) #else call signal(2, handler, sigstat) #endif ! ! Global restart 999 continue pedfil=' ' outfil=' ' twintrait=' ' sexmarker=' ' commands=' ' inconsist=0 ndiscard=0 ngeno=0 nloci=0 ndec_m=0 ndec_t=0 nmarloc=0 nsimped=0 numloc(1:NDATACLASS)=0 fixfreq=MISS twinning=MISS twintype=MISS liab=MISS liabclass=MISS nliabclass=1 wrknum=1 chek=.true. droperr=0 fbatimp=.true. fndr=0 genemod=1 hasid=1 hassex=.true. hasgeno=.true. inline_input=.false. link=0 inblock=0 numcmd=0 nwarn=0 red=.false. sexchek=.true. skipduploc=.false. skipline=0 last_result=MISS t1=0.0 timer=0 use2=2 useimp=.false. zrec=1 assoc_stat_typ = 2 call setup_auto() ! ! main read-eval-parse loop ! ! parse any command line arguments ! and create a corresponding script file ! if (hascmds > 0) then call mktmpfil(OSTR, locfil, wrkdir, ioerr) if (ioerr == 0) then i=1 call get_command_argument(i, lin) eos=len_trim(lin) narg=countargs(lin, ' ', SEP_WHITE) if (lin=='--help' .or. lin=='-h' .or. lin=='-?') then write(OSTR,'(a)') 'help' else if (narg == 1 .and. lin(max(1,eos-2):eos) == '.in') then write(OSTR,'(a/3a)') 'pwd', 'inc "', trim(lin), '"' else if (narg == 1 .and. (lin(max(1,eos-3):eos) == '.bin' .or. & lin(max(1,eos-6):eos) == '.bin.gz')) then write(OSTR,'(a/3a)') 'pwd', 'read bin "', trim(lin), '"' else if (lin=='--locus' .or. lin=='-l') then i=i+1 call get_command_argument(i, lin) write(OSTR,'(3a)') 'loc "', trim(lin), '"' else if (lin=='--include' .or. lin=='-i' .or. lin=='-f') then i=i+1 call get_command_argument(i, lin) write(OSTR,'(3a)') 'inc "', trim(lin), '"' else write(outstr, '(2a)') '-> ', lin(1:max(len_trim(lin), 72)) write(OSTR,'(a)') trim(lin) end if close(OSTR, status='keep') call newinclude('inc', 2, locfil, ioerr) end if hascmds=0 end if ! check and include an init file lin='sib-pair.ini' call findfile(lin, i) if (i /= 0) then call newinclude('inc', 1, trim(lin), ioerr) end if ! ! REPL proper ! main_loop: do irupt=0 if (numcmd == 0) then if (prompt .and. ilevel == 1) then write(*,'(/a)',advance='no') prompt_string end if linlen=1 multiple_lines: do if (ilevel == 1) then read(*,'(a)',iostat=ioerr) commands(linlen:LINSIZ) if (ioerr /= 0) then exit main_loop end if else if (ilevel > 1 .and. ilevel <= NSTRM) then read(incstr(ilevel),'(a)',iostat=ioerr) commands(linlen:LINSIZ) if (ioerr /= 0) then if (incaction(ilevel) < 3) then write(*,'(/3a/)') 'Closing include file "',trim(infil(ilevel)),'".' close(incstr(ilevel), status='keep') else close(incstr(ilevel), status='delete') end if toplevel=toplevel-1 ilevel=ilevel-1 cycle main_loop end if end if nlin=nlin+1 linlen=len_trim(commands) #if defined (WIN32) || defined (IFORT) || defined (NOESCAPE) if (linlen <= 1) then exit else if (commands(linlen-1:linlen) /= ' \') then #else if (linlen <= 1) then exit else if (commands(linlen-1:linlen) /= ' \\') then #endif exit end if end do multiple_lines end if call nextcmd(commands, numcmd, linlen, lin, more) ! last command of series of macro evaluations etc if (numcmd <= 1 .and. ilevel == 0) then if (linlen == 0) then ilevel=ilevold else if (chfind(lin(1:linlen),'%') == 0) then ilevel=ilevold end if end if if (echo .and. .not.iscomment(lin)) then if (plevel < 3) then write(outstr,'(/2a/)') '-> ', lin(1:75) else write(outstr,'(/2a/)') '-> ', trim(lin) end if end if if (linlen == 0) cycle narg=maxwords call args(lin(1:linlen), narg, words, ' ', SEP_WHITE) keyword=words(1)(1:3) keyw2=words(2)(1:3) call proct(t1, 0) ! record command line to log (providing not already history) if (ilevel == 0) then if (.not.more) ilevel=ilevold else if (prompt .and. keyword /= 'las' .and. & keyword(1:1) /= '!' .and. keyword(1:1) /= '#' .and. & logstr /= 0) then nhis=nhis+1 write(logstr,'(a)') lin(1:len_trim(lin)) call flush(logstr) end if ! ! Parse the commands ! ! Comment line if (keyword(1:1) == '!' .or. keyword(1:1) == '#') then if (plevel >= 0) then write(outstr,'(a)') lin(1:79) end if ! Macro variable else if (keyword /= 'mac' .and. keyword /= 'hel' .and. & chfind(lin(1:linlen),'%') > 0) then call macvar(lin, commands, plevel) if (ilevel /= 0) ilevold=ilevel ilevel=0 numcmd=1 ! Implicit loop else if (chfind(lin(1:linlen), '{') > 0 .or. & chfind(lin(1:linlen), '}') > 0) then call macloop(lin, nloci, loc, loctyp, commands, plevel) if (ilevel /= 0) ilevold=ilevel ilevel=0 numcmd=1 ! Macro function else if (isafun(trim(words(1))) > 0) then if (ilevel /= 0) ilevold=ilevel ilevel=0 numcmd=1 lin=get_string(isafun(trim(words(1)))) call macsub(narg, words, lin, plevel) if ((len_trim(lin)+len_trim(commands)) < len(commands)) then commands=trim(lin) // ';' // trim(commands) else write(outstr,'(a)') & 'ERROR: macro expansion lead to an overlong command string.' commands=trim(lin) end if ! Print a string to output else if (keyword == 'ech') then call display(lin((sow(lin)+len_trim(words(1))+1):len_trim(lin))) ! Pass command to shell else if ((keyword(1:1) == '$') .and. len_trim(lin) > 1) then call shell(lin, plevel) ! Locus description else if (keyword == 'set' .and. keyw2 == 'loc') then oldnam=isinuse(namechek, words(3), loc, lochash) if (oldnam .and. skipduploc) then if (plevel > 0) then write(outstr,'(3a)') & 'NOTE: Skipping duplicate declaration of locus "', & trim(words(3)) ,'".' end if cycle end if nloci=nloci+1 if (nloci > size(loc)) then call expand_loci(1000, plevel) end if dclass=GCLASS numloc(TCLASS)=numloc(TCLASS) + 1 outpos(nloci)=numloc(TCLASS) if (words(4)(1:3) == 'mar' .or. words(4) == 'm' .or. & words(4)(1:3).eq.'nam') then newtyp=LOC_CODOM numloc(TCLASS)=numloc(TCLASS)+1 ndec_m=ndec_m+1 locpos(nloci)=numloc(dclass)+1 numloc(dclass)=numloc(dclass) + 2 else if (words(4)(1:3) == 'snp') then newtyp=LOC_CODOM+LOC_CMP dclass=SCLASS numloc(TCLASS)=numloc(TCLASS)+1 ndec_m=ndec_m+1 locpos(nloci)=-(numloc(dclass)+1) numloc(dclass)=numloc(dclass) + 2 else if (words(4)(1:3) == 'xma' .or. words(4) == 'x') then newtyp=LOC_XLIN numloc(TCLASS)=numloc(TCLASS)+1 ndec_m=ndec_m+1 locpos(nloci)=numloc(dclass)+1 numloc(dclass)=numloc(dclass) + 2 else if (words(4)(1:3) == 'xsn') then newtyp=LOC_XLIN+LOC_CMP dclass=SCLASS numloc(TCLASS)=numloc(TCLASS)+1 ndec_m=ndec_m+1 locpos(nloci)=-(numloc(dclass)+1) numloc(dclass)=numloc(dclass) + 2 else if (words(4)(1:3) == 'hap' .or. words(4) == 'h') then newtyp=LOC_HAP numloc(TCLASS)=numloc(TCLASS)+1 ndec_m=ndec_m+1 locpos(nloci)=numloc(dclass)+1 numloc(dclass)=numloc(dclass) + 2 else if (words(4)(1:3) == 'mit' .or. words(4) == 'i') then newtyp=LOC_MIT numloc(TCLASS)=numloc(TCLASS)+1 ndec_m=ndec_m+1 locpos(nloci)=numloc(dclass)+1 numloc(dclass)=numloc(dclass) + 2 else if (words(4)(1:3) == 'yma' .or. words(4) == 'y') then newtyp=LOC_YHA numloc(TCLASS)=numloc(TCLASS)+1 ndec_m=ndec_m+1 locpos(nloci)=numloc(dclass)+1 numloc(dclass)=numloc(dclass) + 2 else if (words(4)(1:3) == 'aff' .or. words(4) == 'a') then newtyp=LOC_AFF dclass=PCLASS locpos(nloci)=numloc(dclass)+1 numloc(dclass)=numloc(dclass) + 1 ndec_t=ndec_t+1 else if (words(4)(1:3) == 'cat' .or. words(4) == 'c') then newtyp=LOC_CAT dclass=PCLASS locpos(nloci)=numloc(dclass)+1 numloc(dclass)=numloc(dclass) + 1 ndec_t=ndec_t+1 else newtyp=LOC_QUA dclass=PCLASS locpos(nloci)=numloc(dclass)+1 numloc(dclass)=numloc(dclass) + 1 ndec_t=ndec_t+1 if (words(4)(1:3) /= 'qua' .and. words(4) /= 'q') then write(outstr,'(3a/7x,a/)') & 'ERROR: Do not recognise locus type "', trim(words(4)),'".', & 'Treating as quantitative trait.' end if end if ! ! Check if previously declared locus name or reserved word if (oldnam) then k=min(loc_width, len_trim(words(3))+2) i=50 do if (i == 50 .and. isreal(words(3))) then words(3)='x' // words(3) else words(3)((k-1):k)='_' // char(i) end if call find_hashtab(trim(words(3)(1:loc_width)), loc, lochash, pos) if (pos == 0) exit if (i == 59) i=64 if (i == 90) then write(*,'(3a)') 'ERROR: Locus "', words(3)(1:k), & '" is already declared! Aborting!' stop end if i=i+i end do write(outstr,'(a/7x,3a/)') & 'WARNING: Locus is already declared or a reserved word.', & 'Changed name to "', trim(words(3)), '".' end if loc(nloci)=words(3) if (namechek) then call insert_lochash(trim(loc(nloci)), nloci, loc, lochash) end if loctyp(nloci)=newtyp group(nloci)=' ' map(nloci)=MISS locnotes(nloci)=' ' ! ! read a map position formatted as <number> or <chr>:<number> if present ! rest of line taken to be annotation, which may include chromosome if (narg > 4) then k=5 if (isreal(words(k))) then map(nloci)=mapconstant*fval(words(k)) k=k+1 else i=index(words(k),':') if (i > 0) then if (isreal(words(k)((i+1):len_trim(words(k))))) then map(nloci)=mapconstant*fval(words(k)((i+1):len_trim(words(k)))) group(nloci)=words(k)(1:(i-1)) k=k+1 end if end if end if i=wordpos(lin, k-1) locnotes(nloci)=adjustl(lin(i:len_trim(lin))) call getchr(loc(nloci), locnotes(nloci), group(nloci)) if (newtyp == LOC_CAT .and. & (len_trim(lin)-i+1) > annotation_width) then call add_scheme_annotation(loc(nloci), & string=adjustl(lin(i:len_trim(lin)))) end if else call getchr(loc(nloci), ' ', group(nloci)) end if ! if pedigree workfile already exists, create a new variable if (red) then if (plevel >= 0) then write(*,'(/3a)') 'Creating new variable "', trim(loc(nloci)),'".' end if call addvar(wrk, twrk, dclass, numloc, work, plevel) end if ! set output number of decimal points else if (keyword == 'set' .and. & (keyw2 == 'nde' .or. keyw2 == 'dig' .or. keyw2 == 'wid')) then if (narg > 2) then if (narg > 3) then nwid=ival(words(3)) ndec=ival(words(4)) ncatwid=nwid else if (keyw2 == 'wid') then ncatwid=ival(words(3)) else ndec=ival(words(3)) end if if (nwid <= 0) nwid=9 if (ncatwid <= 0) ncatwid=9 if (ndec > nwid) then ndec=nwid else if (ndec < 0) then ndec=0 end if end if if (plevel > -1) then write(outstr,'(/a,i2,a,i2/7x,a,i0)') & 'NOTE: Number of decimal digits w.d w=', nwid, ' d=', ndec, & 'Width of categorical variables =', ncatwid end if ! output verbosity level else if (keyword == 'set' .and. & (keyw2 == 'out' .or. keyw2 == 'ple')) then if (narg > 2) then if (words(3)(1:3) == 'ver') then plevel=2 else if (words(3) == 'on') then plevel=1 else if (words(3)(1:3) == 'off') then plevel=0 else plevel=ival(words(3)) end if echo=(plevel > 0) end if if (narg < 4) then write(outstr,'(/a,i2/)') 'NOTE: Print level ', plevel end if ! output style, currently affects only print command else if (keyword == 'set' .and. keyw2 == 'pri') then if (narg > 2) then pstyle=1 if (words(3)(1:3) == 'pai') then pstyle=2 else if (words(3)(1:3) == 'obs') then pstyle=3 else if (words(3)(1:3) == 'ver') then pstyle=4 ! mask controlling printing of pedigree variables (ped,id,fa,mo,sex) else pedmask(1:5)=.true. do i=1, len_trim(words(3)) pedmask(i) = (words(3)(i:i) /= '0') end do end if end if if (plevel > -1) then if (pstyle == 1) then write(outstr,'(/a)', advance='no') 'NOTE: Print data as rectangular matrix' else if (pstyle == 2) then write(outstr,'(/a)', advance='no') 'NOTE: Print data as name=value pairs' else if (pstyle == 3) then write(outstr,'(/a)', advance='no') 'NOTE: Print data as nonmissing name=value pairs' else if (pstyle == 4) then write(outstr,'(/a)', advance='no') 'NOTE: Print individual data vertically' end if j=0 do i=1, 5 if (pedmask(i)) then j=j+1 write(outstr, '(1x,2a)', advance='no') trim(pedvar(i)), ',' end if end do if (j > 0) then write(outstr, '(1x,a)', advance='no') 'data' end if write(outstr, '(a/)') '.' end if ! missing value token for writing data else if (keyword == 'set' .and. keyw2 == 'mis') then if (narg > 2) then misval=words(3) end if if (plevel > -1) then write(outstr,'(/3a/)') & 'NOTE: Missing value token set to "', trim(misval), '".' end if ! allele separator for genotypes else if (keyword == 'set' .and. keyw2 == 'gen') then if (narg > 2) then allsep=words(3)(1:1) end if if (plevel > -1) then write(outstr,'(/3a/)') & 'NOTE: Allele separator for writing genotypes set to "', allsep, '".' end if ! table column separator else if (keyword == 'set' .and. keyw2 == 'tab') then if (narg > 2) then tabsep=words(3)(1:1) end if if (plevel > -1) then write(outstr,'(/3a/)') 'NOTE: Table column separator set to "',tabsep,'".' end if ! in tabular locus listing, output or dataset position else if (keyword == 'set' .and. keyw2 == 'lis') then locus_output_position = 3-locus_output_position else if (keyword == 'set' .and. keyw2 == 'cat') then if (words(3)(1:3) == 'lab' .or. words(3) == '2') then show_cat=2 else show_cat=1 end if if (plevel > -1) then if (show_cat == 1) then write(outstr,'(/a/)') & 'NOTE: Values of categorical variables printed as levels.' else write(outstr,'(/a/)') & 'NOTE: Values of categorical variables printed as labels.' end if end if ! use GUI else if (keyword == 'set' .and. keyw2 == 'gui') then if (index(hasextras,'GUI') /= 0) then if (words(3) == 'on' .or. words(3)(1:3) == 'gtk') then gui=1 else if (words(3) == 'off') then gui=0 else gui=ival(words(3)) if (gui < 0) gui=0 end if if (gui==0) then write(outstr,'(/a/)') 'NOTE: GUI off.' else write(outstr,'(/a/)') 'NOTE: GUI activated.' end if else write(outstr,'(/a/)') 'NOTE: GUI not available.' end if ! set pedigree weighting formula else if (keyword == 'set' .and. keyw2 == 'wei') then if (words(3)(1:3) == 'fou') then fndr=1 if (plevel > -1) then write(outstr,'(/a/7x,a/)') & 'NOTE: Using pedigree gene frequencies', & 'weighted by number of founders in pedigree' end if else if (words(3)(1:3) == 'imp') then fndr=2 if (plevel > -1) then write(outstr,'(/a/)') & 'NOTE: Using count of imputed alleles in founders of pedigree' end if else fndr=0 if (plevel > -1) then write(outstr,'(/a/)') 'NOTE: Using unweighted sample gene frequencies' end if end if ! work directory else if (keyword == 'set' .and. keyw2 == 'wor') then if (narg > 2) then call get_filnam(lin, 3, wrkdir) end if if (plevel > -1) then write(outstr,'(/3a/)') & 'NOTE: Directory for temporary files now "', trim(wrkdir),'".' end if ! data directory ! or current work directory else if (keyword == 'set' .and. & (keyw2 == 'dir' .or. keyw2 == 'dat' .or. keyw2 == 'pwd')) then if (narg > 2) then call get_filnam(lin, 3, wrkfil) else call fchooser(wrkfil, gui, plevel) call extpath(wrkfil) end if inquire(file=wrkfil, exist=filexist) if (.not.filexist) then write(outstr,'(/3a)') & 'ERROR: Directory "',trim(wrkfil), '" not found.' else if (keyw2 == 'pwd') then if (wrkfil /= ' ') then #if IFORT i=chdir(trim(wrkfil)) #else call chdir(trim(wrkfil)) #endif write(outstr,'(3a)') 'Current directory set to "', trim(wrkfil), '".' end if else datdir=wrkfil end if if (plevel > -1 .and. keyw2 /= 'pwd') then write(outstr,'(/3a/)') & 'NOTE: Directory for pedigree files now "', trim(datdir),'".' end if else if (keyword == 'set' .and. keyw2 == 'log') then if (narg > 2) then call get_filnam(lin, 3, logfil) end if call openlog(LSTR, logfil, nhis) ! set location of twinship indicator quantitative trait ! have to keep trait name until read to be resolved else if (keyword == 'set' .and. keyw2 == 'twi') then typ=1 if (narg > 2) then if (words(3) == 'off') then twinning=MISS twintype=MISS twintrait=' ' else if (words(3) == 'err') then if (narg > 3) twin_mistyping = fval(words(4)) if (narg > 4) twin_minmarkers = ival(words(5)) write(outstr,'(/a, g9.4/a,i0/)') & 'Monozygotic twin or duplicate mistyping rate = ', twin_mistyping, & 'Minimum number of markers to be used = ', twin_minmarkers else twinning=0 twintrait=words(3) twintype=1 if (words(4)(1:3) == 'mer') twintype=2 typ=2 end if end if if (plevel > -1) then if (twintrait == ' ') then write(outstr,'(/a/)') & 'Twin indicator variable is not currently defined.' else if (twintype == 1) then write(outstr,'(/3a/)') & 'NOTE: The phenotype "', trim(twintrait), & '" indicates monozygotic (twin) sibships.' else if (twintype == 2) then write(outstr,'(/3a/7x,a)') & 'NOTE: The phenotype "', trim(twintrait), & '" indicates monozygotic and', & 'dizygotic (twin) sibships.' end if end if if (red .and. typ == 2) then numcmd=1 call gettrait(twintrait, LOC_ANY, 0, nloci, loc, lochash, loctyp, twinning, 0) commands='mzt;' // trim(commands) end if ! set number of words or terms in expression else if (keyword == 'set' .and. keyw2 == 'nwo' .and..not.red) then if (ival(words(3)) > 0) then maxwords=ival(words(3)) deallocate(words) deallocate(wtyp) deallocate(wtag) deallocate(expr) allocate(words(maxwords)) allocate(wtyp(maxwords)) allocate(wtag(maxwords)) allocate(expr(maxwords,2)) end if write(outstr,'(/a,i7/)') & 'NOTE: Maximum number of words or terms per line ', maxwords else if (keyword == 'set' .and. keyw2 == 'idw' .and..not.red) then if (ival(words(3)) > 0) ped_width_adj=ival(words(3)) if (ival(words(4)) > 0) id_width_adj=ival(words(4)) write(outstr,'(/a,i0,a,i0/)') & 'NOTE: Pedigree ID string maximum length ', ped_width_adj, & '; individual ID ', id_width_adj ! set marker map else if (keyword == 'set' .and. keyw2 == 'map') then ! linkage mapping function if (words(3)(1:3) == 'fun') then if (words(4)(1:3) == 'kos') then mapf=2 else mapf=1 end if if (plevel > -1) then write(outstr,'(/3a/)') & 'NOTE: Using ', mapfunname(mapf), ' mapping function.' end if ! map units else if (words(3)(1:3) == 'uni') then if (words(4) == 'cM') then mapunits=1 mapconstant=1.0d0 else if (words(4) == 'M') then mapunits=2 mapconstant=1.0d2 else if (words(4) == 'Mb' .or. words(4) == 'Mbp') then mapunits=3 mapconstant=1.0d0 else if (words(4) == 'kb' .or. words(4) == 'kbp') then mapunits=4 mapconstant=1.0d-3 else if (words(4) == 'bp') then mapunits=5 mapconstant=1.0d-6 end if if (plevel > -1) then write(outstr,'(/a)', advance='no') 'NOTE: Map positions are in ' if (mapunits == 1) then write(outstr,'(a/)') 'centiMorgans.' else if (mapunits == 2) then write(outstr,'(a/)') 'Morgans.' else if (mapunits == 3) then write(outstr,'(a/)') 'megabase pairs.' else if (mapunits == 4) then write(outstr,'(a/)') 'kilobase pairs.' else if (mapunits == 5) then write(outstr,'(a/)') 'base pairs.' end if end if else if (words(3)(1:3) == 'pos') then call gettrait(words(4), LOC_ANY, 0, nloci, loc, lochash, loctyp, mark, 0) if (mark > 0) then i=index(words(5),':') if (i > 0) then if (isreal(words(5)((i+1):len_trim(words(5))))) then map(mark)=mapconstant*fval(words(5)((i+1):len_trim(words(5)))) group(mark)=words(5)(1:(i-1)) else write(outstr,'(/3a/)') & 'ERROR: Could not parse map position "', trim(words(5)), '".' end if else map(mark)=mapconstant*fval(words(5)) end if else write(outstr,'(/3a/)') & 'ERROR: Locus "', trim(words(4)), '" not on map.' end if else j=2 do i=1, nloci if (isactdip(loctyp(i))) then j=j+1 if (j <= narg) then dist=fval(words(j)) else write(outstr,'(a/)') & 'NOTE: Ran out of user specified map positions.' exit end if map(i)=dist end if end do end if else if (keyword == 'set' .and. keyw2 == 'dis') then j=1 do i=1, nloci if (isactdip(loctyp(i))) then j=j+1 if (j == 2) then dist=0.0 else if (j <= narg) then dist=fval(words(j))+dist else write(outstr,'(a/)') 'NOTE: Ran out of user specified map distances.' dist=dist+100.0d0 end if map(i)=dist end if end do else if (keyword == 'set' .and. keyw2 == 'chr') then if (narg > 2) then j=3 do i=1, nloci if (isactdip(loctyp(i))) then group(i)=words(j) if (j < narg) j=j+1 end if end do else write(outstr,'(a/)') 'ERROR: Need to specify at least one chromosome.' end if ! set significant minimum length of a run of homozygosity for F_roh estimation else if (keyword == 'set' .and. keyw2 == 'roh') then if (narg > 2) then long_roh=mapconstant*fval(words(3)) end if write(outstr,'(a,f12.6,1x,2a/)') & 'NOTE: Shortest significant run of homozygosity = ', & long_roh/mapconstant, trim(mapunitname(mapunits)), '.' ! read map from file else if (keyword == 'rea' .and. keyw2 == 'map') then typ=mapunits ltyp=0 if (narg == 2) then call fchooser(locfil, gui, plevel) else i=3 if (words(3) == 'bim') then i=i+1 ltyp=5 else if (words(3) == 'vcf') then i=i+1 ltyp=4 end if call get_filnam(lin, i, locfil) call concat(datdir, locfil) end if if (words(4)=='kbp') typ=4 if (words(4)=='bp') typ=5 call open_port(locfil, port, 'r', ioerr) if (ioerr == 0) then write(outstr,'(3a)') 'Reading map file "', trim(locfil), '".' call make_lochash(nloci, loc, lochash) if (ltyp == 4) then call read_vcfmap(port, narg, words, plevel) else call readmap(port, typ, ltyp, lin, words, plevel) end if call close_port(port, ioerr) else write(outstr,'(3a)') 'ERROR: File "', trim(locfil), '" not found.' end if ! update sequence map positions from chain file else if (keyword == 'rea' .and. keyw2 == 'cha') then call get_filnam(lin, 3, locfil) call concat(datdir, locfil) call open_port(locfil, port, 'r', ioerr) if (ioerr == 0) then write(outstr,'(3a)') 'Reading chain file "', trim(locfil), '".' call readchain(port, plevel) call close_port(port, ioerr) else write(outstr,'(3a)') 'ERROR: File "', trim(locfil), '" not found.' end if ! read locus statistics (usually a P-value) from file else if (keyword == 'rea' .and. keyw2 == 'sta') then if (words(3) == 'vcf' .and. narg > 3) then call get_filnam(lin, 4, locfil) call getvcfanno(2, locfil, narg-4, words(5:narg), plevel) else if (narg == 2) then call fchooser(locfil, gui, plevel) else call get_filnam(lin, 3, locfil) call concat(datdir, locfil) end if call open_port(locfil, port, 'r', ioerr) if (ioerr == 0) then trait=ival(words(4)) if (trait > 0) then write(outstr,'(a,i0,3a)') & 'Reading statistic from ', trait, 'th column of file "', & trim(locfil), '" for each matching locus.' else write(outstr,'(4a)') & 'Reading statistic from last column of file "', & trim(locfil), '" for each matching locus.' end if gene=ival(words(5)) if (gene > 0) then write(outstr,'(a,i0,3a)') & 'Reading locus name from ', gene, 'th column of file "', & trim(locfil), '".' else gene=1 write(outstr,'(4a)') & 'Reading locus name from first column of file "', & trim(locfil), '".' end if call readstats(port, gene, trait, lin, words, plevel) call close_port(port, ioerr) else write(outstr,'(3a)') 'ERROR: File "', trim(locfil), '" not found.' end if end if ! read annotations, currently from VCF INFO field, and transfer to head of locnotes() else if (keyword == 'rea' .and. keyw2 == 'ann') then if (narg == 2) then call fchooser(locfil, gui, plevel) else call get_filnam(lin, 3, locfil) call concat(datdir, locfil) end if typ=1 if (words(narg) == 'dum' .or. words(narg) == 'dump') then typ=4 narg=narg-1 else if (words(narg) == 'rename') then typ=3 narg=narg-1 end if call getvcfanno(typ, locfil, narg-3, words(4:narg), plevel) ! or (cross-)tabulate else if (keyword == 'sho' .and. keyw2 == 'ann') then if (narg == 2) then call fchooser(locfil, gui, plevel) call tabulate_info(locfil, narg-3, words(4:narg), plevel) else if (isint(words(3))) then call tabulate_anno(narg-2, words(3:narg)) else call get_filnam(lin, 3, locfil) call concat(datdir, locfil) call tabulate_info(locfil, narg-3, words(4:narg), plevel) end if ! ! read a CSV file and infer type of each field then declare else if (keyword == 'rea' .and. keyw2 == 'csv') then if (narg == 2) then call fchooser(pedfil, gui, plevel) else call get_filnam(lin, 3, pedfil) call concat(datdir, pedfil) end if typ=1 inputsep=',' skipline=0 i=4 do while (i <= narg) if (words(i)(1:3) == 'noh') then typ=2 else if (words(i)(1:3) == 'phe') then typ=typ+4 hasgeno=.false. else if (words(i)(1:3) == 'ski') then if (i < narg) then i=i+1 skipline=ival(words(i)) else skipline=1 end if else if (words(i) == 'sep' .and. i < narg) i=i+1 if (words(i) == 'tab') then inputsep=achar(9) else inputsep=words(i)(1:1) end if end if i=i+1 end do call readcsv(trim(pedfil), typ, inputsep, numloc, n, hasid, skipline, plevel) write(outstr,'(/a,i0)', advance='no') 'Read in names of ', n if (n == 1) then write(outstr,'(a)', advance='no') ' locus' else write(outstr,'(a)', advance='no') ' loci' end if write(outstr,'(3a)') ' from "', trim(pedfil), '".' if (.not.red) then link=3 hassex=.false. if (hasid == 2) then link=0 hassex=.true. end if commands='run ; ' // trim(commands) ilevold=ilevel ilevel=0 end if ! read kinship information from text file ped1 id1 ped2 id2 kin ! or read from GCTA format binary GRM else if (keyword == 'rea' .and. (keyw2 == 'grm' .or. keyw2 == 'kin')) then if (red) then call get_filnam(lin, 3, locfil) ridge_constant = 0.0d0 i=4 if ((narg >= i .and. isreal(words(i))) .or. & (narg > i .and. words(i)(1:3) == 'rid' .and. & isreal(words(i+1)))) then if (words(i)(1:3) == 'rid') i=i+1 ridge_constant = fval(words(i)) write(outstr,'(a,f7.5,a)') & 'Using ridge constant = ', ridge_constant, '.' end if if (keyw2 == 'grm') then call readgrm(locfil, ridge_constant, hashtab, work, i, plevel) else call readkin(locfil, ridge_constant, hashtab, work, ifail, plevel) end if else write(outstr,'(a)') 'Require a dataset to match file IDs to.' end if ! read locus information else if (keyword == 'rea' .and. keyw2 == 'loc') then call args(lin, narg, words, ' ', SEP_WHITE) if (narg == 3) then call fchooser(locfil, gui, plevel) else call getword(lin, 4, locfil) call concat(datdir, locfil) end if eos=len_trim(locfil) inquire(file=locfil, exist=filexist) if (filexist .and. eos > 0) then ! Linkage .loc format if (words(3)(1:3) == 'lin') then call open_port(locfil, port, 'r', ioerr) if (ioerr == 0) then call rdlinloc(port, lin, words, numloc) call close_port(port, ioerr) write(outstr,'(/a,i0,3a)') & 'Read in names of ', nloci, ' loci from "', trim(locfil), '".' call ordvar(TWRK, nloci, loc, loctyp, locpos, outpos, nord, & locord, group, map, locstat, locnotes, wloc) call make_lochash(nloci, loc, lochash) else write(outstr,'(3a)') 'ERROR: Unable to open "', trim(locfil), '".' end if ! MERLIN .dat file else if (words(3)(1:3) == 'mer') then xlin=0 do i=5, narg if (words(i)(1:3) == 'xli') then xlin=xlin+1 else if (words(i)(1:3) == 'snp') then xlin=xlin+LOC_CMP end if end do call open_port(locfil, port, 'r', ioerr) if (ioerr == 0) then call setupmer(port, plevel) call rdmerloc(port, xlin, nloci, loc, locpos, outpos, & loctyp, locnotes, numloc, twinning, twintype, & twintrait, n, plevel) call close_port(port, ioerr) call make_lochash(nloci, loc, lochash) write(outstr,'(/a,i0,3a)') & 'Read in names of ', n, ' loci from "', trim(locfil), '".' if (red) then dclass=GCLASS call addvar(wrk, twrk, dclass, numloc, work, plevel) end if else write(outstr,'(3a)') 'ERROR: Unable to open "', trim(locfil), '".' end if ! PLINK .bim (or .map) file else if (words(3)(1:3) == 'pli') then call open_port(locfil, port, 'r', ioerr) if (ioerr == 0) then typ=1 typ1=1 i=5 do while (i <= narg) if (words(i)(1:3) == 'app') typ=typ+1 if (words(i)(1:3) == 'hum') typ1=typ1+1 i=i+1 end do if (typ == 1) then nloci=0 call setup_auto() call make_lochash(nloci, loc, lochash) end if call setup_plink(port, i, j, 2) if (plevel > 0) then write(outstr,'(a,i0,a,i0,a)') & 'Increasing allocation to ', j, ' loci to accomodate ', i, & ' new markers.' end if call rdloci(port, typ, typ1, namechek, nloci, loc, lochash, & locpos, outpos, loctyp, locnotes, numloc, group, map, n) call close_port(port, ioerr) call make_lochash(nloci, loc, lochash) write(outstr,'(/a,i0,3a)') & 'Read in names of ', n, ' loci from "', trim(locfil), '".' if (red) then dclass=SCLASS call addvar(wrk, twrk, dclass, numloc, work, plevel) end if else write(outstr,'(3a)') 'ERROR: Unable to open "', trim(locfil), '".' end if ! VCF file else if (words(3) == 'vcf') then pos=0 if (narg > 4) then if (words(5)(1:3) == 'ann') then pos=51 end if end if call queryvcf(trim(locfil), 2, numloc, pos, plevel) if (red) then dclass=SCLASS call addvar(wrk, twrk, dclass, numloc, work, plevel) end if ! Sib-pair binary dataset else if (words(3) == 'bin') then call decbinloci(trim(locfil), numloc, plevel) ! a text file with appropriate data columns else if (words(3) == 'fil' .or. words(3) == 'file') then if (narg > 6) then write(outstr,'(3a/3a/3a)') & 'Locus name : "', trim(words(5)), '".', & 'Chromosome : "', trim(words(6)), '".', & 'Map position : "', trim(words(7)), '".' if (narg > 8) then write(outstr,'(3a/3a)') & 'Ref allele : "', trim(words(8)), '".', & 'Alt allele : "', trim(words(9)), '".' end if typ=3 typ1=1 if (words(narg)(1:3) == 'hum') typ1=typ1+1 call open_port(locfil, port, 'r', ioerr) if (ioerr == 0) then call setup_plink(port, i, j, 2) if (plevel > 0) then write(outstr,'(a,i0,a,i0,a)') & 'Increasing allocation to ', j, ' loci to accomodate ', i, & ' new markers.' end if call rdloci(port, typ, typ1, namechek, nloci, loc, lochash, locpos, & outpos, loctyp, locnotes, numloc, group, map, n) call close_port(port, ioerr) call make_lochash(nloci, loc, lochash) write(outstr,'(/a,i0,3a)') & 'Read in names of ', n, ' loci from "', trim(locfil), '".' else write(outstr,'(3a)') 'ERROR: Unable to open "', trim(locfil), '".' end if else write(outstr,'(a/7x,a)') & 'ERROR: Need to specify names of columns holding', & 'locus name, chromosome, coordinate.' end if else write(outstr,'(a)') 'ERROR: locus file type not supported' end if else write(outstr,'(3a)') 'ERROR: file ', trim(locfil), ' not found.' end if ! quickly declare loci with autogenerated names ! eg "dec loc 10m 2q 10x 20a" else if (keyword == 'dec' .and. keyw2 == 'loc') then i=3 new=nloci do while (i <= narg) call locfmt(words(i), j, newtyp) do k=1, j nloci=nloci+1 dclass=GCLASS numloc(TCLASS)=numloc(TCLASS)+1 if (nloci > size(loc)) then call expand_loci(1000, plevel) end if outpos(nloci)=numloc(TCLASS) if (ismarker(newtyp)) then if (iscompressed(newtyp)) then dclass=SCLASS locpos(nloci)=-numloc(dclass)-1 else locpos(nloci)=numloc(dclass)+1 end if numloc(dclass)=numloc(dclass) + 2 numloc(TCLASS)=numloc(TCLASS)+1 ndec_m=ndec_m+1 write(words(1),'(i20)') ndec_m loc(nloci)='mar' // trim(adjustl(words(1))) else dclass=PCLASS locpos(nloci)=numloc(dclass)+1 numloc(dclass)=numloc(dclass) + 1 ndec_t=ndec_t+1 write(words(1),'(i20)') ndec_t loc(nloci)='trait' // trim(adjustl(words(1))) end if oldnam=isinuse(namechek, loc(nloci), loc, lochash) if (oldnam) then length=min(20, len_trim(loc(nloci))+1) loc(nloci)(length:length)='_' write(outstr,'(a/7x,3a/)') & 'WARNING: Locus is already declared or a reserved word.', & 'Changed name to "',loc(nloci)(1:length),'".' end if if (namechek) then call insert_lochash(trim(loc(nloci)), nloci, loc, lochash) end if loctyp(nloci)=newtyp group(nloci)=' ' map(nloci)=MISS locnotes(nloci)=' ' end do if (red) then call addvar(wrk, twrk, dclass, numloc, work, plevel) end if i=i+1 end do new=nloci-new if (red) then write(outstr,'(a,i5,a)') 'Created ', new, ' new variables.' else write(outstr,'(a,i5,a)') 'Declared ', new, ' new variables.' end if ! set treatment of duplicate locus declarations - modify name and declare or skip else if (keyword == 'set' .and. keyw2 == 'app') then if (words(3)(1:3) == 'ski' .or. words(3) == 'on') then skipduploc = .true. else if (words(3)(1:3) == 'ver' .or. words(3) == 'off') then skipduploc = .false. end if if (skipduploc) then write(outstr,'(a)') & 'Duplicate locus declarations are skipped.' else write(outstr,'(a)') & 'Duplicate loci are declared under a modified version of name.' end if ! preallocate memory else if (keyword == 'set' .and. keyw2 == 'mem') then i=3 do while (i <= narg) call locfmt(words(i), j, newtyp) if (nloci+j > size(loc)) then call expand_loci(nloci+j-size(loc), plevel) end if if (ismarker(newtyp)) then write(outstr, '(a,i0,a)') & 'Increasing memory allocation to allow ', j, ' markers.' if (iscompressed(newtyp)) then call expand_sgeno(2*j, work, k) else call expand_geno(2*j, work, k) end if else write(outstr, '(a,i0,a)') & 'Increasing memory allocation to allow ', j, ' traits.' call expand_pheno(j, work, k) end if i=i+1 end do if (narg == 2) then write(outstr, '(a)') & 'Specify space to allocate eg 100m=100 markers.' end if ! set threshold for using file storage for data as opposed to memory else if (keyword == 'set' .and. keyw2 == 'vir') then if (narg > 2) then if (words(3)(1:3) == 'def') then mthresh=MATRIX_THRESH_SIZE else mthresh=int(fval(words(3)), kind=8) end if end if if (mthresh == MATRIX_THRESH_SIZE) then write(outstr,'(a)') 'Always store genotype data in memory.' else write(outstr, '(a,i0,a)') & 'Switch to file storage for genotype data when ', mthresh, ' genotypes.' end if ! ! Pedigree file to read from ! link=0 ped or merlin 1=linkage 2=ppd 3=unrelateds 4=no pedigree field else if (keyword == 'rea' .and. & (keyw2 == 'ped' .or. keyw2 == 'mer' .or. & keyw2 == 'cas' .or. keyw2 == 'lin' .or. keyw2 == 'ppd')) then link=0 skipline=0 inputsep=' ' hasid=1 hassex=.true. if (keyw2 == 'lin') then link=1 else if (keyw2 == 'ppd') then link=2 else if (keyw2 == 'cas') then link=3 hassex=.false. end if call getword(lin, 3, pedfil) i=4 do while (i <= narg) if (words(i) == 'sex') then hassex=.true. i=i+1 else if (words(i)(1:3) == 'ski' .and. i < narg) then skipline=ival(words(i+1)) i=i+2 else if (words(i)(1:3) == 'noi') then hasid=0 i=i+1 else if (words(i)(1:3) == 'nos') then hassex=.false. i=i+1 else if (words(i)(1:3) == 'nop') then link=4 i=i+1 else if (words(i)(1:3) == 'sep' .and. i < narg) then inputsep=words(i+1)(1:1) i=i+2 else write(outstr,'(3a)') 'Skipping unknown keyword "', & words(i)(1:len_trim(words(i))),'".' i=i+1 end if end do ! ! pedigree data may be inline: transfer data to temporary file ! following lines are pedigree data, and are terminated by a line ! starting ";;;;". Require exact keyword match to avoid clashes with files. ! if (pedfil == 'inl' .or. pedfil == 'inline') then call mktmpfil(OSTR, pedfil, wrkdir, ioerr) if (ioerr == 0) then call wrinline(nlin, OSTR) close(OSTR, status='keep') inline_input=.true. else write(outstr,'(/a/)') 'ERROR: Cannot create a work file!' pedfil=' ' end if else if (narg == 2) then call fchooser(pedfil, gui, plevel) else call concat(datdir, pedfil) end if if (pedfil /= ' ') then inquire(file=pedfil, exist=filexist) if (.not.filexist) then pedfil=trim(pedfil) // '.gz' inquire(file=pedfil, exist=filexist) if (.not.filexist) then pedfil=pedfil(1:(len_trim(pedfil)-3)) write(outstr,'(/3a/7x,3a/)') & 'NOTE: Pedigree file "',trim(pedfil), & '" does not exist.','Trying "', trim(words(3)),'".' pedfil=words(3) inquire(file=pedfil, exist=filexist) if (.not.filexist) then write(outstr,'(/3a/)') 'ERROR: Pedigree file "',trim(pedfil), & '" does not exist.' pedfil=' ' end if end if end if end if end if ! ! readbin() and mergebed() bypass usual input checks ! else if (keyword == 'rea' .and. & (keyw2 == 'bin' .or. keyw2 == 'pli' .or. & keyw2 == 'bed' .or. keyw2 == 'vcf')) then typ=1 if (narg == 2) then call fchooser(pedfil, gui, plevel) else call getword(lin, 3, pedfil) call concat(datdir, pedfil) end if ! ! read a Sib-pair bin file if (keyw2 == 'bin') then if (words(4) == 'old') then typ=typ+1 else if (words(4)(1:3) == 'dat') then typ=typ+2 end if call readbin(INSTRM, pedfil, wrkfil, typ, numloc, work, red, plevel) ! added 20140204 nord=nloci call ascend(nord, locord) ! ! read VCF file or files ! else if (keyw2 == 'vcf') then n=0 if (narg > 3) then if (isint(words(narg))) then n=ival(words(narg)) narg=narg-1 end if if (words(narg) == 'ped' .or. words(narg) == 'ped_id') then typ=typ+1 narg=narg-1 end if end if if (narg == 3) then call readvcf(typ, .false., ' ', gt, thresh, n, pedfil, numloc, & hashtab, work, red, plevel) else call readmultvcf(typ, narg-2, words(3:narg), numloc, work, red, plevel) end if ! ! read PLINK .fam .bim .bed files ! read in .fam file ! subsequently merge in .bed file genotypes else if (pedfil /= ' ') then call extprefix(pedfil, '.bed') call concat(datdir, pedfil) if (narg == 3) words(4) = 'join' if (narg == 4 .and. words(4)(1:3) == 'hum') words(5) = 'join' lin='clear data; set loc trait aff; read ped ' // & trim(pedfil) // '.fam; ' // & 'run; merge bed ' // trim(pedfil) // & ' ' // trim(words(4)) // ' ' // trim(words(5)) commands=trim(lin) // '; ' // trim(commands) ilevold=ilevel ilevel=0 else write(outstr,'(a)') 'No file name given' end if end if call make_lochash(nloci, loc, lochash) ! read a HapMap format genotypes file else if (keyword == 'rea' .and. keyw2 == 'hap') then if (narg == 2) then call fchooser(pedfil, gui, plevel) else call get_filnam(lin, 3, pedfil) call concat(datdir, pedfil) end if call readhapmap(pedfil, numloc, work, longnam, red, plevel) call make_lochash(nloci, loc, lochash) else if (keyword == 'run') then if (red) then write(outstr,'(a)') & 'NOTE: Skipping "run" statement as data already read in!' cycle end if if (plevel > 0) then call info(lin, burnin, imp, iter, & mapf, mincnt, plevel, genemod, & showorig, chek, droperr, prompt, use2, gui, & twintrait, sexmarker, datdir, wrkdir) end if write(outstr,'(a,a/a,i0)') & 'Pedigree file = ', trim(pedfil), & 'Number of loci = ', nloci - ENVNUM call make_lochash(nloci, loc, lochash) nord=nloci call ascend(nord, locord) if (plevel > 0) then call listloci(nord, locord, nloci, loc, loctyp, outpos, locnotes, & 1, prompt, plevel) end if inquire(file=pedfil, exist=filexist) if (filexist) then if (red) call cleanup_peds(work) red=.true. inconsist=0 allocate(coltyp(numloc(TCLASS))) call asstyp(nloci, loctyp, locpos, numloc(TCLASS), coltyp) call open_port(pedfil, port, 'r', ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open file "', trim(pedfil), '"' red=.false. cycle end if call reclen(port, lin, i, -1, .false.) if (plevel >= -3) then write(outstr,'(a,i0,a)') 'Max record length is ', i, ' characters' end if if (link /= 3) then if (twintrait /= ' ') then call gettrait(twintrait, LOC_ANY, 0, nloci, loc, lochash, loctyp, twinning, 0) if (twinning /= MISS) then write(outstr,'(a/)') 'Monozygotic twin pair error checking.' twinning=locpos(twinning) thresh=0.0d0 gt=COMP_GT if (twintype==2) gt=COMP_ODD end if end if if (link == 4) then call readpeds(port, WRK, WRK2, inputsep, skipline, link, unspecified, & twinning, gt, thresh, sexchek, hassex, nonextped, & numloc, coltyp, work, longnam, i, nwarn, plevel) else call readpeds(port, WRK, WRK2, inputsep, skipline, link, unspecified, & twinning, gt, thresh, sexchek, hassex, nextped, & numloc, coltyp, work, longnam, i, nwarn, plevel) end if else call readcases(port, hasid, hassex, hasgeno, inputsep, skipline, numloc, & coltyp, locnotes, work, longnam, i, nwarn, plevel) end if call close_port(port, ioerr) if (inline_input) then call delfile(pedfil, plevel-2) inline_input=.false. end if deallocate(coltyp) call duplicates(work, plevel) call tidydata(nloci, loctyp, locpos, work, tottyp) if (chek) then call testsex(1, sexcrit, sexmarker, heterror, & nloci, loc, lochash, loctyp, locpos, & work, allele_buffer, inconsist, plevel) if (twintrait /= ' ') then call gettrait(twintrait, LOC_ANY, 0, nloci, loc, lochash, loctyp, twinning, 0) if (twinning /= MISS) then write(outstr,'(a/)') 'Monozygotic twin pair error checking.' twinning=locpos(twinning) thresh=0.0d0 gt=COMP_GT if (twintype == 2) gt=COMP_ODD call mzgtp(twinning, gt, thresh, & nloci, loc, loctyp, locpos, work, inconsist, -2) if (droperr > 0) then typ=4 call dropt2(twinning, gt, thresh, typ, & nloci, loc, loctyp, locpos, work, plevel) end if else write(outstr,'(3a)') 'ERROR: Specified zygosity indicator "', & trim(twintrait), '" not a declared locus!' end if end if write(outstr,'(a/)') 'Nuclear family error checking.' call setup_stat('Mendelian error rate', typ=2) call check(.true., nloci, loc, loctyp, locpos, locnotes, locstat, & work, droperr, ndiscard, inconsist, plevel) write(outstr,'(a/)') 'Nuclear family error checking completed.' end if ! ! List number of problems encountered ! if (nwarn > 0) then write(outstr,'(/a,i0)') 'Number of warnings = ', nwarn end if write(outstr,'(a,i0)') 'Number of data problems = ', inconsist if (droperr > 0) then write(outstr,'(a,i0,1x,a)') & 'Number discarded genotypes = ', ndiscard, & trim(wrpercent(ndiscard,tottyp)) else if (inconsist > 0) then write(outstr,'(/a/7x,a/7x,a)') & 'NOTE: Too many errors. Stopping prematurely.', & 'Check your data! If you wished to continue regardless,', & 'you need to start your commands with "set error_drop on".' exit main_loop end if if (imp >= 0) then call exclude(imp, nloci, loc, loctyp, locpos, work, & inconsist, imputd, plevel) if (imp < 3) then call start(maxtry, nloci, loc, loctyp, locpos, work, allele_buffer, & inconsist, plevel) end if write(outstr,'(a/)') 'Starting values for missing genotypes generated.' end if if (incaction(ilevel) == 2) then write(outstr,'(/3a/)') 'Closing include file "',trim(infil(ilevel)),'".' close(incstr(ilevel), status='keep') toplevel=toplevel-1 ilevel=ilevel-1 end if longnam=min(longnam+3,10) call sumped(nloci, loctyp, locpos, work) else write(outstr,'(/3a/)') 'ERROR: Need to declare a pedigree file.' end if ! ! Test relatedness to everyone in active pedigrees (eg for sample mixup) wrt ! genotype or age; or check sex markers or haploid data or Mendel errors or ! strandedness problems or map for duplicates or inconsistencies or ids for ! duplicates ! else if (keyword == 'tes' .and. keyw2 == 'map') then typ=1 typ1=1 thresh=0.005d0 if (words(3) == 'mer' .or. words(3) == 'merge') then typ=typ+1 if (narg == 4) thresh=fval(words(4)) else if (narg > 2) then typ=3 call get_filnam(lin, 3, locfil) call concat(datdir, locfil) call open_port(locfil, port, 'r', ioerr) if (words(4)(1:3) == 'hum') typ1=typ1+1 end if if (typ == 3) then if (ioerr == 0) then write(outstr,'(/3a)') 'Comparing current map to "', trim(locfil),'".' call setup_stat('map comparison 1=name 2=pos 3=perfect 4=dups', typ=2) call comparemap(porT, typ1, plevel) call close_port(port, ioerr) else write(outstr,'(3a)') 'ERROR: File "', trim(locfil), '" not found.' end if else write(outstr,'(/a)') 'Testing current map' call setup_stat('map position duplicates', typ=2) call testmap(typ, thresh, nloci, loc, loctyp, locpos, & locnotes, group, map, locstat, work, plevel) end if else if (keyword == 'tes' .and. keyw2 == 'fli') then if (words(3) == 'map') then ioerr=0 typ=1 if (narg > 2) then call get_filnam(lin, 4, locfil) call concat(datdir, locfil) call open_port(locfil, port, 'r', ioerr) if (ioerr == 0) then typ=typ+1 write(outstr,'(3a)') 'Reading map file "', trim(locfil), '".' end if if (ioerr == 0) then call testflips_map(port, plevel) if (typ == 2) call close_port(port, ioerr) else write(outstr,'(3a)') 'ERROR: File "', trim(locfil), '" not found.' end if else write(outstr,'(a)') 'ERROR: Expected name of a map file.' end if else if (words(3)(1:3) == 'fas') then call get_filnam(lin, 4, locfil) call testflips_fasta(1, locfil, plevel) else call gettrait(words(3), LOC_ANY, 0, nloci, loc, lochash, loctyp, trait, 1) if (trait /= MISS) then typ=2 thresh=0.0d0 if (words(4) == 'lod') typ=1 if (narg > 4) thresh=fval(words(5)) write(outstr,'(/3a)') & 'Testing allele swaps by source "', trim(loc(trait)), '".' call setup_stat('Putative allele swaps by source "' // & trim(loc(trait)) // '"', typ=typ) if (plevel > -1) then write(outstr,'(/a/a)') & 'Marker All Diagn Level Chi-sq[1] Chi-sq[0] lod', & '-------------------- --- ------- -------- ------------- --------------- -----' end if do i=1, nloci if (same_loctyp(loctyp(i), LOC_CODOM) .and. irupt == 0) then call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) call testflips_source(1, thresh, loc(trait), locpos(trait), & loctyp(trait), & locnotes(trait), locpos(i), loc(i), & allele_buffer, work, gibbs, statval, plevel) locstat(i)=statval(typ) end if end do else write(outstr,'(a)') 'ERROR: Expected marker source indicator variable.' end if end if else if (keyword == 'tes' .and. red) then ! use informative markers to check sex if (narg==2 .and. words(2) == 'sex') then call testsex(1, sexcrit, sexmarker, heterror, & nloci, loc, lochash, loctyp, locpos, & work, allele_buffer, inconsist, plevel) ! same as hash file <ext_id_list> else if (narg > 2 .and. (words(2) == 'id' .or. words(2) == 'ids')) then call get_filnam(lin, 3, wrkfil) call open_port(wrkfil, port, 'r', ioerr) if (ioerr == 0) then i=0 j=0 if (narg == 5) then i=ival(words(4)) j=ival(words(5)) else if (narg == 4) then if (words(4)(1:3) == 'ped') then j=-1 else j=ival(words(4)) end if end if call findids(port, lin, i, j, hashtab, work, plevel) call close_port(port, ioerr) else write(outstr,'(/3a/)') & 'ERROR: Problem opening ID file "', trim(wrkfil), '".' end if ! test for Mendelian inconsistencies using Mt or Y loci else if (keyw2=='hap') then typ=1 if (words(3)(1:3) == 'mit') typ=typ+1 call testhap(typ, nloci, loc, loctyp, locpos, & work, inconsist, plevel) ! test consistency of ages across generations else if (words(2) == 'age') then thresh=0.0d0 call gettrait(words(3), LOC_QUA, 0, nloci, loc, lochash, loctyp, trait, 1) if (trait /= MISS) then if (narg == 4) thresh=fval(words(4)) call testage(1, loc(trait), locpos(trait), thresh, work, droperr) else write(outstr,'(a)') 'ERROR: Need to specify quantitative trait for age.' end if ! test consistency of birth dates across generations or within sibships else if (words(2) == 'dob') then typ=2 call gettrait(words(3), LOC_QUA, 0, nloci, loc, lochash, loctyp, trait, 1) if (trait /= MISS) then if (words(4)(1:3) == 'gre') then typ=typ+1 thresh=4380.0d0 if (narg>4) thresh=fval(words(5)) else if (narg>3) then thresh=fval(words(4)) end if call testage(typ, loc(trait), locpos(trait), thresh, work, droperr) call testsibage(typ, loc(trait), locpos(trait), ' ', MISS, 0.0d0, work) else write(outstr,'(a)') 'ERROR: Need to specify quantitative trait for DOB.' end if ! test for Mendelian inconsistencies for autosomal markers else if (keyw2 == 'loc') then call setup_stat('Mendelian error rate: "' & // trim(lin) // '"', typ=2) if (narg > 2) then call loadnam(3, narg, words, nloci, loc, lochash, loctyp, group, & map, locstat, wloc, nord, locord, LOC_ANY, 3) do i=1, nloci if (wloc(i) > 0) then wloc(i)=loctyp(i) else wloc(i)=LOC_DEL end if end do call check(.false., nloci, loc, wloc, locpos, locnotes, locstat, & work, droperr, ndiscard, inconsist, plevel) else call check(.false., nloci, loc, loctyp, locpos, locnotes, locstat, & work, droperr, ndiscard, inconsist, plevel) end if else if (keyw2 == 'lan') then write(outstr, '(/a)') & 'Checking for Mendelian inconsistencies using Lange-Goradia approach:' inconsist=0 imputd=0 call setup_stat('Mendelian error rate (Lange-Goradia): "' & // trim(lin) // '"', typ=2) if (narg > 2) then call loadnam(3, narg, words, nloci, loc, lochash, loctyp, group, & map, locstat, wloc, nord, locord, LOC_ANY, 3) do i=1, nloci if (wloc(i) > 0) then if (plevel > -1) then write(outstr, '(a)') loc(i) end if call exclude_onelocus(3, locpos(i), loc(i), loctyp(i), work, & inconsist, imputd, pedincon, plevel) locstat(i)=pedincon end if end do else do i=1, nloci if (isactdip(loctyp(i))) then call exclude_onelocus(3, locpos(i), loc(i), loctyp(i), work, & inconsist, imputd, pedincon, plevel) locstat(i)=pedincon end if end do end if write(outstr,'(a,i0/a,i0)') & ' Mendelian inconsistencies = ', inconsist, & ' Imputed genotyped = ', imputd ! test for likely strand mixups else if (keyw2 == 'str') then call loadnam(3, narg, words, nloci, loc, lochash, loctyp, group, map, & locstat, wloc, nord, locord, LOC_ANY, 1) call setup_stat('putative strand mixups', typ=2) if (plevel > 0) then write(outstr,'(/a/a)') & 'Locus Alleles HWE P Action', & '-------------- --------- --------- ----------' end if do i=1, nord trait=locord(i) if (ismarker(loctyp(trait)) .and. isactive(loctyp(trait))) then call freq(locpos(trait), loctyp(trait), fndr, work, allele_buffer) if (allele_buffer%numal == 3 .or. allele_buffer%numal == 4) then call dohwe(loc(trait), locpos(trait), loctyp(trait), 0, mincnt, .false., & norder, work, pval, 2, plevel-2) locstat(trait)=pval end if end if end do ! test zygosity against current kinship matrix else if (keyw2 == 'zyg') then call highkin(work, plevel) else if (keyw2 == 'dup') then if (words(3) == 'id' .or. words(3) == 'ids') then typ=1 thresh=twin_mistyping i=4 do while (i <= narg) if (words(i)(1:3) == 'mer') then typ=2 else thresh=fval(words(i)) end if i=i+1 end do call duptest(typ, nloci, loc, loctyp, locpos, work, & thresh, twin_minmarkers, plevel) ! flag full sibs with same DOB else if (words(3) == 'dob') then call gettrait(words(4), LOC_QUA, LOC_CAT, nloci, loc, lochash, loctyp, trait, 1) call gettrait(words(5), LOC_QUA, LOC_CAT, nloci, loc, lochash, loctyp, censor, 1) if (trait /= MISS .and. censor /= MISS) then thresh=0.0d0 if (narg > 5) then thresh=fval(words(6)) end if call testsibage(typ, loc(trait), locpos(trait), & loc(censor), locpos(censor), thresh, work) else write(outstr,'(a,7x,a)') & 'NOTE: Needed to specify the DOB variable and a quantitative trait', & 'to save the DOB duplication indicator.' end if else call setup_stat('Number of discordances', typ=2) call gettrait(words(3), LOC_QUA, LOC_CAT, nloci, loc, lochash, loctyp, trait, 1) call mzfind(2, trait, twin_mistyping, twin_minmarkers, nloci, loc, loctyp, locpos, & locstat, work, plevel) if (narg > 2 .and. trait == MISS) then write(outstr,'(a/7x,a)') & 'NOTE: Needed to specify a quantitative trait', & 'to save the duplication indicator.' end if end if ! compare current dataset genotypes to external FImpute file else if (keyw2 == 'fim') then typ=3 typ1=1 typ2=2 i=5 do while (i <= narg) if (words(i)(1:3) == 'hum') then typ1=2 else if (words(i) == 'ped_id') then typ2=1 end if i=i+1 end do call get_filnam(lin, 3, locfil) call get_filnam(lin, 4, wrkfil) call hashids(typ2, work, hashtab, 80, plevel) call mergefim(typ, locfil, wrkfil, typ1, typ2, hashtab, work, plevel) ! compare current dataset genotypes to external VCF file else if (keyw2 == 'vcf') then addref=.false. typ=7 n=0 qualstat=' ' gt=0 thresh=MISS if (narg == 2) then call fchooser(wrkfil, gui, plevel) else call get_filnam(lin, 3, wrkfil) if (narg > 3) then i=4 do while (i <= narg) if (words(i)(1:3) == 'ped') then typ=6 else if (words(i)(1:3) == 'ref') then addref=.true. else if (words(i)(1:3) == 'qua') then if (i < narg) then i=i+1 qualstat=words(i) if (i < narg) then if (iscomp(words(i+1))) then i=i+1 call docomp(i, words, gt, thresh) end if end if end if else n=ival(words(i)) end if i=i+1 end do end if end if call readvcf(typ, addref, qualstat, gt, thresh, n, wrkfil, numloc, hashtab, work, red, plevel) ! check relationships between pairs of relatives using autosomal markers else if (narg == 3) then if (.not.hashtab%current .or. hashtab%keytyp /= 1) then call hashids(1, work, hashtab, 80, plevel) end if call matchid(1, words(2), words(3), work, hashtab, i, 2) if (i > 0) then call ibskin(5, i, gt, thresh, nloci, loc, loctyp, locpos, & work, plevel) end if else if (narg == 5) then if (.not.hashtab%current .or. hashtab%keytyp /= 1) then call hashids(1, work, hashtab, 80, plevel) end if call matchid(1, words(2), words(3), work, hashtab, i, 2) call matchid(1, words(4), words(5), work, hashtab, j, 2) if (i > 0 .and. j > 0) then call prdiscord(i, j, nloci, loc, loctyp, locpos, locnotes, work, plevel) else write(outstr,'(a)') 'Expected ped1 id1 ped2 id2.' end if else write(outstr,'(a)') 'ERROR: Need to specify keyword or pedigree plus individual ID.' end if ! Test sib pair relatedness using mean IBS sharing else if (keyword == 'cki' .and. red) then call ckibs(nloci, loctyp, locpos, allele_buffer, work) ! Test putative MZ twins else if (keyword == 'mzt' .and. red) then call gettrait(words(2), LOC_TRA, 0, & nloci, loc, lochash, loctyp, trait, -1) gt=0 typ=1 thresh=MISS ! while not end of list of keywords i=3 if (trait == MISS) i=i-1 do while (i <= narg) keyword=words(i)(1:3) if (iscomp(keyword)) then call docomp(i, words, gt, thresh) else if (keyword == 'dro' .or. keyword == 'del') then typ=2 i=i+1 else if (keyword == 'unl') then typ=3 i=i+1 else if (keyword == 'cle') then typ=4 i=i+1 else if (keyword == 'fin') then typ=5 i=i+1 else write(outstr,'(3a)') 'Skipping unknown keyword "', trim(words(i)), '".' i=i+1 end if end do if (trait == MISS .and. twintrait /= ' ') then call gettrait(twintrait, LOC_ANY, 0, nloci, loc, lochash, loctyp, trait, 0) end if if (typ == 5) then call setup_stat('Number of discordances', typ=2) call mzfind(1, trait, twin_mistyping, twin_minmarkers, nloci, loc, loctyp, locpos, & locstat, work, plevel) else if (trait /= MISS) then if ((loctyp(trait) == LOC_QUA .or. loctyp(trait) == DEL_QUA .or. & loctyp(trait) == LOC_CAT .or. loctyp(trait) == DEL_CAT) .and. & thresh == MISS) then thresh=0.0d0 gt=16 if (twintype == 2) gt=21 end if call mzgtp(locpos(trait), gt, thresh, & nloci, loc, loctyp, locpos, work, inconsist, plevel) if (typ /= 1) then call dropt2(locpos(trait), gt, thresh, typ, & nloci, loc, loctyp, locpos, work, plevel) end if else write(outstr,'(a)') 'ERROR: need to specify zygosity indicator.' end if ! Make new IDs else if (keyword == 'uni' .and. red) then typ=1 if (keyw2 == 'seq') then typ=2 end if if (plevel > -1) then write(outstr,'(a/a/)') & 'Renaming each pedigree and individual to unique numerical ID.', & 'Inactive pedigrees are not renumbered!' if (typ == 2) write(outstr,'(a)') 'Individual IDs are sequential.' end if call uniqid(typ, work, plevel) ! Break into component nuclear families else if (keyword == 'nuc' .and. red) then maxsibs=MISS typ=1 do i=2, narg if (words(i)(1:3) == 'gra') then typ=2 else maxsibs=ival(words(i)) end if end do write(charnum,'(i10)') work%nact write(outstr,'(/3a/a)') & 'Dividing ', trim(adjustl(charnum)),' pedigrees into nuclear families.', & 'Individuals are duplicated as necessary.' if (maxsibs > 0) then write(outstr,'(a,i3,a)') & 'Sibships with more than ', maxsibs, ' members are truncated.' end if if (maxsibs < 0 .or. maxsibs > (work%maxsiz-2)) maxsibs=work%maxsiz-2 call nuclear(wrk, wrk2, typ, maxsibs, work) hashtab%current=.false. ! break into unrelated cases and controls else if (keyword == 'cas' .and. red) then call gettrait(words(2), LOC_ANY, 0, nloci, loc, lochash, loctyp, trait, 1) if (trait /= MISS) then typ=1 typ2=1 if (words(3) == 'all') typ=2 if (words(3) == 'new' .or. words(4) == 'new') typ2=2 write(outstr,'(/a/3a/)') & 'Extracting unrelated cases from pedigrees.', & 'Subjects must be nonmissing for "', trim(loc(trait)), '".' call wricas(typ, typ2, wrk, twrk, locpos(trait), work) hashtab%current=.false. else write(outstr,'(a)') 'ERROR: Need to specify caseness trait.' end if ! extract disjoint subpedigrees else if (keyword == 'sub' .and. red) then call disjoin(wrk, wrk2, work, plevel) hashtab%current=.false. ! prune pedigree to affecteds plus connectors else if (keyword == 'pru' .and. red) then call getbin(2, narg, words, nloci, loc, lochash, loctyp, trait, gt, thresh) if (trait /= MISS) then call prunep(wrk, twrk, loc(trait), locpos(trait), gt, thresh, work, plevel) hashtab%current=.false. else write(outstr,'(a)') 'ERROR: Need to specify trait to prune on.' end if ! join pedigrees up else if (keyword == 'joi' .and. red) then i=2 if (narg == 1) then call listids(work, 2, 0, 2) write(outstr,'(a)', advance='no') 'choice> ' read(*,'(a)') lin if (ilevel == 1 .and. logstr /= 0) then write(logstr,'(a)') 'join ' // lin(1:len_trim(lin)) end if call args(lin, narg, words, ' ', SEP_WHITE) i=i-1 end if if (chek) then call setup_stat('Mendelian error rate due to pedigree join', typ=2) end if call joinped(wrk, wrk2, 1, i, narg, words, & nloci, loc, locpos, loctyp, locnotes, locstat, & work, chek, droperr, plevel) hashtab%current=.false. if (imp == 0) then call start(maxtry, nloci, loc, loctyp, locpos, work, & allele_buffer, inconsist, -2) end if ! edit <pedigree> <person> <trait> to <value1> [<value2>] else if (keyword == 'edi' .and. red) then call args(lin, narg, words, ' ', 3) call gettrait(words(4), LOC_ANY, 0, nloci, loc, lochash, loctyp, trait, 0) if (trait /= MISS) then if (isactdip(loctyp(trait))) then i=index(words(narg), '/') gcode=gencode(loctyp(trait)) if (i > 0) then all1=aval(words(narg)(1:(i-1)), gcode) all2=aval(words(narg)(i+1:len_trim(words(narg))), gcode) else all1=aval(words(narg-1), gcode) all2=aval(words(narg), gcode) end if else if (ishaploid(loctyp(trait))) then all1=aval(words(narg), 1) else if (iscattrait(loctyp(trait))) then call get_whichcat(words(narg), trait, all1) else all1=fval(words(narg)) end if call edit(words(2)(1:ped_width), words(3)(1:id_width), & locpos(trait), loc(trait), loctyp(trait), & all1, all2, work, plevel) else write(outstr,'(a)') 'ERROR: need to specify locus to edit.' end if ! delete data for <pedigree> <person> or condition else if (keyword == 'del') then typ=0 call args(lin, narg, words, ' ', SEP_WH_RES) i=findwh(2, narg, narg, words) if (i /= 0) then typ=2 call loadnam(2, i-1, words, nloci, loc, lochash, loctyp, group, map, & locstat, wloc, nord, locord, LOC_ANY, 1) else if (narg == 3) then typ=1 end if if (typ /= 0 .and. red) then if (typ == 1) then call edit(words(2)(1:ped_width), words(3)(1:id_width), & MISS, words(1), MISS, 0.0D0, 0.0D0, work, plevel) else call seldel(nord, locord, i+1, narg, words, nloci, loc, lochash, & loctyp, locpos, wtyp, wtag, expr, work, plevel) end if else write(outstr,'(a)') 'ERROR: Target to be deleted could not be parsed.' end if ! standardize quantitative trait else if (keyword == 'sta' .and. red) then call gettrait(words(2), LOC_QUA, 0, nloci, loc, lochash, loctyp, trait, 0) if (trait /= MISS) then typ=1 if (words(3)(1:3) == 'fam') then typ=2 write(outstr,'(/3a)') 'Standardizing "', trim(loc(trait)), & '" WITHIN each family to mean=0, variance=1.' else write(outstr,'(/3a)') 'Standardizing "', trim(loc(trait)), & '" to mean=0, variance=1.' end if call stand(locpos(trait), work, typ) else write(outstr,'(a)') 'ERROR: Need to specify locus to standardize.' end if ! Life table analysis else if (keyword == 'lif' .and. red) then if (words(2) == '0') then trait=0 else call gettrait(words(2), LOC_QUA, 0, nloci, loc, lochash, loctyp, trait, 0) end if call gettrait(words(3), LOC_QUA, 0, nloci, loc, lochash, loctyp, gene , 0) call gettrait(words(4), LOC_AFF, 0, nloci, loc, lochash, loctyp, censor, 0) if ((trait == 0 .or. trait /= MISS) .and. gene /= MISS .and. & censor /= MISS) then write(outstr,'(/a/3a/a)') & '------------------------------------------------', & 'Life table analysis for "', trim(loc(censor)), '"', & '------------------------------------------------' censor=locpos(censor) if (trait > 0) then write(outstr,'(3a)') & '"', trim(loc(trait)), '" is start of observation period.' trait=locpos(trait) end if write(outstr,'(3a)') & '"', trim(loc(gene)), '" is end of observation period.' gene=locpos(gene) mark=MISS typ=1 pars(1)=1.0d0 pars(2)=1.0d0 if (words(narg-1) == 'cov' .or. words(narg-1) == 'covariate') then call gettrait(words(narg), LOC_ANY, 0, nloci, loc, lochash, loctyp, mark, 0) if (mark /= MISS) then write(outstr,'(3a)') & '"', trim(loc(mark)), '" is covariate.' ltyp=loctyp(mark) mark=locpos(mark) end if narg=narg-2 end if if (words(narg)(1:3) == 'day') then narg=narg-1 typ=2 pars(1)=365.25d0 pars(2)=365.25d0 write(outstr,'(a)') 'Units are days, strata defined in years.' else if (words(narg)(1:3) == 'tim') then narg=narg-1 typ=3 pars(1)=100.0d0 pars(2)=100.0d0 else write(outstr,'(a)') 'Strata defined in years.' end if if (narg >= 5) then pars(1)=fval(words(narg-1)) pars(2)=fval(words(narg)) if (pars(1) == 0.0d0) pars(1)=1.0d0 if (pars(2) == 0.0d0) pars(2)=pars(1) end if call lifetab(trait, gene, censor, mark, ltyp, & pars(1), pars(2), typ, work, plevel) else write(outstr,'(a)') 'ERROR: Need to specify start, end, and censoring traits.' end if ! K-M survival analysis and nonparametric survivor residuals else if (keyword == 'kap' .and. red) then call gettrait(words(2), LOC_QUA, 0, nloci, loc, lochash, loctyp, trait, 0) call gettrait(words(3), LOC_AFF, 0, nloci, loc, lochash, loctyp, prob, 0) if (trait /= MISS .and. prob /= MISS) then write(outstr,'(/a/3a/a)') & '------------------------------------------------', & 'Kaplan-Meier survivor function for "', trim(loc(trait)), '"', & '------------------------------------------------' write(outstr,'(3a)') '"', trim(loc(prob)), '" is outcome (censoring) trait.' typ=1 gene=MISS if (words(4)(1:2) == 're') then typ=2 call gettrait(words(5), LOC_QUA, 0, nloci, loc, lochash, loctyp, gene, 0) if (gene == MISS) gene = trait write(outstr,'(/3a)') & 'Replacing value of "', trim(loc(gene)), '" with nonparametric residual.' gene=locpos(gene) end if trait=locpos(trait) prob=locpos(prob) call prodlim(trait, prob, work, typ, gene, plevel) else write(outstr,'(a)') 'ERROR: Need to specify age trait and censoring trait.' end if ! log-rank survival analysis else if (keyword == 'sur') then call gettrait(words(2), LOC_QUA, 0, nloci, loc, lochash, loctyp, trait, 0) call gettrait(words(3), LOC_AFF, 0, nloci, loc, lochash, loctyp, censor, 0) if (trait /= MISS .and. censor /= MISS) then write(outstr,'(/a/3a/a/3a)') & '------------------------------------------------------', & 'Nonparametric survival analysis of trait "', & trim(loc(trait)), '"', & '------------------------------------------------------', & '"', trim(loc(censor)), '" is outcome (censoring) trait.' whlik=3-whlik mcall(whlik)=trim(lin) if (narg > 3) then typ=3 call loadnam(4, narg, words, nloci, loc, lochash, loctyp, group, map, & locstat, wloc, nord, locord, LOC_ANY, 1) nord=nord+1 locord(nord)=trait nord=nord+1 locord(nord)=censor write(outstr,'(a)', advance='no') 'Covariates:' do i=1, nord-2 write(outstr,'(1x,a)', advance='no') trim(loc(locord(i))) end do write(outstr,*) call logrank(typ, nord, locord, nloci, loc, loctyp, locpos, locnotes, & work, nwid, ndec, mlik(whlik), mpar(whlik), pval, plevel) else typ=4 call setup_stat(lin) if (plevel == 0 .or. plevel == -1) then write(outstr,'(/a/a)') & 'Marker Nobs NAff Chi-square Asy P Emp P Iters', & '-------------------- ------ ------ ---------- ------ ------ ------' end if do i=1, nloci if (isactdip(loctyp(i)) .and. irupt == 0) then call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) call simlogrank(loc(i), locpos(i), locpos(trait), locpos(censor), & iter, mincnt, norder, work, allele_buffer, pval, & plevel) locstat(i)=pval end if end do if (plevel < -1) then call sumstat(5, plevel) end if end if else write(outstr,'(/a)') 'ERROR: quantitative trait or covariate misspecified.' end if else if (keyword == 'tre') then call gettrait(words(2), LOC_QUA, 0, nloci, loc, lochash, loctyp, trait, 0) call gettrait(words(3), LOC_CODOM, 0, nloci, loc, lochash, loctyp, gene, 0) if (trait /= MISS) then if (gene /= MISS) then write(outstr,'(/a/5a/a)') & '------------------------------------------------------', & 'Nonparametric association analysis of trait "', & trim(loc(trait)), '" v. "', trim(loc(gene)), '"', & '------------------------------------------------------' call freq(locpos(gene), loctyp(gene), fndr, work, allele_buffer) typ=1 if (words(4)(1:3) == 'per') then typ=typ+1 write(outstr,'(a)') 'NOTE: Permutation approach used.' end if if (plevel == -1) then write(outstr,'(/a/a)') & 'Marker Typed Allels J-T stat Wald P Emp P Iters', & '-------------------- ------ ------ ---------- ------ ------ --------' end if call simtrend(typ, loc(gene), locpos(gene), locpos(trait), iter, mincnt, & norder, work, allele_buffer, pval, plevel+1) else write(outstr,'(/a/3a/a)') & '------------------------------------------------------', & 'Nonparametric association analysis of trait "', & trim(loc(trait)), '"', & '------------------------------------------------------' typ=1 if (words(3)(1:3) == 'per') then typ=typ+1 write(outstr,'(a)') 'NOTE: Permutation approach used.' end if if (plevel > -2 .and. plevel < 1) then write(outstr,'(/a/a)') & 'Marker Typed Allels J-T stat Wald P Emp P Iters', & '-------------------- ------ ------ ---------- ------ ------ --------' end if call setup_stat(lin) !$OMP PARALLEL PRIVATE(allele_buffer) !$OMP DO ORDERED do i=1, nloci if (isactdip(loctyp(i)) .and. irupt == 0) then call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) call simtrend(typ, loc(i), locpos(i), locpos(trait), iter, mincnt, & norder, work, allele_buffer, locstat(i), plevel) pval=locstat(i) end if end do !$OMP END DO !$OMP END PARALLEL end if end if ! to Julian or ISO (epoch 19700101) else if (keyword == 'set' .and. keyw2 == 'epo') then if (narg > 2) then if (words(3)(1:3) == 'iso') then epoch=2440588.0D0 else if (words(3)(1:3) == 'jul') then epoch=0.0D0 else if (words(3)(1:3) == 'mjd') then epoch=2400000.0D0 else if (words(3)(1:3) == 'lil') then epoch=2299161.0D0 else if (words(3)(1:3) == 'j20') then epoch=2451545.0d0 else epoch=tojulian(fval(words(3))) end if end if call wrdate(epoch, words(1), 1) write(outstr,'(/a,i9,a,a10,a/)') 'NOTE: Julian date epoch ', int(epoch), & ' (', trim(words(1)), ').' else if (keyword == 'dat') then if (narg == 1) then i=isodate() tmp=tojulian(dble(i)) - epoch write(outstr,'(/a,i9,a,i9)') 'Date: ', i, ' = ', int(tmp) else if (isreal(words(2))) then if (words(3)(1:3) == 'gre') then tmp=togreg(fval(words(2))+epoch) else tmp=tojulian(fval(words(2)))-epoch end if write(outstr,'(/3a,i9)') 'Date: ', trim(words(2)), ' = ', int(tmp) else if (red) then call gettrait(words(2), LOC_QUA, LOC_CAT, nloci, loc, lochash, loctyp, trait, 0) if (trait /= MISS) then typ=1 if (words(3)(1:3) == 'gre') then typ=2 else if (words(3)(1:3) == 'yea') then typ=3 end if call dateconv(trait, work, trim(words(4)), typ, plevel) else write(outstr,'(a)') 'ERROR: Need to specify date (variable).' end if else write(outstr,'(a/a)') 'ERROR: Dataset not yet read in.', & 'NOTE: Date format is yyyymmdd.' end if else if (keyword == 'wri'.and. keyw2 == 'loc') then if (words(3)(1:3) == 'sib') then call get_filnam(lin, 4, outfil) call get_filnam(lin, 4, outfil) open(OSTR,file=outfil, iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if if (plevel > -2) then write(outstr,'(/2a)') 'Writing Sib-pair type script: ', trim(outfil) end if call sibloci(ostr, nloci, loc, loctyp, outpos, group, map, locnotes) if (narg > 4) then write(OSTR,'(2a/a)') 'read pedigree ', words(5), 'run' end if else if (words(3)(1:3) == 'mer') then call get_filnam(lin, 4, outfil) open(OSTR,file=outfil, iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if if (plevel > -2) then write(outstr,'(/2a)') 'Writing MERLIN locus file: ', trim(outfil) end if if (twintrait /= ' ') then write(OSTR,'(2a)') 'Z ', twintrait end if do i=1, nloci if (isactdip(loctyp(i))) then write(OSTR,'(2a)') 'M ', loc(i) else if (same_loctyp(loctyp(i), LOC_QUA) .or. & same_loctyp(loctyp(i), LOC_CAT)) then write(OSTR,'(2a)') 'T ', loc(i) else if (loctyp(i) == LOC_AFF) then write(OSTR,'(2a)') 'A ', loc(i) end if end do else if (words(3)(1:3) == 'lin' .or. words(3)(1:2) == 'gh' .or. & words(3)(1:3) == 'sup' .or. words(3)(1:3) == 'mli') then call get_filnam(lin, 4, outfil) typ=0 pos=5 if (words(pos)(1:3) == 'dum') then typ=1 pos=pos+1 end if if (words(3)(1:2) == 'gh') then typ=3-typ else if (words(pos)(1:2) == 'gh') then typ=2 pos=pos+1 if (words(pos)(1:2) == 'no') then typ=3 pos=pos+1 end if end if xlin=0 if (words(pos)(1:3) == 'xli') then xlin=1 pos=pos+1 end if if (liab /= MISS) then call gettrait(afftrait, LOC_ANY, 0, nloci, loc, lochash, loctyp, liab, 0) call gettrait(liabtrait, LOC_ANY, 0, nloci, loc, lochash, loctyp, liabclass, 0) end if call lorder(typ, addummy, liab, liabclass, & nloci, loctyp, nord, locord) open(OSTR,file=outfil, iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if if (plevel > -2) then write(outstr,'(/2a)') 'Writing LINKAGE type locus file: ', trim(outfil) end if ! temporarily drop the liability class variable if (liabclass /= MISS) then ltyp=loctyp(liabclass) loctyp(liabclass)=DEL_QUA end if call cntmark(nloci, loctyp, nmark, 5) if (typ == 1 .or. typ == 2) nmark=nmark+1 ! Program code 5=MLINK 8=SuperGH j=5 if (words(3)(1:3) == 'sup') j=8 write(OSTR,'(i5,4i3/a)') nmark, 0, xlin, j, 0, '0 0.0 0.0 0' write(OSTR,*) (i, i=1,nmark) if (typ == 1 .or. typ == 2) then write(outstr,'(a)') 'First locus is a dummy binary trait.' write(OSTR, '(i1,1x,i5,a/2(f8.6,1x)/i5/3(f8.6,1x))') & 1, 2, ' # Dummy #', 0.5, 0.5, 1, 0.5, 0.5, 0.5 if (xlin == 1) then write(OSTR,'(2(f8.6,1x))') 0.0, 0.0 end if end if do k=1, nord i=locord(k) if (isactdip(loctyp(i))) then call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) call wrfreq(OSTR, loc(i), group(i), map(i), & locnotes(i), allele_buffer, 8) else if (same_loctyp(loctyp(i), LOC_QUA)) then write(OSTR, '(i1,1x,i5,3a/2(f8.6,1x)/f8.6/3(f8.6,1x)/f8.6/f8.6)') & 0, 2, ' # ', trim(loc(i)), ' #', 0.1, 0.9, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0 else if (loctyp(i) == LOC_AFF) then write(OSTR,'(i1,1x,i5,3a/f8.6,1x,f8.6)') & 1, 2, ' # ', trim(loc(i)), ' #', smlfreq(2), smlfreq(1) n=1 if (i == liab) then n=nliabclass end if write(OSTR,'(i5)') n do j=1, n write(OSTR,'(3(f8.6,1x))') smlpen(3), smlpen(2), smlpen(1) if (xlin == 1) write(OSTR,'(2(f8.6,1x))') smlpen(3), smlpen(1) end do end if end do write(OSTR,'(a)') '0 0' if (words(3)(1:3) /= 'mli') then call wrmap(OSTR, typ, mapf) else write(OSTR,'(/a)') '0.0' end if if (liabclass /= MISS) then loctyp(liabclass)=ltyp end if if (words(3)(1:3) == 'sup') then write(OSTR,'(/a/a,i0)') '1', '-n 1 1 ', nmark-1 else dist=fval(words(pos)) if (dist <= 0.0d0) dist=0.1d0 hival=fval(words(pos+1)) if (hival <= 0.0d0) hival=0.5d0-dist write(OSTR,'(/a,2(1x,f6.4))') '1', dist, hival end if ! SAGE else if (words(3)(1:3) == 'sag') then call get_filnam(lin, 4, outfil) open(OSTR,file=outfil, iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if if (words(5)(1:3) == 'par') then if (plevel > -2) then write(outstr,'(/3a/a)') & 'Writing SAGE type parameter file: "', trim(outfil), '",', & ' suitable for a Sib-pair generated CSV file.' end if write(OSTR, '(a)') & '#', & '# Modern SAGE type parameter file', & '# Written by Sib-pair', & '# Pedigree Block:', & 'pedigree, character {', & ' delimiters = ","', & ' individual_missing_value = "NA"', & ' sex_code, male = "m", female = "f", missing = "NA"', & ' pedigree_id = ped', & ' individual_id = id', & ' parent_id = fa', & ' parent_id = mo', & ' sex_field = sex' do i=1, nloci if (same_loctyp(loctyp(i), LOC_AFF) .and. irupt == 0) then write(OSTR,'(3a)') ' trait = ', trim(loc(i)), & ', binary, missing="NA", affected="y", unaffected="n"' else if (same_loctyp(loctyp(i), LOC_QUA) .and. irupt == 0) then write(OSTR,'(3a)') ' trait = ', trim(loc(i)), ', missing="NA"' else if (same_loctyp(loctyp(i), LOC_CODOM) .and. irupt == 0) then write(OSTR,'(3a)') ' marker = ', trim(loc(i)), ', missing="NA"' else if (same_loctyp(loctyp(i), LOC_XLIN) .and. irupt == 0) then write(OSTR,'(3a)') ' marker, x_linked = ', trim(loc(i)), ', missing="NA"' else if (same_loctyp(loctyp(i), LOC_HAP)) then write(OSTR,'(3a)') ' marker, y_linked = ', trim(loc(i)), ', missing="NA"' end if end do write(OSTR,'(a)') '}', & '# Marker Block:', & 'marker {', & ' allele_delimiter="/"', & ' allele_missing="NA"', & '}' else if (plevel > -2) then write(outstr,'(/2a)') 'Writing SAGE type locus file: ', trim(outfil) end if do i=1, nloci if (isactdip(loctyp(i)) .and. irupt == 0) then call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) call wrfreq(OSTR, loc(i), group(i), map(i), & locnotes(i), allele_buffer, 5) end if end do end if ! MORGAN else if (words(3)(1:3) == 'mor') then call get_filnam(lin, 4, outfil) open(OSTR, file=outfil, iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if if (plevel > -2) then write(outstr,'(/2a)') 'Writing Morgan parameter file: ', trim(outfil) end if write(OSTR, '(3a/a)') & '# Morgan type parameter file for data from "', trim(pedfil), '"', & '# Written by Sib-pair' if (narg > 4) then write(OSTR, '(/3a/)') & 'input pedigree file "', trim(words(5)), '"' end if call wrmap(OSTR, 11, mapf) call wrmorg(OSTR, 2, nwid, ndec, nloci, loc, loctyp, locpos, & smlfreq, smlpen, work) else if (words(3)(1:3) == 'hap') then if (narg>3) then call get_filnam(lin, 4, outfil) else outfil='haploview.info' end if open(OSTR, file=outfil, status='unknown', iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if if (plevel > -2) then write(outstr,'(/2a)') 'Writing Haploview info file: ', outfil end if call wrmap(OSTR, 12, mapf) ! LOKI else if (words(3)(1:3) == 'lok') then call get_filnam(lin, 4, outfil) lin=words(5) if (narg == 4) lin=pedfil open(OSTR,file=outfil, iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if if (plevel > -2) then write(outstr,'(/2a)') 'Writing Loki prep type control file: ', trim(outfil) end if write(OSTR,'(3a/a/a/3a)', advance='no') & '/* Loki type control file for ', trim(lin), ' */', & '/* Written by Sib-pair */', 'MISSING "x"', & 'FILE [GS="/"] "', trim(lin), '", fam, id, father, mother, sx' trait=1 length=80 do i=1, nloci call addlet(loc(i), lin) j=len_trim(lin) if (same_loctyp(loctyp(i), LOC_CODOM)) then write(OSTR,'(5a)', advance='no') ', ', lin(1:j), '_A, ', lin(1:j), '_B' length=length+2*j+8 else if (istrait(loctyp(i))) then write(OSTR,'(2a)', advance='no') ', ', lin(1:j) length=length+j+2 if (trait == 1) trait=i end if if (length > 67) then write(OSTR,'(/a)', advance='no') ' ' length=6 end if end do write(OSTR,'(/a)') 'PEDIGREE fam, id, father, mother' write(OSTR,'(/a)') 'SEX sx "m","f"' do i=1, nloci if (same_loctyp(loctyp(i), LOC_CODOM)) then call addlet(loc(i), lin) j=len_trim(lin) write(OSTR,'(7a)') 'MARKER LOCUS ',lin(1:j), ' [', lin(1:j),'_A, ', lin(1:j),'_B]' end if end do write(OSTR,'(/a)',advance='no') 'LINK "chrom A"' length=15 do i=1, nloci if (same_loctyp(loctyp(i), LOC_CODOM)) then call addlet(loc(i), lin) write(OSTR,'(2a)',advance='no') ', ', trim(lin) length=length+j+3 if (length > 70) then write(OSTR,'(/a)',advance='no') ' ' length=6 end if end if end do write(OSTR,*) if (loctyp(trait) == LOC_AFF) then write(OSTR,'(2a/3a)') & 'DISCRETE ', loc(trait), & 'AFFECTED WHERE (', trim(loc(trait)), '="y")' end if write(OSTR, '(a/3a)') 'TRAIT LOCUS qtl', 'MODEL ', trim(loc(trait)), ' = qtl' ! PAP else if (words(3) == 'pap') then if (fixfreq /= MISS) then call gettrait(fixmarker, LOC_CODOM, 0, nloci, loc, lochash, loctyp, fixfreq, 0) end if open(OSTR, file='header.dat') open(OSTR2, file='popln.dat') if (plevel > -2) then write(outstr,'(/a)') 'Writing PAP locus files: header.dat and popln.dat' end if allocate(pairs(nloci,2)) gene=1 gen2=0 pairs(1,1)=1 pairs(1,2)=0 words(1)='Gender' do i=1, nloci if (isactdip(loctyp(i))) then gene=gene+1 gen2=gen2+1 pairs(gene,1)=3 if (same_loctyp(loctyp(i), LOC_XLIN)) pairs(gene,1)=4 pairs(gene,2)=gen2 words(gene)=loc(i) if (i /= fixfreq) then call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) else if (plevel > -1) then write(outstr,'(/a)') & 'NOTE: Population allele frequencies are prespecified as:' call wrfreq(outstr, fixmarker, group(fixfreq), map(fixfreq), & locnotes(fixfreq), fixfreq_buffer, 15) end if call copyfreq(fixfreq_buffer, allele_buffer) end if call wrfreq(OSTR2, loc(i), group(i), map(i), & locnotes(i), allele_buffer, 9) else if (same_loctyp(loctyp(i), LOC_QUA)) then gene=gene+1 pairs(gene,1)=2 pairs(gene,2)=0 words(gene)=loc(i) else if (loctyp(i) == LOC_AFF) then gene=gene+1 gen2=gen2+1 pairs(gene,1)=1 pairs(gene,2)=0 words(gene)=loc(i) write(OSTR2,'(2a/2i4,2f8.6)') ' 1 # ', loc(i), 0, 100, 0.05, 0.05 end if end do if (gene > 39) then write(outstr,'(a)') 'ERROR: PAP phen.dat may have no more than 39 columns' else if (gene > 0) then write(OSTR,'(2i4,9a8/(10a8):)') gene, gene, (words(i), i=1,gene) write(OSTR,'(8x,18i4/(20i4):)') (pairs(i,1), pairs(i,2), i=1,gene) end if write(OSTR2,*) close(OSTR2,status='keep') deallocate(pairs) else if (words(3)(1:3) == 'rel') then call get_filnam(lin, 4, outfil) open(OSTR,file=outfil, iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if if (plevel > -2) then write(outstr,'(/2a)') 'Writing RELPAIR type locus file: ', trim(outfil) end if do i=1, nloci if (isactdip(loctyp(i)) .and. irupt == 0) then typ=12 if (same_loctyp(loctyp(i), LOC_XLIN)) typ=13 call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) call wrfreq(OSTR, loc(i), group(i), map(i), & locnotes(i), allele_buffer, typ) end if end do ! MENDEL else if (words(3)(1:3) == 'men') then call get_filnam(lin, 4, outfil) ! order different if trait a factor or a locus typ=4 if (words(5)(1:3) == 'tra') typ=3 ! ltyp indicates if MENDEL 8.0 free format ltyp=0 if (words(5)(1:3) == 'fre' .or. words(6)(1:3) == 'fre' .or. & words(5)(1:3) == 'new' .or. words(6)(1:3) == 'new') then ltyp=9 end if open(OSTR, file=outfil, iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if if (plevel > -2) then write(outstr,'(/2a)') 'Writing MENDEL type locus file: ', trim(outfil) end if if (words(5)(1:3) == 'var') then do i=1, nloci if (same_loctyp(loctyp(i), LOC_QUA)) then write(OSTR,'(a8)') loc(i) end if end do else if (words(5) == 'snp') then typ=21 call wrmap(OSTR, typ, mapf) else call lorder(typ, addummy, liab, liabclass, & nloci, loctyp, nord, locord) if (fixfreq /= MISS) then call gettrait(fixmarker, LOC_CODOM, 0, nloci, loc, lochash, loctyp, fixfreq, 0) end if do k=1, nord i=locord(k) if (isactdip(loctyp(i)) .and. irupt == 0) then typ=7+ltyp if (same_loctyp(loctyp(i), LOC_XLIN)) typ=typ+3 if (i /= fixfreq) then call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) else call copyfreq(fixfreq_buffer, allele_buffer) end if if (ltyp == 0) then call shorten(i, nloci, loc, 8, cutnam) else call shorten(i, nloci, loc, 16, cutnam) end if call wrfreq(OSTR, cutnam, group(i), map(i), & locnotes(i), allele_buffer, typ) else if (same_loctyp(loctyp(i), LOC_QUA)) then if (ltyp /= 0) then write(ostr, '(a,1x,a8)') loc(i), 'VARIABLE' else write(ostr, '(2a8)') loc(i), 'VARIABLE' end if else if (same_loctyp(loctyp(i), LOC_CAT)) then if (ltyp /= 0) then write(ostr, '(a,1x,a8)') loc(i), 'FACTOR' else write(ostr, '(2a8)') loc(i), 'FACTOR' end if else if (loctyp(i) == LOC_AFF) then if (words(5)(1:3) == 'tra') then write(OSTR, '(2a8,2i2,i4,1x,f8.3,2(/a,f8.6),8(/a))') & loc(i), 'AUTOSOME', 2, 2, 1, max(0.0,0.01*map(i)), & ' 001', smlfreq(1), ' 002', smlfreq(2), & '1 3','001/001','001/002','002/002', & '2 3','001/001','001/002','002/002' else if (ltyp /= 0) then write(ostr, '(a8,1x,a8)', advance='no') loc(i), 'FACTOR' else write(ostr, '(2a8)', advance='no') loc(i), 'FACTOR' end if write(ostr, '(2i2,2(/a))') 2, 0, 'AFFECTED ','NORMAL ' end if end if end do end if ! STRUCTURE elseif (words(3)(1:3) == 'str') then if (narg == 4) then outfil='mainparams' else call get_filnam(lin, 5, outfil) end if if (plevel > -2) then write(outstr,'(/2a)') & 'Writing STRUCTURE mainparams file to: ', trim(outfil) end if open(OSTR,file=outfil, iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if call cntmark(nloci, loctyp, nmark, 1) write(OSTR,'(a//a/a/a)') & 'mainparam written by Sib-pair.', & 'KEY PARAMETERS FOR THE PROGRAM structure.', & 'YOU WILL NEED TO SET THESE IN ORDER TO RUN THE PROGRAM.', & 'VARIOUS OPTIONS CAN BE ADJUSTED IN THE FILE extraparams.' write(OSTR,'(a//3a/a/a,i5,a/a,i4,a)') 'Data File', & '#define INFILE ', words(4), '// (str) input data file', & '#define OUTFILE results // (str) results file', & '#define NUMINDS ', work%nobs ,' // (int) no. individuals', & '#define NUMLOCI ', nmark ,' // (int) no. loci' write(OSTR,'(a)') & '#define LABEL 1', '#define POPDATA 1', '#define POPFLAG 0', & '#define PHENOTYPE 1','#define EXTRACOLS 0', & '#define PHASEINFO 0','#define MARKOVPHASE 1', & '#define MISSING -9','#define PLOIDY 2', & '#define ONEROWPERIND 1', '#define MARKERNAMES 1', & '#define MAPDISTANCES 1' write(OSTR,'(/a/3(/a))') 'Program Parameters', & '#define MAXPOPS 2 // (int) assumed no. of pops', & '#define BURNIN 2000 // (int) length of burnin period', & '#define NUMREPS 2000 // (int) no. MCMC reps' write(OSTR,'(/a/8(/a))') 'Command line options:', & '-m mainparams', '-e extraparams', '-s stratparams', & '-K MAXPOPS', '-L NUMLOCI', '-N NUMINDS', & '-i input file','-o output file' else if (words(3)(1:3) == 'ecl' .or. words(3)(1:3) == 'bea') then typ=14 if (words(3)(1:3) == 'bea') typ=20 call get_filnam(lin, 4, outfil) if (plevel > -2) then if (typ == 14) then write(*,'(/2a)') 'Writing Eclipse type locus file: ', trim(outfil) else write(*,'(/2a)') 'Writing Beagle type marker file: ', trim(outfil) end if end if open(OSTR,file=outfil, iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if do i=1, nloci if (same_loctyp(loctyp(i), LOC_CODOM)) then call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) call wrfreq(OSTR, loc(i), group(i), map(i), & locnotes(i), allele_buffer, typ) end if end do else if (words(3)(1:3) == 'dis' .or. words(3)(1:3) == 'DIS') then if (narg == 4) words(5) = '1' call get_filnam(lin, 4, outfil) if (plevel > -2) then write(*,'(/2a)') & 'Writing DISTmix type input file: ', trim(outfil) end if open(OSTR,file=outfil, iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if call todistmix(OSTR, trim(words(5)), work, allele_buffer) ! Plink else if (words(3)(1:3) == 'pli' .or. words(3)(1:3) == 'bim') then lin='write map plink ' // trim(words(4)) commands=trim(lin) // '; ' // trim(commands) ilevold=ilevel ilevel=0 ! VCF else if (words(3)(1:3) == 'vcf') then trait=MISS outfil='sib-pair.vcf' if (narg > 3) call get_filnam(lin, 4, outfil) if (narg > 4) then call gettrait(words(4), LOC_TRA, 0, nloci, loc, lochash, loctyp, trait, 1) end if if (trait /= MISS) trait=locpos(trait) call lorder(1, addummy, liab, liabclass, nloci, loctyp, nord, locord) call wrvcf(OSTR, 3, trait, outfil, allele_buffer, work, plevel) ! FImpute else if (words(3)(1:3) == 'fim' .and. narg > 3) then call get_filnam(lin, 4, outfil) trait=MISS i=5 if (narg == 6 .and. words(5)(1:3) == 'chi') i=i+1 call gettrait(words(i), LOC_TRA, 0, nloci, loc, lochash, loctyp, trait, 1) if (trait /= MISS) then if (plevel > -2) then write(*,'(/2a)') & 'Writing FImpute type locus file: ', trim(outfil) end if open(OSTR,file=outfil, iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if call fimpmap(OSTR, trait, work) else write(outstr,'(a)') 'ERROR: Need to specify a chip identifier variable.' end if else write(outstr,'(a)') 'ERROR: Locus file type not supported.' end if close(OSTR,status='keep') ! Write map file else if (keyword == 'wri' .and. keyw2 == 'map' .and. narg > 2) then if (words(3)(1:3) == 'men') then call get_filnam(lin, 4, outfil) if (outfil == ' ') outfil='mendel.map' open(OSTR, file=outfil, status='unknown', iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if if (plevel > -2) then write(outstr,'(/2a)') 'Writing MENDEL type map file: ', trim(outfil) end if typ=4 if (words(5)(1:3) == 'fre' .or. words(5)(1:3) == 'new') typ=14 if (words(5) == 'snp') typ=21 call wrmap(OSTR, typ, mapf) close(ostr, status='keep') else if (words(3)(1:3) == 'mer') then call get_filnam(lin, 4, outfil) if (outfil == ' ') outfil='merlin.map' open(OSTR, file=outfil, status='unknown', iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if if (plevel > -2) then write(outstr,'(/2a)') 'Writing MERLIN type map file: ', trim(outfil) end if call wrmap(OSTR, 6, mapf) close(OSTR,status='keep') else if (words(3)(1:3) == 'lok') then call get_filnam(lin, 4, outfil) if (outfil == ' ') outfil='loki.map' open(OSTR, file=outfil, status='unknown', iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if if (plevel > -2) then write(outstr,'(/2a)') 'Writing LOKI type parameter file: ',outfil end if call wrmap(OSTR, 7, mapf) close(OSTR, status='keep') else if (words(3)(1:3) == 'sol') then call get_filnam(lin, 4, outfil) if (outfil == ' ') outfil='solar.map' open(OSTR, file=outfil, status='unknown', iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if if (plevel > -2) then write(outstr,'(/2a)') 'Writing SOLAR type map file: ', trim(outfil) end if call wrmap(OSTR, 9, mapf) close(OSTR, status='keep') else if (words(3)(1:3) == 'pli') then call get_filnam(lin, 4, outfil) if (outfil == ' ') outfil='plink.map' open(OSTR, file=outfil, status='unknown', iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if if (plevel > -2) then write(outstr,'(/2a)') 'Writing PLINK type map file: ', trim(outfil) end if call wrmap(OSTR, 13, mapf) close(OSTR, status='keep') ! findhap or BLUPF90 else if (words(3)(1:3) == 'fin' .or. words(3)(1:3) == 'blu') then call get_filnam(lin, 4, outfil) if (outfil == ' ') outfil='chromosome.data' open(OSTR, file=outfil, status='unknown', iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if if (words(3)(1:3) == 'fin') then if (plevel > -2) then write(outstr,'(/2a)') 'Writing findhap type map file: ', trim(outfil) end if call wrmap(OSTR, 22, mapf) else if (plevel > -2) then write(outstr,'(/2a)') 'Writing BLUPF90 type map file: ', trim(outfil) end if call wrmap(OSTR, 23, mapf) end if close(OSTR, status='keep') else write(outstr,'(a)') 'ERROR: Map file type not supported.' end if ! List of quantitative traits for Mendel else if (keyword == 'wri' .and. keyw2 == 'var' .and. narg > 2) then if (words(3)(1:3) == 'men') then call get_filnam(lin, 4, outfil) if (outfil == ' ') outfil='mendel.var' else call get_filnam(lin, 3, outfil) end if open(OSTR, file=outfil, status='unknown', iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if if (plevel > -2) then write(outstr,'(/2a)') 'Writing MENDEL type var file: ', outfil end if call wrmap(OSTR, 20, mapf) close(OSTR,status='keep') ! Write GCTA binary format GRM matrix or big matrix else if (keyword == 'wri' .and. (keyw2 == 'kin' .or. keyw2 == 'grm')) then if (.not.red) then write(outstr,'(3a)') 'ERROR: Need pedigree data to be present.' else if (narg > 2) then typ=1 if (words(narg)(1:3) == 'pai') typ=2 call get_filnam(lin, 3, outfil) trait=MISS call gettrait(words(4), LOC_TRA, 0, nloci, loc, lochash, loctyp, trait, 1) if (plevel > -2) then if (keyw2 == 'grm') then write(outstr,'(/2a)') 'Writing GRM files with prefix: ', trim(outfil) else write(outstr,'(/2a)') 'Writing kinship matrix to ', trim(outfil) end if if (trait /= MISS) then write(outstr,'(3a)') 'Filtering on trait "', trim(loc(trait)), '".' end if end if if (trait /= MISS) trait=locpos(trait) if (keyw2 == 'grm') then call writegrm(outfil, trait, work, plevel) else call writekin(typ, outfil, trait, work, plevel) end if else write(outstr,'(3a)') 'ERROR: Need to specify file name prefix.' end if ! Write pedigree file else if (keyword == 'wri' .and. red) then if (narg == 1) then if (plevel > -2) then write(outstr,'(a,i0,a)') '# Writing ', work%nact,' pedigrees:' end if call pedout(outstr, 1, pedmask, tabsep, allsep, imp, nwid, ndec, & ncatwid, sexcode, misval, 0, 0, 1, show_cat, & nloci, loc, loctyp, locpos, locnotes, work) else if ((narg == 3 .or. narg == 4) .and. keyw2 == 'bin') then call get_filnam(lin, 3, outfil) typ=1 if (words(4)(1:3) == 'com') typ=typ+1 call writebin(OSTR, typ, outfil, work, plevel) else if ((narg == 2 .and. keyw2 /= 'pap' .and. & keyw2 /= 'fin' .and. keyw2 /= 'pfi' .and. keyw2 /= 'sna') .or. & keyw2 == 'sib' .or. keyw2 == 'ped' .or. keyw2 == 'gas') then if (narg == 2) then call get_filnam(lin, 2, outfil) else call get_filnam(lin, 3, outfil) end if header=1 if (words(4)(1:3) == 'hea') header=2 if (plevel > -2) then if (keyw2 == 'sib') then write(outstr,'(/2a)') & 'Writing Sib-pair script with inline data: ',outfil else write(outstr,'(/2a)') & 'Writing GAS type pedigree file: ',outfil end if end if open(OSTR, file=outfil, status='unknown', iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if if (keyw2 == 'sib') then call sibloci(OSTR, nloci, loc, loctyp, outpos, group, map, locnotes) if (words(4)(1:3) == 'mer') then header=2 write(OSTR,'(a)') 'merge inline' else write(OSTR,'(a)') 'read pedigree inline' end if end if call pedout(OSTR, header, pedmask, tabsep, allsep, imp, nwid, ndec, & ncatwid, sexcode, misval, 0, 0, 1, show_cat, & nloci, loc, loctyp, locpos, locnotes, work) if (keyw2 == 'sib') then write(OSTR,'(a)') ';;;;' if (words(4)(1:3) /= 'mer') then write(OSTR,'(a)') 'run' end if end if close(OSTR, status='keep') else if (keyw2=='men' .or. keyw2 == 'fis') then call get_filnam(lin, 3, outfil) ltyp=4 if (words(4)(1:3) == 'tra' .or. words(5)(1:3) == 'tra') ltyp=3 call lorder(ltyp, addummy, liab, liabclass, & nloci, loctyp, nord, locord) if (keyw2=='men') then typ=2 if (words(4)(1:3) == 'new' .or. words(5)(1:3) == 'new' .or. & words(4)(1:3) == 'csv' .or. words(5)(1:3) == 'csv') then typ=10 else if (words(4)(1:3) == 'tra' .or. words(5)(1:3) == 'tra') then typ=3 end if if (plevel > -2) then write(outstr,'(/2a)') 'Writing MENDEL type pedigree file: ', trim(outfil) end if else typ=1 if (plevel > -2) then write(outstr,'(/2a)') 'Writing FISHER type pedigree file: ', trim(outfil) end if end if open(OSTR, file=outfil, status='unknown', iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if if (twintrait /= ' ') then call gettrait(twintrait, LOC_ANY, 0, nloci, loc, lochash, loctyp, twinning, 0) if (twinning /= MISS) twinning=locpos(twinning) end if if (typ == 10) then call wrcsv(OSTR, typ, pedmask, imp, nwid, ndec, fieldsep, allsep, cmisval, & gmisval, twinning, twintype, nloci, loc, loctyp, locpos, & locnotes, nord, locord, work) else call wrfish(OSTR, ndec, twinning, twintype, & nloci, loctyp, locpos, nord, locord, work, typ, plevel) end if close(OSTR, status='keep') else if (keyw2 == 'cri') then call get_filnam(lin, 3, outfil) open(OSTR, file=outfil, status='unknown', iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if if (plevel > -2) then write(outstr,'(/2a)') 'Writing CRI-MAP .gen file: ', trim(outfil) end if call wrcri(OSTR, nloci, loc, loctyp, locpos, locord, work) close(OSTR, status='keep') else if (keyw2 == 'dot') then call get_filnam(lin, 3, outfil) call gettrait(words(4), LOC_AFF, 0, nloci, loc, lochash, loctyp, trait, 0) call gettrait(words(5), LOC_ANY, 0, nloci, loc, lochash, loctyp, gene, 0) if (trait /= MISS) trait=locpos(trait) if (gene /= MISS) then ltyp=loctyp(gene) gene=locpos(gene) end if open(OSTR, file=outfil, status='unknown', iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if if (plevel > -2) then write(outstr,'(/2a)') 'Writing pedigree drawing for dot: ', trim(outfil) if (trait /= MISS) then write(outstr,'(8x,2a)') 'Filled symbols represent: ', words(4) if (words(6) /= ' ') then write(outstr,'(24x,2a)') 'Affected: ', trim(words(6)) end if if (words(7) /= ' ') then write(outstr,'(22x,2a)') 'Unaffected: ', trim(words(7)) end if if (words(8) /= ' ') then write(outstr,'(25x,2a)') 'Missing: ', trim(words(8)) end if end if if (gene /= MISS) then write(outstr,'(8x,2a)') 'Values within symbols: ', words(5) end if end if call wrdot(OSTR, trait, gene, ltyp, nwid, ndec, allsep, & dotfixedsep, dotcrossings, dotnodesep, & dotranksep, dotboxsize, & trim(words(6)), trim(words(7)), & trim(words(8)), trim(words(9)), work) close(OSTR, status='keep') else if (keyw2 == 'pre' .or. keyw2 == 'lin' .or. keyw2 == 'mer' .or. & keyw2 == 'asp' .or. keyw2 == 'hap' .or. keyw2 == 'fba' .or. & keyw2 == 'tcl' .or. words(2)(1:2) == 'gh' .or. keyw2 == 'ppd') then call get_filnam(lin, 3, outfil) open(OSTR, file=outfil, status='unknown', iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if ! ! style typ ! --------- --- ! lin, pre 1 ! ppd 2 ! gh 3 ! asp, tcl 4 ! hap 5 ! fba 6 ! merlin 7 ! addummy=0 renumall=0 typ=1 ltyp=1 if (.not.(narg > 3 .and. words(narg)(1:3) == 'num')) renumall=1 if (words(4)(1:3) == 'dum') then addummy=1 end if if (words(2)(1:2) == 'gh') then ltyp=3 typ=3 else if (words(4)(1:2) == 'gh') then ltyp=3 typ=3 addummy=1 if (words(5)(1:2) == 'no') addummy=0 else if (keyw2 == 'ppd') then ltyp=2 typ=2 else if (keyw2 == 'asp' .or. keyw2 == 'tcl') then ltyp=2 typ=4 else if (keyw2 == 'hap') then ltyp=3 typ=5 renumall=2 else if (keyw2 == 'fba') then ltyp=6 typ=6 else if (keyw2 == 'mer') then ltyp=1 typ=7 end if if (liab /= MISS) then call gettrait(afftrait, LOC_ANY, 0, nloci, loc, lochash, loctyp, liab, 0) call gettrait(liabtrait, LOC_ANY, 0, nloci, loc, lochash, loctyp, liabclass, 0) end if call lorder(ltyp, addummy, liab, liabclass, nloci, loctyp, nord, locord) if (twintrait /= ' ') then call gettrait(twintrait, LOC_ANY, 0, nloci, loc, lochash, loctyp, twinning, 0) if (twinning /= MISS) twinning=locpos(twinning) end if if (plevel > -2) then if (typ==1) then write(outstr,'(/2a)') 'Writing pre-Makeped Linkage style pedigree file: ', trim(outfil) else if (typ==2) then write(outstr,'(/2a)') 'Writing post-Makeped Linkage style pedigree file: ', trim(outfil) else if (typ==3) then write(outstr,'(/2a)') 'Writing Genehunter style pedigree file: ', trim(outfil) else if (typ==5) then write(outstr,'(/2a)') 'Writing Haploview style pedigree file: ', trim(outfil) else if (typ==7) then write(outstr,'(/2a)') 'Writing MERLIN style pedigree file: ', trim(outfil) if (twinning /= MISS) then write(outstr,'(3a)') 'using "', trim(twintrait), '" as zygosity indicator.' end if else if (typ==4) then write(outstr,'(/2a)') 'Writing ASPEX type pedigree file: ', trim(outfil) else if (typ==6) then write(outstr,'(/2a)') 'Writing FBAT type pedigree file: ', trim(outfil) end if end if if (addummy == 1) then write(outstr,'(a)') 'Position 6 is a dummy binary trait.' end if end if if (typ == 4 .or. typ == 6) then do j=1, nord i=locord(j) if (isactdip(loctyp(i))) then write(OSTR,'(2a)', advance='no') trim(loc(i)), ' ' end if end do write(OSTR,*) end if call wrlink(OSTR, typ, imp, addummy, liabclass, & renumall, twinning, twintype, nwid, ndec, & nloci, loctyp, locpos, nord, locord, work) close(OSTR, status='keep') else if (keyw2 == 'phe') then ! ped id data call get_filnam(lin, 3, outfil) open(OSTR, file=outfil, status='unknown', iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if if (plevel > -2) then write(outstr,'(/2a)') 'Writing phenotype data file: ', trim(outfil) end if typ=1 if (words(4)(1:3) == 'roa') typ=typ+1 call wrphe(OSTR, typ, nwid, ndec, nloci, loc, loctyp, locpos, work) close(OSTR, status='keep') ! ! CSV type data files ! 1=ped,id,fa,mo,sex,data (na='NA') ! 2=famid,id,fa,mo,sex,mztwin,hhid (na=' ') ! 3=famid,id, phenotype_data ! 4=id, phenotype_data ! 5=famid,id, genotype_data ! 6=id, genotype_data ! 10=ped,id,fa,mo,sex,mztwin,data (na=' ') ! 11=ped,id,fa,mo,sex,mztwin,data (na='.') ! else if (keyw2 == 'sas' .or. keyw2 == 'csv') then if (keyw2 == 'sas') then typ=11 fieldsep='|' cmisval='.' gmisval='.' else typ=1 fieldsep=',' cmisval=' ' gmisval=' ' end if if (narg > 3) fieldsep=words(4)(1:1) if (narg > 4) cmisval=words(5)(1:3) if (narg > 5) gmisval=words(6)(1:3) call get_filnam(lin, 3, outfil) open(OSTR, file=outfil, status='unknown', iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if if (plevel > -2) then write(outstr,'(/4a)') 'Writing ', keyw2 ,' data file: ', trim(outfil) end if call lorder(1, addummy, liab, liabclass, nloci, loctyp, nord, locord) if (twintrait /= ' ') then call gettrait(twintrait, LOC_ANY, 0, nloci, loc, lochash, loctyp, twinning, 0) if (twinning > 0) twinning=locpos(twinning) end if if (plevel > 0 .and. narg > 3) then write(outstr,'(3a,3(/3a))') ' Field separator = "', fieldsep, '"', & ' Missing value = "', cmisval, '"', & ' Missing genotype = "', gmisval, '"', & ' Allele separator = "', allsep, '"' end if call wrcsv(OSTR, typ, pedmask, imp, nwid, ndec, fieldsep, allsep, cmisval, & gmisval, twinning, twintype, nloci, loc, loctyp, locpos, & locnotes, nord, locord, work) close(OSTR, status='keep') else if (keyw2 == 'sol') then typ=2 fieldsep=',' if (words(4)(1:3) == 'phe') then typ=3 if (words(5)(1:3) == 'nop') typ=4 else if (words(4)(1:3) == 'gen') then typ=5 if (words(5)(1:3) == 'nop') typ=6 end if call get_filnam(lin, 3, outfil) open(OSTR, file=outfil, status='unknown', iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if if (plevel > -2) then if (typ == 3 .or. typ == 4) then write(outstr,'(/2a)') 'Writing SOLAR phenotype file: ', trim(outfil) else if (typ == 5 .or. typ == 6) then write(outstr,'(/2a)') 'Writing SOLAR marker file: ', trim(outfil) else write(outstr,'(/2a)') 'Writing SOLAR pedigree file: ', trim(outfil) end if end if call lorder(1, addummy, liab, liabclass, nloci, loctyp, nord, locord) if (twintrait /= ' ') then call gettrait(twintrait, LOC_ANY, 0, nloci, loc, lochash, loctyp, twinning, 0) if (twinning /= MISS) twinning=locpos(twinning) end if call wrcsv(OSTR, typ, pedmask, imp, nwid, ndec, fieldsep, allsep, cmisval, & gmisval, twinning, twintype, nloci, loc, loctyp, locpos, & locnotes, nord, locord, work) close(OSTR, status='keep') else if (keyw2 == 'mor') then call get_filnam(lin, 3, outfil) open(OSTR, file=outfil, status='unknown', iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if if (plevel > -2) then write(outstr,'(/2a)') 'Writing Morgan pedigree file: ', trim(outfil) end if call wrmorg(OSTR, 1, nwid, ndec, nloci, loc, loctyp, locpos, & smlfreq, smlpen, work) close(OSTR, status='keep') ! ! SNP genotypes as single dose or probability, usually "snp major" or "row major" ! else if (keyw2 == 'snp' .or. keyw2 == 'roa' .or. keyw2 == 'row' .or. & keyw2 == 'fim' .or. keyw2 == 'blu' .or. keyw2 == 'fin' .or. & keyw2 == 'gs3' .or. keyw2 == 'sup' .or. & keyw2 == 'sna' .or. keyw2 == 'pro' .or. keyw2 == 'dos') then typ=1 censor=MISS trait=MISS if (narg > 2) then call get_filnam(lin, 3, outfil) else if (keyw2 == 'sna') then outfil='QTLAllelsR.dat' else if (keyw2 == 'fin') then outfil='genotypes.txt' else outfil='snpmajor.dat' end if open(OSTR, file=outfil, status='unknown', iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if i=4 do while (i <= narg) if ((words(i) == 'key' .or. words(i) == 'chip') .and. i < narg) then call gettrait(words(i+1), LOC_QUA, LOC_CAT, nloci, loc, lochash, & loctyp, censor, 0) i=i+1 else if (words(i)(1:3) == 'noh') then typ=2 else call gettrait(words(i), LOC_TRA, 0, nloci, loc, lochash, & loctyp, trait, 0) end if i=i+1 end do if (plevel > -2) then if (keyw2 == 'snp') then write(outstr,'(/2a)') & 'Writing SNP-major .tped genotype file: ', trim(outfil) if (typ == 1) then write(outstr,'(a)') 'First line is header "Chr SNP bp cm id1...".' end if else if (keyw2 == 'pro') then write(outstr,'(/2a)') & 'Writing SNP-major genotypic probability file: ', trim(outfil) else if (keyw2 == 'dos') then write(outstr,'(/2a)') & 'Writing ID-major genotypic probability file: ', trim(outfil) else if (keyw2 == 'fim') then write(outstr,'(/2a)') & 'Writing FImpute genotype file: ', trim(outfil) else if (keyw2 == 'blu') then write(outstr,'(/2a)') & 'Writing blupf90 genotype file: ', trim(outfil) else if (keyw2 == 'fin') then write(outstr,'(/2a)') & 'Writing findhap genotype file: ', trim(outfil) else if (keyw2 == 'sna') then write(outstr,'(/2a)') & 'Writing WOMBAT SNP-major allelic dosage file: ', trim(outfil) else if (keyw2 == 'snp') then write(outstr,'(/2a)') & 'Writing SuperlinkSNP SNP-major genotype file: ', trim(outfil) else write(outstr,'(/2a)') & 'Writing SNP-major allelic dosage file: ', trim(outfil) end if if (trait /= MISS) then call countp(locpos(trait), work, ntyped) write(outstr,'(a,i0,3a)') & 'Data for ', ntyped, ' individuals phenotyped at "', & trim(loc(trait)), '".' end if if (censor /= MISS) then write(outstr,'(3a)') & 'First record is value at trait "', trim(loc(censor)), '".' end if end if if (trait /= MISS) then trait=locpos(trait) end if if (censor /= MISS) then censor=locpos(censor) end if if (keyw2 == 'snp') then call wrsnp2(typ, OSTR, trait, misval, work) else if (keyw2 == 'dos') then call wrsnp_col(typ, OSTR, trait, censor, tabsep, tabsep, misval, work) else if (keyw2 == 'fim') then call wrsnp_col(1, OSTR, trait, censor, ' ', '', '5', work) else if (keyw2 == 'blu') then call wrsnp_col(3, OSTR, trait, censor, ' ', '', '5', work) else if (keyw2 == 'fin') then call wrsnp_col(4, OSTR, trait, censor, ' ', '', '5', work) else if (keyw2 == 'gs3') then call wrsnp_col(5, OSTR, trait, censor, ' ', '', '5', work) else if (keyw2 == 'roa') then call wrsnp_row(3, OSTR, trait, tabsep, misval, work) else if (keyw2 == 'pro') then call wrsnp3(OSTR, trait, work) else if (keyw2 == 'sna') then call addtmpvar('DOSE', work, gene, ifail) call wrsnp4(OSTR, trait, locpos(gene), censor, work) else if (keyw2 == 'sup') then call wrsnp5(OSTR, trait, work) else call wrsnp_row(typ, OSTR, trait, tabsep, misval, work) end if close(OSTR, status='keep') else if (keyw2 == 'arl') then call get_filnam(lin, 3, outfil) open(OSTR, file=outfil, status='unknown', iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if call gettrait(words(4), LOC_QUA, LOC_AFF, nloci, loc, lochash, loctyp, trait, 0) if (trait /= MISS) then trait=locpos(trait) end if typ=0 if (plevel > -2) then write(outstr,'(/2a)') 'Writing Arlequin file: ', trim(outfil) end if call wrarl(OSTR, trait, typ, nloci, loc, loctyp, locpos, work) else if (keyw2 == 'str') then call get_filnam(lin, 3, outfil) call gettrait(words(4), LOC_AFF, 0, nloci, loc, lochash, loctyp, trait, 0) if (trait /= MISS) then trait=locpos(trait) end if typ=1 if (words(narg) == 'fou') typ=2 if (plevel > -2) then write(outstr,'(/2a)') 'Writing Structure data file: ',outfil end if open(OSTR, file=outfil, status='unknown', iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if call wrmap(OSTR, 8, mapf) call wrprd(OSTR, typ, trait, nloci, loc, loctyp, locpos, work) close(OSTR, status='keep') elseif (words(2)(1:3) == 'bea') then call get_filnam(lin, 3, outfil) typ=1 if (words(narg)(1:3) == 'fou') typ=2 if (words(narg)(1:3) == 'tri') typ=3 if (plevel > -2) then if (typ == 3) then write(outstr,'(/2a)') 'Writing Beagle trios file: ', outfil else write(outstr,'(/2a)') 'Writing Beagle data file: ', outfil end if end if open(OSTR, file=outfil, status='unknown', iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if call wrbeagle(OSTR, typ, work) close(OSTR, status='keep') elseif (words(2)(1:3) == 'pli' .or. words(2) == 'bed') then outfil='sp-plink' if (narg > 2) then call get_filnam(lin, 3, outfil) end if call extprefix(outfil, '.bed') call gettrait(words(4), LOC_TRA, 0, nloci, loc, lochash, loctyp, trait, 1) call gettrait(words(5), LOC_ANY, 0, nloci, loc, lochash, loctyp, censor, 1) if (plevel > -2) then write(outstr,'(/2a,2(1x,a))') & 'Writing PLINK files: ', trim(outfil) // '.bed', & trim(outfil) // '.bim', trim(outfil) // '.fam' if (trait /= MISS) then write(outstr,'(3a)') ' Trait is: "', trim(loc(trait)), '".' end if if (censor /= MISS) then write(outstr,'(3a)') 'Filtering on trait "', trim(loc(censor)), '".' end if end if if (trait /= MISS) trait=locpos(trait) if (censor /= MISS) censor=locpos(censor) call wrbed(OSTR, outfil, trait, censor, allele_buffer, work) else if (words(2) == 'vcf') then typ=1 trait=MISS if (narg > 2) then call get_filnam(lin, 3, outfil) i=4 do while (i <= narg) if (words(i)(1:3) == 'ped') then typ=2 else call gettrait(words(i), LOC_TRA, 0, nloci, loc, lochash, loctyp, trait, 1) end if i=i+1 end do else outfil=trim(pedfil) // '.vcf' end if if (plevel > -2) then if (typ == 1) then write(outstr,'(/2a)') 'Writing VCF file: ', trim(outfil) else write(outstr,'(/2a)') & 'Writing VCF file with ID string of form "ped_id":', trim(outfil) end if if (trait /= MISS) then write(outstr,'(3a)') 'Filtering on trait "', trim(loc(trait)), '".' end if end if if (trait /= MISS) trait=locpos(trait) call lorder(1, addummy, liab, liabclass, nloci, loctyp, nord, locord) call wrvcf(OSTR, typ, trait, outfil, allele_buffer, work, plevel) else if (words(2) == 'pap') then open(OSTR,file='trip.dat') open(OSTR2,file='phen.dat') if (plevel > -2) then write(outstr,'(/a)') 'Writing PAP type pedigree files: phen.dat and trip.dat' end if call wrpap(OSTR, OSTR2, nloci, loc, loctyp, locpos, work) close(OSTR, status='keep') close(OSTR2,status='keep') else if (words(2)(1:3) == 'pfi') then outfil='pedigree.file' if (plevel > -2) then write(outstr,'(/2a)') 'Writing findhap pedigree file: ', outfil end if open(OSTR, file=outfil, status='unknown', iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if call wrped(OSTR, 1, MISS, MISS, '0', work) else write(outstr,'(a)') 'ERROR: Pedigree file type not supported.' end if else if (keyword == 'hea' .or. keyword=='tai') then nrc=10 if (keyw2 == 'map' .or. keyw2 == 'loc') then if (narg > 2) then if (isint(words(narg))) then nrc=max(1, ival(words(narg))) narg=narg-1 end if end if if (narg == 2) then narg=narg+1 words(narg)='$A' if (keyw2 == 'map') words(narg)='$M' end if call loadnam(3, narg, words, nloci, loc, lochash, loctyp, group, map, & locstat, wloc, nord, locord, LOC_ANY, 3) if (keyword == 'tai') then j=max(1,nord-nrc+1) do i=1, min(nord, nrc) locord(i)=locord(j) j=j+1 end do end if nord=min(nord, nrc) if (keyw2 == 'map') then call wrmap(0, 10, mapf) else call listloci(nord, locord, nloci, loc, loctyp, outpos, locnotes, & 1, prompt, plevel) end if else if (keyw2 == 'kin') then nrc=5 if (narg > 2) then if (isint(words(narg))) then nrc=max(1, ival(words(narg))) end if end if call showkin(nrc, work, 0) else if (red) then if (narg > 1 .and. .not.isint(words(2))) then if (keyword == 'hea') then if (words(2) == 'id' .or. words(2) == 'ids') then lin='eval (apply individual-name (seq 1 (min (nobs) 10)))' else if (words(2) == 'ped') then lin='eval (apply pedigrees (seq 1 (min (npeds) 10)))' else lin='eval (map (lambda (x) (data "' // trim(words(2)) // & '" x)) (seq 1 (min (nobs) 10)))' end if else if (words(2) == 'id' .or. words(2) == 'ids') then lin='eval (apply individual-names (seq (max 1 (- (nobs) 10)) (nobs)))' else if (words(2) == 'ped') then lin='eval (apply pedigrees (seq (max 1 (- (npeds) 10)) (npeds)))' else lin='eval (map (lambda (x) (data "' // trim(words(2)) // & '" x)) (seq (max 1 (- (nobs) 10)) (nobs)))' end if end if commands=trim(lin) // '; ' // trim(commands) ilevold=ilevel ilevel=0 else skipline=0 if (narg == 2) then nrc=max(1, ival(words(2))) else if (narg == 3) then skipline=max(0, ival(words(2))) nrc=max(1, ival(words(3))) end if if (keyword=='tai') nrc=-nrc call cntmark(nloci, loctyp, nmark, 1) if (nmark < 1000) then call pedout(6, 1, pedmask, tabsep, allsep, imp, nwid, ndec, & ncatwid, sexcode, misval, nrc, skipline, 1, show_cat, & nloci, loc, loctyp, locpos, locnotes, work) else write(outstr,'(a)') 'ERROR: Too many columns of data to view.' end if end if else write(outstr,'(a)') 'ERROR: No pedigree data in memory to view.' end if else if (keyword == 'mor') then if (red) then keyword=' ' skipline=0 nrc=20 if (narg == 2) then nrc=max(1, ival(words(2))) end if do while (keyword(1:1) /= 'q' .and. skipline < work%nobs) call pedout(6, 1, pedmask, tabsep, allsep, imp, nwid, ndec, & ncatwid, sexcode, misval, nrc, skipline, 1, show_cat, & nloci, loc, loctyp, locpos, locnotes, work) write(words(1),'(i20)') skipline+1 write(words(2),'(i20)') min(skipline+nrc, work%nobs) lin='records ' // trim(adjustl(words(1))) // '-' // & trim(adjustl(words(2))) // ':' write(*,'(a)', advance='no') trim(lin) read(*,'(a)') keyword if (keyword(1:1) == 'h' .or. keyword(1:1) == '?' ) then write(*,'(a)', advance='no') '[bdnpqu]:' read(*,'(a)') keyword end if if (keyword(1:1) == 'b' .or. keyword(1:1) == 'p') then skipline=max(0, skipline-nrc) else if (keyword(1:1) == 'u') then skipline=max(0, skipline-nrc/2) else if (keyword(1:1) == 'd') then skipline=skipline+nrc/2 else skipline=skipline+nrc end if end do end if ! Program setting and data summary else if (keyword == 'inf') then call info(lin, burnin, imp, iter, & mapf, mincnt, plevel, genemod, & showorig, chek, droperr, prompt, use2, gui, & twintrait, sexmarker, datdir, wrkdir) call actped(1, red, pedfil, nloci, loc, loctyp, locpos, & outpos, locnotes, wloc, locstat, work, -1) ! Fine grained summaries else if (keyword == 'sho') then if (keyw2 == 'map') then if (words(3) == 'pos' .or. words(3) == 'position') then call loadpos(4, narg, words, nloci, loc, lochash, loctyp, & group, map, locstat, wloc, nord, locord, 1) else if (words(3) == 'whe' .or. words(3) == 'where') then if (words(4) == 'chr' .or. words(4) == 'chrom' .or. & words(4) == 'chromosome') then call search_chrom(5, narg, words, nloci, group, wloc, nord, locord) else call search_annot(4, narg, words, nloci, locnotes, wloc, nord, locord) end if else call loadnam(3, narg, words, nloci, loc, lochash, loctyp, group, map, & locstat, wloc, nord, locord, LOC_ANY, 3) end if call wrmap(0, 10, mapf) else if (keyw2 == 'chr') then call listchroms(nloci, loc, loctyp, map, group) else if (keyw2 == 'sex') then call sextable(work) else if (keyw2 == 'ped') then trait=MISS if (narg == 2) then call dogen(work, trait, 1, plevel) else call listpeds(1, work, narg, words) end if else if (keyw2(1:2) == 'id') then typ=1 trait=MISS if (narg == 2) then call listids(work, typ, trait, plevel) else if (words(3)(1:3) == 'dup') then typ=2 if (narg > 3) then call gettrait(words(4), LOC_QUA, LOC_CAT, & nloci, loc, lochash, loctyp, trait, 0) if (trait /= MISS) trait=locpos(trait) end if call listids(work, typ, trait, plevel) else call searchid(words(3:narg), work) end if else if (keyw2(1:2) == 'mz') then thresh=0.0d0 gt=16 if (twintype==2) gt=21 if (twinning /= MISS) then call countmz(locpos(twinning), gt, thresh, work, plevel+1) else write(outstr,'(a)') 'ERROR: No zygosity indicator has been specified.' end if else if (keyw2 == 'pat') then call getenv('PATH', lin) write(outstr,'(a)') trim(lin) else if (keyw2 == 'mac') then write(outstr, '(a)') 'Variables:' call list_var(1, plevel) write(outstr, '(/a)') 'Functions:' call list_var(2, plevel) else if (keyw2 == 'mem') then call show_lochash(nloci, lochash) call show_vcfhash(vcfhash) call show_locus_allocation(ival(words(3)), ival(words(4))) call show_ped_allocation(work, ival(words(3)), ival(words(4)), ival(words(5))) else if (keyw2 == 'snp') then call show_snp(ival(words(3)), ival(words(4)), work) else if (keyw2 == 'spe') then call show_spectrum(work) else if (keyw2 == 'loc') then call actped(2, red, pedfil, nloci, loc, loctyp, locpos, & outpos, locnotes, wloc, locstat, work, plevel) else if (keyw2 == 'mis') then call setup_stat(lin, typ=1) call actped(4, red, pedfil, nloci, loc, loctyp, locpos, & outpos, locnotes, wloc, locstat, work, plevel) else if (keyw2 == 'kin') then call showkin(5, work, plevel+1) else if (twintrait /= ' ') then write(outstr,'(/3a)') & 'MZ twin indicator = "', trim(twintrait), '"' end if if (sexmarker /= ' ') then write(outstr,'(/3a)') & 'Genetic sex marker = "', trim(sexmarker), '"' end if call actped(1, red, pedfil, nloci, loc, loctyp, locpos, & outpos, locnotes, wloc, locstat, work, plevel) end if else if (keyword == 'typ') then if (narg == 1) then typ=2 if (plevel < 2) typ=3 call setup_stat(lin, typ=1) call actped(typ, red, pedfil, nloci, loc, loctyp, locpos, & outpos, locnotes, wloc, locstat, work, plevel) else call gettrait(words(2), LOC_TRA, 0, nloci, loc, lochash, loctyp, trait, 0) if (trait /= MISS) then call setup_stat(lin, typ=1) call strattyp(trait, nloci, loc, loctyp, locpos, locnotes, & locord, work, locstat, plevel) else write(*,'(a)') 'ERROR: Need to specify appropriate trait.' end if end if ! Help else if (keyword == 'hel' .or. keyword(1:1) == '?') then typ=7 ! ?"str" is already correctly parsed if (keyword(1:1) == '?' .and. narg == 1 .and. & len(words(1)) > 1) then narg=2 words(2)=words(1)(2:len_trim(words(1))) keyw2=words(2)(1:3) end if if (narg == 1) then typ=6 else if (keyw2 == 'All') then typ=1 else if (keyw2 == 'Glo') then typ=2 else if (keyw2 == 'Ope') then typ=3 else if (keyw2 == 'Dat') then typ=4 else if (keyw2 == 'Ana') then typ=5 else if (keyw2 == 'Exa') then typ=10 end if call help(typ, words(2), lin, twrk2) ! Echo commands to output else if (keyword == 'set' .and. keyw2 == 'ech') then echo=.true. if (words(3) == 'off') then echo=.false. end if ! Report elapsed time for each procedure else if (keyword == 'set' .and. keyw2 == 'tim') then timer=1 if (words(3) == 'off') timer=0 else if (keyword == 'tim') then call stamp(t0) ! set initial burn-in iterations for Monte-Carlo Markov Chain routines else if (keyword == 'set' .and. keyw2 == 'bur') then if (narg > 2) burnin=ival(words(3)) if (plevel > -1) then write(outstr,'(/a,i0/)') 'NOTE: Number of MC burn-in iterations ', burnin end if else if (keyword == 'set' .and. keyw2 == 'nsa') then if (narg > 2) nsamples=ival(words(3)) if (plevel > -1) then write(outstr,'(/a,i0/)') & 'NOTE: Number of MC samples per batch (thinned) ', nsamples end if else if (keyword == 'set' .and. keyw2 == 'bat') then if (narg > 2) nbatch=ival(words(3)) if (plevel > -1) then write(outstr,'(/a,i0/)') 'NOTE: Number of MC batches ',nbatch end if else if (keyword == 'set' .and. keyw2 == 'emi') then if (narg > 2) emiter=ival(words(3)) if (plevel > -1) then write(outstr,'(/a,i0/)') 'NOTE: Number of EM iterations ',emiter end if else if (keyword == 'set' .and. keyw2 == 'ite') then if (narg > 2) then iter=max(0, ival(words(3))) nbatch=max(1, int(sqrt(10*float(iter)))) end if if (plevel > -1) then write(outstr,'(/a,i0/)') 'NOTE: Number of MC iterations ', iter end if else if (keyword == 'set' .and. keyw2 == 'mft') then if (words(3)(1:3) == 'men') then mftalgo = 1 else if (words(3)(1:3) == 'gen') then mftalgo = 2 if (narg > 3) mfteval=ival(words(4)) if (narg > 4) abseps=fval(words(5)) if (narg > 5) releps=fval(words(6)) if (mfteval <= 0) mfteval=2000 if (abseps <= 0.0d0) abseps=5.0d-5 end if if (plevel > -1) then if (mftalgo == 1) then write(outstr,'(a)') & 'NOTE: Mendell-Elston MVN algorithm in use.' else write(outstr,'(/a/7x,a,i0,a/15x,a,g9.4/15x,a,g9.4/)') & 'NOTE: Genz MVN algorithm in use.', & 'MVN cdf evaluations ', mfteval, ' * NDIM.', & 'Absolute err ', abseps, & 'Relative err ', releps end if end if else if (keyword == 'set' .and. keyw2 == 'opt') then if (words(3)(1:3) == 'bob') then optim=3 else if (words(3)(1:3) == 'var') then optim=2 end if if (optim == 2) then write(outstr,'(a)') 'NOTE: VARMET optimizer being used.' else if (optim == 3) then write(outstr,'(a)') 'NOTE: BOBYQA optimizer being used.' end if else if (keyword == 'set' .and. keyw2 == 'tun') then if (narg > 2) tune=fval(words(3)) if (tune <= 0.0) tune=0.3 if (plevel > -1) then write(outstr,'(/a,f9.4/)') 'NOTE: MCMC proposal tuning parameter ', tune end if else if (keyword == 'set' .and. keyw2 == 'tol') then if (narg > 2) toler(1)=fval(words(3)) if (narg > 3) toler(2)=fval(words(4)) if (narg > 4) toler(3)=fval(words(5)) if (toler(1) <= 0.0d0) toler=1.0d-6 if (toler(2) <= 0.0d0) toler=1.0d-1 if (toler(3) <= 0.0d0) toler=1.0d-3 if (plevel > -1) then write(outstr,'(/a,3(/7x,a,g9.4))') & 'NOTE: Convergence criteria are:', & 'VARMET toler = ', toler(1), & 'BOBYQA rhobegin = ', toler(2), & 'BOBYQA rhoend = ', toler(3) end if else if (keyword == 'set' .and. keyw2 == 'inv') then if (narg > 2) then invalg=0 if (words(3)(1:3) == 'gib') then invalg=ival(words(4)) if (invalg == 0) invalg = 20 end if end if if (plevel > -1) then if (invalg > 0) then write(outstr,'(/a,i0,a/)') & 'NOTE: Using approximate matrix inversion (', invalg, ' its).' else write(outstr,'(/a/)') & 'NOTE: Using LINPACK for matrix inversion.' end if end if else if (keyword == 'set' .and. keyw2 == 'cha') then if (narg > 2) then nchain=MAX(1, ival(words(3))) end if if (plevel > -1) then write(outstr,'(/a,i2/)') 'NOTE: Number of MC random effects chains ', nchain end if else if (keyword == 'set' .and. keyw2 == 'mca') then if (words(3)(1:3) == 'ord') then mcalg=2 else if (narg > 2) then mcalg=ival(words(3)) if (mcalg < 1) mcalg=1 if (mcalg > 3) mcalg=3 end if if (plevel > -1) then if (mcalg == 1) then write(outstr,'(/a/)') 'NOTE: Metropolis slice sampler in use for globals.' else if (mcalg == 2) then write(outstr,'(/a/)') 'NOTE: Ordinary Metropolis sampler in use.' else if (mcalg == 3) then write(outstr,'(/a/7x,a/)') & 'NOTE: Metropolis slice sampler in use for all ', & 'continuous parameters (eg breeding values).' end if end if else if (keyword == 'set' .and. keyw2 == 'nha') then if (narg > 2) then maxhap=ival(words(3)) if (maxhap <= 0) maxhap=100 end if if (plevel > -1) then write(outstr,'(/a,i0/)') 'NOTE: Maximum number of haplotypes ', maxhap end if else if (keyword == 'set' .and. keyw2 == 'sta') then if (ival(words(3)) > 0) then maxtry=ival(words(3)) end if if (plevel > -1) then write(outstr,'(/a,i0/)') & 'NOTE: Number of attempts to generate starting genotypes ', maxtry end if else if (keyword == 'set' .and. keyw2 == 'ord') then if (narg > 2) norder=ival(words(3)) if (plevel > -1) then write(outstr,'(/a,i0,a/)') & 'NOTE: Order statistic used to extrapolate MC P-values: ', & norder, 'th highest' end if else if (keyword == 'set' .and. keyw2 == 'min') then if (narg > 2) mincnt=ival(words(3)) if (plevel > -1) then write(outstr,'(/a,i0/)') & 'NOTE: Minimum numerator for MC P-values ', mincnt end if else if (keyword == 'set' .and. keyw2 == 'chi') then if (words(3)(1:3) == 'gib') then assoc_stat_typ = 2 else if (words(3)(1:3) == 'pea') then assoc_stat_typ = 1 end if if (plevel > -1) then if (assoc_stat_typ == 1) then write(outstr,'(/a/)') & 'NOTE: Pearson chi-square used for categorical trait association.' else write(outstr,'(/a/)') & 'NOTE: Gibbs chi-square used for categorical trait association.' end if end if else if (keyword == 'set' .and. words(2) == 'dot') then if (narg > 2) then if (words(3)(1:3) == 'fix') then dotfixedsep=.true. dotcrossings=fval(words(4)) dotnodesep=fval(words(5)) dotranksep=fval(words(6)) dotboxsize=fval(words(7)) if (narg < 4 .or. dotcrossings < 0.0d0) dotcrossings=2.0d0 if (dotnodesep <= 0.0d0) dotnodesep=0.1d0 if (dotranksep <= 0.0d0) dotranksep=0.5d0 if (dotboxsize <= 0.0d0) dotboxsize=0.8d0 else dotfixedsep=.false. end if end if if (plevel > -1) then write(outstr,'(/a)') & 'For Graphviz (dot) pedigree drawings:' if (dotfixedsep) then write(outstr,'(4(a,f3.1/))') & ' line crossings ', dotcrossings, & ' node separation ', dotnodesep, & ' rank separation ', dotranksep, & ' symbol size ', dotboxsize else write(outstr,'(a/)') ' symbol sizes and placements automatic.' end if end if else if (keyword == 'set' .and. keyw2 == 'jac') then if (narg > 2) then if (words(3)=='off') then jdraw=MISS else jdraw=ival(words(3)) if (jdraw <= 0) jdraw=MISS end if end if if (plevel > -1) then if (jdraw == MISS) then write(outstr,'(/a/)') & 'NOTE: Jackknife is adaptive (delete-1 to delete-10).' else write(outstr,'(/a,i0,a/)') 'NOTE: Jackknife is delete-', jdraw,'.' end if end if else if (keyword == 'set' .and. keyw2 == 'mod') then if (narg > 2) then if (words(3)(1:3) == 'all') then genemod=1 else if (words(3)(1:3) == 'gen') then genemod=2 else genemod=ival(words(3)) if (genemod < 1 .or. genemod > 2) genemod=1 end if end if if (plevel > -1) then if (genemod == 1) then write(outstr,'(/a/)') & 'NOTE: Regression model for (first) codominant marker is allelic.' else write(outstr,'(/a/)') & 'NOTE: Regression model for (first) codominant marker is genotypic.' end if end if else if (keyword == 'set' .and. keyw2 == 'see') then if (narg > 2) then i=ival(words(3)) j=ival(words(4)) k=ival(words(5)) if (j == 0) j=i if (k == 0) k=i call set_rng_seeds(i, j, k) end if if (plevel > -1) then call get_rng_seeds(i, j, k) write(outstr,'(a,3(1x,i5)/)') 'Seeds for RNG (AS183)=', i, j, k end if else if (keyword == 'set' .and. keyw2 == 'pro') then prompt=.true. if (words(3) == 'off') then prompt=.false. else if (narg > 2) then prompt_string=words(3) else if (prompt) then call openlog(LSTR, logfil, nhis) end if else if (keyword == 'set' .and. keyw2 == 'sex') then if (words(3)(1:3) == 'mar') then if (narg > 3) sexmarker=words(4) write(outstr,'(/3a/)') & 'NOTE: The marker "', trim(sexmarker), '" indicates sex.' else if (words(3)(1:3) == 'cod') then if (narg > 4) then sexcode(1)=words(4)(1:1) sexcode(2)=words(5)(1:1) end if write(outstr,'(/4a/)') & 'NOTE: Sexes written as male="', & sexcode(1), '" female="', sexcode(2), '".' else if (narg > 2) then if (fval(words(3)) > 0.0d0) then sexcrit=fval(words(3)) if (sexcrit > 1.0d0) sexcrit=1.0d0 end if if (fval(words(4)) > 0.0d0) then heterror=fval(words(4)) if (heterror > 1.0d0) heterror=1.0d0 end if end if write(outstr,'(/a,f6.4/7x,a,f6.4/)') & 'NOTE: Threshold prob for marker diagnosis of sex ', sexcrit, & 'Expected X homozygote->heterozygote miscall rate ', heterror end if ! prefix to generate dummy IDs for missing parents else if (keyword == 'set' .and. keyw2 == 'uns') then if (narg > 2) then if (.not.red) then unspecified=words(3) else write(outstr,'(/a)') 'Can change prefix only before a dataset is read in.' end if end if write(outstr,'(/3a/)') & 'NOTE: Dummy IDs for missing parents are prefixed "', trim(unspecified), '".' ! prespecify allele frequencies for one marker locus else if (keyword == 'set' .and. keyw2 == 'fre') then if (narg > 2) then call gettrait(words(3), LOC_CODOM, LOC_XLIN, nloci, loc, & lochash, loctyp, fixfreq, 1) if (fixfreq /= MISS) then if (narg > 3) then fixmarker=loc(fixfreq) if (words(4)(1:3) == 'obs') then call freq(locpos(fixfreq), loctyp(fixfreq), fndr, work, fixfreq_buffer) else call freq(locpos(fixfreq), loctyp(fixfreq), fndr, work, allele_buffer) call rdfreq(2, 4, narg, words, fixfreq_buffer) if (fixfreq_buffer%numal /= allele_buffer%numal) then write(outstr,'(/3a,i0,a/7x,i0,a)') & 'NOTE: The marker "', trim(fixmarker), & '" has ', allele_buffer%numal, ' observed alleles but ', & fixfreq_buffer%numal, & ' were specified in the "set freq" command.' end if n=min(fixfreq_buffer%numal, allele_buffer%numal) if (fixfreq_buffer%allele_names(1) == 0) then do i=1, n fixfreq_buffer%allele_names(i)=allele_buffer%allele_names(i) end do end if fixfreq_buffer%typed=allele_buffer%typed fixfreq_buffer%untyped=allele_buffer%untyped end if else write(outstr,'(3a)') 'Marker allele frequencies for "', & trim(fixmarker), '" no longer prespecified.' fixfreq=MISS fixmarker='' end if else write(outstr,'(3a)') & 'ERROR: Need to specify marker: "', & trim(words(3)),'" is not an eligible marker name.' end if end if if (fixfreq /= MISS) then write(outstr,'(/3a)') & 'NOTE: The marker "', trim(fixmarker), & '" has prespecified allele frequencies:' call wrfreq(outstr, fixmarker, group(fixfreq), map(fixfreq), & locnotes(fixfreq), fixfreq_buffer, 15) end if ! Long list of variables else if (keyword == 'lis' .or. keyword == 'whi') then typ=1 if (keyword == 'whi') typ=typ+1 if (words(2) == 'whe' .or. words(2) == 'where') then if (words(3)(1:3) == 'chr' .and. narg > 3) then if (plevel > 1) then write(outstr,'(/a)', advance='no') & 'Searching for loci on chromosome' do j=4, narg write(outstr,'(1x,a)', advance='no') trim(words(j)) end do write(outstr,*) end if call search_chrom(4, narg, words, nloci, group, wloc, nord, locord) else if ((words(3) == 'pos' .or. words(3) == 'position') .and. narg > 3) then call loadpos(4, narg, words, nloci, loc, lochash, loctyp, & group, map, locstat, wloc, nord, locord, 1) else call search_annot(3, narg, words, nloci, locnotes, wloc, nord, locord) end if else call loadnam(2, narg, words, nloci, loc, lochash, loctyp, group, map, & locstat, wloc, nord, locord, LOC_ANY, 3) end if if (typ == 1) then call listloci(nord, locord, nloci, loc, loctyp, outpos, locnotes, & 1, prompt, plevel) else do i=1, nord write(words(1), '(i10)') locord(i) - ENVNUM words(1)='(' // trim(adjustl(words(1))) // ')' write(outstr, '(a,1x,a)') trim(words(1)), loc(locord(i)) end do end if ! Short list of variables else if (keyword == 'ls') then call loadnam(2, narg, words, nloci, loc, lochash, loctyp, group, map, & locstat, wloc, nord, locord, LOC_ANY, 3) call listloci(nord, locord, nloci, loc, loctyp, outpos, locnotes, & 2, prompt, plevel) ! List files in current directory (Unix like systems) else if (words(1) == 'dir') then #if WIN32 lin='$ dir' // lin(4:len_trim(lin)) #else lin='$ ls' // lin(4:len_trim(lin)) #endif call shell(lin, -1) ! Show or change current directory else if (words(1) == 'pwd') then if (narg>1) then lin=adjustl(lin(4:len_trim(lin))) #if IFORT i=chdir(trim(lin)) #else call chdir(trim(lin)) #endif end if #if IFORT i=getcwd(lin) #else call getcwd(lin) #endif write(outstr,'(3a)') 'Current directory: "', trim(lin), '"' ! ! File operations -- delete, rename, query, cat, ... else if (keyword == 'fil') then if (keyw2 == 'del') then do i=3, narg call get_filnam(lin, i, wrkfil) call delfile(wrkfil, plevel) end do ! file rename else if (keyw2 == 'ren') then #if IFORT ioerr=rename(words(3), words(4)) #else ioerr=0 call rename(words(3), words(4)) #endif if (ioerr == 0 .and. plevel >=0) then write(outstr, '(5a)') & 'Renamed file "', trim(words(3)), '" to "', trim(words(4)), '".' else write(outstr, '(3a)') & 'Unable to rename file "', trim(words(3)), '".' end if ! file exists? else if (keyw2 == 'que') then do i=3, narg call get_filnam(lin, i, wrkfil) inquire(file=wrkfil, exist=filexist) if (filexist) then inquire(file=wrkfil, size=bigi) j=isgzipped(wrkfil) if (j == 0) then write(outstr, '(3a,i0,a)') & 'File "', trim(wrkfil), '" exists (size=', bigi, ').' else if (j == 2) then write(outstr, '(3a,i0,a)') & 'BGZF File "', trim(wrkfil), '" exists (size=', bigi, ').' else if (j == 1) then write(outstr, '(3a,i0,a)') & 'Gzipped file "', trim(wrkfil), '" exists (size=', bigi, ').' end if else write(outstr, '(3a)') & 'Unable to access file "', trim(wrkfil), '".' end if end do ! count lines, fields else if (keyw2 == 'fie' .or. keyw2 == 'wc') then j=3 skipcomments=.false. if (words(j) == 'skip') then j=j+1 skipcomments=.true. end if do i=j, narg call get_filnam(lin, i, wrkfil) call countfields(wrkfil, skipcomments, plevel) end do ! transpose rows and cols of file else if (keyw2 == 'tra') then do i=3, narg call get_filnam(lin, i, wrkfil) call ftranspose(wrkfil, misval, plevel) end do ! invert a symmetric matrix entered as triples i,j,val else if (keyw2 == 'inv') then call get_filnam(lin, 3, wrkfil) typ=1 ridge_constant = 0.0d0 do i=4, narg if (words(i) == 'upp' .and. mod(typ,2) == 1) then typ=typ+1 else if (words(i) == 'gen' .and. typ < 3) then typ=typ+2 else if (isreal(words(i))) then ridge_constant = fval(words(i)) end if end do call wrinverse(wrkfil, typ, ridge_constant, invalg, plevel) ! (con)catenate contents of files else if (keyw2 == 'cat') then do i=3, narg call get_filnam(lin, i, wrkfil) call cat(wrkfil) end do write(outstr,*) ! file head else if (keyw2 == 'hea' .or. keyw2 == 'tai') then j=10 n=narg if (n > 3 .and. isint(words(n))) then j=ival(words(n)) n=n-1 end if if (n == 3) then call get_filnam(lin, n, wrkfil) if (keyw2 == 'hea') then call head(wrkfil, j) else call tail(wrkfil, j) end if else do i=3, n call get_filnam(lin, i, wrkfil) write(outstr,'(/3a/)') '"', trim(wrkfil), '":' if (keyw2 == 'hea') then call head(wrkfil, j) else call tail(wrkfil, j) end if end do end if ! hex dump else if (keyw2 == 'hex') then call get_filnam(lin, 3, wrkfil) open(OSTR, file=wrkfil, access=stream_access, form=stream_form, iostat=ioerr) if (ioerr == 0) then bigi=int(1,kind=8) bigj=int(96,kind=8) if (narg == 4) then bigj=max(int(1,kind=8),int(fval(words(4)),kind=8)) else if (narg == 5) then bigi=max(int(1,kind=8),int(fval(words(4)),kind=8)) bigj=bigi+int(1,kind=8) if (words(5)(1:1) == '+') then bigj=max(bigj,bigi+int(fval(words(5)(2:)),kind=8)) else bigj=max(bigj,int(fval(words(5)),kind=8)) end if end if lin=' ' read(OSTR, pos=bigi, iostat=ioerr) lin(1:(bigj-bigi+1)) call hexdump(int(1,kind=8), int(bigj-bigi+1,kind=8), lin, & offset=int(bigi,kind=8)) close(OSTR, status='keep') end if else if (keyw2 == 'bin') then do i=3, narg call get_filnam(lin, i, wrkfil) call rdspbin(wrkfil) end do ! pretty printer else if (keyw2 == 'pri') then narg=maxwords call args(lin, narg, words, ' ', SEP_WHITE) call fprinter(narg, words, lin, plevel) ! Fisher combination of P values else if (keyw2 == 'met') then call get_filnam(lin, 3, wrkfil) i=1 if (narg > 3) then i=max(1,ival(words(4))) end if call fisherp(trim(wrkfil), i) ! Combine files for Metasoft loc beta1 se1 beta2 se2... else if (keyw2 == 'Met') then call tometasoft(lin, plevel) ! screen VCF file else if (keyw2 == 'vcf') then if (words(3) == 'has' .or. words(3) == 'hash') then if (words(4)(1:3) == 'mak') then call get_filnam(lin, 5, wrkfil) call make_vcfhash(trim(wrkfil), vcfhash, plevel) else if (words(4)(1:3) == 'rea') then call get_filnam(lin, 5, wrkfil) call read_vcfhash(wrkfil, vcfhash, plevel) else if (words(4)(1:3) == 'wri') then call get_filnam(lin, 5, wrkfil) call write_vcfhash(wrkfil, vcfhash) else if (words(4)(1:3) == 'che') then call check_vcfhash(vcfhash, plevel) else if (words(4)(1:3) == 'fin') then call search_vcfhash(narg-4, words(5:narg), vcfhash) else if (words(4)(1:3) == 'ann') then call getvcfanno2(1, narg-4, words(5:narg), vcfhash, plevel) else write(outstr,'(a)') 'file vcf hash [make|check|find|read|write|annotate]' end if ! (re)order or filter VCF file based on currently active map else if (words(3) == 'ord' .or. words(3) == 'order') then call reorder_vcf(vcfhash, words(4), words(5)) else if (words(3) == 'lif' .or. words(3) == 'liftover') then call reorder_vcf(vcfhash, words(4), words(5), liftover=.true.) else if (words(3) == 'nlo' .or. words(3) == 'nloci') then do i=4, narg call get_filnam(lin, i, wrkfil) call count_vcflines(wrkfil, j) write(outstr,'(2a,i0)') trim(wrkfil), ' = ', j end do else if (narg == 2) then call fchooser(wrkfil, gui, plevel) else call get_filnam(lin, 3, wrkfil) end if pos=0 if (words(4) == 'ann' .or. words(4) == 'annovar') then pos=51 end if call queryvcf(trim(wrkfil), 1, numloc, pos, plevel) end if ! screen tabix index file else if (keyw2 == 'tbi') then if (narg == 2) then call show_tbi(tbi_index, plevel) else if (narg > 2) then call get_filnam(lin, 3, wrkfil) call read_tbi(trim(wrkfil), tbi_index, i) if (i < 0) then write(outstr,'(a,i0)') 'read_tbi problem istat=', i end if if (narg > 3) then call gettrait(words(4), LOC_CODOM, 0, nloci, loc, lochash, loctyp, gene, -1) if (gene /= MISS) then if (group(gene) /= ' ' .and. map(gene) /= MISS) then call frommega(map(gene), words(4)) words(4)=trim(group(gene)) // ':' // words(4) if (plevel > 0) then write(outstr, '(4a)') & 'Searching for ', trim(loc(gene)), ' at ', trim(words(4)) end if end if end if typ=1 if (words(5)(1:3) == 'ann') typ=typ+1 call search_tbi(tbi_index, words(4), typ) else call show_tbi(tbi_index, plevel) end if end if ! screen fasta file else if (keyw2 == 'fas') then if (narg == 2) then call fchooser(wrkfil, gui, plevel) else call get_filnam(lin, 3, wrkfil) end if if (words(4)(1:3) == 'ind') then call index_fasta(wrkfil, i) else if (narg > 3) then call query_fastaseq(wrkfil, words(4), max(1,ival(words(5)))) else call query_fasta(wrkfil, plevel) end if else write(outstr,'(a)') 'File operation not supported' end if ! assorted text utilities else if (keyword == 'set' .and. keyw2 == 'dic') then if (narg > 2) then call getword(lin, 3, wrkfil) inquire(file=wrkfil, exist=filexist) if (filexist) then dictionary%dictfil=wrkfil dictionary%current=.false. dictionary%nwordlist=0 call readdict(dictionary, ioerr) else write(*,'(/3a/)') 'ERROR: Problem opening "', trim(wrkfil), '".' end if end if write(outstr,'(/3a)') 'System dictionary "', trim(dictionary%dictfil),'".' if (.not.dictionary%current) then call readdict(dictionary, ioerr) end if write(outstr,'(18x,i0,5a)') dictionary%nwordlist, ' words "', & trim(dictionary%wordlist(1)), '"..."', & trim(dictionary%wordlist(dictionary%nwordlist)), '"' if (plevel > 0) then write(outstr,'(a,l1)') 'Sorted dictionary ', dictionary%sorted if (dictionary%sorted) then j=96 do i=1, 26 j=j+1 write(outstr,'(a,1x,i0)') achar(j), dictionary%first_letter(i+1)-dictionary%first_letter(i) end do end if end if else if (keyword == 'ana') then if (narg > 1) then i=len_trim(words(2)) ch=' ' if (narg > 2) then if (is_strict_int(words(3))) then i=ival(words(3)) else if (len_trim(words(3)) == 1) then ch=words(3)(1:1) i=4 if (narg > 3) then if (is_strict_int(words(4))) i=ival(words(4)) end if else write(outstr,'(a)') 'ana <word> [<letter>] [<min_subword_length>].' end if end if if (scan(trim(words(2)), '/ ') > 0) then call ana_each(words(2), dictionary, plevel) else if (narg == 2) then call set_anagram(words(2), dictionary, plevel) else call anagrams(words(2), ch, i, (ch /= ' '), dictionary, plevel) end if else write(outstr,'(a)') 'ana <word> [<letter>] [<min_subword_length>].' end if else if (keyword == 'wor') then if (narg > 1) then call dict_search(trim(lin), dictionary, plevel) else write(outstr,'(a)') 'Need to specify word /pattern, or words.' end if ! ! Change target of output stream else if (keyword == 'out') then if (narg == 1 .and. sink) then if (.not.silent) then write(*,'(/3a)') 'Ending output to "', trim(stdfil),'".' end if call flush(outstr) close(outstr, status='keep') outstr=STDOUT sink=.false. silent=.false. else if (sink) then write(*,'(/3a)') 'Already writing output to "', trim(stdfil),'".' else if (narg == 1) then call fchooser(stdfil, gui, plevel) else call get_filnam(lin, 2, stdfil) end if silent=(narg > 2) inquire(file=stdfil, exist=filexist) open(ALTOUT, file=stdfil, status='unknown', & position='append', iostat=ioerr) if (ioerr == 0) then sink=.true. if (.not.silent) then if (filexist) then write(*,'(/3a)') 'Appending output to "', trim(stdfil),'".' else write(*,'(/3a)') 'Writing output to "', trim(stdfil),'".' end if end if outstr=ALTOUT else sink=.false. write(*,'(/3a/)') 'ERROR: Problem opening "', trim(stdfil), '".' end if end if ! Read commands from a file else if (keyword == 'inc' .or. keyword == 'loc') then if (narg == 1) then call fchooser(locfil, gui, plevel) else call get_filnam(lin, 2, locfil) call concat(' ', locfil) end if call newinclude(keyword, 1, trim(locfil), ioerr) else if (keyword == 'set' .and. keyw2 == 'che') then if (words(3) == 'sex') then sexchek=.not.(words(4) == 'off') if (sexchek) then write(outstr,'(a)') 'Sex checking/imputation on' else write(outstr,'(a)') 'Sex checking/imputation off' end if else if (words(3)(1:3) == 'nam') then namechek=.not.(words(4) == 'off') if (namechek) then write(outstr,'(a)') 'Duplicate locus name checking on' else write(outstr,'(a)') 'Duplicate locus name checking off' end if else chek=.not.(words(3) == 'off') end if else if (keyword == 'set'.and.keyw2 == 'err') then if (words(3) == 'off') then droperr=0 else if (words(3) == 'on') then droperr=2 else droperr=ival(words(3)) end if else if (keyword == 'set'.and.keyw2 == 'lia') then if (narg>3) then call gettrait(words(3), LOC_AFF, 0, nloci, loc, lochash, loctyp, liab, 1) call gettrait(words(4), LOC_QUA, 0, nloci, loc, lochash, loctyp, liabclass, 1) nliabclass=ival(words(5)) if (liab == MISS .or. liabclass == MISS) then liab=MISS liabclass=MISS nliabclass=1 write(outstr, '(a)') & 'ERROR: Could not find affection trait or liability class.' else afftrait=words(3) liabtrait=words(4) end if if (nliabclass <= 0) nliabclass=1 else afftrait='' liabtrait='' liab=MISS liabclass=MISS nliabclass=1 end if write(outstr, '(/a)') & 'For Linkage format pedigree files,' if (liab /= MISS .and. liabclass /= MISS) then write(outstr, '(3a/3a/a,i5/)') & ' Affection trait variable = "', trim(afftrait), '"', & ' Liability class variable = "', trim(liabtrait), '"', & ' No. of liability classes =', nliabclass else write(outstr, '(a/)') ' No liability class trait defined.' end if else if (keyword == 'set' .and. keyw2 == 'sml') then if (narg>2) then smlfreq(1)=fval(words(3)) if (smlfreq(1)>=1.0d0 .or. smlfreq(1)<=0.0d0) smlfreq(1)=0.01d0 smlfreq(2)=1.0d0-smlfreq(1) if (narg==6) then smlpen(1)=fval(words(4)) smlpen(2)=fval(words(5)) smlpen(3)=fval(words(6)) else smlpen(1)=0.50d0 smlpen(2)=0.50d0 smlpen(3)=0.05d0 end if end if write(outstr, '(a,f8.6,3(a,f5.3))') & 'SML model: P(A)=', smlfreq(1), ' Pen(AA)=', smlpen(1), & ' Pen(AB)=', smlpen(2), ' Pen(BB)=', smlpen(3) else if (keyword == 'set' .and. keyw2 == 'pre') then if (narg>2) then if (words(3)(1:3) == 'off') then prevalence=MISS else prevalence=fval(words(3)) if (prevalence <= 0.0d0 .or. prevalence >= 1.0d0) prevalence=MISS end if end if if (prevalence == MISS) then write(outstr, '(a)') 'Binary trait model prevalence unspecified' else write(outstr, '(a,f8.6)') 'Binary trait model prevalence = ', prevalence end if else if (keyword == 'set' .and. keyw2 == 'vcf') then if (narg > 3) then vcf_ac=words(3) vcf_an=words(4) vcf_het=words(5) vcf_hom=words(6) end if write(outstr,'(/a,3(/7x,3a))') & 'NOTE: When reading external population allele frequencies from a VCF file', & 'alternate allele count ="', trim(vcf_ac), '",', & 'total allele count ="', trim(vcf_an), '",', & 'heterozygote count ="', trim(vcf_het), '" and', & 'homozygote count ="', trim(vcf_hom), '".' else if (keyword == 'set' .and. keyw2 == 'fba') then fbatimp=.not.(words(3) == 'off') if (fbatimp) then write(outstr,'(/a/7x,a)') & 'NOTE: In FBAT, missing child alleles imputable from lower down in pedigree', & 'utilized in test for that sibship.' else write(outstr,'(/a/7x,a)') & 'NOTE: In FBAT, missing child alleles imputable from lower down in pedigree', & 'are not utilized in test for that sibship.' end if else if (keyword == 'set' .and. keyw2 == 'tdt') then if (words(3)(1:3) == 'fir') then use2=3 write(outstr,'(/a/)') & 'NOTE: Only one index case per pedigree used -- both parents must be typed.' else use2=2 write(outstr,'(/a/)') & 'NOTE: Index may contribute to TDT only where both parents typed.' end if else if (keyword == 'set' .and. keyw2 == 'hre') then if (words(3)(1:3) == 'zer' .or. words(3)(1:3) == 'fou') then zrec=1 else if (words(3)(1:3) == 'chi') then zrec=2 else zrec=ival(words(3)) end if if (zrec == 0) zrec=2 if (zrec == 1) then write(outstr,'(/a/7x,a)') & 'NOTE: Marker LD model assumes zero recombinants.', & 'In trios, parental haplotypes inferred and used.' else write(outstr,'(/a/7x,a)') 'NOTE: Marker LD model assumes recombinants.', & 'In trios, offspring haplotypes inferred and used.' end if else if (keyword == 'set' .and. keyw2 == 'ana') then useimp=.false. if (words(3)(1:3) == 'imp') useimp=.true. if (.not.useimp) then write(outstr,'(/a)') & 'NOTE: Association analysis uses observed genotypes only.' else write(outstr,'(/a)') & 'NOTE: Association analysis includes imputed genotypes.' end if else if (keyword == 'set' .and. keyw2 == 'ibd') then if (narg > 2) closedist=fval(words(3)) if (narg > 3) then maxcluster=ival(words(4)) if (maxcluster > MAXMULT) maxcluster=MAXMULT if (maxcluster < 1) maxcluster=1 end if write(outstr,'(/a/7x,a,i2,a,f7.3,a)') & 'NOTE: Multipoint IBD estimation is carried out using', & 'sets of up to ', maxcluster, & ' adjacent markers separated by <=', closedist, ' cM.' ! modify content of whole dataset kinship matrix kinmat else if (keyword == 'set' .and. keyw2 == 'kin') then if (words(3) == 'C' .or. words(3) == 'c') then call setup_bigC(work, plevel) else if (words(3) == 'A' .or. words(3) == 'a') then call setup_bigA(work, plevel) ! else if (words(3) == 'H' .or. words(3) == 'h') then ! call setup_bigH(work, plevel) else if (words(3) == 'G' .or. words(3) == 'g') then call momentibs(3, trait, gt, thresh, nloci, loc, loctyp, locpos, & work, plevel) else if (words(3)(1:3) == 'rid') then ridge_constant = fval(words(4)) call kinridge(ridge_constant) else if (words(3) == 'on') then call protect_kin(.true.) write(outstr,'(a)') 'Kinship matrix persists after utilization.' else if (words(3) == 'off') then call protect_kin(.false.) call free_kin(plevel) write(outstr,'(a)') 'Kinship matrix storage freed.' else write(outstr,'(a)') & 'Kinship matrix operations: A, C, G, ridge, on, off.' end if else if (keyword == 'set' .and. keyw2 == 'imp') then if (words(3) == 'off') then imp=0 else if (words(3) == 'on') then imp=1 else if (words(3)(1:3) == 'ful') then imp=2 else if (words(3)(1:3) == 'lan' .or. words(3)(1:3) == 'seq') then imp=3 else if (words(3)(1:3) == 'nil') then imp=-1 else imp=ival(words(3)) end if if (imp > 0) chek=.true. if (imp == 0) then write(outstr,'(a)') & 'NOTE: Imputation off; start genotypes gene-dropped.' else if (imp == 1) then write(outstr,'(a)') & 'NOTE: Unequivocal genotypes imputed; start genotypes gene-dropped.' else if (imp == 2) then write(outstr,'(a)') & 'NOTE: Imputed start genotypes now printable/saveable.' else if (imp == 3) then write(outstr,'(a)') & 'NOTE: Start genotypes to be sequentially imputed by Lange-Goradia.' else if (imp == -1) then write(outstr,'(a)') & 'NOTE: No start genotypes to be generated.' else write(outstr,'(a,i3,a)') & 'NOTE: Imputation level set to ', imp, '.' end if else if (keyword == 'ren') then if (words(2) == 'map') then pos_chrom=0 pos_bp=0 pos_id=0 if (narg == 2) then call fchooser(locfil, gui, plevel) else i=3 if (words(3) == 'bim') then i=i+1 pos_chrom=1 pos_bp=4 pos_id=2 else if (words(3) == 'vcf') then i=i+1 pos_chrom=1 pos_bp=2 pos_id=3 if (narg == 5) pos_id=-1 end if call get_filnam(lin, i, locfil) call concat(datdir, locfil) if (i == 3 .and. narg == 6) then pos_chrom=ival(words(4)) pos_bp=ival(words(5)) pos_id=ival(words(6)) end if end if if (pos_id > -1) then call renamer(locfil, pos_chrom, pos_bp, pos_id, plevel) else call getvcfanno(3, locfil, 1, words(5:5), plevel) end if call make_lochash(nloci, loc, lochash) else if (narg > 2) then call gettrait(words(2), LOC_ANY, 0, nloci, loc, lochash, loctyp, trait, 0) typ=1 if (words(narg) == 'nocheck') then narg=narg-1 typ=typ+1 oldnam=.false. end if if (words(2) /= words(narg)) then if (typ == 1) oldnam=isinuse(namechek, words(narg), loc, lochash) if (trait /= MISS .and. .not.oldnam) then if (plevel > -1) then write(outstr,'(5a)') & 'Renaming locus "', trim(loc(trait)),'" to "', trim(words(narg)),'".' end if loc(trait)=words(narg) call make_lochash(nloci, loc, lochash) call get_string_var('labels_' // trim(words(2)), length=i) if (i > 0) then scheme_lin=' (define labels_' // trim(words(narg)) // & ' labels_' // trim(words(2)) // ')' call repl_scheme(3,0) scheme_lin=' (define labels_' // trim(words(2)) // ' "")' call repl_scheme(3,0) end if else if (oldnam) then write(outstr,'(6a)') & 'ERROR: "', trim(words(narg)),'" in use or reserved,', & ' so cannot rename "', trim(words(2)) , '".' end if end if else write(outstr,'(a)') & 'ERROR: Need to specify old and new names, or a map file' end if ! keep or drop variables from active list else if (keyword == 'kee' .or. keyword == 'dro' .or. keyword == 'und') then typ=1 if (keyword == 'dro') typ=2 ! locus types to act upon (diploid markers) typ1=LOC_CODOM typ2=LOC_XLIN if (keyword == 'und') then typ=3 typ1=DEL_CODOM typ2=DEL_XLIN end if ! select via criterion if (keyw2 == 'whe') then ! if monomorphic if (words(3)(1:3) == 'mon') then write(outstr,'(/a/)') 'Selecting monomorphic markers.' do i=1, nloci wloc(i)=0 if (iseligiblemarker(loctyp(i), 0, typ < 3)) then call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) if (allele_buffer%numal < 2) then wloc(i)=1 if (plevel > 0) then write(outstr,'(3a)') & 'Selected ', trim(loc(i)), ' as monomorphic.' end if end if end if end do ! if diallelic else if (words(3)(1:3) == 'dia' .or. words(3)(1:3) == 'snp') then write(outstr,'(/a/)') 'Selecting diallelic markers.' do i=1, nloci wloc(i)=0 if (iseligiblemarker(loctyp(i), 0, typ < 3)) then call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) if (allele_buffer%numal == 2) then wloc(i)=1 if (plevel > 0) then write(outstr,'(3a)') & 'Selected ', trim(loc(i)), ' as diallelic.' end if end if end if end do ! any number of alleles else if (words(3)(1:3) == 'all') then i=4 call docomp(i, words, gt, hival) if (gt == 0) then hival=fval(words(4)) gt=COMP_EQ end if write(outstr,'(/2a,1x,i0/)') & 'Selecting markers with number of alleles ', & compsign(gt), int(hival) do i=1, nloci wloc(i)=0 if (iseligiblemarker(loctyp(i), 0, typ < 3)) then call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) if (isaff(dble(allele_buffer%numal), hival, gt) == 2.0d0) then wloc(i)=1 if (plevel > 0) then write(outstr,'(3a,i0,a)') & 'Selected ', trim(loc(i)), ' with ', & allele_buffer%numal, ' alleles.' end if end if end if end do ! via frequency of commonest allele else if (words(3)(1:3) == 'max' .or. words(3) == 'maf') then i=4 call docomp(i, words, gt, hival) if (gt == 0) then hival=fval(words(4)) gt=COMP_GE if (typ == 2) gt=gt+1 end if if (words(3) == 'maf') then write(outstr,'(/2a,1x,g9.4/)') & 'Selecting markers with MAF', compsign(gt), hival do i=1, nloci wloc(i)=0 if (iseligiblemarker(loctyp(i), 0, typ < 3)) then call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) all1=allele_buffer%allele_freqs(allele_buffer%minall) if (isaff(all1, hival, gt) == 2.0d0) wloc(i)=1 end if end do else write(outstr,'(/2a,1x,g9.4/)') & 'Selecting markers with max allele freq', compsign(gt), hival do i=1, nloci wloc(i)=0 if (iseligiblemarker(loctyp(i), 0, typ < 3)) then call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) all1=allele_buffer%allele_freqs(allele_buffer%topall) if (isaff(all1, hival, gt) == 2.0d0) wloc(i)=1 end if end do end if ! via allelic spectrum else if (words(3)(1:3) == 'spe') then write(outstr,'(/3a)',advance='no') & 'Selecting markers with allele spectrum "', trim(words(4)), '"' if (narg > 4) then do k=5, narg write(outstr,'(3a)',advance='no') ' "', trim(words(k)), '"' end do end if write(outstr,'(/)') do i=1, nloci wloc(i)=0 if (iseligiblemarker(loctyp(i), 0, typ < 3)) then ! If compressed SNP storage, retrieve allele names if (work%hassnps == 2 .and. iscompressed(loctyp(i))) then call get_snpallele2(locnotes(i), allele_buffer) else call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) end if test_all: do k=4, narg n=0 do j=1, allele_buffer%numal call wrall(allele_buffer%allele_names(j), keyword) keyword=adjustl(keyword) if (index(words(k), trim(keyword)) > 0) n=n+1 end do if (n == allele_buffer%numal) then wloc(i)=1 exit test_all end if end do test_all end if end do ! via the number typed at that locus else if (words(3)(1:3) == 'num' .or. words(3)(1:3) == 'mis') then call coutyp(nloci, loctyp, locpos, work, tnum, wloc) if (words(3)(1:3) == 'mis') then do i=1, nloci wloc(i)=tnum-wloc(i) end do end if i=4 call docomp(i, words, gt, hival) if (gt == 0) then hival=fval(words(4)) gt=COMP_GE if (typ == 2) gt=gt+1 end if ntyped=0 if (hival >= 1.0d0) then ntyped=int(hival) else if (hival > 0.0d0) then ntyped=-1 do i=1, nloci if (wloc(i) > ntyped) ntyped=wloc(i) end do ntyped=int(hival*dble(ntyped)) end if if (words(3)(1:3) == 'mis') then write(outstr,'(/2a,1x,i0,a/)') & 'Selecting loci with ', compsign(gt), & ntyped, ' missing values.' else write(outstr,'(/2a,1x,i0,a/)') & 'Selecting loci with ', compsign(gt), & ntyped, ' observed values.' end if do i=1, nloci if (isaff(dble(wloc(i)), dble(ntyped), gt) == 2.0d0) then if (plevel > 0) then write(outstr,'(3a,i0)') & 'Selected ', trim(loc(i)), ' N typed=', wloc(i) end if wloc(i)=1 else wloc(i)=0 end if end do ! via coverage of categories of a trait else if (words(3)(1:3) == 'cov') then call gettrait(words(4), LOC_TRA, 0, nloci, loc, lochash, & loctyp, trait, 0) if (trait /= MISS) then i=5 call docomp(i, words, gt, pcrit) if (gt == 0) then pcrit=fval(words(5)) gt=COMP_GT end if pcrit=max(0.0d0, pcrit) write(outstr,'(/4a,1x,i0/)') & 'Selecting where number missed categories of "', & trim(loc(trait)), '" ', compsign(gt), int(pcrit) call strattyp(trait, nloci, loc, loctyp, locpos, locnotes, & locord, work, locstat, -2) call selstat('Missed categories at "' // trim(loc(trait)) // '"', & pcrit, gt, plevel) else write(outstr,'(a)') 'ERROR: Need to specify trait to cover.' end if ! via a specified chromosome else if (words(3)(1:3) == 'chr' .or. & (words(3) == 'not' .and. words(4)(1:3) == 'chr')) then sta=4 invert=.false. if (words(3) == 'not') then invert=.true. sta=sta+1 end if if (narg >= sta) then trait=0 if (words(narg)(1:3) == 'tra') then trait=8 narg=narg-1 write(outstr,'(/a)', advance='no') & 'Selecting traits on chromosome' else write(outstr,'(/a)', advance='no') & 'Selecting markers on chromosome' end if if (invert) then write(outstr,'(a)', advance='no') ' other than' end if do j=sta, narg write(outstr,'(1x,a)', advance='no') trim(words(j)) end do write(outstr,*) call search_chrom(sta, narg, words, nloci, group, wloc, nord, locord) do i=1, nloci if (.not.iseligiblemarker(loctyp(i), trait, typ < 3)) then wloc(i)=0 end if if (invert) then if (wloc(i) == 0) then wloc(i)=1 else wloc(i)=0 end if end if end do else write(outstr,'(a)') & 'ERROR: Need to specify at least one chromosome name.' end if ! via a specified map interval else if (words(3)(1:3) == 'pos' .and. narg > 3) then i=1 if (typ == 3) i=i+1 call loadpos(4, narg, words, nloci, loc, lochash, loctyp, & group, map, locstat, wloc, nord, locord, i) ! nearest neighbours else if (words(3)(1:3) == 'nea') then nmark=5 if (narg > 4 .and. isint(words(narg))) then nmark=max(1, ival(words(narg))/2) narg=narg-1 end if i=1 if (typ == 3) i=i+1 call loadnam(4, narg, words, nloci, loc, lochash, loctyp, group, map, & locstat, wloc, nord, locord, LOC_ANY, i) do j=1, nord pos=locord(j) call neighbours(pos, 1, nmark, nloci, loctyp, wloc) call neighbours(pos, -1, nmark, nloci, loctyp, wloc) end do ! via a specified map density else if (words(3)(1:3) == 'dis') then gap=fval(words(4)) write(outstr,*) & 'Selecting markers so as separated by ', gap, ' map units.' dist=0.0d0 do i=1, nloci wloc(i)=0 if (iseligiblemarker(loctyp(i), 0, typ < 3) .and. map(i) /= MISS) then dist=dist+map(i) if (dist >= gap) then if (plevel > 0) then write(outstr,'(3a,f9.3)') & 'Selected ', trim(loc(i)), ' on intermarker gap ', dist end if dist=0.0d0 wloc(i)=1 end if end if end do if (typ == 2) then do i=1, nloci if (same_loctyp(loctyp(i), loctyp(pos))) then wloc(i)=1-wloc(i) end if end do end if ! via a specified pairwise disequilibrium r2 else if (words(3) == 'r2') then if (narg < 4) then write(outstr,'(a)') 'ERROR: No threshold for r2 given!' cycle end if thresh=fval(words(4)) write(outstr,'(a)', advance='no') 'Selecting markers so intermarker r2 <' write(outstr,*) thresh wloc=0 do i=1, nloci if (isactive(loctyp(i))) then wloc(i)=1 end if end do ! Move to first active marker locus do pos=1, nloci if (isactdip(loctyp(pos))) then wloc(pos)=2 exit end if end do j=pos+1 ! check for significant LD with last 20 active loci do while (j <= nloci) if (isactive(loctyp(j)) .and. & same_loctyp(loctyp(j), loctyp(pos))) then call freq(locpos(j), loctyp(j), fndr, work, allele_buffer2) wloc(j)=2 nmark=0 backcheck: do i=pos, 1, -1 if (wloc(i) == 2) then nmark=nmark+1 call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) call twold(zrec, maxhap, locpos(i), loc(i), loctyp(i), & locpos(j),loc(j), loctyp(j), & allele_buffer, allele_buffer2, work, & iter, pval, 1, plevel-2) if (pval > thresh) then wloc(j)=0 exit backcheck end if if (nmark > 20) exit ! avoid too exhaustive comparison end if end do backcheck end if if (wloc(j) == 2) then if (plevel > 0) then write(outstr,'(5a,f9.3)') & 'Selected "', trim(loc(j)), '" with intermarker r2 to "', & trim(loc(pos)), '" of ', pval end if pos=j end if j=j+1 end do ! keep and drop need to have same effect for this command if (typ == 2) typ=1 ! every Nth locus else if (words(3)(1:3) == 'eve' .and. narg == 4) then if (ival(words(4)) > 1) then k=ival(words(4)) write(outstr,'(a,i0,a)') 'Selecting every ', k, 'th locus.' nmark=0 do i=1, nloci wloc(i)=0 if (isactive(loctyp(i))) then nmark=nmark+1 if (nmark == k) then nmark=0 wloc(i)=1 if (plevel > 0) then write(outstr,'(2a)') 'Selected ', trim(loc(i)) end if end if end if end do else thresh=fval(words(4)) if (thresh > 0.0d0 .and. thresh < 1.0d0) then write(outstr,'(a,f6.1,a)') 'Selecting ', thresh, 'proportion of loci.' do i=1, nloci wloc(i)=0 if (isactive(loctyp(i))) then if (random() < thresh) then wloc(i)=1 if (plevel > 0) then write(outstr,'(2a)') 'Selected ', trim(loc(i)) end if end if end if end do end if end if ! HWD or association test P-value else if (words(3)(1:3) == 'tes' .or. words(3)(1:3) == 'hwe' .or. & words(3)(1:3) == 'hom') then i=4 call docomp(i, words, gt, pcrit) if (gt == 0) then if (narg > 3 .and. isreal(words(4))) then pcrit=fval(words(4)) else call cntmark(nloci, loctyp, nmark, 1) pcrit=bonf(nmark, 0.05D0) end if gt=17 if (typ == 2) gt=gt+1 end if if (locstat_typ /= 0 .or. ((locstat_typ == 0 .or. & words(3)(1:3) == 'hwe' .or. words(3)(1:3) == 'hom') .and. & ((pcrit >= 0.0d0 .and. pcrit <= 1.0d0) & .or. pcrit == MISS))) then if (words(3)(1:3) == 'hwe') then write(outstr,'(2a,1x)', advance='no') & 'Selecting markers where HWE P-value ', compsign(gt) write(outstr,*) pcrit if (iter > 0 .and. nloci > 100) then write(outstr,'(a/7x,a)') & 'NOTE: Since the number of MC iterations is nonzero,', & 'this command may take a prolonged time (Ctrl-C to interrupt).' end if !-OMP PARALLEL !-OMP DO ORDERED do i=1, nloci if (irupt == 0) then wloc(i)=0 if (same_loctyp(loctyp(i), typ1) .or. & same_loctyp(loctyp(i), typ2)) then call dohwe(loc(i), locpos(i), loctyp(i), iter, mincnt, assfnd, & norder, work, pval, 1, plevel-3) if (isaff(pval, pcrit, gt) == 2.0d0) then wloc(i)=1 if (plevel > 0) then write(outstr,'(4a)') & 'Selected ', trim(loc(i)), ' HWE P=', pstring(pval) end if end if end if end if end do !-OMP END DO !-OMP END PARALLEL else if (words(3)(1:3) == 'hom') then write(outstr,'(2a,1x)', advance='no') & 'Selecting markers where homozygosity ', compsign(gt) write(outstr,*) pcrit do i=1, nloci if (irupt == 0) then wloc(i)=0 if (same_loctyp(loctyp(i), typ1) .or. & same_loctyp(loctyp(i), typ2)) then call counthom(locpos(i), work, pval) if (isaff(pval, pcrit, gt) == 2.0d0) then wloc(i)=1 if (plevel > 0) then write(outstr,'(4a)') & 'Selected ', trim(loc(i)), ' Obs Hom = ', pstring(pval) end if end if end if end if end do else if (locstat_typ == 0) then write(outstr,'(2a,1x)', advance='no') & 'Selecting markers where test P-value ', compsign(gt) write(outstr,*) pcrit call selstat(' P-value', pcrit, gt, plevel) else write(outstr,'(2a,1x)', advance='no') & 'Selecting markers where test statistic ', compsign(gt) write(outstr,*) pcrit call selstat(' test', pcrit, gt, plevel) end if else write(outstr,*) 'Inappropriate P-value for exclusion: ', pcrit end if ! listed in a text file else if (words(3) == 'in') then if (narg == 2) then call fchooser(locfil, gui, plevel) else call get_filnam(lin, 4, locfil) call concat(datdir, locfil) end if call open_port(locfil, port, 'r', ioerr) if (ioerr == 0) then call make_lochash(nloci, loc, lochash) if (isint(words(5))) then i=ival(words(5)) call readnames(port, nloci, loc, lochash, wloc, plevel, colpos=i) else call readnames(port, nloci, loc, lochash, wloc, plevel) end if call close_port(port, ioerr) else write(outstr,'(3a)') 'ERROR: File "', trim(locfil), '" not found.' end if ! via a search of the annotations for that locus else call search_annot(3, narg, words, nloci, locnotes, wloc, nord, locord) end if ! or a list of names or wild-card search of the names else i=1 if (typ == 3) i=i+1 call loadnam(2, narg, words, nloci, loc, lochash, loctyp, group, map, & locstat, wloc, nord, locord, LOC_ANY, i) end if ! keep if (typ == 1) then nmark=0 do i=ENVNUM+1, nloci if (mod(loctyp(i), LOC_CMP) < LOC_DEL) then loctyp(i)=loctyp(i)+LOC_DEL end if end do do i=ENVNUM+1, nloci if (wloc(i) > 0) then nmark=nmark+1 loctyp(i)=loctyp(i)-LOC_DEL end if end do if (plevel > -1) then if (nmark == 1) then write(outstr,'(a)') 'Keeping 1 active locus.' else write(outstr,'(a,i0,a)') 'Keeping ', nmark, ' active loci.' end if end if ! drop else if (typ == 2) then nmark=0 do i=ENVNUM+1, nloci if (wloc(i) > 0 .and. mod(loctyp(i), LOC_CMP) < LOC_DEL) then nmark=nmark+1 loctyp(i)=loctyp(i)+LOC_DEL end if end do if (plevel > -1) then if (nmark==1) then write(outstr,'(a)') 'Dropping 1 active locus.' else write(outstr,'(a,i0,a)') 'Dropping ', nmark, ' active loci.' end if end if ! Undrop via a search of the locus annotations or the locus names else nmark=0 do i=ENVNUM+1, nloci if (mod(loctyp(i), LOC_CMP) > LOC_DEL .and. wloc(i) > 0) then nmark=nmark+1 loctyp(i)=loctyp(i)-LOC_DEL end if end do if (plevel > -1) then if (nmark==1) then write(outstr,'(a)') 'Reactivated 1 locus.' else write(outstr,'(a,i0,a)') 'Reactivated ', nmark, ' loci.' end if end if end if ! Reorder the locus presentation (ie tweak locord) else if (keyword == 'ord') then call loadnam(2, narg, words, nloci, loc, lochash, loctyp, group, map, & locstat, wloc, nord, locord, LOC_ANY, 1) call ordvar(TWRK, nloci, loc, loctyp, locpos, outpos, nord, locord, & group, map, locstat, locnotes, wloc) call make_lochash(nloci, loc, lochash) ! Sibship disequilibrium test else if (keyword == 'sdt' .and. red) then call gettrait(words(2), LOC_AFF, LOC_QUA, nloci, loc, lochash, loctyp, trait, 1) if (trait /= MISS) then write(*,'(/a/3a/a/)') & '------------------------------------------------', & 'SDT for trait "', trim(loc(trait)), '" v. all markers', & '------------------------------------------------' cltyp=-2 if (words(3)(1:3) == 'ped') then cltyp=-1 write(outstr,'(a)') 'NOTE: Stratifying on pedigree, not sibship.' else if (words(3)(1:3) == 'str' .and. narg == 4) then call gettrait(words(4), LOC_ANY, 0, nloci, loc, lochash, loctyp, censor, 1) if (censor /= MISS) then write(outstr,'(3a)') & 'NOTE: Stratifying on "', trim(loc(censor)), '".' cltyp=censor end if end if if (plevel <= 0) then write(outstr,'(/a/a)') & 'Marker Typed Allels Chi-square Asy-P ST-P' , & '-------------------- ------ ------ ---------- ------ ------' end if nord=2 locord(nord)=trait call setup_stat(lin) do i=1, nloci if (isactdip(loctyp(i)) .and. irupt == 0) then call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) locord(1)=i gene=i call clreg(2, cltyp, nord, locord, nloci, loc, loctyp, locpos, & gene, genemod, allele_buffer, useimp, work, & mlik(whlik), mpar(whlik), statval, pval, plevel) locstat(i)=pval end if end do else write(outstr,'(a)') 'ERROR: Need to specify trait.' end if ! TDTs else if (keyword == 'tdt' .and. red) then call gettrait(words(2), LOC_TRA, 0, nloci, loc, lochash, loctyp, trait, 1) if (trait /= MISS) then cutoff=0 gt=0 thresh=MISS typ=3 ! while not end of list of keywords i=3 do while (i <= narg) keyword=words(i)(1:3) if (iscomp(keyword)) then call docomp(i, words, gt, thresh) else if (keyword == 'cut') then cutoff=ival(words(i+1)) i=i+2 else if (keyword == 'mat') then typ=1 i=i+1 else if (keyword == 'pat') then typ=2 i=i+1 else write(outstr,'(3a)') 'Skipping unknown keyword "', & words(i)(1:len_trim(words(i))),'".' i=i+1 end if end do ! write(outstr,'(/a/3a/a/)') & '------------------------------------------------', & 'TDT for trait "', trim(loc(trait)), '" v. all markers', & '------------------------------------------------' if (typ == 1) then write(outstr,'(a/)') 'NOTE: Maternal contributions only.' else if (typ == 2) then write(outstr,'(a/)') 'NOTE: Paternal contributions only.' end if if (thresh /= MISS) call defpro(gt, thresh, .true.) if (plevel == -1 .or. plevel == 0) then if (loctyp(trait) == LOC_AFF .or. gt > 0) then write(outstr,'(/a/a)') & 'Marker Typed NParam Chi-square Asy P Emp P Iters', & '-------------------- ------ ------ ---------- ------ ------ --------' else write(outstr,'(/a/a)') & 'Marker Typed NParam F test Asy P Emp P Iters', & '-------------------- ------ ------ ---------- ------ ------ --------' end if end if call setup_stat(lin) if (loctyp(trait) == LOC_AFF .or. gt > 0) then !$OMP PARALLEL DO do i=1, nloci if (isactdip(loctyp(i)) .and. irupt == 0) then call dotdt(locpos(trait), loc(i), locpos(i), loctyp(i), fndr, iter, & mincnt, use2, typ, cutoff, gt, thresh, work, & locstat(i), plevel) end if end do !$OMP END PARALLEL DO else !$OMP PARALLEL DO do i=1, nloci if (isactdip(loctyp(i)) .and. irupt == 0) then call qtdt(locpos(trait), loc(i), locpos(i), loctyp(i), fndr, iter, & mincnt, use2, typ, work, locstat(i), plevel) end if end do !$OMP END PARALLEL DO end if else write(outstr,'(a)') 'ERROR: Need to specify trait.' end if ! Nontransmitted alleles to proband else if (keyword == 'hrr'.and.red) then call getbin(2, narg, words, nloci, loc, lochash, loctyp, trait, gt, thresh) if (trait /= MISS) then write(outstr,'(/a/3a/a/)') & '----------------------------------------------------', & 'Haplotype Relative Risk for trait "', trim(loc(trait)), '" v. all markers', & '----------------------------------------------------' if (thresh /= MISS) call defpro(gt, thresh, .true.) if (plevel < 1) then write(outstr,'(/a/a)') & 'Marker Typed NParam Chi-square Asy P Emp P Iters', & '-------------------- ------ ------ ---------- ------ ------ --------' end if call setup_stat(lin) do i=1, nloci if (isactdip(loctyp(i)) .and. irupt == 0) then call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) call dohrr(locpos(trait), loc(i), locpos(i), iter, mincnt, gt, thresh, & work, allele_buffer, pval, plevel) locstat(i)=pval end if end do else write(outstr,'(a)') 'ERROR: Need to specify trait.' end if ! descriptive statistics for traits else if ((keyword == 'fre' .or. keyword == 'des') .and. red) then typ=1 typ2=1 if (words(2) == 'snp') then typ=2 narg=4 words(2)='$m' words(3)='$x' words(4)='$h' call setup_stat('Marker MAF', typ=1) if (plevel > -2) then write(outstr,'(/a/a)') & 'Marker NAll Allele(s) Freq Het Ntyped', & '-------------------- ---- ----------- ------ ------ ------' end if else if (words(narg) == 'pol' .or. words(narg) == 'polychoric') then typ2=2 narg=narg-1 end if call loadnam(2, narg, words, nloci, loc, lochash, loctyp, group, map, & locstat, wloc, nord, locord, LOC_ANY, 1) do i=1, nord if (irupt == 0) then j=locord(i) if (isactive(loctyp(j)) .and. ismarker(loctyp(j))) then call freq(locpos(j), loctyp(j), fndr, work, allele_buffer) if (allele_buffer%minall > 0) then locstat(j)=allele_buffer%allele_freqs(allele_buffer%minall) end if if (plevel > -2) then call wrfreq(wrk2, loc(j), group(j), map(j), & locnotes(j), allele_buffer, typ) end if else if (loctyp(j) == LOC_QUA) then call famcor(loc(j), locpos(j), work, jdraw, iter, plevel) else if (loctyp(j) == LOC_AFF) then call segrat(loc(j), locpos(j), work) else if (loctyp(j) == LOC_CAT) then call catseg(typ2, j, work, jdraw, iter, plevel) end if end if end do ! summary of MAFs when plevel if (plevel < -1 .and. typ == 2) then call histstat(plevel) end if ! MCEM estimation of marker allele frequencies else if (keyword == 'mcf' .and. red) then call loadnam(2, narg, words, nloci, loc, lochash, loctyp, group, map, & locstat, wloc, nord, locord, LOC_ANY, 1) do i=1, nord if (irupt == 0) then j=locord(i) if (same_loctyp(loctyp(j), LOC_CODOM)) then call freq(locpos(j), loctyp(j), fndr, work, allele_buffer) call mcfreq(locpos(j), iter, emiter, work, allele_buffer, plevel) call wrfreq(wrk2, loc(j), group(j), map(j), & locnotes(j), allele_buffer, 11) end if end if end do ! Iterative peeled or MCMC genotypic probability estimates else if (keyword == 'gpe' .and. red) then call gettrait(words(2), LOC_CODOM, 0, nloci, loc, lochash, loctyp, gene, 1) if (gene /= MISS) then typ=2 words(1)='ML' if (words(3)(1:3) == 'mcm' .or. words(4)(1:3) == 'mcm') then typ=typ-1 words(1)='MCMC' call gettrait(words(4), LOC_QUA, 0, nloci, loc, lochash, loctyp, trait, 1) else call gettrait(words(3), LOC_QUA, 0, nloci, loc, lochash, loctyp, trait, 1) end if if (fixfreq /= MISS) then call gettrait(fixmarker, LOC_CODOM, 0, nloci, loc, lochash, loctyp, fixfreq, 0) end if write(outstr,'(/a/4a/a)') & '---------------------------------------------------------', & trim(words(1)), ' Genotype Probability Estimates for "', trim(loc(gene)), '"', & '---------------------------------------------------------' if (gene /= fixfreq) then call freq(locpos(gene), loctyp(gene), fndr, work, mcmc_buffer) else write(outstr,'(/a)') & 'NOTE: Population allele frequencies are prespecified as:' call wrfreq(outstr, fixmarker, group(fixfreq), map(fixfreq), & locnotes(fixfreq), fixfreq_buffer, 15) call copyfreq(fixfreq_buffer, mcmc_buffer) if (typ == 1) then call newstart(locpos(gene), mcmc_buffer, work, plevel) end if end if if (trait /= MISS) then write(outstr,'(3a/)') & 'NOTE: Writing allele dose to "', trim(loc(trait)), '".' trait=locpos(trait) end if if (typ == 1) then call mcgpe(locpos(gene), trait, iter, burnin, mcmc_buffer, work, plevel) else whlik=3-whlik mcall(whlik)=trim(lin) call dopeel(typ, locpos(gene), trait, emiter, mcmc_buffer, work, & mlik(whlik), plevel) end if else write(outstr,'(a)') 'ERROR: Need to specify marker.' end if ! Iterative peeling likelihood else if (keyword == 'pee' .and. red) then call gettrait(words(2), LOC_CODOM, 0, nloci, loc, lochash, loctyp, gene, 1) if (gene /= MISS) then typ=1 trait=MISS if (words(3)=='gpe') typ=typ+1 if (fixfreq /= MISS) then call gettrait(fixmarker, LOC_CODOM, 0, nloci, loc, lochash, loctyp, fixfreq, 0) end if write(outstr,'(/a/3a/a)') & '---------------------------------------------------------', & 'Iterative peeling likelihood for "', trim(loc(gene)), '"', & '---------------------------------------------------------' if (gene /= fixfreq) then call freq(locpos(gene), loctyp(gene), fndr, work, allele_buffer) else write(outstr,'(/a)') & 'NOTE: Population allele frequencies are prespecified as:' call wrfreq(outstr, fixmarker, group(fixfreq), map(fixfreq), & locnotes(fixfreq), fixfreq_buffer, 15) call copyfreq(fixfreq_buffer, allele_buffer) end if whlik=3-whlik mcall(whlik)=trim(lin) call dopeel(typ, locpos(gene), trait, emiter, allele_buffer, work, & mlik(whlik), plevel) else write(outstr,'(a)') 'ERROR: Need to specify marker.' end if ! Corrected segregation ratios following Davie 1976 else if (keyword == 'dav' .and. red) then call gettrait(words(2), LOC_AFF, 0, nloci, loc, lochash, loctyp, trait, 0) call gettrait(words(3), LOC_AFF, 0, nloci, loc, lochash, loctyp, prob, 0) if (trait /= MISS) then if (prob == MISS) prob=trait call davie(loc(trait), locpos(trait), loc(prob), locpos(prob), & work, plevel) else write(outstr,'(a)') 'ERROR: Need to specify trait.' end if ! Segregation ratios for a marker else if (keyword == 'seg' .and. red) then call gettrait(words(2), LOC_CODOM, LOC_XLIN, nloci, loc, lochash, loctyp, gene, 0) typ=1 if (words(3)(1:3) == 'unp') typ=2 if (gene /= MISS) then call freq(locpos(gene), loctyp(gene), fndr, work, allele_buffer) call marseg(locpos(gene), loc(gene), typ, work, allele_buffer, plevel) else write(outstr,'(a)') 'ERROR: Need to specify marker.' end if ! global recoding of trait values else if (keyword == 'rec' .and. red) then call loadnam(2, 2, words, nloci, loc, lochash, loctyp, & group, map, locstat, wloc, nord, locord, LOC_ANY, 1) if (nord > 0) then typ=0 pos=findword('to', 3, narg, narg, words) if (nord == 1 .and. pos > 0) then trait=locord(nord) nto=narg-pos nf=pos-3 if (nf >= nto .and. nto >= 1) then if (.not.allocated(recfro)) then allocate(recto(nf)) allocate(recfro(nf)) else if (nf>size(recfro)) then deallocate(recto, recfro) allocate(recto(nf)) allocate(recfro(nf)) end if if (ismarker(loctyp(trait)) .and. isactive(loctyp(trait))) then gcode=gencode(loctyp(trait)) do i=1, nto recto(i)=aval(words(pos+i), 1) end do do i=1, nf recfro(i)=aval(words(2+i), 1) end do else do i=1, nto recto(i)=fval(words(pos+i)) end do do i=1, nf recfro(i)=fval(words(2+i)) end do end if call recode(loc(trait), locpos(trait), loctyp(trait), & nto, recto, nf, recfro, work, plevel) else write(outstr,'(a/7x,a)') & 'ERROR: Need to specify correct number of values to recode:', & 'either an N->1 or N->N mapping.' end if else if (words(3)(1:3) == 'let') then write(outstr,'(/a)') & 'Recoding numbered alleles to nucleotide letter code (1234->ACGT).' do i=1, nord trait=locord(i) if (ismarker(loctyp(trait)) .and. isactive(loctyp(trait))) then call ntcode(2, locpos(trait), work) end if end do else if (words(3)(1:3) == 'num') then write(outstr,'(/a)') & 'Recoding nucleotide letter alleles to number code (ACGT->1234).' do i=1, nord trait=locord(i) if (ismarker(loctyp(trait)) .and. isactive(loctyp(trait))) then call ntcode(1, locpos(trait), work) end if end do else if (words(3)(1:3) == 'nuc') then write(outstr,'(/a)') & 'Recoding numbered or A/B alleles to nucleotide letter code.' do i=1, nord trait=locord(i) if (ismarker(loctyp(trait)) .and. isactive(loctyp(trait))) then call freq(locpos(trait), loctyp(trait), fndr, work, allele_buffer) call nuccode(locpos(trait), loctyp(trait), locnotes(trait), & allele_buffer, work) end if end do else if (words(3)(1:3) == 'ref' .or. words(3)(1:3) == 'maj') then typ=1 if (words(3)(1:3) == 'maj') typ=typ+1 i=4 if (words(i) == 'vcf') then call get_filnam(lin, i+1, wrkfil) i=i+2 call open_port(wrkfil, port, 'r', ioerr) if (ioerr == 0) then typ=typ+2 else write(outstr,'(/3a/)') & 'ERROR: Problem opening VCF file "', trim(wrkfil), '".' end if end if call gettrait(words(i), LOC_ANY, 0, nloci, loc, lochash, loctyp, censor, 1) if (typ == 1 .or. typ == 3) then write(outstr,'(/a)') & 'Recoding missing genotypes to reference allele homozygote.' if (typ == 3) then write(outstr,'(3a)') & 'Reading reference allele from VCF file "', trim(wrkfil), '".' end if else write(outstr,'(/a)') & 'Recoding missing genotypes to reference allele homozygote.' if (typ == 4) then write(outstr,'(3a)') & 'Reading major allele from VCF file "', trim(wrkfil), '".' end if end if if (censor /= MISS) then write(outstr,'(3a)') 'Filtering on trait "', trim(loc(censor)), '".' censor=locpos(censor) end if call filter_snp(censor, work) if (typ == 1 .or. typ == 2) then if (plevel > 0) then write(outstr,'(/a)') & 'Locus Changed New_Genotype' end if do i=1, nord gene=locord(i) if (ismarker(loctyp(gene)) .and. isactive(loctyp(gene))) then call freq(locpos(gene), loctyp(gene), fndr, work, allele_buffer) call refgeno(typ, loc(gene), locpos(gene), loctyp(gene), & locnotes(gene), allele_buffer, work, plevel) end if end do else call refvcfgeno(typ-2, vcf_ac, vcf_an, port, work, plevel) call close_port(port, ioerr) end if else if (words(3)(1:3) == 'cat') then do i=1, nord trait=locord(i) if (loctyp(trait) == LOC_QUA .or. loctyp(trait) == LOC_CAT) then loctyp(trait)=LOC_QUA+LOC_CAT-loctyp(trait) else if (loctyp(trait) == LOC_AFF) then loctyp(trait)=LOC_CAT call recast(loctyp(trait), locpos(trait), work, plevel) end if write(outstr,'(4a)') & 'Recast "', trim(loc(trait)), '" as ', typlloc(loctyp(trait)) end do else if (words(3)(1:3) == 'aff' .or. words(3)(1:3) == 'bin') then do i=1, nord trait=locord(i) if (loctyp(trait) == LOC_QUA .or. loctyp(trait) == LOC_AFF) then loctyp(trait)=LOC_QUA+LOC_AFF-loctyp(trait) call recast(loctyp(trait), locpos(trait), work, plevel) else if (loctyp(trait) == LOC_CAT) then loctyp(trait)=LOC_AFF call recast(loctyp(trait), locpos(trait), work, plevel) end if write(outstr,'(4a)') & 'Recast "', trim(loc(trait)), '" as ', typlloc(loctyp(trait)) end do else typ=2 if (words(3)(1:3) == 'fre') typ=3 do i=1, nord trait=locord(i) if (ismarker(loctyp(trait)) .and. isactive(loctyp(trait))) then call freq(locpos(trait), loctyp(trait), fndr, work, allele_buffer) call renumb(loc(trait), locpos(trait), typ, allele_buffer, work) end if end do end if else write(outstr,'(a)') 'ERROR: Need to specify appropriate locus to recode.' end if ! If alleles are nucleotides recode to other strand else if (keyword == 'fli') then if (words(2) == 'map' .or. words(2) == 'vcf') then ioerr=0 typ=1 if (narg > 2) then call get_filnam(lin, 3, locfil) call concat(datdir, locfil) call open_port(locfil, port, 'r', ioerr) if (ioerr == 0) then typ=typ+1 write(outstr,'(3a)') 'Reading map file "', trim(locfil), '".' end if end if if (ioerr == 0) then if (red) then call flipper(typ, port, work, plevel) else if (typ == 2) then call testflips_map(port, plevel) end if if (typ == 2) call close_port(port, ioerr) else write(outstr,'(3a)') 'ERROR: File "', trim(locfil), '" not found.' end if else if (words(2) == 'fasta') then typ=1 if (red) typ=2 call get_filnam(lin, 3, locfil) call testflips_fasta(typ, locfil, plevel) else call loadnam(2, narg, words, nloci, loc, lochash, loctyp, group, map, & locstat, wloc, nord, locord, LOC_ANY, 1) do i=1, nord trait=locord(i) if (ismarker(loctyp(trait)) .and. isactive(loctyp(trait))) then call freq(locpos(trait), loctyp(trait), fndr, work, allele_buffer) if (allele_buffer%numal <= 2) then call flip(loc(trait), locpos(trait), flip_atgc, work, plevel) else if (allele_buffer%numal == 4) then call dohwe(loc(trait), locpos(trait), loctyp(trait), 0, mincnt, .false., & norder, work, pval, 2, plevel) end if end if end do end if ! ! If diallelic marker, swap alleles for list of markers unconditionally or ! via stratum membership and values of test statistic ! else if (keyword == 'swa' .and. red) then call gettrait(words(2), LOC_AFF, LOC_CAT, nloci, loc, lochash, loctyp, trait, 1) if (trait /= MISS) then thresh=2.0d0 if (narg > 2 .and. words(3) == 'lod') then thresh=fval(words(4)) end if call setup_stat('Putative allele swaps by source "' // & trim(loc(trait)) // '"', typ=2) write(outstr,'(/a/3a/a/a,f6.1)') & '----------------------------------------------------------', & 'Repairing likely allele swaps within strata of "', trim(loc(trait)), '"', & '----------------------------------------------------------', & 'Lod score triggering swap = ', thresh if (plevel > -1) then write(outstr,'(/a/a)') & 'Marker All Diagn Level Chi-sq[1] Chi-sq[0] lod Changes', & '-------------------- --- ------- -------- ------------- --------------- ----- -------' end if nmark=0 do i=1, nloci if (ismarker(loctyp(i)) .and. isactive(loctyp(i))) then call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) if (allele_buffer%numal == 2) then call testflips_source(2, thresh, loc(trait), locpos(trait), & loctyp(trait), locnotes(trait), & locpos(i), loc(i), & allele_buffer, work, gibbs, statval, plevel) locstat(i)=statval(1) if (statval(1) > thresh) nmark=nmark+1 end if end if end do write(outstr,'(/a,i0,a)') 'Swapped alleles at ', nmark, ' loci.' else call loadnam(2, narg, words, nloci, loc, lochash, loctyp, group, map, & locstat, wloc, nord, locord, LOC_ANY, 1) nmark=0 do i=1, nord gene=locord(i) if (ismarker(loctyp(gene)) .and. isactive(loctyp(gene))) then call freq(locpos(gene), loctyp(gene), fndr, work, allele_buffer) if (allele_buffer%numal == 2) then nmark=nmark+1 call swapalleles(loc(gene), locpos(gene), allele_buffer, work, plevel) end if end if end do write(outstr,'(/a,i0,a)') 'Swapped alleles at ', nmark, ' loci.' end if ! combine rare alleles for marker loci else if (keyword == 'com' .and. red) then thresh=0.05D0 if (isreal(words(narg))) then thresh=fval(words(narg)) narg=narg-1 end if call loadnam(2, narg, words, nloci, loc, lochash, loctyp, group, map, & locstat, wloc, nord, locord, LOC_ANY, 1) do i=1, nord trait=locord(i) if (ismarker(loctyp(trait)) .and. isactive(loctyp(trait))) then write(outstr,'(3a)') 'Combining rare alleles for ', trim(loc(trait)), '.' call freq(locpos(trait), loctyp(trait), fndr, work, allele_buffer) if (.not.allocated(recfro)) then allocate(recto(allele_buffer%numal)) allocate(recfro(allele_buffer%numal)) else if (allele_buffer%numal>size(recfro)) then deallocate(recto, recfro) allocate(recto(allele_buffer%numal)) allocate(recfro(allele_buffer%numal)) end if call combine(thresh, recto, nf, recfro, allele_buffer) if (nf > 1) then nto=1 if (thresh == 2.0d0) nto=nf call recode(loc(trait), locpos(trait), loctyp(trait), & nto, recto, nf, recfro, work, plevel) end if end if end do ! ! Dummy code a SNP 1=additive, 2=dom, 3=rec ! else if (keyword == 'snp' .and. red) then call gettrait(words(2), LOC_CODOM, LOC_XLIN, nloci, loc, lochash, loctyp, gene, 0) call gettrait(words(3), LOC_QUA, 0, nloci, loc, lochash, loctyp, trait, 0) if (trait /= MISS .and. gene /= MISS) then typ=1 if (words(4)(1:3) == 'dom') typ=2 if (words(4)(1:3) == 'rec') typ=3 call snpenc(locpos(gene), locpos(trait), typ, work) else write(outstr,'(a)') & 'ERROR: Need to specify marker and locus to hold dummy encoding.' end if ! ! index for each proband within a family for a variable ! else if (keyword == 'cum' .and. red) then call gettrait(words(2), LOC_TRA, 0 , nloci, loc, lochash, loctyp, trait, 0) call gettrait(words(3), LOC_QUA, LOC_CAT, nloci, loc, lochash, loctyp, gene, 0) if (trait /= MISS .and. gene /= MISS) then call docum(locpos(trait), loctyp(trait), locpos(gene), work) else write(outstr,'(a)') & 'ERROR: Need to specify trait and locus to hold index value.' end if ! ! rank a variable ! else if ((keyword == 'ran' .or. keyword == 'blo') .and. red) then call gettrait(words(2), LOC_QUA, LOC_AFF, nloci, loc, lochash, loctyp, gene, 0) i=3 typ=1 trait=MISS do while (i <= narg) if (i == narg .and. words(i)(1:3) == 'fam') then typ=2 else call gettrait(words(i), LOC_QUA, 0, nloci, loc, lochash, loctyp, trait, 0) end if i=i+1 end do if (keyword == 'blo') typ=typ+2 if (trait == MISS) trait=gene if (gene /= MISS) then if (typ < 3) then write(outstr,'(/5a)') & 'Placing ranks of "', trim(loc(gene)), & '" in "', trim(loc(trait)), '".' else write(outstr,'(/5a)') & 'Placing Blom scores of "', trim(loc(gene)), & '" in "', trim(loc(trait)), '".' end if call dorank(locpos(trait), locpos(gene), typ, work) else write(outstr,'(a)') 'ERROR: Need to specify scored trait and result loci.' end if ! ! permute trait values ! else if (keyword == 'per') then trait=MISS call gettrait(words(2), LOC_TRA, 0, nloci, loc, lochash, loctyp, trait, 1) if (trait /= MISS) then write(outstr,'(/3a)') & 'Permuting values of "', trim(loc(trait)), '" within pedigrees.' call permdata(locpos(trait), work) else write(outstr,'(a)') 'ERROR: Need to specify trait to permute.' end if ! ! simulate pedigree, trait or marker data (unconditionally or conditional on one marker) ! else if (keyword == 'sim') then if (keyw2 == 'ped' .and. .not.red) then nped=100 if (ival(words(3))>0) nped=ival(words(3)) ngen=2 if (ival(words(4))>0) ngen=ival(words(4)) nminoff=ival(words(5)) nmaxoff=2 if (ival(words(6))>0) nmaxoff=ival(words(6)) if (plevel > -1) then write(outstr,'(/4(a,i0),a)') & 'Simulating ', nped, ' pedigrees of depth ', ngen, & ' generations with sibship size ', nminoff, ' to ', nmaxoff, '.' if (words(7) /= ' ') then write(outstr,'(3a)') & 'Prefixing pedigree ID with "', trim(words(7)), '".' end if end if if (pedfil /= ' ') then inquire(file=pedfil, exist=filexist) if (filexist) then write(outstr,'(3a)') & 'Appending to existing pedigree file "', trim(pedfil), '".' open(OSTR, file=pedfil, status='old', & position='append', iostat=ioerr) else open(OSTR, file=pedfil, iostat=ioerr, status='new') end if else inline_input=.true. call mktmpfil(OSTR, pedfil, wrkdir, ioerr) end if if (ioerr == 0) then call simdata(OSTR, nped, ngen, nminoff, nmaxoff, & trim(words(7)), numloc(TCLASS), nsimped) close(OSTR, status='keep') else write(outstr,'(a)') 'ERROR: Unable to create new pedigree file!' pedfil=' ' inline_input=.false. end if else if (words(2) == 'qtl' .and. narg > 3 .and. red) then trait=MISS gene=MISS h2=0.5D0 call gettrait(words(3), LOC_AFF, 0, nloci, loc, lochash, loctyp, trait, 1) call gettrait(words(4), LOC_CODOM, 0, nloci, loc, lochash, loctyp, gene, 1) if (trait /= MISS .and. gene /= MISS) then if (narg > 4) h2=fval(words(5)) call wrsimqtl(locpos(trait), locpos(gene), smlfreq, smlpen, h2, work, plevel) else write(outstr,'(a)') 'ERROR: Expected binary trait, marker [, h2].' end if else if ((words(2) == 'dro' .or. words(2) == 'drop') .and. narg > 2 .and. red) then call gettrait(words(3), LOC_CODOM, 0, nloci, loc, lochash, loctyp, gene, 1) if (gene /= MISS) then call wrdrop(locpos(gene), work, plevel) else write(outstr,'(a)') 'ERROR: Expected marker.' end if else if (red) then trait=MISS gene=MISS h2=0.5D0 typ=2 call gettrait(words(2), LOC_ANY, 0, nloci, loc, lochash, loctyp, trait, 1) if (trait /= MISS) then i=3 if (istrait(loctyp(trait))) then if (i <= narg .and. isreal(words(i))) then h2=fval(words(i)) if (h2 > 1.0D0) then h2=1.0D0 else if (h2 <= 0.0D0) then h2=0.0D0 end if i=i+1 end if typ=1 if (plevel > -1) then write(outstr,'(/3a,f5.3)', advance='no') & 'Simulating "', trim(words(2)), & '" as a trait of heritability ', h2 if (loctyp(trait) == LOC_AFF .and. prevalence /= MISS) then write(outstr,'(a,f5.3)', advance='no') & ', prevalence ', prevalence end if write(outstr,'(a)') '.' end if end if ! Does not allow cosegregating marker specification by numerical index if (.not.isreal(words(i))) then call gettrait(words(i), LOC_CODOM, 0, nloci, loc, lochash, loctyp, gene, 1) i=i+1 end if if (gene == MISS) then if (same_loctyp(loctyp(trait), LOC_CODOM)) then gene=trait typ=1 if (gene /= fixfreq) then call rdfreq(1, i, narg, words, allele_buffer) if (plevel > 0) then write(outstr,'(a)') & 'NOTE: Population allele frequencies specified as:' call wrfreq(outstr, loc(gene), group(gene), map(gene), & locnotes(gene), allele_buffer, 15) end if else if (plevel > 0) then write(outstr,'(a)') & 'NOTE: Population allele frequencies are prespecified as:' call wrfreq(outstr, fixmarker, group(fixfreq), map(fixfreq), & locnotes(fixfreq), fixfreq_buffer, 15) end if call copyfreq(fixfreq_buffer, allele_buffer) end if if (plevel > -1) then write(outstr,'(3a,i0,a)') & 'Simulating "', trim(words(2)), '" as a ', & allele_buffer%numal, '-allele marker.' end if end if else ! new values for unobserved genotypes -- wrsim/wrsimq relies on these call freq(locpos(gene), loctyp(gene), fndr, work, allele_buffer2) if (same_loctyp(loctyp(gene), LOC_CODOM)) then call newstart(locpos(gene), allele_buffer2, work, plevel) end if if (same_loctyp(loctyp(trait), LOC_CODOM)) then if (i > narg) then typ=3 write(outstr,'(5a)') & 'Simulating "', trim(words(2)), & '" as a perfectly informative marker linked to "', & trim(loc(gene)), '".' else call rdfreq(1, i, narg, words, allele_buffer) write(outstr,'(3a,i0,3a)') & 'Simulating "', trim(words(2)), '" as a ', & allele_buffer%numal, '-allele marker linked to "', & trim(words(3)), '".' end if else typ=2 write(outstr,'(3a)') 'QTL is completely linked to "', trim(loc(gene)),'".' end if end if if (isactdip(loctyp(trait))) then call wrsim(typ, locpos(trait), locpos(gene), & allele_buffer, allele_buffer2, work, plevel) else if (istrait(loctyp(trait))) then if (gene /= MISS) gene=locpos(gene) call wrsimq(typ, locpos(trait), loctyp(trait), prevalence, & h2, gene, allele_buffer, allele_buffer2, work, plevel) end if else write(outstr,'(a)') 'ERROR: Need to specify locus to simulate.' end if end if ! ! ID hash else if (keyword == 'has') then if (narg == 1) then call hashids(1, work, hashtab, 80, 1) else if (keyw2 == 'sho') then if (words(3)(1:3) == 'loc') then call hashprint(lochash, work, loc, plevel) else call hashprint(hashtab, work, loc, plevel) end if else if (keyw2 == 'del') then if (plevel > 0) then write(outstr,'(a)') 'Hash table deleted.' end if call cleanup_hash(hashtab) else if (words(2) == 'loc' .or. words(2) == 'locus') then if (.not.lochash%current) then if (narg == 2 .or. plevel > 0) then write(outstr,'(a)') 'Locus hash table updated.' end if call make_lochash(nloci, loc, lochash) end if if (narg > 2) then call find_hashtab(trim(words(3)(1:loc_width)), loc, lochash, iaddress) if (iaddress > 0) then write(outstr,'(a,i0,a,1x,a)') '(', iaddress,')', loc(iaddress) else write(outstr,'(a)') 'No match.' end if end if else if (keyw2 == 'siz') then call hashids(1, work, hashtab, ival(words(3)), 1) else if (keyw2 == 'id') then if (narg == 3) then if (.not.hashtab%current .or. hashtab%keytyp /= 2) then call hashids(2, work, hashtab, 80, plevel) end if call matchid(2, ' ', words(3), work, hashtab, i, 2) end if else if (keyw2 == 'fil' .or. narg == 2) then if (narg == 2) then call get_filnam(lin, narg, wrkfil) else call get_filnam(lin, 3, wrkfil) end if call open_port(wrkfil, port, 'r', ioerr) if (ioerr == 0) then i=0 j=0 if (narg == 5) then i=ival(words(4)) j=ival(words(5)) else if (narg == 4) then j=ival(words(4)) end if call findids(port, lin, i, j, hashtab, work, plevel) call close_port(port, ioerr) else write(outstr,'(/3a/)') & 'ERROR: Problem opening ID file "', trim(wrkfil), '".' end if else if (keyw2 == 'vcf') then call get_filnam(lin, 3, wrkfil) typ=5 if (words(4)(1:3) == 'ped') typ=typ+1 i=0 if (narg == 5) i=ival(words(5)) call readvcf(typ, .false., ' ', gt, thresh, i, wrkfil, numloc, & hashtab, work, red, plevel) else if (.not.hashtab%current .or. hashtab%keytyp /= 1) then call hashids(1, work, hashtab, 80, plevel) end if call matchid(1, words(2), words(3), work, hashtab, i, 2) end if ! hash copy else if (keyword == 'cop' .and. red) then if (narg >= 5) then typ=1 if (words(6)(1:3) == 'mer' .or. words(6)(1:3) == 'ins') typ=typ+1 call copydata(typ, words(2), words(3), words(4), words(5), & nloci, loc, loctyp, locpos, work, hashtab, plevel) else write(outstr,'(a)') & 'ERROR: Need to specify <from_ped> <from_id> <to_ped> <to_id>.' end if ! ! hash join ! merge bed|fim|probs|geno|dose|mach ! else if ((keyword == 'upd' .or. keyword == 'mer') .and. red) then if (words(2) == 'bed' .or. words(2) == 'pli' .or. & words(2) == 'plink') then typ=1 typ1=1 typ2=1 inputsep=' ' ktyp=HK_LOCNAM i=4 do while (i <= narg) if (words(i)(1:3) == 'joi') then typ=2 else if (words(i)(1:3) == 'com') then typ=3 else if (words(i)(1:3) == 'hum') then typ1=2 else if (words(i) == 'id') then typ2=2 else if (words(i) == 'sep' .and. i < narg) then inputsep=words(i+1)(1:1) i=i+1 else if (words(i) == 'pos' .or. words(i) == 'position') then ktyp=HK_MAPPOS end if i=i+1 end do call get_filnam(lin, 3, wrkfil) call extprefix(wrkfil,'.bed') call hashids(typ2, work, hashtab, 80, plevel) call mergebed(TWRK, typ, typ1, typ2, ktyp, wrkfil, hashtab, work, plevel) call make_lochash(nloci, loc, lochash) else if (words(2) == 'vcf') then addref=.false. qualstat=' ' typ=3 n=0 gt=0 thresh=MISS if (narg == 2) then call fchooser(wrkfil, gui, plevel) else call get_filnam(lin, 3, wrkfil) if (narg > 3) then i=4 do while (i <= narg) if (words(i)(1:3) == 'ped') then typ=4 else if (words(i)(1:3) == 'ref') then addref=.true. else if (words(i)(1:3) == 'qua') then if (i < narg) then i=i+1 qualstat=words(i) end if if (i < narg) then i=i+1 call docomp(i, words, gt, thresh) if (gt == 0) i=i-1 end if else if (isint(words(i))) then n=ival(words(i)) else write(outstr,'(3a)') & 'Unrecognized keyword: "', trim(words(i)), '".' end if i=i+1 end do end if end if call readvcf(typ, addref, qualstat, gt, thresh, n, wrkfil, numloc, & hashtab, work, red, plevel) else if (words(2) == 'fim') then typ=1 if (keyword == 'upd') typ=2 typ1=1 typ2=2 i=5 do while (i <= narg) if (words(i)(1:3) == 'hum') then typ1=2 else if (words(i) == 'ped_id') then typ2=1 end if i=i+1 end do call get_filnam(lin, 3, locfil) call get_filnam(lin, 4, wrkfil) call hashids(typ2, work, hashtab, 80, plevel) call mergefim(typ, locfil, wrkfil, typ1, typ2, hashtab, work, plevel) else if (words(2) == 'gen' .or. words(2) == 'geno' .or. & words(2) == 'genotypes') then if (narg == 2) then call fchooser(wrkfil, gui, plevel) else call get_filnam(lin, 3, wrkfil) end if gt=0 thresh=MISS skipline=1 typ=1 i=3 do i=i+1 if (i > narg) exit if (words(i)(1:3) == 'loc') then typ=2 end if if (words(i)(1:3) == 'ill') then typ=3 gt=COMP_GT thresh=0.6d0 end if if (words(i)(1:3) == 'csv') then typ=4 gt=COMP_GT thresh=0.6d0 end if if (words(i)(1:3) == 'qua') then if (i < narg) then i=i+1 call docomp(i, words, gt, thresh) if (gt == 0) i=i-1 end if end if if (words(i)(1:3) == 'ski') then i=i+1 if (i < narg) then skipline=ival(words(i)) end if end if end do call open_port(wrkfil, port, 'r', ioerr) if (ioerr == 0) then write(outstr,'(3a)') 'Merging genotypes from "', trim(wrkfil), '".' call readgeno(typ, port, gt, thresh, skipline, hashtab, work, plevel) call close_port(port, ioerr) else write(*,'(/3a/)') 'ERROR: Problem opening "', trim(wrkfil), '".' end if ! ! Read genotype probabilities file typ=1 Beagle; =2 Mach, Impute2 ! else if (words(2) == 'pro' .or. words(2) == 'probs' .or. & words(2) == 'probabilities') then call get_filnam(lin, 3, wrkfil) typ=1 trait=-1 locfil='' i=4 do while (i <= narg) if (words(i)(1:3) == 'mac' .or. words(i)(1:3) == 'imp') then typ=typ+1 else if (words(i) == 'id') then trait=-2 else if (words(i) == 'pedid') then trait=-1 else if (words(i)(1:3) == 'fil') then if (i < narg) then call get_filnam(lin, i+1, locfil) else write(*,'(/a/)') 'ERROR: Expected a file name.' end if i=i+1 else if (words(i) == 'key') then if (i < narg) then call gettrait(words(i+1), LOC_QUA, LOC_CAT, nloci, & loc, lochash, loctyp, trait, 0) if (trait == MISS) then write(*,'(/3a/)') 'ERROR: "', trim(words(narg)), & '" is not a suitable merge key.' else trait=locpos(trait) end if else write(*,'(/a/)') 'ERROR: Expected a trait containing merge key.' end if i=i+1 end if i=i+1 end do call open_port(wrkfil, port, 'r', ioerr) if (ioerr == 0) then call reclen(port, lin, i, -1, .false.) call readprobs(port, typ, trait, locfil, i, hashtab, work, plevel) call close_port(port, ioerr) else write(*,'(/3a/)') 'ERROR: Problem opening "', trim(wrkfil), '".' end if ! PLINK genotype dose else if (words(2) == 'dos' .or. words(2) == 'dose' .or. words(2) == 'dosage') then call get_filnam(lin, 3, wrkfil) thresh=0.5d0 if (isreal(words(4))) then thresh=fval(words(4)) if (thresh > 1.0d0 .or. thresh < 0.0d0) thresh=0.5d0 end if call open_port(wrkfil, port, 'r', ioerr) if (ioerr == 0) then call reclen(port, lin, i, -1, .false.) call rdplinkdose(port, thresh, i, hashtab, work, plevel) call close_port(port, ioerr) else write(*,'(/3a/)') 'ERROR: Problem opening "', trim(wrkfil), '".' end if ! MACH dataset else if (words(2)(1:3) == 'mac') then thresh=0.5d0 if (isreal(words(narg))) then thresh=fval(words(narg)) if (thresh > 1.0d0 .or. thresh < 0.0d0) thresh=0.5d0 narg=narg-1 end if call get_filnam(lin, 3, locfil) if (narg == 3) then wrkfil=trim(locfil) // '.ped' locfil=trim(locfil) // '.dat' else call get_filnam(lin, 4, wrkfil) end if call readmach(locfil, wrkfil, thresh, hashtab, work, plevel) else if (words(2) == 'loc' .or. words(2) == 'loci') then call gettrait(words(3), LOC_CODOM, LOC_XLIN, & nloci, loc, lochash, loctyp, trait, 0) call gettrait(words(4), LOC_CODOM, LOC_XLIN, & nloci, loc, lochash, loctyp, gene, 0) if (trait /= MISS .and. gene /= MISS) then thresh=0.005d0 if (narg == 5) thresh=fval(words(5)) call mergeloci(trait, gene, thresh, nloci, loc, loctyp, locpos, & locnotes, group, map, work, plevel) else write(outstr,'(/a/)') & 'ERROR: Need to specify target and donor marker loci!' end if ! ! merge phenotype or genotype data from rectangular data headed by column names ! one may specify a subset of names else typ=1 if (keyword == 'mer') typ=2 if (narg > 2 .and. words(narg)(1:3) == 'com') then typ=3 narg=narg-1 end if if (narg > 3) then if (words(narg-1) == 'sep') then if (words(narg) == 'tab') then inputsep=achar(9) else inputsep=words(narg)(1:1) end if narg=narg-2 end if end if nord=0 if (narg > 2) then call loadnam(2, narg-1, words, nloci, loc, lochash, loctyp, group, map, & locstat, wloc, nord, locord, LOC_ANY, 1) else if (narg == 2) then nord=nloci wloc(1:nord)=1 end if if (nord /= 0) then call get_filnam(lin, narg, wrkfil) if (wrkfil == 'inline' .or. wrkfil == 'inl') then call mktmpfil(OSTR, wrkfil, wrkdir, ioerr) if (ioerr == 0) then call wrinline(nlin, OSTR) close(OSTR,STATUS='keep') inline_input=.true. else write(*,'(/3a/)') 'ERROR: Could not create temporary data file!' cycle end if end if call open_port(wrkfil, port, 'r', ioerr) if (ioerr == 0) then call reclen(port, lin, i, -1, .false.) call replacedata(port, typ, inputsep, nloci, loc, lochash, loctyp, & locpos, wloc, hashtab, work, i, plevel) call close_port(port, ioerr) if (inline_input) then call delfile(wrkfil, plevel-2) inline_input=.false. end if else write(*,'(/3a/)') 'ERROR: Problem opening "', trim(wrkfil), '".' end if else write(outstr,'(a)') 'ERROR: Need to specify update file +/- active loci to be updated.' end if end if ! ! selection of pedigrees on name of pedigree or of a member ! else if (keyword == 'sel' .and. red .and. & (keyw2 == 'ped' .or. keyw2 == 'id')) then i=3 typ=1 do j=3, 4 if (words(j) == 'not') then i=i+1 typ=3-typ else if (words(j) == 'in') then i=i+1 end if end do if (keyw2 == 'id') typ=typ+2 if (words(narg-1) == 'fil' .or. words(narg-1) == 'file') then call get_filnam(lin, narg, wrkfil) call open_port(wrkfil, port, 'r', ioerr) if (ioerr == 0) then call selped_fil(typ, port, hashtab, work, plevel) call close_port(port, ioerr) else write(*,'(/3a/)') & 'ERROR: Problem opening pedigree ID file "', trim(wrkfil), '".' end if else call selped(typ, i, narg, words, work, plevel) end if ! ! print data for selected pedigree or individual ! else if (keyword == 'pri' .and. red .and. keyw2 == 'ped') then if (narg == 2) then call listpeds(2, work, narg, words) else i=narg+2 nmark=0 if ((words(narg-1) == 'nea' .or. words(narg-1) == 'nearest') .and. & isint(words(narg))) then nmark=ival(words(narg)) narg=narg-2 end if do j=3, narg if (words(j) == 'id') then i=j+1 end if end do call showdata(3, i, narg, words, nmark, nloci, loc, loctyp, locpos, & locnotes, work, pedmask, nwid, ndec, ncatwid, sexcode, misval, & show_cat, tabsep, allsep, pstyle, plevel) end if ! ! selection of pedigrees on logical expression ! eg given trait value or pedigree size ! else if (keyword == 'sel' .and. red) then call args(lin, narg, words, ' ', SEP_WH_RES) if ((keyw2 == 'con' .or. keyw2 == 'exa') .and. & words(4)(1:3) == 'whe') then typ=4 nprob=ival(words(3)) if (nprob == 0 .or. keyw2 == 'exa') typ=typ+1 i=5 else typ=3 nprob=1 i=2 if (keyw2 == 'whe') i=i+1 end if call preparser(i, narg, words) call typwords(i, narg, words, nloci, loc, lochash, loctyp, wtyp, wtag, expr, actn) if (actn == 0) then write(outstr,'(/a/7x,a)') & 'ERROR: could not parse logical expression.', & 'Perhaps "select pedigree <nam>" is needed.' else call doselect(typ, nprob, i, narg, words, & nloci, loc, lochash, loctyp, locpos, wtyp, wtag, expr, & work, nobs, plevel) end if else if (keyword == 'uns' .and. red) then typ=0 if (narg > 1) typ=ival(words(2)) call unsel(work, typ, plevel) ! pack (ie permanently delete) inactive loci and pedigrees else if (keyword == 'pac') then if (.not.red) then typ=2 call packloci(nloci, loc, loctyp, locpos, group, map, locnotes, numloc, plevel) else typ=3 if (keyw2 == 'ped') then typ=1 else if (keyw2 == 'loc') then typ=2 end if call packer(typ, wrk, wrk2, nloci, loc, loctyp, locpos, group, map, & locnotes, numloc, work, plevel) end if if (typ /= 2) hashtab%current=.false. if (typ /= 1) then call make_lochash(nloci, loc, lochash) if (twintrait /= ' ') then call gettrait(twintrait, LOC_ANY, 0, nloci, loc, lochash, loctyp, twinning, 0) if (twinning == MISS) then twintype=MISS twintrait=' ' write(outstr,'(a)') & 'NOTE: Declared twinning indicator was permanently deleted.' end if end if end if ! count pedigrees, sibships on simple expression else if ((keyword == 'cou' .or. keyword == 'pri') .and. red) then typ=1 if (keyword == 'pri') typ=typ+1 if (narg == 2) then call gettrait(words(2), LOC_CODOM, LOC_XLIN, nloci, loc, lochash, loctyp, trait, -1) if (trait /= MISS) then lin=keyword // ' istyp ' // trim(loc(trait)) end if else if (narg == 1) then lin=keyword // ' 1' end if call args(lin, narg, words, ' ', SEP_WH_RES) i=2 if (keyw2 == 'whe') i=i+1 call preparser(i, narg, words) call typwords(i, narg, words, nloci, loc, lochash, loctyp, wtyp, wtag, expr, actn) if (actn == 0) then write(outstr,'(/a)') 'ERROR: could not parse condition.' else call docount(typ, i, narg, words, & nloci, loc, lochash, loctyp, locpos, locnotes, & wtyp, wtag, expr, & work, pedmask, nwid, ncatwid, ndec, sexcode, misval, & tabsep, allsep, show_cat, pstyle, plevel) end if ! ! get summary of trait values of a given class of relatives of ego ! *or* members of the same class ! else if ((keyword == 'get') .and. red) then typ=1 if (keyw2 == 'gro') then typ=2 call gettrait(words(3), LOC_TRA, 0, nloci, loc, lochash, loctyp, prob, 1) end if call gettrait(words(3+typ), LOC_TRA, 0, nloci, loc, lochash, loctyp, trait, 1) if (trait /= MISS .and. (typ == 1 .or. (typ == 2 .and. prob /= MISS))) then gene=MISS if (narg > (3+typ)) then call gettrait(words(narg), LOC_TRA, 0, nloci, loc, lochash, loctyp, gene, 1) end if if (typ == 1) then write(outstr, '(/5a)') & 'Trait values in relatives for "', trim(loc(trait)), & '" summarized as "', trim(words(3)),'".' call getrelval(keyw2, words(3)(1:3), loc(trait), loctyp(trait), & locpos(trait), gene, work, plevel) else write(outstr, '(/7a)') & 'Trait values for "', trim(loc(trait)), & '" summarized as "', trim(words(4)),'" for each level of "', & trim(loc(prob)), '".' call getclassval(prob, trait, gene, words(4)(1:3), & nloci, loc, locpos, loctyp, locnotes, work, plevel) end if if (gene /= MISS) then write(outstr, '(3a)') & 'Storing summary statistic in variable "', trim(loc(gene)),'".' gene=locpos(gene) end if else write(outstr,'(a)') 'ERROR: Need to specify relationship, statistic, trait.' end if ! Plot a histogram else if (keyword == 'his' .and. red) then call gettrait(words(2), LOC_ANY, 0, nloci, loc, lochash, loctyp, trait, 1) if (trait /= MISS) then histcat=21 outfil='sib-pair.eps' if (narg > 2) then if (isint(words(3))) then histcat=ival(words(3)) if (narg > 3) then call get_filnam(lin, narg, outfil) end if else call get_filnam(lin, narg, outfil) end if end if call histogram(trait, nloci, loc, locpos, loctyp, histcat, work, & nwid, ndec, outfil, 1) end if ! Test mixture of distributions for quantitative trait else if ((keyword == 'mix') .and. red) then call gettrait(words(2), LOC_QUA, LOC_CAT, nloci, loc, lochash, loctyp, trait, 1) if (trait /= MISS) then histcat=21 nmix=ival(words(3)) if (nmix < 1) then nmix=2 end if if (words(4)(1:3) == 'nor') then typ=1 else if (words(4)(1:3) == 'poo') then typ=2 else if (words(4)(1:3) == 'exp') then typ=3 else if (words(4)(1:3) == 'poi') then typ=4 else typ=ival(words(4)) end if if (typ < 1 .or. typ > 4) typ=1 whlik=3-whlik mcall(whlik)=trim(lin) call domix(loc(trait), locpos(trait), nmix, typ, histcat, outfil, work, & mlik(whlik), mpar(whlik), nwid, ndec, plevel) else write(outstr,'(a)') 'ERROR: Need to specify quantitative trait.' end if ! ! quantile normalization of multiple traits eg expression levels ! else if ((keyword == 'qua') .and. red) then call loadnam(2, narg, words, nloci, loc, lochash, loctyp, & group, map, locstat, wloc, nord, locord, LOC_ANY, 1) call quantnorm(nord, locord, loc, locpos, loctyp, work, plevel) ! ! Filliben correlation for multiple traits eg expression levels ! else if ((keyword == 'nor') .and. red) then call loadnam(2, narg, words, nloci, loc, lochash, loctyp, & group, map, locstat, wloc, nord, locord, LOC_ANY, 1) histcat=21 outfil='sib-pair.eps' call setup_stat('Filliben correlation', typ=2) j=0 do i=1, nord trait=locord(i) if (isqtrait(loctyp(trait)) .and. isactive(loctyp(trait))) then call histogram(trait, nloci, loc, locpos, loctyp, histcat, work, & nwid, ndec, outfil, plevel-2) locstat(trait)=statval(1) j=j+1 end if end do write(outstr,'(/a,i0,a)') & 'Calculated Filliben correlations for ', j, ' traits.' ! Means and correlations for traits else if ((keyword == 'mea' .or. keyword == 'cor' .or. keyword == 'cov') .and. red) then j=2 k=0 if (words(2) == 'distance' .or. words(2) == 'dis') then j=3 do i=j, narg if (words(i) == 'versus') k=i-j end do end if call loadnam(j, narg, words, nloci, loc, lochash, loctyp, & group, map, locstat, wloc, nord, locord, LOC_ANY, 1, division=k) if (j == 3) then call dodist(k, nord, locord, nloci, loc, loctyp, locpos, work, plevel) else typ=1 if (keyword == 'cov') typ=typ+1 call docov(typ, nord, locord, nloci, loc, loctyp, locpos, work) end if ! Principal components of a covariance matrix else if (keyword == 'pca') then if (narg == 2 .and. isint(words(2))) then call doeigen(ival(words(2))) else if (words(2) == 'ibs') then call gettrait(words(3), LOC_QUA, 0, nloci, loc, lochash, loctyp, trait, 1) if (trait /= MISS) then call loadnam(3, narg, words, nloci, loc, lochash, loctyp, & group, map, locstat, wloc, nord, locord, LOC_QUA, 1) call ibspca(1, nloci, loc, loctyp, locpos, & nord, locord, work, plevel) else write(outstr,'(a/6x,a)') & 'ERROR: Need to specify at least one quantitative variable', & 'where the scores can be written.' end if else call loadnam(2, narg, words, nloci, loc, lochash, loctyp, & group, map, locstat, wloc, nord, locord, LOC_ANY, 1) call docov(3, nord, locord, nloci, loc, loctyp, locpos, work) end if ! Classical MDS on ibs else if (keyword == 'mds') then call gettrait(words(2), LOC_QUA, 0, nloci, loc, lochash, loctyp, trait, 1) if (trait /= MISS) then call loadnam(2, narg, words, nloci, loc, lochash, loctyp, & group, map, locstat, wloc, nord, locord, LOC_QUA, 1) call ibspca(2, nloci, loc, loctyp, locpos, & nord, locord, work, plevel) else write(outstr,'(a/6x,a)') & 'ERROR: Need to specify at least one quantitative variable', & 'where the coordinates can be written.' end if else if (keyword == 'cho') then if (narg == 2 .and. isint(words(2))) then call dochol(ival(words(2))) end if ! Genotype-based sex or family-based age imputation else if (keyword == 'imp' .and. narg==2 .and. red) then if (words(2) == 'sex') then call testsex(2, sexcrit, sexmarker, heterror, & nloci, loc, lochash, loctyp, locpos, & work, allele_buffer, inconsist, plevel) call imputesex(2, work, plevel) else call gettrait(words(2), LOC_QUA, 0, nloci, loc, lochash, loctyp, trait, 1) if (trait /= MISS) then call famimp(loc(trait), locpos(trait), work, plevel) else write(outstr,'(a)') 'ERROR: Need to specify quantitative trait for imputation.' end if end if ! Multiple linear or logistic regression of trait else if ((keyword == 'reg' .or. keyword == 'imp' .or. keyword == 'clr' .or. & keyword == 'pre' .or. keyword == 'res') .and. narg > 3 .and. red) then nf=narg censor=MISS cltyp=-2 off=MISS nrepl=1 fixshape=.false. mcp=.false. shap=1.0d0 typ=0 if (keyword == 'res') then typ=1 else if (keyword == 'imp') then typ=2 else if (keyword == 'pre') then typ=3 end if ! any flags at end of line reading=.true. do while (reading) if (words(nf) == 'complete') then typ=typ+10 nf=nf-1 else if (words(nf-1) == 'rep' .or. words(nf-1) == 'replicates') then nrepl=ival(words(nf)) nf=nf-2 else if (words(nf) == 'sim' .or. words(nf) == 'simulate') then mcp=.true. nf=nf-1 else if (words(nf-1) == 'shape') then shap=fval(words(nf)) nf=nf-2 else if (words(nf) == 'poisson') then typ=GLM_POISS+2 nf=nf-1 else if (words(nf-1) == 'weibull' .or. words(nf-1) == 'fixedweibull') then typ=GLM_WEIB+2 call gettrait(words(nf), LOC_AFF, 0, nloci, loc, lochash, loctyp, censor, 0) fixshape=(words(nf-1) == 'fixedweibull') nf=nf-2 else if (words(nf) == 'weibull' .or. words(nf) == 'fixedweibull') then typ=GLM_WEIB+2 fixshape=(words(nf) == 'fixedweibull') nf=nf-1 else if (words(nf-1) == 'exponential') then typ=GLM_EXPON+2 call gettrait(words(nf), LOC_AFF, 0, nloci, loc, lochash, loctyp, censor, 0) nf=nf-2 else if (words(nf) == 'exponential') then typ=GLM_EXPON+2 nf=nf-1 else if (words(nf-1) == 'evd') then typ=GLM_EVD+2 call gettrait(words(nf), LOC_AFF, 0, nloci, loc, lochash, loctyp, censor, 0) nf=nf-2 else if (words(nf-1) == 'offset') then call gettrait(words(nf), LOC_QUA, 0, nloci, loc, lochash, loctyp, off, 0) nf=nf-2 else if (keyword == 'clr' .and. words(nf)(1:3) == 'ped') then cltyp=-1 nf=nf-1 else if (keyword == 'clr' .and. words(nf-1) == 'stratum') then call gettrait(words(nf), LOC_ANY, 0, nloci, loc, lochash, loctyp, gene, 0) if (gene /= MISS) cltyp=gene nf=nf-2 else reading=.false. end if end do ! first read the x variables call loadnam(4, nf, words, nloci, loc, lochash, loctyp, group, map, & locstat, wloc, nord, locord, LOC_ANY, 1) ! then read the y variable which is added onto the end of the list call gettrait(words(2), LOC_QUA, LOC_AFF, nloci, loc, lochash, loctyp, trait, 0) if (trait /= MISS) then ! mark first marker for full allelic encoding ! if marker allele frequencies prespecified, do not reestimate gene=findml(nord, locord, loctyp) if (gene /= MISS) then call freq(locpos(gene), loctyp(gene), fndr, work, allele_buffer) if (nrepl > 1 .or. useimp) then if (fixfreq /= MISS) then call gettrait(fixmarker, LOC_CODOM, 0, nloci, loc, lochash, loctyp, fixfreq, 0) end if if (gene /= fixfreq) then call copyfreq(allele_buffer, mcmc_buffer) else write(outstr,'(a)') & 'NOTE: Population allele frequencies are prespecified as:' call wrfreq(outstr, fixmarker, group(fixfreq), map(fixfreq), & locnotes(fixfreq), fixfreq_buffer, 15) call copyfreq(fixfreq_buffer, mcmc_buffer) end if end if end if if (loctyp(trait) == LOC_AFF) then typ=4 if (keyword == 'clr') typ=1000 end if nord=nord+1 locord(nord)=trait if (typ == 0) then call regress(typ, nord, locord, nloci, loc, loctyp, locpos, & gene, genemod, allele_buffer, work, & mlik(whlik), mpar(whlik), pval, max(0, plevel)) else if (typ == 1000) then whlik=3-whlik mcall(whlik)=trim(lin) call clreg(1, cltyp, nord, locord, nloci, loc, loctyp, locpos, & gene, genemod, allele_buffer, useimp, work, & mlik(whlik), mpar(whlik), statval, pval, plevel) else if (typ >= 4 .and. typ <= 8) then typ=typ-2 whlik=3-whlik mcall(whlik)=trim(lin) ! ! if imputed genotypes to be used in association analysis, reimpute each time ! via MCMC chain and accumulate test results over multiple replicates ! if ((nrepl > 1 .or. useimp) .and. gene /= MISS) then loval=1.0d0 hival=0.0d0 meanstat=0.0d0 varstat=0.0d0 meanp=0.0d0 meanlik=0.0d0 withinvar=0.0d0 do n=1, nrepl call newstart(locpos(gene), mcmc_buffer, work, plevel) call binreg(typ, nord, locord, nloci, loc, loctyp, locpos, & off, censor, gene, genemod, allele_buffer, & mcp, .true., fixshape, iter, mincnt, work, shap, & mlik(whlik), mpar(whlik), statval, pval, plevel) if (n == 1) baslik=mlik(whlik) meanlik=meanlik+exp(baslik-mlik(whlik)) call moment(n, statval(1), meanstat, varstat) withinvar=withinvar+statval(2) meanp=meanp+pval if (irupt /= 0) exit end do n=min(n, nrepl) if (plevel >= 0) then write(outstr,'(/5a//a,i6)') & 'Multiple imputation GLM association analysis: "', & trim(loc(trait)), '" v. "', trim(loc(gene)), '"', & 'Number of replicates =', n end if mlik(whlik)=baslik+log(meanlik)-log(dble(n)) if (n > 1) then meanp=meanp/dble(n) varstat=varstat/dble(n-1) withinvar=withinvar/dble(n) df=int(dble(n-1)*(1.0d0+withinvar/(varstat*(1.0d0+1.0d0/dble(n))))**2) varstat=(1.0d0+1.0d0/dble(n))*varstat + withinvar if (plevel > 0) then write(outstr,'(3(/a,g12.4)/a,i0)') & 'Between-repl variance =', varstat, & 'Within-repl variance =', withinvar, & 'MI Wald test statistic =', abs(meanstat)/sqrt(varstat), & 't-test df =', df end if varstat=sqrt(varstat) pval=tp(abs(meanstat)/varstat, df) else varstat=sqrt(withinvar) pval=zp(abs(meanstat)/varstat) meanp=pval end if if (plevel >= 0) then write(outstr,'(/a,f9.2/a,i6/a,f11.4,a,f9.4,a,2(/a,5x,a6))') & 'Overall Model Deviance =', mlik(whlik), & 'No. of Pars =', mpar(whlik), & 'Assoc Parameter (SE) =', meanstat, ' (', varstat, ')', & 'MI Wald test P-value =', pstring(pval), & 'Averaged Emp. P-value =', pstring(meanp) if (allele_buffer%numal > 2 .or. plevel > 0) then call wrall(allele_buffer%allele_names(2), keyw2) call wrall(allele_buffer%allele_names(1), keyword) write(outstr,'(/5a)') & 'NOTE: Association parameter estimate refers to allele "', & trim(adjustl(keyw2)), '" v. allele "', trim(adjustl(keyword)),'".' end if else write(outstr,'(2(a14,1x),g9.4,1x,f6.1,i4,1x,a6,i6,1x,a)') & loc(trait), loc(gene), meanstat, mlik(whlik), mpar(whlik), & pstring(meanp), n, 'GLM' end if else call binreg(typ, nord, locord, nloci, loc, loctyp, locpos, off, & censor, gene, genemod, allele_buffer, & mcp, useimp, fixshape, iter, mincnt, work, shap, & mlik(whlik), mpar(whlik), statval, pval, plevel) end if else call regress(typ, nord, locord, nloci, loc, loctyp, locpos, & gene, genemod, allele_buffer, work, & mlik(whlik), mpar(whlik), pval, plevel) end if else write(outstr,'(a)') 'ERROR: Need to specify regression y and x variables.' end if ! Scatterplot of two variables else if (keyword == 'plo' .and. red) then typ=1 call gettrait(words(2), LOC_QUA, LOC_AFF, nloci, loc, lochash, loctyp, trait, 0) call gettrait(words(3), LOC_QUA, 0, nloci, loc, lochash, loctyp, gene, 0) call gettrait(words(4), LOC_TRA, 0, nloci, loc, lochash, loctyp, censor, -1) if (trait /= MISS .and. gene /= MISS) then if (loctyp(trait) == LOC_AFF) typ=typ+1 outfil='sib-pair.eps' i=4 if (censor /= MISS) i=i+1 if (narg == i) then call get_filnam(lin, i, outfil) end if if (plevel > 0) then write(outstr,'(7a)') & 'Creating Postscript file "', trim(outfil), & '": plot of "', trim(words(2)), & '" v. "', trim(words(3)), '".' if (censor /= MISS) then write(outstr,'(3a)') & 'Symbol style represents "', trim(words(4)), '":' if (loctyp(censor) == LOC_AFF) then write(outstr,'(a/a)') & ' open circle = no', & ' closed circle = yes' else write(outstr,'(a/a)') & ' circle=1, disc=2, square=3 triup=4 plus=5 ', & ' diamond=6 cross=7 pentagon=8 tridown=9 point=10' end if end if end if if (censor /= MISS) then words(4)=loc(censor) censor=locpos(censor) end if call doplot(outfil, typ, locpos(trait), locpos(gene), & censor, loc(trait), loc(gene), words(4), pedfil, work) else write(outstr,'(a)') 'ERROR: Need to specify two appropriate traits.' end if ! cross-tabulation else if (keyword == 'tab' .or. keyword == 'kru') then if (.not.red) cycle typ=1 xtab_ordering=1 xtab_missing=DROPX xtab_sample_weight=MISS if (keyword == 'kru' .and. narg >= 3) then call gettrait(words(2), LOC_TRA, 0, nloci, loc, lochash, loctyp, trait, 0) call gettrait(words(3), LOC_ANY, 0, nloci, loc, lochash, loctyp, gene, 0) if (trait /= MISS .and. gene /= MISS) then typ=2 call loadnam(3, narg, words, nloci, loc, lochash, loctyp, group, map, & locstat, wloc, nord, locord, LOC_ANY, 1) nord=nord+1 locord(nord)=trait call xtab(typ, xtab_ordering, xtab_missing, xtab_sample_weight, nord, locord, & nloci, loc, locpos, loctyp, locnotes, & work, iter, nwid, ndec, pval, plevel) else write(outstr,'(/a)') 'ERROR: quantitative trait or covariate misspecified.' end if else if (keyw2 == 'ped' .and. narg == 3) then call gettrait(words(3), LOC_ANY, 0, nloci, loc, lochash, loctyp, trait, 0) if (trait /= MISS) then write(outstr, '(3a)') 'Pedigree versus "', trim(loc(trait)), '":' if (loctyp(trait) == LOC_AFF) then call tarone(locpos(trait), work, plevel) else call pedtab(trait, nloci, loc, loctyp, locpos, locnotes, & work, nwid, ndec, plevel) end if else write(outstr,'(/a)') 'ERROR: quantitative trait or covariate misspecified.' end if else if (words(2) == 'allelic') then call loadnam(3, narg, words, nloci, loc, lochash, loctyp, group, map, & locstat, wloc, nord, locord, LOC_ANY, 1) call addtmpvar('DOSE', work, censor, ifail) call blutab(nord, locord, locpos(censor), nloci, loc, locpos, loctyp, locnotes, & work, iter, nwid, ndec, pval, plevel) else if (narg > 1) then i=2 reading=.true. do while (reading) if (words(i) == 'showmiss' .or. words(i) == 'showmissing') then xtab_missing=SHOWX i=i+1 else if (words(i) == 'sampleweight') then call gettrait(words(i+1), LOC_TRA, 0, nloci, loc, lochash, loctyp, & xtab_sample_weight, 0) if (xtab_sample_weight == MISS) then write(outstr,'(a)') & 'ERROR: Expected name of the sample weight variable.' end if i=i+2 else if (words(i) == 'polychoric') then typ=3 i=i+1 else if (words(i) == 'totals') then typ=4 i=i+1 else if (words(i) == 'ordered') then xtab_ordering=2 i=i+1 else reading=.false. end if end do call loadnam(i, narg, words, nloci, loc, lochash, loctyp, group, map, & locstat, wloc, nord, locord, LOC_ANY, 1) if (nord > 0) then call xtab(typ, xtab_ordering, xtab_missing, xtab_sample_weight, & nord, locord, nloci, loc, locpos, loctyp, locnotes, & work, iter, nwid, ndec, pval, plevel) end if else nmark=1 write(outstr,*) do i=1, nloci if (isactive(loctyp(i))) then wloc(1)=i call xtab(typ, xtab_ordering, xtab_missing, xtab_sample_weight, & nmark, wloc, nloci, loc, locpos, loctyp, locnotes, & work, iter, nwid, ndec, pval, plevel) end if end do end if else if (keyword == 'zzz') then if (narg == 1) then write(outstr,'(a)') 'zzz tests formula expansion eg: zzz (a+b)^2' else if (words(2)(1:5) == 'token') then call open_port(words(3), port, 'r', ioerr) if (ioerr == 0) then i=1 j=0 k=-1 n=0 do call readtoken(port, words(1), ioerr) j=j+1 words(2)=words(1) if (ioerr == -2) then if (j /= k) then write(*,*) 'L ', i, ' Nfields ', j, ': ', trim(words(1)) end if i=i+1 n=n+j k=j j=0 end if if (ioerr /= 0 .and. ioerr /= -2) exit end do call close_port(port, ioerr) write(*,*) 'Number of lines =', i write(*,*) 'Total number of words =', n else write(outstr,'(3a)') 'Could not open file "', trim(words(3)), '".' end if else if (words(2) == 'tbi') then if (is_strict_int(words(3))) then i=ival(words(3)) j=i if (narg == 4) j=ival(words(4)) write(*,*) i, j, reg2bin(i, j) else call gettrait(words(3), LOC_CODOM, LOC_XLIN, nloci, loc, lochash, loctyp, gene, 0) if (gene /= MISS) then i=tobp(map(gene)) j=i write(*,*) trim(words(3)), ': ', i, reg2bin(i, j) else write(outstr,'(3a)') 'Could not find marker "', trim(words(3)), '".' end if end if #if defined(GFORTRAN) ! quad precision special mathematical functions else if (words(2) == 'pnorm') then write(*,*) trim(words(3)), ' ', & erfc(real(fval(words(3)), 16)/sqrt(2.0_16))/2.0_16, & mizawa_zp(fval(words(3))) else if (words(2) == 'erf') then write(*,*) trim(words(3)), ' ', erf(real(fval(words(3)), 16)) else if (words(2) == 'erfc') then write(*,*) trim(words(3)), ' ', erfc(real(fval(words(3)), 16)) else if (words(2) == 'gamma') then write(*,*) trim(words(3)), ' ', gamma(real(fval(words(3)), 16)) else if (words(2) == 'log_gamma') then write(*,*) trim(words(3)), ' ', log_gamma(real(fval(words(3)), 16)) #endif else if (words(2) == 'dgamma') then write(*,*) dgamma(fval(words(3)), fval(words(4)), fval(words(5))) else if (words(2) == 'scmfun') then whlik=3-whlik mcall(whlik)=lin(4:len_trim(lin)) do i=4, narg pars(i-3)=fval(words(i)) end do mlik(whlik)=scmfun(trim(words(3)), narg-3, pars) write(*,*) words(3), ' ', mlik(whlik) else i=2 call test_form(i, narg, words, nloci, loc, lochash) end if ! log linear model else if (keyword == 'llm' .and. red) then whlik=3-whlik mcall(whlik)=trim(lin) call args(lin, narg, words, ' ', SEP_WH_RES) call fitloglin(2, narg, words, nloci, loc, lochash, loctyp, locpos, & locnotes, work, mlik(whlik), mpar(whlik), pval, nwid, & ndec, plevel) ! pedigree listing else if (keyword == 'gen' .and. red) then typ=1 call gettrait(words(2), LOC_QUA, LOC_CAT, nloci, loc, lochash, loctyp, trait, 1) write(outstr,'(/a/a/a)') & '------------------------------------------------', & 'Summary of structure of pedigrees', & '------------------------------------------------' if (trait /= MISS) then write(outstr,'(3a/)') & 'NOTE: Writing generation number to "', trim(loc(trait)), '".' if (words(3)(1:3) == 'rev') typ=typ+1 trait=locpos(trait) call dogen(work, trait, typ, plevel) else call dogen(work, trait, typ, plevel) end if ! list immediate relatives else if (keyword == 'rel' .and. red) then typ=MISS write(outstr,'(/a/4a/a)') & '------------------------------------------------', & 'Relatives of index ', trim(words(2)), '--', trim(words(3)), & '------------------------------------------------' if (words(4) == 'kin' .or. words(4) == 'kinship') then typ=1000 write(outstr,'(a/)') & 'NOTE: Showing empirical kinship.' else call gettrait(words(4), LOC_ANY, 0, nloci, loc, lochash, loctyp, trait, 1) if (trait /= MISS) then write(outstr,'(3a/)') & 'NOTE: Showing "', trim(loc(trait)), '".' typ=loctyp(trait) trait=locpos(trait) end if end if call relations(words(2)(1:ped_width), words(3)(1:id_width), & work, trait, typ, plevel) ! HWE chi-squares else if (keyword == 'hwe') then i=0 if (isint(words(2))) i=ival(words(2)) if (narg == 2 .and. i > 0) then call hwep(i) else if (red) then i=2 assfnd=.false. if (keyw2 == 'fou') then i=3 assfnd=.true. end if call loadnam(i, narg, words, nloci, loc, lochash, loctyp, group, map, & locstat, wloc, nord, locord, LOC_ANY, 1) write(outstr,'(/a/a/a)') & '--------------------------------------------------', & 'Hardy-Weinberg equilibrium for marker loci', & '--------------------------------------------------' if (assfnd) then write(outstr,'(a/)') 'NOTE: Analysis restricted to founders only.' end if if (plevel == -1 .or. plevel == 0) then write(outstr,'(/a/a)') & 'Marker Typed Genos Chi-square Asy P Emp P Iters', & '-------------------- ------ ------ ---------- ------ ------ ------' end if call setup_stat(lin) do i=1, nord j=locord(i) if (isactdip(loctyp(j)) .and. irupt == 0) then call dohwe(loc(j), locpos(j), loctyp(j), iter, mincnt, assfnd, & norder, work, pval, 1, plevel) locstat(j)=pval if (plevel > 0) then call freq(locpos(j), loctyp(j), fndr, work, allele_buffer) if (.not.allele_buffer%xlinkd) then call domar(locpos(j), work, allele_buffer, plevel) end if call margen(locpos(j), work, allele_buffer, iter, plevel) end if end if end do else write(outstr,'(a)') 'ERROR: Need number or dataset read in.' end if ! LD chi-squares else if (keyword == 'dis' .or. keyword == 'ld') then if ((narg == 2 .or. narg == 3) .and. isint(words(2))) then numal=ival(words(2)) numal2=numal if (narg == 3) numal2=ival(words(3)) if (numal > 1 .and. numal2 > 1) then call ldp(numal, numal2, plevel) else write(outstr,'(a)') 'ERROR: Need both loci polymorphic.' end if else if (red) then write(outstr,'(/a/a/a/)') & '---------------------------------------------------', & 'Inter-marker allelic association analysis', & '---------------------------------------------------' typ=3 sumtyp=0 if (narg == 2 .and. keyw2 == 'all') then typ=typ+1 else if (narg == 2 .and. keyw2 == 'r2') then sumtyp=1 typ=11 else if (narg == 2 .and. keyw2 == 'dpr') then sumtyp=2 typ=12 else if (narg > 3) then typ=100 else i=2 if (keyw2 == 'r2') then sumtyp=1 i=i+1 else if (keyw2 == 'dpr') then sumtyp=2 i=i+1 end if call gettrait(words(i), LOC_CODOM, LOC_XLIN, nloci, loc, lochash, loctyp, trait, 1) call gettrait(words(i+1), LOC_CODOM, LOC_XLIN, nloci, loc, lochash, loctyp, gene, 1) if (trait /= MISS) then typ=typ-1 if (gene /= MISS) typ=typ-1 end if end if ! Multilocus (nloc>2) haplotype log linear model if (typ == 100) then call loadnam(2, narg, words, nloci, loc, lochash, loctyp, group, & map, locstat, wloc, nord, locord, LOC_ANY, 1) call hapassoc(nord, locord, loc, loctyp, locpos, locnotes, & work, pval, plevel) ! Pairwise LD else if (typ < 10) then if (plevel < 1) then write(outstr,'(a/a)') & 'Marker 1 Marker 2 N mean D'' r2 Chi-sq df asy P', & '-------------- -------------- ------ ------- ----- ------ --- ------' end if last=.false. call setup_stat(lin, typ=sumtyp) do call ldlist(typ, trait, gene, nloci, loctyp, last) if (last .or. irupt /= 0) exit call freq(locpos(trait), loctyp(trait), fndr, work, allele_buffer) call freq(locpos(gene), loctyp(gene), fndr, work, allele_buffer2) call twold(zrec, maxhap, locpos(trait), loc(trait), loctyp(trait), & locpos(gene),loc(gene), loctyp(gene), & allele_buffer, allele_buffer2, work, iter, pval, sumtyp, plevel) locstat(gene)=pval end do ! Write a lower triangular matrix of r2 or D's else if (typ == 11) then write(outstr, '(/a/)') 'Intermarker r2' else if (typ == 12) then write(outstr, '(/a/)') 'Intermarker Hedrick D''' end if typ=typ-10 do i=1, nloci if ((same_loctyp(loctyp(i), LOC_CODOM) .and. irupt==0)) then call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) write(outstr, '(a10)', advance='no') loc(i) do j=1, i-1 if ((same_loctyp(loctyp(j), LOC_CODOM) .and. irupt==0)) then call freq(locpos(j), loctyp(j), fndr, work, allele_buffer2) call twold(zrec, maxhap, locpos(i), loc(i), loctyp(i), & locpos(j),loc(j), loctyp(j), & allele_buffer, allele_buffer2, work, iter, dist, sumtyp, -2) write(outstr, '(1x,f5.3)', advance='no') dist end if end do write(outstr, '(1x,a1)') '1' end if end do end if else write(outstr,'(a)') 'ERROR: Need numbers or dataset read in.' end if ! LD clumping else if (keyword == 'clu') then typ=1 if (words(narg)(1:3) == 'nos') then typ=typ+1 narg=narg-1 end if pcrit=0.05d0 thresh=0.5d0 dist=1.0d0 if (narg >= 2) then pcrit=fval(words(2)) if (pcrit <= 0.0d0) pcrit=0.05d0 if (narg >= 3) then thresh=fval(words(3)) if (thresh <= 0.0d0) thresh=0.5d0 if (narg >= 4) then dist=mapconstant*fval(words(4)) if (dist <= 0.0d0) dist=1.0d0 end if end if end if call clumpld(typ, pcrit, thresh, dist, maxhap, work, plevel) ! Moskvina and Schmidt 2008 effective number of tests else if (keyword == 'nef') then dist=1.0d0 pcrit=0.05d0 if (narg > 1) then pcrit=fval(words(2)) if (pcrit <= 0.0d0) pcrit=0.05d0 if (narg > 2) then dist=mapconstant*fval(words(3)) if (dist <= 0.0d0) dist=1.0d0 end if end if call moskvina(dist, pcrit, maxhap, nloci, loc, loctyp, & locpos, locord, map, work, statval(1), plevel) ! ! Combine a pair of SNPs else if (keyword == 'hap' .and. red) then if (keyw2 == 'yha' .or. keyw2 == 'mit') then typ=3 if (keyw2 == 'mit') typ=typ+1 if (narg > 4) then call loadnam(3, narg, words, nloci, loc, lochash, loctyp, group, map, & locstat, wloc, nord, locord, LOC_HAP, 1) call haploid_freq(nord, locord, loc, locpos, loctyp, & work, plevel, typ) else write(outstr,'(a)') & 'ERROR: Need at least 2 haploid markers and a target marker to store haplotypes.' end if else call gettrait(words(2), LOC_CODOM, 0, nloci, loc, lochash, loctyp, trait, 1) call gettrait(words(3), LOC_CODOM, 0, nloci, loc, lochash, loctyp, gene, 1) call gettrait(words(4), LOC_CODOM, 0, nloci, loc, lochash, loctyp, prob, 1) if (trait /= MISS .and. gene /= MISS .and. prob /= MISS) then cutoff=0 if (narg > 4) cutoff=ival(words(5)) call freq(locpos(trait), loctyp(trait), fndr, work, allele_buffer) call freq(locpos(gene), loctyp(gene), fndr, work, allele_buffer2) call compld(locpos(trait), locpos(gene), locpos(prob), & cutoff, allele_buffer, allele_buffer2, work) else write(outstr,'(a)') & 'ERROR: Need 2 SNPS and a target marker to store haplotypes.' end if end if ! F statistics else if (keyword == 'fst' .and. red) then call gettrait(words(2), LOC_TRA, 0, nloci, loc, lochash, loctyp, trait, 0) if (trait /= MISS) then assfnd=(words(3)(1:3)=='fou') conibd=MISS gt=-1 thresh=MISS typ=11 sumtyp=0 if (words(narg) == 'fst') then sumtyp=1 else if (words(narg) == 'fis') then sumtyp=2 else if (words(narg) == 'fit') then sumtyp=3 end if call popgen_init() if (plevel > -3) then write(outstr,'(/a/3a/a)') & '--------------------------------------------------', & 'F-statistics for populations "', trim(loc(trait)), '"', & '--------------------------------------------------' if (plevel < 1) then nmark=1 wloc(1)=trait write(outstr,'(a)') 'Population membership indicator:' call xtab(1, 1, DROPX, MISS, nmark, wloc, nloci, loc, locpos, loctyp, & locnotes, work, iter, nwid, ndec, pval, plevel) write(outstr,'(/a/a)') & 'Marker Typed Allels Pops Fis Fit Fst Asy P Emp P Iters', & '-------------------- ------ ------ ----- ------ ------ ------ ------ ------ --------' end if end if call setup_stat(lin, typ=sumtyp) if (assoc_stat_typ == 1) then !$OMP PARALLEL !$OMP DO ORDERED do i=1, nloci if (isactdip(loctyp(i)) .and. irupt == 0) then call doassoc(locpos(trait), loc(trait), loctyp(trait), locnotes(trait), & loc(i), locpos(i), loctyp(i), pearson, & iter, mincnt, norder, assfnd, gt, thresh, & conibd, work, 0, .false., fixfreq_buffer, allele_buffer2, & prevalence, locstat(i), sumtyp, plevel, typ) pval=locstat(i) end if end do !$OMP END DO !$OMP END PARALLEL else if (assoc_stat_typ == 2) then !$OMP PARALLEL !$OMP DO ORDERED do i=1, nloci if (isactdip(loctyp(i)) .and. irupt == 0) then call doassoc(locpos(trait), loc(trait), loctyp(trait), locnotes(trait), & loc(i), locpos(i), loctyp(i), gibbs, & iter, mincnt, norder, assfnd, gt, thresh, & conibd, work, 0, .false., fixfreq_buffer, allele_buffer2, & prevalence, locstat(i), sumtyp, plevel, typ) pval=locstat(i) end if end do !$OMP END DO !$OMP END PARALLEL end if call popgen_summary(outstr, plevel) else write(outstr,'(/a/a/a)') & '--------------------------------------------------', & 'Marker homozygosity in all typed individuals', & '--------------------------------------------------' call popgen_init() write(outstr,'(/a/a)') & 'Marker N Obs Exp Fis Z Emp P Iters', & '-------------------- ------ ------ ------ ------ ------ ------ ------' call setup_stat(lin) !$OMP PARALLEL DO do i=1, nloci if (isactdip(loctyp(i)) .and. irupt == 0) then call dohomoz(trait, loc(i), locpos(i), loctyp(i), fndr, iter, & mincnt, norder, gt, thresh, work, & locstat(i), plevel) end if end do !$OMP END PARALLEL DO call popgen_homoz(outstr, plevel) end if ! ! counts of rare alleles in cases and controls ! else if ((keyword == 'rar') .and. red) then thresh=0.01d0 trait=MISS call gettrait(words(2), LOC_ANY, 0, nloci, loc, lochash, loctyp, trait, 0) if (trait /= MISS) then if (narg > 2) then thresh=fval(words(3)) end if if (loctyp(trait) == LOC_AFF) then write(outstr,'(/a/3a/a/a,f8.6)') & '--------------------------------------------------', & ' Counts of rare alleles versus "', trim(loc(trait)),'"', & '--------------------------------------------------', & 'Rare defined as MAF < ', thresh call rarecascon(trait, thresh, work, plevel) else if (loctyp(trait) == LOC_CODOM) then write(outstr,'(/a/3a/a/a,f8.6)') & '--------------------------------------------------', & ' Rare allele carrier status as "', trim(loc(trait)),'"', & '--------------------------------------------------', & 'Rare defined as MAF < ', thresh call rarecarrier(trait, thresh, work, plevel) end if else write(outstr,'(a)') 'ERROR: Need to specify binary trait or a marker.' end if ! ! SKAT ! else if ((keyword == 'ska') .and. red) then call gettrait(words(2), LOC_TRA, 0, nloci, loc, lochash, loctyp, trait, 0) if (trait /= MISS) then typ=1 if (words(3)(1:3) == 'mad') then typ=2 else if (words(3)(1:3) == 'bet') then typ=3 end if write(outstr,'(/a/3a/a)') & '--------------------------------------------------', & ' SKAT test for "', trim(loc(trait)),'"', & '--------------------------------------------------' if (typ == 1) then write(outstr,'(a)') 'Using unweighted linear kernel.' else if (typ == 2) then write(outstr,'(a)') 'Using Madsen-Browning (1/pq) weighted linear kernel.' else if (typ == 3) then write(outstr,'(a)') 'Using SKAT default B(1,25) weighted linear kernel.' end if call doskat(trait, typ, work, pval, plevel) else write(outstr,'(a)') 'ERROR: Need to specify binary trait or a marker.' end if ! ! association analysis (ANOVA or chi-square) ! else if (keyword == 'ass' .and. red) then call gettrait(words(2), LOC_TRA, 0, nloci, loc, lochash, loctyp, trait, 0) assfnd=.false. conibd=MISS gt=0 nord=0 thresh=MISS sumtyp=0 typ=1 ! while not end of list of keywords i=3 call preparser(i, narg, words) do while (i <= narg) keyword=words(i)(1:3) if (iscomp(keyword)) then call docomp(i, words, gt, thresh) else if (keyword == 'cat') then gt=-1 i=i+1 else if (keyword == 'gen') then typ=2 i=i+1 else if (keyword == 'snp') then typ=10 i=i+1 else if (keyword == 'fre') then typ=12 i=i+1 else if (keyword == 'maf') then typ=13 i=i+1 else if (keyword == 'ris') then typ=14 i=i+1 else if (keyword == 'fou') then assfnd=.true. i=i+1 else if (keyword == 'ibd' .and. i < narg) then call gettrait(words(i+1), LOC_CODOM, 0, nloci, loc, lochash, loctyp, conibd, 0) i=i+2 else if (keyword == 'cov' .and. i < narg) then call gettrait(words(i+1), LOC_ANY, 0, nloci, loc, lochash, loctyp, gene, 0) if (gene /= MISS) then nord=nord+1 locord(nord)=gene end if i=i+2 else if (keyword == 'vcf' .and. i < narg) then typ=15 call get_filnam(lin, i+1, wrkfil) i=i+2 else write(outstr,'(3a)') & 'Skipping unknown keyword "', trim(words(i)), '".' i=i+1 end if end do if (trait /= MISS) then if (loctyp(trait) == LOC_CAT .and. gt == 0) gt=-1 write(outstr,'(/a/3a/a)') & '--------------------------------------------------', & 'Allelic association testing for trait "', trim(loc(trait)), '"', & '--------------------------------------------------' if (assfnd) then write(outstr,'(a/)') 'NOTE: Analysis restricted to founders only.' end if if (gt > 0) call defpro(gt, thresh, .true.) if (gt == -1) then write(outstr,'(a/)') & 'NOTE: Categorical trait analysis performed.' end if if (typ == 2) then write(outstr,'(a/)') 'NOTE: Genotypic rather than allelic association test.' else if (typ == 10) then if (loctyp(trait) == LOC_QUA .and. gt == 0) then write(outstr,'(a/)') 'NOTE: Showing allelic betas for diallelic markers.' else write(outstr,'(a/)') 'NOTE: Showing allelic odds ratios for diallelic markers.' end if else if (plevel < 1 .and. gt /= -1) then if (typ == 12) then write(outstr,'(a/)') 'NOTE: Showing allele frequencies in cases and controls.' else if (typ == 13) then write(outstr,'(a/)') 'NOTE: Showing minor allele frequencies in cases and controls.' else if (typ == 14) then write(outstr,'(a/)') 'NOTE: Showing risk allele frequencies in cases and controls.' end if end if if (conibd /= MISS) then write(outstr,'(3a/)') 'NOTE: Gene dropping is conditional on IBD at "', & trim(loc(conibd)), '".' end if if (nord > 0) then write(outstr,'(a)',advance='no') 'NOTE: Covariates are:' do i=1, nord j=locord(i) write(outstr,'(3a)',advance='no') ' "', trim(loc(j)), '"' end do write(outstr,'(a)') '.' end if if (plevel == 0 .or. plevel == -1) then if (typ == 1 .or. gt == -1) then write(outstr,'(/a/a)') & 'Marker Typed Allels Chi-square Asy P Emp P Iters', & '-------------------- ------ ------ ---------- ------ ------ --------' else if (typ == 2) then write(outstr,'(/a/a)') & 'Marker Typed Gtps Chi-square Asy P Emp P Iters', & '-------------------- ------ ------ ---------- ------ ------ --------' else if (typ == 12 .or. typ == 13 .or. typ == 14) then write(outstr,'(/a/a)') & 'Marker Typed Allele Case Contrl Chi-square Asy P Emp P Iters', & '-------------------- ------ ------ ------ ------ ---------- ------ ------ --------' else if (loctyp(trait) == LOC_QUA) then write(outstr,'(/a/a)') & 'Marker Allele AF Typed Beta ASE Z P-value ', & '-------------------- ------ ---- ------ ---------- ---------- ---------- ---------' else if (typ == 15) then continue else write(outstr,'(/a/a)') & 'Marker Allele OR 95% CI P-value ', & '-------------------- ------ -------- -------------------- ----------' end if end if if (conibd /= MISS) then call freq(locpos(conibd), loctyp(conibd), fndr, work, allele_buffer2) conibd=locpos(conibd) end if call setup_stat(lin) if (loctyp(trait) == LOC_QUA .and. gt == 0) then ! SNP type output (regression coefficients) if (typ == 10) then nord=nord+2 locord(nord)=trait !$OMP PARALLEL PRIVATE(allele_buffer) !$OMP DO ORDERED do i=1, nloci if (isactdip(loctyp(i)) .and. irupt == 0) then call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) locord(nord-1)=i call regress(-2, nord, locord, nloci, loc, loctyp, locpos, & i, 1, allele_buffer, work, & mlik(whlik), mpar(whlik), pval, max(0, plevel)) locstat(i)=pval end if end do !$OMP END DO !$OMP END PARALLEL else !$OMP PARALLEL !$OMP DO ORDERED do i=1, nloci if (isactdip(loctyp(i)) .and. irupt == 0) then call doanova(locpos(trait), loc(i), locpos(i), loctyp(i), iter, & mincnt, norder, assfnd, conibd, work, fndr, & (i == fixfreq), fixfreq_buffer, allele_buffer2, & locstat(i), plevel, typ) if (.not.assfnd) then call cpganova(locpos(trait), loc(i), locpos(i), loctyp(i), & iter, mincnt, fndr, work, plevel) end if end if end do !$OMP END DO !$OMP END PARALLEL end if else if (typ /= 10 .and. typ /= 15) then if (assoc_stat_typ == 1) then !$OMP PARALLEL !$OMP DO ORDERED do i=1, nloci if (isactdip(loctyp(i)) .and. irupt == 0) then call doassoc(locpos(trait), loc(trait), loctyp(trait), locnotes(trait), & loc(i), locpos(i), loctyp(i), pearson, & iter, mincnt, norder, assfnd, gt, thresh, & conibd, work, fndr, (i == fixfreq), & fixfreq_buffer, allele_buffer2, & prevalence, locstat(i), sumtyp, plevel, typ) isbin=(loctyp(trait) == LOC_AFF .or. gt > 0) if (.not.same_loctyp(loctyp(i), LOC_XLIN) .and. isbin .and. & typ < 12 .and. plevel > -2) then call rctdt(locpos(trait), loc(i), locpos(i), loctyp(i), & iter, mincnt, gt, thresh, fbatimp, fndr, & work, plevel) end if end if end do !$OMP END DO !$OMP END PARALLEL else if (assoc_stat_typ == 2) then !$OMP PARALLEL !$OMP DO ORDERED do i=1, nloci if (isactdip(loctyp(i)) .and. irupt == 0) then call doassoc(locpos(trait), loc(trait), loctyp(trait), locnotes(trait), & loc(i), locpos(i), loctyp(i), gibbs, & iter, mincnt, norder, assfnd, gt, thresh, & conibd, work, fndr, (i == fixfreq), & fixfreq_buffer, allele_buffer2, & prevalence, locstat(i), sumtyp, plevel, typ) isbin=(loctyp(trait) == LOC_AFF .or. gt > 0) if (.not.same_loctyp(loctyp(i), LOC_XLIN) .and. isbin .and. & typ < 12 .and. plevel > -2) then call rctdt(locpos(trait), loc(i), locpos(i), loctyp(i), & iter, mincnt, gt, thresh, fbatimp, fndr, & work, plevel) end if end if end do !$OMP END DO !$OMP END PARALLEL end if ! SNP type output (odds ratios) else if (typ == 10) then nord=nord+2 locord(nord)=trait censor=MISS off=MISS fixshape=.false. mcp=.true. shap=1.0d0 do i=1, nloci if (isactdip(loctyp(i)) .and. irupt == 0) then call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) locord(nord-1)=i call binreg(GLM_BINOM, nord, locord, nloci, loc, loctyp, & locpos, off, censor, i, genemod, & allele_buffer, mcp, useimp, fixshape, & iter, mincnt, work, shap, mlik(whlik), & mpar(whlik), statval, pval, plevel-2) locstat(i)=pval if (statval(1) >= 0.0d0) then call wrall(allele_buffer%allele_names(2), charnum) else call wrall(allele_buffer%allele_names(1), charnum) end if charnum=adjustl(charnum) tmp=1.96d0*sqrt(statval(3)) write(outstr,'(a20,a1,3x,a3,a1,f8.3,a1,f8.3,a,f8.3,a1,g10.4,a1,a22)') & loc(i), tabsep, charnum, tabsep, exp(abs(statval(1))), & tabsep, exp(abs(statval(1))-tmp), ' -- ', & exp(abs(statval(1))+tmp), tabsep, pval, tabsep, locnotes(i) end if end do ! compare to population allele frequencies from VCF file else call open_port(wrkfil, port, 'r', ioerr) if (ioerr == 0) then call vcfcascon(trait, gt, thresh, assfnd, & vcf_ac, vcf_an, vcf_het, vcf_hom, & port, work, plevel) call close_port(port, ioerr) else write(*,'(/3a/)') & 'ERROR: Problem opening VCF file "', trim(wrkfil), '".' end if end if end if if (plevel < -1) then call sumstat(5, plevel) end if else write(outstr,'(a)') 'ERROR: Need to specify trait locus.' end if else if ((keyword == 'mit' .or. keyword == 'yha') .and. red) then typ=1 htyp=LOC_YHA gt=0 thresh=MISS words(1)='Y' if (keyword == 'mit') then typ=typ+1 htyp=LOC_MIT words(1)='Mito' end if if (words(2) == 'hap') then if (narg == 2) then narg=3 words(3)='$h' end if call loadnam(3, narg, words, nloci, loc, lochash, loctyp, group, map, & locstat, wloc, nord, locord, htyp, 1) call haploid_freq(nord, locord, loc, locpos, loctyp, & work, plevel, typ) else call gettrait(words(2), LOC_TRA, 0, nloci, loc, lochash, loctyp, trait, 0) if (trait /= MISS) then write(outstr,'(/a/5a/a)') & '------------------------------------------------------', & 'Association of trait "', trim(loc(trait)),'" with ', & trim(words(1)), ' haplotypes', & '------------------------------------------------------' if (plevel < 1) then write(outstr,'(/a/a)') & 'Marker Typed Haplos Chi-square Asy P Emp P Iters', & '-------------------- ------ ------ ---------- ------ ------ --------' end if ltyp=1 if (narg == 2 .or. (narg == 3 .and. words(3) == 'cat')) then if (narg == 3 .and. words(3) == 'cat') ltyp=ltyp+1 call setup_stat(lin) if (loctyp(trait) == LOC_QUA .and. ltyp == 1) then do i=1, nloci if (same_loctyp(loctyp(i), htyp) .and. irupt == 0) then nord=1 locord(nord)=i call haploid_aov(trait, nord, locord, loc, locpos, loctyp, & iter, mincnt, work, pval, plevel, typ) locstat(i)=pval end if end do else if (assoc_stat_typ == 1) then do i=1, nloci if (same_loctyp(loctyp(i), htyp) .and. irupt == 0) then nord=1 locord(nord)=i call haploid_ass(trait, nord, locord, loc, locpos, loctyp, & locnotes, pearson, iter, mincnt, work, & locstat(i), plevel, typ) end if end do else if (assoc_stat_typ == 2) then do i=1, nloci if (same_loctyp(loctyp(i), htyp) .and. irupt == 0) then nord=1 locord(nord)=i call haploid_ass(trait, nord, locord, loc, locpos, loctyp, & locnotes, gibbs, iter, mincnt, work, & locstat(i), plevel, typ) end if end do end if end if else i=3 if (words(i) == 'cat') then i=i+1 ltyp=ltyp+1 end if call loadnam(i, narg, words, nloci, loc, lochash, loctyp, group, map, & locstat, wloc, nord, locord, htyp, 1) if (loctyp(trait) == LOC_QUA .and. ltyp == 1) then call haploid_aov(trait, nord, locord, loc, locpos, loctyp, & iter, mincnt, work, pval, plevel, typ) else if (assoc_stat_typ == 1) then call haploid_ass(trait, nord, locord, loc, locpos, loctyp, & locnotes, pearson, iter, mincnt, work, & pval, plevel, typ) else if (assoc_stat_typ == 2) then call haploid_ass(trait, nord, locord, loc, locpos, loctyp, & locnotes, gibbs, iter, mincnt, work, & pval, plevel, typ) end if end if end if else write(outstr,'(a)') 'ERROR: Need to specify trait locus.' end if end if ! ! Schaid and Sommer else if (keyword == 'sch' .and. red) then call gettrait(words(2), LOC_AFF, 0, nloci, loc, lochash, loctyp, trait, 0) if (trait /= MISS) then write(outstr,'(/a/3a/a)') & '--------------------------------------------------', & 'Schaid & Sommer analysis of trait "', trim(loc(trait)),'"', & '--------------------------------------------------' if (narg == 2) then if (plevel == 0 .or. plevel == -1) then write(outstr,'(/a/a)') & 'Marker Typed Allele Chi-square Asy P ', & '-------------------- ------ ------ ---------- ------' end if candal=MISS !$OMP PARALLEL DO do i=1, nloci if (isactdip(loctyp(i)) .and. irupt == 0) then call nucseg(locpos(trait), loc(i), locpos(i), loctyp(i), fndr, & candal, work, locstat(i), plevel) end if end do !$OMP END PARALLEL DO else call gettrait(words(3), LOC_CODOM, 0, nloci, loc, lochash, loctyp, gene, 0) if (trait /= MISS .and. gene /= MISS) then gcode=gencode(loctyp(gene)) candal=int(aval(words(4), gcode)) call nucseg(locpos(trait), loc(gene), locpos(gene), & loctyp(gene), fndr, candal, work, pval, max(1, plevel)) else write(outstr,'(a)') 'ERROR: Need to specify trait and marker.' end if end if else write(outstr,'(a)') 'ERROR: Need to specify binary trait.' end if ! homozygosity analysis else if ((keyword == 'hom') .and. red) then call getbin(2, narg, words, nloci, loc, lochash, loctyp, trait, gt, thresh) if (trait /= MISS) then write(outstr,'(/a/3a/a)') & '--------------------------------------------------', & 'Marker homozygosity in cases of trait "', trim(loc(trait)), '"', & '--------------------------------------------------' if (gt > 0) call defpro(gt, thresh, .true.) trait=locpos(trait) else write(outstr,'(/a/a/a)') & '--------------------------------------------------', & 'Marker homozygosity in all typed individuals', & '--------------------------------------------------' end if call popgen_init() write(outstr,'(/a/a)') & 'Marker N Obs Exp Fis Z Asy P Emp P Iters', & '-------------------- ------ ------ ------ ------ ------ ------ ------ --------' call setup_stat(lin) !$OMP PARALLEL DO do i=1, nloci if (isactdip(loctyp(i)) .and. irupt == 0) then call dohomoz(trait, loc(i), locpos(i), loctyp(i), fndr, iter, mincnt, & norder, gt, thresh, work, locstat(i), plevel) end if end do !$OMP END PARALLEL DO call popgen_homoz(outstr, plevel) else if ((keyword == 'mul') .and. red) then trait=MISS censor=MISS if (words(2) == 'sav' .or. words(2) == 'save') then call gettrait(words(3), LOC_QUA, 0, nloci, loc, lochash, loctyp, censor, 0) else call getbin(2, narg, words, nloci, loc, lochash, loctyp, trait, gt, thresh) end if if (trait /= MISS) then write(outstr,'(/a/3a/a)') & '-------------------------------------------------------', & 'Runs of marker homozygosity in cases of trait "', trim(loc(trait)), '"', & '-------------------------------------------------------' if (gt > 0) call defpro(gt, thresh, .true.) trait=locpos(trait) call mulhom(trait, gt, thresh, xlinkd, iter, mincnt, & nloci, loc, loctyp, locpos, map, work, plevel) else write(outstr,'(/a/a/a/a,f12.6,1x,2a)') & '----------------------------------------------------', & 'Overall marker homozygosity in all typed individuals', & '----------------------------------------------------', & 'Minimum run of homozygosity used: ', & long_roh/mapconstant, trim(mapunitname(mapunits)), '.' if (censor /= MISS) then write(outstr,'(3a)') 'Writing F_roh to "', trim(loc(censor)), '"' censor=locpos(censor) end if call globhom(work, long_roh, censor, plevel) end if else if ((keyword == 'hbd').and.red) then call gettrait(words(2), LOC_CODOM, 0, nloci, loc, lochash, loctyp, gene, 1) call gettrait(words(3), LOC_QUA, 0, nloci, loc, lochash, loctyp, trait, 1) if (gene /= MISS .and. iter > 0) then write(outstr,'(/a/3a/a)') & '-------------------------------------------------------', & 'Estimated homozygosity-by-descent at locus "', trim(loc(gene)),'"', & '-------------------------------------------------------' if (trait /= MISS) then write(outstr,'(3a)') 'Writing HBD to "', trim(loc(trait)), '"' trait=locpos(trait) end if call freq(locpos(gene), loctyp(gene), fndr, work, allele_buffer) if (allele_buffer%typed > 0) then call wrhbd(locpos(gene), trait, iter, burnin, & allele_buffer, work, plevel) else write(outstr,'(a)') 'No genotyped individuals.' end if else write(outstr,'(a)') 'ERROR: Need to specify marker.' end if ! ! List individuals and matings with largest number of affected ! descendants for each pedigree ! else if (keyword == 'anc' .and. red) then call getbin(2, narg, words, nloci, loc, lochash, loctyp, trait, gt, thresh) if (trait /= MISS) then call ancest(loc(trait), locpos(trait), gt, thresh, work, plevel) else write(outstr,'(a)') 'ERROR: Need to specify trait.' end if ! show pedigree loops else if (keyword == 'loo' .and. red) then call gettrait(words(2), LOC_QUA, LOC_AFF, nloci, loc, lochash, loctyp, trait, 1) write(outstr,'(/a/a/a)') & '------------------------------------------------', & 'Inbreeding or marital loops in pedigrees', & '------------------------------------------------' if (trait /= MISS) then write(outstr,'(3a)') 'Writing loop indicator to "', trim(loc(trait)), '"' trait=locpos(trait) end if call findloop(trait, work, plevel) ! ! kinship and inbreeding coefficients ! ! 1=default lower triangular matrix ! 2=pairwise 3=(nonzero) inbreeding coefficients 4=delta7 ! 5=kinship for cases ! 6=MCMC inbreeding coefficients ! 8=empirical kinship coefficients ! 9=roadtrips/kincoef format ! else if (keyword == 'kin' .and. red) then typ=1 trait=MISS if (keyw2 == 'pai') then typ=2 else if (keyw2 == 'inb') then typ=3 i=3 if (words(3)(1:3) == 'mon' .or. words(3) == 'mc') then typ=typ+typ i=i+1 end if call gettrait(words(i), LOC_QUA, 0, nloci, loc, lochash, loctyp, trait, 1) if (trait /= MISS) then write(outstr,'(3a)') 'Writing inbreeding coefficient to "', trim(loc(trait)), '"' trait=locpos(trait) end if else if (keyw2 == 'dom') then typ=4 else if (keyw2 == 'ibs') then typ=8 else if (keyw2 == 'roa') then typ=9 else if (keyw2 == 'wri') then typ=10 else if (narg > 1) then call getbin(2, narg, words, nloci, loc, lochash, loctyp, trait, gt, thresh) if (trait /= MISS) then typ=5 else typ=7 write(outstr,'(3a)') 'ERROR: Did not recognize trait "', trim(words(2)), '".' end if end if if (typ == 8) then call ibskin(3, trait, gt, thresh, nloci, loc, loctyp, locpos, work, plevel) else if (typ == 3 .or. typ == 6) then call doinbred(iter, work, trait, plevel) else if (typ < 5 .or. typ == 9 .or. typ == 10) then call dokin(typ, work) else if (typ == 5) then call casekin(loc(trait), locpos(trait), gt, thresh, work, statval, & pval, iter, plevel) end if ! IBD matrices else if (keyword == 'ibd' .and. red) then typ=1 if (words(narg)(1:3) == 'pai') then typ=typ+1 narg=narg-1 end if nord=0 do i=2, narg call gettrait(words(i), LOC_CODOM, 0, nloci, loc, lochash, loctyp, gene, 1) if (gene /= MISS) then nord=nord+1 locord(nord)=gene end if end do if (nord /= 0 .and. iter > 0) then write(outstr,'(/a)') repeat('-', 48) if (nord == 1) then write(outstr,'(3a)') & 'Estimated IBD sharing at "', trim(loc(locord(1))), '"' else write(outstr,'(5a)') & 'Estimated IBD sharing at "', trim(loc(locord(1))), '" to "', & trim(loc(locord(nord))), '"' end if write(outstr,'(a)') repeat('-', 48) call wribd(nord, locord, loc, loctyp, locpos, work, & burnin, iter, typ, plevel) else write(outstr,'(a)') 'ERROR: Need to specify marker(s).' end if ! IBS sharing else if (keyword == 'ibs' .and. red) then if (keyw2 == 'kin' .or. keyw2 == 'mom') then typ=2 if (words(3)(1:3) == 'fou') then typ=typ-1 else call getbin(3, narg, words, nloci, loc, lochash, loctyp, trait, gt, thresh) if (trait /= MISS) typ=4 end if if (keyw2 == 'mom') then call momentibs(typ, trait, gt, thresh, nloci, loc, loctyp, locpos, & work, plevel) else call ibskin(typ, trait, gt, thresh, nloci, loc, loctyp, locpos, & work, plevel) end if else call getbin(2, narg, words, nloci, loc, lochash, loctyp, trait, gt, thresh) call wribs(trait, gt, thresh, nloci, loc, loctyp, locpos, work, plevel) end if ! APM analyses - IBD or IBS based else if (keyword == 'apm' .and. red) then call getbin(2, narg, words, nloci, loc, lochash, loctyp, trait, gt, thresh) if (trait /= MISS .and. iter > 0) then typ=1 if (words(3) == 'ibd' .or. words(5) == 'ibd') typ=2 write(outstr,'(/a/3a/a/)') & '------------------------------------------------', & 'APM for trait "', trim(loc(trait)),'" v. all markers', & '------------------------------------------------' if (typ == 2) then write(outstr,'(a/)') 'NOTE: Identity-by-descent based statistic used.' end if if (thresh /= MISS) call defpro(gt, thresh, .true.) if (plevel < 1) then write(outstr,'(/a/a)') & 'Marker NFams NAff Z-value Asy P Emp P Iters', & '-------------------- ------ ------ ---------- ------ ------ ------' end if call setup_stat(lin) do i=1, nloci if (same_loctyp(loctyp(i), LOC_CODOM) .and. irupt == 0) then call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) call doapm(locpos(trait), loc(i), locpos(i), typ, iter, & burnin, gt, thresh, work, allele_buffer, pval, plevel) locstat(i)=pval end if end do else write(outstr,'(a)') 'ERROR: need to specify trait and iter>0.' end if ! ASP analysis else if (keyword == 'asp' .and. red) then call getbin(2, narg, words, nloci, loc, lochash, loctyp, trait, gt, thresh) if (trait /= MISS) then write(outstr,'(/a/3a/a/)') & '------------------------------------------------', & 'IBS ASP for "', trim(loc(trait)), '" v. all marker loci', & '------------------------------------------------' if (thresh /= MISS) call defpro(gt, thresh, .true.) if (plevel < 1) then write(outstr,'(a/a)') & 'Marker NPairs mIBS ExpIBS Asy P mIBD Asy P', & '-------------------- ------ ------ ------ ------ ------ ------' end if call setup_stat(lin) do i=1, nloci if (same_loctyp(loctyp(i), LOC_CODOM) .and. irupt == 0) then call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) call doasp(locpos(trait), loc(i), locpos(i), gt, thresh, & allele_buffer, work, pval, plevel) locstat(i)=pval end if end do else write(outstr,'(a)') 'ERROR: Need to specify trait.' end if ! Penrose sib pair analysis else if (keyword == 'pen' .and. red) then call gettrait(words(2), LOC_ANY, 0, nloci, loc, lochash, loctyp, trait, 1) call gettrait(words(3), LOC_ANY, 0, nloci, loc, lochash, loctyp, gene, 1) if (trait /= MISS .and. gene /= MISS) then write(outstr,'(/a/5a/a/)') & '---------------------------------------------------------------', & 'Penrose Sib Pair Linkage Analysis for "', & trim(loc(trait)), '" v. "', trim(loc(gene)), '"', & '---------------------------------------------------------------' call dopenrose(loc(trait), locpos(trait), loctyp(trait), & loc(gene), locpos(gene), loctyp(gene), work, & iter, plevel) else write(outstr,'(a)') 'ERROR: Need to specify two loci.' end if ! H-E sib-pair linkage analysis else if ((keyword == 'sib' .or. keyword == 'he1' .or. & keyword == 'he2' .or. keyword == 'vis') .and. red) then call gettrait(words(2), LOC_QUA, LOC_AFF, nloci, loc, lochash, loctyp, trait, 0) if (trait /= MISS) then typ=3 words(1)='Sham S+D' if (keyword == 'he1') then typ=1 words(1)='Standard' else if (keyword == 'he2') then typ=2 words(1)='CP-based' else if (keyword == 'vis') then typ=4 words(1)='V&H S+D ' end if gene=MISS sibm=MISS sibr=MISS sibv=MISS weight=MISS mcp=.false. i=3 do while (i <= narg) if (words(i) == 'sim' .or. words(i) == 'simulate') then mcp=.true. else if (words(i) == 'var') then i=i+1 sibv=fval(words(i)) else if (words(i) == 'sd') then i=i+1 sibv=fval(words(i))**2 else if (words(i) == 'mea') then i=i+1 sibm=fval(words(i)) else if (words(i) == 'cor') then i=i+1 sibr=fval(words(i)) else call gettrait(words(i), LOC_QUA, 0, nloci, loc, lochash, loctyp, gene, 0) if (gene /= MISS) weight=locpos(gene) end if i=i+1 end do write(outstr,'(/a/a8,3a/a)') & '---------------------------------------------------------', & words(1),' H-E for trait "', trim(loc(trait)),'" v. all markers', & '---------------------------------------------------------' if (gene /= MISS) then write(outstr,'(3a,2(/7x,a))') & 'NOTE: Each pair contribution weighted by mean of "', trim(loc(gene)),'"', & 'for each member. Weight is taken as proportional to', & 'the variance for that contribution (WLS).' end if if (sibr /= MISS) then write(outstr,'(a,f5.3)') & 'NOTE: Using trait sibling correlation provided: ',sibr end if if (sibm /= miss) then write(outstr,'(a,f10.4,a,f10.4,a)') & 'NOTE: Using trait mean (SD) provided: ', sibm,' (',sqrt(sibv),')' end if if (plevel < 1) then write(outstr,'(/a/a)') & 'Marker FSibs HSibs t-value Asy P Emp P Iters', & '-------------------- ------ ------ ---------- ------ ------ ------' end if call setup_stat(lin) do i=1, nloci if (same_loctyp(loctyp(i), LOC_CODOM) .and. irupt == 0) then call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) call sibpair(loc(trait), locpos(trait), loc(i), locpos(i), map(i), & typ, sibm, sibr, sibv, mcp, iter, mincnt, weight, & work, allele_buffer, pval, plevel) locstat(i)=pval end if end do else write(outstr,'(a)') 'ERROR: need to specify trait.' end if ! VC QTL linkage analysis else if (keyword == 'qtl' .and. red) then call gettrait(words(2), LOC_QUA, LOC_AFF, nloci, loc, lochash, loctyp, trait, 0) if (trait /= MISS) then write(outstr,'(/a/3a/a)') & '---------------------------------------------------------', & 'VC linkage analysis for trait "', trim(loc(trait)), '" v. all markers', & '---------------------------------------------------------' gene=MISS modtyp=GLM_GAUSS typ=1 nord=0 i=3 do while (i <= narg) keyword=words(i)(1:3) if (keyword == 'ful') then typ=5 i=i+1 else if (keyword == 'cqe') then typ=7 i=i+1 else if (keyword == 'mft') then modtyp=GLM_BINOM i=i+1 else if (keyword == 'cov' .and. i < narg) then call loadnam(i+1, narg, words, nloci, loc, lochash, loctyp, group, map, & locstat, wloc, nord, locord, LOC_ANY, 1) gene=findml(nord, locord, loctyp) i=narg+1 else write(outstr,'(3a)') 'Skipping unknown keyword "', trim(words(i)), '".' i=i+1 end if end do nord=nord+1 locord(nord)=trait if (plevel < 1 .and. nord > 1) then write(outstr, '(3a)',advance='no') ' Fixed: ', & trim(loc(locord(nord))), ' ~ mu' do j=1, nord-1 write(outstr,'(2a)',advance='no') ' + ', trim(loc(locord(j))) if (locord(j) == gene) then write(outstr,'(a)',advance='no') '(M)' end if end do write(outstr,*) end if call setup_stat(lin) if (typ == 1) then if (plevel == 0 .or. plevel == -1) then write(outstr,'(/a/a)') & 'Marker FSibs HSibs lod score Asy P Emp P Iters', & '-------------------- ------ ------ ---------- ------ ------ ------' end if do i=1, nloci if (same_loctyp(loctyp(i), LOC_CODOM) .and. irupt == 0) then call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) call sibqtl(loc(trait), locpos(trait), loc(i), locpos(i), & allele_buffer, work, pval, plevel, invalg, toler) locstat(i)=pval end if end do else if (plevel < 1) then write(outstr,'(/a/a)') & 'Marker NFams NPheno lod score Asy P Emp P Iters', & '-------------------- ------ ------ ---------- ------ ------ ------' end if ! enumerate levels for any covariate marker if (gene /= MISS) then call freq(locpos(gene), loctyp(gene), fndr, work, allele_buffer) end if ! evaluate IBD at ith marker and neighbours nmarklist=0 i=1 do while (i <= nloci .and. irupt == 0) call nearloc(i, closedist, maxcluster, nloci, loc, loctyp, & group, map, nmarklist, marklist, plevel) if (nmarklist > 0) then whlik=3-whlik mcall(whlik)=trim(lin) call varcom(modtyp, nord, locord, nloci, loc, loctyp, locpos, & gene, genemod, allele_buffer, nmarklist, marklist, work, & nobs, mlik(whlik), mpar(whlik), pval, & plevel, burnin, iter, typ, invalg, optim, toler) locstat(i-nmarklist)=pval end if end do end if else write(outstr,'(a)') 'ERROR: Need to specify trait.' end if ! ! Summary of results from scan of markers else if (keyword == 'sum') then if (keyw2 == 'plo') then outfil='sib-pair.eps' if (words(3) == 'qq' .or. words(3)(1:3) == 'qua') then if (narg > 3) then call get_filnam(lin, narg, outfil) end if call qqplot(outfil) else if (narg > 2) then call get_filnam(lin, narg, outfil) end if call sumplot(outfil) call asciiplot(plevel) end if else if (keyw2 == 'tab') then if (locstat_typ == 0) then call tabstat(plevel) else call histstat(plevel) end if else if (keyw2 == 'ucs') then if (narg > 2) then call sumucsc(trim(words(3))) else write(outstr,'(a)') 'ERROR: Need to specify chromosome.' end if else if (keyw2 == 'dum') then outfil='sib-pair.eps' if (narg > 2) then call get_filnam(lin, narg, outfil) end if open(OSTR, file=outfil, status='unknown', iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if call dumpstats(OSTR) close(OSTR, status='keep') else if (keyw2 == 'get') then call get_stats(trim(words(3))) else if (keyw2 == 'com') then call loadnam(3, narg, words, nloci, loc, lochash, loctyp, & group, map, locstat, wloc, nord, locord, LOC_ANY, 1) call combine_stats(pval, plevel) else n=ival(words(2)) if (n <= 0) n=5 call sumstat(n, plevel) end if ! two-point linkage between markers else if (keyword == 'lod' .and. red) then write(outstr,'(/a/a/a/)') & '------------------------------------', & 'Two-point lod score linkage analysis', & '------------------------------------' call gettrait(words(2), LOC_CODOM, 0, nloci, loc, lochash, loctyp, trait, 0) call gettrait(words(3), LOC_CODOM, 0, nloci, loc, lochash, loctyp, gene, 0) if (trait /= MISS .and. gene /= MISS) then typ=1 th1=0.0d0 if (narg == 4) then if (words(narg) == 'gpe') then typ=3 th1=0.0d0 else if (words(narg)(1:3) == 'dos') then typ=4 th1=0.0d0 else typ=2 th1=fval(words(4)) if (th1 < 0.0d0) th1=0.0d0 if (th1 > 0.5d0) th1=0.5d0 end if end if if (trait /= fixfreq) then call freq(locpos(trait), loctyp(trait), fndr, work, allele_buffer) else write(outstr,'(/3a)') & 'NOTE: Population allele frequencies for "', trim(loc(trait)), & '" are prespecified as:' call wrfreq(outstr, fixmarker, group(fixfreq), map(fixfreq), & locnotes(fixfreq), fixfreq_buffer, 15) call copyfreq(fixfreq_buffer, allele_buffer) end if if (gene /= fixfreq) then call freq(locpos(gene), loctyp(gene), fndr, work, allele_buffer2) else write(outstr,'(/3a)') & 'NOTE: Population allele frequencies for "', trim(loc(gene)), & '" are prespecified as:' call wrfreq(outstr, fixmarker, group(fixfreq), map(fixfreq), & locnotes(fixfreq), fixfreq_buffer, 15) call copyfreq(fixfreq_buffer, allele_buffer2) end if write(outstr,'(3a,i0,3a,i0,a)') & '"', trim(loc(trait)), '" (', allele_buffer%numal,' alleles) v. "', & trim(loc(gene)),'" (', allele_buffer2%numal,' alleles).' call dopeel2(typ, locpos(trait), locpos(gene), th1, emiter, & allele_buffer, allele_buffer2, work, plevel) end if ! sib-pair linkage between markers after Elston else if (keyword == 'lin' .and. red) then write(outstr,'(/a/a/a//a/a)') & '---------------------------------------------------', & 'Inter-marker sib pair linkage analysis', & '---------------------------------------------------', & 'Marker 1 Marker 2 Sibships Sibpairs r(IBD) Recomb', & '-------------- -------------- -------- -------- ------ -------' call gettrait(words(2), LOC_CODOM, 0, nloci, loc, lochash, loctyp, trait, 0) call gettrait(words(3), LOC_CODOM, 0, nloci, loc, lochash, loctyp, gene, 0) if (trait /= MISS) then call freq(locpos(trait), loctyp(trait), fndr, work, allele_buffer) if (gene /= MISS) then call freq(locpos(gene), loctyp(gene), fndr, work, allele_buffer2) call twopoi(locpos(trait),loc(trait), locpos(gene), loc(gene), & allele_buffer, allele_buffer2, work, plevel) else do i=1, nloci if (same_loctyp(loctyp(i), LOC_CODOM) .and. i /= trait .and. irupt == 0) then call freq(locpos(i), loctyp(i), fndr, work, allele_buffer2) call twopoi(locpos(trait),loc(trait), locpos(i), loc(i), & allele_buffer, allele_buffer2, work, plevel) end if end do end if else do i=1, nloci if (same_loctyp(loctyp(i), LOC_CODOM) .and. irupt == 0) then if (trait /= MISS) then call freq(locpos(trait), loctyp(trait), fndr, work, allele_buffer) call freq(locpos(i), loctyp(i), fndr, work, allele_buffer2) call twopoi(locpos(trait),loc(trait), locpos(i), loc(i), & allele_buffer, allele_buffer2, work, plevel) end if trait=i end if end do end if ! ! Variance components analysis ! typ 1=CE 2=AE 3=ACE 4=ADE ! 5=AQE (6=AQE with empirical kinship) ! 7=CQE (8=AQE wth ibd matrix in script) ! else if ((keyword == 'var' .or. keyword == 'mft') .and. red) then call gettrait(words(2), LOC_QUA, LOC_AFF, nloci, loc, lochash, loctyp, trait, 0) if (trait /= MISS) then nord=0 modtyp=GLM_GAUSS if (keyword == 'mft') modtyp = GLM_BINOM typ=4 i=3 gene=MISS nmarklist=0 do while (i <= narg) if (words(i) /= '+') keyword=words(i)(1:3) if (keyword == 'ce' .or. keyword == 'CE') then typ=1 i=i+1 else if (keyword == 'ae' .or. keyword == 'AE') then typ=2 i=i+1 else if (keyword == 'ace' .or. keyword == 'ACE') then typ=3 i=i+1 else if (keyword == 'ade' .or. keyword == 'ADE') then typ=4 i=i+1 else if (keyword == 'ge' .or. keyword == 'GE') then typ=9 i=i+1 else if (keyword == 'aqe' .or. keyword == 'AQE') then typ=5 if (words(i+1)=='ibs') then typ=6 else if (words(i+1)=='inline') then typ=8 else call gettrait(words(i+1), LOC_CODOM, 0, & nloci, loc, lochash, loctyp, k, 0) if (k /= MISS) then if (nmarklist < MAXMULT) then nmarklist=nmarklist+1 marklist(nmarklist)=k end if else write(outstr,'(3a)') & 'Skipping "', trim(words(i+1)), '": not an active marker.' end if end if i=i+2 else if (keyword == 'lik') then typ=typ+128 i=i+1 else if (keyword == 'cov' .and. i < narg) then call gettrait(words(i+1), LOC_ANY, 0, nloci, loc, lochash, loctyp, k, 0) if (k /= MISS) then nord=nord+1 locord(nord)=k else write(outstr,'(3a)') & 'Skipping "', trim(words(i+1)), '": not an active trait.' end if i=i+2 else write(outstr,'(3a)') 'Skipping unknown keyword "', trim(words(i)), '".' i=i+1 end if end do nord=nord+1 locord(nord)=trait gene=findml(nord, locord, loctyp) whlik=3-whlik mcall(whlik)=trim(lin) ! enumerate levels for covariate marker and ! calculate fixed effects starting values if (gene /= MISS) then call freq(locpos(gene), loctyp(gene), fndr, work, allele_buffer) end if call varcom(modtyp, nord, locord, nloci, loc, loctyp, locpos, & gene, genemod, allele_buffer, nmarklist, marklist, & work, nobs, mlik(whlik), mpar(whlik), pval, & plevel, burnin, iter, typ, invalg, optim, toler) else write(outstr,'(a)') 'ERROR: Need to specify trait.' end if else if (keyword == 'blu' .and. red) then ridge_constant = 0.0d0 call gettrait(words(2), LOC_ANY, 0, nloci, loc, lochash, loctyp, trait, 0) if (trait /= MISS) then typ=1 typ2=1 if (same_loctyp(loctyp(trait), LOC_CODOM)) typ=typ+1 gt=COMP_NE thresh=MISS censor=MISS gene=MISS i=3 do while (i <= narg) if (words(i) == 'kin' .and. narg > i) then call get_filnam(lin, i+1, wrkfil) if (wrkfil == 'G' .or. wrkfil == '-') then ifail=has_kinmat() if (ifail == 0) then typ2=2 write(outstr,'(a)') 'Using current kinship matrix.' else write(outstr,'(a)') 'ERROR: No kinship matrix defined.' end if i=i+2 else write(outstr,'(3a)') & 'Using kinship matrix from "', trim(wrkfil), '".' i=i+2 if ((narg >= i .and. isreal(words(i))) .or. & (narg > i .and. words(i)(1:3) == 'rid' .and. & isreal(words(i+1)))) then if (words(i)(1:3) == 'rid') i=i+1 ridge_constant = fval(words(i)) write(outstr,'(a,f7.5,a)') & 'Using ridge constant = ', ridge_constant, '.' i=i+1 end if call readkin(wrkfil, ridge_constant, hashtab, work, ifail, plevel) if (ifail == 0) then typ2=2 else write(outstr,'(a)') 'ERROR: Could not read kinship file!' i=i+1 end if end if else if (typ == 1) then if (isreal(words(i))) then h2=fval(words(i)) if (h2 > 1.0D0) then h2=0.99D0 else if (h2 /= MISS .and. h2 <= 0.0D0) then h2=0.01D0 end if else call gettrait(words(i), LOC_QUA, 0, & nloci, loc, lochash, loctyp, gene, 0) if (gene /= MISS) then write(outstr,'(2a)', advance='no') & 'Saving BLUPs to trait: ', trim(loc(gene)) gene=locpos(gene) end if end if i=i+1 else if (typ == 2) then call gettrait(words(i), LOC_TRA, 0, & nloci, loc, lochash, loctyp, censor, 0) i=i+1 if (censor /= MISS) then if (narg >= i) then keyword=words(i)(1:3) if (iscomp(keyword)) call docomp(i, words, gt, thresh) end if write(outstr,'(2a)', advance='no') & 'Subsetting on trait: ', trim(loc(censor)) call defpro(gt, thresh, .false.) censor=locpos(censor) end if end if end do if (typ == 2) then call freq(locpos(trait), loctyp(trait), fndr, work, allele_buffer) if (typ2 == 1) then call bluefreq(locpos(trait), censor, gt, thresh, work, & allele_buffer, plevel) else call bigblue(locpos(trait), censor, gt, thresh, work, & allele_buffer, plevel) end if if (censor == MISS) then call wrfreq(outstr, loc(trait), group(trait), map(trait), & locnotes(trait), allele_buffer, 21) end if else if (typ == 1) then if (trait /= MISS .and. h2 /= MISS) then call doblup(loc(trait), locpos(trait), h2, gene, work, plevel) else write(outstr,'(a)') 'ERROR: Need to specify trait and heritability.' end if else write(outstr,'(a)') 'ERROR: BLUPs not implemented for trait type.' end if if (typ2 == 2) call free_kin(plevel) else write(outstr,'(a)') 'ERROR: Need to specify trait.' end if ! ! MFT ! else if ((keyword == 'gri') .and. red) then call gettrait(words(2), LOC_AFF, 0, nloci, loc, lochash, loctyp, trait, 0) if (trait /= MISS) then pars(1)=0.0d0 pars(2)=1.0d0 pars(3)=10.0d0 typ=1 n=1 do i= 3, narg if (words(i) == 'ce' .or. words(i) == 'CE') then typ=2 else if (words(i) == 'ae' .or. words(i) == 'AE') then typ=1 else if (isreal(words(i))) then if (n == 1) then pars(n)=max(0.0d0, fval(words(i))) else if (n == 2) then pars(n)=min(1.0d0, fval(words(i))) else if (n == 3) then pars(n)=fval(words(i)) end if n=n+1 else write(outstr,'(3a)') 'Skipping unknown keyword "', trim(words(i)), '".' end if end do whlik=3-whlik mcall(whlik)=trim(lin) write(outstr,'(/a/3a/a)') & '------------------------------------------------------', & 'Multifactorial threshold model for trait "', trim(loc(trait)), '"', & '------------------------------------------------------' call domft(locpos(trait), prevalence, pars(1), pars(2), pars(3), & work, mlik(whlik), mpar(whlik), statval(1), iter, typ, plevel) else write(outstr,'(a)') 'ERROR: Need to specify binary trait.' end if ! ! Bourgain etc QLS tests for categorical trait association ! typ=W/MQLS typ1=binary WQLS typ2=pedigree/empirical kinship ! else if ((keyword == 'wql' .or. keyword == 'mql') .and. red) then call gettrait(words(2), LOC_TRA, 0, nloci, loc, lochash, loctyp, trait, 0) if (trait /= MISS) then typ=1 typ1=1 typ2=1 robvar=2 words(1)='WQLS' if (keyword == 'mql') then typ=2 words(1)='MQLS' end if write(outstr,'(/a/4a/a)') & '--------------------------------------------------', & trim(words(1)), ' association testing for trait "', & trim(loc(trait)), '"', & '--------------------------------------------------' trait=locpos(trait) wrkfil=' ' gt=0 thresh=MISS qprev=prevalence ridge_constant = 0.0d0 i=3 if (iscomp(words(i)(1:3))) then call docomp(i, words, gt, thresh) if (typ == 1) then typ=2 typ1=2 end if end if do while (i <= narg) if (words(i) == 'kin' .and. narg > i) then i=i+1 call get_filnam(lin, i, wrkfil) if (wrkfil == 'G') then ifail=has_kinmat() if (ifail == 0) then write(outstr,'(a)') 'Using current kinship matrix.' end if else write(outstr,'(3a)') & 'Using kinship matrix from "', trim(wrkfil), '".' call readkin(wrkfil, ridge_constant, hashtab, work, ifail, plevel) end if if (ifail == 0) then typ2=2 else write(outstr,'(a)') 'ERROR: Could not read kinship file!' end if else if (words(i)(1:3) == 'rid' .and. narg > i) then if (isreal(words(i+1))) then ridge_constant = fval(words(i+1)) write(outstr,'(a,f7.5,a)') & 'Using ridge constant = ', ridge_constant, '.' i=i+1 end if else if (words(i)(1:3) == 'rob') then robvar=2 write(outstr,'(a)') 'Using robust null variance estimator.' else if (words(i)(1:3) == 'hwe') then robvar=1 write(outstr,'(a)') 'Using HWE null variance estimator.' else if (words(i)(1:3) == 'wql') then typ1=2 else if (words(i)(1:3) == 'pre' .and. narg > i) then if (isreal(words(i+1))) then qprev=fval(words(i+1)) i=i+1 end if else write(outstr,'(3a)') & 'Unrecognized keyword: "', trim(words(i)), '".' end if i=i+1 end do if (thresh /= MISS) call defpro(gt, thresh, .true.) if (typ > 1 .and. qprev /= MISS) then write(outstr,'(a,f6.4)') 'Trait model prevalence = ', qprev end if if (fixfreq /= MISS) then call gettrait(fixmarker, LOC_CODOM, 0, nloci, loc, lochash, loctyp, fixfreq, 0) write(outstr,'(/a)') & 'NOTE: Population allele frequencies are prespecified as:' call wrfreq(outstr, fixmarker, group(fixfreq), map(fixfreq), & locnotes(fixfreq), fixfreq_buffer, 15) end if if (plevel == -1 .or. plevel == 0) then write(outstr,'(/a/a)') & 'Marker Typed Allels Chi-square Asy P ', & '-------------------- ------ ------ ---------- ------' end if call setup_stat(lin) if (typ == 1) then gt=COMP_NE thresh=MISS if (fixfreq /= MISS) then call corchi(typ2, trait, loctyp(trait), locpos(fixfreq), loc(fixfreq), & hashtab, work, fixfreq_buffer, iter, pval, plevel) locstat(fixfreq)=pval else do i=1, nloci if (same_loctyp(loctyp(i), LOC_CODOM) .and. irupt == 0) then call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) if (typ2 == 1) then call bluefreq(locpos(i), trait, gt, thresh, work, & allele_buffer, plevel-2) else call bigblue(locpos(i), trait, gt, thresh, work, & allele_buffer, plevel-2) end if call corchi(typ2, trait, loctyp(trait), locpos(i), loc(i), & hashtab, work, allele_buffer, iter, pval, plevel) locstat(i)=pval end if end do end if else if (typ2 == 1) then do i=1, nloci if (same_loctyp(loctyp(i), LOC_CODOM) .and. irupt == 0) then call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) ! Precalculate BLUEs if generating per-family empirical P-values if (iter > 0 .and. plevel > 0) then call bluefreq(locpos(i), MISS, COMP_NE, toler(1), work, & allele_buffer, plevel) end if call domqls(typ1, trait, gt, thresh, locpos(i), loc(i), qprev, & robvar, work, allele_buffer, iter, pval, plevel) locstat(i)=pval end if end do else if (typ2 == 2) then do i=1, nloci if (same_loctyp(loctyp(i), LOC_CODOM) .and. irupt == 0) then call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) call big_mqls(typ1, trait, gt, thresh, locpos(i), loc(i), qprev, & robvar, work, allele_buffer, pval, plevel) locstat(i)=pval end if end do end if if (typ2 == 2) call free_kin(plevel) else write(outstr,'(a)') 'ERROR: Need to specify trait.' end if ! ! Quick random effects version of stratified SNP association test ! else if ((keyword == 'str' .or. keyword == 'int') .and. red) then call gettrait(words(2), LOC_TRA, 0, nloci, loc, lochash, loctyp, trait, 0) typ=1 if (keyword == 'int') typ=2 gt=0 thresh=MISS gene=MISS xtab_sample_weight=MISS i=3 if (iscomp(words(i))) then call docomp(i, words, gt, thresh) end if if (narg > i .and. words(narg-1) == 'sampleweight') then call gettrait(words(narg), LOC_TRA, 0, nloci, loc, lochash, loctyp, & xtab_sample_weight, 0) if (xtab_sample_weight /= MISS) then xtab_sample_weight=locpos(xtab_sample_weight) end if narg=narg-2 end if if (narg > i) then call gettrait(words(i), LOC_ANY, 0, nloci, loc, lochash, loctyp, gene, 0) call gettrait(words(i+1), LOC_TRA, 0, nloci, loc, lochash, loctyp, censor, 0) else call gettrait(words(i), LOC_TRA, 0, nloci, loc, lochash, loctyp, censor, 0) end if if (trait /= MISS .and. censor /= MISS) then if (loctyp(trait) == LOC_AFF .or. gt > 0) then write(outstr,'(/a/5a/a)') & '--------------------------------------------------------------', & 'Association test for trait "', trim(loc(trait)), & '" stratified on "', trim(loc(censor)), '"', & '--------------------------------------------------------------' if (gt > 0) call defpro(gt, thresh, .true.) if (typ == 2) then write(outstr,'(a)') 'Test of between-stratum heterogeneity:' end if if (plevel == -1 .or. plevel == 0) then write(outstr,'(/a/a)') & 'Marker Typed Strata Chi-square Asy P ', & '-------------------- ------ ------ ---------- ------' end if if (gene /= MISS) then if (same_loctyp(loctyp(gene), LOC_CODOM)) then call freq(locpos(gene), loctyp(gene), fndr, work, allele_buffer) end if call whitehead(locpos(trait), gt, thresh, loc(gene), & locpos(gene), loctyp(gene), allele_buffer, & loc(censor), locpos(censor), loctyp(censor), & locnotes(censor), xtab_sample_weight, & work, pval, typ, plevel) else call setup_stat(lin) do i=1, nloci if (same_loctyp(loctyp(i), LOC_CODOM) .and. irupt == 0) then call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) call whitehead(locpos(trait), gt, thresh, loc(i), locpos(i), & loctyp(i), allele_buffer, loc(censor), & locpos(censor), loctyp(censor), locnotes(censor), & xtab_sample_weight, work, pval, typ, plevel) locstat(i)=pval end if end do if (plevel < -1) then call sumstat(5, plevel) end if end if else write(outstr,'(a)') 'ERROR: Trait must be binary or dichotomized.' end if else write(outstr,'(a)') 'ERROR: Need to specify trait and stratifying covariate.' end if ! ! SML/Finite polygenic/mixed/GLMM MCMC sampler ! else if (keyword == 'fpm' .and. red) then call gettrait(words(2), LOC_QUA, LOC_AFF, nloci, loc, lochash, loctyp, trait, 0) if (trait /= MISS) then mcp=.false. censor=MISS gene=MISS off=MISS call mksegmod(narg, words, trait, gt, thresh, off, censor, & nord, locord, nloci, loc, lochash, loctyp, & priran, nqtl, linkf, modtyp, shap) if (nord > 1) then gene=findml(nord, locord, loctyp) ! enumerate levels for covariate marker and ! calculate fixed effects starting values and scales if (gene /= MISS) then call freq(locpos(gene), loctyp(gene), fndr, work, allele_buffer) end if if (modtyp==1) then call regress(-1, nord, locord, nloci, loc, loctyp, locpos, & gene, genemod, allele_buffer, work, & mlik(whlik), mpar(whlik), pval, plevel) else if (linkf /= LINK_ID .and. modtyp == GLM_BINOM) then call binreg(GLM_BINOM, nord, locord, nloci, loc, loctyp, locpos, & off, censor, gene, genemod, allele_buffer, & mcp, useimp, .false., iter, mincnt, work, & shap, lrts, mdf, statval, pval, plevel) else if ((linkf == LINK_LOG .and. modtyp == GLM_POISS) .or. & modtyp == GLM_WEIB) then call binreg(modtyp, nord, locord, nloci, loc, loctyp, locpos, & off, censor, gene, genemod, allele_buffer, & mcp, useimp, .false., iter, mincnt, work, & shap, lrts, mdf, statval, pval, plevel) else if (modtyp == GLM_GAMMA) then call binreg(GLM_EXPON, nord, locord, nloci, loc, loctyp, locpos, & off, censor, gene, genemod, allele_buffer, & mcp, useimp, .false., iter, mincnt, work, & shap, lrts, mdf, statval, pval, plevel) end if end if whlik=3-whlik mcall(whlik)=trim(lin) call segsim(linkf, modtyp, shap, trait, gt, thresh, off, & censor, nord, locord, gene, genemod, allele_buffer, & nloci, loc, loctyp, locpos, & burnin, iter, nbatch, nsamples, tune, nchain, & nqtl, work, mlik(whlik), mpar(whlik), priran, mcalg, plevel) else write(outstr,'(a)') 'ERROR: Need to specify trait.' end if ! ! quantitative trait measured genotype analysis - mixed (AE) model MVN or MFT, ! or binary trait measured genotype analysis - currently sibships ! else if (keyword == 'mgt' .and. red) then call gettrait(words(2), LOC_AFF, LOC_QUA, nloci, loc, lochash, loctyp, trait, 0) if (trait /= MISS) then modtyp=GLM_GAUSS ncovars=0 nord=0 i=3 typ=1 sta=1 fin=nloci if (use2 == 3) typ=typ+1 call gettrait(words(i), LOC_CODOM, 0, nloci, loc, lochash, loctyp, mark, 0) if (mark /= MISS) then sta=mark fin=mark i=i+1 end if if (words(i)(1:3) == 'cov') then call loadnam(i+1, narg, words, nloci, loc, lochash, loctyp, group, map, & locstat, wloc, nord, locord, LOC_ANY, 1) ncovars=nord end if write(outstr,'(/a/3a/a/)') & '------------------------------------------------', & 'Measured genotype analysis for trait "', trim(loc(trait)), '"', & '------------------------------------------------' if (plevel == -1 .or. plevel == 0) then write(outstr,'(a/a)') & 'Marker Typed Allels Chi-square Asy P ', & '-------------------- ------ ------ ---------- ------' end if if (loctyp(trait) == LOC_AFF .and. words(narg) == 'sib') then narg=narg-1 trait=locpos(trait) if (narg > 2 .and. words(3)(1:3) /= 'cov') then call gettrait(words(3), LOC_CODOM, 0, nloci, loc, lochash, loctyp, gene, 0) if (trait /= MISS .and. gene /= MISS) then call freq(locpos(gene), loctyp(gene), fndr, work, allele_buffer) call sibass(trait, loc(gene), locpos(gene), allele_buffer, & work, iter, typ, pval, plevel) else write(outstr,'(a)') 'ERROR: Needed to specify a codominant autosomal marker.' end if else call setup_stat(lin) do i=sta, fin if (same_loctyp(loctyp(i), LOC_CODOM) .and. irupt == 0) then call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) call sibass(trait, loc(i), locpos(i), allele_buffer, & work, iter, typ, pval, plevel) locstat(i)=pval end if end do end if else if (loctyp(trait) == LOC_AFF) modtyp = GLM_BINOM nmarklist=0 nord=ncovars+1 locord(nord)=trait typ=130 whlik=2 call varcom(modtyp, nord, locord, nloci, loc, loctyp, locpos, & MISS, genemod, allele_buffer, nmarklist, marklist, & work, nobs, mlik(1), mpar(1), pval, & plevel-2, burnin, iter, typ, invalg, optim, toler) call addtmpvar('DOSE', work, gene, ifail) if (ifail /= 0) then write(outstr,'(a)') 'ERROR: Memory allocation problem.' cycle end if call setup_stat(lin) do i=sta, fin if (same_loctyp(loctyp(i), LOC_CODOM) .and. irupt == 0) then call freq(locpos(i), loctyp(i), fndr, work, allele_buffer) if (allele_buffer%numal == 2) then call dopeel(2, locpos(i), locpos(gene), emiter, allele_buffer, & work, mlik(whlik), plevel-2) typ=130 nord=ncovars+2 locord(ncovars+1)=gene locord(nord)=trait call varcom(modtyp, nord, locord, nloci, loc, loctyp, locpos, & MISS, genemod, allele_buffer, nmarklist, marklist, & work, nobs, mlik(2), mpar(2), pval, & plevel-2, burnin, iter, typ, invalg, optim, toler) expr(1,1)=mlik(1)-mlik(2) df=mpar(2)-mpar(1) pval=chip(expr(1,1), df) if (plevel > 0) then write(outstr,'(/a/a)') & 'Marker Typed Allels Chi-square Asy P ', & '-------------------- ------ ------ ---------- ------' end if write(outstr,'(a20,2(a1,i6),a1,f10.1,a1,a6)') & loc(i), tabsep, nobs, tabsep, & allele_buffer%numal, tabsep, expr(1,1), tabsep, pstring(pval) locstat(i)=pval end if end if end do end if else write(outstr,'(a)') 'ERROR: Needed to specify a trait.' end if ! ! classical twin analyses else if ((keyword == 'twi' .or. keyword == 'ken') .and. red) then censor=MISS call gettrait(words(2), LOC_QUA, LOC_AFF, nloci, loc, lochash, loctyp, trait, 0) if (trait /= MISS) then i=3 if (keyword == 'ken') then call gettrait(words(i), LOC_QUA, LOC_AFF, nloci, loc, lochash, loctyp, censor, 0) if (loctyp(trait) /= LOC_QUA) censor=MISS i=i+1 end if call gettrait(words(i), LOC_QUA, LOC_AFF, nloci, loc, lochash, loctyp, gene, -1) gt=0 thresh=MISS ! while not end of list of keywords i=i+1 if (gene == MISS) i=i-1 do while (i <= narg) keyword=words(i)(1:3) if (iscomp(keyword)) then call docomp(i, words, gt, thresh) else write(outstr,'(3a)') 'Skipping unknown keyword "', trim(words(i)), '".' i=i+1 end if end do if (gene == MISS .and. twintrait /= ' ') then call gettrait(twintrait, LOC_ANY, 0, nloci, loc, lochash, loctyp, gene, 0) end if if (gene /= MISS) then if ((loctyp(gene) == LOC_CAT .or. loctyp(gene) == LOC_QUA) .and. & thresh == MISS) then thresh=0.0d0 gt=COMP_GT if (twintype==2) gt=COMP_ODD end if if (censor /= MISS) then call twinken(loc(trait), locpos(trait), & loc(censor), locpos(censor), & locpos(gene), gt, thresh, work, & iter, mincnt, norder, plevel) else if (loctyp(trait) == LOC_QUA) then call twincor(loc(trait), locpos(trait), locpos(gene), gt, thresh, work, plevel) else call twincon(loc(trait), locpos(trait), locpos(gene), gt, thresh, work, plevel) end if else write(outstr,'(a)') 'No twin indicator specified.' end if else if (twintrait /= ' ') then call gettrait(twintrait, LOC_ANY, 0, nloci, loc, lochash, loctyp, gene, 0) if (gene /= MISS) then if ((loctyp(gene) == LOC_CAT .or. loctyp(gene) == LOC_QUA) .and. & thresh == MISS) then thresh=0.0d0 gt=COMP_GT if (twintype==2) gt=COMP_ODD end if call twinrate(locpos(gene), gt, thresh, work, plevel) else write(outstr,'(a)') 'No twin indicator specified.' end if else write(outstr,'(a)') 'Need to specify trait and twin indicator.' end if else if (keyword == 'lrt' .and. red) then expr(1,1)=mlik(whlik)-mlik(3-whlik) i=mpar(3-whlik)-mpar(whlik) if (i < 0) then i=-i expr(1,1)=-expr(1,1) end if pval=chip(expr(1,1),i) if (plevel > -2) then write(outstr,'(/a/a/2(a,f12.4,i5,9x,a/),a,f12.4,i5,2x,a6,1x,a)') & 'Term -2*LL NPar P-value', & '------ ----------- ---- -------', & 'Model0', mlik(3-whlik), mpar(3-whlik), trim(mcall(3-whlik)), & 'Model1', mlik(whlik), mpar(whlik), trim(mcall(whlik)), & 'LRTS ', expr(1,1), i, pstring(pval), trim(words(2)) end if ! SML predicted genotype frequencies in relatives else if (keyword == 'ito') then typ=1 if (narg>2) typ=typ+1 do i=2, narg pars(i-1)=fval(words(i)) end do do i=narg+1, 4 pars(i-1)=0.0d0 end do call doito(typ, pars) ! SML predicted recurrence risks, ibd sharing etc else if (keyword == 'grr') then if (narg >= 4) then write(outstr,'(3(/a))') & '------------------------------------------------', & 'Single Major Locus Recurrence Risk Calculation', & '------------------------------------------------' if (words(5)(1:3) == 'cas') then typ=1 if (words(6)(1:3) == 'pop') typ=2 call ccpen(fval(words(2)), fval(words(3)), fval(words(4)), typ) else call grrpen(words(5)(1:3), fval(words(2)), fval(words(3)), fval(words(4))) end if else write(outstr,'(a)') 'ERROR: Need to specify prevalence etc for risk calculation!' end if else if (keyword == 'sml') then pars=0.0d0 if (keyw2 == 'age') then if (narg >= 4) then do i=3, narg pars(i-2)=fval(words(i)) end do call mutage(pars(1), pars(2), pars(3)) else write(outstr,'(a)') 'ERROR: Need to specify p, N [,r]!' end if else typ=1 do i=2, narg pars(i-1)=fval(words(i)) if (pars(i-1) > 1.0d0 .or. pars(i-1) < 0.0d0) typ=2 end do if (narg > 5) typ=2 if (typ == 2 .and. narg >= 5 .and. narg < 8) then j=max(5,narg-1) do i=narg+1, 8 pars(i-1)=pars(j) end do end if if (typ == 1 .and. narg >= 2) then write(outstr,'(3(/a))') & '------------------------------------------------', & 'Single Major Locus Recurrence Risk Calculation', & '------------------------------------------------' call recrisk(pars(1), pars(2), pars(3), pars(4)) else if (typ == 2 .and. narg >= 2) then write(outstr,'(3(/a))') & '------------------------------------------------', & 'Quantitative Trait SML Expectations', & '------------------------------------------------' call qtlpars(pars(1), pars(2), pars(3), pars(4), & pars(5), pars(6), pars(7)) end if end if ! Contingency chi-square else if (keyword == 'chi' .or. keyword == 'pol') then i=ival(words(2)) j=ival(words(3)) typ=1 if (keyword == 'pol') typ=typ+1 if (i > 1 .and. j > 1) then call rcp(typ, i, j, narg, words(1:narg), iter) else write(outstr,'(a)') 'Give number of rows and columns in table!' end if ! CI for a proportion else if (keyword == 'pro') then i=ival(words(2)) j=ival(words(3)) tmp=95.0d0 if (narg > 3) tmp=fval(words(4)) call wrpropci(i, j, tmp) ! Noncentral chi-square for LR test power else if (keyword == 'pow') then expr(1,1)=1.0d0 ncp=0.0d0 lrts=3.84d0 tmp=1.0d0 ! while not end of list of keywords j=0 i=2 do while (i <= narg) keyword=words(i)(1:3) if (keyword == 'ncp') then ncp=fval(words(i+1)) i=i+2 else if (keyword == 'N' .or. keyword == 'n' .or. keyword == 'num') then if (j < maxwords) then j=j+1 expr(j,1)=fval(words(i+1)) end if i=i+2 else if (keyword == 'df') then tmp=fval(words(i+1)) lrts=chisqd(0.05d0, nint(tmp)) i=i+2 else if (keyword == 'p' .or. keyword == 'pva') then lrts=chisqd(fval(words(i+1)), nint(tmp)) i=i+2 else if (isreal(words(i))) then ncp=fval(words(i)) i=i+1 else write(outstr,'(3a)') 'Skipping unknown keyword "', & words(i)(1:len_trim(words(i))),'".' i=i+1 end if end do if (j > 1 .or. plevel > 0) then write(outstr,'(a/a)') & ' Crit Chi-sq df Alpha NCP N Power', & '------------ ------ ---------- ------------ ------ ------' do i=1, max(1,j) ch=' ' last_result=1.0d0-chi2nc(lrts, tmp, expr(i,1)*ncp, ifault) if (ifault /= 0) ch='?' write(outstr,'(f12.2,1x,i6,1x,g10.3,1x,f12.4,1x,i6,1x,f6.4,1x,a1)') & lrts, int(tmp), chip(lrts,int(tmp)), ncp, int(expr(i,1)), & last_result, ch end do else last_result=1.0d0-chi2nc(lrts, tmp, expr(1,1)*ncp, ifault) if (ifault /= 0) then write(outstr,'(a,i0,a)') 'ERROR: chi2nc() IFAULT=', ifault,'.' write(outstr,*) ' crit x2=', lrts, 'df=', tmp, & 'ncp=', expr(1,1)*ncp end if write(outstr,*) last_result end if else if (keyword == 'qch') then tmp=fval(words(2)) i=ival(words(3)) last_result=chisqd(tmp, i) write(outstr,*) last_result else if (keyword == 'pch') then tmp=fval(words(2)) i=ival(words(3)) if (narg == 3) then last_result=chip(tmp, i) write(outstr,*) last_result else if (narg == 4) then j=ival(words(4)) last_result=fp(tmp, i, j) write(outstr,*) last_result else if (words(4) == 'ncp') then lrts=fval(words(2)) i=ival(words(3)) ncp=fval(words(5)) last_result=1.0d0-chi2nc(lrts, dble(i), ncp, ifault) if (ifault /= 0) then write(outstr,'(a,i0,a)') 'ERROR: chi2nc() IFAULT=', ifault,'.' end if write(outstr,*) last_result else write(outstr,'(a)') & 'ERROR: Expected 2 (Chi-sq) or 3 (F-dist) numerical arguments.' end if else if (keyword == 'tet') then if (narg == 3) then last_result=tetcor(fval(words(2)), fval(words(3))) write(outstr,*) last_result else if (narg == 4) then last_result=mvbvu(ppnd(fval(words(2))), ppnd(fval(words(3))), & fval(words(4))) write(outstr,*) last_result else write(outstr,'(a)') & 'ERROR: Expected prop1, prop2 and correlation.' end if ! ! History ! logfile has 3 line header then commands else if (keyword == 'las') then if (logstr /= 0) then if (narg == 1) then rewind(logstr) do i=1, 3 read(logstr, '(a)') lin write(*,'(a)') trim(lin) end do pos=1 if (plevel < 1) pos = max(pos, nhis-100) do i=1, pos-1 read(logstr, '(a)') lin end do do i=pos, nhis read(logstr, '(a)') lin write(*,'(i0,2a)') i,': ', trim(lin) end do else if (ilevel == 1 .and. isint(words(2))) then ilevold=ilevel ilevel=0 k=ival(words(2)) if (nhis == 0) then write(*,'(a)') 'No commands in history!' commands=' ' cycle main_loop else if (k == 0 .or. k > nhis) then k=nhis else if (nhis+k < 0) then write(*,'(a)') 'No commands that far back in history!' commands=' ' cycle main_loop else if (k < 0) then k=nhis+k+1 end if rewind(logstr) do i=1, 3 read(logstr,*) end do do i=1, k read(logstr,'(a)') commands end do write(*,'(i4,2a)') k,': ',commands(1:len_trim(commands)) do i=k+1, nhis read(logstr,*) end do end if else write(*,'(a)') 'Logfile not available.' end if ! Reset program else if (keyword == 'cle') then call cleanup_hash(hashtab) call cleanup_hash(lochash) call cleanup_peds(work) call cleanup_alleles(allele_buffer) if (allocated(coltyp)) deallocate(coltyp) red=.false. nloci=0 numloc=0 numcol=0 call setup_auto() if (keyw2 /= 'dat') go to 999 else if (keyword(1:1) == ' ') then continue ! close script or exit else if (keyword == 'sto' .or. keyword == 'qui' .or. & keyword == 'exi' .or. keyword(1:2) == 'by') then if (ilevel > 1) then call flush(outstr) n=1 if (keyword == 'exi') n=ilevel-1 do i=1, n if (plevel > -2) then write(outstr,'(/3a/)') & 'Closing include file "', trim(infil(ilevel)), '".' end if if (incaction(ilevel) < 3) then close(incstr(ilevel), status='keep') else close(incstr(ilevel), status='delete') end if ilevel=ilevel-1 toplevel=toplevel-1 end do if (keyword /= 'exi') cycle end if exit main_loop ! run scheme interpreter else if (keyword == 'eva') then typ=1 if (words(2) == 'resume') then typ=5 else if (narg > 1) then typ=typ+1 end if call repl_scheme(typ, plevel) ! Define a macro variable or function else if (keyword == 'mac') then call args(lin, narg, words, ' ', SEP_WH_RES) macname=words(2) scheme_lin=' ' ! assoc array if (words(3) == '[' .and. words(5) == ']' .and. words(6) == '=') then if (.not.isahash(trim(macname))) then scheme_lin='(define ' // trim(macname) // ' (hash ''make)) ' end if scheme_lin=trim(scheme_lin) // ' (hash ''set! ' // trim(macname) // & ' "' // trim(words(4)) // '" "' // & adjustl(lin((index(lin(1:linlen), '=')+1):linlen)) // '")' ! atomic variable else if (words(3) == '=') then scheme_lin=adjustl(lin((index(lin(1:linlen), '=')+1):linlen)) call escape(scheme_lin,'"') scheme_lin='(define ' // trim(macname) // ' "' // trim(scheme_lin) // '")' ! saving Sib-pair state variables else if (words(3) == '<') then i=4 if (words(i) == '-') i=i+1 if (words(i)(1:3) == 'ple') then write(scheme_lin, '(i0)') plevel else if (words(i)(1:3) == 'pri') then scheme_lin='00000' do j=1, 5 if (pedmask(j)) then scheme_lin(j:j)='1' end if end do else if (words(i)(1:3) == 'imp') then write(scheme_lin, '(i0)') imp else if (words(i)(1:3) == 'ite') then write(scheme_lin, '(i0)') iter else if (words(i)(1:3) == 'bur') then write(scheme_lin, '(i0)') burnin else if (words(i)(1:3) == 'min') then write(scheme_lin, '(i0)') mincnt else if (words(i)(1:3) == 'che') then scheme_lin='off' if (chek) scheme_lin='on' else if (words(i)(1:3) == 'epo') then write(scheme_lin, '(f10.0)') epoch else if (words(i)(1:3) == 'see') then write(scheme_lin, '(i0,1x,i0,1x,i0)') ix, iy, iz else if (words(i)(1:3) == 'twi') then scheme_lin=trim(twintrait) else if (words(i)(1:3) == 'sex') then scheme_lin=trim(sexmarker) else if (words(i)(1:3) == 'pwd') then #if IFORT i=getcwd(scheme_lin) #else call getcwd(scheme_lin) #endif #if WIN32 call escape(scheme_lin, '\') call escape(scheme_lin, '\') #endif else if (words(i) == 'ls') then do i=1, nloci if (loctyp(i) < LOC_DEL) then scheme_lin=trim(scheme_lin) // ' ' // trim(loc(i)) end if end do else if (words(i)(1:3) == 'all' .or. words(i)(1:3) == 'fre') then call gettrait(words(i+1), LOC_CODOM, LOC_XLIN, nloci, loc, lochash, loctyp, gene, 0) if (gene /= MISS) then call freq(locpos(gene), loctyp(gene), fndr, work, allele_buffer) if (words(i)(1:3) == 'all') then do i=1, allele_buffer%numal call wrall(allele_buffer%allele_names(i), charnum) scheme_lin=trim(scheme_lin) // ' ' // trim(adjustl(charnum)) end do else do i=1, allele_buffer%numal write(charnum,'(f6.4)') allele_buffer%allele_freqs(i) scheme_lin=trim(scheme_lin) // ' ' // trim(adjustl(charnum)) end do end if end if else if (words(i)(1:3) == 'lik') then write(scheme_lin, '(g14.6,1x,i0)') mlik(whlik), mpar(whlik) else if (words(i)(1:3) == 'pva') then write(scheme_lin, '(g14.6)') pval else if (words(i)(1:3) == 'las') then write(scheme_lin, '(g14.6)') last_result else write(outstr,'(3a)') & 'ERROR: State of "', trim(words(i)),'" not savable.' scheme_lin='' end if scheme_lin='(define ' // trim(macname) // ' "' // trim(scheme_lin) // '")' else if (isafun(trim(words(2))) == 0) then oldnam=isinuse(.true., words(2), loc, lochash) if (oldnam) then write(outstr,'(3a)') & 'ERROR: "', trim(words(2)),'" in use or reserved.' cycle main_loop end if end if i=1 do if (ilevel==1) then write(outstr,'(2a)', advance='no') trim(macname),'> ' read(*,'(a)', iostat=ioerr) lin else read(incstr(ilevel), '(a)', iostat=ioerr) lin end if if (lin==' ' .or. lin(1:4)==';;;;' .or. ioerr /=0) exit eos=len_trim(lin) if (i+eos-1 > len(scheme_lin)) then write(outstr,'(a,i0,a)') & 'ERROR: Macro buffer only ', len(scheme_lin), ' characters.' exit end if call args(lin, narg, words, ' ', SEP_WH_RES) if (words(1)(1:3) == 'mac' .and. & words(3) /= '=' .and. words(3) /= '<') then write(outstr,'(a)') & 'ERROR: Attempting to nest macro function definitions.' exit end if if (words(1)(1:1) == '#' .or. words(1)(1:1) == '!') then continue #if defined (WIN32) || defined (IFORT) || defined (NOESCAPE) else if (words(narg) /= '\') then #else else if (words(narg) /= '\\') then #endif scheme_lin(i:i+eos-1)=trim(lin) i=i+eos scheme_lin(i:i)=';' else eos=eos-1 scheme_lin(i:i+eos-1)=lin(1:eos) i=i+eos end if i=i+1 end do scheme_lin((i-1):(i-1))=' ' call escape(scheme_lin,'"') scheme_lin='(define ' // trim(macname) // & ' (cons "*sp-fun*" "' // trim(scheme_lin) // '"))' end if call repl_scheme(3,0) ! else maybe an expression? else call args(lin, narg, words, ' ', SEP_WH_RES) nterm=narg if (keyword == 'let') then do i=2, nterm words(i-1)=words(i) end do nterm=nterm-1 narg=narg-1 end if call preparser(1, narg, words) call typwords(1, nterm, words, nloci, loc, lochash, loctyp, & wtyp, wtag, expr, actn) if (actn == 0) then error=1 else if (actn == 2) call dryrun(1, nterm, wtyp) call parser(nterm, wtyp, wtag, expr, error) ! Write answer if (error > 0) then error=1 else if (actn == 1) then call wrans('=> ',nterm, expr, wtyp, wtag, last_result) else if (red) then if (plevel >= 0) then write(outstr,'(a/)') 'Operating on pedigree file' end if if (chek) then call setup_stat('Mendelian error rate due to "' & // trim(lin) // '"', typ=2) end if call evalped(narg, words, nloci, loc, lochash, loctyp, locpos, & locnotes, locstat, wtyp, wtag, expr, allele_buffer, & work, chek, imp, maxtry, droperr, plevel) else error=1 end if end if if (error == 1) then write(outstr,'(a,i0,a/7x,a/)') & 'ERROR: problematic input at line ',nlin,':',lin(1:72) if (.not.red) write(*,'(a/7x,a/)') & 'NOTE: data set has not yet been read in.', & 'Most procedures require a preceding "run" statement.' end if end if call proct(t1, timer) call flush(6) end do main_loop ! ! clean up memory usage before exit call cleanup_loci() call cleanup_hash(hashtab) call cleanup_peds(work) call cleanup_alleles(allele_buffer) call cleanup_mem() call clean_AS164() call cleanup_memoized_kininv() deallocate(words, wtyp, wtag, expr) call stamp(t0) end program nsp ! ! count number of commands on line and delineate next command ! (using position of ";"'s) to be evaluated ! subroutine nextcmd(commands, numcmd, linlen, s, more) use interrupt character(len=*), intent(inout) :: commands integer, intent(out) :: numcmd integer, intent(out) :: linlen character(len=*), intent(out) :: s logical, intent(out) :: more integer :: eoc, i logical :: escaped, inquote eoc=0 escaped=.false. inquote=.false. more=.false. numcmd=0 s=' ' linlen=len_trim(commands) if (linlen==0) return i=1 do while (commands(i:i)==' ' .and. i <= linlen) i=i+1 end do if (commands(i:i) /= '#' .and. commands(i:i) /= '!') then do while (eoc==0 .and. i <= linlen) if (.not.escaped .and. commands(i:i)=='"') then inquote=.not.inquote end if if (commands(i:i)==';' .and..not.inquote .and. .not.escaped) then eoc=i end if #if defined (WIN32) || defined (IFORT) || defined (NOESCAPE) escaped=(commands(i:i)=='\') #else escaped=(commands(i:i)=='\\') #endif i=i+1 end do end if more=(eoc>0) if (.not.more) then s=commands(1:linlen) commands='' else s=commands(1:eoc-1) commands=commands(eoc+1:linlen) numcmd=numcmd+1 i=1 do while (i < linlen) if (commands(i:i)==';') then numcmd=numcmd+1 end if i=i+1 end do linlen=eoc-1 end if if (irupt > 0) then more=.false. commands='' s='' end if end subroutine nextcmd ! ! character to integer conversion via internal read ! parses simpler scientific notation and KMG suffixes ! reads ., x, X, NA as missing ! function ival(string) use outstream integer :: ival character(len=*), intent(in) :: string integer, parameter :: MISS=-9999 integer :: dnote, ioerr, lens, mult, unote double precision :: v if (string.eq.' ') then ival=0 elseif (string == 'x' .or. string == 'X' .or. & string == '.' .or. string == 'NA') then ival=MISS else lens=len_trim(string) unote=index('KMG',string(lens:lens)) dnote=scan(string, 'dDeE') if (unote == 0 .and. dnote == 0) then read(string,'(i40)',iostat=ioerr) i else if (dnote > 0) then read(string,'(f40.0)',iostat=ioerr) v if (ioerr == 0) then if (anint(v) == v) then i=int(v) else ioerr=-1 end if end if else mult=1000**unote read(string(1:(lens-1)),'(f40.0)',iostat=ioerr) v if (ioerr == 0) then v=dble(mult)*v if (anint(v) == v) then i=int(v) else ioerr=-1 end if end if end if if (ioerr == 0) then ival=i else write(outstr,'(3a/)') 'ERROR: Unable to read integer "',string, '".' ival=0 end if end if end function ival ! ! character to float conversion via internal read ! function fval(string) use outstream double precision :: fval integer, parameter :: BLANKD=-9999, MISS=-9999 character(len=*), intent(in) :: string integer :: ioerr double precision :: v ! functions logical :: ismiss if (string == ' ' .or. string == '-') then fval=BLANKD elseif (ismiss(string)) then fval=MISS elseif (string == 'y' .or. string == 'Y') then fval=2.0d0 elseif (string == 'n' .or. string == 'N') then fval=1.0d0 else read(string,'(f40.0)',iostat=ioerr) v if (ioerr == 0) then fval=v else write(outstr,'(2a/)') & 'ERROR: Unable to read double precision number ',string fval=0.0d0 end if end if end function fval ! ! subroutine version ! subroutine fval2(string, res, ierr) use outstream integer, parameter :: BLANKD=-9999, MISS=-9999 character(len=*), intent(in) :: string double precision, intent(out) :: res integer, intent(out) :: ierr integer :: ioerr double precision :: v ! functions logical :: ismiss ierr=0 res=BLANKD if (string == ' ' .or. string == '-') then res=BLANKD elseif (ismiss(string)) then res=MISS elseif (string == 'y' .or. string == 'Y') then res=2.0d0 elseif (string == 'n' .or. string == 'N') then res=1.0d0 else read(string,'(f40.0)',iostat=ioerr) v if (ioerr == 0) then res=v else res=0.0d0 ierr=1 end if end if end subroutine fval2 ! ! Lossless conversion of double precision Mbp to integer bp ! function tobp(mapval) integer :: tobp double precision, intent(in) :: mapval tobp=nint(1.0d6*mapval) end function tobp ! ! Lossless conversion of double precision Mbp to long integer bp ! function tobp8(mapval) integer (kind=8) :: tobp8 double precision, intent(in) :: mapval tobp8=nint(1.0d6*mapval, kind=8) end function tobp8 ! ! Lossless conversion of double precision Mbp to bp as string ! subroutine frommega(mapval, bpval) double precision, intent(in) :: mapval character (len=*), intent(out) :: bpval integer :: i, j, slen if (mapval == 0.0d0) then bpval='0' else slen=len(bpval) write(bpval,'(f20.6)') mapval i=index(bpval,'.') j=i+1 if (mapval < 1.0d0) then do if (bpval(j:j) /= '0') exit if (j == slen) exit j=j+1 end do bpval=adjustl(bpval(j:slen)) else bpval=adjustl(bpval(1:(i-1)) // bpval(j:slen)) end if end if end subroutine frommega ! ! read allele values either numeric or letter code ! range of legal alleles depends on storage type ! function aval(string, gcode) use outstream integer :: aval integer, parameter :: BLANKD=-9999, MISS=-9999, ZERO=0 character(len=*), intent(in) :: string integer, intent(in) :: gcode integer :: ich, ioerr character(len=8) :: fstring integer, dimension(2), parameter :: letter0 = (/ 10000, 0 /) integer :: v ! functions logical :: is_strict_int if (string == ' ' .or. string == '-') then aval=BLANKD elseif (string == 'x' .or. string == 'X' .or. string == '.') then aval=MISS ! a single character might be a letter code else if (len_trim(string) == 1) then ich=ichar(string(1:1)) ! a single digit if (ich >= 48 .and. ich <= 57) then aval=ich-48 ! a letter a-zA-Z maps to 10001..52 else if ((ich >= 65 .and. ich <= 90) .or. & (ich >= 97 .and. ich <= 122)) then if (gcode < 3) then aval=ich+letter0(gcode) else aval=MISS if (ich == 65 .or. ich == 97) then aval=1 else if (ich == 66 .or. ich == 98) then aval=2 end if end if else aval=MISS end if else if (is_strict_int(string)) then read(string, '(i40)') v aval=v else write(outstr,'(3a/6x,a,i0)') & 'ERROR: Unable to interpret allele "', trim(string), '".', & 'len=', len_trim(string) aval=MISS end if if (gcode > 1 .and. aval == MISS) aval=ZERO end function aval ! ! Read simplified locus declaration eg 10m 10 m -> 10 autosomal markers ! subroutine locfmt(str, rep, newtyp) use locus_types character (len=*), intent(in) :: str integer, intent(out) :: rep, newtyp integer :: eos, pos, sta rep=1 eos=len_trim(str) pos=1 if (ichar(str(pos:pos))>47 .and. ichar(str(pos:pos))<58) then sta=pos do pos=pos+1 if (pos > eos) exit if (ichar(str(pos:pos)) < 48 .or. ichar(str(pos:pos)) > 57) exit end do read(str(sta:(pos-1)), '(i20)') rep end if newtyp=LOC_QUA if (pos>eos) then return else if (str(pos:pos)=='m') then newtyp=LOC_CODOM else if (str(pos:pos)=='x') then newtyp=LOC_XLIN else if (str(pos:pos)=='a') then newtyp=LOC_AFF else if (str(pos:pos)=='s') then newtyp=LOC_CODOM+LOC_CMP end if end subroutine locfmt ! ! skip leading whitespace ! function sow(string) integer :: sow character (len=*), intent(in) :: string integer :: i do i=1, len(string) if (string(i:i) /= ' ' .and. ichar(string(i:i)) /= 9) then exit end if end do sow=i end function sow ! ! find end of string ! function eow(string) integer :: eow character (len=*), intent(in) :: string do i=len(string), 1, -1 if (string(i:i) /= ' ' .and. ichar(string(i:i)) /= 9) then exit end if end do eow=i end function eow ! ! See if a string is a missing value ! function ismiss(string) logical :: ismiss character (len=*), intent(in) :: string ismiss=(string == 'x' .or. string == 'X' .or. string == '.' .or. string == 'NA') end function ismiss ! ! see if a string is a valid Sib-pair integer ! which includes scientific notation or KMG suffixes ! as well as n,N,x,X,y,Y ! function isint(string) logical :: isint integer, parameter :: miss=-9999 character(len=*) string integer :: i, ich, j , lens isint=.true. if (string == 'x' .or. string == 'X' .or. string == '.' .or. & string == 'y' .or. string == 'Y' .or. string == ' ' .or. & string == 'n' .or. string == 'N') then return end if i=1 lens=len_trim(string) if (string(i:i) == '-' .or. string(i:i)=='+') i=i+1 if (index('KMG',string(lens:lens)) > 0) lens=lens-1 if (lens == 0) then isint=.false. return end if do j=i, lens ich=ichar(string(j:j)) if (ich < 48 .or. ich > 57) then isint=.false. return end if end do end function isint ! ! see if a string is a valid integer ! function is_strict_int(string) logical :: is_strict_int character(len=*) string integer :: i, lens is_strict_int=.false. lens=len_trim(string) if (lens == 0) return i=1 if (string(i:i) == '-' .or. string(i:i)=='+') i=i+1 if (i > lens) return is_strict_int=(verify(string(i:lens),'0123456789') == 0) end function is_strict_int ! ! See if a string is a valid Sib-pair double precision number ! includes n,N,x,X,y,Y ! Free format fails for comma containing lists ! function isreal(string) logical :: isreal integer, parameter :: miss=-9999 character(len=*) string integer :: ilen, ioerr character(len=8) fstring double precision :: v if (string == 'X' .or. string == 'x' .or. string == '.' .or. & string == 'Y' .or. string == 'y' .or. string == ' ' .or. & string == 'N' .or. string == 'n') then isreal=.true. else ilen=len_trim(string) write(fstring,'(a,i0,a)') '(f', ilen, '.0)' read(string, fstring, iostat=ioerr) v if (ioerr == 0) then isreal=.true. else isreal=.false. end if end if end function isreal ! ! See if a string is a valid double precision number ! function is_strict_real(string) logical :: is_strict_real integer, parameter :: miss=-9999 character(len=*) string integer :: i, ioerr, lens character(len=20) fstring double precision :: v is_strict_real=.false. lens=len_trim(string) i=1 if (string(i:i) == '-' .or. string(i:i)=='+') i=i+1 if (i > lens) return write(fstring,'(a,i0,a)') '(f', lens, '.0)' read(string, fstring, iostat=ioerr) v if (ioerr == 0) then is_strict_real=.true. end if end function is_strict_real ! ! See if a string is a comment ! function iscomment(string) logical :: iscomment character (len=*), intent(in) :: string integer :: i character (len=1) :: ch iscomment=.false. do i=1, len(string) ch=string(i:i) if (ch == '#' .or. ch == '!') then iscomment=.true. exit else if (ch /= ' ') then exit end if end do end function iscomment ! ! See if a string is a map position of form CHR:bp ! 0 = no ! 1 = <any>:<int> ! 2 = [chr](<int>|X|Y|XY|MT):<int> ! function ismappos(string) integer :: ismappos character (len=*), intent(in) :: string integer :: i, nsep, slen, seppos ! functions logical :: isint ismappos=0 nsep=0 slen=len(string) do i=1, slen if (string(i:i) == ':') then nsep=nsep+1 seppos=i end if end do if (nsep == 1) then if (isint(string((seppos+1):slen))) then ismappos=1 i=1 if (string(1:3) == 'chr') i=4 if (string(i:(seppos-1)) == 'MT' .or. & string(i:(seppos-1)) == 'X' .or. & string(i:(seppos-1)) == 'Y' .or. & string(i:(seppos-1)) == 'XY' .or. & isint(string(i:(seppos-1)))) then ismappos=2 end if end if end if end function ismappos ! ! write sex as character ! subroutine wrsex(sex,ch) integer, intent(in) :: sex character (len=*), intent(out) :: ch ch='x' if (sex == 1) then ch='m' else if (sex == 2) then ch='f' end if end subroutine wrsex ! ! write date as character ! subroutine wrdate(date,str,typ) use timelib double precision, intent(in) :: date character (len=*), intent(out) :: str integer, intent(in) :: typ if (typ == 1) then write(str,'(i9.9)') abs(int(togreg(date))) else if (typ == 2) then write(str,'(i9.9)') abs(int(date)) end if str=str(2:5) // '-' // str(6:7) // '-' // str(8:9) return end subroutine wrdate ! ! binary trait as character ! subroutine wraff(val, ch, typ) double precision, intent(in) :: val character (len=1), intent(out) :: ch integer, intent(in) :: typ character (len=1), dimension(6), parameter :: let=(/'x','n','y','?','U','A'/) ch=let(1+3*(typ-1)) if (val == 1.0d0) then ch=let(2+3*(typ-1)) else if (val == 2.0d0) then ch=let(3+3*(typ-1)) end if end subroutine wraff ! ! A big integer as integer or rounded scientific notation ! subroutine wrint(intval, str) integer, intent(in) :: intval character (len=*), intent(out) :: str integer :: lens, isiz character (len=3) :: expt character (len=40) :: nbuffer lens=len(str) isiz=nint(log10(dfloat(intval))) if (isiz < lens) then write(nbuffer,'(i40)') lens nbuffer='(i' // trim(adjustl(nbuffer)) // ')' write(str, nbuffer) intval else write(expt,'(i3)') isiz expt=adjustl(expt) write(nbuffer,'(i40)') intval nbuffer=adjustl(nbuffer) str=nbuffer(1:1) // '.' // & nbuffer(2:(lens-2-len_trim(expt))) // 'e' // trim(expt) end if end subroutine wrint ! Fortran format statement to write one number ! subroutine wrform(typ, nwid, ndec, fstring) integer :: ndec, nwid character(len=1) :: typ character(len=*) :: fstring character(len=3) :: cdec, cwid ! functions integer sow write(cwid,'(i3)') nwid if (typ == 'a') then fstring='(a' // trim(adjustl(cwid)) // ')' else if (typ /= 'i') then write(cdec,'(i3)') ndec write(fstring,'(6a)') & '(', typ, cwid(sow(cwid):3), '.', cdec(sow(cdec):3), ')' else fstring='(i' // trim(adjustl(cwid)) // ')' end if end subroutine wrform ! ! Get maximum lengths of ID strings ! subroutine idwidths(dataset, widths, name_formats) use ped_class type (ped_data) :: dataset integer, dimension(4), intent(out) :: widths character (len=3), dimension(4), intent(out) :: name_formats integer :: i, ped, pedoffset widths(1)=1 widths(2)=1 widths(3)=1 widths(4)=1 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then widths(1)=max(widths(1), len_trim(dataset%pedigree(ped))) pedoffset=dataset%num(ped-1) do i=pedoffset+1, pedoffset+dataset%nfound(ped) widths(2)=max(widths(2), len_trim(dataset%id(i))) end do do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped) widths(2)=max(widths(2), len_trim(dataset%id(i))) widths(3)=max(widths(3), len_trim(dataset%id(dataset%fa(i)))) widths(4)=max(widths(4), len_trim(dataset%id(dataset%mo(i)))) end do end if end do do i=1, 4 write(name_formats(i), '(i3)') widths(i) name_formats(i)='a' // trim(adjustl(name_formats(i))) end do end subroutine idwidths ! ! Write P-values as a histogram: . + * ** *** ! subroutine phist(pval1, pval2, histo) double precision, intent(in) :: pval1 double precision, intent(in) :: pval2 character (len=3), intent(out) :: histo double precision :: pval pval=min(pval1, pval2) histo='. ' if (pval < 0.0001d0) then histo='***' else if (pval < 0.001d0) then histo='**' else if (pval < 0.01d0) then histo='*' else if (pval < 0.1d0) then histo='+' end if end subroutine phist ! ! Write real as a string ! function gstring(x) character (len=14) :: gstring double precision, intent(in) :: x character (len=14) :: buff write(buff,'(g14.4)') x gstring=adjustl(buff) end function gstring ! ! Write P-values as a string ! function pstring(pval) #if SUN use, intrinsic :: ieee_arithmetic use, intrinsic :: ieee_exceptions #endif character (len=6) :: pstring double precision, intent(in) :: pval character (len=6) :: pch character (len=8) :: nbuffer integer :: charpos, expt pch=' . ' if (pval >= 0.0001d0) then write(pch,'(f6.4)') pval else if (pval == 0.0d0) then pch='0.0' #if SUN else if (ieee_is_nan(pval)) then #else else if (isnan(pval)) then #endif continue else if (pval < 0.0d0) then continue else write(nbuffer,'(d8.1)') pval charpos=index(nbuffer,'-') pch=nbuffer(charpos:8) read(pch,'(i6)') expt write(pch,'(i6)') expt-1 charpos=index(nbuffer,'.')+1 pch=nbuffer(charpos:charpos) // 'e' // adjustl(pch) end if pstring=pch end function pstring ! ! Write correlation as a 6 character string (deal nicely with -1) ! function corstring(rval) character (len=6) :: corstring double precision, intent(in) :: rval character (len=6) :: pch character (len=7) :: nbuffer integer :: expt corstring='-1 ' if (rval > -1.0d0) then write(corstring,'(f6.4)') rval end if end function corstring ! ! append one word to a string if enough room ! subroutine append(word, note) character (len=*), intent(in) :: word character (len=*), intent(inout) :: note integer sta, fin ! functions sta=len_trim(note)+2 fin=sta+len_trim(word)-1 if (fin <= len(note)) then note(sta:fin)=trim(word) end if end subroutine append ! ! prepend "x" to a string if starts with an integer ! Loki and R for example do not allow variable names that start with a digit ! subroutine addlet(old, new) character (len=*), intent(in) :: old character (len=*), intent(out) :: new character (len=1) :: ch ch=old(1:1) if (ichar(ch) >= 48 .and. ichar(ch) <= 57) then new='x' // old else new=old end if end subroutine addlet ! ! create a shorter unique version of a string eg locus name ! Old versions of MENDEL for instance wants 8 character locus names ! subroutine shorten(idx, nwords, words, newlen, res) use outstream integer, intent(in) :: idx integer, intent(in) :: nwords character (len=*), intent(in) :: words(nwords) integer, intent(in) :: newlen character (len=*), intent(out) :: res integer :: i, ncopies, nindch, offset res=words(idx)(1:newlen) if (len_trim(words(idx)) < newlen) return ncopies=0 do i=1, nwords if (words(i)(1:newlen) == res) then ncopies=ncopies+1 end if end do if (ncopies > 1) then ncopies=0 nindch=newlen-1 do i=1, idx-1 if (words(i)(1:nindch) == res(1:nindch)) then ncopies=ncopies+1 end if end do ncopies=ncopies+1 if (ncopies > 117) then write(outstr,'(4a)') & 'ERROR: too many collisions caused by ', & 'truncation of "', trim(words(idx)),'".' else offset=64 if (ncopies > 26) offset=96 if (ncopies > 52) offset=190 res(newlen:newlen)=char(offset+ncopies) end if end if write(outstr,'(5a)') & 'Shortened "', trim(words(idx)), '" to "', trim(res), '"' end subroutine shorten ! ! hash an integer to a two character string 01-99,A-Z,a-z,a-z... ! append to name: typ=1, appended with underscore; typ=2, appended directly ! subroutine makeind(typ, idx, eos, los, string) integer, intent(in) :: typ integer, intent(in) :: idx integer, intent(in) :: eos integer, intent(in) :: los character (len=*), intent(out) :: string ! integer :: d1, d2, i character (len=2) :: ch character (len=8) :: fdec ! if (idx < 100) then write(ch,'(i2.2)') idx else if (idx < 776) then i=idx-100 d1=65+i/26 d2=65+mod(i,26) ch(1:1)=char(d1) ch(2:2)=char(d2) else i=idx-776 d1=i/26 d2=mod(i,26) ch(1:1)=char(97+mod(d1,26)) ch(2:2)=char(97+mod(d2,26)) end if ! ! add number to name if short enough if (typ == 2 .and. eos < (los-1)) then string((eos+1):(eos+2))=ch else if (eos < (los-2)) then string((eos+1):(eos+1))='_' string((eos+2):(eos+3))=ch else ! check if danger of nonunique new name if (string((los-2):(los-2)) == '_' .and. eos == los) then d1=1 do i=2, los d1=mod(d1*ichar(string(i:i)),1048576) end do call wrform('i', los, los, fdec) write(string, fdec) d1 end if string(3:3)='_' string(1:2)=ch end if end subroutine makeind ! ! Create a new unique temporary file ! subroutine mktmpfil(str, filnam, wrkdir, ioerr) use rngs integer, intent(inout) :: str character (len=*), intent(out) :: filnam character (len=*), intent(in) :: wrkdir integer, intent(out) :: ioerr logical :: filexist integer :: tries ioerr=-1 tries=0 do tries=tries+1 call uniqnam(5, filnam) filnam='sp-' // trim(filnam) // '.dat' call concat(wrkdir, filnam) inquire(file=filnam, exist=filexist) if (.not.filexist) exit if (tries > 10) return end do open(str, file=filnam, iostat=ioerr) end subroutine mktmpfil ! ! Copy inline data to a file ! Relies on iostat=-2 as eol to use lin as a buffer ! subroutine wrinline(nlin, outstr) use iocodes use iobuff implicit none integer, intent(inout) :: nlin integer, intent(in) :: outstr integer :: ioerr do read(incstr(ilevel), '(a)', advance='no', iostat=ioerr) lin if (ioerr == eolcode) then if (lin(1:4) == ';;;;') exit nlin=nlin+1 write(outstr,'(a)') trim(lin) cycle else if (ioerr /= 0) then exit end if write(outstr,'(a)', advance='no') lin end do end subroutine wrinline ! ! Open the standard log file "sib-pair.log" ! subroutine openlog(lstr, logfil, nhis) use outstream use timelib integer, intent(in) :: lstr character (len=*) :: logfil integer, intent(out) :: nhis integer :: ioerr logical :: filexist logstr=lstr inquire(unit=logstr, opened=filexist) if (filexist) then close(logstr, status='keep', iostat=ioerr) if (ioerr == 0) then write(outstr,'(a)') 'NOTE: Log stream was in use. Closing and reopening!' else write(outstr,'(a)') & 'NOTE: Log stream is in use. Will be unable to save commands from current session.' end if end if inquire(file=logfil, exist=filexist) if (filexist) then write(outstr,'(a)') 'NOTE: Overwriting existing logfile.' end if open(logstr, file=logfil, iostat=ioerr) if (ioerr == 0) then write(logstr,'(a/2a/a)') '#','# Sib-pair logfile created: ', current_time(),'#' else write(outstr,'(3a)') 'ERROR: Cannot open logfile "', trim(logfil), '"' logstr=0 end if nhis=0 end subroutine openlog ! ! System utilities ! ! Find a file along the search path -- check pwd, then HOME first ! subroutine findfile(filnam, stat) character (len=*), intent(inout) :: filnam integer, intent(out) :: stat character (len=1024) :: path, nam integer :: pos #if WIN32 character (len=1) :: sep=';' character (len=1) :: slash='\\' #else character (len=1) :: sep=':' character (len=1) :: slash='/' #endif logical :: filexist stat=0 call getenv('HOME', nam) call getenv('PATH', path) path='.' // sep // trim(nam) // sep // trim(path) do pos=index(path, sep) if (pos == 0) exit nam=path(1:(pos-1)) // slash // trim(filnam) inquire(file=trim(nam), exist=filexist) if (filexist) then filnam=nam stat=stat+1 return end if path=path((pos+1):) end do end subroutine findfile ! ! Evaluate tilde in path names ! subroutine expandtilde(filnam) character (len=*), intent(inout) :: filnam character (len=1024) :: path #if WIN32 character (len=1) :: slash='\\' #else character (len=1) :: slash='/' #endif if (filnam(1:1) == '~') then call getenv('HOME', path) if (path /= ' ') then filnam=trim(path) // slash // filnam(2:len_trim(filnam)) end if end if end subroutine expandtilde ! ! Read and expand a file name ! subroutine get_filnam(string, pos, filnam) use scanner character (len=*), intent(in) :: string integer, intent(in) :: pos character (len=*), intent(out) :: filnam call getword(string, pos, filnam) call expandtilde(filnam) end subroutine get_filnam ! ! Delete a file ! subroutine delfile(filnam, plevel) #if FLANG use posix_utils #endif use outstream character (len=*), intent(in) :: filnam integer, intent(in) :: plevel integer :: ioerr #if IFORT || SUN integer :: unlink ioerr=unlink(filnam) #elif OPEN64 ioerr=0 call unlink(filnam) #else call unlink(filnam, ioerr) #endif if (ioerr == 0 .and. plevel >= 0) then write(outstr, '(3a)') 'Deleted file "', trim(filnam),'".' end if end subroutine delfile ! ! Flag a file as gzip compressed and ! unzip for reading (necessary for binary files) ! subroutine unzipper(filnam, wrkfil, gzipped) use outstream use fileio use rngs character (len=*), intent(in) :: filnam character (len=*), intent(out) :: wrkfil logical, intent(out) :: gzipped integer :: eon gzipped=.false. wrkfil=filnam eon=len_trim(filnam) if (eon == 0) then write(outstr,'(a)') 'No pedigree file name given.' return end if gzipped=(isgzipped(filnam) > 0) if (gzipped) then call uniqnam(5, wrkfil) wrkfil='sp-' // trim(wrkfil) // '.txt' call system('gzip -cd "' // trim(filnam) // '" > ' // wrkfil) end if end subroutine unzipper ! ! Return length of longest line of file ! Use lin as buffer ! Relies on iostat code for eol ! testlines limits to the first testlines lines: set to -1 to check all ! if skipcomments is set, testlines excludes comment lines ! subroutine reclen(port, buffer, longest, testlines, skipcomments) use fileio type (ioport) :: port character (len=*), intent(in out) :: buffer integer, intent(out) :: longest integer, intent(in) :: testlines logical, intent(in) :: skipcomments integer :: nlines, ioerr, ilen, lenbuff logical :: iscomment, sta lenbuff=len(buffer) longest=0 ilen=0 sta=.true. iscomment=.false. nlines=testlines call rewind_port(port, ioerr) do while (nlines /= 0) call readline(port, buffer, advance='no', ios=ioerr) if (skipcomments .and. sta) then iscomment=(buffer(1:1) == '#') sta=.false. end if if (ioerr == eolcode) then ilen=ilen+len_trim(buffer) if (ilen > longest) longest=ilen ilen=0 sta=.true. nlines=nlines-1 if (skipcomments) then if (iscomment) nlines=nlines+1 end if cycle else if (ioerr /= 0) then exit end if ilen=ilen+lenbuff end do call rewind_port(port, ioerr) end subroutine reclen ! ! Return representative number of words per line in file ! Use lin as buffer ! subroutine filecols(port, buffer, testlines, nwords, plevel) use fileio use scanner type (ioport) :: port character (len=*), intent(in out) :: buffer integer, intent(in) :: testlines integer, intent(out) :: nwords integer, intent(in) :: plevel integer :: ioerr, narg, nlines character (len=1) :: ch ! functions logical :: iscomment nwords=0 nlines=0 call rewind_port(port, ioerr) do call readline(port, buffer, ios=ioerr) if (ioerr /= 0 .or. nlines >= testlines) then exit end if if (iscomment(buffer)) cycle narg=countargs(buffer, ' ', SEP_WHITE) nlines=nlines+1 if (plevel > 1) then if (narg > nwords) then write(*,'(a,i0,a,i0)') 'Line: ', nlines, ' Fields: ', narg end if end if if (narg > nwords) nwords=narg end do call rewind_port(port, ioerr) end subroutine filecols ! ! GUI stuff ! Uses JAPI to call AWT, or PILIB to call GTK2 if present ! else simple file picker ! subroutine fchooser(fil, gui, plevel) #if JAPI use japi #elif PILIB use pimod #endif character (len=*), intent(out) :: fil integer, intent(in) :: gui integer, intent(in) :: plevel #if JAPI integer :: frame, menubar, fileact, openact, quitact, obj character (len=256) :: directory #elif PILIB type (string) :: filna type (string), dimension(1) :: types, patterns integer :: iclos, ihwin, ipat types(1)=c('Any') patterns(1)=c('*') #endif fil = ' ' #if JAPI if (gui /= 0) then if (.not. j_start()) then write(*,'(a)') 'ERROR: Cannot start up Java for windowing.' call fpicker(fil, plevel) else directory= '.' frame= j_frame('Directory Browser') call j_filedialog(frame, 'Open File', directory, fil) call chdir(trim(directory)) call j_quit() end if else call fpicker(fil, plevel) end if #elif PILIB if (gui /= 0) then call piinit call gkfilesel(c('File Picker'), types, patterns, 1, & filna, ipat) call gkproc fil=c(filna) ! destroy file selector dialogue call gkproc else call fpicker(fil, plevel) end if #else call fpicker(fil, plevel) #endif end subroutine fchooser #if WIN32 ! ! Text based Windows file picker ! subroutine fpicker(fil, plevel) use rngs use string_utilities character (len=*), intent(out) :: fil integer, intent(in) :: plevel integer, parameter :: TWRK=7 integer :: choice, i, ioerr, lpos, pos logical :: dir, fin, srch character (len=4) :: cpos character (len=13) :: procid character (len=22) :: cmd character (len=80) :: regexp character (len=256) :: slin, thisdir ! functions ! chfind, strfind logical :: isreal fil = ' ' regexp=' ' call uniqnam(8, procid) procid=trim(procid) // '.tmp' cmd='dir > ' // procid srch=.false. do fin = .true. if (plevel > 2) then write(*,*) 'System call: ', trim(cmd) end if call system(cmd) open(TWRK, file=procid) pos=0 do while (pos < 4) read(TWRK,'(a)',iostat=ioerr) slin if (ioerr /= 0) then exit end if pos=pos+1 end do write(*,'(2a/)') 'Directory: ', slin(15:len_trim(slin)) read(TWRK,'(a)',iostat=ioerr) slin if (ioerr /= 0) then exit end if lpos=0 pos=0 do read(TWRK,'(a)',iostat=ioerr) slin if (ioerr /= 0) then exit else if (slin(1:1)==' ') then exit end if pos=pos+1 slin=slin(40:80) if (.not.srch .or. & (srch .and. strfind(regexp, slin, 1))) then write(cpos, '(i4)') pos cpos=adjustl(cpos) lpos=lpos+len_trim(cpos)+4+len_trim(slin) if (lpos > 75) then lpos=len_trim(cpos)+4+len_trim(slin) write(*,*) end if write(*,'(3a)', advance='no') '[' // trim(cpos) // '] ', trim(slin), ' ' end if end do write(*, '(/a)', advance='no') 'choice> ' read(*,*) slin srch=.false. if (slin=='q' .or. slin(1:3)=='qui') then choice=0 fil=' ' else if (isreal(trim(slin))) then choice=ival(trim(slin)) else if (chfind(trim(slin),'*') > 0) then choice=-1 srch=.true. regexp=trim(slin) else choice=0 fil=trim(slin) end if if (choice>0 .and. choice < pos) then rewind(TWRK) do i=1, 5 read(TWRK,'(a)') slin end do do i=1, choice read(TWRK,'(a)') slin end do dir=(slin(25:29)=='<DIR>') fil=trim(slin(40:len_trim(slin))) if (dir) then call chdir(trim(fil)) fin=.false. end if else if (choice==0) then fin=.true. else fin=.false. end if close(TWRK, status='delete') if (fin) then exit end if end do end subroutine fpicker #else ! ! Text based file picker ! subroutine fpicker(fil, plevel) #if FLANG use posix_utils #endif use string_utilities use rngs character (len=*), intent(out) :: fil integer, intent(in) :: plevel integer, parameter :: TWRK=7 integer :: choice, eos, i, ioerr, lpos, pos logical :: fin, srch character (len=4) :: cpos character (len=13) :: procid character (len=24) :: cmd character (len=80) :: regexp character (len=256) :: slin ! functions ! chfind, strfind logical :: isreal fil = ' ' regexp=' ' call uniqnam(8, procid) procid='/tmp/' // trim(procid) cmd='ls -a > ' // procid srch=.false. do fin = .true. call system(cmd) open(TWRK, file=procid, iostat=ioerr) pos=0 lpos=0 do read(TWRK,'(a)',iostat=ioerr) slin if (ioerr /= 0) then exit end if pos=pos+1 if (.not.srch .or. & (srch .and. strfind(regexp, slin, 1))) then write(cpos, '(i4)') pos cpos=adjustl(cpos) lpos=lpos+len_trim(cpos)+4+len_trim(slin) if (lpos > 75) then lpos=len_trim(cpos)+4+len_trim(slin) write(*,*) end if write(*,'(3a)', advance='no') '[' // trim(cpos) // '] ', trim(slin), ' ' end if end do write(*, '(/a)', advance='no') 'choice> ' read(*,*) slin srch=.false. if (slin=='q' .or. slin(1:3)=='qui') then choice=0 fil=' ' else if (isreal(trim(slin))) then choice=ival(trim(slin)) else if (chfind(trim(slin), '*') > 0) then choice=-1 srch=.true. regexp=trim(slin) else choice=0 fil=trim(slin) end if if (choice>0 .and. choice <= pos) then rewind(TWRK) do i=1, choice read(TWRK,'(a)') slin end do fil=trim(slin) eos=len_trim(fil) if (fil(eos:eos)=='/') then call chdir(fil(1:(eos-1))) fin=.false. end if else if (choice==0) then fin=.true. else fin=.false. end if close(TWRK, status='delete') if (fin) then exit end if end do end subroutine fpicker #endif ! ! Display information about program and current settings ! subroutine info(lin, burnin, imp, iter, & mapf, mincnt, plevel, genemod, & showorig, chek, droperr, prompt, use2, gui, & twintrait, sexmarker, datdir, wrkdir) use extras use iso_fortran_env use outstream use genetic_maps use julian_epoch use rndseed #if ZLIB use f95zlib #endif character (len=*) :: lin integer, intent(in) :: burnin integer, intent(in) :: imp integer, intent(in) :: iter integer, intent(in) :: mapf integer, intent(in) :: mincnt integer, intent(in) :: plevel integer, intent(in) :: genemod integer, intent(in) :: showorig logical, intent(in) :: chek integer, intent(in) :: droperr logical, intent(in) :: prompt integer, intent(in) :: use2 integer, intent(in) :: gui character (len=*), intent(in) :: twintrait character (len=*), intent(in) :: sexmarker character (len=*), intent(in) :: datdir character (len=*), intent(in) :: wrkdir character (len=10) :: string character (len=9), dimension(2) :: modlabel = (/'Allelic ' , 'Genotypic'/) #if THREADED integer :: nthreads, tid integer :: omp_get_num_threads, omp_get_thread_num #endif write(outstr,'(2a/)') 'Program version = ',version write(outstr,'(2a)') 'Compiler = ',compiler_version() if (plevel > 1) then write(outstr,'(2a)') 'Compile options = ',compiler_options() end if #if THREADED write(outstr,'(a)') 'Multithreading = openmp' !$OMP PARALLEL PRIVATE(TID) tid = omp_get_thread_num() if (tid == 0) then nthreads = omp_get_num_threads() write(outstr,'(a,i0)') 'Available threads = ', nthreads end if !$OMP END PARALLEL #else write(outstr,'(a)') 'Multithreading = single' #endif if (len_trim(hasextras) > 0) then write(outstr,'(2a)') 'Extra functionality = ', trim(hasextras) end if #if ZLIB call zlib_version(string) write(outstr,'(3a)') 'zlib version = "', trim(string), '"' if (plevel > 1) then write(outstr,'(a,b0,a)') & 'zlib compile options = "',zlibcompileflags(), '"' write(outstr,'(22x)', advance='no') call zlib_compileflags() end if #endif write(outstr,'(a,i5,a)') 'Max command length = ', len(lin), ' characters' write(outstr,'(a,l5)') 'Simple Mendel checks = ',chek write(outstr,'(2(a,i5/))') 'Imputation level = ',imp, & 'Drop incon. genotypes= ',droperr write(outstr,'(3(a,i5/),2(a,3(1x,i5)/))') & 'Maximum MC iterations= ', iter, & 'Min numerator P-value= ', mincnt, & 'Burn-in MC iterations= ', burnin, & 'Seeds for RNG (AS183)=', ix, iy, iz, & 'Initial RNG seeds =', initix, initiy, initiz write(outstr,'(2a/3(a,l5/),a,i5/a,i5, 2(/3a))') & 'Marker effect model = ', modlabel(genemod), & 'Multiple TDT/family = ', use2<3, & 'Show prompt string = ', prompt, & 'Use GUI = ', (gui/=0), & 'Output detail level = ', plevel, & 'Haplotype detail lvl = ', showorig, & 'MZ twin indicator = "', trim(twintrait), '"', & 'Sex inform marker = "', trim(sexmarker), '"' write(outstr,'(2(3a/))') & 'Data file directory = "', trim(datdir), '"', & 'Work file directory = "', trim(wrkdir), '"' call wrdate(epoch, string, 1) write(outstr,'(2a/2a/)') & ' Map function = ', mapfunname(mapf), & ' Julian date epoch = ', string end subroutine info ! ! brief online help ! subroutine help(typ, regexp, lin, twrk) use outstream use scheme_lang use string_utilities integer, intent(in) :: typ character (len=*), intent(inout) :: regexp character (len=*), intent(inout) :: lin integer, intent(in) :: twrk integer :: i, ioerr, lenr, strm character (len=12) :: wrkfil ! functions ! logical :: strfind strm=6 wrkfil='sib-pair.hlp' if (typ == 7) then strm=twrk open(strm,file=wrkfil,status='unknown') else if (typ == 6) then write(strm,'(a/a//a)') & 'Keywords can be shortened to the first 3 letters.', & 'Help prints a brief description of a command or group of commands:', & ' help [<search string> | All | Globals | Operators | Data | Analysis | Examples]' if (isafun('help.start') /= 0) then write(strm,'(/a//a)') & 'To open a browser window for detailed help :', ' help.start' end if write(strm,'(/a//)') 'Now try "help Examples"' return else if (typ == 10) then write(strm,'(a/9(/a))') & 'A few example commands:', & '>> set loc Cholesterol quantitative', & '>> set loc D15S124 marker', & '>> read pedigree inline', & 'Smith John x x m 6.8 12/14', & 'Smith Jane x x f x 16/18', & 'Smith Jim John Jane m 4.8 12/16', & 'Smith Jill John Jane f 4.1 14/18', & 'Smith Joss John Mary m 4.7 12/16', & ';;;; end of pedigree' write(strm,'(10(a/))') & '>> run', & '>> set loc logChol qua', & '>> logChol=log(Cholesterol)', & '>> head', & '>> describe logChol D15S124', & '>> var logChol', & '>> qtl logChol full', & '>> tdt logChol', & '>> assoc logChol', & '>> quit' return end if if (typ == 1 .or. typ == 2 .or. typ == 7) then write(strm,'(a)') '*Globals*', & '; {divide commands}', & '!|# {comment}', 'echo <txt> {print rest of line}', & '$ <cmd> {shell command}', & 'dir <args> {file listing for current directory/folder}', & '[set] pwd [<dir>] {print or change current directory/folder}', & 'fil ren|del|cat|hea|que <fil> [<fil>...] {delete|rename|cat|head|query file(s)}', & 'fil tra <fil> [<fil>...] {transpose file rows and columns}', & 'fil inv <fil> [low|upp] [<ridge>] {invert symmetric matrix from file}', & 'fil met <fil> [<col>] {Fisher combination of P values}', & 'fil fie|wc [skip] <fil> [<fil>...] {count lines columns words in file(s)}', & 'fil hex <fil> [<end>|(<sta> <end>|+<off>)] {hex dump file}', & 'fil tbi <fil> [<chr>:<bp>|<mar> [ann]] {print tabix and VCF file locus information}', & 'fil vcf <fil> [ann] [(<sta> [<end>])|(<loc> [..<loc])] {print VCF file locus information}', & 'fil vcf ord <fil> <ofil> {order/filter VCF file using current map}', & 'fil vcf lif <fil> <ofil> {order/filter VCF file and update/liftover genomic positions}', & 'fil fas <fil> [(<chr>:<bp> [<len>])|index] {print FASTA file sequence information}', & 'fil pri [/<s>/ [/<s>/]] [(<fmt>|csv|tab)] [csv|tab] [NR] [S] [+] [<N>p] [<col1>..<colN>] <fil> {print/search file}', & 'hel [<keyword>|All|Globals|Operators|Data|Analysis|Examples] {searchable help}', & 'qui|bye|exi {exit}', & 'cle [dat] {reset/clear data}', & 'inc <fil> {include/read commands from a file}', & 'loc <fil> {include/read locus and ped declarations from a file}', & 'out [<fil>] {divert text output to file}', & 'lis|ls <loc1>.[to]..<locN> [$(m|x|y|h|i|q|a)[rm]] {list loci}' , & 'lis where pos <pos1> [--|<pos2>...] {list loci based on map position/range}' , & 'lis where <str> {list loci based on annotations}' , & 'las [<line no>|-<offset>] {cmd history}', & 'sho (chr|loc|mis|spe) {show current chromosomes|loci|missingness|spectrum}', & 'sho map (pos <pos1> [--|<pos2>...])|[<loc1>...] {show marker map}', & 'sho ids [(dup [<tra>])|<str>..)]|(ped [<str>...]) {show individual or pedigree IDs}', & 'sho (mac|mem|mz|path|sex) {show macros|memory [<s> <f>]|mztwins|search path|sex}', & 'sho kin {show current big kinship matrix}', & 'sho ann <col> [...<colN>] {tabulate annotation columns}', & 'sho ann <vcf> [<v1>...<vN>] {show or tabulate VCF INFO variable values}' write(strm,'(a)') 'inf {program info}', 'las [<num>] {command history}', & 'tim {total elapsed time}', 'set tim [on|off] {time procedures}', & 'set epo [jul|iso|mjd|lil|j2000|<epo>] {set epoch for Julian dates}' write(strm,'(a)') & 'set pro [on|off|<str>] {display prompt}', & 'set gui [on|off] {activate gui commands}', & 'set ech [on|off] {echo commands to output}', & 'set log <fil> {change name of logfile}', & 'set out|ple -1|0|1|2|ver|on|off [qui] {output verbosity, plevel}', & 'set pri rec|pai|obs|ver|<mask> {output style for print command}', & 'set cat lev|lab {output style for printing categorical variables}', & 'set tab <sep> {column separator for summary tables}', & 'set gen <sep> {allele separator for writing genotypes}', & 'set mis <str> {missing data token for printing}', & 'set nde [<nwid>] <ndec> {output pedigree decimal digits}', & 'set wid [<wid>] {output pedigree categorical variable width}', & 'set dot [<ncro> <nsep> <rsep> <siz>] {ped symbol size and spacing}', & 'set hap 0|1|2|ver|on|off {haplotype detail}', & 'set wei fou {weight allele frequencies}' write(strm,'(a)') 'set ite|bur|emi <it> {maximum MC|burn-in|EM iters}', & 'set mft men|(genz [<num> [<abs> [<rel>]]]) {MFT algorithm, eval count, tols}', & 'set opt bobyqa|varmet {maximizer convergence criterion}', & 'set tol <tol> {maximizer convergence criterion}', & 'set tun <tun> {MCMC proposal tuner}', & 'set bat <num> {number of MCMC batches}', & 'set cha <num> {number of MCMC chains}', & 'set sta <ite> {number of MCMC initial genotype proposal trials}', & 'set jac <num> {size of jackknife draw}', & 'set min <num> {required numerator sequential MC P-values}', & 'set ord <num> {order statistic for P-values approximation}', & 'set chi pea|gib {chi-square statistic for association}' write(strm,'(a)') 'set see <s1> <s2> <s3> {RNG seeds}', & 'set err [on|off] {remove nuclear family mendelian errors}', & 'set che [sex|nam] [on|off] {disable mendelian, sex or duplicate locus checks}', & 'set pre <prev>|off {fix population binary trait prevalence}', & 'set fre <mar> <p1>..<pN> {fix population allele frequencies}', & 'set vcf <ACname> <ANname> {names for VCF file allele counts}', & 'set sml <pA> <penAA> <penAB> <penBB> {dummy SML parameters}', & 'set lia <tra> <liab> <nlev> {declare liability classes for trait}', & 'set tdt both|one|fir {parents typed for TDT}', & 'set fba on|off {impute child genotypes for FBAT}', & 'set hre zero|chi {assume zero recomb for phased LD model}', & 'set mod [all|gen] {allelic or genotypic marker encoding for regression model}', & 'set nha <num> {max number of haplotypes for loglinear LD model}', & 'set ibd <dis> [<nma>] {multipoint IBD marker cM threshold for clumping}', & 'set roh <dis> {shortest homozygosity run length for inbreeding F_roh}' write(strm,'(a)') 'set map fun kos|hal {set mapping function}', & 'pch <x2> <df> [(ncp <ncp>)|<df2>] {Chi-square or F-dist P-value}', & 'qch <pval> <df> {Chi-square quantiles}', & 'pow [ncp <ncp>] [n <nobs>] [p <pval>] [df <df>] {LRT power}', & 'chi <nr> <nc> {contingency Chi-square}', & 'pol <nr> <nc> {polychoric correlation for contingency table}', & 'tet <prev> <rr> {tetrachoric correlation}', & 'pro <num> <den> [<width>] {CI for proportion}' write(strm,'(a)') 'sml <pA> <penAA> <penAB> <penBB> {recurrence risks}', & 'grr <prev> <pA> <GRR> [<add|dom|rec>] {recurrence risks}', & 'grr <prev> <pCa> <pCo> cas [pop] {recurrence risks case-control data}', & 'ito <pA> [<penAA> <penAB> <penBB>] {carrier rates in relatives}', & 'sml age <pA> <N> [<r>] {age of allele}' write(strm,'(a)') 'set dic <dict> {dictionary}', & 'wor <str> [(..<strN>)|/<a><b>../] {find word (inc wilds/pattern) in dictionary}', & 'ana <str> [<ch>] [<n>] {anagrams of word(s) in dictionary}' end if if (typ == 1 .or. typ == 3 .or. typ == 7) then write(strm,'(a)') '*Operators/functions*', & ' ( ) if then else * / mod + - ^ = not neg pos int round', & ' and or < > ge le ne eq >= <= ^= ==', & ' abs sqrt log exp sin cos tan asin acos atan inht', & ' pnorm qnorm fact julian greg rand rnorm', & ' eps pi y n x "<all>/<all>" "/<all>/"' write(strm,'(a)') & ' istyp|untyp <mar> {genotype available this individual?}', & ' ishom|ishet <mar> {hom/het genotype?}', & ' alla|allb <mar> {first/second allele of genotype}', & ' anytyp alltyp {available active markers?}', & ' protyp numtyp {prop or number markers typed}', & ' commar {max markers typed common to rels}', & ' anymis {missing active traits or markers?}' write(strm,'(a)') & ' isfou isnon {founder/nonfounder?}', & ' female male {male/female?}', & ' num nfoun {family size/no. founders}', & ' famnum index {family no. 1..n, individual no. 1..n}', & ' chosen {acted upon by last operation}' write(strm,'(a)') & 'mac <nam> {create a macro function}', & 'mac <nam> = <value> {define a macro variable}', & 'mac <nam> <- (all|fre) <mar> {save allele list to var}', & 'mac <nam> <- lik|pva|las {save likelihood or P-value or last result to var}', & 'mac <nam> <- bur|che|epo|imp|ite|ls|min|ple|pri|pwd|sex|twi {save state to var}' write(strm,'(a)') & '%<nam> {macro variable - replaced by contents of macro}', & '%% {macro function call "process ID" (random) string}', & '%1 %2..%N {positional arguments of a macro function}', & '%0 {all the arguments of a macro function}', & '%+N {all the macro arguments from Nth onwards}' write(strm,'(a)') & 'let <expr> {evaluate an expression}', & '<expr> : <expr> [: <expr>...] {sequence of expressions}', & '<cmd> $(m|x|h|i|y|q|a|A|D)[rmt[r]] {loci of class, orig/reverse/map order}', & '<cmd> {<val1> <val2>...}|{<n1> : <n2>} {iterate command over contents of braces}', & 'eval [<SEXPR>...] {evaluate a Scheme expression eg "eval (help)"}', & 'eval (locnotes "<loc>") {returns notes for a locus}', & 'eval (locnotes-set! "<loc>" "<str>") {rewrites notes for a locus}' end if if (typ == 1 .or. typ == 4 .or. typ == 7) then write(strm,'(a)') & '*Data*','set dat|wor <path> {data | work directory}', & 'set imp -1|0|1|2|3|nil|off|on|ful|lan|seq {impute unmeasured genotypes}', & 'set ana [obs|imp] {use imputed genotypes in association analysis}', & 'set loc <nam> mar|xma|hap|qua|aff [<mappos>] [<txt>] {declare locus position,type}', & 'set loc <nam> mar ... {declare codominant autosomal marker locus}', & 'set loc <nam> xma ... {declare codominant X-chromosome marker locus}', & 'set loc <nam> hap ... {declare haploid marker locus}', & 'set loc <nam> yma ... {declare Y chromosome (haploid) marker locus}', & 'set loc <nam> mit ... {declare mitochondrial (haploid) marker locus}', & 'set loc <nam> qua ... {declare quantitative trait locus}', & 'set loc <nam> aff ... {declare dichotomous (y/n) trait locus}', & 'dec loc <N><m|x|q|a> [<N2><typ2>...] {declare multiple autonamed loci}', & 'set app [ski|ver] {set handling of repeat locus declarations}', & 'set mem <N><m|x|q|a> [<N2><typ2>...] {preallocate memory for extra loci}', & 'set vir [<thr>] {dataset size threshold for virtual memory}', & 'ren (<loc> [to] <new>)|map <map_fil> [<chr> <bp> <loc>] {rename loci}', & 'ren (<loc> map vcf <vcf_fil> [<INFO_var>] {rename loci from VCF annotation}' write(strm,'(a)') & 'rea ped|mer <fil>|inline [skip <n>] [sep <ch>] [nos] [nop] {declare/read pedigree file}', & 'rea lin|ppd <fil>|inline {declare/read pedigree file Linkage type}', & 'rea cas <fil>|inline [noid] [sex] [sep <ch>] {declare/read pedigree file case data}', & 'rea csv <fil> [noh] [pheno] [sep <ch>] [ski <n>] {read csv inferring locus types}', & 'rea vcf <fil> [...<filN>] [ped_id] {read IDs from VCF file}', & 'rea bin <fil> [old|dat] {read binary/raw Sib-pair pedigree file}', & 'rea pli <pre> [com] {read PLINK .bim .fam .bed files}', & 'rea hap <fil> {read HapMap style genotype file}', & 'rea grm|kin <fil> [rdg] {read GCTA binary or text GRM kinship file}', & 'rea loc fil <fil> <loc> <chr> <pos> [<ref> <alt>] {read locus position,type,map}', & 'rea loc lin <fil> {read Linkage locus position,type,map}', & 'rea loc mer <fil> [xli] [snp] {read Merlin locus file}', & 'rea loc vcf <fil> [ann] [<sta> [<end>]] [hum] {read VCF file locus information}', & 'rea loc pli <fil> [app] [hum] {read PLINK .map file}', & 'rea ann <fil> [<v1>[:<idx>]...<vN>[:<idx>]] [sep] [dump] {read INFO variable from VCF file to annotations}' write(strm,'(a)') & 'rea map <fil> [[k]bp] {read map, guessing format incl GTF, VCF}', & 'set map pos <loc> <pos> {set marker map position}', & 'set map <pos1>...<posN> {set marker map positions}', & 'set dis <dis12> <dis23>...<disN-1N> {set map distances (cM)}', & 'set chr <chr1> [...<chrN>] {set marker chromosomal assignment}', & 'ord <loc1>.[to]..<locN> [$(m|x|q|a)[rm]] {reorder loci}', & 'rea cha <fil> {read UCSC chain file and liftover/update map}' write(strm,'(a)') & 'set sex <thr> [<err>] {set reporting threshold for sex errors}', & 'set sex mar <loc> {declare a sex-informative marker (eg amelogenin)}', & 'set twi <twin> [mer] {twin zygosity (or MZ) indicator}', & 'set twi err [<thr> [N]] {twin/duplicate test cutoffs}', & 'set uns <str> {prefix to generate missing parental IDs}', & 'run {process pedigree data}', & 'kee <loc1>.[to]..<locN> [$m|x|h|q|a] {retain loci in analysis}', & 'dro <loc1>.[to]..<locN> [$m|x|h|q|a] {drop loci from analysis}', & 'und [<loc1>.[to]..<locN> [$m|x|q|a]] {return loci to analysis}' write(strm,'(a)') & 'kee|dro|und whe (num|mis) <c_op> <ntyp> {keep/drop loci on number typed}', & 'kee|dro|und whe [not] chr <chr>..<chrN> {keep/drop loci on chromosome}', & 'kee|dro|und whe pos <pos1> [--|<pos2>...] {keep/drop loci on map position/range}', & 'kee|dro|und whe in <fil> {keep/drop loci listed in file}', & 'kee|dro|und whe nea <loc1>..<locN> [N] {keep/drop N loci near target}', & 'kee|dro|und whe <str> {keep/drop loci on annotations}', & 'kee|dro|und whe dis <dis>|r2 <r2>|eve (<Nth>|<prop) {keep/drop loci on density}', & 'kee|dro|und whe mon|dia|snp {keep/drop monomorphic or diallelic markers}', & 'kee|dro|und whe all <c_op> <num> {keep/drop loci on number of alleles}', & 'kee|dro|und whe spe <alleles> {keep/drop loci on allelic spectrum}', & 'kee|dro|und whe max|maf <c_op> <frq> {keep/drop loci on major/minor allele frequency}', & 'kee|dro|und whe (hwe|tes) [<c_op> <pva>] {keep/drop loci on test P value}', & 'kee|dro|und whe hom [<c_op> <val>] {keep/drop loci on observed homozygosity}', & 'kee|dro|und whe cov <tra> [[<c_op>] <mislev>] {keep/drop marker on trait coverage}' write(strm,'(a)') 'sel [con|exa <npro> whe] <expr> {select pedigrees}', & 'sel [ped|id] [not [in]] (<ped1>...<pedN>|fil <fil>) {select on name}', & 'uns [<Nth>] {unselect/return pedigrees to analysis (undo Nth last select)}', & 'pac [loc|ped] {delete dropped pedigrees and loci permanently}' write(strm,'(a)') & 'rec [<mar>|$(m|x)] [fre] {recode alleles to 1..n by size/freq}', & 'rec [<mar>|$(m|x)] [let|nuc|num] {recode nt alleles to/from numbers}', & 'rec [<mar>|$(m|x)] [ref|maj [vcf <fil>] [<tra>]] {recode missing alleles to reference allele}', & 'rec <loc> <val1>..<valN> to <new> [..<newN>] {recode old values to new}', & 'rec <loc> aff|cat {recast trait locus to/from quantitative class}', & 'fli <mar> {flip/recode SNP nucleotides to complementary strand}', & 'fli map|fas [<fil>] {flip/recode/compare SNP nucleotides to fasta/VCF/GFF reference strand}', & 'swa <mar> [...<mar>] {swap SNP allele labels around for active individuals}', & 'swa <tra> [lod <thr>] {test and repair likely SNP allele/strand swap within stratum}', & 'snp <mar> <qua tra> [add|dom|rec] {Dummy encode SNP genotype}', & 'com <mar1>..<marN> [<thr>] {combine/recode rare alleles}' write(strm,'(a)') & 'get <rel> sum|mea|min|max|cou|sam <loc> [<new>] {get/save relatives trait value summary}', & 'get all|chi|off|par|sib|spo <sum> <loc> [<new>] {get/save relatives trait value summary}', & 'get bro|dau|fat|hus|mot|son|wif|sis ... {get/save relatives trait value summary}', & 'blo|ran <tra> <rank> {rank or Blom score for trait values}', & 'qua <tra> [...<tra>] {quantile normalization}', & 'kap <tra> <cen> [res] {survivor function estimate}' write(strm,'(a)') & 'dat (<yyyymmdd> jul)|(<num> gre) {julian date conversion}', & 'dat [<tra>] [jul|gre|yea] [<fmt>] {julian date conversion}' , & 'adj <tra> on <loc1> [to <xval>|m|f] {linear regress adjust}' , & 'res <tra> on <loc1>...<locN> [com] {linear regress resid}', & 'pre <tra> on <loc1>...<locN> [com] {linear regress predicted}', & 'imp <tra> on <loc1>...<locN> [com] {linear regress imputation}', & 'imp <tra> {familial imputation (esp age)}', & 'imp sex {genotype based sex imputation}' write(strm,'(a)') & 'edi <ped> <per>|all <loc> [to] <val1> [<val2>] {edit data}', & 'cop <ped1> <per1> [to] <ped2> <per2> [mer] {copy data}', & 'mer [<loc>..<locN>] <fil> [sep <sep>] {merge data from phenotype file}', & 'mer bed <pre> [joi|com] [id] [pos] {merge data from plink .bim/.bed files}', & 'mer gen <fil> [loc|ill|csv] [qua c_op <thr>])] [ski <n>] {merge genotype file (eg id loc a1 a2 qs)}', & 'mer pro <datfil> [(key <tra>)|(fil <fil>)] [mac|imp] {merge genotype probability file}', & 'mer dos <datfil> <thr> {merge PLINK format dosage data}', & 'mer mac <datfil> <pedfil> <thr> {merge data from MaCH/minimac}', & 'mer vcf <fil> [ped_id] [qua <QCstat> [<c_op> <thr>]] [ref] {merge data from VCF style genotype file}', & 'mer fim <locfil> <genfil> [ped_id] {merge data from FImpute style genotype file}', & 'mer [<loc>..<locN>] inline|<fil> com {compare data to phenotype file}', & 'upd [<loc>..<locN>] inline|<fil> {update data from phenotype file}', & 'del <ped> <per>|all {delete/set all data missing for individual or}', & 'del [<loc1>...<locN>] whe <expr> {delete/set selected data missing}', & 'sta <loc> [fam] {standardize trait value}' write(strm,'(a)') & 'sim ped <nped> <ngen> <minoff> <maxoff> [<prefix>] {simulate pedigrees}', & 'sim <mar> [<linked_to>] [<Nall>|<frq1>...<frqN>] {simulate a marker}', & 'sim <tra> [<h2>] [<linked_to>] {simulate a trait}', & 'sim qtl <tra> <mar> [<h2>] {simulate qtl genotypes}', & 'sim drop <mar> {simulate genotypes by gene dropping}', & 'per <tra> {permute trait values within pedigrees}' write(strm,'(a)') & 'nuc [<maxsibs>] [gra] {convert to (trimmed) nuclear families}', & 'joi <ped1> [...<pedN>] {join up pedigrees by shared IDs}', & 'sub {divide into subpedigrees (if compound)}', & 'pru <tra> [c_op <thr>] {prune unaffecteds}' , & 'cas <tra> [all] [new] {divide into unrelated cases}' , & 'uni [seq] {generate unique numerical IDs}', & 'has [<fil>|fil <fil> [<pedcol>] <idcol>|(id|<ped>) <id>|sho|del|siz <pc>] {hash search for IDs}', & 'has loc [<loc>]|sho loc {hash search for locus}' write(strm,'(a)') & 'pri ped <ped1>...<pedN> [id <id1>...<idN> [nearest <n>]] {print data}', & 'wri {print data}', & 'hea|tai [<nrec>|(<sta> <nrec>)] {print head/part/tail of pedigree}', & 'hea|tai map|loc|kin] [$m...] [<nrec>] {print head/tail map, loci, kinships/grm}', & 'mor [<nrec>] {page through pedigree file}', & 'wri [gas] <fil> {write GAS type ped file}' write(strm,'(a)') & 'wri arl <fil> [<pop>] {write Arlequin data file}', & 'wri asp|tcl|fba [dum] <fil> {write Aspex/FBAT pedigree file}', & 'wri bea <fil> [fou|tri] {write Beagle type file}', & 'wri bin <fil> [com] {write binary/raw Sib-pair pedigree file}', & 'wri cri <fil> {write Cri-map pedigree file}', & 'wri csv <fil> [<sep> [<mis> [<genomis>]]] {write CSV type file}', & 'wri dos <fil> [noh] {write ID-major SNP dosage file (set tabsep, misval prn)}', & 'wri blu <fil> [<filt>] {write blupf90 SNP genotype file}', & 'wri gs3 <fil> [<filt>] {write gs3 SNP genotype file}', & 'wri fin <fil> [<filt>] {write findhap SNP genotype file}', & 'wri fim <fil> chip <tra> [<filt>] {write FImpute SNP genotype file}', & 'wri dot <fil> [<tra> [<mar>|<tra>]] {write Dot graph file drawing pedigree}', & 'wri fis <fil> {write FISHER pedigree file}' write(strm,'(a)') & 'wri gda <fil> {write GDA pedigree file}', & 'wri gh <fil> [dum] {write Genehunter pedigree file}', & 'wri hap <fil> [dum] {write Haploview pedigree file}', & 'wri lin|pre <fil> [dum] {write Linkage pre-Makeped pedigree file}', & 'wri men <fil> [new] [tra] {write MENDEL pedigree file (trait as factor/locus)}', & 'wri mer [dum] <fil> {write Merlin pedigree file}' write(strm,'(a)') & 'wri mim <fil> {write MIM pedigree file}', & 'wri mor <fil> {write MORGAN pedigree file}', & 'wri pap {write PAP trip.dat and phen.dat}', & 'wri ped <fil> {write Sib-pair/GAS pedigree file}', & 'wri phe <fil> {write FBAT/Sibs type phenotype file}', & 'wri pli <pre> [<tra> [<filt>]] {write PLINK .bed .fam .bim files}', & 'wri ppd [dum] <fil> {write Linkage post-Makeped pedigree file}', & 'wri pro <fil> [<tra>] {write row-major (Impute2) SNP genotype probabilities file}', & 'wri ram <tra> {write LDL_rams ped and dat files}', & 'wri roa <tra> {write Roadtrips SNP genotype file}', & 'wri sag <fil> {write SAGE pedigree file}', & 'wri sas <fil> [<sep>] {write SAS script with inline data cards}', & 'wri sib <fil> [mer] {write Sib-pair script with pedigree data inline}', & 'wri snp <fil> [<tra>] [noh] {write row-major (tped) SNP genotype data}', & 'wri sna <fil> [<tra>] [key <tra>] {write row-major WOMBAT SNP dosage data}', & 'wri sup <fil> [<tra>] {write row-major SuperlinkSNP genotype data}', & 'wri sol <fil> [phe|gen] [nop] {write Solar type pedigree|phenotype|marker file}', & 'wri str <fil> [fou] {write Structure type data file}', & 'wri vcf [<fil> [ped_id] [<filt>]] {write VCF type genotype file}' write(strm,'(a)') & 'wri loc asp|tcl <fil> {write ASPEX locus file}', & 'wri loc bea <fil> {write Beagle marker file}', & 'wri loc dis <fil> <chr> {write DISTmix data file}', & 'wri loc ecl <fil> {write Eclipse data file}', & 'wri loc fis <fil> {write FISHER locus file}', & 'wri loc gas <fil> {write GAS locus file}', & 'wri loc lok <fil> [<pedfil>] {write Loki "prep" control file}', & 'wri loc gh [dum] <fil> [xli] {write Genehunter locus file}', & 'wri loc hap <fil> {write Haploview info file}' write(strm,'(a)') & 'wri loc lin <fil> [dum] [xli] {write Linkage locus file}', & 'wri loc mli <fil> [ste] [end] {write twopoint MLINK locus file}', & 'wri loc men <fil> [tra] [new|snp] {write MENDEL locus file}', & 'wri loc mer <fil> {write Merlin locus file}', & 'wri loc mor <fil> {write MORGAN locus file}', & 'wri loc pap {write PAP header.dat and popln.dat}' , & 'wri loc rel <fil> {write RELPAIR locus file}', & 'wri loc sag <fil> [par] {write SAGE locus or parameter file}', & 'wri loc sib <fil> [<pedfil>] {write Sib-pair script}', & 'wri loc str <pedfil> [<mainp>] {write Structure mainparam}', & 'wri loc sup <fil> [dum] [xli] {write Superlink (GH) locus file}', & 'wri loc vcf <fil> [<tra>] {write VCF locus file without genotypes}', & 'wri loc fim <fil> [chip] <tra> {write FImpute locus file}', & 'wri loc fin <fil> {write findhap locus file}' write(strm,'(a)') & 'wri map lok <fil> {write Loki parameter file}', & 'wri map men <fil> [new|snp] {write MENDEL map file}', & 'wri map mer <fil> {write Merlin map file}', & 'wri map sol <fil> {write Solar map file}', & 'wri map pli <fil> {write PLINK map file}', & 'wri var [men] <fil> {write MENDEL var file}', & 'wri kin <fil> [<tra>] [pai] {write big square/listwise kinship matrix}', & 'wri grm <fil> [<tra>] {write GCTA binary GRM kinship file}' end if if (typ == 1 .or. typ == 5 .or. typ == 7) then write(strm,'(a)') '*Analysis*', & 'gen [<qua tra> [rev]] {summarize pedigree(s) and (save) generations}', & 'loo <ind> {show or mark marital or inbreeding loops}', & 'rel <ped> <id> [kin] {show immediate relatives of index, kinships}', & 'anc <tra> [c_op <thr>] {common ancestor of most probands}', & 'typ [<tra>] {number genotyped stratified by trait}', & 'cou|pri [[whe] <expr>] {count or print where expression true}', & 'cum <tra> [<idx>] {cumulative index for binary trait probands}' write(strm,'(a)') & 'hap <loc1> <loc2> <hap> [<thr>] {combine two markers into haplotypes}', & 'hap (mit|yha) <loc1>..<locN> <hap> {combine haploid markers into haplotypes}', & 'tri {show triad-phaseable haplotypes}', & 'fre|des [snp|(<loc1>..<locN>)] [pol] {descriptive stats and familial association}', & 'his <qua tra> [<nbins>] {histogram and normality test}', & 'plo <tr1> <tr2> [<tr3>] [<fil>] {Postscript scatterplot}' write(strm,'(a)') & 'nor [<loc1>..<locN>] {Filliben correlation normality test}', & 'mea|cor [<loc1>..<locN>] {phenotypic means and correlations}', & 'cor distance [<loc1>..<locN> [versus <locN+1>..]] {distance correlations}', & 'pca [[ibs] <loc1>..<locN>] {principal components analysis}', & 'mds <ax1>...<axN>] {marker IBS multidimensional scaling}', & 'mix <qua tra> [[<num>] [nor|poo|exp|poi]] {test admixture}', & 'tab [ordered] [showmiss] [sampleweight <tr>] [<tr1> [<tr2>..<trN>]] {contingency table and test}', & 'tab polychoric <tr1> <tr2> {contingency table and polychoric correlation}', & 'tab ped <tra> {tabulation by pedigree and Tarone test}', & 'tab totals [tr1..trN] <qua tra> {tabulated totals}', & 'tab allelic <tra> [..trN] <mar> {BLUE allele frequency tabulation by stratum}', & 'llm <v1> + <v2> + <v1>*<v2> + ...[-1] {log-linear model of contingency table}', & 'llm ... [all] [wei <tr>] {log-linear model with allelic effect coding (HWE etc)}', & 'kru <qua tra> <loc1> [..<locN>] {Kruskall-Wallis test}' write(strm,'(a)') & 'reg <qua tra> on <loc1>.[to]..<locN> {linear regression}', & 'reg <bin tra> on <loc1>.[to]..<locN> [off <off>] [sim] [rep <n>] {logistic regression}', & 'reg <tra> on <loc1>.[to]..<locN> [off <off>] poisson [sim] [rep <n>] {poisson regression}', & 'reg ... [off <off>] exponential|weibull|evd [<cens>] [shape <sha>] [sim] [rep <n>] {survival regression}', & 'clr <bin tra> on <loc1>.[to]..<locN> [ped|stratum <str>] {conditional logistic regression}', & 'lif <sta> <end> <cen> [<wid1> [<wid2>]] [tim] [cov <cov>] {life table}', & 'sur <tim> <cen> <cov> [..covN] {nonparametric survival analysis}' write(strm,'(a)') & 'dav <tra> <pro> {segregation ratios under ascertainment}', & 'seg <mar> [unp] {segregation of a marker}', & 'hwe [fou] {test HWE}', & 'dis|ld all|r2|dpr|(<loc1> [<loc2> [..<locN>]]) {intragametic association/disequilibrum}', & 'dis|ld <loc1> <loc2> [..<locN>] <tra> {haplotype association}', & 'clu [<pcrit> <rmax> <win> nosave] {clump/prune markers where non-independent (due LD) tests}', & 'nef <win> <pcrit> {effective number (due LD) of marker tests}', & 'hom [<tra> [<c_op> <thr>]] {marker homozygosity}', & 'mul [(<tra> [<c_op> <thr>])|save <tra>] {multipoint homozygosity/roh inbreeding coef}', & 'fst <pop> [fou] {Population genetic F-statistics}' write(strm,'(a)') & 'set kin [A|C|G|rid <coe>] {set/manipulate big kinship matrix}', & 'kin [pai|inb [mc] <coe>|dom|ibs|<tra> [c_op <thr>]] {kinship/inbreeding coefs}', & 'ibd <loc> [<loc2>..<locN>] [pai] {relative pair IBD sharing at marker(s)}', & 'hbd <loc> [<coe>] {homozygosity-by-descent at marker}', & 'mcf <mar1> [..<marN>] {MCEM allele frequencies}', & 'blu <mar> [<tra> [<c_op> <thr>]] [kin <fil> [<rdg>]] {BLUE allele frequencies}', & 'gpe <mar> [mcmc] [<dose>] {ML/MCMC genotype probability estimates}', & 'pee <mar> {Iterative peeling likelihood calculator}' write(strm,'(a)') & 'ibs [kin|mom| (<tra> [<c_op> <thr>])] {IBS sharing at multiple markers}', & 'cki {sib pair IBS sharing at multiple markers}', & 'sha {rel pair IBS sharing at multiple markers}', & 'tes sex {test sex using markers}', & 'tes hap [yha|mit] {test mendelism using Y/mitochondrial haploid markers}', & 'tes [loc|lange] [<mar1> [...<marN>]] {test mendelism}', & 'tes map [(mer [<thr>])|<fil>] {identify or merge duplicate map positions}', & 'tes fim <locfil> <genfil> [ped_id] {compare to FImpute genotype file}', & 'tes ids <fil> [[ped_pos] id_pos] {compare IDs to VCF or other file}', & 'tes vcf <fil> [ped_id] [qua <QCstat> [<c_op> <thr>]] {compare genotypes to VCF file}', & 'tes str [<mar1> [...<marN>]] {test for strand mixtures and problems}', & 'tes fli map|fas <fil> {test for flips wrt reference strand}', & 'tes fli <tra> [lod] {test for flips/swaps associated trait indicating source}', & 'tes zyg {test for MZ twins or duplicates using current big kinship matrix}', & 'tes dup [<poi>] {test for MZ twins or duplicates using markers}', & 'tes dup dob <tra> [<poi>] [thr <thr>] {test for twins using sibship and age/DOBs}', & 'tes dup ids [mer] {test duplicate IDs using markers and merge data}', & 'tes <ped> <id> [<ped2> <id2>] {test for a twin using markers}', & 'tes (age <qua>)|(dob <qua> [gre]) [<thr>] {test consistency of ages/DOBs}', & 'mzt [<zyg>] fin {identify MZ twin pairs by genotype concordance}' write(strm,'(2a)') 'mzt [<zyg> [<c_op> <thr>]] [del|cle|unl]', & ' {MZ twin genotype discordance|drop one member}', & 'ass <tra> [(<c_op> <thr>)|cat] [fou] [gen|snp|fre|maf|ris] ', & ' {allelic/genotypic association}' write(strm,'(a)') & 'ass <tra> ... [cov <cov>] [ibd <mar>] {allelic/genotypic association}', & 'ass <tra> vcf <fil> {allelic association versus external control frequencies from VCF file}', & 'mit|yha (<tra>|hap) [<mar1> [...<marN>]] {mitochondrial/Y haplotype association}', & 'rar (<tra>|<mar>) [<thr>] {rare allele counts and association test or carrier indicator}', & 'ska <tra> [mad|beta] {SKAT set-based association test}', & 'mgt <tra> [<mar>] [cov <tra>...] {VC allelic association test}', & 'tre <tra> <mar> [perm] {Jonckheere-Terpstra trend association test}', & 'wql <tra> [kin <fil>|G [rdg]] {extended WQLS allelic association}', & 'mql <tra> [<c_op> <thr>] [<prev>] [wql] {MQLS allelic association}', & 'str <tra> <str> [sampleweight <wt>] {stratified allelic association}', & 'int <tra> <str> [sampleweight <wt>] {stratified allelic association interaction test}', & 'str <tra> <cov> <str> [sampleweight <wt>] {Whitehead stratified (RE) association}', & 'hrr <tra> [<c_op> <thr>] {haplotype relative risk}', & 'tdt <tra> [<c_op> <thr>] [pat|mat] {several TDTs}', & 'sch <tra> [<mar> [<all>]] {Schaid & Sommer HWE/CPG test}', & 'sdt <tra> {sibship disequilibrium test}' write(strm,'(a)') & 'lin [<mar>] [<mar>]] {Elston-Keats sib-pair intermarker linkage analysis}', & 'lod <mar1> <mar2> [<theta>] {Two-point linkage lod score analysis}', & 'pen <loc1> <loc2> {Penrose sib-pair linkage analysis}', & 'asp <tra> [<c_op> <thr>] {affected sib-pair IBS/IBD linkage analysis}', & 'apm <tra> [<c_op> <thr>] [ibd|ibs] {IBS or IBD APM linkage analysis}' write(strm,'(2a/a/a/a)') 'sib <tra> [<wei>] [sim] [cor <r> [mea <m>]', & ' [sd|var <v>]] {Sham & Purcell QTL linkage regression}', & 'vis <tra> [<wei>] [sim] {Visscher & Hopper H-E QTL linkage regression}', & 'he1 <tra> [<wei>] [sim] {Trad Haseman-Elston QTL linkage regression}', & 'he2 <tra> [<wei>] [sim] {Cross-product Haseman-Elston QTL linkage regression}', & 'two <tra> <loc1> <loc2> <theta> {two-point Haseman-Elston}' write(strm,'(2a)') 'qtl <tra> [full [cqe] [cov <var1>..<varN>]]', & ' {sibs or pedigree Variance Components linkage}', & 'var|mft <tra> [[a][c][d]e] [cov <var1>..+..<varN>]', & ' {Variance Components (VC) or MFT trait analysis}', & 'var|mft <tra> [aqe (inl|ibs|<mar1> [..+..<marN>])] [cov ...]', & ' {Variance Components (VC) or MFT multipoint linkage analysis}' write(strm,'(a)') & 'blu <tra> <h2> {BLUP for AE variance components model}', & 'fpm <tra> [<c_op> <thr>] [nqtl <nqtl>] [p] [a] [d] [g] [c] [s] {MCMC mixed/SML/finite polygenic model}' write(strm,'(a)') & 'fpm <tra> ... [(p|g|a|c|s)va|AA|AB|BB|mu|var <val>] {MCMC fpm start values}', & 'fpm <tra> ... [fixed p|a|c|d|e|g|m|mu|s|var {MCMC fpm fixed pars}', & 'fpm <tra> ... [lin logit|probit|ln|mft] [lik gau|bin|poi|gam] [cov <var1> [+ <var2>...] {MCMC fpm GLMM pars}', & 'fpm <tra> ... [lik wei cen <tra>] [pri|sav <blu>] {MCMC fpm survival analysis}' write(strm,'(a)') & 'twi {Twinning rate}', & 'twi <tra> [<zyg> [<c_op> <thr>]] {Classical twin analysis}', & 'ken <age> <tra> [<zyg> [<c_op> <thr>]] {Twin ranks-based survival analysis}' write(strm,'(a)') & 'lrt [<annot>] {Compare last 2 models fitted (mix/VC/GLM/GLMM)}', & 'sum [<num>|(plo [qq]|dum) [<fil>]|tab|get <v>|com <loc>...] {Summarize n highest tests from last command}', & 'rea sta (<fil> [<pos> [<nam>]] )|(vcf <fil> <var>[:<idx>] [<sub>]) {Read in test statistics for loci}' end if if (typ >= 7) then lenr=len_trim(regexp) do i=lenr, 1, -1 regexp((i+1):(i+1))=regexp(i:i) end do regexp(1:1)='*' lenr=min(20,lenr+2) regexp(lenr:lenr)='*' i=0 rewind(strm) write(outstr,*) do read(strm,'(a)', iostat=ioerr) lin if (ioerr /= 0) exit if (strfind(regexp, lin, 2)) then i=i+1 write(outstr,'(a)') trim(lin) end if end do close(strm,status='delete') if (i==0) then write(outstr,'(a)') 'No match in online help' end if end if end subroutine help ! ! pass line to shell -- requires existence of fairly ! standard routine system() subroutine shell(lin, plevel) use outstream character (len=*), intent(inout) :: lin integer :: plevel integer :: fin, i, sta sta=1 do while (lin(sta:sta) /= '$') sta=sta+1 end do sta=sta+1 do while (lin(sta:sta) == ' ') sta=sta+1 end do fin=len_trim(lin) lin=lin(sta:fin) fin=fin-sta+1 i=1 do while (i <= fin) #if defined (WIN32) || defined (IFORT) || defined (NOESCAPE) if (lin(i:i) == '\') then #else if (lin(i:i) == '\\') then #endif lin=lin(1:(i-1)) // lin((i+1):fin) fin=fin-1 end if i=i+1 end do if (plevel >= 0) then write(outstr,'(a/3a/a)') '!','! "',lin(1:min(fin,75)),'"','!' end if call system(lin(1:fin)) end subroutine shell ! ! write elapsed time since first/last asked ! subroutine stamp(t0) use outstream integer, intent(in) :: t0 integer :: t1, ticks real :: elapsed call system_clock(t1, count_rate=ticks) elapsed=float(t1-t0)/float(ticks) if (elapsed < 120.0) then write(outstr,'(/a,f5.1,a)') 'This job has taken ',elapsed,' seconds' else if (elapsed < 7200.0) then write(outstr,'(/a,f5.1,a)') 'This job has taken ', elapsed/60.0, ' minutes' else write(outstr,'(/a,f5.1,a)') 'This job has taken ', elapsed/3600.0, ' hours' end if return end subroutine stamp ! ! time a procedure ! subroutine proct(t1, plevel) use outstream real, intent(out) :: t1 integer, intent(in) :: plevel real :: t2 call cpu_time(t2) if (plevel /= 0) write(outstr,'(a,f8.2,a)') '[',t2-t1,' s]' t1=t2 end subroutine proct ! ! Read a MERLIN locus file ! subroutine rdmerloc(port, xli, nloci, loc, locpos, outpos, loctyp, & locnotes, numloc, twinning, twintype, twintrait, & nread, plevel) use fileio use outstream use scanner use parser_data use storage_classes use locus_types type (ioport) :: port integer, intent(in) :: xli integer, intent(inout) :: nloci character (len=*), dimension(:), intent(out) :: loc integer,dimension(:), intent(out) :: locpos, outpos integer,dimension(:), intent(out) :: loctyp character (len=*), dimension(:), intent(out) :: locnotes ! Number of columns of data for each data class integer, dimension(NDATACLASS), intent(out) :: numloc ! zygosity indicator integer, intent(out) :: twinning integer, intent(out) :: twintype character (len=*), intent(out) :: twintrait integer, intent(out) :: nread integer, intent(in) :: plevel ! local variables integer :: ioerr, k, k2, mact, mclass, mdel, mdir, narg character (len=1) :: ch character (len=256) :: lin character (len=40), dimension(2) :: words nread=nloci numloc=0 ! marker class: autosomal, xlinked, +/- compressed mact=LOC_CODOM+xli mdel=DEL_CODOM+xli mdir=1 mclass=GCLASS if (xli >= LOC_CMP) then mdir=-1 mclass=SCLASS end if do call readline(port, lin, ios=ioerr) if (ioerr /= 0) exit narg=2 call args(lin, narg, words, ' ', SEP_WHITE) ch=words(1)(1:1) if (ch /= 'E') then nloci=nloci+1 loc(nloci)=words(2) numloc(TCLASS)=numloc(TCLASS)+1 outpos(nloci)=numloc(TCLASS) if (ch == 'M') then loctyp(nloci)=mact locpos(nloci)=sign(numloc(mclass)+1, mdir) numloc(mclass)=numloc(mclass)+2 numloc(TCLASS)=numloc(TCLASS)+1 else if (ch == 'A') then loctyp(nloci)=LOC_AFF locpos(nloci)=numloc(PCLASS)+1 numloc(PCLASS)=numloc(PCLASS)+1 else if (ch == 'Z') then twinning=nloci twintype=2 twintrait=loc(nloci) loctyp(nloci)=LOC_QUA locpos(nloci)=numloc(PCLASS)+1 numloc(PCLASS)=numloc(PCLASS)+1 write(outstr,'(/3a/)') & 'NOTE: The phenotype "', trim(twintrait), & '" now indicates monozygotic (twin) sibships.' else if (words(1)(1:2) == 'S2') then loctyp(nloci)=mdel locpos(nloci)=sign(numloc(mclass)+1, mdir) numloc(mclass)=numloc(mclass)+2 numloc(TCLASS)=numloc(TCLASS)+1 else if (words(2)(1:6) == 'COUNT(') then call args(lin, narg, words, ',', SEP_CHAR) ! minimac appends indel information after colon eg 18:29018380:T_TC k=index(words(2),':', back=.TRUE.) k2=index(words(2),':') if (k == k2 .and. k < 4) k=len_trim(words(2)) loc(nloci)=words(2)(1:(k-1)) loctyp(nloci)=LOC_CODOM+LOC_CMP locpos(nloci)=-(numloc(SCLASS)+1) numloc(SCLASS)=numloc(SCLASS) + 2 numloc(TCLASS)=numloc(TCLASS)+1 else loctyp(nloci)=LOC_QUA locpos(nloci)=numloc(PCLASS)+1 numloc(PCLASS)=numloc(PCLASS)+1 end if locnotes(nloci)=lin if (plevel > 0 .and. mod(nloci, 1000) == 1) then write(outstr, '(a,i0)') 'Reading locus ', nloci end if end if end do nread=nloci-nread end subroutine rdmerloc ! ! Read PLINK or other .map file (combines locus and map information) ! typ=1: standard PLINK, one dummy trait, overwrite any existing loci ! 2: PLINK, no dummy trait, append ! 3: Other, columns specified, append ! chrcode=1: standard codes for chromosomes, number, X, Y, Mt ! 2: and, 23=X 24=Y 25=PAR 26=Mit ! subroutine rdloci(port, typ, chrcode, namechek, nloci, loc, lochash, & locpos, outpos, loctyp, locnotes, numloc, group, map, nread) use iobuff use outstream use scanner use recast_data use parser_data use storage_classes use locus_types use lochash_class use locus_list use fileio type (ioport) :: port integer, intent(in) :: typ, chrcode logical, intent(in) :: namechek integer, intent(inout) :: nloci character (len=20), dimension(:), intent(inout) :: loc type (hash_table) :: lochash integer,dimension(:), intent(inout) :: locpos, outpos integer,dimension(:), intent(inout) :: loctyp character (len=annotation_width), dimension(:), intent(inout) :: locnotes ! Number of columns of data for each data class integer, dimension(NDATACLASS), intent(inout) :: numloc character (len=chromosome_width), dimension(:), intent(inout) :: group double precision, dimension(:), intent(inout) :: map integer, intent(out) :: nread ! local variables integer, parameter :: MISS=-9999 integer :: firstsnp, i, ios, n, nmapped, nskipped character (len=chromosome_width) :: chrom character (len=annotation_width), dimension(5) :: colnames character (len=annotation_width), dimension(:), allocatable :: words ! columns containing the key variables integer :: lastcol integer :: chrpos, snppos, cmpos, bppos, refpos, altpos ! functions logical :: isint integer :: ival double precision :: fval nread=nloci ! note that nloci is reset before rdloci is called when typ=1 if (typ == 1) then nread=0 nloci=nloci+1 numloc(:)=0 loc(nloci)='trait' loctyp(nloci)=LOC_AFF numloc(PCLASS)=numloc(PCLASS)+1 numloc(TCLASS)=numloc(TCLASS)+1 outpos(nloci)=numloc(TCLASS) locpos(nloci)=numloc(PCLASS) locnotes(nloci)=' ' map(nloci)=MISS end if ! ! set the columns to be read ! chrpos=0 snppos=0 cmpos=0 bppos=0 refpos=0 altpos=0 if (typ == 1 .or. typ == 2) then chrpos=1 snppos=2 cmpos=3 bppos=4 refpos=5 altpos=6 allocate(words(6)) else if (typ == 3) then allocate(words(9)) narg=9 call args(lin, narg, words, ' ', SEP_WHITE) if (isint(words(5)) .and. isint(words(6)) .and. isint(words(7))) then snppos=ival(words(5)) chrpos=ival(words(6)) cmpos=ival(words(7)) bppos=ival(words(7)) refpos=ival(words(8)) altpos=ival(words(9)) else colnames(1:2)=words(5:6) colnames(3:5)=words(7:9) call readline(port, lin, ios=ios) narg=countargs(trim(lin), ' ', SEP_WHITE) deallocate(words) allocate(words(narg)) call args(lin, narg, words, ' ', SEP_WHITE) n=0 do i=1, narg if (words(i) == colnames(1)) then snppos=i n=n+1 elseif (words(i) == colnames(2)) then chrpos=i n=n+1 elseif (words(i) == colnames(3)) then bppos=i n=n+1 elseif (words(i) == colnames(4)) then refpos=i n=n+1 elseif (words(i) == colnames(5)) then altpos=i n=n+1 end if if (n == 5) exit end do end if end if ! Abort if insufficient information if (snppos == 0 .or. chrpos == 0 .or. bppos == 0) then if (snppos == 0) then write(outstr, '(a)') 'ERROR: locus name column not specified!' end if if (chrpos == 0) then write(outstr, '(a)') 'ERROR: chromosome column not specified!' end if if (bppos == 0) then write(outstr, '(a)') 'ERROR: map coordinate column not specified!' end if return end if lastcol=max(snppos, chrpos, bppos, cmpos, altpos, refpos) nmapped=0 nskipped=0 firstsnp=nloci+1 main: do call readline(port, lin, ios=ios) if (ios /= 0) exit narg=lastcol call args(lin, narg, words, ' ', SEP_WHITE) if (narg > 0) then if (words(1) == '#' .or. words(1) == '!') then cycle main else if (isinuse(namechek, words(snppos), loc, lochash)) then nskipped=nskipped+1 if (nskipped <= 10) then if (nskipped < 10) then write(outstr,'(3a)') & 'Skipping illegal or duplicate locus name "', trim(words(snppos)), '".' else write(outstr,'(a)') 'Skipping ...' end if end if cycle main end if call chr_convert(chrcode, words(chrpos), chrom) nloci=nloci+1 loc(nloci)=words(snppos) loctyp(nloci)=LOC_CODOM+LOC_CMP if (chrom == 'X' .or. chrom == 'x') loctyp(nloci)=LOC_XLIN+LOC_CMP if (chrom == 'Y' .or. chrom == 'y') loctyp(nloci)=LOC_YHA+LOC_CMP if (chrom == 'MT' .or. chrom == 'mt') loctyp(nloci)=LOC_MIT+LOC_CMP locpos(nloci)=-(numloc(SCLASS)+1) numloc(SCLASS)=numloc(SCLASS)+2 numloc(TCLASS)=numloc(TCLASS)+2 outpos(nloci)=numloc(TCLASS) if (chrom /= '') then locnotes(nloci)=trim(words(bppos)) // ' (chr ' // & trim(words(chrpos)) // ')' end if if (refpos > 0) then if (words(refpos) /= ' ') then if (words(refpos) == '0') then locnotes(nloci)=trim(locnotes(nloci)) // & ' [' // trim(words(altpos)) // '/' // trim(words(refpos)) // ']' else locnotes(nloci)=trim(locnotes(nloci)) // & ' [' // trim(words(refpos)) // '/' // trim(words(altpos)) // ']' end if end if end if if (chrom == 'XY') chrom = 'X' group(nloci)=chrom map(nloci)=1.0d-6*fval(words(bppos)) if (map(nloci) /= 0.0d0) nmapped=nmapped+1 end if end do main if (nmapped == 0 .and. nloci > 1 .and. cmpos /= 0) then call rewind_port(port, ios) narg=4 do i=firstsnp, nloci call readline(port, lin, ios=ios) call args(lin, narg, words, ' ', SEP_WHITE) map(i)=fval(words(cmpos)) end do end if nread=nloci-nread if (nskipped > 0) then write(outstr,'(a,i0,a)') 'NOTE: Skipped reading ', nskipped, ' loci.' end if end subroutine rdloci ! ! read file suffix to obtain hint as to type, currently: ! filtyp 3 GTF/GFF ! 4 VCF ! 5 PLINK .bim ! 6 Sib-pair binary ! subroutine getfilehint(filnam, filtyp) character (len=*) :: filnam integer, intent(out) :: filtyp character (len=3) :: suffix filtyp=0 call extsuffix(filnam, suffix) if (suffix == 'bin') then filtyp=6 else if (suffix == 'bim') then filtyp=5 else if (suffix == 'vcf') then filtyp=4 else if (suffix == 'gff' .or. suffix == 'gtf') then filtyp=3 end if end subroutine getfilehint ! ! Read start of map file, working out file type or column names ! subroutine maphead(port, units, filehinted, lin, words, & filtyp, nampos, chrpos, bppos, mappos, mapunits, plevel) use locus_data use outstream use fileio use scanner use locus_list implicit none type(ioport) :: port integer, intent(in) :: units integer, intent(in) :: filehinted character (len=*), intent(inout) :: lin character (len=40), dimension(:), intent(inout) :: words integer, intent(out) :: bppos, chrpos, filtyp, mappos, mapunits, nampos integer, intent(in) :: plevel ! local variables integer, parameter :: MISS=-9999, TWRK=7 integer :: filehint, i, idx, ioerr, lpos, mapped, & maxarg, narg, nlines, nmark, searchpos ! functions logical :: isreal double precision :: fval ! ! map type is not always specified, so check first two records ! filehint is the declared type ! ! filtyp 0=not readable ! 1=name, position on one line ! 2=alternating lines for name, distance ! 3=GTF (GFF, GVF) ! 4=VCF ! 5=.bim ! 6=Sib-pair binary ! ! nampos = column number for locus name ! chrpos = column number for chromosome name ! bppos = column number for map position in base pairs ! mappos = column number for map position in map units ! mapunits = main map units: M, cM, Mbp, kbp, bp ! filehint=filehinted if (filehint == 0) then call getfilehint(port%filnam, filehint) end if maxarg=size(words) mapunits=units filtyp=1 chrpos=0 nampos=1 mappos=2 bppos=0 nlines=0 call readline(port, lin, ios=ioerr) if (ioerr /= 0) goto 999 if (lin(1:16) == 'Sib-pair raw ped') then narg=1 lin=lin(1:21) words(1) = 'Sib-pair' else narg=maxarg call args(lin, narg, words, ' ', SEP_WHITE) end if if (plevel > 1) then write(outstr,'(/2a)') '1: ',lin(1:65) end if if (words(1) == 'Sib-pair') then filtyp=6 if (plevel > 0) then write(outstr,'(3a/)') & 'NOTE: Reading as a Sib-pair ', lin(18:21), ' binary dataset.' end if else if (words(1)(1:5) == '##gff' .or. words(1)(1:5) == '##gvf') then filtyp=3 chrpos=1 bppos=4 if (plevel > 0) then write(outstr,'(a/)') 'NOTE: Reading as a GTF file.' end if else if (words(1)(1:12) == '##fileformat' .or. & words(1)(1:15) == '##SnpEffVersion') then filtyp=4 chrpos=1 bppos=2 nampos=3 if (plevel > 0) then write(outstr,'(a)') 'NOTE: Reading as a VCF file.' end if else if (words(1) == '#CHROM' .and. words(2) == 'POS' .and. words(3) == 'ID') then filtyp=4 chrpos=1 bppos=2 nampos=3 else if (ichar(words(1)(1:1)) == 67) then write(outstr,'(a,i0,a)') & 'NOTE: An Affy XDA format CDF file v', ichar(words(1)(5:5)), '.' filtyp=0 else if (ichar(words(1)(1:1)) == 108 .and. ichar(words(1)(2:2)) == 27) then write(outstr,'(a)') 'NOTE: A PLINK .bed file.' filtyp=0 else if (narg == 1) then ! a MENDEL type map file? if (.not.isreal(words(1))) then call readline(port, lin, ios=ioerr) if (ioerr /= 0) goto 999 if (plevel > 1) then write(outstr,'(2a)') '2: ',lin(1:65) end if narg=maxarg call args(lin, narg, words, ' ', SEP_WHITE) if ((narg == 1 .or. narg == 2) .and. isreal(words(1))) then filtyp=2 if (plevel > 0) then write(outstr,'(a)') 'NOTE: Guessed to be a MENDEL map file.' end if end if end if else if (narg == 2) then ! presume name, mappos or mappos, name if (.not.isreal(words(1)) .and. .not.isreal(words(2))) then call readline(port, lin, ios=ioerr) if (ioerr /= 0) goto 999 narg=maxarg call args(lin, narg, words, ' ', SEP_WHITE) end if if (narg == 2) then if (isreal(words(1)) .and. .not.isreal(words(2))) then nampos=2 mappos=1 else if (.not.isreal(words(1)) .and. isreal(words(2))) then nampos=1 mappos=2 end if end if else if (narg >= 3) then ! most likely chr, name, mappos or name, mpos, fpos ! but can be chr, mappos, name or even name, chrom, mappos if (.not.isreal(words(1)) .and. .not.isreal(words(2)) .and. & .not.isreal(words(3))) then call readline(port, lin, ios=ioerr) if (ioerr /= 0) goto 999 narg=maxarg call args(lin, narg, words, ' ',SEP_WHITE) end if if (narg == 3) then if (.not.isreal(words(1)) .and. isreal(words(2)) .and. & isreal(words(3))) then nampos=1 if (fval(words(2)) < 30.0d0 .and. fval(words(3)) > 30.0d0) then chrpos=2 mappos=3 if (fval(words(mappos)) > 30.0d0) then bppos=mappos end if if (plevel > 0) then write(outstr,'(a)') 'NOTE: Guessed name, chr, position.' end if else if (fval(words(2)) > 30.0d0 .and. fval(words(3)) < 30.0d0) then mappos=2 chrpos=3 if (fval(words(mappos)) > 30.0d0) then bppos=mappos end if if (plevel > 0) then write(outstr,'(a)') 'NOTE: Guessed name, position, chr.' end if else mappos=2 if (fval(words(mappos)) > 30.0d0) then bppos=mappos end if if (plevel > 0) then write(outstr,'(a)') 'NOTE: Guessed name, position.' end if end if else if (isreal(words(1)) .and. .not.isreal(words(2)) .and. & isreal(words(3))) then ! MERLIN maps have ! (chr at position 1) locus name at 2, map position at 3 chrpos=1 nampos=2 mappos=3 if (plevel > 0) then write(outstr,'(a)') 'NOTE: Guessed to be a MERLIN map file.' end if else if (isreal(words(1)) .and. isreal(words(2)) .and. & .not. isreal(words(3))) then chrpos=1 mappos=2 nampos=3 if (fval(words(mappos)) > 30.0d0) then bppos=mappos end if if (plevel > 0) then write(outstr,'(a)') 'NOTE: Guessed chr, position, name.' end if else if (.not.isreal(words(1)) .and. .not.isreal(words(2)) .and. & isreal(words(3))) then chrpos=1 nampos=2 mappos=3 if (len_trim(words(1)) > 2 .and. len_trim(words(2)) <= 2) then chrpos=2 nampos=1 if (plevel > 0) then write(outstr,'(a)') 'NOTE: Guessed name, chr, position.' end if else if (plevel > 0) then write(outstr,'(a)') 'NOTE: Guessed chr, position, name.' end if else write(outstr,'(a)') & 'NOTE: Did not recognize format! Trying name, position.' end if else if (narg >= 4) then if (filehint == 5 .or. (isreal(words(1)) .and. .not.isreal(words(2)) .and. & isreal(words(3)) .and. isreal(words(4)))) then chrpos=1 bppos=4 mappos=4 nampos=2 if (fval(words(3)) > 0.0d0) then mappos=3 else mapunits=5 end if if (narg == 6) then if (verify(trim(words(5)), 'ABCGTabcgt0') == 0 .and. & verify(trim(words(6)), 'ABCGTabcgt0') == 0) then filtyp=5 write(outstr,'(a)') 'NOTE: Reading as a PLINK .bim format.' end if end if if (plevel > 0) then write(outstr,'(a)') & 'NOTE: Guessed PLINK format; chr, name, pos (cM), coord (bp).' end if else if (.not.isreal(words(1)) .and. isreal(words(2)) .and. & isreal(words(3)) .and. .not.isreal(words(4))) then nampos=1 chrpos=2 mappos=3 bppos=3 mapunits=5 if (plevel > 0) then write(outstr,'(a)') & 'NOTE: Guessed name, chr, coord (bp), alleles etc.' end if else write(outstr,'(a)') & 'NOTE: Did not recognize format! Trying name, position.' end if end if end if call rewind_port(port, ioerr) if (ioerr /= 0) then write(outstr,'(a,i0,a)') 'ERROR: Unable to rewind ios=', ioerr, '.' end if return ! read error 999 continue write(outstr,'(a)') 'ERROR: io error in map file.' end subroutine maphead ! ! Compare Sib-pair map and locus list to map ! subroutine comparemap(port, chrcode, plevel) use interrupt use automatic_data use alleles_class use nucleotides use locus_data use outstream use fileio use scanner use locus_types use locus_data use locus_list use recast_data use vcftools implicit none type (ioport) :: port integer, intent(in) :: chrcode ! toggles meaning of chr 23-26 integer, intent(in) :: plevel ! local variables integer, parameter :: MISS=-9999, TWRK=7 ! used when reading Sib-pair file integer (kind=8) , parameter :: loc_namtyp_siz = 72 type (locus_container) :: ldata type (hash_table) :: maphash integer :: bppos, chrpos, i, idx, ioerr, filtyp, lpos, ltyp, mapped, mappos, & maxarg, nampos, narg, nlines, nmark, searchpos, mapunits, units integer :: nmatched, ndiffname, ndiffpos, ndups, nsamename, nsamepos, other_nloci integer :: bsize, ib, j, k, l logical :: gzipped character (len=512) :: lin character (len=40), dimension(5) :: words character (len=2) :: ch2 character (len=chromosome_width) :: chrom character (len=3) :: all1, all2, vcf1, vcf2 character (len=4) :: byte character (len=8) :: word64 character(len=loc_width) :: lword ! read buffering character (len=2000) :: gp_buff character (len=4000) :: ltyp_buff character (len=8000) :: map_buff character (len=1000*loc_width) :: loc_buff character (len=13) :: pos_str character (len=13), dimension(nloci) :: map_str ! used when reading Sib-pair file integer (kind=8) :: offset, offset_ltyp, offset_group, offset_map double precision :: xval ! functions integer :: tobp interface subroutine maphead(port, units, filehinted, lin, words, & filtyp, nampos, chrpos, bppos, mappos, mapunits, plevel) use locus_data use outstream use fileio use scanner use locus_list implicit none type(ioport) :: port integer, intent(in) :: units integer, intent(in) :: filehinted character (len=*), intent(inout) :: lin character (len=40), dimension(:), intent(inout) :: words integer, intent(out) :: bppos, chrpos, filtyp, mappos, mapunits, nampos integer, intent(in) :: plevel end subroutine maphead end interface units=1 call maphead(port, units, 0, lin, words, & filtyp, nampos, chrpos, bppos, mappos, mapunits, plevel) if (filtyp /= 6 .and. (chrpos == 0 .or. bppos == 0)) then write(outstr,'(a)') & 'Supports files that specify chromosome and base pair position.' return end if if (filtyp == 3 .or. filtyp == 4) then call metavcf_vars(port, lin, ' ', ioerr, plevel) end if if (plevel > 0) then write(outstr,'(/a20,4(a1,a))') 'Status', tabsep, 'Locus', tabsep, & 'Position', tabsep, 'ExternalName', tabsep, 'ExternalPosition' end if nlines=0 nmatched=0 ndiffname=0 ndiffpos=0 ndups=0 nsamename=0 nsamepos=0 mapped=0 nmark=0 other_nloci=0 do i=1, nloci if (ismarker(loctyp(i)) .or. map(i) /= MISS) then nmark=nmark+1 locstat(i)=0.0d0 end if end do call make_maphash(nloci, loctyp, group, map, map_str, maphash) if (filtyp == 6) then call rdspbinloci(port, ldata, ioerr, plevel) if (ioerr /= 0) goto 999 do i=ENVNUM+1, ldata%nloci if (irupt > 0) exit if (ismarker(ldata%loctyp(i)) .or. ldata%map(i) /= MISS) then nlines=nlines+1 write(pos_str,'(i10)') tobp(ldata%map(i)) pos_str= trim(ldata%group(i)) // ':' // adjustl(pos_str) call record_map_matches(ldata%loc(i), pos_str, map_str, maphash, & mapped, nmatched, nsamename, nsamepos, & ndups, ndiffname, ndiffpos, plevel) end if end do call cleanup_locus_container(ldata) else do while (irupt == 0) call readline(port, lin, ios=ioerr) if (ioerr /= 0) exit nlines=nlines+1 narg=5 call args(lin, narg, words, ' ', SEP_WHITE) call chr_convert(chrcode, words(chrpos), chrom) pos_str=trim(chrom) // ':' // adjustl(words(bppos)) call record_map_matches(words(nampos), pos_str, map_str, maphash, & mapped, nmatched, nsamename, nsamepos, & ndups, ndiffname, ndiffpos, plevel) if (nmatched == nmark) exit end do end if write(outstr,'(/a,i0/a,i0/a,i0,a,2(f5.3,a))') & 'Number of markers Sib-pair map = ', nmark, & 'Number of markers external map = ', nlines, & 'Total number intersecting = ', nmatched, & ' (', dble(nmatched)/dble(nmark),', ', & dble(nmatched)/dble(nlines),')' write(outstr,'(2(a,i0,a,i0,a/),a,i0/a,i0)') & 'Intersecting on marker name = ', nsamename, ' (discordant position=', ndiffpos,')', & 'Intersecting on map position = ', nsamepos, ' (discordant name=', ndiffname,')', & 'Number where multiple matches = ', ndups, & 'Number unique to Sib-pair map = ', nmark-nmatched return 999 continue write(outstr,'(a)') 'ERROR: Problem reading Sib-pair binary dataset!' return end subroutine comparemap ! ! Records map concordances and discordances for current locus ! subroutine record_map_matches(locnam, pos_str, map_str, maphash, & mapped, nmatched, nsamename, nsamepos, & ndups, ndiffname, ndiffpos, plevel) use interrupt use alleles_class use nucleotides use locus_data use outstream use fileio use scanner use locus_types use locus_list use vcftools implicit none character (len=loc_width), intent(in) :: locnam character (len=13), intent(in) :: pos_str character (len=13), dimension(nloci) :: map_str type (hash_table), intent(in) :: maphash ! the counters integer, intent(inout) :: mapped, nmatched, ndiffname, ndiffpos, ndups, & nsamename, nsamepos integer, intent(in) :: plevel ! local variables integer, parameter :: MISS=-9999, TWRK=7 integer :: idx call find_hashtab(trim(pos_str), map_str, maphash, idx) if (idx > 0) then if (locstat(idx) > 0.0d0) then ndups=ndups+1 locstat(idx)=4.0d0 write(outstr,'(a20,4(a1,a))') & 'Duplicate match', tabsep, trim(loc(idx)), tabsep, trim(map_str(idx)), & tabsep, trim(locnam), tabsep, trim(pos_str) else locstat(idx)=locstat(idx)+2.0d0 nmatched=nmatched+1 nsamepos=nsamepos+1 mapped=mapped+1 if (loc(idx) /= locnam) then ndiffname=ndiffname+1 if (plevel > 0) then write(outstr,'(a20,4(a1,a))') & 'Discordant_name', tabsep, trim(loc(idx)), tabsep, trim(map_str(idx)), & tabsep, trim(locnam), tabsep, trim(pos_str) end if else nsamename=nsamename+1 locstat(idx)=locstat(idx)+1.0d0 if (plevel > 1) then write(outstr,'(a20,4(a1,a))') & 'Complete_match', tabsep, trim(loc(idx)), tabsep, trim(map_str(idx)), & tabsep, trim(locnam), tabsep, trim(pos_str) end if end if end if else call find_hashtab(trim(locnam), loc, lochash, idx) if (idx > 0) then if (locstat(idx) > 0.0d0) then ndups=ndups+1 locstat(idx)=4.0d0 write(outstr,'(a20,4(a1,a))') & 'Duplicate_match', tabsep, trim(loc(idx)), tabsep, trim(map_str(idx)), & tabsep, trim(locnam), tabsep, trim(pos_str) else nmatched=nmatched+1 nsamename=nsamename+1 locstat(idx)=locstat(idx)+1.0d0 if (trim(map_str(idx)) /= trim(pos_str)) then ndiffpos=ndiffpos+1 if (plevel > 0) then write(outstr,'(a20,4(a1,a))') & 'Discordant_position', tabsep, trim(loc(idx)), tabsep, trim(map_str(idx)), & tabsep, trim(locnam), tabsep, trim(pos_str) end if else nsamepos=nsamepos+1 end if end if else if (plevel > 1) then write(outstr,'(a20,4(a1,a))') & 'Unmatched_marker', tabsep, 'NA', tabsep, 'NA', & tabsep, trim(locnam), tabsep, trim(pos_str) end if end if end subroutine record_map_matches ! ! rename loci based on matching position on a map ! subroutine renamer(filnam, pos_chrom, pos_bp, pos_id, plevel) use interrupt use alleles_class use genetic_maps use nucleotides use locus_data use outstream use fileio use scanner use locstring_widths use locus_list use locus_types use vcftools use tabixtools implicit none character (len=*) :: filnam integer, intent(in) :: pos_chrom, pos_bp, pos_id integer, intent(in) :: plevel ! local variables integer, parameter :: MISS=-9999, TWRK=7 integer (kind=8) , parameter :: loc_namtyp_siz = 72 type(ioport) :: port type (hash_table) :: maphash integer :: bppos, chrpos, i, idx, ioerr, filtyp, gene, lpos, mapped, mappos, & header_mapunits, maxarg, nampos, narg, nlines, nmark, nrenamed, & other_nloci, searchpos, typ, units logical :: gzipped character (len=512) :: lin character (len=40), dimension(10) :: words character(len=loc_width) :: lword character (len=1) :: sep character (len=2) :: ch2 character (len=4) :: byte character (len=3) :: all1, all2, vcf1, vcf2 character(len=8) :: word64 character (len=13) :: pos_str character (len=13), dimension(nloci) :: map_str logical :: hasname, has_tbi integer (kind=8) :: offset, offset_group, offset_map double precision :: xval ! active markers - if indexed VCF integer :: mpos, nmark_data, nact_data integer, dimension(nloci) :: mark ! functions integer :: tobp interface subroutine maphead(port, units, filehinted, lin, words, & filtyp, nampos, chrpos, bppos, mappos, mapunits, plevel) use locus_data use outstream use fileio use scanner use locus_list implicit none type(ioport) :: port integer, intent(in) :: units integer, intent(in) :: filehinted character (len=*), intent(inout) :: lin character (len=40), dimension(:), intent(inout) :: words integer, intent(out) :: bppos, chrpos, filtyp, mappos, mapunits, nampos integer, intent(in) :: plevel end subroutine maphead end interface call open_port(filnam, port, 'r', ioerr) if (ioerr /= 0) then write(outstr,'(3a)') & 'ERROR: Could not open map file "', trim(filnam),'".' return end if has_tbi=.false. sep=' ' if (pos_chrom > 0 .and. pos_bp > 0 .and. pos_id > 0) then typ=1 filtyp=1 nampos=pos_id chrpos=pos_chrom bppos=pos_bp if (plevel > 0) then write(outstr,'(a,3(1x,i0),a)') & 'NOTE: Specified locus name, chrom, bp at columns', nampos, chrpos, bppos, '.' end if else units=1 call maphead(port, units, 0, lin, words, & filtyp, nampos, chrpos, bppos, mappos, header_mapunits, plevel) end if if (filtyp /= 6 .and. (chrpos == 0 .or. bppos == 0)) then write(outstr,'(a)') & 'Supports files that specify chromosome and base pair position.' return end if call setup_stat('Loci renamed using external map: 0=same_name 1=renamed 2=multiple matches', typ=2) nmark_data=0 nact_data=0 do i=1, nloci if (ismarker(loctyp(i))) then nmark_data=nmark_data+1 if (isactive(loctyp(i))) then nact_data=nact_data+1 mark(nact_data)=i end if end if end do if (plevel > 0) then write(outstr,'(a,i0,a)') 'There are ', nact_data, ' active markers.' end if if (filtyp == 3 .or. filtyp == 4) then sep=achar(9) typ=5 call metavcf_vars(port, lin, ' ', ioerr, plevel) call load_tbi(port%filnam, tbi_index, has_tbi) end if nlines=0 nrenamed=0 mapped=0 mpos=0 call cntmark(nloci, loctyp, nmark, 1) call make_maphash(nloci, loctyp, group, map, map_str, maphash) ! read a Sib-pair binary dataset if (filtyp == 6) then offset=21 call seek_port(port, offset, ioerr) call readline(port, byte, advance='no', ignore_eol='yes', ios=ioerr) if (ioerr /= 0) goto 999 other_nloci=transfer(byte, idx) if (plevel > 0) then write(outstr,'(a,i0,a)') 'External dataset nloci= ', other_nloci end if offset=25 offset_group=offset+int(other_nloci, kind=8)*loc_namtyp_siz offset_map=offset_group+2*int(other_nloci, kind=8) do i=1, other_nloci call seek_port(port, offset_group, ioerr) if (ioerr /= 0) goto 999 call readline(port, ch2, advance='no', ios=ioerr) if (ioerr /= 0) goto 999 call seek_port(port, offset_map, ioerr) if (ioerr /= 0) goto 999 call readline(port, word64, advance='no', ignore_eol='yes', ios=ioerr) write(lword,'(i10)') tobp(transfer(word64, xval)) if (ioerr /= 0) goto 999 pos_str=trim(ch2) // ':' // adjustl(lword) call find_hashtab(trim(pos_str), map_str, maphash, idx) if (idx > 0) then mapped=mapped+1 if (isactive(loctyp(idx))) then call seek_port(port, offset, ioerr) if (ioerr /= 0) goto 999 call readline(port, lword, advance='no', ios=ioerr) if (ioerr /= 0) goto 999 if (loc(idx) /= lword) then nrenamed=nrenamed+1 if (plevel > 1) then write(outstr,'(6a)') & 'Renaming ', trim(loc(idx)), ' to ', trim(lword), & ' at position ', trim(pos_str) end if locnotes(idx)=trim(locnotes(idx)) // ' (ORIG ' // trim(loc(idx)) // ')' if (locstat(idx) == MISS) locstat(idx)=1.0d0 loc(idx)=lword else if (locstat(idx) == MISS) locstat(idx)=0.0d0 end if end if if (mapped == nmark) exit end if offset_group=offset_group+2 offset_map=offset_map+8 offset=offset+loc_width end do ! else read a recognized map file - utilising index if available else do if (irupt > 0) exit if (nact_data == mapped) exit if (nmark_data == mpos) exit if (has_tbi) then mpos=mpos+1 gene=mark(mpos) call moveto_tbi(tbi_index, group(gene), tobp(map(gene)), port, lin, ioerr) if (plevel > 1) then write(outstr,'(3a,i0)') 'Seeking ', loc(gene), ' stat=', ioerr end if if ((ioerr == -1 .or. ioerr == 1) .and. mpos < nact_data) cycle else call readline(port, lin, ios=ioerr) end if if (ioerr /= 0) exit nlines=nlines+1 narg=10 call args(lin, narg, words, sep, typ) if (words(chrpos)(1:3) == 'chr') then words(chrpos)=words(chrpos)(4:len(words(chrpos))) ! Kluge for dbSNP files, where chromosome fields are NC_0000nn.nn else if (words(pos_chrom)(1:3) == 'NC_') then call ncbiseq_to_chr(words(pos_chrom)) end if pos_str=trim(words(chrpos)) // ':' // adjustl(words(bppos)) call find_hashtab(trim(pos_str), map_str, maphash, idx) if (idx > 0) then mapped=mapped+1 if (isactive(loctyp(idx))) then if (loc(idx) /= words(nampos) .and. words(nampos) /= '.') then nrenamed=nrenamed+1 if (plevel > 1) then write(outstr,'(6a)') & 'Renaming ', trim(loc(idx)), ' to ', trim(words(nampos)), & ' at position ', trim(pos_str) end if locnotes(idx)=trim(locnotes(idx)) // ' (ORIG ' // trim(loc(idx)) // ')' if (locstat(idx) == MISS) then locstat(idx)=1.0d0 else if (locstat(idx) > 0.0d0) then locstat(idx)=locstat(idx)+1.0d0 end if loc(idx)=words(nampos) else if (locstat(idx) == MISS) locstat(idx)=0.0d0 end if end if if (mapped == nmark) exit end if end do end if write(outstr,'(a,2(i0,a))') & 'Renamed ', nrenamed, ' of ', mapped, ' mappable loci.' call close_port(port, ioerr) return ! read errors 999 continue write(outstr,'(a)') 'ERROR: error while reading map!' write(outstr,'(a,2(i0,a))') & 'Renamed ', nrenamed, ' of ', mapped, ' mappable loci.' call close_port(port, ioerr) return end subroutine renamer ! ! test strand flips based on matching to a reference set ! reads a VCF or GTF file ! subroutine testflips_map(port, plevel) use interrupt use alleles_class use nucleotides use locus_types use locus_data use outstream use fileio use scanner use locus_list use gtftools use genetic_maps implicit none type(ioport) :: port integer, intent(in) :: plevel ! local variables integer, parameter :: MISS=-9999, TWRK=7 type (allele_data) :: allele_buffer integer :: astat, bppos, chrpos, i, idx, ioerr, filtyp, longall, mapped, & mappos, maxarg, nampos, narg, ndups, nmark, nrenamed, & ext_mapunits, mappedbyname, incon, searchtype, altpos, refpos logical :: dup, gzipped character (len=512) :: lin character (len=40), dimension(6) :: words character (len=40) :: misplaced character (len=10) :: annotation character (len=1) :: all1, all2, altall, altall2, refall character (len=7) :: mapfmt ! match by map position type (hash_table) :: maphash character (len=13), dimension(nloci) :: map_str character (len=13) :: pos_str ! functions character (len=6) :: pstring interface subroutine maphead(port, units, filehinted, lin, words, & filtyp, nampos, chrpos, bppos, mappos, mapunits, plevel) use locus_data use outstream use fileio use scanner use locus_list implicit none type(ioport) :: port integer, intent(in) :: units integer, intent(in) :: filehinted character (len=*), intent(inout) :: lin character (len=40), dimension(:), intent(inout) :: words integer, intent(out) :: bppos, chrpos, filtyp, mappos, mapunits, nampos integer, intent(in) :: plevel end subroutine maphead end interface call maphead(port, 1, 0, lin, words, & filtyp, nampos, chrpos, bppos, mappos, ext_mapunits, plevel) if (filtyp /= 3 .and. filtyp /= 4 .and. filtyp /= 5) then write(outstr,'(a)') 'Currently only supports .bim, GTF and VCF files.' return end if if (.not.lochash%current) then call make_lochash(nloci, loc, lochash) end if call cntmark(nloci, loctyp, nmark, 3) if (plevel > 0) then write(outstr,'(/a,i0/a/a)') & 'Number of active markers = ', nmark, & 'Locus Alleles Reference Diagnosis Map Position Notes', & '-------------- --------- --------- ------------ ------------- -------' end if call setup_stat('Allele consistency with reference: 0=OK 1=swap 2=flip 3=incon', typ=2) incon=0 mapfmt=mapformat(mapunits, '12') mapped=0 mappedbyname=0 misplaced='' ndups=0 refpos=4 altpos=5 ! GTF/GFF if (filtyp == 3) then refpos=2 altpos=3 else if (filtyp == 5) then refpos=5 altpos=6 end if call make_maphash(nloci, loctyp, group, map, map_str, maphash) do call readline(port, lin, ios=ioerr) if (ioerr /= 0) exit if (irupt > 0) exit narg=5 searchtype=1 call args(lin, narg, words, char(9), SEP_CHAR) if (words(chrpos)(1:3) == 'chr') words(chrpos)=words(chrpos)(4:len_trim(words(chrpos))) pos_str=trim(words(chrpos)) // ':' // adjustl(words(bppos)) call find_hashtab(trim(pos_str), map_str, maphash, idx) if (filtyp == 3) then call get_varinfo(lin, words(nampos), words(refpos), words(altpos)) end if if (idx == 0) then searchtype=2 call find_hashtab(trim(words(nampos)(1:loc_width)), loc, lochash, idx) end if if (idx > 0) then if (index('ACGT', trim(adjustl(words(refpos)))) > 0 .and. & len_trim(adjustl(words(refpos))) == 1 .and. & isactive(loctyp(idx))) then dup=(locstat(idx) /= MISS) if (.not.dup) mapped=mapped+1 if (searchtype == 2) then mappedbyname=mappedbyname+1 misplaced=trim(loc(idx)) // ' ' // misplaced end if longall=48 refall=trim(adjustl(words(refpos))) call extract_alt_alleles(trim(adjustl(words(altpos))), altall, altall2) call get_refalleles(locnotes(idx), all1, all2) if ((all1 == altall .or. all1 == altall2) .and. all2 == refall) then if (locstat(idx) == MISS) then incon=incon+1 locstat(idx)=1.0d0 end if if (dup) ndups=ndups+1 if (plevel > 0) then annotation='Swap' if (dup) annotation=trim(annotation) // ' DUP' write(outstr,'(a14,3x,3a,7x,3a,7x,a,3x,a)', advance='no') & trim(loc(idx)), all1, '/', all2, refall, '/', altall, annotation, group(idx) write(outstr, mapfmt, advance='no') map(idx)/mapconstant write(outstr,'(1x,a)') locnotes(idx) end if else if (all1 /= refall .or. (all2 /= altall .and. all2 /= altall2)) then if (complement(refall) == all1 .and. complement(altall) == all2 .and. & complement(refall) /= altall) then if (locstat(idx) == MISS) then incon=incon+1 locstat(idx)=2.0d0 end if if (dup) ndups=ndups+1 if (plevel > 0) then annotation='Flip' if (dup) annotation=trim(annotation) // ' DUP' write(outstr,'(a14,3x,3a,7x,3a,7x,a,3x,a)', advance='no') & trim(loc(idx)), all1, '/', all2, refall, '/', altall, annotation, group(idx) write(outstr, mapfmt, advance='no') map(idx)/mapconstant write(outstr,'(1x,a)') locnotes(idx) end if else if (locstat(idx) == MISS) then incon=incon+1 locstat(idx)=3.0d0 end if if (dup) ndups=ndups+1 if (plevel > 0) then annotation='Incon' if (dup) annotation=trim(annotation) // ' DUP' write(outstr,'(a14,3x,3a,7x,3a,7x,a,3x,a)', advance='no') & trim(loc(idx)), all1, '/', all2, refall, '/', altall, annotation, group(idx) write(outstr, mapfmt, advance='no') map(idx)/mapconstant write(outstr,'(1x,a)') locnotes(idx) end if end if else if (plevel > 1) then annotation='Con' write(outstr,'(a14,3x,3a,7x,3a,7x,a,3x,a)', advance='no') & trim(loc(idx)), all1, '/', all2, refall, '/', altall, annotation, group(idx) write(outstr, mapfmt, advance='no') map(idx)/mapconstant write(outstr,'(1x,a)') locnotes(idx) end if if (locstat(idx) > 0.0d0) incon=incon-1 locstat(idx)=0.0d0 end if if (mapped == nmark) exit end if end if end do write(outstr,'(/a,i0,a,i0,a)') & 'Matched ', mapped, ' out of ', nmark, ' loci to reference allele data.' if (mappedbyname > 0) then write(outstr,'(a,i0,3a)') & 'Matched ', mappedbyname, ' by locus name and not position (', & trim(misplaced), ').' end if write(outstr,'(a,i0,3a)') & 'Allele discordance between Sib-pair annotation and external reference map at ', incon, & ' positions (', trim(pstring(dble(incon)/dble(max(1,mapped)))), ').' if (ndups > 0) then write(outstr,'(a,i0,a)') & 'Excludes discordances at each of ', ndups, & ' duplicates on reference map.' end if end subroutine testflips_map ! ! Compare reference alleles in annotation to the consensus allele ! from FASTA sequence file ! Scans annotations rather than map file since latter is indexed and bigger. ! Swaps around the references alleles in the annotation to match the consensus ! Does not touch actual genotypes ! subroutine testflips_fasta(typ, fil, plevel) use interrupt use nucleotides use locus_types use locus_data use locus_list use fastatools integer, intent(in) :: typ character(len=*), intent(in) :: fil integer, intent(in) :: plevel type (fasta_data) :: fasta_container integer :: astat, i, idx, nmark, nmonoswap integer(kind=8) :: bp character (len=1) :: refall, altall, seqall integer, parameter :: NDIAGS = 5 character (len=9), dimension(NDIAGS), parameter :: diag = & (/ '0=OK ', '1=flipped', '2=swapped', & '3=fli+swa', '4=no_seq ' /) integer, dimension(NDIAGS) :: diagfreq ! functions integer(kind=8) :: tobp8 call open_fasta(fil, fasta_container, astat) if (astat /= 0) return diagfreq=0 nmonoswap=0 call cntmark(nloci, loctyp, nmark, 3) call setup_stat('Annotation v FASTA file: 0=OK 1=flip 2=swap 3=fl+sw 4=NA', typ=2) write(outstr,'(/2a/a,i0)') & 'FASTA file = ', trim(fasta_container%filnam), & 'Number of sequences = ', fasta_container%number_sequences if (plevel > 0) then write(outstr,'(/a,i0/a/a)') & 'Number of active markers = ', nmark, & 'Locus Alleles Reference Diagnosis', & '-------------- --------- --------- ----------' end if do i=1, nloci if (ismarker(loctyp(i)) .and. isactive(loctyp(i)) .and. irupt == 0) then bp=tobp8(map(i)) call get_refalleles(locnotes(i), refall, altall) call get_fastaref(trim(adjustl(group(i))), bp, fasta_container, seqall) if (seqall == 'N' .or. seqall == '.') then idx=5 else if ((refall == 'I' .and. altall == 'D') .or. & (refall == 'D' .and. altall == 'I')) then idx=5 else if (seqall == refall) then idx=1 else if (seqall == altall) then idx=3 if (refall == '.' .or. refall == '0' .or. refall == ' ') then nmonoswap=nmonoswap+1 end if else if (refall == 'T' .and. seqall == 'A') then idx=2 else if (refall == 'A' .and. seqall == 'T') then idx=2 else if (refall == 'C' .and. seqall == 'G') then idx=2 else if (refall == 'G' .and. seqall == 'C') then idx=2 else idx=4 end if locstat(i)=idx-1 diagfreq(idx)=diagfreq(idx)+1 if (plevel > 0 .and. idx /= 1) then write(outstr,'(a,1x,3a,5x,a,6x,a,1x,a,1x,i0)') & loc(i), refall, '/', altall, seqall, diag(idx), group(i), bp else if (plevel > 1) then write(outstr,'(a,1x,3a,5x,a,6x,a,1x,a,1x,i0)') & loc(i), refall, '/', altall, seqall, diag(idx), group(i), bp end if end if end do if (plevel > -1) then if (nmonoswap > 0) then diagfreq(1)=diagfreq(1)+nmonoswap diagfreq(3)=diagfreq(3)-nmonoswap end if write(outstr,'(/a/a)') & 'Annotation reference allele v. FASTA reference sequence:', & 'Status Count Proportion' do i=1, NDIAGS write(outstr,'(a,i11,4x,f6.4)') & diag(i), diagfreq(i), dble(diagfreq(i))/dble(nmark) end do if (nmonoswap > 0) then write(outstr,'(/a,i0,a/7x,a/7x,a)') & 'NOTE: Annotation reference allele was missing ("0",".") for ', & nmonoswap, ' markers', & 'where the alternate allele matched the FASTA reference.', & 'These are included in the "OK" total, but flagged as swapped.' end if end if call close_fasta(fasta_container) ! actually swap or flip reference alleles if (typ == 2) then do i=1, nloci if (locstat(i) > 0 .and. locstat(i) < 4) then call get_refalleles(locnotes(i), refall, altall) if (locstat(i) == 1 .or. locstat(i) == 3) then refall=complement(refall) altall=complement(altall) end if if (locstat(i) > 1) then call set_refalleles(altall, refall, locnotes(i)) else call set_refalleles(refall, altall, locnotes(i)) end if end if end do end if end subroutine testflips_fasta ! ! Test for allele swaps or flips for genotypes coming from different sources ! typ=1 report, typ=2 carry out swap in appropriate stratum ! subroutine testflips_source(typ, lodthresh, loc, trait, loctyp, locnote, gene, & locnam, allele_buffer, dataset, & assoc_stat, statval, plevel) use interrupt use outstream use alleles_class use ped_class use contingency_table use categorical_data implicit none integer, intent(in) :: typ double precision, intent(in) :: lodthresh character (len=*), intent(in) :: loc integer, intent(in) :: trait integer, intent(in) :: loctyp character (len=*), intent(in) :: locnote integer, intent(in) :: gene character (len=*), intent(in) :: locnam type (allele_data), intent(in) :: allele_buffer type (ped_data) :: dataset double precision, dimension(3), intent(out) :: statval integer, intent(in) :: plevel integer, parameter :: MISS=-9999 double precision, parameter :: lodconst = 0.43429448190325182765d0 ! Marginal trait tabulation type (table_data) :: traittable double precision, dimension(1) :: val ! Genotype tables integer, dimension(:,:), allocatable :: cntall integer, dimension(:), allocatable :: nca double precision, dimension(:), allocatable :: lr integer :: a1, a2, bestswap, df, g1, g2, gen2, geno, i, iaff, & j, k, ncats, nchanges, nswaps, sgn, traitlevels integer :: ped, pedoffset character (len=3) :: gtp character (len=9) :: clev double precision :: obschi, bestchi, lod ! functions integer :: clcpos interface function assoc_stat(sta, fin, nlev, nca, cntall) double precision assoc_stat integer, intent(in) :: sta, fin, nlev integer, dimension(:), intent(in) :: nca integer, dimension(:,:), intent(in) :: cntall end function assoc_stat end interface statval=MISS if (allele_buffer%numal /= 2) return bestswap=0 bestchi=0.0d0 call setup_table(1, 30, traittable) dataset%untyped=.true. do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) if (dataset%plocus(i,trait) /= MISS .and. observed(i, gene, dataset)) then val(1)=dataset%plocus(i,trait) call insert_table(1, val, traittable, 1) dataset%untyped(i)=.false. end if end do end if end do ncats=allele_buffer%numgtp traitlevels=traittable%ncells if (traitlevels < 2 .or. ncats < 2) then if (plevel > 0) then write(outstr, '(6a)') locnam, tabsep, 'No_Info', tabsep, '-', tabsep end if return end if gen2=gene+1 allocate(cntall(ncats, traitlevels+1)) allocate(nca(traitlevels)) allocate(lr(traitlevels)) nca=0 cntall=0 df=0 do i=1, dataset%nobs if (.not.dataset%untyped(i)) then call get_namedgeno(i, gene, gen2, dataset, allele_buffer, g1, g2) geno=clcpos(g1,g2) iaff=findlev(dataset%plocus(i,trait), traittable) cntall(geno,iaff)=cntall(geno,iaff)+1 end if end do do j=1, ncats do k=1, traitlevels nca(k)=nca(k)+cntall(j,k) cntall(j,traitlevels+1)=cntall(j,traitlevels+1)+cntall(j,k) end do if (cntall(j,traitlevels+1) > 0) df=df+1 end do obschi=assoc_stat(1, ncats, traitlevels, nca, cntall) bestchi=obschi nswaps=traitlevels lr=0.0d0 if (traitlevels == 2) nswaps=1 ! Swap counts but also row totals do k=1, nswaps call swap(cntall(1,k), cntall(3,k)) cntall(1,traitlevels+1)=cntall(1,traitlevels+1)-cntall(3,k)+cntall(1,k) cntall(3,traitlevels+1)=cntall(3,traitlevels+1)-cntall(1,k)+cntall(3,k) lr(k)=assoc_stat(1, ncats, traitlevels, nca, cntall) call swap(cntall(1,k), cntall(3,k)) cntall(1,traitlevels+1)=cntall(1,traitlevels+1)-cntall(3,k)+cntall(1,k) cntall(3,traitlevels+1)=cntall(3,traitlevels+1)-cntall(1,k)+cntall(3,k) if (lr(k) < bestchi) then bestchi=lr(k) bestswap=k end if end do statval(1)=lodconst*(obschi-bestchi) statval(2)=bestswap statval(3)=bestchi if (bestswap == 0) then statval(1)=lodconst*(obschi-lr(nswaps)) end if if (plevel > -1) then if (bestswap == 0 .or. statval(1) < lodthresh) then if (plevel > 0) then call wrtrait(traittable%categories(traittable%idx(nswaps),1)%rvalue, clev, & loctyp, get_notes(loc, locnote), 9, 4) a1=allele_buffer%allele_names(1) a2=allele_buffer%allele_names(2) call wrgtp(a1, a2, gtp, '/', ' ', 1) write(outstr, '(8a,g12.6,a1,g12.6,a1,f8.1)') & locnam, tabsep, gtp, tabsep, 'No_Swap', tabsep, clev, tabsep, & lr(nswaps), tabsep, obschi, tabsep, statval(1) end if else if (typ == 1) then call wrtrait(traittable%categories(traittable%idx(bestswap),1)%rvalue, clev, & loctyp, get_notes(loc, locnote), 9, 4) a1=allele_buffer%allele_names(1) a2=allele_buffer%allele_names(2) call wrgtp(a1, a2, gtp, '/', ' ', 1) write(outstr, '(8a,g12.6,a1,g12.6,a1,f8.1)') & locnam, tabsep, gtp, tabsep, 'Swap ', tabsep, clev, tabsep, & bestchi, tabsep, obschi, tabsep, statval(1) end if end if ! if (bestswap > 0 .and. typ == 2) then nchanges=0 if (statval(1) > lodthresh) then a1=allele_buffer%allele_names(1) a2=allele_buffer%allele_names(2) do i=1, dataset%nobs if (.not.dataset%untyped(i)) then iaff=findlev(dataset%plocus(i,trait), traittable) if (iaff == bestswap) then if (.not.missing(i, gene, dataset)) then call get_geno(i, gene, gen2, dataset, g1, g2) if (g1 == g2) then nchanges=nchanges+1 sgn=sign(1, g1) if (abs(g1) == a1) then g1=sgn*a2 g2=sgn*a2 else g1=sgn*a1 g2=sgn*a1 end if call set_geno(i, gene, gen2, dataset, g1, g2) end if end if end if end if end do if (plevel > -1) then call wrtrait(traittable%categories(traittable%idx(bestswap),1)%rvalue, clev, & loctyp, get_notes(loc, locnote), 9, 4) call wrgtp(a1, a2, gtp, '/', ' ', 1) write(outstr, '(8a,g12.6,a1,g12.6,a1,f8.1,1x,i0)') & locnam, tabsep, gtp, tabsep, 'Swapped', tabsep, clev, tabsep, & bestchi, tabsep, obschi, tabsep, statval(1), nchanges end if else if (plevel > 0) then call wrtrait(traittable%categories(traittable%idx(bestswap),1)%rvalue, clev, & loctyp, get_notes(loc, locnote), 9, 4) write(outstr, '(8a,g12.6,a1,g12.6,a1,f8.1)') & locnam, tabsep, gtp, tabsep, 'No_Swap', tabsep, clev, tabsep, & bestchi, tabsep, obschi, tabsep, statval(1), 0 end if end if end subroutine testflips_source ! ! flip strand based on matching to a reference set ! typ=1 looks in annotations for "[A/B]" A=Ref B=Alt ! typ=2 reads a VCF or GTF file ! subroutine flipper(typ, port, dataset, plevel) use interrupt use alleles_class use nucleotides use locus_types use locus_data use pedigree_data use outstream use fileio use scanner use locus_list use gtftools implicit none integer, intent(in) :: typ type(ioport) :: port type (ped_data) :: dataset integer, intent(in) :: plevel ! local variables integer, parameter :: MISS=-9999, TWRK=7 type (allele_data) :: allele_buffer, ref_allele_buffer integer :: astat, bppos, chrpos, i, idx, ioerr, filtyp, mapped, mappos, & maxarg, nampos, narg, ndups, nmark, nrenamed, & mapunits, mappedbyname, searchtype, altpos, refpos double precision :: altfreq logical :: dup, gzipped character (len=512) :: lin character (len=40), dimension(6) :: words character (len=40) :: misplaced character (len=10) :: annotation character (len=1) :: all1, all2 ! match by map position type (hash_table) :: maphash character (len=13), dimension(nloci) :: map_str character (len=13) :: pos_str ! functions double precision :: fval interface subroutine maphead(port, units, filehinted, lin, words, & filtyp, nampos, chrpos, bppos, mappos, mapunits, plevel) use locus_data use outstream use fileio use scanner use locus_list implicit none type(ioport) :: port integer, intent(in) :: units integer, intent(in) :: filehinted character (len=*), intent(inout) :: lin character (len=40), dimension(:), intent(inout) :: words integer, intent(out) :: bppos, chrpos, filtyp, mappos, mapunits, nampos integer, intent(in) :: plevel end subroutine maphead end interface if (typ == 2) then call maphead(port, 1, 0, lin, words, & filtyp, nampos, chrpos, bppos, mappos, mapunits, plevel) if (filtyp /= 3 .and. filtyp /= 4 .and. filtyp /= 5) then write(outstr,'(a)') 'Currently only supports .bim, GTF and VCF files.' return end if end if if (.not.lochash%current) then call make_lochash(nloci, loc, lochash) end if call cntmark(nloci, loctyp, nmark, 3) if (plevel > 0) then if (typ == 1) then write(outstr,'(/a)') 'Using reference alleles from annotation.' else write(outstr,'(/a)') 'Using reference alleles from map file.' end if write(outstr,'(/a,i0/a/a)') & 'Number of active markers = ', nmark, & 'Locus Alleles Reference Action', & '-------------- --------- --------- ----------' end if call setup_stat('Allele consistency with reference: -1=bad 0=OK 1=flip 2=swap', typ=2) mapped=0 mappedbyname=0 misplaced='' ndups=0 refpos=4 altpos=5 altfreq=0.5d0 if (typ == 1) then do i=1, nloci if (isactive(loctyp(i)) .and. ismarker(loctyp(i))) then call get_refalleles(locnotes(i), all1, all2) call load_refallele(all1, all2, altfreq, ref_allele_buffer) if (all1 /= ' ') then mapped=mapped+1 call freq(locpos(i), loctyp(i), 0, dataset, allele_buffer) call refstrand(1, loc(i), locpos(i), dataset, allele_buffer, & ref_allele_buffer, astat, plevel) locstat(i)=astat end if if (irupt > 0) exit end if end do write(outstr,'(/a,i0,a,i0,a)') & 'Found ', mapped, ' out of ', nmark, ' loci with reference allele data.' else ! GTF/GFF if (filtyp == 3) then refpos=2 altpos=3 else if (filtyp == 5) then refpos=5 altpos=6 end if call make_maphash(nloci, loctyp, group, map, map_str, maphash) do call readline(port, lin, ios=ioerr) if (ioerr /= 0) exit if (irupt > 0) exit narg=5 searchtype=1 call args(lin, narg, words, char(9), SEP_CHAR) if (words(chrpos)(1:3) == 'chr') words(chrpos)=words(chrpos)(4:len_trim(words(chrpos))) pos_str=trim(words(chrpos)) // ':' // adjustl(words(bppos)) call find_hashtab(trim(pos_str), map_str, maphash, idx) if (filtyp == 3) then call get_varinfo(lin, words(nampos), words(refpos), words(altpos)) end if if (idx == 0) then searchtype=2 call find_hashtab(trim(words(nampos)(1:loc_width)), loc, lochash, idx) end if if (idx > 0) then if (index('ACGT', trim(adjustl(words(refpos)))) > 0 .and. & len_trim(adjustl(words(refpos))) == 1 .and. & isactive(loctyp(idx))) then dup=(locstat(idx) /= MISS) if (.not.dup) then mapped=mapped+1 else ndups=ndups+1 end if if (searchtype == 2) then mappedbyname=mappedbyname+1 misplaced=trim(loc(idx)) // ' ' // misplaced end if all1=trim(adjustl(words(refpos))) all2=trim(adjustl(words(altpos))) ! read a reference allele frequency if available if (filtyp == 4) then altfreq=0.5d0 call getpairval('AF', lin, opsimple, words(1)) if (plevel > 1) then write(outstr,'(4a)') 'Reference alt allele frequency = "', trim(words(1)), '"' end if if (words(1) /= ' ') then altfreq=fval(words(1)) end if end if call load_refallele(all1, all2, altfreq, ref_allele_buffer) call freq(locpos(idx), loctyp(idx), 0, dataset, allele_buffer) call refstrand(1, loc(idx), locpos(idx), dataset, allele_buffer, & ref_allele_buffer, astat, plevel) call set_refalleles(all1, all2, locnotes(idx)) ! overwrite a duplicate if it was inconsistent if (locstat(idx) < 0) then locstat(idx)=astat end if if (mapped == nmark) exit end if end if end do write(outstr,'(/a,i0,a,i0,a)') & 'Matched ', mapped, ' out of ', nmark, ' loci to reference allele data.' if (mappedbyname > 0) then write(outstr,'(a,i0,3a)') & 'Matched ', mappedbyname, ' by locus name and not position (', & trim(misplaced), ')' end if if (ndups > 0) then write(outstr,'(a,i0,a)') 'NOTE: ', ndups, ' duplicates on reference map.' end if end if end subroutine flipper ! ! Read a set of locus statistics for locstat - usually P-values ! subroutine readstats(port, namcol, statcol, lin, words, plevel) use locus_types use locus_data use outstream use fileio use scanner use locus_list implicit none type(ioport) :: port character (len=*), intent(inout) :: lin integer, intent(in) :: namcol, statcol character (len=40), dimension(:), intent(inout) :: words integer, intent(in) :: plevel ! local variables integer, parameter :: MISS=-9999, TWRK=7 integer :: idx, ioerr, mapped, nampos, narg, ndups, nlines, statpos double precision :: minstat, maxstat ! allow matching by map position type (hash_table) :: maphash character (len=13), dimension(nloci) :: map_str ! functions logical :: isreal double precision :: fval mapped=0 ndups=0 nlines=0 nampos=namcol minstat=1.0d99 maxstat=-1.0d99 call make_lochash(nloci, loc, lochash) call make_maphash(nloci, loctyp, group, map, map_str, maphash) call setup_stat('Read in statistics', typ=0) do call readline(port, lin, ios=ioerr) if (ioerr /= 0) exit nlines=nlines+1 if (plevel > 1) then write(outstr,'(i0,2a)') nlines, ': ', lin(1:72) end if narg=6 call args(lin, narg, words, ' ', SEP_WHITE) call find_hashtab(trim(words(nampos)(1:loc_width)), loc, lochash, idx) if (idx == 0) then if (words(nampos)(1:3) == 'chr') then words(nampos)=words(nampos)(4:len_trim(words(nampos))) end if call find_hashtab(trim(words(nampos)), map_str, maphash, idx) end if if (idx > 0) then statpos=statcol if (statpos == 0) statpos=narg if (isreal(words(statpos))) then if (locstat(idx) == MISS) then mapped=mapped+1 else ndups=ndups+1 end if locstat(idx)=fval(words(statpos)) maxstat=max(locstat(idx), maxstat) minstat=min(locstat(idx), minstat) end if end if end do write(outstr,'(/a,i0,a)') & 'Matched up ', mapped, ' loci with their statistics.' if (ndups > 0) then write(outstr,'(a,i0,a)') 'NOTE: ', ndups, ' duplicate statistics.' end if if (maxstat > 1.0d0 .or. minstat < 0.0d0) then locstat_typ=1 if (plevel > -1) then write(outstr,'(a)') 'NOTE: Do not look like P-values.' end if end if end subroutine readstats ! ! Read a mapfile -- attempts to intelligently decide ! what to read ! subroutine readmap(port, units, filehint, lin, words, plevel) use locus_types use locus_data use outstream use fileio use scanner use locus_list use vcftools use gtftools implicit none type(ioport) :: port integer, intent(in) :: units integer, intent(in) :: filehint character (len=*), intent(inout) :: lin character (len=40), dimension(:), intent(inout) :: words integer, intent(in) :: plevel ! local variables integer, parameter :: MISS=-9999, TWRK=7 integer :: bppos, chrpos, i, idx, ioerr, filtyp, lpos, mapped, mappos, & maxarg, nampos, narg, nlines, nmark, searchpos, mapunits ! reading bin file integer (kind=8) :: offset, offset_g character (len=256) :: locinfo character (len=3) :: altall, refall ! double precision :: dist, minpos, maxpos double precision :: mapconstant ! functions logical :: isreal double precision :: fval interface subroutine maphead(port, units, filehinted, lin, words, & filtyp, nampos, chrpos, bppos, mappos, mapunits, plevel) use locus_data use outstream use fileio use scanner use locus_list implicit none type(ioport) :: port integer, intent(in) :: units integer, intent(in) :: filehinted character (len=*), intent(inout) :: lin character (len=40), dimension(:), intent(inout) :: words integer, intent(out) :: bppos, chrpos, filtyp, mappos, mapunits, nampos integer, intent(in) :: plevel end subroutine maphead end interface ! map type not specified, so check first two records ! filtyp 1=name, position on one line ! 2=alternating lines for name, distance ! 3=gtf call setup_stat('Reading map positions', typ=1) nmark=0 do i=1, nloci if (ismarker(loctyp(i)) .and. isactive(loctyp(i))) then nmark=nmark+1 locstat(i)=0.0d0 end if end do minpos=1.0d99 maxpos=0.0d0 maxarg=size(words) mapconstant=1.0d-6 call maphead(port, units, filehint, lin, words, & filtyp, nampos, chrpos, bppos, mappos, mapunits, plevel) ! ! Read the mapfile ! mapped=0 ! name-position pair per line ! hash search for matching locus if (filtyp == 1) then do call readline(port, lin, ios=ioerr) if (ioerr /= 0) exit nlines=nlines+1 if (plevel > 1) then write(outstr,'(i0,2a)') nlines, ': ', lin(1:72) end if narg=3 call args(lin, narg, words, ' ', SEP_WHITE) call find_hashtab(trim(words(nampos)(1:loc_width)), loc, lochash, idx) if (idx > 0) then if (isreal(words(mappos))) then mapped=mapped+1 map(idx)=fval(words(mappos)) minpos=min(minpos, map(idx)) maxpos=max(maxpos, map(idx)) if (chrpos /= 0) then group(idx)=words(chrpos) locnotes(idx)=trim(locnotes(idx)) // ' (chr' // trim(words(chrpos)) // ')' end if if (bppos /= 0 .and. bppos /= mappos) then locnotes(idx)=trim(words(bppos)) // ' ' // trim(locnotes(idx)) end if locstat(idx)=1.0d0 if (mapped == nmark) exit end if end if end do ! name distance on alternate lines ! assumes map and data order same else if (filtyp == 2) then do dist=0.0d0 call readline(port, lin, ios=ioerr) if (ioerr /=0) exit if (plevel > 1) then write(outstr,'(a)') lin(1:72) end if narg=1 call args(lin, narg, words, ' ', SEP_WHITE) lpos=0 do i=1, nloci if (words(nampos) == loc(i)) then lpos=i exit end if end do call readline(port, lin, ios=ioerr) if (ioerr /=0) goto 999 narg=maxarg call args(lin, narg, words, ' ', SEP_WHITE) if (narg == 2 .and. isreal(words(1)) .and. isreal(words(2))) then dist=dist+0.5d0*(fval(words(1))+fval(words(2))) else if (isreal(words(1))) then dist=dist+fval(words(1)) end if if (lpos > 0) then mapped=mapped+1 map(lpos)=dist minpos=min(minpos, map(lpos)) maxpos=max(maxpos, map(lpos)) locstat(lpos)=1.0d0 end if end do ! GTF file ! first skip meta-information else if (filtyp == 3) then call metavcf_vars(port, lin, ' ', ioerr, plevel) if (ioerr /= 0) goto 999 if (plevel > 1) then write(outstr,'(/a/)') 'Reading variation data.' end if ! variation data do call get_varinfo(lin, locinfo, refall, altall) if (locinfo /= ' ') then call find_hashtab(trim(locinfo(1:loc_width)), loc, lochash, idx) if (idx > 0) then narg=4 call args(lin, narg, words, char(9), SEP_CHAR) mapped=mapped+1 map(idx)=mapconstant*fval(words(bppos)) minpos=min(minpos, map(idx)) maxpos=max(maxpos, map(idx)) group(idx)=words(chrpos) locnotes(idx)=trim(words(chrpos)) // ':' // trim(words(bppos)) // & ' [' // trim(refall) // '/' // trim(altall) // ']' // & trim(locnotes(idx)) if (plevel > 1) then if (mod(mapped, 10000) == 1) then write(outstr,'(i10,a,a15,2(1x,a))') & mapped, ': ', trim(locinfo), trim(words(bppos)), group(idx) end if end if locstat(idx)=1.0d0 if (mapped == nmark) exit end if end if call readline(port, lin, ios=ioerr) if (ioerr /= 0) exit nlines=nlines+1 if (plevel > 1) then if (mod(nlines, 100000) == 1) then write(outstr,'(a,i0,4a)') & 'Reading line ', nlines, ' locus "', trim(locinfo), '": ', & trim(lin) end if end if end do ! ! VCF ! else if (filtyp == 4) then call metavcf_vars(port, lin, ' ', ioerr, plevel) if (ioerr /= 0) goto 999 do call readline(port, lin, ios=ioerr) if (ioerr /= 0) exit narg=3 call args(lin, narg, words, char(9), SEP_CHAR) call find_hashtab(trim(words(nampos)(1:loc_width)), loc, lochash, idx) if (idx > 0) then if (isreal(words(bppos))) then mapped=mapped+1 map(idx)=mapconstant*fval(words(bppos)) minpos=min(minpos, map(idx)) maxpos=max(maxpos, map(idx)) group(idx)=words(chrpos) if (plevel > 1) then write(outstr,'(i0,1x,a,1x,a)') mapped, trim(words(nampos)), words(bppos) end if narg=8 call args(lin, narg, words, char(9), SEP_CHAR) locnotes(idx)='[' // trim(adjustl(words(4))) // '/' // & trim(adjustl(words(5))) // '] ' // & trim(words(8)) if (words(8) /= 'PASS') then locnotes(idx)=trim(locnotes(idx)) // ' ' // trim(words(8)) end if locstat(idx)=1.0d0 if (mapped == nmark) exit end if end if end do ! ! .bim ! else if (filtyp == 5) then do call readline(port, lin, ios=ioerr) if (ioerr /= 0) exit nlines=nlines+1 if (plevel > 1) then write(outstr,'(i0,2a)') nlines, ': ', lin(1:72) end if narg=6 call args(lin, narg, words, ' ', SEP_WHITE) call find_hashtab(trim(words(nampos)(1:loc_width)), loc, lochash, idx) if (idx > 0) then if (isreal(words(bppos))) then mapped=mapped+1 map(idx)=mapconstant*fval(words(bppos)) group(idx)=words(chrpos) minpos=min(minpos, map(idx)) maxpos=max(maxpos, map(idx)) locnotes(idx)='[' // trim(adjustl(words(5))) // '/' // & trim(adjustl(words(6))) // '] ' // & trim(locnotes(idx)) locstat(idx)=1.0d0 if (mapped == nmark) exit end if end if end do end if write(outstr,'(/a,i0,a)') & 'Matched up ', mapped, ' loci with their map positions ' if (plevel > 0) then if (anint(maxpos) == maxpos .and. anint(minpos) == minpos) then write(outstr,'(a,i0,a,i0)') & 'Map range ', int(minpos), ' to ', int(maxpos) else write(outstr,'(a,g14.6,a,g14.6)') & 'Map range ', minpos, ' to ', maxpos end if end if if (filtyp == 1 .or. filtyp == 2) then if (maxpos > 1.0d6 .and. mapunits == 1) then mapunits=5 if (plevel > 0) then write(outstr,'(a)') 'NOTE: Guessed map units to be bp.' end if end if if (mapunits > 1) then if (mapunits == 4) mapconstant=1.0d-3 do i=1, nloci if (map(i) /= MISS) then narg=1 call args(locnotes(i), narg, words, ' ', SEP_WHITE) if (.not.(isreal(words(1)))) then write(words(1), '(i20)') int(map(i)) locnotes(i)=trim(adjustl(words(1))) // ' ' // trim(locnotes(i)) end if if (locstat(i) == 1.0d0) then map(i)=mapconstant*map(i) end if end if end do end if end if return ! read error 999 continue write(outstr,'(a)') 'ERROR: io error in map file.' end subroutine readmap ! ! Read a UCSC chain file ! following https://github.com/hmgu-itg/VCF-liftover ! subroutine readchain(port, plevel) use locus_types use locus_data use outstream use fileio use scanner use locus_list use genetic_maps use sorts implicit none type(ioport) :: port integer, intent(in) :: plevel integer, parameter :: MISS=-9999 ! allow moving to chromosome type (chromosome_data) :: chrom_table ! and passing through by map order double precision, dimension(nloci) :: mapidx integer, dimension(nloci) :: chosen, locidx, ord, revidx character (len=256) :: buff character(len=loc_width) :: currchrom character(len=loc_width), dimension(15) :: words character (len=2) :: thischr integer :: chrpos, curoff, curpos, fin, i, i1, i2, ichr, ioerr, j, lpos, & narg, nmark, nupdated, pos, sta, kk logical :: skip double precision :: hash_locnam ! functions integer :: chrnum, ival character (len=8) :: wrpercent if (.not.lochash%current) then call make_lochash(nloci, loc, lochash) end if call tabulate_chroms(nloci, loc, loctyp, map, group, chrom_table) call setup_stat('Lift over loci 1=unchanged 2=lifted_over', typ=2) nmark=0 ord=0 revidx=0 locidx=0 chosen=0 mapidx=0.0d0 do i=1, nloci if (isactive(loctyp(i)) .and. map(i) /= MISS) then nmark=nmark+1 locstat(i)=1 ord(nmark)=nmark locidx(nmark)=i revidx(i)=nmark ichr=chrnum(group(i)) hash_locnam=0.0d0 if (loc(i)(1:2) /= 'rs') hash_locnam=0.5d0 mapidx(nmark)=1.0d9*ichr + 1.0d6*map(i) + hash_locnam end if end do call srank(nmark, mapidx, ord) do i=1, nmark chosen(ord(i))=i end do nupdated=0 skip=.true. if (plevel > 0) then write(outstr,'(/a)') 'Chromosome Int_start Int_end Offset' end if do call readline(port, buff, ios=ioerr) if (ioerr /= 0) exit narg=12 call args(buff, narg, words, ' ', SEP_WHITE) if (words(1) == 'chain') then if (words(3) /= words(8)) then skip=.true. else skip=.false. currchrom=words(3) curpos=ival(words(6)) curoff=ival(words(11))-ival(words(6)) end if else if (.not.skip) then i1=ival(words(1)) i2=ival(words(2)) if (plevel > 0) then write(outstr,'(a10,3(1x,i10))') currchrom, curpos, curpos+i1, curoff end if thischr=currchrom(4:5) ! through that chromosome, chains may not be in order ! NB map positions are being updated on fly - locstat records which have moved ! and so shouldn't be tested call whichchrom(thischr, chrom_table, chrpos) if (chrpos > 0) then sta=chosen(revidx(chrom_table%mapstart(chrpos,1))) fin=chosen(revidx(chrom_table%mapend(chrpos,1))) do pos=locidx(ord(sta)) if (locstat(pos) == 1) then lpos=nint(1.0d6*map(pos)) if (lpos >= curpos) exit end if if (sta == fin) exit sta=sta+1 end do if (curpos <= lpos .and. lpos <= (curpos+i1)) then do pos=locidx(ord(fin)) if (locstat(pos) == 1) then lpos=nint(1.0d6*map(pos)) if (lpos <= (curpos+i1)) exit end if if (sta == fin) exit fin=fin-1 end do else fin=sta-1 end if ! if (fin < sta) then ! write(*,*) currchrom, curpos, curpos+i1, curoff, ' no loci in interval' ! else ! write(*,*) currchrom, curpos, curpos+i1, curoff, sta, fin, map(locidx(chosen(sta))), map(locidx(chosen(fin))) ! end if do i=sta, fin pos=locidx(ord(i)) if (locstat(pos) == 1) then lpos=nint(1.0d6*map(pos)) if (plevel > 1) then write(outstr,*) loc(pos), ' ', group(pos), ' ', lpos, & ' -> ', lpos+curoff end if map(pos)=1.0d-6*real(lpos+curoff, kind=8) nupdated=nupdated+1 locstat(pos)=2 end if end do end if if (nupdated == nmark) exit curpos=curpos+i1+i2 curoff=curoff+ival(words(3))-i2 end if end do write(outstr,'(/a,i0,1x,2a)') 'Lifted over ', nupdated, & trim(wrpercent(nupdated, nmark)), ' map positions.' call clean_chroms(chrom_table) end subroutine readchain ! ! Read a list of locus names from a file to keep/drop/undrop ! normally reads first field of each line unless VCF, ! Sib-pair binary or column specified ! subroutine readnames(port, nloci, loc, lochash, chosen, plevel, colpos) use fileio use outstream use idhash_class use locstring_widths use scanner type (ioport) :: port integer, intent(in) :: nloci character (len=loc_width), dimension(:), intent(in) :: loc type (hash_table) :: lochash integer, dimension(:), intent(out) :: chosen integer, intent(in) :: plevel integer, optional, intent(in) :: colpos character (len=256) :: buff character(len=loc_width) :: word integer :: filehint, ioerr, locnum, matched, nampos, unmatched, slen nampos=1 call getfilehint(port%filnam, filehint) if (filehint == 4) then nampos=3 else if (filehint == 5) then nampos=2 end if if (present(colpos)) then if (colpos > 0) then nampos=colpos if (plevel > 0) then write(outstr,'(a,i0,a)') 'Reading column ', nampos, '.' end if end if end if matched=0 unmatched=0 chosen(1:nloci)=0 do call readline(port, buff, ios=ioerr) if (ioerr /= 0) exit call getword(buff, nampos, word) slen=len_trim(word) ! SuperlinkSNP expects marker names to be "#name#", so strip if (word(1:1) == '#' .and. word(slen:slen) == '#' .and. slen > 2) then word=word(2:(slen-1)) end if call find_hashtab(trim(word), loc, lochash, locnum) if (locnum > 0) then matched=matched+1 chosen(locnum)=1 else if (len_trim(word) > 0) then unmatched=unmatched+1 if (plevel > 1) then write(outstr,'(3a)') 'Current dataset does not contain "', trim(word), '".' end if end if end do if (plevel > 0) then write(outstr,'(/a,i0,3a/a,i0,3a/)') & 'Match for ', matched, ' markers from "', trim(port%filnam), '".', & 'No match for ', unmatched, ' markers from "', trim(port%filnam), '".' end if end subroutine readnames ! ! Read a Linkage locus file ! subroutine rdlinloc(port, lin, words, numloc) use fileio use outstream use scanner use parser_data use locus_types use locus_data use locus_list use storage_classes type (ioport) :: port character (len=*), intent(inout) :: lin character (len=*), dimension(:), intent(inout) :: words ! Number of columns of data for each data class integer, dimension(NDATACLASS), intent(out) :: numloc ! local variables integer :: i, i1, i2, j, k, lpos, narg, ncol, newsiz, nlrec, nmark, & oldsiz, nrec, ntrait, typ, xlink logical :: hasnam, iscm real :: r1, r2 double precision :: dist ! functions integer :: ival double precision :: fval oldsiz=size(loc) call readline(port, lin, ios=ioerr) if (ioerr /= 0) goto 999 read(lin, *, err=999) nlrec, i1, xlink, i2 if (nlrec > oldsiz) then newsiz=5*(1+nlrec/5) call expand_loci(newsiz-oldsiz, 0) end if call readline(port, lin, ios=ioerr) if (ioerr /= 0) goto 999 read(lin, *, err=999) i1, r1, r2, i2 ! list giving locus map order call getlin(port, nord, words, lin, 1) nrec=nord if (nrec > nlrec) then write(outstr,'(a,i0,a,i0,a)') & 'ERROR: ', nrec, ' map elements but only ', nlrec, ' loci!' end if do i=1, nord locord(i)=ival(words(i)) wloc(i)=locord(i) end do ncol=0 nloci=0 nmark=0 ntrait=0 numloc(:)=0 do i=1, nlrec call getlin(port, narg, words, lin, 1) typ=ival(words(1)) ncol=ncol+1 if (typ == 3) ncol=ncol+1 hasnam=(narg >= 4 .and. .not. isinuse(.true., words(4), loc, lochash)) if (typ == 3) then nloci=nloci+1 nmark=nmark+1 locpos(nloci)=numloc(GCLASS)+1 outpos(nloci)=numloc(TCLASS)+1 numloc(GCLASS)=numloc(GCLASS)+2 numloc(TCLASS)=numloc(TCLASS)+2 locnotes(nloci)=lin if (.not.hasnam) then write(loc(nloci),'(a,i5.5)') 'mar', nmark call insert_lochash(trim(loc(nloci)), nloci, loc, lochash) else loc(nloci)=words(4) end if loctyp(nloci)=LOC_CODOM if (xlink == 1) loctyp(nloci)=LOC_XLIN call readline(port, lin, ios=ioerr) if (ioerr /= 0) goto 999 else if (typ == 0 .or. typ == 4) then nloci=nloci+1 ntrait=ntrait+1 locpos(nloci)=numloc(PCLASS)+1 outpos(nloci)=numloc(TCLASS)+1 numloc(PCLASS)=numloc(PCLASS)+1 numloc(TCLASS)=numloc(TCLASS)+1 loctyp(nloci)=LOC_QUA if (.not.hasnam) then write(loc(nloci),'(a,i3.3)') 'trait', ntrait else loc(nloci)=words(4) end if locnotes(nloci)=lin if (typ == 0) then do j=1, 4 call readline(port, lin, ios=ioerr) end do end if else if (typ == 1) then nloci=nloci+1 ntrait=ntrait+1 loctyp(nloci)=LOC_AFF locpos(nloci)=numloc(PCLASS)+1 outpos(nloci)=numloc(TCLASS)+1 numloc(PCLASS)=numloc(PCLASS)+1 numloc(TCLASS)=numloc(TCLASS)+1 locnotes(nloci)=lin if (typ == 0) loctyp(nloci)=LOC_QUA if (.not.hasnam) then write(loc(nloci),'(a,i3.3)') 'trait', ntrait else loc(nloci)=words(4) end if call readline(port, lin, ios=ioerr) if (ioerr /= 0) goto 999 call readline(port, lin, ios=ioerr) if (ioerr /= 0) goto 999 read(lin,*,err=999) i1 ! add in liability class as quantitative trait if necessary if (i1 > 1) then if (nloci > size(loc)) then call expand_loci(10, 0) end if write(outstr,'(/3a)') & 'NOTE: Liability class for "', trim(loc(nloci)), & '" added as quantitative variable.' call insloc(nloci) loc(nloci+1)=loc(nloci)(1:min(len_trim(loc(nloci)),8)) // '_l' nloci=nloci+1 loctyp(nloci)=LOC_QUA locpos(nloci)=numloc(PCLASS)+1 outpos(nloci)=numloc(TCLASS)+1 numloc(PCLASS)=numloc(PCLASS)+1 numloc(TCLASS)=numloc(TCLASS)+1 locnotes(nloci)='Liability class for ' // loc(nloci-1) ! correct positions of later loci in prespecified order -- ! locus list (includes extra liability loci) *and* recomb list j=1 do while (j <= nord) if (locord(j) >= nloci) then locord(j)=locord(j)+1 else if (locord(j) == (nloci-1)) then do k=nord, j+1, -1 locord(k+1)=locord(k) end do j=j+1 nord=nord+1 locord(j)=nloci end if j=j+1 end do do j=1, nrec if (wloc(j) >= nloci) then wloc(j)=wloc(j)+1 end if end do end if do j=1, i1 call readline(port, lin, ios=ioerr) if (ioerr /= 0) goto 999 end do end if end do call readline(port, lin, ios=ioerr) if (ioerr /= 0) goto 999 read(lin,*,err=999) i1, i2 call getlin(port, narg, words, lin, 1) if (narg /= (nrec-1)) then write(outstr,'(a/7x,a)') & 'ERROR: Number of recombination fractions does', & 'not match number of declared loci on map.' end if iscm=.false. do i=1, narg if (fval(words(i)) > 0.5d0) then iscm=.true. write(outstr,'(a)') & 'NOTE: Linkage locus file map distances inferred to be cM.' exit end if end do dist=0.0d0 map(wloc(1))=dist if (iscm) then do i=1, min(narg, nord) lpos=wloc(i+1) map(lpos)=dist+fval(words(i)) dist=map(lpos) end do else do i=1, min(narg, nord) lpos=wloc(i+1) map(lpos)=dist-50.0d0*log(1.0d0-2*fval(words(i))) dist=map(lpos) end do end if call close_port(port, ios) return ! read error 999 continue write(outstr,'(a)') 'ERROR: io error in Linkage locus file.' call close_port(port, ios) end subroutine rdlinloc ! ! Read a set of allele frequencies from the command line, ! making up some numbers if necessary ! typ=1 only expect list of allele frequencies ! 2 check for allele names alternating with frequencies ! subroutine rdfreq(typ, sta, fin, words, allele_buffer) use outstream use alleles_class use sorts implicit none integer, intent(in) :: typ integer, intent(in) :: sta integer, intent(in) :: fin character (len=*), dimension(:), intent(in) :: words type (allele_data), intent(inout) :: allele_buffer ! integer :: i, istep, j, na logical :: unsorted double precision :: x integer, dimension(:), allocatable :: sortorder double precision, dimension(:), allocatable :: sortfreq ! functions integer :: aval, ival logical :: isint, is_strict_int, is_strict_real double precision :: fval ! unsorted=.false. allele_buffer%numal=0 allele_buffer%xlinkd=.false. allele_buffer%typed=0 allele_buffer%untyped=0 allele_buffer%totall=0 allele_buffer%minall=0 allele_buffer%topall=0 if (.not.allocated(allele_buffer%allele_names)) then allocate(allele_buffer%allele_names(10)) allocate(allele_buffer%allele_freqs(10)) allocate(allele_buffer%cum_freqs(10)) end if allele_buffer%allele_names=0 ! just the number of alleles given if (sta == fin .and. isint(words(sta))) then allele_buffer%numal=ival(words(sta)) if (allele_buffer%numal >= size(allele_buffer%allele_names)) then call expand_alleles(allele_buffer, allele_buffer%numal-size(allele_buffer%allele_names)) end if x=1.0D0/dble(allele_buffer%numal) allele_buffer%allele_names(1)=1 allele_buffer%allele_freqs(1)=x allele_buffer%cum_freqs(1)=x do i=2, allele_buffer%numal-1 allele_buffer%allele_names(i)=i allele_buffer%allele_freqs(i)=x allele_buffer%cum_freqs(i)=allele_buffer%cum_freqs(i-1)+x end do allele_buffer%cum_freqs(allele_buffer%numal)=1.0D0 allele_buffer%minall=1 allele_buffer%topall=1 ! ! else read a list of allele frequencies ! padding out if sum to less than one ! else if (fin >= sta) then istep=1 ! Usually has specified allele names as well as frequencies ! Look for allele-freq pairs if (typ == 2 .and. mod(fin-sta,2) == 1) then istep=2 do i=sta, fin, 2 x=0.0d0 if (is_strict_real(words(i)) .and. .not.is_strict_int(words(i))) then x=fval(words(i)) if (x > 0.0d0 .and. x < 1.0d0) then istep=1 exit end if end if end do if (istep == 2) then write(outstr,'(a)',advance='no') 'NOTE: Presuming allele names are specified as:' do i=sta, fin, 2 write(outstr,'(1x, a)', advance='no') trim(words(i)) end do write(outstr,*) allele_buffer%allele_names(1)=aval(words(sta), 1) end if end if ! expand allele storage as required i=size(allele_buffer%allele_names) na=(fin-sta+1)/istep if (na >= i) then call expand_alleles(allele_buffer, na-i+1) end if j=1 allele_buffer%numal=na allele_buffer%allele_freqs(j)=fval(words(sta+istep-1)) allele_buffer%cum_freqs(j)=allele_buffer%allele_freqs(1) do i=sta+istep, fin, istep j=j+1 if (istep == 2) then allele_buffer%allele_names(j)=aval(words(i), 1) else allele_buffer%allele_names(j)=j end if if (allele_buffer%allele_names(j) < & allele_buffer%allele_names(j-1)) then unsorted=.true. end if allele_buffer%allele_freqs(j)=fval(words(i+istep-1)) allele_buffer%cum_freqs(j)=allele_buffer%cum_freqs(j-1) + & allele_buffer%allele_freqs(j) if (allele_buffer%cum_freqs(j) > 1.0D0) then allele_buffer%numal=j exit end if end do ! alleles are stored sorted by collation order if (unsorted) then allocate(sortorder(allele_buffer%numal), sortfreq(allele_buffer%numal)) sortfreq=allele_buffer%allele_freqs do j=1, allele_buffer%numal sortorder(j)=j end do call isort(1, allele_buffer%numal, allele_buffer%allele_names, & sortorder, 2) do j=1, allele_buffer%numal allele_buffer%allele_freqs(sortorder(j))=sortfreq(j) end do allele_buffer%cum_freqs(1)=allele_buffer%allele_freqs(1) do j=2, allele_buffer%numal allele_buffer%cum_freqs(j)=allele_buffer%cum_freqs(j-1) + & allele_buffer%allele_freqs(j) end do end if ! pad out if (allele_buffer%cum_freqs(allele_buffer%numal) > 0.99D0) then allele_buffer%cum_freqs(allele_buffer%numal)=1.0d0 allele_buffer%allele_freqs(allele_buffer%numal)= & 1.0d0-allele_buffer%cum_freqs(allele_buffer%numal-1) else write(outstr,'(a,f6.4,a)') & 'NOTE: Adding one extra allele as sum of frequencies = ', & allele_buffer%cum_freqs(allele_buffer%numal), '!' allele_buffer%numal=na+1 allele_buffer%cum_freqs(allele_buffer%numal)=1.0d0 allele_buffer%allele_freqs(allele_buffer%numal)= & 1.0d0-allele_buffer%cum_freqs(allele_buffer%numal-1) end if else allele_buffer%numal=2 allele_buffer%allele_names(1)=1 allele_buffer%allele_names(2)=2 allele_buffer%allele_freqs(1)=0.5d0 allele_buffer%allele_freqs(2)=0.5d0 allele_buffer%cum_freqs(1)=0.5d0 allele_buffer%cum_freqs(2)=1.0d0 end if allele_buffer%numgtp=allele_buffer%numal*(allele_buffer%numal+1)/2 end subroutine rdfreq ! ! Make change in order of variables ! Note that automatic variables get special treatment (esp since 20180829) ! subroutine ordvar(twrk, nloci, loc, loctyp, locpos, outpos, nord, locord, & group, map, locstat, locnotes, ord) use locus_types use automatic_data integer, intent(inout) :: twrk integer, intent(inout) :: nloci character (len=*), dimension(:), intent(inout) :: loc integer,dimension(:), intent(inout) :: loctyp integer,dimension(:), intent(inout) :: locpos, outpos ! new order integer, intent(in) :: nord integer, dimension(:), intent(in) :: locord character (len=*), dimension(:), intent(inout) :: group double precision, dimension(:), intent(inout) :: map double precision, dimension(:), intent(inout) :: locstat character (len=*), dimension(:), intent(inout) :: locnotes integer, dimension(:), intent(inout) :: ord ! integer, parameter :: MISS=-9999 integer :: i, pos ! ! write ordered loci followed by all others, latter set to deleted ! open(twrk, status='scratch', form='unformatted') do i=ENVNUM+1, nloci ord(i)=0 end do do i=1, ENVNUM ord(i)=i write(twrk) loc(i), loctyp(i), locpos(i), outpos(i), group(i), map(i), & locstat(i), locnotes(i) end do do i=1, nord pos=locord(i) ord(pos)=i if (pos > ENVNUM) then write(twrk) loc(pos), loctyp(pos), locpos(pos), outpos(pos), & group(pos), map(pos), locstat(pos), locnotes(pos) end if end do do i=1, nloci if (ord(i) == 0) then if (loctyp(i) < LOC_DEL) loctyp(i)=loctyp(i)+LOC_DEL write(twrk) loc(i), loctyp(i), locpos(i), outpos(i), group(i), map(i), & locstat(i), locnotes(i) end if end do rewind(twrk) do i=1, nloci read(twrk) loc(i), loctyp(i), locpos(i), outpos(i), group(i), map(i), & locstat(i), locnotes(i) end do close(twrk) end subroutine ordvar ! ! Pack pedigrees and loci ! Writes and reads temporary data to disk ! Note that SNPs stored as 2 genotypes per byte cannot be packed, ! so if hassnps == 2 then slocus is left unchanged ! subroutine packer(typ, wrk, wrk2, nloci, loc, loctyp, locpos, group, map, & locnotes, numloc, dataset, plevel) use outstream use ped_class use locus_types integer, intent(in) :: typ integer, intent(in) :: wrk, wrk2 integer, intent(inout) :: nloci character (len=*), dimension(:), intent(inout) :: loc integer,dimension(:), intent(inout) :: loctyp integer,dimension(:), intent(inout) :: locpos character (len=*), dimension(:), intent(inout) :: group double precision, dimension(:), intent(inout) :: map character (len=*), dimension(:), intent(inout) :: locnotes integer, dimension(NDATACLASS), intent(inout) :: numloc type (ped_data) :: dataset integer, intent(inout) :: plevel ! local variables integer, parameter :: MISS=-9999 integer :: dped, dobs, i, ioff, imztwin, j, newoffset, nped, nobs, & num, pedoffset, ped ! columns to save integer :: gkeep, gpos, pkeep, pos, ppos, skeep integer, dimension(dataset%numloc(GCLASS)) :: gactive integer, dimension(dataset%numloc(PCLASS)) :: pactive integer, dimension(dataset%numloc(SCLASS)) :: sactive ! ! make list of columns to retain ! also if asked update locus list, recalculate nloci (number of loci) ! locpos (first column of locus), and numloc (total columns of data) ! if (typ /= 1) then gkeep=0 pkeep=0 skeep=0 gpos=0 ppos=0 pos=0 do i=1, nloci if (dataset%hassnps == 2 .and. iscompressed(loctyp(i))) then pos=pos+1 loc(pos)=loc(i) locnotes(pos)=locnotes(i) loctyp(pos)=loctyp(i) group(pos)=group(i) map(pos)=map(i) locpos(pos)=locpos(i) else if (isactive(loctyp(i))) then pos=pos+1 if (ismarker(loctyp(i))) then if (locpos(i) > 0) then gkeep=gkeep+1 gactive(gkeep)=locpos(i) locpos(pos)=gkeep gkeep=gkeep+1 gactive(gkeep)=gactive(gkeep-1)+1 else skeep=skeep+1 sactive(skeep)=-locpos(i) locpos(pos)=-skeep skeep=skeep+1 sactive(skeep)=sactive(skeep-1)+1 end if else if (.not.isspecial(loctyp(i))) then pkeep=pkeep+1 pactive(pkeep)=locpos(i) locpos(pos)=pkeep end if loc(pos)=loc(i) locnotes(pos)=locnotes(i) loctyp(pos)=loctyp(i) group(pos)=group(i) map(pos)=map(i) else if (plevel > 1) then write(outstr,'(2a)') 'Deleting locus ', loc(i) end if end do if (pos < nloci) then write(outstr,'(a,i0,a/)') 'Permanently deleted ', nloci-pos, ' loci.' end if nloci=pos if (dataset%hassnps == 2) then numloc(SCLASS) = dataset%numloc(SCLASS) else numloc(SCLASS) = skeep end if numloc(GCLASS) = gkeep numloc(PCLASS) = pkeep numloc(TCLASS) = numloc(SCLASS) + numloc(GCLASS) + numloc(PCLASS) else numloc=dataset%numloc do i=1, numloc(GCLASS) gactive(i)=i end do do i=1, numloc(PCLASS) pactive(i)=i end do do i=1, numloc(SCLASS) sactive(i)=i end do end if ! ! rewrite pedigrees ! open(wrk, status='scratch', form='unformatted') open(wrk2, status='scratch', form='unformatted') nped=0 nobs=0 dped=0 dobs=0 newoffset=0 do ped=1, dataset%nped pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset if (dataset%actset(ped) > 0 .or. typ == 2) then nped=nped+1 nobs=nobs+num write(wrk) dataset%pedigree(ped), dataset%actset(ped), & newoffset+num, dataset%nfound(ped) do i=pedoffset+1, pedoffset+dataset%nfound(ped) write(wrk2) dataset%id(i), MISS, MISS, MISS, dataset%sex(i), & (dataset%glocus(i,gactive(j)), j=1,numloc(GCLASS)), & (dataset%plocus(i,pactive(j)), j=1,numloc(PCLASS)) if (dataset%hassnps == 1) then call matrix_write_filtered_row(i, dataset%slocus, skeep, sactive, wrk2) else if (dataset%hassnps == 2) then call matrix_write_row(i, dataset%slocus, wrk2) end if end do ioff=pedoffset-newoffset do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped) if (dataset%imztwin(i)==MISS) then imztwin=MISS else imztwin=dataset%imztwin(i)-ioff end if write(wrk2) dataset%id(i), imztwin, & dataset%fa(i)-ioff, & dataset%mo(i)-ioff, dataset%sex(i), & (dataset%glocus(i,gactive(j)), j=1,numloc(GCLASS)), & (dataset%plocus(i,pactive(j)), j=1,numloc(PCLASS)) if (dataset%hassnps == 1) then call matrix_write_filtered_row(i, dataset%slocus, skeep, sactive, wrk2) else if (dataset%hassnps == 2) then call matrix_write_row(i, dataset%slocus, wrk2) end if end do newoffset=newoffset+num else if (plevel > 1) then write(outstr,'(2a)') 'Deleting pedigree ', trim(dataset%pedigree(ped)) end if dped=dped+1 dobs=dobs+num end if end do call pedin(wrk, wrk2, nped, nobs, numloc, numloc, dataset) close(wrk, status='delete') close(wrk2, status='delete') if (dped > 0) then write(outstr,'(/a,i6,a,i7,a/)') & 'Permanently deleted ', dped, ' pedigrees (', dobs, ' individuals).' end if end subroutine packer ! ! Pack locus list if dataset not yet read in ! subroutine packloci(nloci, loc, loctyp, locpos, group, map, locnotes, numloc, plevel) use outstream use storage_classes use locus_types integer, intent(inout) :: nloci character (len=*), dimension(:), intent(inout) :: loc integer,dimension(:), intent(inout) :: loctyp integer,dimension(:), intent(inout) :: locpos character (len=*), dimension(:), intent(inout) :: group double precision, dimension(:), intent(inout) :: map character (len=*), dimension(:), intent(inout) :: locnotes integer, dimension(NDATACLASS) :: numloc integer, intent(inout) :: plevel ! local variables integer :: i, gseek, pkeep, skeep, pos gkeep=0 pkeep=0 skeep=0 pos=0 do i=1, nloci if (isactive(loctyp(i))) then pos=pos+1 if (ismarker(loctyp(i))) then if (locpos(i) > 0) then gkeep=gkeep+1 locpos(pos)=gkeep gkeep=gkeep+1 else skeep=skeep+1 locpos(pos)=-skeep skeep=skeep+1 end if else if (.not.isspecial(loctyp(i))) then pkeep=pkeep+1 locpos(pos)=pkeep end if loc(pos)=loc(i) locnotes(pos)=locnotes(i) loctyp(pos)=loctyp(i) group(pos)=group(i) map(pos)=map(i) end if end do if (pos < nloci) then write(outstr,'(a,i0,a/)') 'Permanently deleted ', nloci-pos, ' loci.' end if nloci=pos numloc(SCLASS) = skeep numloc(GCLASS) = gkeep numloc(PCLASS) = pkeep numloc(TCLASS) = numloc(SCLASS) + numloc(GCLASS) + numloc(PCLASS) end subroutine packloci ! ! Calculate Bonferroni corrected P-value for given number of tests ! function bonf(ntest,alpha) double precision :: bonf integer, intent(in) :: ntest double precision, intent(in) :: alpha bonf=alpha if (ntest > 1) then bonf=1.0D0-(1.0D0-alpha)**(1.0D0/dble(ntest)) end if end function bonf ! ! Determine if index person is affected or unaffected ! function isaff(val, thresh, gt) double precision :: isaff double precision, intent(in) :: val double precision, intent(in) :: thresh integer, intent(in) :: gt integer, parameter :: MISS=-9999 isaff=val if (gt > 14 .and. isaff /= MISS) then if (gt == 15 .and. isaff < thresh) then isaff=2.0d0 else if (gt == 16 .and. isaff > thresh) then isaff=2.0d0 else if (gt == 17 .and. isaff >= thresh) then isaff=2.0d0 else if (gt == 18 .and. isaff <= thresh) then isaff=2.0d0 else if (gt == 19 .and. isaff /= thresh) then isaff=2.0d0 else if (gt == 20 .and. isaff == thresh) then isaff=2.0d0 else if (gt == 21 .or. gt == 22) then if (mod(nint(isaff),2) == (22-gt)) then isaff=2.0d0 else isaff=1.0d0 end if else isaff=1.0d0 end if end if if (isaff /= MISS .and. isaff /= 1.0d0 .and. isaff /= 2.0d0) isaff = MISS end function isaff ! ! Is an MZ twin? ! function isatwin(twintype, twinind) logical :: isatwin integer, intent(in) :: twintype double precision, intent(in) :: twinind integer, parameter :: KNOWN=0, MISS=-9999 isatwin=((twintype==1 .and. twinind > KNOWN) .or. & (twintype==2 .and. twinind /= MISS .and. & mod(int(twinind), 2)==1)) end function isatwin ! ! Is pair MZ? ! index i must precede j ! function ismzpair(i, j, dataset) use ped_class implicit none logical :: ismzpair integer, intent(in) :: i, j type (ped_data), intent(in) :: dataset integer, parameter :: MISS=-9999 ismzpair=.false. if (dataset%imztwin(j) == MISS) return if (i == dataset%imztwin(j)) then ismzpair=.true. else if (dataset%imztwin(i) == dataset%imztwin(j)) then ismzpair=.true. end if end function ismzpair ! ! swap alleles so ordered consistently ! subroutine order(all1, all2) integer, intent(inout) :: all1 integer, intent(inout) :: all2 integer :: swp if (all1 > all2) then swp=all1 all1=all2 all2=swp end if end subroutine order ! ! swap alleles ! subroutine swap(all1, all2) integer, intent(in out) :: all1 integer, intent(in out) :: all2 integer :: swp swp=all1 all1=all2 all2=swp return end subroutine swap ! ! Create order of loci for outputting a pedigree ! 1 = as is ! 2 = LINKAGE ! 3 = GENEHUNTER ! 4 = MENDEL ! 5 = LINKAGE PPD ! 6 = FBAT ! 7 = MERLIN ! subroutine lorder(typ, addummy, liab, liabclass, & nloci, loctyp, nord, locord) use locus_types integer, intent(in) :: typ integer, intent(in) :: addummy integer, intent(in) :: liab, liabclass integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, intent(out) :: nord integer, dimension(:), intent(out) :: locord ! Printing order of loci integer :: i logical :: didliab didliab=.false. ! Default is no manipulation if (typ < 2 .or. typ==5 .or. typ==7) then nord=nloci do i=1, nloci locord(i)=i end do ! else Genehunter 2 ordering else nord=0 ! no more than one binary trait if typ=3 or 6 if (typ == 2 .or. typ == 3 .or. (typ == 6 .and. addummy==0)) then do i=1, nloci if (loctyp(i) == LOC_AFF) then nord=nord+1 locord(nord)=i ! put liability class after appropriate binary trait if (i == liab) then nord=nord+1 locord(nord)=liabclass didliab=.true. end if if (typ == 3 .or. typ == 6) exit end if end do end if ! all the markers do i=1, nloci if (isactdip(loctyp(i))) then nord=nord+1 locord(nord)=i end if end do ! MENDEL factors if (typ == 4) then do i=1, nloci if (loctyp(i) == LOC_AFF) then nord=nord+1 locord(nord)=i end if end do end if ! then the categorical followed by quantitative traits if (typ /= 6) then do i=1, nloci if (same_loctyp(loctyp(i), LOC_CAT)) then if (i /= liabclass .or. .not.didliab) then nord=nord+1 locord(nord)=i end if end if end do do i=1, nloci if (same_loctyp(loctyp(i), LOC_QUA)) then if (i /= liabclass .or. .not.didliab) then nord=nord+1 locord(nord)=i end if end if end do end if end if end subroutine lorder ! ! Is a bound environmental variable? and if so where? ! function isinenv(word,nvar,envnam) integer :: isinenv character (len=*), intent(in) :: word integer, intent(in) :: nvar character (len=*), intent(in) :: envnam(nvar) do isinenv=1, nvar if (envnam(isinenv) == word) then return end if end do isinenv=0 end function isinenv ! ! Read a Sib-pair binary file encoded using ! various levels of compression (currently just calls gunzip) ! Default (compress_level=1) is a "Fortran unformatted write" dump of the ! locus and pedigree arrays ! typ=format version ! 1=current (2012/02) ! 2=older (2009/08) ! 3=original (change in loctyp coding) ! subroutine readbin(strm, filnam, wrkfil, typ, numloc, dataset, red, plevel) use outstream use locus_types use locus_data use idstring_widths use locus_data use ped_class use scheme_lang use iocodes use automatic_data implicit none integer, intent(in) :: strm character (len=*), intent(in) :: filnam character (len=*), intent(inout) :: wrkfil integer, intent(in) :: typ ! number of columns of locus data integer, dimension(NDATACLASS), intent(inout) :: numloc type (ped_data), intent(inout) :: dataset logical, intent(out) :: red integer, intent(in) :: plevel integer, parameter :: MISS = -9999, WORDLEN=40 ! integer :: nped ! number of pedigrees integer :: nobs ! number of records ! number of available columns of locus data integer, dimension(NDATACLASS) :: numcol integer :: astat, eon, errcode, imaj, imin, ios, ityp, newsiz, oldsiz, stor logical :: gzipped character (len=21) :: slin character (len=80) :: bigword ! timing integer :: it1, it2, ticks double precision :: dataset_uses ! chunking of slocus integer :: i, iblock, ichunk, newsta, newfin, offset, sta, fin integer(kind=8) :: nsnps call system_clock(it1) ityp=typ imaj=-1 imin=-1 red=.false. bigword=' ' slin=' ' gzipped=.false. eon=len_trim(filnam) if (eon == 0) then write(outstr,'(a)') 'No pedigree file name given.' return end if call unzipper(filnam, wrkfil, gzipped) open(strm, file=wrkfil, access=stream_access, form=stream_form, iostat=ios) if (ios /= 0) then write(outstr,'(3a)') & 'ERROR: Could not open Sib-pair binary file "', trim(filnam),'".' close(strm) if (gzipped) call delfile(wrkfil, plevel-3) return end if errcode=-1 read(strm, err=999, end=998) slin if (slin(1:16) /= 'Sib-pair raw ped') then ! .bin files were previously written unformatted sequential close(strm) open(strm, file=wrkfil, form='unformatted', iostat=ios) read(strm, err=999, end=998) slin if (slin(1:16) /= 'Sib-pair raw ped') then write(outstr,'(a)') 'ERROR: Not a Sib-pair binary pedigree file.' close(strm) if (gzipped) call delfile(wrkfil, plevel-3) return end if end if ! if (slin(19:19) /= 'r') then read(slin(19:19), '(i1)') imaj read(slin(21:21), '(i1)') imin end if if (plevel > 0) then write(outstr,'(a,i1,a,i1)') & 'Sib-pair pedigree file version ', imaj, '.', imin end if ! ! Read in number of loci oldsiz=size(loc) read(strm) nloci sta=1 fin=nloci newsiz=ENVNUM + 5*(1+nloci/5) call expand_loci(newsiz-oldsiz, 0) errcode=-2 read(strm, err=999, end=998) loc(sta:fin), loctyp(sta:fin), & locpos(sta:fin), outpos(sta:fin), locnotes(sta:fin) read(strm, err=999, end=998) group(sta:fin), map(sta:fin) ! ! Support older formats, where ENVNUM can be 0, 15 ! if (ityp == 2) call newloctyp() call count_specials(offset) if (offset /= ENVNUM) then sta=sta+offset nloci=nloci-offset newsta=ENVNUM+1 newfin=ENVNUM+fin loc(newsta:newfin)=loc(sta:fin) loctyp(newsta:newfin)=loctyp(sta:fin) locpos(newsta:newfin)=locpos(sta:fin) outpos(newsta:newfin)=outpos(sta:fin) locnotes(newsta:newfin)=locnotes(sta:fin) group(newsta:newfin)=group(sta:fin) map(newsta:newfin)=map(sta:fin) call setup_auto() end if ! read(strm, err=999, end=998) nped, nobs, numloc, numcol if (plevel > 1) then call system_clock(it2, count_rate=ticks) write(slin, '(f20.2)') float(it2-it1)/float(ticks) slin=adjustl(slin) write(outstr,'(/a,i0,3a/a/a,i0,a,i0,2(/a,4(1x,i0))/)') & 'Read in descriptions of ', nloci, ' loci (', trim(slin), 's)', & 'About to read in pedigree data: ', & 'nped=', nped, ' nobs=', nobs, & 'numloc=', numloc, 'numcol=', numcol end if ! added 2022-06-28 after erroneous numloc in binary file if (numloc(PCLASS) > numcol(PCLASS)) then numloc(PCLASS) = numcol(PCLASS) end if ! added 2017-08-14 after erroneous numloc in binary file if (numloc(SCLASS) > numcol(SCLASS)) then numloc(SCLASS) = numcol(SCLASS) end if ! added 2020-11-16 after erroneous numloc in binary file if (numloc(GCLASS) > numcol(GCLASS)) then numloc(GCLASS) = numcol(GCLASS) end if ! added 2016-12-07 V2.3 if (imaj >= 2 .and. imin >= 3) then read(strm) ped_width_adj, id_width_adj else ped_width_adj = 20 id_width_adj = 14 end if call cleanup_peds(dataset) call setup_peds(nped, nobs, numloc, numcol, dataset, astat, plevel) if (astat /= 0) return errcode=-3 read(strm, err=999, end=998) dataset%nped, dataset%nact, dataset%maxsiz, & dataset%maxact, dataset%nobs, dataset%numloc, dataset%numcol, dataset%hassnps if (ped_width_adj /= ped_width) then if (plevel > 1) then write(outstr,'(a,i0/a,i0)') & 'Program pedigree ID string maximum length = ', ped_width, & 'Binary image pedigree maximum length = ', ped_width_adj end if do i=1, nped read(strm, err=999, end=998) bigword(1:ped_width_adj) dataset%pedigree(i)=bigword end do else read(strm, err=999, end=998) dataset%pedigree end if read(strm, err=999, end=998) dataset%num, dataset%nfound, dataset%actset read(strm, err=999, end=998) dataset%iped, dataset%imztwin if (id_width_adj /= id_width) then if (plevel > 1) then write(outstr,'(a,i0/a,i0)') & 'Program individual ID string maximum length = ', id_width, & 'Binary image maximum length = ', id_width_adj end if do i=1, nobs read(strm, err=999, end=998) bigword(1:id_width_adj) dataset%id(i)=bigword end do else read(strm, err=999, end=998) dataset%id end if read(strm, err=999, end=998) dataset%fa, dataset%mo, dataset%sex if (dataset%hassnps /= 0) then errcode=-4 snpstorage=dataset%hassnps nsnps=int(dataset%nobs, kind=8)*int(dataset%numcol(SCLASS), kind=8) if (plevel > 0) then write(outstr,'(a,i0,a)') & 'Reading ', int(snpstorage, kind=8)*nsnps, ' SNP genotypes.' end if if (mod(ityp, 2) == 1) then call matrix_read(strm, dataset%slocus, ios) else call matrix_read_unformatted(strm, dataset%nobs, & dataset%numcol(SCLASS), dataset%slocus, ios) end if if (ios /= 0) goto 999 end if errcode=-5 if (plevel > 0) then write(outstr,'(a,i0,a)') & 'Reading other marker genotypes.' end if read(strm, err=999, end=998) dataset%glocus errcode=-6 if (plevel > 0) then write(outstr,'(a,i0,a)') & 'Reading phenotypes.' end if read(strm, err=999, end=998) dataset%plocus ! ! Repair numloc if corrupted ! 20170814 ! numloc=0 do i=ENVNUM+1, nloci if (istrait(loctyp(i))) then numloc(PCLASS)=numloc(PCLASS)+1 else stor=gencode(loctyp(i)) if (stor == 1) then numloc(GCLASS)=numloc(GCLASS)+2 else if (stor == 2) then numloc(SCLASS)=numloc(SCLASS)+2 else if (stor == 3) then numloc(SCLASS)=numloc(SCLASS)+1 end if end if end do numloc(TCLASS)=numloc(SCLASS)+numloc(GCLASS)+numloc(PCLASS) if (numloc(SCLASS) /= dataset%numloc(SCLASS)) then write(outstr,'(a,i0,a/7x,a,i0,a/7x,a)') & 'ERROR: Number of SNPs in locus list, ', & numloc(SCLASS),',', 'is inconsistent with file header ', & dataset%numloc(SCLASS), '.', 'Updating to former.' end if if (numloc(GCLASS) /= dataset%numloc(GCLASS)) then write(outstr,'(a,i0,a,i0,a)') & 'ERROR: Number of markers inconsistent, ', & numloc(GCLASS),' versus read ', dataset%numloc(GCLASS), '.' end if if (numloc(PCLASS) /= dataset%numloc(PCLASS)) then write(outstr,'(a,i0,a,i0,a)') & 'ERROR: Number of traits inconsistent, ', & numloc(PCLASS),' versus read ', dataset%numloc(PCLASS), '.' end if dataset%numloc=numloc ! ! key variables state and state of scheme memory ! added 20090531 ! read(strm, iostat=ios) slin if (ios == 0 .and. slin == 'Other Variable States') then if (plevel > 0) then write(outstr,'(a,i0,a)') & 'Reading environmental variables and Scheme image.' end if read(strm) twinning, twintype, twintrait, sexmarker if (typ < 3) then call read_scheme_image(strm, ios) end if else write(outstr, '(a)') 'NOTE: Format version < 20090531' end if ! close(strm) red=.true. call system_clock(it2, count_rate=ticks) write(slin, '(f20.2)') float(it2-it1)/float(ticks) slin=adjustl(slin) write(outstr,'(a,i0,a,i0,a/9x,i0,a)') & 'Read in ', nped, ' pedigrees, ', nobs, ' individuals', & numloc(TCLASS), ' variables (' // trim(slin) // ' s)' write(slin, '(f20.3)') dataset_uses(dataset) slin=adjustl(slin) write(outstr,'(a/)') 'Dataset occupies ' // trim(slin) // ' MB.' if (gzipped) call delfile(wrkfil, plevel-3) return ! ! read error and premature end handler 998 continue write(outstr,'(a)') 'ERROR: Premature end of file!' 999 continue write(outstr,'(3a,i0)') & 'ERROR: Problem reading "', trim(filnam), '". Error=', errcode close(strm) ! call cleanup_peds(dataset) if (gzipped) call delfile(wrkfil, plevel-3) end subroutine readbin ! ! Write a Sib-pair binary file ! Default was a "Fortran unformatted write" dump of the ! locus and pedigree arrays, but now is stream output ! If compress=2, currently calls gzip to compress the resulting file ! ! 2.0 stream based write ! 2.1 first NUMENV variables are automatic ! 2.2 NUMENV increased by 1 ! 2.3 adjustable ped_width id_width ! subroutine writebin(strm, compress_level, filnam, dataset, plevel) use outstream use locus_types use locus_data use idstring_widths use locus_data use ped_class use scheme_lang use iocodes implicit none integer, intent(in) :: strm, compress_level character (len=*), intent(inout) :: filnam type (ped_data), intent(in) :: dataset integer, intent(in) :: plevel integer, parameter :: MISS = -9999, WORDLEN=35 integer :: eon, gzip, ios character (len=21) :: slin integer :: it1, it2, ticks integer(kind=8) :: nsnps ! call system_clock(it1) gzip=compress_level eon=len_trim(filnam) if (filnam((eon-2):eon) == '.gz') then gzip=2 filnam=filnam(1:(eon-3)) end if open(strm, file=filnam, access=stream_access, form=stream_form, iostat=ios) if (ios /= 0) then write(outstr,'(3a)') & 'ERROR: Could not open file "', trim(filnam),'" for writing.' return end if slin='Sib-pair raw ped V2.3' write(strm) slin write(strm) nloci write(strm) loc(1:nloci), loctyp(1:nloci), locpos(1:nloci), outpos(1:nloci), & locnotes(1:nloci) write(strm) group(1:nloci), map(1:nloci) write(strm) dataset%nped, dataset%nobs, dataset%numloc, dataset%numcol ! added 2016-12-07 V2.3 write(strm) ped_width, id_width write(strm) dataset%nped, dataset%nact, dataset%maxsiz, dataset%maxact, & dataset%nobs, dataset%numloc, dataset%numcol, dataset%hassnps write(strm) dataset%pedigree, dataset%num, dataset%nfound, dataset%actset write(strm) dataset%iped, dataset%imztwin, dataset%id, & dataset%fa, dataset%mo, dataset%sex if (dataset%hassnps /= 0) then nsnps=int(dataset%nobs, kind=8)*int(dataset%numcol(SCLASS), kind=8) if (plevel > 0) then write(outstr,'(a,i0,a)') & 'Writing ', int(snpstorage,kind=8)*nsnps, ' SNP genotypes.' end if call matrix_write(dataset%slocus, strm, ios) end if write(strm) dataset%glocus write(strm) dataset%plocus ! key variables state slin='Other Variable States' write(strm) slin write(strm) twinning, twintype, twintrait, sexmarker ! state of scheme memory call save_scheme_image(strm, ios) if (ios /= 0) then write(outstr,'(a)') 'ERROR: Problem writing scheme image.' end if close(strm) if (gzip == 2) then call system('gzip ' // trim(filnam)) filnam=trim(filnam) // '.gz' end if call system_clock(it2, count_rate=ticks) write(slin, '(f20.2)') float(it2-it1)/float(ticks) slin=adjustl(slin) write(outstr,'(a,i0,a,i0,a/7x,i0,5a)') & 'Wrote ', dataset%nped, ' pedigrees, ', dataset%nobs, ' individuals', & dataset%numloc(TCLASS), ' variables to "', trim(filnam), & '" (', trim(slin), ' s).' end subroutine writebin ! ! Declare loci from a sib-pair binary file eg prior to merge ! subroutine decbinloci(filnam, numloc, plevel) use fileio use outstream use locstring_widths use locus_types use automatic_data use locus_data use storage_classes character (len=*), intent(in) :: filnam ! number of columns of locus data integer, dimension(NDATACLASS), intent(inout) :: numloc integer, intent(in) :: plevel integer, parameter :: MISS = -9999, WORDLEN=35 type (ioport) :: port integer :: ich, ioerr, ifail, newsiz, other_nloci, oldsiz, stor integer (kind=8) :: offset, filsiz character (len=1) :: ch character (len=2) :: ch2 character (len=4) :: byte character (len=8) :: word64 character (len=21) :: slin integer (kind=8) , parameter :: locsiz=82, loc_namtyp_siz = 72 double precision :: xval integer :: it1, it2, ticks ! call system_clock(it1) ifail=-1 call open_port(filnam, port, 'r', ioerr) if (ioerr /= 0) then write(outstr,'(3a)') & 'ERROR: Could not open Sib-pair binary file "', trim(filnam),'".' return end if call readline(port, slin, advance='no', ios=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') & 'ERROR: Unable to read "', trim(port%filnam),'".' call close_port(port, ioerr) return else if (slin(1:16) /= 'Sib-pair raw ped') then write(outstr,'(a)') 'ERROR: Not a Sib-pair binary pedigree file.' return end if if (plevel > 0) then write(outstr,'(/a)') slin end if other_nloci=-1 call readline(port, byte, advance='no', ios=ioerr) if (ioerr == 0) other_nloci=transfer(byte, ich) if (plevel > 0) then write(outstr,'(3a,i0)') 'file=', trim(port%filnam), ' nloci=', other_nloci end if if (other_nloci < 1) goto 999 ifail=0 oldsiz=size(loc) nloci=other_nloci newsiz=ENVNUM + 5*(1+nloci/5) call expand_loci(newsiz-oldsiz, 0) offset=25 call seek_port(port, offset, ioerr) if (ioerr /= 0) goto 999 write(outstr,'(a)', advance='no') 'Reading' do i=1, nloci call readline(port, loc(i), advance='no', ios=ioerr) if (ioerr /= 0) goto 999 end do write(outstr,'(a)', advance='no') '..locus names' do i=1, nloci call readline(port, byte, advance='no', ignore_eol='yes', ios=ioerr) if (ioerr /= 0) goto 999 loctyp(i)=transfer(byte, ich) end do write(outstr,'(a)', advance='no') '..types' do i=1, nloci call readline(port, byte, advance='no', ignore_eol='yes', ios=ioerr) if (ioerr /= 0) goto 999 locpos(i)=transfer(byte, ich) end do do i=1, nloci call readline(port, byte, advance='no', ignore_eol='yes', ios=ioerr) if (ioerr /= 0) goto 999 outpos(i)=transfer(byte, ich) end do do i=1, nloci call readline(port, locnotes(i), advance='no', ios=ioerr) if (ioerr /= 0) goto 999 end do do i=1, nloci call readline(port, group(i), advance='no', ios=ioerr) if (ioerr /= 0) goto 999 end do write(outstr,'(a)', advance='no') '..chroms' do i=1, nloci call readline(port, word64, advance='no', ignore_eol='yes', ios=ioerr) if (ioerr /= 0) goto 999 map(i)=transfer(word64, xval) end do call close_port(port, ioerr) call system_clock(it2, count_rate=ticks) write(slin, '(f20.2)') float(it2-it1)/float(ticks) slin=adjustl(slin) write(outstr,'(3a/)') '..map (', trim(slin), ' s).' ! numloc numloc=0 do i=ENVNUM+1, nloci if (istrait(loctyp(i))) then numloc(PCLASS)=numloc(PCLASS)+1 else stor=gencode(loctyp(i)) if (stor == 1) then numloc(GCLASS)=numloc(GCLASS)+2 else if (stor == 2) then numloc(SCLASS)=numloc(SCLASS)+2 else if (stor == 3) then numloc(SCLASS)=numloc(SCLASS)+1 end if end if end do numloc(TCLASS)=numloc(SCLASS)+numloc(GCLASS)+numloc(PCLASS) write(outstr,'(/a,4(1x,i0)/)') 'numloc=', numloc return ! all read errors 999 continue write(outstr,'(3a)') 'ERROR: Error while reading "', trim(filnam),'".' call close_port(port, ioerr) ifail=-2 return end subroutine decbinloci ! ! Read loci from sib-pair binary file into a locus_container ! subroutine rdspbinloci(port, ldata, ifail, plevel) use fileio use outstream use locstring_widths use locus_types use locus_data use storage_classes type (ioport) :: port type (locus_container) :: ldata integer, intent(out) :: ifail integer, intent(in) :: plevel integer, parameter :: MISS = -9999, WORDLEN=35 integer :: ich, ioerr, other_nloci, other_nped, other_nobs integer (kind=8) :: offset, filsiz character (len=1) :: ch character (len=2) :: ch2 character (len=4) :: byte character (len=8) :: word64 character (len=21) :: slin integer (kind=8) , parameter :: locsiz=82, loc_namtyp_siz = 72 double precision :: xval integer :: it1, it2, ticks ! call system_clock(it1) ifail=-1 call readline(port, slin, advance='no', ios=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') & 'ERROR: Unable to read "', trim(port%filnam),'".' call close_port(port, ioerr) return else if (slin(1:16) /= 'Sib-pair raw ped') then write(outstr,'(a)') 'ERROR: Not a Sib-pair binary pedigree file.' return end if if (plevel > 0) then write(outstr,'(/a)') slin end if ifail=0 other_nloci=-1 other_nped=-1 other_nobs=-1 call readline(port, byte, advance='no', ios=ioerr) if (ioerr == 0) other_nloci=transfer(byte, ich) offset=25+int(other_nloci, kind=8)*locsiz call seek_port(port, offset, ioerr) call readline(port, byte, advance='no', ios=ioerr) if (ioerr == 0) other_nped=transfer(byte, ich) call readline(port, byte, advance='no', ios=ioerr) if (ioerr == 0) other_nobs=transfer(byte, ich) if (plevel > 0) then write(outstr,'(2a,3(a,i0))') & 'file=', trim(port%filnam), ' nloci=', other_nloci, ' nped=', other_nped, ' nobs=', other_nobs end if call setup_locus_container(other_nloci, ldata) offset=25 call seek_port(port, offset, ioerr) if (ioerr /= 0) goto 999 write(outstr,'(a)', advance='no') 'Reading' do i=1, ldata%nloci call readline(port, ldata%loc(i), advance='no', ios=ioerr) if (ioerr /= 0) goto 999 end do write(outstr,'(a)', advance='no') '..locus names' do i=1, ldata%nloci call readline(port, byte, advance='no', ignore_eol='yes', ios=ioerr) if (ioerr /= 0) goto 999 ldata%loctyp(i)=transfer(byte, ich) end do write(outstr,'(a)', advance='no') '..types' offset=25+int(ldata%nloci, kind=8)*loc_namtyp_siz call seek_port(port, offset, ioerr) if (ioerr /= 0) goto 999 do i=1, ldata%nloci call readline(port, ldata%group(i), advance='no', ios=ioerr) if (ioerr /= 0) goto 999 end do write(outstr,'(a)', advance='no') '..chroms' do i=1, ldata%nloci call readline(port, word64, advance='no', ignore_eol='yes', ios=ioerr) if (ioerr /= 0) goto 999 ldata%map(i)=transfer(word64, xval) end do call system_clock(it2, count_rate=ticks) write(slin, '(f20.2)') float(it2-it1)/float(ticks) slin=adjustl(slin) write(outstr,'(3a/)') '..map (', trim(slin), ' s).' return 999 continue write(outstr,'(3a)') 'ERROR: Error while reading "', trim(port%filnam),'".' ifail=-2 return end subroutine rdspbinloci ! ! Summarize Sib-pair binary file ! subroutine rdspbin(filnam) use fileio use outstream use locstring_widths use locus_types use locus_data use storage_classes character (len=*), intent(in) :: filnam integer, parameter :: MISS = -9999, WORDLEN=35 type (ioport) :: port type (locus_container) :: ldata integer :: fin, i, ioerr, ityp, j, sta call open_port(filnam, port, 'r', ioerr) if (ioerr /= 0) then write(outstr,'(3a)') & 'ERROR: Could not open map "', trim(filnam),'".' return end if call rdspbinloci(port, ldata, ioerr, 2) if (ioerr /= 0) return call listchroms(ldata%nloci, ldata%loc, ldata%loctyp, ldata%map, ldata%group) call cleanup_locus_container(ldata) call close_port(port, ioerr) return end subroutine rdspbin ! ! Read in HapMap format ! subroutine readhapmap(filnam, numloc, dataset, longnam, red, plevel) use iobuff use locus_types use locus_data use idstring_widths use locus_data use ped_class use fileio use scanner use automatic_data implicit none character (len=*), intent(in) :: filnam integer, dimension(NDATACLASS), intent(inout) :: numloc type (ped_data), intent(inout) :: dataset integer, intent(out) :: longnam logical, intent(out) :: red integer, intent(in) :: plevel integer, parameter :: MISS = -9999, WORDLEN=35 ! file i/o port type (ioport) :: port ! ID strings and data strings integer :: narg character (len=WORDLEN) :: slin character (len=WORDLEN), dimension(:), allocatable :: words ! buffer for genotype data integer (kind=1), dimension(:), allocatable :: ibuff integer, dimension(NDATACLASS) :: numcol character (len=1) :: ch, ch2 character (len=256) :: prefix character (len=id_width) :: currfa, currmo integer :: cfa, cmo, eon, eop, g1, g2, gcode, gtp, i, ii, ioerr, j, & newsiz, ncol, nmar, pos, pos2 integer :: nf, nmapped, nobs, nped, num, pedoffset integer (kind=8) :: ngeno integer :: it1, it2, ticks integer :: aval double precision :: fval, dataset_uses call system_clock(it1) red=.false. call open_port(filnam, port, 'r', ioerr) if (ioerr /= 0) then write(outstr,'(3a)') & 'ERROR: Could not open HapMap style genotype file "', trim(filnam),'".' return end if call setup_plink(port, nmar, newsiz, 2) nmapped=0 nloci=0 numloc(:)=0 call rewind_port(port, ioerr) ! header call readline(port, lin(1:LINSIZ), ios=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') & 'ERROR: Could not read HapMap style genotype file "', trim(filnam),'".' return end if if (plevel > 1) then write(outstr,'(2a)') 'Header: ', lin(1:72 ) end if ncol=countargs(trim(lin), ' ', 4) nobs=ncol-11 if (nobs <= 0) then write(outstr,'(3a)') 'ERROR: Cannot read header of "', trim(filnam),'".' write(outstr,'(a)') lin(1:72) return end if ! allocate(words(ncol)) do call readline(port, lin(1:LINSIZ), ios=ioerr) if (ioerr /= 0) exit narg=4 call args(lin, narg, words, ' ', SEP_WHITE) nloci=nloci+1 loc(nloci)=words(1) loctyp(nloci)=LOC_CODOM words(3)=words(3)(4:len_trim(words(3))) if (words(3) == 'X') then loctyp(nloci)=LOC_XLIN end if locpos(nloci)=2*nloci locnotes(nloci)=trim(words(4)) // ' (chr ' // trim(words(3)) // ') ' // & trim(words(2)) group(nloci)=words(3) map(nloci)=1.0d-6*fval(words(4)) if (map(nloci) /= 0.0d0) nmapped=nmapped+1 outpos(nloci)=2*nloci end do numloc(GCLASS)=2*nloci+1 nped=nobs numloc(TCLASS)=numloc(GCLASS)+numloc(PCLASS)+numloc(SCLASS) write(outstr,'(a,a/a,i0)') & 'Pedigree file = ', trim(filnam), & 'Number of loci = ', nloci - ENVNUM write(outstr,'(a,i0/a,i0)') & 'Number of individuals = ', nobs, & 'Number of genotypes = ', int(nobs, kind=8)*int(nloci, kind=8) ! some extra workspace numcol=numloc numcol(TCLASS)=numcol(TCLASS) + 6 numcol(GCLASS)=numcol(GCLASS) + 4 numcol(PCLASS)=numcol(PCLASS) + 2 call setup_peds(nped, nobs, numloc, numcol, dataset, ioerr, plevel) if (ioerr /= 0) then write(outstr,'(/a)') 'ERROR: Could not allocate enough memory!' call close_port(port, ioerr) return end if ! ! Should be able to read into memory now ! call rewind_port(port, ioerr) call readline(port, lin(1:LINSIZ), ios=ioerr) narg=1 call args(lin, narg, words, ' ', SEP_WHITE) ii=11 do i=1, nobs ii=ii+1 dataset%pedigree(i)=words(ii) dataset%id(i)=words(ii) dataset%num(i)=dataset%num(i-1)+1 dataset%nfound(i)=1 dataset%actset(i)=1 eop=len_trim(words(ii)) longnam=max(longnam, eop) dataset%iped(i)=i dataset%imztwin(i)=MISS dataset%fa(i)=MISS dataset%mo(i)=MISS dataset%sex(i)=MISS if (plevel > 1) then write(outstr,'(a)') dataset%pedigree(i), dataset%num(i) end if end do j=0 ngeno=0 do call readline(port, lin(1:LINSIZ), ios=ioerr) if (ioerr /= 0) exit j=j+1 gcode=gencode(loctyp(j)) pos=locpos(j) pos2=pos+1 narg=nobs call args(lin, narg, words, ' ', SEP_WHITE) ii=11 do i=1, nobs ii=ii+1 if (words(ii) /= 'NN') then ngeno=ngeno+1 g1=aval(words(ii)(1:1), gcode) g2=aval(words(ii)(2:2), gcode) else g1=MISS g2=MISS end if call set_geno(i, pos, pos2, dataset, g1, g2) end do end do call close_port(port, ioerr) call system_clock(it2, count_rate=ticks) write(slin, '(f20.2)') float(it2-it1)/float(ticks) slin=adjustl(slin) write(outstr,'(a,i0,a,i0,a/9x,i0,a)') & 'Read in ', nped, ' pedigrees, ', nobs, ' individuals', & ngeno, ' nonmissing SNP genotypes (' // trim(slin) // ' s)' write(slin, '(f20.3)') dataset_uses(dataset) slin=adjustl(slin) write(outstr,'(a/)') 'Dataset occupies ' // trim(slin) // ' MB.' red=.true. end subroutine readhapmap ! ! Read genotyping file where one genotype per record (eg Sequenom, Illumina report) ! typ=1 id locus_name allele1 allele2 ... [quality score etc] ! typ=2 locus_name id allele1 allele2 ... [quality score etc] ! typ=3 locus_name id qual_score allele1 allele2 ! typ=4 Illumina CSV locus_name=4 id=2 qual_score=5 allele1=10 allele2=11 ! Format includes "[Header]" and "[Data]" sections ! gt thresh used if quality score available ! skipline defaults to 1 (skipping a header line) ! subroutine readgeno(typ, port, gt, thresh, skipline, hashtab, dataset, plevel) use locus_types use locus_data use iobuff use fileio use scanner use idstring_widths use idhash_class use ped_class use comp_ops implicit none integer, intent(in) :: typ ! i/o port for dataset type (ioport) :: port integer, intent(in) :: gt double precision, intent(in) :: thresh integer, intent(in) :: skipline ! Hash table for IDs type (hash_table) :: hashtab type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel integer, parameter :: MISS = -9999, WORDLEN=35 ! ID strings and data strings character (len=id_width) :: curid character (len=WORDLEN), dimension(20) :: words ! Count genotypes read per locus integer, dimension(nloci) :: ngeno ! index to matching record integer :: curidx ! field separator integer :: field_sep character :: field_sep_char integer :: g1, g2, gene, gen2, i, ios, keytyp, narg, nch, nchanges, & ndiscarded, nlines, pos, pos2 integer :: pos_id, pos_loc, pos_a1, pos_a2, pos_qs integer :: matched, unmatched logical :: noskipid, usegeno double precision :: qualstat_val character (len=1) :: a1, a2 ! functions integer :: aval double precision :: fval, isaff if (plevel > 0) then if (typ == 1) then write(outstr,'(a)') & 'Order of fields expected to be: id locus all1 all2...' else if (typ == 2) then write(outstr,'(a)') & 'Order of fields expected to be: locus id all1 all2...' else if (typ == 3) then write(outstr,'(a)') & 'Order of fields expected to be: locus id qscore all1 all2...' else if (typ == 4) then write(outstr,'(a/a/a)') & 'Expecting Genome Studio style CSV called genotypes.', & ' Will read "SNP Name" "Sample Name" "GC Score"', & ' "Allele1 - Forward" "Allele2 - Forward" from "[Data]" section' end if write(outstr,'(a,i0,a/)') 'Skipping first ', skipline, ' lines.' end if pos_id=1 pos_loc=2 pos_a1=3 pos_a2=4 pos_qs=5 field_sep=SEP_WH_SLASH_CAS field_sep_char=' ' usegeno=.true. if (typ > 1) then pos_id=2 pos_loc=1 end if if (typ == 3 .or. typ == 4) then pos_qs=3 pos_a1=4 pos_a2=5 if (typ == 4) then pos_id=2 pos_loc=4 pos_a1=10 pos_a2=11 pos_qs=5 field_sep=SEP_CHAR field_sep_char=',' end if call setup_stat('Mean Quality Score', typ=1) if (gt > 0) then write(outstr,'(a)', advance='no') 'Filtering genotypes on GC Score ' call defpro(gt, thresh, .false.) end if ngeno=0 do i=1, nloci if (isactive(loctyp(i)) .and. ismarker(loctyp(i))) then locstat(i)=0.0d0 end if end do ! Skip through header section call readline(port, lin, ios=ios) if (lin(1:8) == '[Header]') then do call readline(port, lin, ios=ios) if (plevel > 0) then write(outstr,'(2x,a)') lin(1:min(len_trim(lin),72)) end if if (ios /= 0) then write(outstr,'(a)') 'ERROR: EOF while reading header.' return end if if (lin(1:6) == '[Data]') exit end do write(outstr,*) else write(outstr,'(3a)') & 'NOTE: No header encountered in "', trim(lin(1:60)), '"' call rewind_port(port, ios) end if end if if (.not.lochash%current) then call make_lochash(nloci, loc, lochash) end if keytyp=HK_ID if (.not.hashtab%current .or. hashtab%keytyp /= keytyp) then call hashids(keytyp, dataset, hashtab, 80, plevel) end if curid=' ' curidx=1 matched=0 nchanges=0 ndiscarded=0 unmatched=0 noskipid=.true. ! Skip 1st line do i=1, skipline call readline(port, lin, ios=ios) if (ios /= 0) then write(outstr,'(a,i0,a)') 'ERROR: EOF at ', i, 'th record.' return end if end do nlines=0 do call readline(port, lin, ios=ios) if (ios /= 0) exit nlines=nlines+1 if (plevel >= 0 .and. mod(nlines, 1000000) == 0) then write(outstr,'(a,i0,1x,a)') 'Reading line ', nlines, lin(1:60) end if narg=20 call args(lin, narg, words, field_sep_char, field_sep) if (words(pos_id) /= curid) then curid=words(pos_id) call matchid(keytyp, ' ', trim(curid), dataset, hashtab, curidx, plevel) if (curidx == 0) then unmatched=unmatched+1 noskipid=.false. if (plevel > 0) then write(outstr, '(3a)') 'NOTE: Could not match "', trim(curid), '".' end if else if (plevel > 1) then write(outstr, '(3a)') 'Merging genotypes for "', trim(curid), '".' end if matched=matched+1 noskipid=.true. end if end if if (noskipid) then call find_hashtab(trim(words(pos_loc)(1:loc_width)), loc, lochash, pos) if (pos /= 0) then gene=locpos(pos) gen2=gene+1 if (narg == 3) then nch=len_trim(words(3)) a1=' ' a2=' ' if (nch == 1) then a1=words(3)(1:1) a2=a1 else if (nch == 2) then a1=words(3)(1:1) a2=words(3)(2:2) end if g1=aval(a1, 1) g2=aval(a2, 1) else g1=aval(words(pos_a1),1) g2=aval(words(pos_a2),1) if (typ == 3 .or. typ == 4) then qualstat_val=fval(words(pos_qs)) if (gt > 0) then usegeno=(int(isaff(qualstat_val, thresh, gt)) == 2) end if if (usegeno) then ngeno(pos)=ngeno(pos)+1 locstat(pos)=locstat(pos)+qualstat_val else ndiscarded=ndiscarded+1 end if end if end if if (usegeno) then call order(g1, g2) call set_geno(curidx, gene, gen2, dataset, g1, g2) nchanges=nchanges+1 end if else if (plevel > 2) then write(outstr, '(3a)') 'NOTE: Could not match locus "', trim(words(pos_loc)), '".' end if end if end do if (typ == 3 .or. typ == 4) then do i=1, nloci if (ngeno(i) > 0) then locstat(i)=locstat(i)/dble(ngeno(i)) end if end do end if write(outstr,'(/a,i0,a,i0,a)') & 'Updated ', nchanges, ' genotypes for ', matched,' individuals.' if (ndiscarded > 0) then write(outstr,'(a,i0,a)') & 'Discarded ', ndiscarded, ' poor quality genotypes.' end if if (unmatched /= 0) then write(outstr,'(a,i0,a)') 'Failed to match ', unmatched, ' IDs.' end if end subroutine readgeno ! ! Read in biallelic genotypic probabilities from a file, ! imputing the most likely genotype ! Need to have numeric variable in pedigree that matches ! column of genotypes ! Assumes that all SNPs have been declared already ! file formats ! typ=1: (Beagle) ! marker alleleA alleleB col.3 col.3 col.3 col.5 col.5 col.5 col.7 col.7 col.7 col ! rs885550 C T 0.9846 0.0154 0.0001 0.9846 0.0154 0.0001 0.9846 0.0154 0.0001 0.98 ! typ=2: ! -- rs885550 9887804 C T 0.97 0.03 0 0.97 0.03 0 0.97 0.03 0 0.97 0.03 0 0.97 ! subroutine readprobs(port, typ, mergekey, pedfil, longest, hashtab, dataset, plevel) use locus_types use locus_data use iobuff use fileio use scanner use locus_data use idhash_class use ped_class implicit none ! i/o port for genotype data type (ioport) :: port integer, intent(in) :: typ ! variable containing genotype column number matching current individual integer, intent(in) :: mergekey ! or file containing IDs for genotype file character (len=*) :: pedfil integer, intent(in) :: longest ! Hash table for IDs type (hash_table) :: hashtab type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel integer, parameter :: MISS = -9999, WORDLEN=35 type (ioport) :: pedport ! index to matching pedigree record integer, dimension(:), allocatable :: idx ! buffer for entire line of data character (len=longest) :: buffer character (len=80) :: bigword character (len=40) :: word character (len=40), dimension(2) :: idstring character (len=6) :: alleles ! nobs is number of individuals in probability file integer :: nobs integer :: a1, a2, eol, g1, g2, gene, gen2, i, ii, ios, first, j, keytyp, & n, narg, nerrors, nids, nlines, nmar, nmatched, nwords, pos, stat integer (kind=8) :: ngeno integer :: it1, it2, ticks double precision, dimension(3) :: prob ! functions integer :: aval, ival double precision :: fval, dataset_uses call system_clock(it1) ! count up number of individuals per line first=3 if (typ == 2) first=5 call filecols(port, buffer, 1, nwords, plevel-2) nobs=(nwords-first)/3 allocate(idx(nobs)) idx=0 ! read in the header nlines=0 buffer=' ' if (typ == 1) then call readline(port, buffer, ios=ios) nlines=nlines+1 end if ! ! Need to match original ordering to order of records in dataset ! nmatched=0 nerrors=0 if (plevel > 1) then write(outstr,'(/a)') 'Genotyping ID Matched' end if ! ! mergekey in current dataset as trait if (mergekey > 0) then do i=1, dataset%nobs if (dataset%plocus(i, mergekey) /= MISS) then pos=int(dataset%plocus(i, mergekey)) if (pos >= 1 .and. pos <= nobs) then nmatched=nmatched+1 idx(pos)=i else nerrors=nerrors+1 end if end if end do ! ! else match up IDs from a pedigree file ! else if (pedfil /= '') then call open_port(pedfil, pedport, 'r', ios) if (ios /= 0) then write(outstr,'(3a)') & 'ERROR: Could not open file containing IDs "', trim(pedfil),'".' return end if keytyp=-mergekey if (.not.hashtab%current .or. hashtab%keytyp /= keytyp) then call hashids(keytyp, dataset, hashtab, 80, plevel) end if ii=0 do call readline(pedport, lin, ios=ios) if (ios /= 0) exit ii=ii+1 narg=2 call args(lin, narg, idstring, ' ', SEP_WHITE) call matchid(keytyp, idstring(1), idstring(2), dataset, hashtab, pos, plevel) if (pos == 0) then nerrors=nerrors+1 if (plevel > 1) then write(outstr,'(a25,1x,a)') trim(idstring(1)) // '--' // trim(idstring(2)), 'n' end if else nmatched=nmatched+1 idx(ii)=pos if (plevel > 1) then write(outstr,'(a25,1x,a)') trim(idstring(1)) // '--' // trim(idstring(2)), 'y' end if end if end do call close_port(pedport, ios) ! match up IDs in header of probability file else eol=len_trim(buffer) keytyp=-mergekey if (.not.hashtab%current .or. hashtab%keytyp /= keytyp) then call hashids(keytyp, dataset, hashtab, 80, plevel) end if i=1 ii=0 n=0 ! skip "marker alleleA alleleB" call nextword(i, buffer, eol, opchar, n, bigword, stat, ' ', SEP_WHITE) call nextword(i, buffer, eol, opchar, n, bigword, stat, ' ', SEP_WHITE) call nextword(i, buffer, eol, opchar, n, bigword, stat, ' ', SEP_WHITE) ! read through expected triples of ID strings if (mergekey == -2) then write(outstr,'(a)') 'Merging on individual IDs.' do call nextword(i, buffer, eol, opchar, n, bigword, stat, ' ', SEP_WHITE) if (stat /= 0) exit ii=ii+1 call matchid(keytyp, ' ', trim(bigword), dataset, hashtab, pos, plevel-2) if (pos /= 0) then nmatched=nmatched+1 idx(ii)=pos if (plevel > 1) then write(outstr,'(a25,1x,a)') bigword, 'y' end if else if (plevel > 1) then write(outstr,'(a25,1x,a)') bigword, 'n' end if call nextword(i, buffer, eol, opchar, n, bigword, stat, ' ', SEP_WHITE) call nextword(i, buffer, eol, opchar, n, bigword, stat, ' ', SEP_WHITE) end do else if (mergekey == -1) then write(outstr,'(a)') 'Merging on combined pedigree+individual IDs (format ppp-iiii).' do call nextword(i, buffer, eol, opchar, n, bigword, stat, ' ', SEP_WHITE) if (stat /= 0) exit ii=ii+1 narg=2 call args(bigword, narg, idstring, '-', SEP_CHAR) if (narg == 2) then call matchid(keytyp, trim(idstring(1)), trim(idstring(2)), & dataset, hashtab, pos, plevel-2) if (pos /= 0) then nmatched=nmatched+1 idx(ii)=pos if (plevel > 1) then write(outstr,'(a25,1x,a)') bigword, 'y' end if else if (plevel > 1) then write(outstr,'(a25,1x,a)') bigword, 'n' end if else nerrors=nerrors+1 if (nerrors < 5) then write(outstr,'(/3a)') & 'ERROR: Could not parse header string "', trim(bigword), & '" into pedigree and individual IDs.' end if end if call nextword(i, buffer, eol, opchar, n, bigword, stat, ' ', SEP_WHITE) call nextword(i, buffer, eol, opchar, n, bigword, stat, ' ', SEP_WHITE) end do end if end if write(outstr,'(/a,i0/a,i0)') & 'Number of individuals genotyped = ', nobs, & 'Number matching current dataset = ', nmatched if (nerrors > 0) then write(outstr,'(/a,i0,a/)') & 'NOTE: There were ', nerrors, ' erroneous merge IDs or keys!' end if if (nmatched == 0) return ! ! read SNP data ! if (.not.lochash%current) then call make_lochash(nloci, loc, lochash) end if nmar=0 ngeno=0 lineloop: do call readline(port, buffer, ios=ios) if (ios /= 0) exit nlines=nlines+1 n=0 i=1 call nextword(i, buffer, longest, opchar, n, word, stat, ' ', SEP_WHITE) if (stat == -1) exit lineloop if (typ == 2) then call nextword(i, buffer, longest, opchar, n, word, stat, ' ', SEP_WHITE) if (stat == -1) exit lineloop end if call find_hashtab(trim(word(1:loc_width)), loc, lochash, pos) if (pos == 0) cycle nmar=nmar+1 gene=locpos(pos) gen2=gene+1 if (typ == 2) then call nextword(i, buffer, longest, opchar, n, word, stat, ' ', SEP_WHITE) if (stat == -1) exit lineloop end if call nextword(i, buffer, longest, opchar, n, word, stat, ' ', SEP_WHITE) if (stat == -1) exit lineloop a1=aval(word, 2) alleles=trim(word) call nextword(i, buffer, longest, opchar, n, word, stat, ' ', SEP_WHITE) if (stat == -1) exit lineloop a2=aval(word, 2) alleles=trim(alleles) // '/' // trim(word) if (plevel > 1) then write(outstr,'(5a)') & 'Reading genotype probabilities for ', trim(loc(pos)), & ' (', trim(alleles), ')' end if ! nobs sets of triples ii=0 do do j=1, 3 call nextword(i, buffer, longest, opchar, n, word, stat, ' ', SEP_WHITE) if (stat == -1) exit lineloop prob(j)=fval(word) end do ii=ii+1 ! write(*,*) 'writing data for individual ', idx(ii), dataset%id(idx(ii)) if (idx(ii) /= 0) then g1=0 g2=0 if (prob(1) > prob(2) .and. prob(1) > prob(3)) then g1=a1 g2=a1 ngeno=ngeno+1 else if (prob(2) > prob(1) .and. prob(2) > prob(3)) then g1=a1 g2=a2 ngeno=ngeno+1 else if (prob(3) > prob(1) .and. prob(3) > prob(2)) then g1=a2 g2=a2 ngeno=ngeno+1 end if call set_geno(idx(ii), gene, gen2, dataset, g1, g2) end if if (n == nwords) exit end do end do lineloop call system_clock(it2, count_rate=ticks) write(word, '(f20.2)') float(it2-it1)/float(ticks) word=adjustl(word) write(outstr,'(a,i0,a,i0,a/9x,i0,a)') & 'Read in ', nmatched, ' individuals genotyped at ', nmar, ' loci', & ngeno, ' nonmissing SNP genotypes (' // trim(word) // ' s)' write(word, '(f20.3)') dataset_uses(dataset) word=adjustl(word) write(outstr,'(a/)') 'Dataset occupies ' // trim(word) // ' MB.' end subroutine readprobs ! ! Merge in most likely genotype based on PLINK dosage file ! SNP A1 A2 00010 0001002 00028 0002801 ! rs2237028 T G 1 2 2 1 0 2 ! subroutine rdplinkdose(port, thresh, longest, hashtab, dataset, plevel) use locus_types use locus_data use iobuff use fileio use scanner use locus_data use idhash_class use ped_class implicit none ! i/o port for genotype data type (ioport) :: port ! threshold for calling genotype double precision, intent(in) :: thresh integer, intent(in) :: longest ! Hash table for IDs type (hash_table) :: hashtab type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel integer, parameter :: MISS = -9999, WORDLEN=35 ! index to matching pedigree record integer, dimension(:), allocatable :: idx ! buffer for entire line of data character (len=longest) :: buffer character (len=80) :: word character (len=40), dimension(2) :: idstring character (len=6) :: alleles integer :: a1, a2, eol, g1, g2, gene, gen2, i, ii, ios, first, j, keytyp, & n, narg, nlines, nmar, nmatched, nobs, nwords, pos, stat integer (kind=8) :: ngeno, nerrors integer :: it1, it2, ticks double precision :: nocallrate, prob double precision :: crit1, crit21, crit22, crit3 ! functions integer :: aval, ival double precision :: fval, dataset_uses call system_clock(it1) crit1=2.0d0-thresh crit21=1.0d0-thresh crit22=1.0d0+thresh crit3=thresh call filecols(port, buffer, 1, nwords, plevel-2) nobs=(nwords-3)/2 nwords=nobs+3 ! read in the header nlines=0 buffer=' ' call readline(port, buffer, ios=ios) ! ! Need to match original ordering to order of records in dataset ! allocate(idx(nobs)) idx=0 nmatched=0 nerrors=0 ! match up IDs in header of probability file eol=len_trim(buffer) if (.not.hashtab%current) then call hashids(HK_PED_ID, dataset, hashtab, 80, plevel) end if if (plevel > 1) then write(outstr,'(/a)') 'Genotyping ID Matched' end if i=1 ii=0 n=0 ! skip "SNP A1 A2" call nextword(i, buffer, eol, opchar, n, word, stat, ' ', SEP_WHITE) call nextword(i, buffer, eol, opchar, n, word, stat, ' ', SEP_WHITE) call nextword(i, buffer, eol, opchar, n, word, stat, ' ', SEP_WHITE) ! PLINK dosage file gives white space separated pedigree and individual IDs do call nextword(i, buffer, eol, opchar, n, idstring(1), stat, ' ', SEP_WHITE) if (stat /= 0) exit call nextword(i, buffer, eol, opchar, n, idstring(2), stat, ' ', SEP_WHITE) if (stat /= 0) exit ii=ii+1 call matchid(HK_PED_ID, trim(idstring(1)), trim(idstring(2)), & dataset, hashtab, pos, plevel-2) if (pos /= 0) then nmatched=nmatched+1 idx(ii)=pos if (plevel > 1) then write(outstr,'(a35,1x,a)') & trim(idstring(1)) // '--' // trim(idstring(2)), 'y' end if else if (plevel > 1) then write(outstr,'(a35,1x,a)') & trim(idstring(1)) // '--' // trim(idstring(2)), 'n' end if end do write(outstr,'(/a,i0/a,i0)') & 'Number of individuals genotyped = ', nobs, & 'Number matching current dataset = ', nmatched if (nerrors > 0) then write(outstr,'(/a,i0,a/)') & 'NOTE: There were ', nerrors, ' erroneous merge IDs or keys!' end if if (nmatched == 0) return ! ! read SNP data ! if (.not.lochash%current) then call make_lochash(nloci, loc, lochash) end if nerrors=0 nmar=0 ngeno=0 lineloop: do call readline(port, buffer, ios=ios) if (ios /= 0) exit nlines=nlines+1 n=0 i=1 call nextword(i, buffer, longest, opchar, n, word, stat, ' ', SEP_WHITE) if (stat == -1) exit lineloop call find_hashtab(trim(word(1:loc_width)), loc, lochash, pos) if (pos == 0) cycle nmar=nmar+1 gene=locpos(pos) gen2=gene+1 call nextword(i, buffer, longest, opchar, n, word, stat, ' ', SEP_WHITE) if (stat == -1) exit lineloop a1=aval(word, 2) alleles=trim(word) call nextword(i, buffer, longest, opchar, n, word, stat, ' ', SEP_WHITE) if (stat == -1) exit lineloop a2=aval(word, 2) alleles=trim(alleles) // '/' // trim(word) if (plevel > 1) then write(outstr,'(5a)') & 'Reading genotype probabilities for ', trim(loc(pos)), & ' (', trim(alleles), ')' end if ii=0 if (isactdip(loctyp(pos))) then do call nextword(i, buffer, longest, opchar, n, word, stat, ' ', SEP_WHITE) if (stat == -1) exit lineloop ii=ii+1 if (idx(ii) /= 0) then g1=0 g2=0 prob=fval(word) if (prob > crit1) then ngeno=ngeno+1 g1=a1 g2=a1 call set_geno(idx(ii), gene, gen2, dataset, g1, g2) else if (prob > crit21 .and. prob < crit22) then ngeno=ngeno+1 g1=a1 g2=a2 call set_geno(idx(ii), gene, gen2, dataset, g1, g2) else if (prob < crit3) then ngeno=ngeno+1 g1=a2 g2=a2 call set_geno(idx(ii), gene, gen2, dataset, g1, g2) else nerrors=nerrors+1 end if end if if (n == nwords) exit end do else if (loctyp(pos) == LOC_QUA) then do call nextword(i, buffer, longest, opchar, n, word, stat, ' ', SEP_WHITE) if (stat == -1) exit lineloop ii=ii+1 if (idx(ii) /= 0) then dataset%plocus(idx(ii),gene)=fval(word) ngeno=ngeno+1 end if if (n == nwords) exit end do end if end do lineloop call system_clock(it2, count_rate=ticks) write(outstr,'(/a,i0,a)') 'Reading doses took ', (it2-it1)/ticks, ' seconds.' nocallrate=dble(nerrors)/dble(nerrors+ngeno) write(outstr, '(/a,f6.4,3(/a,f6.4,a,f6.4)/a,f6.4/)') & 'Genotype call threshold = ', thresh, & 'Interval called as 1/1 = ', crit1, ' -- ' , 2.0d0, & 'Interval called as 1/2 = ', crit21, ' -- ' , crit22, & 'Interval called as 2/2 = ', 0.0d0, ' -- ' , crit3, & 'Resulting call rate = ', 1.0d0-nocallrate write(word, '(f20.2)') 0.001*float(it2-it1) word=adjustl(word) write(outstr,'(a,i0,a,i0,a/9x,i0,a)') & 'Read in ', nmatched, ' individuals genotyped at ', nmar, ' loci', & ngeno, ' nonmissing SNP genotypes (' // trim(word) // ' s)' write(word, '(f20.3)') dataset_uses(dataset) word=adjustl(word) write(outstr,'(a/)') 'Dataset occupies ' // trim(word) // ' MB.' end subroutine rdplinkdose ! ! Read MaCH/minimac type allelic dosages ! pedigree file: ! 00359 0035902 0035903 0035904 2 -9 2.000 2.000 2.000 ! locus file: ! Z Zygosity ! T COUNT(T,18:28937192) ! T COUNT(G,18:28937474) ! subroutine readmach(locfil, pedfil, thresh, hashtab, dataset, plevel) use locus_types use locus_data use iobuff use fileio use scanner use locus_data use idhash_class use ped_class implicit none ! .dat and .ped character (len=*), intent(in) :: locfil character (len=*), intent(in) :: pedfil ! threshold for calling genotype double precision, intent(in) :: thresh ! Hash table for IDs type (hash_table) :: hashtab type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel ! integer, parameter :: MISS = -9999, WORDLEN=35 ! i/o port for genotype data type (ioport) :: port ! new locus counts integer, dimension(NDATACLASS) :: newloc character (len=80) :: word character (len=40), dimension(3) :: words character (len=1) :: ch integer :: firstcol, firstloc, longest, nmar integer :: eol, g1, g2, gene, gen2, i, ifail, ioerr, j, k, k2, & narg, nmatched, every integer (kind=8) :: ngeno integer :: it1, it2, ticks ! functions double precision :: dataset_uses call system_clock(it1) call open_port(locfil, port, 'r', ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Could not open .dat file "', trim(locfil),'".' return end if newloc=dataset%numloc call setupmer(port, plevel) firstloc=nloci firstcol=5 every=1000 do call readline(port, lin, ios=ioerr) if (ioerr /= 0) exit narg=2 call args(lin, narg, words, ' ', SEP_WHITE) ch=words(1)(1:) if (words(2)(1:6) == 'COUNT(') then narg=3 call args(lin, narg, words, ',', SEP_CHAR) nloci=nloci+1 ! minimac appends indel information after colon eg 18:29018380:T_TC k=index(words(3),':', back=.TRUE.) k2=index(words(3),':') if (k == k2 .and. k < 4) k=len_trim(words(3)) loc(nloci)=words(3)(1:(k-1)) loctyp(nloci)=LOC_CODOM+LOC_CMP locpos(nloci)=-(newloc(SCLASS)+1) newloc(SCLASS)=newloc(SCLASS) + 2 newloc(TCLASS)=newloc(TCLASS) + 2 outpos(nloci)=newloc(TCLASS) locnotes(nloci)=lin if (plevel > 0 .and. mod(nloci, every) == 1) then write(outstr, '(a,i0,2a)') & 'Declaring locus ', nloci, ': ', trim(loc(nloci)) every=3*every/2 end if else firstcol=firstcol+1 end if end do call close_port(port, ioerr) nmar=nloci-firstloc dataset%numloc=newloc ! Space for new genotype data if (plevel > 0) then write(outstr,'(a,i0,a,i0,a,i0,a)') 'Allocating storage for ', & nmar, ' markers * ', dataset%nobs, ' individuals = ', & int(nmar, kind=8)*int(dataset%nobs, kind=8) , ' genotypes.' end if call expand_sgeno(newloc(SCLASS), dataset, ifail) if (ifail /= 0) then write(outstr,'(3a)') 'ERROR: Could not allocate memory.' nloci=nloci-nmar return end if call open_port(pedfil, port, 'r', ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Could not open .ped file "', trim(pedfil),'".' return end if write(outstr, '(/2a/2a)') & 'MaCH locus file = ', trim(locfil), & 'MaCH pedigree file = ', trim(pedfil) call reclen(port, lin, longest, -1, .false.) call rdmachdose(port, thresh, firstcol, firstloc, longest, hashtab, & dataset, nmatched, ngeno, plevel) call close_port(port, ioerr) call system_clock(it2, count_rate=ticks) write(word, '(f20.2)') float(it2-it1)/float(ticks) word=adjustl(word) write(outstr,'(a,i0,a,i0,a/9x,i0,a)') & 'Read in ', nmatched, ' individuals genotyped at ', nmar, ' loci', & ngeno, ' nonmissing SNP genotypes (' // trim(word) // ' s)' write(word, '(f20.3)') dataset_uses(dataset) word=adjustl(word) write(outstr,'(a/)') 'Dataset occupies ' // trim(word) // ' MB.' end subroutine readmach ! ! Actually read MaCH/minimac dosage file ! subroutine rdmachdose(port, thresh, firstcol, firstloc, longest, hashtab, & dataset, nmatched, ngeno, plevel) use locus_types use locus_data use iobuff use fileio use scanner use locus_data use idhash_class use ped_class implicit none ! i/o port for genotype data type (ioport) :: port ! threshold for calling genotype double precision, intent(in) :: thresh integer, intent(in) :: firstcol integer, intent(in) :: firstloc integer, intent(in) :: longest ! Hash table for IDs type (hash_table) :: hashtab type (ped_data), intent(inout) :: dataset integer, intent(out) :: nmatched integer (kind=8), intent(out) :: ngeno integer, intent(in) :: plevel ! integer, parameter :: MISS = -9999, WORDLEN=35 ! buffer for entire line of data character (len=longest) :: buffer character (len=40), dimension(4) :: idstring character (len=40) :: word integer :: sx, zyg ! storage for doses real, dimension(:), allocatable :: doses integer :: dups, g1, g2, gene, gen2, i, ii, idx, ioerr, j, & n, narg, nlines, nmar, nobs, nwords, pos, stat, unmatched integer (kind=8) :: nerrors integer :: it1, it2, ticks double precision :: nocallrate, prob double precision :: crit1, crit21, crit22, crit3 ! functions integer :: aval, ival double precision :: fval, dataset_uses crit1=2.0d0-thresh crit21=1.0d0-thresh crit22=1.0d0+thresh crit3=thresh nmar=nloci-firstloc allocate(doses(nmar)) dups=0 nerrors=0 ngeno=0 nmatched=0 unmatched=0 if (.not.hashtab%current .or. hashtab%keytyp /= HK_PED_ID) then call hashids(HK_PED_ID, dataset, hashtab, 80, plevel) end if dataset%untyped=.true. nlines=0 call system_clock(it1) do call readline(port, buffer, ios=ioerr) if (ioerr /= 0) exit nlines=nlines+1 read(buffer,*) idstring(1:4), sx, zyg, doses call matchid(HK_PED_ID, idstring(1), idstring(2), dataset, & hashtab, idx, plevel-2) if (idx /= 0) then if (dataset%actset(dataset%iped(idx)) > 0) then if (.not.dataset%untyped(idx)) then dups=dups+1 if (plevel > 0) then write(outstr, '(4a)') & 'NOTE: Duplicate data for individual ', & trim(idstring(1)), '--', trim(idstring(2)) end if else nmatched=nmatched+1 end if dataset%untyped(idx)=.false. ii=firstloc do i=1, nmar ii=ii+1 gene=locpos(ii) gen2=gene+1 prob=doses(i) if (prob > crit1) then ngeno=ngeno+1 g1=1 g2=1 call set_geno(idx, gene, gen2, dataset, g1, g2) else if (prob > crit21 .and. prob < crit22) then ngeno=ngeno+1 g1=1 g2=2 call set_geno(idx, gene, gen2, dataset, g1, g2) else if (prob < crit3) then ngeno=ngeno+1 g1=2 g2=2 call set_geno(idx, gene, gen2, dataset, g1, g2) else nerrors=nerrors+1 end if end do if (plevel > 0 .or. (plevel == 0 .and. mod(nlines,100) == 1)) then write(outstr,'(a,i0,5a)') & 'Read in dosage data for ', nlines, 'th individual: ', & trim(idstring(1)), '--', trim(idstring(2)), '.' end if else if (plevel > 0) then write(outstr, '(5a)') 'NOTE: Pedigree of ', & trim(dataset%pedigree(dataset%iped(idx))), '--', & trim(dataset%id(idx)), ' is not currently active. Data not updated.' end if else unmatched=unmatched+1 if (plevel > 0 .or. unmatched < 6) then write(outstr, '(5a)') & 'NOTE: Could not match ', & trim(idstring(1)), '--', trim(idstring(2)), '.' end if end if end do call system_clock(it2, count_rate=ticks) write(outstr,'(/a,i0,a)') 'Reading doses took ', (it2-it1)/ticks, ' seconds.' nocallrate=dble(nerrors)/dble(nerrors+ngeno) write(outstr, '(/a,f6.4,3(/a,f6.4,a,f6.4)/a,f6.4/)') & 'Genotype call threshold = ', thresh, & 'Interval called as 1/1 = ', crit1, ' -- ' , 2.0d0, & 'Interval called as 1/2 = ', crit21, ' -- ' , crit22, & 'Interval called as 2/2 = ', 0.0d0, ' -- ' , crit3, & 'Resulting call rate = ', 1.0d0-nocallrate if (dups /= 0) then write(outstr,'(a,i0,a)') 'Multiple updates for ', dups, ' IDs.' end if if (unmatched /= 0) then write(outstr,'(a,i0,a)') 'Failed to match ', unmatched, ' IDs.' end if call cleanup_hash(hashtab) end subroutine rdmachdose ! ! Read in VCF dataset ! typ=1 read in pedigree data ! 2 read in pedigree data where VCF IDs of form ped_id ! 3 merge in genotype data on individual ID ! 4 merge in genotype data on VCF IDs of form ped_id ! 5 report matching IDs in VCF file ! 6 count matching VCF IDs of form ped_id ! 7 count matching individual IDs ! 8 fill in missing genotypes with reference allele homozygote ! 9 fill in missing genotypes with major allele homozygote ! ! addref replaces missing genotypes with reference allele homozygote ! qualstat is the genotype quality score to return in locstat ! subroutine readvcf(typ, addref, qualstat, gt, thresh, linlen, filnam, numloc, & hashtab, dataset, red, plevel) use iobuff use locus_types use locus_data use idstring_widths use locus_data use ped_class use comp_ops use fileio use scanner implicit none integer, intent(in) :: typ logical, intent(in) :: addref character (len=*), intent(in) :: qualstat integer, intent(in) :: gt double precision, intent(in) :: thresh integer, intent(in) :: linlen character (len=*), intent(in) :: filnam integer, dimension(NDATACLASS), intent(inout) :: numloc ! Hash table for IDs type (hash_table), intent(inout) :: hashtab type (ped_data), intent(inout) :: dataset logical, intent(inout) :: red integer, intent(in) :: plevel integer, parameter :: MISS = -9999, WORDLEN=35 ! file i/o port type (ioport) :: port integer :: ioerr, it1, it2, longest, nmatched, ticks integer (kind=8) :: ngeno character (len=WORDLEN) :: slin ! functions double precision :: dataset_uses call open_port(filnam, port, 'r', ioerr) if (ioerr /= 0) then write(outstr,'(3a)') & 'ERROR: Could not open VCF file "', trim(filnam),'".' return end if if (typ == 1) then write(outstr,'(/a)') 'Reading in pedigree data from VCF file:' else if (typ == 2) then write(outstr,'(/a)') 'Reading in pedigree data from VCF file where ID string of form "ped_id":' else if (typ == 3) then write(outstr,'(/a)') 'Merging in VCF genotype data:' else if (typ == 4) then write(outstr,'(/a)') 'Merging in VCF genotype data on ID string of form "ped_id":' else if (typ == 6) then write(outstr,'(/a)') 'Comparing VCF genotype data on ID string of form "ped_id":' else if (typ == 7) then write(outstr,'(/a)') 'Comparing VCF genotype data:' end if if (addref) then write(outstr,'(/a)') 'Missing genotypes in the VCF file are replaced by reference alleles.' end if if (qualstat /= ' ') then write(outstr,'(3a)') 'Genotype quality score = "', trim(qualstat), '"' if (gt > 0) then write(outstr,'(2a)', advance='no') & 'Genotype quality filter = ', trim(qualstat) call defpro(gt, thresh, .false.) end if end if write(outstr,'(/2a)') & 'VCF file = ', trim(filnam) call system_clock(it1) if (linlen > 100) then longest=linlen else call reclen(port, lin, longest, 100, .true.) end if if (plevel > 1) then if (linlen > 100) then write(outstr,'(a,i0)') & 'Specified record buffer length = ', linlen else write(outstr,'(a,i0)') & 'Record length (characters) = ', longest end if end if if (typ > 2) then call rdvcfgeno(typ-2, addref, qualstat, gt, thresh, longest+longest/5, port, & hashtab, dataset, nmatched, ngeno, plevel) else call rdvcfped(typ, longest, port, numloc, dataset, red, plevel) end if call close_port(port, ioerr) call system_clock(it2, count_rate=ticks) write(slin, '(f20.2)') float(it2-it1)/float(ticks) slin=adjustl(slin) if (typ == 3 .or. typ == 4) then write(outstr,'(a,i0,a/9x,i0,a)') & 'Read in ', nmatched, ' individuals', & ngeno, ' nonmissing SNP genotypes (' // trim(slin) // ' s)' else if (typ == 1 .or. typ == 2) then write(outstr,'(a,i0,a,i0,a)') & 'Read in ', dataset%nped, ' pedigrees, ', dataset%nobs, & ' individuals (' // trim(slin) // ' s).' end if if (typ < 5) then write(slin, '(f20.3)') dataset_uses(dataset) slin=adjustl(slin) write(outstr,'(a/)') 'Dataset occupies ' // trim(slin) // ' MB.' end if end subroutine readvcf ! ! read in IDs from VCF dataset ! subroutine rdvcfped(typ, longest, port, numloc, dataset, red, plevel) use iobuff use locus_types use locus_data use idstring_widths use locus_data use ped_class use vcftools use fileio use scanner implicit none integer, intent(in) :: typ integer, intent(in) :: longest ! file i/o port type (ioport) :: port integer, dimension(NDATACLASS), intent(inout) :: numloc type (ped_data), intent(inout) :: dataset logical, intent(inout) :: red integer, intent(in) :: plevel integer, parameter :: MISS = -9999, WORDLEN=35 ! ID strings and data strings integer :: narg character (len=WORDLEN) :: slin character (len=WORDLEN), dimension(:), allocatable :: words ! buffer for entire line of data character (len=longest) :: buffer ! and for split ID if of form ped_id character (len=WORDLEN), dimension(2) :: idstrings character (len=ped_width) :: pedigree integer :: biggest, first, i, ii, ioerr, j, ncol, stat integer :: nobs, nped, num call metavcf_vars(port, buffer, ' ', stat, plevel) if (stat /= 0) return call getword(trim(buffer), 9, slin) first=8 if (slin == 'FORMAT') first=first+1 ncol=countargs(trim(buffer), ' ', SEP_WHITE) nobs=ncol-first allocate(words(ncol)) narg=ncol call args(buffer, narg, words, ' ', SEP_WHITE) ! write(*,*) buffer(1:150) ! write(*,*) 'ncol=', ncol, ' narg=', narg, ' ', trim(words(first+1)), ' ', ! trim(words(first+2)), ' ... ', trim(words(narg)) nped=0 if (typ == 1) then nped=nobs biggest=1 else if (typ == 2) then j=0 biggest=0 pedigree=' ' do ii=first+1, ncol call args(words(ii), narg, idstrings, '_', SEP_CHAR) if (idstrings(1) /= pedigree) then nped=nped+1 biggest=max(j, biggest) j=0 pedigree=idstrings(1) end if j=j+1 end do end if if (plevel > 0) then write(outstr,'(a,i0,a,i0,a)') & 'Reading ', nped, ' pedigrees ', nobs, ' ids.' end if call setup_peds(nped, nobs, numloc, numloc, dataset, stat, plevel) if (stat /= 0) then write(outstr,'(a)') 'ERROR: readvcfped() could not allocate pedigree storage!' return end if dataset%maxsiz=biggest dataset%maxact=biggest dataset%num(0)=0 ii=first dataset%fa(1:nobs)=MISS dataset%mo(1:nobs)=MISS dataset%sex(1:nobs)=MISS dataset%imztwin(1:nobs)=MISS if (typ == 1) then do i=1, nobs ii=ii+1 dataset%pedigree(i)=words(ii) dataset%num(i)=i dataset%nfound(i)=1 dataset%actset(i)=1 dataset%id(i)=words(ii) dataset%iped(i)=i end do else narg=2 call args(words(first+SEP_WHITE), narg, idstrings, '_', SEP_CHAR) nped=0 num=0 pedigree=' ' do i=1, nobs ii=ii+1 call args(words(ii), narg, idstrings, '_', SEP_CHAR) if (idstrings(1) /= pedigree) then nped=nped+1 pedigree=idstrings(1) dataset%pedigree(nped)=idstrings(1) dataset%actset(nped)=1 num=0 end if num=num+1 dataset%num(nped)=i dataset%nfound(nped)=num dataset%id(i)=idstrings(2) dataset%iped(i)=nped end do end if red=.true. deallocate(words) if (plevel > 1) then write(outstr,'(/a/a)') & 'Pedigree ID', & '--------------------- ---------------' do i=1, dataset%nobs write(outstr, '(a,1x,a)') dataset%pedigree(dataset%iped(i)), dataset%id(i) end do end if end subroutine rdvcfped ! ! Read multiple VCF files with a view to merging them ! subroutine readmultvcf(typ, nfil, filnams, numloc, dataset, red, plevel) use iobuff use idstring_widths use ped_class use contingency_table use vcftools use fileio use scanner implicit none integer, intent(in) :: typ ! 1=id 2=ped_id integer, intent(in) :: nfil character (len=*), dimension(nfil), intent(in) :: filnams integer, dimension(NDATACLASS), intent(inout) :: numloc type (ped_data), intent(inout) :: dataset logical, intent(inout) :: red integer, intent(in) :: plevel integer, parameter :: MISS = -9999, WORDLEN=35 ! file i/o port type (ioport) :: port ! ID strings and data strings: ped, id, source type (table_cell) :: val(3) type (table_data) :: idtable ! table of ped, id type (table_data) :: indtable ! table of pedigrees type (table_data) :: pedtable integer, dimension(2) :: mar character (len=WORDLEN) :: prefix, slin character (len=WORDLEN), dimension(2) :: idstrings ! buffer for entire line of data character (len=2) :: buffer character (len=ped_width) :: pedigree integer :: biggest, first, i, ii, ioerr, j, lens, narg, ncol, pos, stat integer :: nobs, nped, nrep, num call setup_table(3, 500, idtable) call set_table_colname(1, 'Pedigree', idtable) call set_table_colname(2, 'Individual', idtable) call set_table_colname(3, 'Source', idtable) do j=1, nfil if (plevel > 0) then write(outstr,'(3a)') & 'Reading VCF file "', trim(filnams(j)),'".' end if call open_port(filnams(j), port, 'r', ioerr) if (ioerr /= 0) then write(outstr,'(3a)') & 'ERROR: Could not open VCF file "', trim(filnams(j)),'".' cycle end if do call readline(port, buffer, advance='no', ios=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') & 'ERROR: Premature end of VCF file "', trim(filnams(j)),'".' cycle end if if (buffer /= '##') exit call readline(port, buffer, ios=ioerr) end do do i=1, 9 call readtoken(port, slin, ioerr) if (ioerr /= 0) cycle end do first=8 if (slin == 'FORMAT') then first=first+1 call readtoken(port, slin, ioerr) end if nobs=0 if (typ == 1) then do nobs=nobs+1 call set_table_cell(val(1), string=trim(slin)) call set_table_cell(val(2), string=trim(slin)) call set_table_cell(val(3), ivalue=j, string=trim(filnams(j))) call insert_table_cells(3, val, idtable, 1) if (ioerr /= 0) exit call readtoken(port, slin, ioerr) end do else do nobs=nobs+1 narg=2 call args(slin, narg, idstrings, '_', SEP_CHAR) call set_table_cell(val(1), string=trim(idstrings(1))) call set_table_cell(val(2), string=trim(idstrings(2))) call set_table_cell(val(3), ivalue=j, string=trim(filnams(j))) call insert_table_cells(3, val, idtable, 1) if (ioerr /= 0) exit call readtoken(port, slin, ioerr) end do end if if (plevel > -1) then write(outstr,'(3a,i0,a)') & 'VCF file "', trim(filnams(j)),'": ', nobs, ' IDs.' end if call close_port(port, ioerr) end do call sort_table(idtable) call setup_table(2, idtable%ncells, indtable) mar(1)=1 mar(2)=2 call marginal_table(2, mar, idtable, indtable) nobs=indtable%ncells nrep=0 do i=1, nobs if (indtable%icount(i) > 1) then nrep=nrep+1 end if end do if (nrep > 0) then write(outstr,'(/a,i0,a/)') 'There are ', nrep, ' duplicate IDs.' end if if (plevel > 0) then call print_table(idtable) end if call setup_table(1, idtable%ncells, pedtable) mar(1)=1 call marginal_table(1, mar, idtable, pedtable) nped=pedtable%ncells biggest=0 do i=1, nped if (pedtable%icount(i) > biggest) then biggest=pedtable%icount(i) end if end do call setup_peds(nped, nobs, numloc, numloc, dataset, stat, plevel) dataset%maxsiz=biggest dataset%maxact=biggest dataset%num(0)=0 dataset%fa(1:nobs)=MISS dataset%mo(1:nobs)=MISS dataset%sex(1:nobs)=MISS dataset%imztwin(1:nobs)=MISS nped=0 num=0 pedigree=' ' do i=1, nobs pos = indtable%idx(i) call get_table_cell(indtable%categories(pos,1), string=idstrings(1)) call get_table_cell(indtable%categories(pos,2), string=idstrings(2)) if (idstrings(1) /= pedigree) then nped=nped+1 pedigree=idstrings(1) dataset%pedigree(nped)=idstrings(1) dataset%actset(nped)=1 num=0 end if num=num+1 dataset%num(nped)=i dataset%nfound(nped)=num dataset%id(i)=idstrings(2) dataset%iped(i)=nped end do red=.true. call clean_table(idtable) call clean_table(indtable) call clean_table(pedtable) end subroutine readmultvcf ! ! Actually read VCF file genotypes where corresponding pedigree ! is active (was all matchable IDs, changed 20161017) ! merge on id (typ=1) or ped_id (typ=2) ! count matching VCF IDs on id (typ=3) or ped_id (typ=4) ! count matching VCF genotypes on id (typ=5) or ped_id (typ=6) ! if addref, replace missing genotypes with reference allele homozygote ! also check strand etc ! subroutine rdvcfgeno(typ, addref, qualstat, gt, thresh, longest, port, & hashtab, dataset, nmatched, ngeno, plevel) use interrupt use iobuff use locus_types use locus_data use idstring_widths use locus_data use ped_class use alleles_class use nucleotides use sorts use fileio use scanner use tabixtools implicit none integer, intent(in) :: typ logical, intent(in) :: addref character (len=*), intent(in) :: qualstat integer, intent(in) :: gt double precision, intent(in) :: thresh type (ioport) :: port integer, intent(in) :: longest ! Hash table for IDs type (hash_table) :: hashtab type (ped_data), intent(inout) :: dataset integer, intent(out) :: nmatched integer (kind=8), intent(out) :: ngeno integer, intent(in) :: plevel integer, parameter :: MISS = -9999, WORDLEN=80, SNPLISTLEN=40 ! file i/o port ! ID strings and data strings integer :: narg integer, dimension(:), allocatable :: idx, vcfcol ! buffer for entire line of data character (len=longest) :: buffer character (len=WORDLEN) :: curloc, slin character (len=WORDLEN), dimension(:), allocatable :: words ! and for split ID if of form ped_id character (len=WORDLEN), dimension(2) :: idstrings ! allow matching by map position type (hash_table) :: maphash character (len=13), dimension(nloci) :: map_str character (len=13) :: pos_str logical :: hasname ! active markers - if indexed VCF integer :: mpos, nmark_data, nact_data integer, dimension(nloci) :: mark logical :: has_tbi ! alleles for current locus ! and alleles in current dataset at this locus type (allele_data) :: allele_buffer, vcf_alleles character (len=3) :: sall integer :: astat, dupmatch, first, g1, g2, g3, g4, gcode, gene, gen2, i, ii, & ioerr, isep, j, longall, lpos, n, ncol, nlines, nmar, nwarn, pos, & pos2, totmar ! if comparing genotypes integer, dimension(:), allocatable :: discord, indcompare, ord character (len=SNPLISTLEN), dimension(:), allocatable :: discord_snps integer :: nagree, nbadalleles, ncompared, nfiltered, ninfovars, nrefs, & totagree ! quality score ! qualstat can be be either ! genotype wise, qualstat_location = 0, qualstat_pos = position in FORMAT list ! locus-wise, qualstat_location = 1, qualstat_pos = position in INFO list ! integer :: qualstat_location integer :: qualstat_pos double precision :: qualstat_val integer, dimension(2) :: qsnum(2) double precision, dimension(2) :: qsmean, qsvar integer :: nf, nobs, nped, num, pedoffset logical :: hasformat, hasgeno, readtoend, usegeno character (len=1) :: allsep character (len=2) :: gtcode character (len=3) :: dupind character (len=7) :: gtp, ogtp character (len=80) :: info character (len=WORDLEN) :: gformat real :: tim0, tim1 ! functions integer :: aval, ival, tobp double precision :: fval, isaff character (len=8) :: wrpercent interface subroutine ascend(n, ia) integer, intent(in) :: n integer, dimension(:), intent(inout) :: ia end subroutine ascend end interface call cpu_time(tim0) if (dataset%nobs == 0) return dupmatch=0 gcode=1 nbadalleles=0 nmatched=0 ngeno=0 nmar=0 nfiltered=0 ninfovars=0 nrefs=0 qualstat_location=0 qualstat_pos=0 hasformat=.false. dataset%untyped=.true. allocate(words(100)) ! header call readline(port, buffer, ios=ioerr) if (ioerr /= 0) then write(outstr,'(a)') 'ERROR: Could not read VCF file header!' return end if narg=4 call args(buffer, narg, words, ' ', SEP_WH_RES) if (words(1) /= '##fileformat') then write(outstr,'(a/8x,a)') & 'NOTE: Expected metainformation headed by "##fileformat=..." in:', & '"', buffer(1:60), '..."' words(3)='Nonstandard' end if write(outstr,'(3a/)') 'File format = "', trim(words(3)), '"' do call readline(port, buffer, ios=ioerr) if (ioerr /= 0) exit narg=100 call args(buffer, narg, words, ' ', SEP_WH_RES) if (words(1) == '#CHROM') exit if (words(1)(1:1) /= '#') exit if (words(1) == '##INFO') then ninfovars=ninfovars+1 if (qualstat /= ' ') then if (index(buffer, 'ID=' // trim(qualstat)) > 0) then qualstat_location=1 qualstat_pos=ninfovars if (plevel > 0) then write(outstr,'(3a)') & 'Requested variable "', trim(qualstat), '" is declared in INFO.' end if end if end if end if if (words(1) == '##FORMAT') then if (index(buffer, 'ID=GT') > 0) then hasformat=.true. end if if (plevel > 0 .or. typ < 3) then write(outstr,'(a)') buffer(1:72) end if else if (plevel > 1) then write(outstr,'(a)') buffer(1:72) end if end do if (words(9) /= 'FORMAT' .and. .not.hasformat) then write(outstr,'(/a/7x,a,a60,a)') & 'ERROR: Expected FORMAT metainformation and column (col 9)!', & '"', buffer, ' ..."' return end if ! ! now reading header with as many columns as genotyped individuals, plus 9 fixed columns ! match up IDs between VCF header and current pedigrees ! call cpu_time(tim1) ncol=countargs(trim(buffer), ' ', SEP_WHITE) first=10 nobs=ncol-first+1 deallocate(words) allocate(words(ncol)) narg=ncol call args(buffer, narg, words, ' ', SEP_WHITE) allocate(idx(nobs), vcfcol(nobs)) idx=0 vcfcol=0 if (typ == 1 .or. typ == 3 .or. typ == 5) then call hashids(HK_ID, dataset, hashtab, 80, plevel-2) else call hashids(HK_PED_ID, dataset, hashtab, 80, plevel-2) end if if (plevel > 0) then write(outstr,'(/a/a)') & 'ID Found', & '------------------------------ -----' end if if (typ == 1 .or. typ == 3 .or. typ == 5 .or. typ == 7) then do ii=first, ncol astat=3 call matchid(HK_ID, ' ', words(ii), dataset, hashtab, pos, plevel-2) if (pos /= 0) then if (dataset%actset(dataset%iped(pos)) > 0) then astat=1 nmatched=nmatched+1 idx(nmatched)=pos vcfcol(nmatched)=ii if (dataset%untyped(pos)) then dupind=' ' dataset%untyped(pos)=.false. else dupind='Dup' dupmatch=dupmatch+1 end if else astat=2 end if end if if (plevel > 0) then if (astat == 3) then write(outstr,'(a30,1x,a,1x,a1)') words(ii), 'N', '-' else if (plevel > 1) then if (astat == 1) then write(outstr,'(a30,1x,a,1x,i0,1x,a)') words(ii), 'Y', nmatched, dupind else write(outstr,'(a30,1x,a,1x,a1)') words(ii), 'I', '-' end if end if end if end do else do ii=first, ncol call args(words(ii), narg, idstrings, '_', SEP_CHAR) call matchid(HK_PED_ID, idstrings(1), idstrings(2), dataset, & hashtab, pos, plevel-2) if (pos /= 0) then nmatched=nmatched+1 idx(nmatched)=pos vcfcol(nmatched)=ii if (dataset%untyped(pos)) then dupind=' ' dataset%untyped(pos)=.false. else dupind='Dup' dupmatch=dupmatch+1 end if if (plevel > 1) then write(outstr,'(a30,1x,a,1x,i0,1x,a)') words(ii), 'Y', nmatched, dupind end if else if (plevel > 0) then write(outstr,'(5a,1x,a1)') 'ped="',trim(idstrings(1)), & '" id="',trim(idstrings(2)), '" N', '-' end if end do end if if (plevel > 0) write(outstr,*) write(outstr,'(a,i0/a,i0)') & 'Individuals genotyped in VCF file = ', nobs, & 'VCF IDs matching current dataset = ', nmatched if (dupmatch > 0) then write(outstr,'(a,i0,a)') & 'NOTE: There were ', dupmatch, ' matchable duplicate IDs in the VCF file.' end if write(outstr,'(a,f6.4)') & 'Proportion of dataset updatable = ', & dble(nmatched)/dble(max(1,dataset%nobs)) if (typ == 3 .or. typ == 4) then return end if if (nmatched == 0) then write(outstr,'(a)') 'ERROR: Expected at least one matching ID!' return end if ! ! can finish early if exhausted eligible loci ! nmark_data=0 nact_data=0 do i=1, nloci if (ismarker(loctyp(i))) then nmark_data=nmark_data+1 if (isactive(loctyp(i))) then nact_data=nact_data+1 mark(nact_data)=i end if end if end do if (.not.lochash%current) then call make_lochash(nloci, loc, lochash) end if call make_maphash(nloci, loctyp, group, map, map_str, maphash) nmar=0 nlines=0 totagree=0 totmar=0 nwarn=0 readtoend=.false. if (typ == 1 .or. typ == 2) then if (qualstat == ' ') then call setup_stat('Number of genotypes merged from VCF file', typ=2) else call setup_stat('Mean ' // trim(qualstat) // ' for genotypes merged from VCF file', typ=1) end if else if (qualstat == ' ') then call setup_stat('Number of concordant genotypes in VCF file', typ=2) else call setup_stat('Mean ' // trim(qualstat) // ' for genotypes concordant with VCF file', typ=1) end if allocate(discord(nmatched), indcompare(nmatched), ord(nmatched)) allocate(discord_snps(nmatched)) discord=0 discord_snps='' indcompare=0 end if ! call load_tbi(port%filnam, tbi_index, has_tbi) call setup_freq(128, vcf_alleles) if (plevel >= 0) then if (typ == 1 .or. typ == 2) then write(outstr,'(/a/a)') & 'Locus NAll Alleles Useable Annotation', & '-------------------- ---- -------- -------------- ------------' else write(outstr,'(/a/a)') & 'Locus NAll Alleles Concordant Prop Annotation', & '-------------------- ---- -------- -------------- ----- ------------' end if end if ! ! If not indexed, read each locus from VCF file in turn ! Try and match by locus name, then locus position ! Else skip to matching position ! mpos=0 do if (irupt > 0) exit if (nact_data == nmar .or. nmark_data == totmar) then if (.not.has_tbi) readtoend=.true. exit end if if (has_tbi) then mpos=mpos+1 if (mpos > nact_data) exit gene=mark(mpos) call moveto_tbi(tbi_index, group(gene), tobp(map(gene)), port, buffer, ioerr) if (plevel > 1) then write(outstr,'(3a,i0)') 'Seeking ', loc(gene), ' stat=', ioerr end if if ((ioerr == 1 .or. ioerr == -1) .and. mpos < nact_data) cycle else call readline(port, buffer, ios=ioerr) end if if (ioerr /= 0) exit nlines=nlines+1 narg=2 call args(buffer(1:1000), narg, words, ' ', SEP_WHITE) call getword(buffer, 3, curloc) if (words(1)(1:3) == 'chr') words(1)=words(1)(4:len_trim(words(1))) pos=0 hasname=.true. if (curloc == '.') then hasname=.false. curloc='chr' // trim(words(1)) // ':' // trim(words(2)) end if if (hasname) then call find_hashtab(trim(curloc(1:loc_width)), loc, lochash, pos) end if if (pos == 0) then pos_str=trim(words(1)) // ':' // adjustl(words(2)) call find_hashtab(trim(pos_str), map_str, maphash, pos) end if ! check if eligible if (pos > 0) then totmar=totmar+1 if (.not.isactive(loctyp(pos))) pos=0 end if ! rescan whole line if (pos > 0) then narg=ncol call args(buffer, narg, words, ' ', SEP_WHITE) if (locnotes(pos) == ' ') then locnotes(pos)=trim(words(8)) // ' ' // trim(words(4)) // ' ' // & trim(words(5)) end if ! update map if missing locus information if (hasname) then if (map(pos) == MISS) then map(pos)=1.0d-6*fval(words(2)) else if (group(pos) /= ' ' .and. fval(words(2)) > 0.0d0) then if (group(pos) /= words(1) .and. & tobp(map(pos)) /= ival(words(2))) then nwarn=nwarn+1 if (nwarn < 10 .or. plevel > 0) then write(outstr,'(5a,i0,4a)') & 'NOTE: Current map has "', trim(loc(pos)), '" at chr', & trim(group(pos)), ':', tobp(map(pos)), & ' but VCF file has ', trim(words(1)), ':', trim(words(2)) end if end if end if if (group(pos) == ' ') then group(pos)=words(1) end if end if ! check format for genotypes ! "first sub-field must always be the genotype (GT) if it is present." call getword(words(9), 1, slin, sep=':') if (slin == 'GT') then usegeno=.true. gformat=words(9) if (qualstat_location == 1) then call getword(buffer, 8, info) call getpairval(qualstat, info, opsimple, slin) qualstat_val=fval(trim(slin)) if (gt > 0) then usegeno=(int(isaff(qualstat_val, thresh, gt)) == 2) end if qsmean(1)=qualstat_val else if (qualstat /= ' ') then qualstat_pos=wordfind(qualstat, gformat, ':', SEP_CHAR) qsmean=0 end if qsnum=0 qsvar=0 nagree=0 ncompared=0 nmar=nmar+1 gene=locpos(pos) gen2=gene+1 ! read in alleles as specified by VCF file for this locus ! might be different alleles or order than Sib-pair's - a ! problem if a long allele has been coded as a number call load_vcf_refall(1, ' ', ' ', ' ', ' ', buffer, vcf_alleles) ! flip strand if necessary after comparing to current dataset call freq(gene, loctyp(pos), 0, dataset, allele_buffer) call refstrand(2, loc(pos), gene, dataset, allele_buffer, & vcf_alleles, astat, plevel-2) ! if inconsistent alleles, do not merge or compare if (astat == -1) then nbadalleles=nbadalleles+1 locstat(pos)=-1 if (plevel == 0) then write(outstr,'(a)', advance='no') & 'NOTE: Inconsistent alleles between current dataset (' do j=1, allele_buffer%numal call wrall(allele_buffer%allele_names(j), sall) write(outstr,'(a)', advance='no') trim(adjustl(sall)) end do write(outstr,'(a)', advance='no') & ') and VCF file (' do j=1, allele_buffer%numal call wrall(vcf_alleles%allele_names(j), sall) write(outstr,'(a)', advance='no') trim(adjustl(sall)) end do write(outstr,'(3a)') ') for "', trim(loc(pos)), '".' else if (plevel > 0) then info=trim(words(4)) // ' ' // trim(words(5)) write(outstr,'(a,i5,1x,a8,1x,a11,1x,a)') & loc(pos), vcf_alleles%numal, info, 'Incon_Alls', locnotes(pos) end if else ! merge if (typ == 1 .or. typ == 2) then do i=1, nmatched ii=vcfcol(i) call getword(words(ii), 1, slin, sep=':') if (.not.observed(idx(i), gene, dataset)) then if (slin(1:1) /= '.') then ! if qualstat_location == 1 then usegeno constant for this locus if (qualstat_location == 0) then usegeno=.true. if (qualstat_pos /= 0) then call getword(words(ii), qualstat_pos, info, sep=':') qualstat_val=fval(trim(info)) if (qualstat_val /= MISS) then if (gt > 0) then usegeno=(int(isaff(qualstat_val, thresh, gt)) == 2) end if if (usegeno) then qsnum(1)=qsnum(1)+1 call moment(qsnum(1), qualstat_val, qsmean(1), qsvar(1)) end if end if end if end if if (usegeno) then ncompared=ncompared+1 ngeno=ngeno+1 isep=scan(slin,'|/') if (isep == 0) then g1=ival(slin)+1 g2=g1 else g1=ival(slin(1:(isep-1)))+1 g2=ival(slin((isep+1):len_trim(slin)))+1 end if g1=vcf_alleles%allele_names(g1) g2=vcf_alleles%allele_names(g2) call order(g1, g2) call set_geno(idx(i), gene, gen2, dataset, g1, g2) else nfiltered=nfiltered+1 end if else if (addref) then nrefs=nrefs+1 ncompared=ncompared+1 ngeno=ngeno+1 g1=vcf_alleles%allele_names(vcf_alleles%topall) g2=g1 call set_geno(idx(i), gene, gen2, dataset, g1, g2) end if end if end do if (qualstat_pos == 0) then qsmean(1)=dble(ncompared)/dble(nmatched) locstat(pos)=dble(ncompared) else locstat(pos)=qsmean(1) end if ! compare else do i=1, nmatched ii=vcfcol(i) call getword(words(ii), 1, slin, sep=':') if (observed(idx(i), gene, dataset)) then qualstat_val=MISS hasgeno=(slin(1:1) /= '.') usegeno=hasgeno if (hasgeno) then if (qualstat_pos /= 0) then call getword(words(ii), qualstat_pos, info, sep=':') qualstat_val=fval(trim(info)) if (gt > 0) then usegeno=(int(isaff(qualstat_val, thresh, gt)) == 2) if (.not.usegeno) then nfiltered=nfiltered+1 end if end if end if else if (addref) then usegeno=.true. end if if (usegeno) then indcompare(i)=indcompare(i)+1 ncompared=ncompared+1 ngeno=ngeno+1 if (addref .and. .not.hasgeno) then nrefs=nrefs+1 g1=vcf_alleles%allele_names(vcf_alleles%topall) g2=g1 else isep=scan(slin,'|/') if (isep == 0) then g1=ival(slin)+1 g2=g1 else g1=ival(slin(1:(isep-1)))+1 g2=ival(slin((isep+1):len_trim(slin)))+1 end if g1=vcf_alleles%allele_names(g1) g2=vcf_alleles%allele_names(g2) call order(g1, g2) end if call get_geno(idx(i), gene, gen2, dataset, g3, g4) if (g1 == g3 .and. g2 == g4) then nagree=nagree+1 if (qualstat_val /= MISS) then qsnum(1)=qsnum(1)+1 call moment(qsnum(1), qualstat_val, qsmean(1), qsvar(1)) end if else discord(i)=discord(i)+1 if (len_trim(discord_snps(i)) < (SNPLISTLEN-5)) then discord_snps(i)=trim(discord_snps(i)) // ' ' // & trim(loc(pos)) end if if (qualstat_val /= MISS) then qsnum(2)=qsnum(2)+1 call moment(qsnum(2), qualstat_val, qsmean(2), qsvar(2)) end if if (plevel > 1) then call wrgtp(g1, g2, gtp, '/', '', 1) call wrgtp(g3, g4, ogtp, '/', '', 1) write(outstr,'(14a,1x,a)') & 'NOTE: Genotype at "', trim(loc(pos)),'" for ', & trim(dataset%pedigree(dataset%iped(idx(i)))), '--', & trim(dataset%id(idx(i))), ' VCF=', gtp, ' dataset=', ogtp, & ' ; ', trim(gformat), ' = ', trim(words(ii)), trim(locnotes(pos)) end if end if end if end if end do if (qualstat_pos == 0) then qsmean(1)=dble(nagree)/dble(max(1,ncompared)) end if locstat(pos)=qsmean(1) totagree=totagree+nagree end if if ((plevel >= 0 .and. nmar < 10) .or. plevel > 0) then info=trim(words(4)) // ' ' // trim(words(5)) write(outstr,'(a,i5,1x,a8)', advance='no') & loc(pos), vcf_alleles%numal, info if (typ == 1 .or. typ == 2) then write(outstr,'(1x,i13)', advance='no') ncompared if (qualstat_pos == 0) then write(outstr,'(1x,3a,f5.1,a)', advance='no') & ' (', trim(qualstat), ' mean=', qsmean(1), ') ' end if write(outstr,'(2x,a)') trim(locnotes(pos)) else write(info,'(i0,1x,a,1x,i0)') nagree, '/', ncompared write(outstr,'(1x,a13,1x,f6.4)', advance='no') & info, dble(nagree)/dble(max(1, ncompared)) if (qualstat_pos == 0) then write(outstr,'(3a,f5.1,a,f5.1,a)', advance='no') & ' (', trim(qualstat), ' mean con=', qsmean(1), ' dis=', qsmean(2),') ' end if write(outstr,'(a)') trim(locnotes(pos)) end if end if end if end if else if (plevel > 2) then info=trim(words(4)) // ' ' // trim(words(5)) write(outstr,'(a20,i5,1x,a8,1x,a)') curloc, vcf_alleles%numal, info, 'No_match' end if if (plevel == 0 .and. mod(nlines, 100000) == 0) then write(outstr,'(a,i0,3a,i0)') & 'Screening marker ', nlines, ' "', trim(curloc), '"; Matched ', nmar end if end do ! ! if completed matches early, count rest of lines in VCF file if (readtoend) then do if (irupt > 0) exit call readline(port, info, ios=ioerr) if (ioerr /= 0) exit nlines=nlines+1 end do end if write(outstr,'(/a,i0/a,i0,1x,a)') & 'Total number of loci scanned = ', nlines, & 'Number of matched loci = ', nmar, & trim(wrpercent(nmar, nlines)) if (nbadalleles > 0) then write(outstr,'(a,i0)') & 'Loci skipped as alleles differ = ', nbadalleles end if if (gt > 0) then write(outstr,'(a,i0,1x,a,f5.1,a)') & 'Number of genotypes failing QC = ', nfiltered, & '(', dble(100*nfiltered)/dble(max(1, nfiltered+ngeno)), '%)' end if if (addref) then write(outstr,'(a,i0)') & 'Number inferred wt/wt genotypes = ', nrefs end if if (typ == 5 .or. typ == 6) then write(outstr,'(a,i0,1x,a,f5.1,a)') & 'Number of concordant genotypes = ', totagree, & '(', dble(100*totagree)/dble(max(1, ngeno)), '%)' ! table of individuals by number of discordances call ascend(nmatched, ord) call isort(1, nmatched, discord, ord, 2) n=1 if (plevel < 1) n=max(nmatched-10, n) write(outstr,'(/a/a)') & 'Individual Discordant genotypes', & '------------------------- --------------------' do i=nmatched, n, -1 ii=ord(i) write(outstr,'(a,t28,i0,a,i0,1x,f6.4,1x,a)') & trim(dataset%pedigree(dataset%iped(idx(ii)))) // '--' // & trim(dataset%id(idx(ii))), discord(i), ' / ', indcompare(ii), & dble(discord(i))/dble(max(1,indcompare(ii))), & discord_snps(i) end do end if return end subroutine rdvcfgeno ! ! Replace missing genotypes with reference (ref or maj) allele in VCF file ! subroutine refvcfgeno(typ, vcf_ac, vcf_an, port, dataset, plevel) use interrupt use iobuff use vcftools use locus_types use locus_data use locus_list use idstring_widths use locus_data use ped_class use alleles_class use nucleotides use sorts use fileio use scanner implicit none integer, intent(in) :: typ character (len=*), intent(in) :: vcf_ac, vcf_an type (ioport) :: port type (ped_data) :: dataset integer, intent(in) :: plevel ! integer, parameter :: BUFLEN=2000, KNOWN=0, MISS = -9999, WORDLEN=80 ! buffer for entire line of data character (len=BUFLEN) :: buffer character (len=WORDLEN), dimension(:), allocatable :: words ! allow matching by map position type (hash_table) :: maphash character (len=13), dimension(nloci) :: map_str character (len=13) :: pos_str ! allele frequencies dataset and VCF file type (allele_data) :: allele_buffer, vcf_alleles character (len=WORDLEN) :: curloc, slin integer :: aref, badmatch, g1, g2, gcode, gene, gen2, i, ioerr, j, jj, & narg, nchange, nlines, nmar, ped, pos, refall, totaltloc, & totchange, totmark integer, dimension(50) :: allele_map character (len=1) :: alt, ref character (len=7) :: gtp ! functions integer :: aval allocate(words(100)) call setup_freq(50, vcf_alleles) call setup_freq(50, allele_buffer) totaltloc=0 totchange=0 ! header call readline(port, buffer, ios=ioerr) if (ioerr /= 0) then write(outstr,'(a)') 'ERROR: Could not read VCF file header!' return end if if (plevel > 0) then narg=4 call args(buffer, narg, words, ' ', SEP_WH_RES) if (words(1) /= '##fileformat') then write(outstr,'(a/8x,a)') & 'NOTE: Expected metainformation headed by "##fileformat=..." in:', & '"', buffer(1:60), '..."' words(3)='Nonstandard' end if write(outstr,'(3a)') 'VCF file name = "', trim(port%filnam), '"' write(outstr,'(3a/)') 'File format = "', trim(words(3)), '"' end if call metavcf_vars(port, buffer, trim(vcf_ac) // ',' // trim(vcf_an), ioerr, plevel) if (ioerr /= 0) then write(outstr,'(/5a)') & 'ERROR: Expected metainformation for "', & trim(vcf_ac), '" and "', trim(vcf_an), '".' return end if if (plevel > 0) then write(outstr,'(/a)') & 'Locus Changed New_Genotype' end if ! ! Read each locus from VCF file in turn ! if (.not.lochash%current) then call make_lochash(nloci, loc, lochash) end if call make_maphash(nloci, loctyp, group, map, map_str, maphash) call cntmark(nloci, loctyp, totmark, 3) badmatch=0 nlines=0 nmar=0 do call readline(port, buffer, ios=ioerr) if (ioerr /= 0) exit nlines=nlines+1 call getword(buffer, 3, curloc) if (curloc == '.') then call args(buffer, narg, words, ' ', SEP_WHITE) if (words(1)(1:3) == 'chr') words(1)=words(1)(4:len_trim(words(1))) curloc='chr' // trim(words(1)) // ':' // trim(words(2)) pos_str=trim(words(1)) // ':' // adjustl(words(2)) call find_hashtab(trim(pos_str), map_str, maphash, pos) else call find_hashtab(trim(curloc(1:loc_width)), loc, lochash, pos) end if ! if eligible if (.not.isactive(loctyp(pos))) pos=0 if (pos > 0) then nmar=nmar+1 gene=locpos(pos) gen2=gene+1 ! read in alleles as specified by VCF file for this locus call load_vcf_refall(2, vcf_ac, vcf_an, ' ', ' ', buffer, vcf_alleles) ! test if reference allele from VCF is compatible with current dataset - aref=-1 if (vcf_alleles%totall > 0) then allele_map=-1 call freq(gene, loctyp(pos), 0, dataset, allele_buffer) if (allele_buffer%totall > 0) then do j=1, allele_buffer%numal if (vcf_alleles%allele_names(vcf_alleles%topall) == & allele_buffer%allele_names(j)) then aref=j end if do jj=1, vcf_alleles%numal if (vcf_alleles%allele_names(jj) == & allele_buffer%allele_names(j)) then allele_map(j)=jj end if end do end do do j=1, allele_buffer%numal if (allele_map(j) < 0) aref=-1 end do else aref=1 end if end if if (plevel > 2) then write(outstr,'(/a)') 'Current dataset:' call wrfreq(outstr, loc(pos), group(pos), map(pos), & locnotes(pos), allele_buffer, 1) write(outstr,'(/a)') 'Reference population:' call wrfreq(outstr, curloc, group(pos), map(pos), & words(8), vcf_alleles, 1) end if ! if inconsistent alleles, skip comparison if (aref > 0) then gen2=gene+1 gcode=gencode(loctyp(pos)) nchange=0 refall=vcf_alleles%allele_names(1) if (typ == 2) refall=vcf_alleles%allele_names(vcf_alleles%topall) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (.not.observed(i, gene, dataset) .and. .not.dataset%untyped(i)) then nchange=nchange+1 g1=refall g2=refall call set_geno(i, gene, gen2, dataset, g1, g2) end if end do end if end do totchange=totchange+nchange if (nchange > 0) then totaltloc=totaltloc+1 end if if (plevel > 0) then call wrgtp(refall, refall, gtp, '/', '', 1) write(outstr,'(a,i8,1x,a)') loc(pos), nchange, gtp end if else badmatch=badmatch+1 if (plevel == 1) then write(outstr,'(a,i8,1x,a)') loc(pos), 0, 'Incompat' else if (plevel > 1) then write(outstr,'(/3a/a)', advance='no') & 'Incompatible alleles at "', trim(loc(pos)), '":', 'This dataset:' call wrfreq(outstr, loc(pos), group(pos), map(pos), & locnotes(pos), allele_buffer, 15) write(outstr,'(a)', advance='no') ' VCF file:' call wrfreq(outstr, curloc, group(pos), map(pos), & words(8), vcf_alleles, 15) end if end if end if if (nmar == totmark) exit if (irupt /= 0) exit end do if (plevel > -1) then write(outstr, '(a,i0,a,i0,a)') & 'Replaced ', totchange, ' missing genotypes at ', totaltloc, ' loci.' if (badmatch > 0) then write(outstr, '(a,i0,a)') 'Skipped ', badmatch, & ' loci where alleles discordant between VCF and dataset.' end if end if end subroutine refvcfgeno ! ! Read PLINK .bed format ! ! The .bim and .fam files are plain ASCII and allow us to fix the ! expected number of genotypes. In the .bed file, the first 3 bytes ! have a special meaning. The first two bytes are a 'magic number' ! that enables PLINK to confirm that a BED file is really a BED ! file: that is, BED files should always start 01101100 00011011. ! The third byte indicates whether the BED file is in SNP-major or ! individual-major mode: a value of 00000001 indicates SNP-major (i.e. ! list all individuals for first SNP, all individuals for second SNP, ! etc) whereas a value of 00000000 indicates individual-major (i.e. ! list all SNPs for the first individual, list all SNPs for the second ! individual, etc). By default, all BED files are SNP-major mode. ! ! For the genotype data, each byte encodes up to four genotypes (2 bits ! per genotype). The coding is ! ! 00 Homozygote 1/1 ! 01 Heterozygote 1/2 ! 11 Homozygote 2/2 ! 10 Missing x/x ! ! The only slightly confusing wrinkle is that each byte is effectively read ! backwards. That is, if we label each of the 8 position as A to H, we would ! label backwards: 01101100 ! HGFEDCBA ! | | | AB 00 -- homozygote (first) ! | | CD 11 -- other homozygote ! | EF 01 -- heterozygote ! GH 10 -- missing genotype (fourth) ! ! Finally, when we reach the end of a SNP (or if in individual-mode, the ! end an individual) we skip to the start of a new byte (i.e. skip any ! remaining bits in that byte). ! ! Data read in is either stored as normal genotypes (typ=1,2) or as 4-bits per ! genotype (typ=3). A join operation (appending any new loci) is carried out ! for typ=2 or typ=3, while a merge affecting only existing loci is typ=1 ! subroutine mergebed(strm, typ, chrcode, keytyp, keyloc, & filnam, hashtab, dataset, plevel) use locus_types use locus_data use iobuff use fileio use scanner use recast_data use idstring_widths use locstring_widths use locus_data use ped_class implicit none integer, intent(in) :: strm integer, intent(in) :: typ ! merge, join, join+compress integer, intent(in) :: chrcode ! toggles meaning of chr 23-26 integer, intent(in) :: keytyp ! merge on id or ped+id integer, intent(in) :: keyloc ! merge on locus name or locus map position character (len=*), intent(inout) :: filnam ! Hash table for IDs type (hash_table) :: hashtab type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel integer, parameter :: MISS = -9999, WORDLEN=35, SKIP=0 integer (kind=1), parameter :: zero = 0 ! i/o port for .bim type (ioport) :: port ! allow matching by map position type (hash_table) :: maphash character (len=13), dimension(:), allocatable :: map_str character (len=13) :: pos_str ! ID strings and data strings character (len=ped_width) :: pedigree character (len=WORDLEN), dimension(6) :: words character (len=WORDLEN) :: slin ! index to matching pedigree record integer, dimension(:), allocatable :: idx ! index to matching marker and list of corresponding addresses integer, dimension(:), allocatable :: locidx integer, dimension(:), allocatable :: bedidx ! SNP alleles from extended .bim file integer, dimension(:,:), allocatable :: snpalleles logical, dimension(:), allocatable :: snpswap ! new locus counts integer, dimension(NDATACLASS) :: newloc ! buffer for genotype data integer (kind=1), dimension(:), allocatable :: ibuff integer, dimension(NDATACLASS) :: numcol ! genotypes work array integer (kind=1), dimension(dataset%nobs) :: ig1, ig2 ! character (len=1) :: ch, ch2 character (len=chromosome_width) :: chrom character (len=256) :: prefix character (len=id_width) :: currfa, currmo integer :: cfa, cmo, curout, eon, g1, g2, gtp, i, ifail, ii, imin, imaj, & ios, j, k, kk, lpos, narg, nbytes, newloci, newsiz, nelig_ids, & nelig_markers, nmar, nmatched, pos, pos2, tenth integer :: iaddress, nf, nmapped, nobs, nped, num, pedoffset integer :: snpperword integer (kind=8) :: bedpos, ngeno logical :: filexist double precision :: propmatched ! last of previously declared loci (in locpos etc) integer :: lastold integer :: it1, it2, ticks ! functions integer :: aval, ival double precision :: fval, dataset_uses call system_clock(it1) ifail=0 prefix=filnam ! ! moved file checks to front 20141115 ! filnam=trim(prefix) // '.bed' inquire(file=trim(filnam), exist=filexist) if (.not.filexist) then write(outstr,'(3a)') 'ERROR: Could not open .bed file "', trim(filnam),'".' return end if filnam=trim(prefix) // '.fam' inquire(file=trim(filnam), exist=filexist) if (filexist) then call open_port(filnam, port, 'r', ios) if (ios /= 0) then write(outstr,'(3a/a)') & 'ERROR: Could not open .fam file "', trim(filnam),'".', & 'ERROR: Aborted reading .bed file!' return end if else filnam=trim(prefix) // '.fam.gz' inquire(file=trim(filnam), exist=filexist) if (filexist) then call open_port(filnam, port, 'r', ios) if (ios /= 0) then write(outstr,'(3a/a)') & 'ERROR: Could not open .fam file "', trim(filnam),'".', & 'ERROR: Aborted reading .bed file!' return end if else write(outstr,'(3a/a)') & 'ERROR: Could not open .fam file "', trim(prefix), '.fam".', & 'ERROR: Aborted reading .bed file!' return end if end if if (keytyp == HK_ID) then write(outstr,'(a)') 'NOTE: Merging individual records based in id only.' end if if (.not.hashtab%current .or. hashtab%keytyp /= keytyp) then call hashids(keytyp, dataset, hashtab, 80, plevel) end if ! ! Need to match original ordering to order of records in dataset ! nobs=0 do call readline(port, lin, ios=ios) if (ios /= 0) exit nobs=nobs+1 end do call rewind_port(port, ios) allocate(idx(nobs)) nobs=0 nelig_ids=0 dataset%untyped=.true. do call readline(port, lin, ios=ios) if (ios /= 0) exit narg=2 call args(lin, narg, words, ' ', SEP_WHITE) nobs=nobs+1 call matchid(keytyp, trim(words(1)), trim(words(2)), & dataset, hashtab, idx(nobs), plevel) if (idx(nobs) == 0) then if (typ /= 1) then write(outstr,'(6a/a)') & 'ERROR: Cannot match ', trim(words(1)), '--', trim(words(2)), & ' from .fam file.', 'ERROR: Aborted reading .bed file!' return else if (plevel > 1) then write(outstr,'(6a)') & 'NOTE: Cannot match ', trim(words(1)), '--', trim(words(2)), & ' from .fam file.' end if else nelig_ids=nelig_ids + 1 dataset%untyped(idx(nobs))=.false. end if end do call close_port(port, ios) ! ! Now .bim file ! filnam=trim(prefix) // '.bim' inquire(file=trim(filnam), exist=filexist) if (filexist) then call open_port(filnam, port, 'r', ios) if (ios /= 0) then write(outstr,'(3a/a)') & 'ERROR: Could not open .bim file "', trim(filnam),'".', & 'ERROR: Aborted reading in .bed file!' return end if else filnam=trim(prefix) // '.bim.gz' inquire(file=trim(filnam), exist=filexist) if (filexist) then call open_port(filnam, port, 'r', ios) if (ios /= 0) then write(outstr,'(3a)') 'ERROR: Could not open .bim file "', trim(filnam),'".' return end if else write(outstr,'(3a)') 'ERROR: Could not find .bim file "', trim(filnam),'".' return end if end if call setup_plink(port, nmar, newsiz, typ) newloci=0 nmapped=0 nelig_markers=0 curout=0 lastold=nloci newloc=dataset%numloc if (nloci > 0) then curout=outpos(nloci) end if if (plevel > 1) then write(outstr,'(/a,i0,a)') 'NOTE: PLINK .bim file contains ', nmar, ' loci.' end if allocate(locidx(nmar)) call make_lochash(nloci, loc, lochash) if (keyloc == HK_MAPPOS) then write(outstr,'(a)') 'NOTE: Merging loci based on map position.' allocate(map_str(nloci)) call make_maphash(nloci, loctyp, group, map, map_str, maphash) end if if (typ == 1 .or. typ == 2) then snpstorage = SNP_ONE snpperword=1 allocate(snpalleles(nmar,2)) allocate(snpswap(nmar)) ii=newloc(SCLASS)-1 nmar=0 do call readline(port, lin, ios=ios) if (ios /= 0) exit if (lin == '' .or. lin == ' ') cycle nmar=nmar+1 if (plevel > 1) then write(outstr,'(a,i0)') 'Reading locus ', nmar end if narg=6 call args(lin, narg, words, ' ', SEP_WHITE) call chr_convert(chrcode, words(1), chrom) if (keyloc == HK_MAPPOS) then pos_str=trim(chrom) // ':' // adjustl(words(4)) call find_hashtab(trim(pos_str), map_str, maphash, iaddress) else call find_hashtab(trim(words(2)(1:loc_width)), loc, lochash, iaddress) end if if (iaddress == 0) then if (typ == 1) then locidx(nmar)=SKIP else ii=ii+2 newloci=newloci+1 nelig_markers=nelig_markers+1 nloci=nloci+1 loc(nloci)=words(2) call insert_lochash(trim(loc(nloci)), nloci, loc, lochash) loctyp(nloci)=LOC_CODOM+LOC_CMP if (chrom == 'X' .or. chrom == 'x') loctyp(nloci)=LOC_XLIN+LOC_CMP if (chrom == 'Y' .or. chrom == 'y') loctyp(nloci)=LOC_YHA+LOC_CMP if (chrom == 'MT' .or. chrom == 'mt') loctyp(nloci)=LOC_MIT+LOC_CMP locpos(nloci)=-ii locnotes(nloci)=trim(words(4)) // ' (chr ' // trim(words(1)) // ') ' // & trim(words(5)) // '/' // trim(words(6)) if (chrom == 'XY') chrom='X' group(nloci)=chrom map(nloci)=1.0d-6*fval(words(4)) if (map(nloci) /= 0.0d0) nmapped=nmapped+1 outpos(nloci)=curout+2*newloci locidx(nmar)=nloci end if else nelig_markers=nelig_markers+1 locidx(nmar)=iaddress if (map(iaddress) == 0.0d0) map(iaddress)=1.0d-6*fval(words(4)) if (group(iaddress) == ' ') then group(iaddress)=chrom end if if (locnotes(iaddress) == ' ') then locnotes(iaddress)=trim(words(4)) // ' (chr ' // trim(chrom) // & ') ' // trim(words(5)) // '/' // trim(words(6)) end if end if if (len_trim(words(5)) == 1 .and. len_trim(words(6)) == 1) then snpalleles(nmar,1)=aval(words(5),1) snpalleles(nmar,2)=aval(words(6),1) snpswap(nmar)=(snpalleles(nmar,1) > snpalleles(nmar,2)) else snpalleles(nmar,1)=aval('A',1) snpalleles(nmar,2)=aval('B',1) snpswap(nmar)=.false. end if end do newloc(SCLASS)=newloc(SCLASS)+ii+1 newloc(TCLASS)=newloc(TCLASS)+ii+1 else if (typ == 3) then snpstorage = SNP_TWO snpperword=2 nmar=0 ii=newloc(SCLASS) do call readline(port, lin, ios=ios) if (ios /= 0) exit narg=6 nmar=nmar+1 call args(lin, narg, words, ' ', SEP_WHITE) call chr_convert(chrcode, words(1), chrom) if (keyloc == HK_MAPPOS) then pos_str=trim(chrom) // ':' // adjustl(words(4)) call find_hashtab(trim(pos_str), map_str, maphash, iaddress) else call find_hashtab(trim(words(2)(1:loc_width)), loc, lochash, iaddress) end if if (iaddress == 0) then newloci=newloci+1 nloci=nloci+1 ii=ii+1 loc(nloci)=words(2) call insert_lochash(trim(loc(nloci)), nloci, loc, lochash) loctyp(nloci)=LOC_CODOM+LOC_CMP if (chrom == 'X') then loctyp(nloci)=LOC_XLIN+LOC_CMP end if locpos(nloci)=-ii locnotes(nloci)=trim(words(4)) // ' (chr ' // trim(chrom) // ') ' // & trim(words(5)) // '/' // trim(words(6)) group(nloci)=chrom map(nloci)=1.0d-6*fval(words(4)) if (map(nloci) /= 0.0d0) nmapped=nmapped+1 outpos(nloci)=curout+2*newloci locidx(nmar)=nloci else locidx(nmar)=iaddress if (map(iaddress) == 0.0d0) map(iaddress)=1.0d-6*fval(words(4)) if (group(iaddress) == ' ') group(iaddress)=chrom if (locnotes(iaddress) == ' ') then locnotes(iaddress)=trim(words(4)) // ' (chr ' // trim(chrom) // & ') ' // trim(words(5)) // '/' // trim(words(6)) end if end if end do nelig_markers=nmar newloc(SCLASS)=newloc(SCLASS)+1+newloci/2 newloc(TCLASS)=newloc(TCLASS)+1+newloci/2 end if ! ! Originally read column 3 of .bim file, and backed up from column 4 - ! reversed this behaviour on 20140814 ! if (typ > 1 .and. nmapped == 0 .and. nmar > 0) then call rewind_port(port, ios) do i=nloci-nmar, nloci narg=4 call readline(port, lin, ios=ios) call args(lin, narg, words, ' ', SEP_WHITE) map(i)=fval(words(3)) end do end if call close_port(port, ios) filnam=trim(prefix) // '.fam' write(outstr,'(/a,a,2(/a,i0))') & 'Pedigree file = ', trim(filnam), & 'Total number of markers = ', nmar, & 'Number eligible markers = ', nelig_markers if (typ > 1) then write(outstr,'(a,i0)') & 'Number of new markers = ', newloci end if if (keyloc == HK_MAPPOS) then deallocate(map_str) end if if (nelig_markers == 0) return ! ! skip through bed (rather than as originally read through entire file) ! allocate(bedidx(nelig_markers)) k=0 do j=1, nmar if (locidx(j) /= SKIP) then k=k+1 bedidx(k)=j end if end do if (plevel > 0) then write(outstr,'(/a)', advance='no') 'Markers:' pos=9 do k=1, min(10, nelig_markers) j=bedidx(k) eon=len_trim(loc(locidx(j))) pos=pos+eon+1 call newlin(9,78,pos,eon+2) write(outstr,'(1x,a)', advance='no') trim(loc(locidx(j))) end do write(outstr,*) end if ! ! Space for new genotype data if (typ == 2) then call expand_sgeno(newloc(SCLASS)+3, dataset, ifail) else if (typ == 3) then call expand_sgeno(newloc(SCLASS), dataset, ifail) end if if (ifail /= 0) then write(outstr,'(3a)') 'ERROR: Could not allocate memory.' nloci=nloci-nmar return end if dataset%numloc=newloc propmatched=0.0d0 if (nobs > 0) then propmatched=dble(nelig_ids)/dble(nobs) end if write(outstr,'(a,i0,a,f5.3,a/a,i0/2a)') & 'Number of individuals = ', nelig_ids, ' (', propmatched, ')', & 'Number of genotypes = ', & int(nelig_ids, kind=8)*int(nelig_markers, kind=8), & 'Storage type = ', matrix_type(dataset%slocus) ! ! read SNP data ! filnam=trim(prefix) // '.bed' open(strm, file=filnam, access=stream_access, form=stream_form, iostat=ios) if (ios /= 0) then write(outstr,'(/3a)') 'ERROR: Could not open .bed file "', trim(filnam),'".' return end if ! .bed files start 01101100 00011011. read(strm, iostat=ios) ch, ch2 if (ios /= 0) then write(outstr,'(/3a)') 'ERROR: Could not read "', trim(filnam), '"!' close(strm) return else if (ichar(ch) == 73 .and. ichar(ch2) == 80) then write(outstr,'(/3a)') & 'ERROR: File "', trim(filnam), & '" is a MENDEL SNP binary file containing ordered genotypes.' close(strm) return else if (ichar(ch) /= 108 .or. ichar(ch2) /= 27) then write(outstr,'(/3a,2(1x,b0))') & 'ERROR: File "', trim(filnam), '" has wrong magic number: ', & ichar(ch), ichar(ch2) close(strm) return end if read(strm, iostat=ios) ch ! SNP-major mode, read nobs/4 byte chunks if (ichar(ch) == 1) then if (plevel > 0) then write(outstr,'(3a)') 'NOTE: File "', trim(filnam), '" is SNP-major mode.' end if ngeno=0 nmatched=0 tenth=max(1, nmar/10) nbytes=int(ceiling(0.25d0*dble(nobs))) allocate(ibuff(nbytes)) ! ordinary SNP storage if (typ == 1 .or. typ == 2) then bedloop: do k=1, nelig_markers j=bedidx(k) bedpos=int(j-1,kind=8)*int(nbytes,kind=8) + 4 read(strm, pos=bedpos, iostat=ios) ibuff if (ios /= 0) then write(outstr,'(3a)') 'ERROR: File "', trim(filnam), '" is truncated!' close(strm) return end if if (mod(k,tenth) == 0) then write(outstr,'(a,i0,a,i0)') & 'Reading data for marker ', k, ' of ', nelig_markers end if lpos=locidx(j) if (lpos /= SKIP) then nmatched=nmatched+1 i=1 kk=0 pos=locpos(lpos) pos2=pos+1 if (pos < 0) then call matrix_get_col(dataset%slocus, -pos, ig1, ios) call matrix_get_col(dataset%slocus, 1-pos, ig2, ios) ! ig1(:)=zero ! ig2(:)=zero do ii=1, nobs if (idx(ii) /= 0) then gtp=ibits(ibuff(i),kk,2) call fromplink(gtp, snpalleles(j,1), snpalleles(j,2), & snpswap(j), g1, g2, ngeno) call encode_geno1(g1, g2, ig1(idx(ii)), ig2(idx(ii))) end if kk=mod(kk+2,8) if (kk == 0) i=i+1 end do call matrix_set_col(ig1, -pos, dataset%slocus, ios) call matrix_set_col(ig2, 1-pos, dataset%slocus, ios) else do ii=1, nobs if (idx(ii) /= 0) then gtp=ibits(ibuff(i),kk,2) call fromplink(gtp, snpalleles(j,1), snpalleles(j,2), & snpswap(j), g1, g2, ngeno) call set_geno(idx(ii), pos, pos2, dataset, g1, g2) end if kk=mod(kk+2,8) if (kk == 0) i=i+1 end do end if if (nmatched == nelig_markers) exit bedloop end if end do bedloop ! compressed storage else if (typ == 3) then lpos=lastold bedloop_comp: do k=1, nelig_markers j=bedidx(k) bedpos=int(j-1,kind=8)*int(nbytes,kind=8) + 4 read(strm, pos=bedpos, iostat=ios) ibuff if (ios /= 0) then write(outstr,'(3a)') 'ERROR: File "', trim(filnam), '" is truncated!' close(strm) return end if if (mod(k, tenth) == 0) then write(outstr,'(a,i0,a,i0)') & 'Reading data for marker ', k, ' of ', nelig_markers end if lpos=locidx(j) i=1 kk=0 pos=locpos(lpos) imaj=(-pos-1)/2 + 1 imin=4*mod(-pos-1, 2) + 1 ! write(*,*) 'Marker ', j, ' imaj= ', imaj, ' imin=', imin call matrix_get_col(dataset%slocus, imaj, ig1, ios) ! write(*,*) 'Marker ', j, ': ig1[in] ', ig1(1:10) do ii=1, nobs gtp=ibits(ibuff(i),kk,2) call fromplink(gtp, 1, 2, .FALSE., g1, g2, ngeno) call encode_geno2(g1, g2, ig1(idx(ii)), imin) kk=mod(kk+2,8) if (kk == 0) i=i+1 end do ! write(*,*) 'Marker ', j, ': ig1[out] ', ig1(1:10) call matrix_set_col(ig1, imaj, dataset%slocus, ios) end do bedloop_comp end if ! individual-major mode, read nmar/4 byte chunks else if (ichar(ch) == 0) then write(outstr,'(3a/7x,a)') & 'ERROR: File "', trim(filnam), '" is individual-major mode.', & 'Individual-major mode not implemented!' else write(*,'(a,2(1x,z0))') 'ERROR: Unknown .bed file mode: ', ichar(ch) end if close(strm, status='keep') call system_clock(it2, count_rate=ticks) write(slin, '(f20.2)') float(it2-it1)/float(ticks) slin=adjustl(slin) write(outstr,'(/a,i0,a/9x,i0,a)') & 'Read in ', nelig_ids, ' individuals', & ngeno, ' nonmissing SNP genotypes (' // trim(slin) // ' s)' write(slin, '(f20.3)') dataset_uses(dataset) slin=adjustl(slin) write(outstr,'(a/)') 'Dataset occupies ' // trim(slin) // ' MB.' end subroutine mergebed ! ! Convert PLINK .bed genotype codes to alleles ! subroutine fromplink(pcode, a1, a2, snpswap, g1, g2, ngeno) integer, intent(in) :: pcode integer, intent(in) :: a1, a2 logical, intent(in) :: snpswap integer, intent(out) :: g1, g2 integer (kind=8), intent(inout) :: ngeno integer, parameter :: MISS=-9999 g1=MISS g2=MISS if (pcode == 0) then g1=a1 g2=a1 ngeno=ngeno+1 else if (pcode == 2) then if (snpswap) then g1=a2 g2=a1 else g1=a1 g2=a2 end if ngeno=ngeno+1 else if (pcode == 3) then g1=a2 g2=a2 ngeno=ngeno+1 end if end subroutine fromplink ! ! Read FImpute imputed genotypes ! ! The snp_info.txt file gives the SNP (FImpute does diallelic markers only) map ! The genotypes_imp.txt gives the genotypes ! ID Chip Calls... ! 0001001 2 3004440003233 ! ... ! First allele is paternal and the second is maternal. ! 0=1|1 1=1/2 2=2|2 3=1|2 4=2|1 ! 5=x/x 6=1|x 7=2|x 8=x|1 9=x|2 ! subroutine mergefim(typ, mapfil, genofil, chrcode, keytyp, hashtab, dataset, plevel) use interrupt use sorts use alleles_class use locus_types use locus_data use iobuff use fileio use scanner use recast_data use idstring_widths use locstring_widths use locus_data use ped_class implicit none integer, intent(in) :: typ ! merge, update, compare character (len=*), intent(in) :: mapfil character (len=*), intent(in) :: genofil integer, intent(in) :: chrcode integer, intent(in) :: keytyp ! merge on id or ped+id ! Hash table for IDs type (hash_table) :: hashtab type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel integer, parameter :: TYP_MERGE = 1, TYP_UPDATE = 2, TYP_COMPARE = 3 integer, parameter :: KNOWN = 0, MISS = -9999, WORDLEN=40, SKIP=0 ! i/o port for map and genotypes type (ioport) :: port ! ID strings and data strings character (len=WORDLEN), dimension(3) :: words character (len=WORDLEN) :: slin ! index to matching marker and list of corresponding addresses ! locidx(1:nelig_markers) is location in locus_data ! genoidx(1:nelig_markers) is column of FImpute genotype data ! use wloc to test if multiple matches ! integer, dimension(:), allocatable :: locidx integer, dimension(:), allocatable :: genoidx ! SNP alleles from our dataset to match with imputed "1" and "2" integer, dimension(:,:), allocatable :: snpalleles ! and alleles in current dataset at this locus type (allele_data) :: allele_buffer ! character (len=1) :: ch character (len=3) :: altall, refall character (len=7) :: gtp, ogtp character (len=chromosome_width) :: chrom integer :: eon, g1, g2, g3, g4, gene, i, idx, & ios, j, k, kk, lpos, n, narg, nchips, nelig_ids, & nelig_markers, ncol, nmar, unused, offset, pos integer :: iaddress, nobs, nped, num integer (kind=8) :: tot_discord, tot_agree, tot_updateable, ngeno ! if comparing genotypes integer, dimension(:), allocatable :: discord, indcompare, ord logical :: filexist integer :: it1, it2, ticks ! functions interface subroutine ascend(n, ia) integer, intent(in) :: n integer, dimension(:), intent(inout) :: ia end subroutine ascend end interface integer :: aval, ival character (len=8) :: wrpercentl double precision :: fval call system_clock(it1) if (typ == TYP_MERGE) then write(outstr,'(/a/)') 'Merging in FImpute genotype data:' else if (typ == TYP_UPDATE) then write(outstr,'(/a/)') 'Updating from FImpute genotype data:' else write(outstr,'(/a/)') 'Comparing current genotypes to FImpute data:' end if inquire(file=trim(genofil), exist=filexist) if (.not.filexist) then write(outstr,'(3a)') 'ERROR: Could not find FImpute genotype output file "', trim(genofil),'".' return end if if (keytyp == HK_ID) then write(outstr,'(a)') 'NOTE: Merging individual records based in id only.' end if if (.not.hashtab%current .or. hashtab%keytyp /= keytyp) then call hashids(keytyp, dataset, hashtab, 80, plevel) end if call open_port(mapfil, port, 'r', ios) if (ios /= 0) then write(outstr,'(3a)') & 'ERROR: Could not open FImpute SNP information file "', trim(mapfil),'".' return end if nelig_markers=0 allocate(locidx(nloci), genoidx(nloci)) wloc=0 call make_lochash(nloci, loc, lochash) ! ! Header ! call readline(port, lin, ios=ios) ncol=countargs(trim(lin), ' ', SEP_WHITE) nchips=ncol-3 if (plevel > 0) then write(outstr,'(/2a/)') 'Header: ', lin(1:70) end if ! ! Read SNP map ! nmar=0 do call readline(port, lin, ios=ios) if (ios /= 0) exit if (plevel > 2) then write(outstr,'(a)') lin(1:72) end if nmar=nmar+1 narg=3 call args(lin, narg, words, ' ', SEP_WHITE) call find_hashtab(trim(words(1)(1:loc_width)), loc, lochash, iaddress) if (iaddress /= 0) then if (isactive(loctyp(iaddress))) then wloc(iaddress)=wloc(iaddress)+1 if (wloc(iaddress) == 1) then nelig_markers=nelig_markers+1 locidx(nelig_markers)=iaddress genoidx(nelig_markers)=nmar if (map(iaddress) == 0.0d0) map(iaddress)=1.0d-6*fval(words(3)) if (group(iaddress) == ' ') then call chr_convert(chrcode, words(2), chrom) group(iaddress)=chrom end if else write(outstr,'(5a)') & 'NOTE: Locus ', trim(words(1)), & ' present more than once in "', trim(mapfil), '".' end if end if end if end do call close_port(port, ios) write(outstr,'(/a,a,3(/a,i0))') & 'FImpute SNP map file = ', trim(mapfil), & 'Number of arrays/sources = ', nchips, & 'Total number of markers = ', nmar, & 'Number matched = ', nelig_markers if (nelig_markers == 0) return ! ! Find correct reference alleles ! allocate(discord(nelig_markers), ord(nelig_markers)) discord=0 allocate(snpalleles(nelig_markers,2)) k=0 do k=1, nelig_markers j=locidx(k) call get_refalleles(locnotes(j), refall, altall) if (refall /= ' ') then snpalleles(k,1)=aval(refall, 1) snpalleles(k,2)=aval(altall, 1) else call freq(locpos(j), loctyp(j), 0, dataset, allele_buffer) snpalleles(k,1)=allele_buffer%allele_names(allele_buffer%topall) if (allele_buffer%numal > 1) then snpalleles(k,2)=allele_buffer%allele_names(allele_buffer%minall) else snpalleles(k,2)=snpalleles(k,1) end if end if end do if (plevel > 0) then write(outstr,'(/a)', advance='no') 'Markers:' pos=9 do k=1, min(10, nelig_markers) i=locidx(k) eon=len_trim(loc(i)) pos=pos+eon+1 call newlin(9,78,pos,eon+2) write(outstr,'(1x,a)', advance='no') trim(loc(i)) end do write(outstr,*) end if ! ! read SNP data ! call open_port(genofil, port, 'r', ios) if (ios /= 0) then write(outstr,'(3a)') & 'ERROR: Could not open FImpute SNP genotype file "', trim(genofil),'".' return end if write(outstr,'(2a)') & 'FImpute genotype file = ', trim(genofil) ! Header call readline(port, lin, ios=ios) if (plevel > 1) then write(outstr,'(/2a/)') 'Header: ', lin(1:70) end if ! start of genotypes in line nelig_ids=0 nobs=0 unused=0 offset=36 ngeno=0 tot_agree=0 tot_discord=0 tot_updateable=0 do call readline(port, lin, ios=ios) if (ios /= 0) exit nobs=nobs+1 call getword(lin, 1, slin) if (keytyp == HK_PED_ID) then narg=2 call args(slin, narg, words, '_', SEP_CHAR) call matchid(keytyp, words(1), words(2), dataset, hashtab, idx, plevel) else call matchid(keytyp, ' ', trim(slin), dataset, hashtab, idx, plevel) end if if (idx /= 0) then if (dataset%actset(dataset%iped(idx)) > 0) then nelig_ids = nelig_ids + 1 if (plevel > 1) then write(outstr,'(3a)') 'Reading individual ', trim(dataset%id(idx)) end if if (typ == TYP_UPDATE) then do k=1, nelig_markers i=locidx(k) j=genoidx(k) gene=locpos(i) pos=offset+j ch=lin(pos:pos) call fromfimp(ch, snpalleles(k,1), snpalleles(k,2), g1, g2) ngeno=ngeno+1 call set_geno(idx, gene, gene+1, dataset, g1, g2) end do else if (typ == TYP_MERGE) then do k=1, nelig_markers i=locidx(k) j=genoidx(k) gene=locpos(i) if (.not.observed(idx, gene, dataset)) then pos=offset+j ch=lin(pos:pos) call fromfimp(ch, snpalleles(k,1), snpalleles(k,2), g1, g2) ngeno=ngeno+1 call set_geno(idx, gene, gene+1, dataset, g1, g2) end if end do else do k=1, nelig_markers i=locidx(k) j=genoidx(k) gene=locpos(i) pos=offset+j ch=lin(pos:pos) call fromfimp(ch, snpalleles(k,1), snpalleles(k,2), g1, g2) call get_geno(idx, gene, gene+1, dataset, g3, g4) ngeno=ngeno+1 if (g1 == g3 .and. g2 == g4) then tot_agree=tot_agree+1 else if (g1 > KNOWN .and. g3 <= KNOWN) then tot_updateable=tot_updateable+1 else if (g1 > KNOWN .and. g3 > KNOWN) then tot_discord=tot_discord+1 discord(k)=discord(k)+1 if (plevel > 1) then call wrgtp(g1, g2, gtp, '/', '', 1) call wrgtp(g3, g4, ogtp, '/', '', 1) write(outstr,'(12a)') & 'NOTE: Genotype at "', trim(loc(i)),'" for ', & trim(dataset%pedigree(dataset%iped(idx))), '--', & trim(dataset%id(idx)), ' FImpute=', gtp, ' dataset=', ogtp, & ' ; ', trim(locnotes(i)) end if end if end do end if else unused=unused+1 if (plevel > 2) then write(outstr,'(3a)') 'Individual "', trim(dataset%id(idx)), & '" is present in the FImpute dataset but currently unselected.' end if end if end if if (irupt /= 0) exit end do call close_port(port, ios) call system_clock(it2, count_rate=ticks) write(slin, '(f20.2)') float(it2-it1)/float(ticks) slin=adjustl(slin) write(outstr,'(/a,i0,a/9x,i0,a)') & 'Read in ', nelig_ids, ' individuals', & ngeno, ' nonmissing SNP genotypes (' // trim(slin) // ' s)' if (typ == TYP_COMPARE) then write(outstr,'(3(/a,i0,1x,a))') & 'Number of concordant genotypes = ', tot_agree, & trim(wrpercentl(tot_agree,ngeno)), & 'Number of discordant genotypes = ', tot_discord, & trim(wrpercentl(tot_discord,ngeno)), & 'Number of updateable genotypes = ', tot_updateable, & trim(wrpercentl(tot_updateable,ngeno)) ! table of SNPs by number of discordances if (tot_discord > 0) then call ascend(nelig_markers, ord) call isort(1, nelig_markers, discord, ord, 2) n=1 if (plevel < 1) n=max(nelig_markers-10, n) write(outstr,'(/a/a)') & 'SNP Discordant genotypes', & '------------------- --------------------' do k=nelig_markers, n, -1 kk=ord(k) i=locidx(kk) write(outstr,'(a,i8,1x,a)') & loc(i), discord(k), locnotes(i) end do end if end if if (unused > 0) then write(outstr,'(a,i0,3a)') 'NOTE: There were ', unused, & ' matched but unused individuals in "', trim(genofil), '".' end if end subroutine mergefim ! ! Read FImpute output genotype ! subroutine fromfimp(geno, refall, altall, g1, g2) character (len=1), intent(in) :: geno integer, intent(in) :: altall, refall integer, intent(out) :: g1, g2 integer, parameter :: MISS=-9999 g1=MISS g2=MISS if (geno == '0') then g1=refall g2=g1 else if (geno == '1' .or. geno == '3' .or. geno == '4') then if (refall < altall) then g1=refall g2=altall else g1=altall g2=refall end if else if (geno == '2') then g1=altall g2=g1 end if end subroutine fromfimp ! ! Infer type of variables in a csv file ! header=(1,2)=(yes,no) + (0,4)=(geno+pheno,pheno-only) ! And declare them for later read operation ! subroutine readcsv(filnam, header, sepchar, numloc, nread, hasid, headerpos, plevel) use interrupt use outstream use fileio use string_utilities use scanner use storage_classes use locus_types use locus_list use locus_data character (len=*), intent(in) :: filnam integer, intent(in) :: header character (len=1), intent(in) :: sepchar ! Number of columns of data for each data class integer, dimension(NDATACLASS), intent(out) :: numloc integer, intent(out) :: hasid integer, intent(out) :: nread integer :: headerpos integer, intent(in) :: plevel character(len=1024) :: lin character(len=20), dimension(:), allocatable :: words, varnames character(len=1), dimension(:), allocatable :: vartyp character(len=20), dimension(:), allocatable :: firstval character(len=3) :: key, key2 type (ioport) :: port integer :: first, i, ioerr, newsiz, nlines, nfields, nvars, nwords, skipline logical :: nogeno, oldnam ! functions logical :: isreal skipline=headerpos hasid=0 headerpos=0 nread=0 call open_port(filnam, port, 'r', ioerr) if (ioerr /= 0) then write(outstr,'(3a)') & 'ERROR: Could not open file "', trim(filnam),'".' return else write(outstr,'(3a)') & 'Successfully opened file "', trim(filnam),'".' end if nwords=100 nvars=0 allocate(words(nwords), varnames(nwords), firstval(nwords), vartyp(nwords)) do i=1, nwords write(varnames(i), '(a,i0)') 'V', i vartyp(i)=' ' firstval(i)='x' end do nlines=0 do i=1, skipline call readline(port, lin, ios=ioerr) if (ioerr /= 0) exit nlines=nlines+1 end do if (mod(header,4) == 1) then do nfields=0 call readline(port, lin, ios=ioerr) if (ioerr /= 0) exit if (irupt > 0) exit nlines=nlines+1 if (lin(1:1) == '#') cycle nfields=countargs(lin, sepchar, SEP_CHAR) if (nfields > 0) exit end do if (nfields > 0) then nvars=nfields if (nfields > nwords) then nwords=nfields deallocate(varnames, vartyp, words) allocate(varnames(nvars), firstval(nvars), vartyp(nvars), words(nvars)) vartyp=' ' firstval='x' end if headerpos=nlines narg=nfields call args(lin, narg, varnames, sepchar, SEP_CHAR) call sanitize(narg, varnames) if (plevel > 1) then write(outstr,'(a,i0,a)') 'Header contains ', narg, ' varnames.' do i=1, narg write(outstr,'(i0,3a)') i, ' "', trim(varnames(i)), '"' end do end if else write(outstr,'(3a)') & 'ERROR: Could not find header line in "', trim(filnam),'".' call close_port(port, ioerr) return end if end if do call readline(port, lin, ios=ioerr) if (ioerr /= 0) exit if (irupt > 0) exit nlines=nlines+1 if (lin(1:1) == '#') cycle nfields=countargs(lin, sepchar, SEP_CHAR) if (nfields == 0) cycle if (nfields /= nvars) then if (header == 1) then write(outstr,'(3a,i0,a/7x,a,i0,a,i0,a/7x,3a)') & 'ERROR: header in "', trim(filnam),'" had ', nvars, ' variable names,', & 'but line ', nlines,' contains ', nfields, ' fields:', & '"', lin(1:min(65,len_trim(lin))), '"' else if (nfields > nvars) then nvars=nfields end if end if if (nfields > nwords .and. header > 1) then deallocate(varnames, vartyp, words) nwords=nfields allocate(varnames(nwords), vartyp(nwords), words(nwords)) do i=1, nwords write(varnames(i), '(a,i0)') 'V', i vartyp(i)=' ' end do end if narg=nfields call args(lin, narg, words, sepchar, SEP_CHAR) do i=1, narg if (words(i) == 'y' .or. words(i) == 'n') then if (vartyp(i) == ' ') then vartyp(i)='a' firstval(i)=words(i) else if (vartyp(i) == 'a') then continue else vartyp(i)='c' end if else if (header < 4 .and. scan(words(i),'/') > 1) then if (vartyp(i) == ' ') then vartyp(i)='m' firstval(i)=words(i) else if (vartyp(i) == 'm') then continue else vartyp(i)='c' end if else if (isreal(words(i))) then if (vartyp(i) == ' ') then vartyp(i)='q' firstval(i)=words(i) else if (vartyp(i) == 'q') then continue else vartyp(i)='c' end if else if (words(i) == ' ' .or. words(i) == 'NA') then continue else vartyp(i)='c' firstval(i)=words(i) end if end do end do call close_port(port, ioerr) do i=1, nwords if (vartyp(i)==' ') vartyp(i)='q' end do if (plevel > 1) then write(outstr,'(/a/a)') 'Column Typ Values', & '-------------------- --- -----------' do i=1, nvars write(outstr,'(a,2x,a,2x,a)') varnames(i), vartyp(i), firstval(i) end do write(outstr,'(/3a,i0)') & 'Closed file "', trim(filnam),'" with ioerr=', ioerr end if ! is first field ID? first=1 key=lcase(varnames(1)(1:3)) key2=lcase(varnames(2)(1:3)) if (key == 'id') then hasid=1 first=2 else if ((key == 'ped' .or. key == 'fam' .or. key == 'fid') .and. & (key2 == 'id' .or. key2 == 'iid' .or. key2=='ind') .and. & (lcase(varnames(3)(1:2)) == 'fa' .and. & lcase(varnames(4)(1:2)) == 'mo')) then hasid=2 first=5 if (lcase(varnames(5)(1:3)) == 'sex' .or. & lcase(varnames(5)) == 'gender') then first=first+1 end if end if ! declare loci call make_lochash(nloci, loc, lochash) newsiz=5*(1+nvars/5) call expand_loci(newsiz, 0) do i=first, nvars nread=nread+1 nloci=nloci+1 loc(nloci)=varnames(i) numloc(TCLASS)=numloc(TCLASS)+1 outpos(nloci)=numloc(TCLASS) if (vartyp(i) == 'm') then loctyp(nloci)=LOC_CODOM locpos(nloci)=numloc(GCLASS)+1 numloc(GCLASS)=numloc(GCLASS)+2 numloc(TCLASS)=numloc(TCLASS)+1 else if (vartyp(i) == 'a') then loctyp(nloci)=LOC_AFF locpos(nloci)=numloc(PCLASS)+1 numloc(PCLASS)=numloc(PCLASS)+1 else if (vartyp(i) == 'q') then loctyp(nloci)=LOC_QUA locpos(nloci)=numloc(PCLASS)+1 numloc(PCLASS)=numloc(PCLASS)+1 else loctyp(nloci)=LOC_CAT locpos(nloci)=numloc(PCLASS)+1 numloc(PCLASS)=numloc(PCLASS)+1 end if end do deallocate(words, varnames, firstval, vartyp) end subroutine readcsv ! ! Read file containing just unrelated individuals ! Duplicates (if contiguous) are combined into the same "family" ! with appended copy numbers ! Annotates locnotes with labels for categorical variable levels ! subroutine readcases(port, hasid, hassex, hasgeno, inputsep, skipline, numloc, coltyp, & locnotes, dataset, longnam, longest, nwarn, plevel) use iocodes use outstream use fileio use string_utilities use scanner use automatic_data use locus_types use ped_class use contingency_table use categorical_data type (ioport) :: port integer, intent(in) :: hasid logical, intent(in) :: hassex logical, intent(in) :: hasgeno character(len=1), intent(in) :: inputsep integer, intent(in) :: skipline integer, dimension(NDATACLASS), intent(in) :: numloc integer, dimension(:), intent(in) :: coltyp character (len=*), dimension(:), intent(inout) :: locnotes type (ped_data), intent(inout) :: dataset integer, intent(inout) :: longnam integer, intent(in) :: longest integer, intent(inout) :: nwarn integer, intent(in) :: plevel integer, parameter :: MISS = -9999, WORDLEN=35 type (ped_data) :: buffer integer :: nobs, nped, num integer :: astat, biggest, col, eop, first, gcode, gcol, higen, i, ioerr, j, & narg, nfields, ncol, nlines, pcol, scol, sxpos, typ, typ_readped integer (kind=1) :: i1 character(len=1) :: sepchar ! line buffer character(len=longest) :: lin ! ID strings and data strings character (len=ped_width) :: pedigree, thisped character (len=WORDLEN) :: slin character (len=WORDLEN), dimension(:), allocatable :: words integer :: it1, it2, ticks ! Categorical trait levels integer :: catval, ncatvars type (table_cell), dimension(1) :: values type (cat_data) :: categories ! functions integer :: aval logical :: ismiss double precision :: fval, dataset_uses call system_clock(it1) biggest=1 first=1 sepchar=' ' typ=SEP_WH_SLASH_CAS_NOID ! some people include slashes in their pedigree IDs typ_readped=SEP_WHITE if (hasid > 0) then first=first+1 typ=SEP_WH_SLASH_CAS end if if (hassex) first=first+1 if (inputsep /= ' ') then typ=SEP_CHAR_SLASH if (.not.hasgeno) typ=SEP_CHAR typ_readped=SEP_CHAR sepchar=inputsep end if sxpos=2 nwarn=0 nlines=0 nobs=0 num=0 longnam=1 nfields=first+numloc(TCLASS)-1 allocate(words(nfields)) nped=0 pedigree=' ' slin=' ' ! ! Handle categorical traits, allowing non-numeric values ! call setup_cats(categories) ! ! read through and count pedigrees ! call rewind_port(port, ioerr) do i=1, skipline call readline(port, slin, ios=ioerr) if (ioerr == eofcode) exit nlines=nlines+1 end do do call readline(port, slin, ios=ioerr) if (ioerr == eofcode) then biggest=max(biggest, num) nobs=nobs+num exit end if narg=1 call args(slin, narg, words, sepchar, typ_readped) if (narg == 0) then continue else if (words(1)(1:1) == '!' .or. words(1)(1:1) == '#') then continue else if (hasid > 0) then if (words(1) /= pedigree) then if (num > 1 .and. plevel > -1) then write(outstr,'(3a)') & 'NOTE: Contiguous duplicate records for ID "', trim(pedigree),'"' end if nobs=nobs+num biggest=max(biggest, num) pedigree=words(1) nped=nped+1 num=1 else num=num+1 end if else num=num+1 nped=nped+1 end if end do call rewind_port(port, ioerr) ! call system_clock(it2, count_rate=ticks) write(slin, '(f20.2)') float(it2-it1)/float(ticks) slin=adjustl(slin) write(outstr,'(a,i0,a,i0,a)') & 'Screened ', nped, ' IDs, ', nobs, ' records (' // trim(slin) // ' s).' call setup_peds(nped, nobs, numloc, numloc, dataset, astat, plevel) if (astat /= 0) then write(outstr,'(a)') 'ERROR: readcases() could not allocate pedigree storage!' return end if dataset%maxsiz=biggest dataset%maxact=biggest dataset%num(0)=0 ! ! Main read loop ! pedigree=' ' nlines=0 nobs=0 nped=0 num=0 do i=1, skipline call readline(port, slin, ios=ioerr) if (ioerr /= 0) exit nlines=nlines+1 end do do call readline(port, lin, ios=ioerr) if (ioerr /= 0) then dataset%pedigree(nped)=pedigree dataset%num(nped)=num+dataset%num(nped-1) dataset%nfound(nped)=num dataset%actset(nped)=1 exit end if narg=1 call args(lin, narg, words, sepchar, typ) if (words(1)(1:1) == '!' .or. words(1)(1:1) == '#') then nlines=nlines+1 if (plevel > 1) write(outstr,'(a)') lin(1:min(len_trim(lin),79)) else if (narg == 0) then nlines=nlines+1 continue else nlines=nlines+1 nobs=nobs+1 ncol=countargs(trim(lin), sepchar, typ) if (ncol /= nfields) then nwarn=nwarn+1 if (nwarn <= 25) then if (ncol < nfields) then write(outstr,'(/a,i0,a,i0,a/7x,a,i0,3a/)') & 'NOTE: Insufficient number of data fields (', & ncol, '; expected ', nfields,') in:', & 'Line ', nlines, ' "', lin(1:min(len_trim(lin),72)), '"' else write(outstr,'(/a,i0,a,i0,a/7x,a,i0,3a/)') & 'NOTE: Excessive number of data fields (', & ncol, '; expected ', nfields,') in:', & 'Line ', nlines, ' "', lin(1:min(len_trim(lin),72)), '"' end if end if end if narg=nfields call args(lin, narg, words, sepchar, typ) if (hasid > 0) then thisped=words(1) else write(thisped,'(i20)') nobs thisped=adjustl(thisped) end if if (thisped /= pedigree) then if (nped > 0) then dataset%pedigree(nped)=pedigree dataset%num(nped)=num+dataset%num(nped-1) dataset%nfound(nped)=num dataset%actset(nped)=1 end if nped=nped+1 num=0 pedigree=thisped eop=len_trim(pedigree) longnam=max(longnam, eop) end if num=num+1 if (num == 1) then dataset%id(nobs)=pedigree else write(slin,'(i20)') num dataset%id(nobs)=trim(pedigree) // '.' // trim(adjustl(slin)) end if dataset%iped(nobs)=nped dataset%imztwin(nobs)=MISS dataset%fa(nobs)=MISS dataset%mo(nobs)=MISS dataset%sex(nobs)=MISS if (hassex) then slin=words(sxpos) call tolower(slin) if (slin == 'f') then buffer%sex(num)=2 else if (slin == 'm') then buffer%sex(num)=1 else if (slin == '2' .or. slin == 'female') then buffer%sex(num)=2 else if (slin == '1' .or. slin == 'male') then buffer%sex(num)=1 end if end if ! all other variables col=0 gcol=0 ncatvars=0 pcol=0 scol=0 do j=first, nfields col=col+1 if (ismarker(coltyp(col))) then gcode=gencode(coltyp(col)) if (gcode > 1) then scol=scol+1 call matrix_set_el(int(aval(words(j), gcode), kind=1), nobs, scol, dataset%slocus, astat) call matrix_get_el(nobs, scol, dataset%slocus, i1, astat) else gcol=gcol+1 dataset%glocus(nobs,gcol)=aval(words(j), gcode) end if else if (iscattrait(coltyp(col))) then pcol=pcol+1 ncatvars=ncatvars+1 ! we do not want a missing data factor level if (ismiss(words(j)) .or. words(j) == ' ') then dataset%plocus(nobs,pcol)=MISS else call set_table_cell(values(1), string=trim(words(j))) call insert_table_cells(1, values, categories%cat_tables(ncatvars), & 1, slot=catval) dataset%plocus(nobs,pcol)=dble(catval) end if else pcol=pcol+1 dataset%plocus(nobs,pcol)=fval(words(j)) end if end do ! pad if short of data do j=gcol+1, numloc(GCLASS) dataset%glocus(nobs,j)=MISS end do do j=pcol+1, numloc(PCLASS) dataset%plocus(nobs,j)=MISS end do end if end do ! reorder category indicator values to match collation order of labels call relevel_cats(categories, dataset) call clean_cats(categories) call system_clock(it2, count_rate=ticks) write(slin, '(f20.2)') float(it2-it1)/float(ticks) slin=adjustl(slin) write(outstr,'(a,i0,a,i0,a)') & 'Read in ', nped, ' pedigrees, ', nobs, ' individuals (' // trim(slin) // ' s).' write(slin, '(f20.3)') dataset_uses(dataset) slin=adjustl(slin) write(outstr,'(a/)') 'Dataset occupies ' // trim(slin) // ' MB.' end subroutine readcases ! ! Read pedigree file ! subroutine readpeds(port, wrk, wrk2, inputsep, skipline, link, unspecified, & mztwin, gt, thresh, sexchek, hassex, nextped, & numloc, coltyp, dataset, longnam, longest, nwarn, plevel) use outstream use fileio use string_utilities use scanner use locus_types use ped_class use contingency_table use categorical_data type (ioport) :: port integer, intent(in) :: wrk, wrk2 character (len=1), intent(in) :: inputsep integer, intent(in) :: skipline ! link=0 ped or merlin, 1=linkage, 2=ppd, 3=unrelateds, 4=no pedigree field integer, intent(in) :: link character (len=*), intent(in) :: unspecified integer, intent(in) :: mztwin integer, intent(in) :: gt double precision, intent(in) :: thresh logical, intent(in) :: sexchek logical, intent(in) :: hassex logical :: nextped external :: nextped integer, dimension(NDATACLASS), intent(in) :: numloc integer, dimension(:), intent(in) :: coltyp type (ped_data), intent(inout) :: dataset integer, intent(inout) :: longnam integer, intent(in) :: longest integer, intent(inout) :: nwarn integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS = -9999 integer, parameter :: WORDLEN=40 type (ped_data) :: buffer integer :: nfam, nfound, nobs, nped, num integer :: astat, biggest, col, extra, eop, first, gcol, gcode, higen, i, ioerr, j, & maxsiz, narg, ncol, nerr, nfields, nid, & pcol, pedoffset, ped, scol, thistwin, typ_read, typ_readped integer :: pedidpos, indidpos, faidpos, moidpos, sxpos integer, dimension(NDATACLASS) :: numcol character (len=1) :: sepchar ! arrays for pedigree sorting and rearranging integer, dimension(:), allocatable :: indx, ord, key1, key2 integer (kind=1) :: i1 ! string to read line into character(len=longest) :: lin ! ID strings and data strings character (len=ped_width) :: pedigree character (len=id_width) :: cfa, cid, cmo character (len=WORDLEN) :: slin character (len=8) :: extraidfmt character (len=WORDLEN), dimension(:), allocatable :: words integer :: it1, it2, ticks ! Categorical trait levels integer :: catval, ncatvars type (table_cell), dimension(1) :: values type (cat_data) :: categories ! functions integer :: aval logical :: ismiss double precision :: fval, dataset_uses, isaff interface subroutine tabid(curid, nid, indx, id, counts, incr, idpos) use ped_class character (len=id_width), intent(in) :: curid integer, intent(inout) :: nid integer, intent(in) :: incr integer, intent(inout) :: indx(:) character (len=id_width), intent(inout) :: id(:) integer, intent(inout) :: counts(:) integer, intent(inout) :: idpos end subroutine tabid subroutine mkdummy(num, nfound, sx, numloc, buffer) use ped_class integer, intent(inout) :: num integer, intent(inout) :: nfound integer, intent(in) :: sx integer, dimension(NDATACLASS), intent(in) :: numloc type (ped_data), intent(inout) :: buffer end subroutine mkdummy subroutine processfam(sexchek, mztwin, gt, thresh, & wrk, wrk2, nped, pedigree, & num, nfound, numloc, nobs, & buffer, nid, higen, ord, key1, key2, plevel) use ped_class logical, intent(in) :: sexchek integer, intent(in) :: mztwin integer, intent(in) :: gt double precision, intent(in) :: thresh integer, intent(in) :: wrk, wrk2 integer, intent(inout) :: nped character (len=ped_width) :: pedigree integer, intent(inout) :: num integer, intent(inout) :: nfound integer, dimension(NDATACLASS), intent(in) :: numloc integer, intent(inout) :: nobs type (ped_data), intent(inout) :: buffer integer, intent(inout) :: nid integer, intent(inout) :: higen integer, dimension(:), intent(inout) :: key1, key2, ord integer, intent(in) :: plevel end subroutine processfam end interface call system_clock(it1) biggest=0 extra=0 nwarn=0 sepchar=' ' typ_read=SEP_WH_SLASH typ_readped=SEP_WH_SLASH_PED if (inputsep /= ' ') then typ_read=SEP_CHAR_SLASH typ_readped=SEP_CHAR sepchar=inputsep end if ! ! positions of pedigree data ! pedidpos=1 indidpos=2 faidpos=3 moidpos=4 sxpos=5 first=6 pedigree=' ' if (link == 2) then first=10 sxpos=8 else if (link == 4) then indidpos=1 faidpos=2 moidpos=3 sxpos=4 first=5 pedigree='ped' end if if (.not.hassex) first=first-1 nerr=0 nid=0 nobs=0 num=0 nfound=0 longnam=1 nfields=first+numloc(TCLASS)-1 allocate(words(nfields)) nfam=0 nped=0 slin=' ' ! ! Handle categorical traits, allowing non-numeric values ! call setup_cats(categories) ! ! read through and count pedigrees ! call rewind_port(port, ioerr) ! write(*,*) 'REWIND ioerr=', ioerr, 'stream=', port%fstream ! read(port%fstream,'(a)') slin ! write(*,*) '1>', slin, '<' ! read(port%fstream,'(a)') slin ! write(*,*) '2>', slin, '<' call rewind_port(port, ioerr) ! write(*,*) 'REWIND ioerr=', ioerr, 'stream=', port%fstream do i=1, skipline call readline(port, slin, ios=ioerr) ! write(*,*) 'SKIPLINE: ', trim(slin) if (ioerr /= 0) exit end do do call readline(port, slin, ios=ioerr) ! write(*,*) 'SLIN: ', ioerr, ' "', trim(slin), '"' narg=1 call args(slin, narg, words, sepchar, typ_readped) if (ioerr /= 0) then biggest=max(biggest, num) nobs=nobs+num exit else if (narg==0) then continue else if (words(1)(1:1) == '!' .or. words(1)(1:1) == '#') then continue else if (slin(1:8) == 'pedigree') then continue else if (nextped(words(pedidpos), pedigree)) then nobs=nobs+num biggest=max(biggest, num) pedigree=words(pedidpos) nped=nped+1 num=1 else num=num+1 end if end if end do call rewind_port(port, ioerr) ! ! maximum possible extras is two parents per observed person !? ! call system_clock(it2, count_rate=ticks) write(slin, '(f20.2)') float(it2-it1)/float(ticks) slin=adjustl(slin) write(outstr,'(a,i0,a,i0,a)') & 'Screened ', nped, ' pedigrees, ', nobs, ' records (' // trim(slin) // ' s).' maxsiz=3*biggest i=int(log10(dble(maxsiz)))+1 write(extraidfmt,'(a,i1,a,i1,a)') '(a,i',i,'.',i,')' call setup_peds(1, maxsiz, numloc, numloc, buffer, astat, plevel) if (astat /= 0) then write(outstr,'(a)') 'ERROR: readpeds() could not allocate pedigree buffer!' return end if allocate(indx(maxsiz), ord(maxsiz), key1(maxsiz), key2(maxsiz)) open(wrk, status='scratch', form='unformatted') open(wrk2, status='scratch', form='unformatted') ! ! Main read loop ! nobs=0 nped=0 nid=0 num=0 nfound=0 do i=1, skipline call readline(port, slin, ios=ioerr) if (ioerr /= 0) exit end do do call readline(port, lin, ios=ioerr) if (ioerr /= 0) then exit end if narg=nfields call args(lin, narg, words, sepchar, typ_read) if (words(1)(1:1) == '!' .or. words(1)(1:1) == '#') then if (plevel > 1) write(outstr,'(a)') lin(1:min(len_trim(lin),79)) else if (narg == 0) then continue else if (narg==1 .and. words(1) == 'end') then continue else ncol=countargs(trim(lin), sepchar, typ_read) if (ncol /= nfields) then nwarn=nwarn+1 if (nwarn <= 25) then if (ncol < nfields) then write(outstr,'(/a,i0,a,i0,3a/7x,a/)') & 'ERROR: Insufficient number of data fields (', & ncol, '; expected ', nfields,';sep="',sepchar,'") in:', & lin(1:min(len_trim(lin),72)) else write(outstr,'(/a,i0,a,i0,3a/7x,a/)') & 'NOTE: Excessive number of data fields (', & ncol, '; expected ', nfields,';sep="',sepchar,'") in:', & lin(1:min(len_trim(lin),72)) end if end if end if ! read just pedigree information allowing slashes in IDs added 20260510 narg=10 call args(lin, narg, words, sepchar, typ_readped) if (nextped(words(pedidpos), pedigree)) then if (num > 0) then call processfam(sexchek, mztwin, gt, thresh, wrk, wrk2, & nped, pedigree, num, nfound, numloc, nobs, & buffer, nid, higen, ord, key1, key2, plevel) end if extra=0 num=0 nfound=0 nid=0 pedigree=words(pedidpos) eop=len_trim(pedigree) longnam=max(longnam, eop) do i=1, maxsiz key2(i)=0 end do end if num=num+1 cid=words(indidpos) cfa=words(faidpos) cmo=words(moidpos) ! sex buffer%sex(num)=MISS if (hassex) then slin=words(sxpos) call tolower(slin) if (slin == 'f') then buffer%sex(num)=2 else if (slin == 'm') then buffer%sex(num)=1 else if (slin == '2' .or. slin == 'female') then buffer%sex(num)=2 else if (slin == '1' .or. slin == 'male') then buffer%sex(num)=1 end if end if ! all other variables - reread narg=nfields call args(lin, narg, words, sepchar, typ_read) col=0 gcol=0 ncatvars=0 pcol=0 scol=0 if (link == 1 .or. link == 2) then do j=first, nfields col=col+1 if (ismarker(coltyp(col))) then gcode=gencode(coltyp(col)) if (gcode > 1) then scol=scol+1 call matrix_set_el(int(aval(words(j), gcode), kind=1), & num, scol, buffer%slocus, astat) else gcol=gcol+1 buffer%glocus(num,gcol)=aval(words(j), gcode) end if else pcol=pcol+1 buffer%plocus(num,pcol)=fval(words(j)) if (fval(words(j)) == 0.0d0) buffer%plocus(num,col)=MISS end if end do else do j=first, nfields col=col+1 if (ismarker(coltyp(col))) then gcode=gencode(coltyp(col)) if (gcode > 1) then scol=scol+1 call matrix_set_el(int(aval(words(j), gcode), kind=1), & num, scol, buffer%slocus, astat) call matrix_get_el(num, scol, buffer%slocus, i1, astat) ! write(*,*) 'col=', col, ' coltyp=', coltyp(col), ' gcode=', gcode ! write(*,*) 'num=', num, 'scol=', scol, ' val=', i1 else gcol=gcol+1 buffer%glocus(num,gcol)=aval(words(j), gcode) end if ! Capture Merlin (or other) zygosity indicator ! 20181202 This is complicated by treatment of categorical variables else if (words(j) == 'MZ' .or. words(j) == 'mz') then pcol=pcol+1 if (iscattrait(coltyp(col))) ncatvars=ncatvars+1 buffer%plocus(num,pcol)=1.0d0 else if (words(j) == 'DZ' .or. words(j) == 'dz') then pcol=pcol+1 if (iscattrait(coltyp(col))) ncatvars=ncatvars+1 buffer%plocus(num,pcol)=0.0d0 else if (iscattrait(coltyp(col))) then pcol=pcol+1 ncatvars=ncatvars+1 if (ismiss(words(j)) .or. words(j) == ' ') then buffer%plocus(num,pcol)=MISS else call set_table_cell(values(1), string=trim(words(j))) call insert_table_cells(1, values, categories%cat_tables(ncatvars), & 1, slot=catval) buffer%plocus(num,pcol)=dble(catval) end if else pcol=pcol+1 call fval2(words(j), buffer%plocus(num,pcol), astat) if (astat /= 0) then write(outstr,'(2a/7x,a,i0,a,i0,a/)') & 'ERROR: Unable to read real number ',words(j), & 'at line ', num, ' col ', j, '.' end if end if end do end if ! pad if short of data do j=gcol+1, numloc(GCLASS) buffer%glocus(num,j)=MISS end do do j=pcol+1, numloc(PCLASS) buffer%plocus(num,j)=MISS end do ! Tabulate individual IDs, creating a pointer to the table of IDs, ! and a pointer to the position of the person call tabid(cid, nid, indx, buffer%id, key2, 1, key1(num)) ! write(*,*) 'Placed "', trim(cid), '" nid=', nid, ' pos=', key1(num) ! do kk=1, nid ! write(*,*) kk, buffer%id(kk), buffer%id(indx(kk)) ! end do ord(key1(num))=num if (cfa == '0' .or. cfa == 'X' .or. cfa == '-' .or. & cfa == '.' .or. cfa == 'NA' .or. cfa == '') cfa='x' if (cmo == '0' .or. cmo == 'X' .or. cmo == '-' .or. & cmo == '.' .or. cmo == 'NA' .or. cmo == '') cmo='x' ! ! MZ twins -- possible that a parent unspecified: check if already ! generated a new parental ID ! I imagine commonest case will be to represent multiple records for ! one individual ! if (mztwin > KNOWN) then if (int(isaff(buffer%plocus(num,mztwin),thresh,gt)) == 2) then thistwin=MISS do j=num-1, 1, -1 if (buffer%plocus(j,mztwin) == buffer%plocus(num,mztwin)) then thistwin=j exit end if end do if (thistwin /= MISS) then if (buffer%fa(thistwin) /= MISS .and. cfa == 'x') then cfa=buffer%id(buffer%fa(thistwin)) if (plevel >= 0) then write(outstr,'(6a/7x,5a)') & 'NOTE: Father of MZ twin ', trim(pedigree), '-', & trim(cid), ' unspecified. Set to ', trim(cfa), & ' to match putative cotwin ', & trim(pedigree), '-', trim(buffer%id(key1(thistwin))), '.' end if end if if (buffer%mo(thistwin) /= MISS .and. cmo == 'x') then cmo=buffer%id(buffer%mo(thistwin)) if (plevel >= 0) then write(outstr,'(6a/7x,5a)') & 'NOTE: Mother of MZ twin ', trim(pedigree), '-', & trim(cid), ' unspecified. Set to ', trim(cmo), & ' to match putative cotwin ', & trim(pedigree), '-', trim(buffer%id(key1(thistwin))), '.' end if end if end if end if end if ! ! Tabulate parental IDs ! adding extra records where a parental ID is not specified ! nonfounder if (cfa /= 'x' .and. cmo /= 'x') then call tabid(cfa, nid, indx, buffer%id, key2, 0, buffer%fa(num)) call tabid(cmo, nid, indx, buffer%id, key2, 0, buffer%mo(num)) ! founder else if (cfa == 'x' .and. cmo == 'x') then nfound=nfound+1 buffer%fa(num)=MISS buffer%mo(num)=MISS ! create new father else if (cfa == 'x') then call tabid(cmo, nid, indx, buffer%id, key2, 0, buffer%mo(num)) extra=extra+1 write(cfa,extraidfmt) trim(unspecified), extra call tabid(cfa, nid, indx, buffer%id, key2, 0, buffer%fa(num)) call mkdummy(num, nfound, MISS, numloc, buffer) ord(nid)=num key1(num)=nid key2(nid)=1 if (plevel >= 0) then write(outstr,'(/8a/)') 'NOTE: Father of individual ', & trim(pedigree),'-', trim(cid), ' not specified. Creating ', & trim(pedigree),'-', trim(cfa) end if ! create new mother else if (cmo == 'x') then call tabid(cfa, nid, indx, buffer%id, key2, 0, buffer%fa(num)) extra=extra+1 write(cmo,extraidfmt) trim(unspecified), extra call tabid(cmo, nid, indx, buffer%id, key2, 0, buffer%mo(num)) call mkdummy(num, nfound, MISS, numloc, buffer) ord(nid)=num key1(num)=nid key2(nid)=1 if (plevel >= 0) then write(outstr,'(/8a/)') 'NOTE: Mother of individual ', & trim(pedigree),'-', trim(cid), ' not specified. Creating ', & trim(pedigree),'-', trim(cmo) end if end if end if end do call processfam(sexchek, mztwin, gt, thresh, wrk, wrk2, & nped, pedigree, num, nfound, & numloc, nobs, buffer, nid, higen, ord, key1, key2, plevel) call cleanup_peds(buffer) deallocate(indx, ord, key1, key2) deallocate(words) numcol=numloc numcol(TCLASS)=numcol(TCLASS) + 6 numcol(GCLASS)=numcol(GCLASS) + 4 numcol(PCLASS)=numcol(PCLASS) + 2 call setup_peds(nped, nobs, numloc, numcol, dataset, astat, plevel) if (astat /= 0) then write(outstr,'(a)') 'ERROR: readpeds() could not allocate pedigree storage!' return end if rewind(wrk) dataset%num(0)=0 do ped=1, nped read(wrk) pedigree, num, nfound dataset%maxsiz=max(dataset%maxsiz, num) dataset%pedigree(ped)=pedigree dataset%num(ped)=num+dataset%num(ped-1) dataset%nfound(ped)=nfound dataset%actset(ped)=1 end do dataset%maxact=dataset%maxsiz close(wrk, status='delete') rewind(wrk2) do i=1, nobs dataset%imztwin(i)=MISS read(wrk2) dataset%id(i), dataset%fa(i), dataset%mo(i), dataset%sex(i), & dataset%glocus(i,1:numloc(GCLASS)), & dataset%plocus(i,1:numloc(PCLASS)) call matrix_read_row(wrk2, i, dataset%slocus) end do close(wrk2, status='delete') ! ! add pointer to pedigree information ! add appropriate offset to parental pointers, as ! are currently with respect to start of current pedigree ! pedoffset=0 do ped=1, nped do i=pedoffset+1, dataset%num(ped) dataset%iped(i)=ped end do do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped) dataset%fa(i)=dataset%fa(i)+pedoffset dataset%mo(i)=dataset%mo(i)+pedoffset end do pedoffset=dataset%num(ped) end do ! reorder category indicator values to match collation order of labels call relevel_cats(categories, dataset) call clean_cats(categories) call system_clock(it2, count_rate=ticks) write(slin, '(f20.2)') float(it2-it1)/float(ticks) slin=adjustl(slin) write(outstr,'(a,i0,a,i0,a)') & 'Read in ', nped, ' pedigrees, ', nobs, ' individuals (' // trim(slin) // ' s).' write(slin, '(f20.3)') dataset_uses(dataset) slin=adjustl(slin) write(outstr,'(a/)') 'Dataset occupies ' // trim(slin) // ' MB.' end subroutine readpeds ! ! Test if current line is next pedigree ! function nextped(str, pedigree) logical :: nextped character(len=*) :: str character(len=*) :: pedigree nextped=(str /= pedigree) end function nextped ! ! Does not use pedigree IDs ! function nonextped(str, pedigree) logical :: nonextped character(len=*) :: str character(len=*) :: pedigree nonextped=.false. end function nonextped ! ! All members of pedigree now read in, error check and sort ! subroutine processfam(sexchek, mztwin, gt, thresh, & wrk, wrk2, nped, pedigree, & num, nfound, numloc, nobs, & buffer, nid, higen, ord, key1, key2, plevel) use outstream use ped_class implicit none logical, intent(in) :: sexchek integer, intent(in) :: mztwin integer, intent(in) :: gt double precision, intent(in) :: thresh integer, intent(in) :: wrk, wrk2 integer, intent(inout) :: nped character (len=ped_width) :: pedigree integer, intent(inout) :: num integer, intent(inout) :: nfound integer, dimension(NDATACLASS), intent(in) :: numloc integer, intent(inout) :: nobs type (ped_data), intent(inout) :: buffer integer, intent(inout) :: nid integer, intent(inout) :: higen integer, dimension(:), intent(inout) :: key1, key2, ord integer, intent(in) :: plevel integer, parameter :: MISS=-9999 integer :: i, j, nfam, pos, sexfa, sexmo integer :: nerr character (len=id_width) :: cid interface subroutine mkdummy(num, nfound, sx, numloc, buffer) use ped_class integer, intent(inout) :: num integer, intent(inout) :: nfound integer, intent(in) :: sx integer, dimension(NDATACLASS), intent(in) :: numloc type (ped_data), intent(inout) :: buffer end subroutine mkdummy subroutine famsort(pedigree,num, nfound, nid, id, pid, fa, mo, & key1, ord, higen, nerr, plevel) use idstring_widths character (len=ped_width), intent(in out) :: pedigree integer, intent(in) :: num integer, intent(in) :: nfound integer, intent(in out) :: nid character (len=id_width), dimension(:), intent(inout) :: id integer, dimension(:), intent(inout) :: pid integer, dimension(:), intent(inout) :: fa integer, dimension(:), intent(inout) :: mo integer, dimension(:), intent(inout) :: key1 integer, dimension(:), intent(inout) :: ord integer, intent(inout) :: higen integer, intent(inout) :: nerr integer, intent(in) :: plevel end subroutine famsort subroutine addsexes(mztwin, gt, thresh, pedigree, num, buffer, & key1, ord, nerr, plevel) use ped_class use outstream integer, intent(in) :: mztwin integer, intent(in) :: gt double precision, intent(in) :: thresh character (len=ped_width), intent(in out) :: pedigree integer, intent(in) :: num type (ped_data), intent(inout) :: buffer integer, dimension(:), intent(inout) :: key1, ord integer, intent(inout) :: nerr integer, intent(in) :: plevel end subroutine addsexes end interface nerr=0 ! Errors by individual do i=1, nid if (key2(i) > 1) then write(outstr,'(/5a/)') 'ERROR: Duplicate record for individual ', & trim(pedigree),'-',trim(buffer%id(i)),'.' nerr=1 else if (key2(i) == 0) then if (plevel >= 0) then write(outstr,'(/5a/)') 'NOTE: Creating dummy record for ', & trim(pedigree), '-',trim(buffer%id(i)),'.' end if call mkdummy(num, nfound, MISS, numloc, buffer) ord(i)=num key1(num)=i else if ((buffer%fa(i) /= MISS .and. buffer%fa(i) == key1(i)) .or. & (buffer%mo(i) /= MISS .and. buffer%mo(i) == key1(i))) then write(outstr,'(/5a/)') 'ERROR: Individual ', & trim(pedigree), '-', trim(buffer%id(key1(i))),' is his own parent.' nerr=1 else if (buffer%fa(i) /= MISS .and. buffer%fa(i) == buffer%mo(i)) then write(outstr,'(/7a/)') 'ERROR: Individual ', & trim(pedigree), '-', trim(buffer%id(buffer%fa(i))), & ' is both father and mother of ', trim(buffer%id(i)),'.' nerr=1 end if end do ! Errors by mating if (nerr == 0 .and. sexchek) then call addsexes(mztwin, gt, thresh, pedigree, num, & buffer, key1, ord, nerr, plevel) end if if (nerr /= 0) then write(outstr,'(/3a)') & 'Too many errors. Dropping pedigree ', trim(pedigree), '.' return end if ! ! Sort the pedigree on generation number, id, and parental ID, ! returning the sorted position in ord ! ! first change the parental ID pointer from id table position ! to file position as required by connect() and gener() ! do i=1, num if (buffer%fa(i) /= MISS) then buffer%fa(i)=ord(buffer%fa(i)) buffer%mo(i)=ord(buffer%mo(i)) end if end do call famsort(pedigree, num, nfound, nid, buffer%id, key1, & buffer%fa, buffer%mo, key2, ord, & higen, nerr, plevel) ! Catch pedigree errors if (nerr /= 0) then write(outstr,'(3a/)') & 'FAMSORT: Too many errors. Dropping pedigree ', trim(pedigree), '.' return end if ! ! reorder the pedigree using external file ! do i=1, num key2(ord(i))=i end do nped=nped+1 nobs=nobs+num write(wrk) pedigree, num, nfound do i=1, num pos=ord(i) if (buffer%fa(pos) /= MISS) then write(wrk2) buffer%id(key1(pos)), & key2(buffer%fa(pos)), key2(buffer%mo(pos)), buffer%sex(pos), & buffer%glocus(pos,1:numloc(GCLASS)), & buffer%plocus(pos,1:numloc(PCLASS)) call matrix_write_row(pos, buffer%slocus, wrk2) else write(wrk2) buffer%id(key1(pos)), MISS, MISS, buffer%sex(pos), & buffer%glocus(pos,1:numloc(GCLASS)), & buffer%plocus(pos,1:numloc(PCLASS)) call matrix_write_row(pos, buffer%slocus, wrk2) end if end do end subroutine processfam ! ! Tabulate alphanumeric IDs in order of appearance ! subroutine tabid(curid, nid, indx, id, counts, incr, idpos) use ped_class character (len=id_width), intent(in) :: curid integer, intent(inout) :: nid integer, intent(in) :: incr integer, intent(inout) :: indx(:) character (len=id_width), intent(inout) :: id(:) integer, intent(inout) :: counts(:) integer, intent(inout) :: idpos integer :: hi, i, idx, lo hi=nid lo=1 idx=lo search: do while (hi >= lo) idx=lo+(hi-lo)/2 idpos=indx(idx) ! test if higher if (curid > id(idpos)) then lo=idx+1 cycle search end if ! test if lower if (curid < id(idpos)) then hi=idx-1 cycle search end if counts(idpos)=counts(idpos)+incr return end do search ! put new ID at end of list, and update the index of positions nid=nid+1 idpos=nid id(idpos)=curid counts(idpos)=incr do i=nid, lo+1, -1 indx(i)=indx(i-1) end do indx(lo)=nid end subroutine tabid ! ! Check consistency of sexes, allowing for MZ twins ! and mating cycles ! subroutine addsexes(mztwin, gt, thresh, pedigree, num, buffer, & key1, ord, nerr, plevel) use outstream use ped_class use rngs integer, intent(in) :: mztwin integer, intent(in) :: gt double precision, intent(in) :: thresh character (len=ped_width), intent(in out) :: pedigree integer, intent(in) :: num type (ped_data), intent(inout) :: buffer integer, dimension(:), intent(inout) :: key1, ord integer, intent(inout) :: nerr integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS=-9999 integer :: i, idx, it, j, newidx, nmiss, oldval, p1, p2, pos1, pos2, sxcode integer :: mzmiss, thistwin, thispos logical :: fin, showimp integer, dimension(num) :: grp, impsex character (len=1) :: sx character (len=3) :: cimp ! functions double precision :: isaff ! ! linked list of cotwins mzmiss=0 if (mztwin > KNOWN) then do i=1, num if (int(isaff(buffer%plocus(i,mztwin),thresh,gt)) == 2) then if (buffer%sex(i) == MISS) then mzmiss=mzmiss+1 end if end if end do if (mzmiss > 0) then buffer%imztwin(1:num)=0 do i=1, num if (int(isaff(buffer%plocus(i,mztwin),thresh,gt)) == 2) then if (buffer%imztwin(i) == 0) then thispos=i thistwin=buffer%plocus(i,mztwin) do j=i+1, num if (thistwin == buffer%plocus(j,mztwin)) then buffer%imztwin(j)=thispos thispos=j end if end do buffer%imztwin(i)=thispos newsex=buffer%sex(i) do while (thispos /= i .and. newsex == MISS) if (buffer%sex(thispos) /= MISS) then thistwin=thispos newsex=buffer%sex(thispos) end if thispos=buffer%imztwin(thispos) end do if (newsex /= MISS) then thispos=i do if (buffer%sex(thispos) == MISS) then buffer%sex(thispos)=newsex else if (buffer%sex(thispos) /= newsex) then nerr=1 call wrsex(buffer%sex(thispos), sx) write(outstr,'(7a)', advance='no') & 'ERROR: Inconsistent MZ twin sexes, ', & trim(pedigree), '-', & trim(buffer%id(key1(thispos))), ' (', sx, ')' call wrsex(buffer%sex(thistwin), sx) write(outstr,'(7a)') & ' and ', trim(pedigree), '-', & trim(buffer%id(key1(thistwin))), ' (', sx, ').' return end if thispos=buffer%imztwin(thispos) if (thispos == i) exit end do end if end if end if end do end if end if ! ! loop until resolve all missing sexes it=0 idx=0 grp=0 impsex(1:num)=buffer%sex(1:num) do newidx=0 do i=idx+1, num if (buffer%sex(i) == MISS) then newidx=i exit end if end do if (newidx == 0) exit idx=newidx grp(idx)=idx newsex=MISS pos1=0 pos2=0 do fin=.true. it=it+1 ! write(*,*) 'Idx=', idx, it do i=1, num if (buffer%fa(i) /= MISS .and. buffer%mo(i) /= MISS) then p1=ord(buffer%fa(i)) p2=ord(buffer%mo(i)) if (idx == p1) pos1=pos1+1 if (idx == p2) pos2=pos2+1 if (abs(grp(p1)) == idx .and. abs(grp(p2)) /= idx) then ! write(*,*) p1, '(', grp(p1),')', p2, '(', grp(p2),')' grp(p2) = -sign(idx, grp(p1)) if (buffer%sex(p2) /= MISS) then if (newsex == MISS) then if (grp(p2) > 0) then newsex=buffer%sex(p2) else newsex=3-buffer%sex(p2) end if else if ((grp(p2) > 0 .and. newsex /= buffer%sex(p2)) .or. & (grp(p2) < 0 .and. newsex == buffer%sex(p2))) then write(outstr,'(5a)') 'ERROR: Sex inconsistency due to ', & trim(pedigree), '-', trim(buffer%id(key1(p2))), ' !' nerr=1 end if end if fin=.false. else if (abs(grp(p1)) /= idx .and. abs(grp(p2)) == idx) then ! write(*,*) p1, '(', grp(p1),')', p2, '(', grp(p2),')' grp(p1) = -sign(idx,grp(p2)) if (buffer%sex(p1) /= MISS) then if (newsex == MISS) then if (grp(p1) > 0) then newsex=buffer%sex(p1) else newsex=3-buffer%sex(p1) end if else if ((grp(p1) > 0 .and. newsex /= buffer%sex(p1)) .or. & (grp(p1) < 0 .and. newsex == buffer%sex(p1))) then write(outstr,'(a)') 'ERROR: Inconsistent sexes!' write(outstr,'(5a)') 'ERROR: Sex inconsistency due to ', & trim(pedigree), '-', trim(buffer%id(key1(p1))), ' !' nerr=1 end if end if fin=.false. end if end if end do if (fin) exit end do if (mzmiss /= 0) then do i=1, num if (buffer%imztwin(i) /= 0) then if (grp(i) == 0) then thispos=buffer%imztwin(i) do while (thispos /= i) if (grp(thispos) /= 0) then grp(i)=grp(thispos) mzmiss=mzmiss-1 exit end if thispos=buffer%imztwin(thispos) end do end if end if end do end if sxcode=3 if (newsex == MISS) then sxcode=4 newsex=1 if (pos1 == 0 .and. pos2 > 0) then newsex=2 else if (pos2 > pos1) then newsex=2 else if (pos1 == pos2) then newsex=irandom(1,2) end if end if do i=1, num if (grp(i) == idx) then impsex(i)=sxcode buffer%sex(i)=newsex ! write(*,*) idx, i, buffer%sex(i) else if (grp(i) == -idx) then impsex(i)=sxcode buffer%sex(i)=3-newsex ! write(*,*) idx, i, buffer%sex(i) end if end do end do ! order father then mother do i=1, num if (buffer%fa(i) /= MISS .and. buffer%mo(i) /= MISS) then p1=ord(buffer%fa(i)) p2=ord(buffer%mo(i)) if (buffer%sex(p1) == 2 .and. buffer%sex(p2) == 1) then j=buffer%fa(i) buffer%fa(i)=buffer%mo(i) buffer%mo(i)=j else if (buffer%sex(p1) == buffer%sex(p2)) then nerr=1 if (impsex(p1) > 2 .and. impsex(p2) > 2) then write(outstr,'(/5a/7x,4a/7x,5a)') & 'ERROR: Parents of ', & trim(pedigree), '-', trim(buffer%id(key1(i))), & ' are obliged to be the same sex:', & trim(buffer%id(key1(p1))), ' x ', trim(buffer%id(key1(p2))),'.', & 'Sexes inferred from relationships to ', & trim(pedigree),'-',trim(buffer%id(key1(abs(grp(p1))))),'.' else write(outstr,'(/5a/7x,4a)') & 'ERROR: Parents of ', & trim(pedigree), '-', trim(buffer%id(key1(i))), & ' appear to be the same sex:', & trim(buffer%id(key1(p1))), ' x ', trim(buffer%id(key1(p2))), '.' end if end if end if end do if (plevel > 0) then showimp=.false. do i=1, num if (impsex(i) > 2) then showimp=.true. exit end if end do if (showimp) then write(outstr,'(/a/a)') & 'Pedigree ID New sex', & '--------------- ------------ -------' do i=1, num if (impsex(i) > 2) then call wrsex(buffer%sex(i), sx) cimp=' ' if (impsex(i) > 3) cimp='[i]' write(outstr,'(a15,1x,a12,1x,a,1x,a)') & pedigree, buffer%id(key1(i)), sx, cimp end if end do write(outstr,*) end if end if end subroutine addsexes ! ! Work out generation number ord(), then sort family on ! founder status, generation number, parental ID, ! and personal ID giving their position in ord(). ! Returns the ranking in ord(), and the depth of the pedigree in higen ! subroutine famsort(pedigree, num, nfound, nid, id, pid, fa, mo, & key1, ord, higen, nerr, plevel) use idstring_widths use sorts character (len=ped_width), intent(in out) :: pedigree integer, intent(in) :: num integer, intent(in) :: nfound integer, intent(inout) :: nid character (len=id_width), dimension(:), intent(inout) :: id integer, dimension(:), intent(inout) :: pid integer, dimension(:), intent(inout) :: fa integer, dimension(:), intent(inout) :: mo integer, dimension(:), intent(inout) :: key1 integer, dimension(:), intent(inout) :: ord integer, intent(inout) :: higen integer, intent(inout) :: nerr integer, intent(in) :: plevel integer, dimension(size(pid),2) :: set integer, dimension(size(pid)) :: key2 integer, parameter :: MISS=-9999 integer :: curkey1, curkey2, i, maxgrp, nsub, stratum interface subroutine ascend(n, ia) integer, intent(in) :: n integer, dimension(:), intent(inout) :: ia end subroutine ascend subroutine connect(num,fa,mo,set,nsub,maxgrp) integer, intent(in) :: num integer, dimension(:), intent(in) :: fa integer, dimension(:), intent(in) :: mo integer, dimension(:,:), intent(out) :: set integer, intent(out) :: nsub integer, intent(out) :: maxgrp end subroutine connect subroutine wrsubped(pedigree,num,id,key,set,nsub,maxgrp,plevel) use idstring_widths character (len=ped_width), intent(in out) :: pedigree integer, intent(in) :: num character (len=id_width), dimension(:), intent(in out) :: id integer, dimension(:), intent(in out) :: key integer, dimension(:,:), intent(in out) :: set integer, intent(in out) :: nsub integer, intent(in) :: maxgrp integer, intent(in) :: plevel end subroutine wrsubped subroutine badloop(pedigree, num, id, key, fa, mo, nerr) use outstream character (len=*) :: pedigree integer, intent(in) :: num character (len=*), dimension(:), intent(in) :: id integer, dimension(:), intent(in) :: key, fa, mo integer, intent(inout) :: nerr end subroutine badloop subroutine gener(pedigree,num,fa,mo,nsub,set,ord,higen, nerr,plevel) use idstring_widths character (len=ped_width), intent(in out) :: pedigree integer, intent(in) :: num integer, dimension(:), intent(in) :: fa integer, dimension(:), intent(in) :: mo integer, intent(in) :: nsub integer, dimension(:,:), intent(in) :: set integer, dimension(:), intent(out) :: ord integer, intent(out) :: higen integer, intent(out) :: nerr integer, intent(in) :: plevel end subroutine gener end interface ! ! nsub=number of disjoint subpedigrees within "pedigree"; higen=number of ! generations in family; subped no. 1 largest, size maxgrp ! determine collation order of IDs in table call ascend(nid, key1) call csort(nid, id, key1) ! create reverse index from sorted table to original records ! so that the multiple key sort can be performed call ascend(nid, ord) call isort(1, nid, key1, ord, 2) do i=1, num pid(i)=ord(pid(i)) end do ! ! determine if one or more subpedigrees are present ! call connect(num, fa, mo, set, nsub, maxgrp) ! ! list any subpedigrees ! if (nsub > 1 .and. plevel >= 0) then call wrsubped(pedigree, num, id, pid, set, nsub, maxgrp, plevel) end if ! ! get the generation number ! call gener(pedigree, num, fa, mo, nsub, set, key1, higen, nerr, plevel) if (nerr > 0) then call badloop(pedigree, num, id, pid, fa, mo, nerr) return end if ! ! and sort on generation number and foundership ! do i=1, num if (fa(i) /= MISS) then key1(i)=higen+key1(i) end if end do call ascend(num, ord) call isort(1, num, key1, ord, 2) ! now on paternal ID do i=nfound+1, num key2(i)=pid(fa(ord(i))) end do call msdsort(nfound+1, num, key1, key2, ord) ! now on maternal ID stratum=0 curkey1=MISS curkey2=MISS do i=nfound+1,num if (key1(i) /= curkey1 .or. & key1(i) == curkey1 .and. key2(i) /= curkey2) then stratum=stratum+1 curkey1=key1(i) curkey2=key2(i) end if key2(i)=stratum key1(i)=pid(mo(ord(i))) end do call msdsort(nfound+1, num, key2, key1, ord) ! now on ID do i=1, nfound key1(i)=0 key2(i)=pid(ord(i)) end do stratum=0 curkey1=MISS curkey2=MISS do i=nfound+1, num if (key2(i) /= curkey1 .or. key1(i) /= curkey2) then stratum=stratum+1 curkey1=key2(i) curkey2=key1(i) end if key1(i)=stratum key2(i)=pid(ord(i)) end do call isort(1, nfound, key2, ord, 2) call msdsort(nfound+1,num,key1,key2,ord) end subroutine famsort ! ! Create dummy records for added individals ! subroutine mkdummy(num, nfound, sx, numloc, buffer) use ped_class integer, intent(inout) :: num integer, intent(inout) :: nfound integer, intent(in) :: sx integer, dimension(NDATACLASS), intent(in) :: numloc type (ped_data), intent(inout) :: buffer integer, parameter :: MISS=-9999 integer (kind=1), dimension(1) :: zero = (/ 0 /) integer :: j num=num+1 nfound=nfound+1 buffer%fa(num)=MISS buffer%mo(num)=MISS buffer%sex(num)=sx do j=1, numloc(GCLASS) buffer%glocus(num,j)=MISS end do do j=1, numloc(PCLASS) buffer%plocus(num,j)=MISS end do if (buffer%hassnps /= 0) then call matrix_set_row(zero, num, buffer%slocus, ios) end if end subroutine mkdummy ! ! Assign a locus type to every column of data file ! subroutine asstyp(nloci, loctyp, locpos, totloc, coltyp) use automatic_data use locus_types integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos integer, intent(in) :: totloc integer, dimension(:), intent(out) :: coltyp integer :: i, pos do i=1, totloc coltyp(i)=0 end do pos=0 do i=1, nloci if (.not.isspecial(loctyp(i))) then pos=pos+1 coltyp(pos)=loctyp(i) if (ismarker(loctyp(i))) then pos=pos+1 coltyp(pos)=loctyp(i) end if end if end do end subroutine asstyp ! ! Add extra blank columns to the dataset ! subroutine addvar(wrk, wrk2, dclass, newloc, dataset, plevel) use outstream use ped_class integer, intent(in) :: wrk, wrk2 integer, intent(in) :: dclass ! data class (1=i2, 2=r8) integer, dimension(NDATACLASS), intent(in) :: newloc type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel integer, parameter :: MISS = -9999 integer :: astat, i, ifail, nped, nobs integer, dimension(NDATACLASS) :: oldloc, newcol ! functions double precision :: dataset_uses ifail=0 oldloc=dataset%numloc ! check if already extra columns allocated if (newloc(dclass) <= dataset%numcol(dclass)) then if (plevel > 1) then write(outstr,'(a)') 'NOTE: Extra space already allocated.' end if dataset%numloc(dclass)=newloc(dclass) if (dclass == GCLASS) then dataset%glocus(1:dataset%nobs, (oldloc(dclass)+1):newloc(dclass))=MISS else if (dclass == PCLASS) then dataset%plocus(1:dataset%nobs, (oldloc(dclass)+1):newloc(dclass))=MISS end if return end if ! else carry out in memory if economical newcol=newloc i=2 if (dclass == GCLASS .or. dclass == SCLASS) i=2*i newcol(dclass)=newcol(dclass)+i newcol(TCLASS)=newcol(TCLASS)+i if (dclass == PCLASS) then if (plevel > 1) then write(outstr,'(a)') 'NOTE: Expanding phenotype storage space.' end if call expand_pheno(newcol(dclass), dataset, ifail) dataset%numloc=newloc else if (dclass == GCLASS) then if (plevel > 1) then write(outstr,'(a)') 'NOTE: Expanding marker storage space.' end if call expand_geno(newcol(dclass), dataset, ifail) dataset%numloc=newloc else if (dclass == SCLASS) then if (plevel > 1) then write(outstr,'(a)') 'NOTE: Expanding SNP storage space.' end if call expand_sgeno(newcol(dclass), dataset, ifail) dataset%numloc=newloc end if if (ifail /= 0) then if (plevel > 1) then write(outstr,'(a,f7.1,a)') & 'NOTE: Swapping out to disk since dataset occupies ', & dataset_uses(dataset), ' Mb.' end if nobs=0 nped=0 open(wrk, status='scratch', form='unformatted') open(wrk2, status='scratch', form='unformatted') do i=1, dataset%nped call wrkout(wrk, wrk2, i, dataset, nped, nobs) end do call pedin(wrk, wrk2, nped, nobs, oldloc, newcol, dataset) if (dclass == PCLASS) then dataset%plocus(1:dataset%nobs, (oldloc(dclass)+1):newloc(dclass))=MISS else if (dclass == GCLASS) then dataset%glocus(1:dataset%nobs, (oldloc(dclass)+1):newloc(dclass))=MISS end if dataset%numloc=newloc dataset%numcol=newcol end if end subroutine addvar ! ! Create a temporary quantitative variable ! subroutine addtmpvar(tmpnam, dataset, tmppos, ifail) use locus_types use locus_data use ped_class character (len=*), intent(in) :: tmpnam type (ped_data), intent(inout) :: dataset integer, intent(out) :: tmppos integer, intent(out) :: ifail ifail=0 if (nloci >= size(loc)) then call expand_loci(10, 0) end if if (dataset%numloc(PCLASS) >= dataset%numcol(PCLASS)) then call expand_pheno(dataset%numloc(PCLASS)+1, dataset, ifail) end if tmppos=nloci+1 loc(tmppos)=tmpnam loctyp(tmppos)=LOC_QUA locpos(tmppos)=dataset%numloc(PCLASS)+1 end subroutine addtmpvar ! ! Write out current pedigree to a work file, updating number of records ! subroutine wrkout(wrk, wrk2, ped, dataset, nped, nobs) use ped_class integer, intent(in) :: wrk, wrk2 integer, intent(in) :: ped type (ped_data), intent(in) :: dataset integer, intent(inout) :: nobs, nped integer, parameter :: MISS=-9999 integer :: i, ioff, imztwin, num, pedoffset pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset write(wrk) dataset%pedigree(ped), dataset%actset(ped), nobs+num, dataset%nfound(ped) do i=pedoffset+1, pedoffset+dataset%nfound(ped) write(wrk2) dataset%id(i), MISS, MISS, MISS, dataset%sex(i), & dataset%glocus(i,1:dataset%numloc(GCLASS)), & dataset%plocus(i,1:dataset%numloc(PCLASS)) if (dataset%hassnps /= 0) then call matrix_write_row(i, dataset%slocus, wrk2) end if end do do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped) ioff=pedoffset-nobs if (dataset%imztwin(i)==MISS) then imztwin=MISS else imztwin=dataset%imztwin(i)-ioff end if write(wrk2) dataset%id(i), imztwin, & dataset%fa(i)-ioff, & dataset%mo(i)-ioff, & dataset%sex(i), & dataset%glocus(i,1:dataset%numloc(GCLASS)), & dataset%plocus(i,1:dataset%numloc(PCLASS)) if (dataset%hassnps /= 0) then call matrix_write_row(i, dataset%slocus, wrk2) end if end do nped=nped+1 nobs=nobs+num end subroutine wrkout ! ! Read pedigree back in from work files ! May allocate extra blank columns in dataset%plocus for later use ! by numcol > numloc ! subroutine pedin(wrk, wrk2, nped, nobs, numloc, numcol, dataset) use outstream use ped_class integer, intent(in) :: wrk, wrk2 integer, intent(in) :: nobs, nped integer, dimension(NDATACLASS) :: numloc, numcol type (ped_data), intent(inout) :: dataset integer astat, i, maxact, nact, num, ped character (len=20) :: selapsed integer :: it1, it2, ticks ! functions double precision :: dataset_uses call system_clock(it1) call cleanup_peds(dataset) call setup_peds(nped, nobs, numloc, numcol, dataset, astat, 0) if (astat /= 0) then write(outstr,'(a)') 'ERROR: pedin() could not allocate pedigree storage!' return end if nact=0 maxact=0 rewind(wrk) do ped=1, dataset%nped read(wrk) dataset%pedigree(ped), dataset%actset(ped), & dataset%num(ped), dataset%nfound(ped) num=dataset%num(ped)-dataset%num(ped-1) dataset%maxsiz=max(dataset%maxsiz, num) if (dataset%actset(ped)>0) then nact=nact+1 maxact=max(maxact, num) end if end do dataset%nact=nact dataset%maxact=maxact rewind(wrk2) ped=1 do i=1, dataset%nobs read(wrk2) dataset%id(i), dataset%imztwin(i), & dataset%fa(i), dataset%mo(i), & dataset%sex(i), & dataset%glocus(i,1:dataset%numloc(GCLASS)), & dataset%plocus(i,1:dataset%numloc(PCLASS)) if (dataset%hassnps /= 0) then call matrix_read_row(wrk2, i, dataset%slocus) end if if (i > dataset%num(ped)) ped=ped+1 dataset%iped(i)=ped end do call system_clock(it2, count_rate=ticks) write(selapsed, '(f20.2)') float(it2-it1)/float(ticks) selapsed=adjustl(selapsed) write(outstr,'(a,i0,a,i0,a)') & 'Reread ', dataset%nped, ' pedigrees, ', & dataset%nobs, ' individuals (' // trim(selapsed) // ' s).' write(selapsed, '(f20.3)') dataset_uses(dataset) selapsed=adjustl(selapsed) write(outstr,'(a)') 'Dataset occupies ' // trim(selapsed) // ' MB.' end subroutine pedin ! ! Read in data updates from a file ! file format: [ped] id loc1 loc2 ... locN, with header giving locus names ! uses hash to match up ids in file and current dataset ! and to match locus names in file to current dataset ! typ=1 overwrite all =2 update if missing =3 compare ! subroutine replacedata(port, typ, inputsep, nloci, loc, lochash, loctyp, locpos, & chosen, hashtab, dataset, longest, plevel) use locus_types use outstream use string_utilities use fileio use scanner use ped_class use idhash_class use lochash_class use categorical_data implicit none type (ioport) :: port integer, intent(in) :: typ character (len=1), intent(in) :: inputsep integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc type (hash_table) :: lochash integer,dimension(:), intent(in) :: loctyp integer,dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: chosen ! Hash table for IDs type (hash_table) :: hashtab type (ped_data) :: dataset ! Categorical trait levels integer :: catval, ncatvars type (table_cell), dimension(1) :: values integer, dimension(nloci) :: catidx type (cat_data) :: categories integer, intent(in) :: longest integer, intent(out) :: plevel ! integer, parameter :: KNOWN=0, MISS=-9999 integer, dimension(:), allocatable :: fieldord, fieldpos, nupdated character (len=longest) :: lin character (len=40), dimension(:), allocatable :: words integer :: dups, g1, g2, g3, g4, gcode, gene, gen2, i, idx, ioerr, & j, k, keytyp, narg, nchanges, nfields, nid, nlines, & n_indchanged, nvar, nwarn, pos, matched, typ_read, & typ_read_head, unmatched logical :: found double precision :: val character (len=1) :: sep character (len=7) :: gtp, ogtp character (len=11), dimension(3) :: act = (/ 'Overwriting', 'Overwriting', & 'Discordant ' /) integer :: len_unmatched_ids character (len=60) :: unmatched_ids ! functions integer :: aval logical :: iscomment, isreal double precision :: fval ! dataset%untyped=.true. allocate(words(3)) sep=' ' typ_read=SEP_WH_SLASH_CAS typ_read_head=SEP_WHITE if (inputsep /= ' ') then sep=inputsep typ_read_head=SEP_CHAR typ_read=SEP_CHAR end if keytyp=0 nid=0 call rewind_port(port, ioerr) do call readline(port, lin, ios=ioerr) if (ioerr /= 0) then write(outstr,'(/a)') 'ERROR: Unable to read file header.' return end if if (iscomment(lin)) cycle narg=size(words) call args(lin, narg, words, sep, typ_read_head) if (words(1)(1:3) == 'ped' .and. words(2) == 'id' .and. narg > 2) then keytyp=HK_PED_ID nid=2 else if (words(1)(1:3) == 'FID' .and. words(2) == 'IID' .and. narg > 2) then keytyp=HK_PED_ID nid=2 else if (lcase(words(1)) == 'id' .and. narg > 1) then keytyp=HK_ID nid=1 else if (lcase(words(1)) == 'iid'.and. narg > 1) then keytyp=HK_ID nid=1 else write(outstr,'(/a/7x,a)') & 'ERROR: file header should be "ped id var1..." or "id var1..." in:', & lin(1:min(len_trim(lin),72)) write(outstr,'(7x,5a,l1,a,l1)') & '"', trim(words(1)), '" "', trim(words(2)), '" ped:', & words(1)(1:3) == 'ped', ' id:', words(1) == 'id' return end if exit end do deallocate(words) narg=countargs(trim(lin), sep, typ_read_head) allocate(words(2*narg)) call args(lin, narg, words, sep, typ_read_head) allocate(fieldord(narg-nid), fieldpos(narg-nid), nupdated(narg-nid)) if (plevel > 0) then write(outstr,'(a,i0,a/7x,a/)') & 'File contains ', narg-nid, ' variables:', lin(1:min(len_trim(lin),72)) end if nupdated=0 ! ! Try and match names in header ! if (.not.lochash%current) then call make_lochash(nloci, loc, lochash) end if nvar=0 ncatvars=0 nfields=nid do i=nid+1, narg found=.false. nfields=nfields+1 call find_hashtab(trim(words(i)), loc, lochash, pos) if (pos > 0) then if (.not.isspecial(loctyp(pos))) then if (chosen(pos) > 0) then nvar=nvar+1 fieldord(nvar)=pos fieldpos(nvar)=nfields if (iscattrait(loctyp(pos))) then ncatvars=ncatvars+1 catidx(ncatvars)=pos end if end if if (ismarker(loctyp(pos))) then nfields=nfields+1 end if found=.true. end if end if if (.not.found) then if (trim(words(i)) /= 'sex' .and. & trim(words(i)) /= 'father' .and. trim(words(i)) /= 'fa' .and. & trim(words(i)) /= 'mother' .and. trim(words(i)) /= 'mo') then write(outstr,'(/3a/7x,a)') & 'NOTE: Undeclared locus "', trim(words(i)), '" in update file.', & 'This is assumed to occupy only one field!' end if end if end do write(outstr, '(/a,i0,a)') & 'Update file contains ', nvar,' useable variables.' if (plevel > 1) then do i=1, nvar write(outstr,'(i0,3a,i0,a)') & i, ') ', trim(loc(fieldord(i))), ' at column ', fieldpos(i), '.' end do end if call load_cat_levels(ncatvars, catidx, categories) dups=0 nchanges=0 n_indchanged=0 nlines=0 nwarn=0 matched=0 unmatched=0 len_unmatched_ids=0 unmatched_ids=' ' if (.not.hashtab%current .or. keytyp /= hashtab%keytyp) then call hashids(keytyp, dataset, hashtab, 80, plevel) end if do call readline(port, lin, ios=ioerr) if (ioerr /= 0) exit nlines=nlines+1 if (iscomment(lin)) cycle narg=nfields call args(lin, narg, words, sep, typ_read) if (narg /= nfields) then nwarn=nwarn+1 if (nwarn <= 25) then if (narg < nfields) then write(outstr,'(/a,i0,a,i0,a/7x,a,i0,3a/)') & 'ERROR: Insufficient number of data fields (', & narg, '; expected ', nfields,') in:', & 'Line ', nlines, ' "', lin(1:min(len_trim(lin),72)), '"' else write(outstr,'(/a,i0,a,i0,a/7x,a,i0,3a/)') & 'NOTE: Excessive number of data fields (', & narg, '; expected ', nfields,') in:', & 'Line ', nlines, ' "', lin(1:min(len_trim(lin),72)), '"' end if end if end if if (keytyp == HK_PED_ID) then call matchid(keytyp, words(1), words(2), dataset, hashtab, idx, plevel) else call matchid(keytyp, ' ', words(1), dataset, hashtab, idx, plevel) end if if (idx /= 0) then if (dataset%actset(dataset%iped(idx)) > 0) then if (.not.dataset%untyped(idx)) then dups=dups+1 if (plevel > 0) then if (keytyp == HK_PED_ID) then write(outstr, '(4a)') & 'NOTE: Duplicate data for ', trim(words(1)), '--', trim(words(2)) else write(outstr, '(2a)') & 'NOTE: Duplicate data for ', trim(words(1)) end if end if else matched=matched+1 end if dataset%untyped(idx)=.false. ncatvars=0 do i=1, nvar pos=fieldpos(i) j=fieldord(i) gene=locpos(j) gen2=gene+1 if (isactive(loctyp(j))) then if (ismarker(loctyp(j))) then found=observed(idx, locpos(j), dataset) if (typ /= 2 .or. .not.found) then ! Replaced gencode call to presetting to 1 2015-03-26 g1 = aval(words(pos), 1) g2 = aval(words(pos+1), 1) if (g1 == MISS .or. g2 == MISS) then g1=MISS g2=MISS end if call order(g1, g2) if (typ /= 2 .or. g1 /= MISS) then nchanges=nchanges+1 nupdated(i)=nupdated(i)+1 if (typ == 3 .or. plevel > 1) then g3=MISS g4=MISS if (observed(idx, gene, dataset)) then call get_geno(idx, gene, gen2, dataset, g3, g4) end if if (g1 /= g3 .or. g2 /= g4) then dataset%untyped(idx)=.true. call wrgtp(g1, g2, gtp, '/', '', 1) call wrgtp(g3, g4, ogtp, '/', '', 1) write(*,'(11a)') & act(typ), ' genotype at "', trim(loc(j)),'" for ', & trim(dataset%pedigree(dataset%iped(idx))), '--', & trim(dataset%id(idx)), ' to ', gtp, ' from ', ogtp else if (typ == 3) then nchanges=nchanges-1 nupdated(i)=nupdated(i)-1 end if end if if (typ /= 3) then call set_geno(idx, gene, gen2, dataset, g1, g2) end if end if end if else if (typ /= 2 .or. dataset%plocus(idx,gene) == MISS) then if (iscattrait(loctyp(j))) then ncatvars=ncatvars+1 if (isreal(words(pos))) then call fval2(words(pos), val, ioerr) if (ioerr /= 0) then write(outstr,'(a,i0,a,i0,3a,i0)') & 'Problem reading line', nlines, ' pos=', pos, ' "', & words(pos), '" ioerr=', ioerr end if else call set_table_cell(values(1), string=trim(words(pos))) call insert_table_cells(1, values, categories%cat_tables(ncatvars), & 1, slot=catval) val=float(catval) !!!!!!!!!! call get_whichcat(words(pos), j, val) end if else call fval2(words(pos), val, ioerr) if (ioerr /= 0) then write(outstr,'(a,i0,a,i0,3a,i0)') & 'Problem reading line', nlines, ' pos=', pos, ' "', & words(pos), '" ioerr=', ioerr end if end if if (typ /= 2 .or. val /= MISS) then nchanges=nchanges+1 nupdated(i)=nupdated(i)+1 if (typ == 3 .or. plevel > 1) then if (val /= dataset%plocus(idx,gene)) then dataset%untyped(idx)=.true. write(outstr,'(10a)', advance='no') & act(typ), ' trait value at "', trim(loc(j)),'" for ', & trim(dataset%pedigree(dataset%iped(idx))), '--', & trim(dataset%id(idx)), ' to ', trim(words(pos)), ' from ' write(outstr, *) dataset%plocus(idx,gene) else nchanges=nchanges-1 nupdated(i)=nupdated(i)-1 end if end if end if if (typ /= 3) then dataset%plocus(idx,gene) = val end if end if end if end if end do if (dataset%untyped(idx)) then n_indchanged=n_indchanged+1 end if else if (plevel > 0) then write(outstr, '(5a)') 'NOTE: Pedigree of ', & trim(dataset%pedigree(dataset%iped(idx))), '--', & trim(dataset%id(idx)), ' is not currently active. Data not updated.' end if else unmatched=unmatched+1 if (len_unmatched_ids < 58) then if (keytyp == HK_PED_ID) then unmatched_ids=trim(unmatched_ids) // ' ' // & trim(words(1)) // '--' // trim(words(2)) else unmatched_ids=trim(unmatched_ids) // ' ' // trim(words(1)) end if len_unmatched_ids=len_trim(unmatched_ids) end if if (plevel > 0) then if (keytyp == HK_PED_ID) then write(outstr, '(5a)') & 'NOTE: Could not match ', trim(words(1)), '--', trim(words(2)), '.' else write(outstr, '(3a)') 'NOTE: Could not match ', trim(words(1)), '.' end if end if end if end do if (typ == 1) then write(outstr,'(/a,i0,a,i0,a)') & 'Updated ', nchanges, ' values for ',matched,' individuals.' else if (typ == 2) then write(outstr,'(/a,i0,a,i0,a)') & 'Merged in ', nchanges, ' values for ',matched,' individuals.' else write(outstr,'(/a,i0,a,i0,a)') & 'Detected ', nchanges, ' discordant values for ', & n_indchanged, ' individuals.' end if if (plevel > 0) then write(outstr,'(/a/a)') 'Locus Updates', & '-------------------- -------' do i=1, nvar j=fieldord(i) write(outstr,'(a20,i8)') loc(j), nupdated(i) end do write(outstr,*) end if end if if (dups /= 0) then write(outstr,'(a,i0,a)') 'Multiple updates for ', dups, ' IDs.' end if if (unmatched /= 0) then write(outstr,'(a,i0,2a)') 'Failed to match ', unmatched, ' IDs: ', & trim(unmatched_ids) end if call cleanup_hash(hashtab) call relevel_cats(categories, dataset) call clean_cats(categories) end subroutine replacedata ! ! Prefix filnam with a dirnam ! If filnam starts with ~/, expand this instead of dirnam ! subroutine concat(dirnam, filnam) character (len=*), intent(in) :: dirnam character (len=*), intent(inout) :: filnam #if defined (WIN32) character (len=1), parameter :: slash='\\' #else character (len=1), parameter :: slash='/' #endif integer :: len1, len2 character (len=len(filnam)) :: prefix len1=len_trim(dirnam) if (filnam(1:1) == '~' .and. filnam(2:2) == slash) then filnam=filnam(3:len_trim(filnam)) call getenv('HOME', prefix) len1=len_trim(prefix) else if (len1 > 0) then prefix=dirnam end if if (len1 > 0) then len2=len_trim(filnam) if ((len1+len2+1) > len(filnam)) then write(*,'(a,i3,a/7x,3a/)') & 'ERROR: Path name exceeds ', len(filnam), ' characters.', & 'File path remains "', filnam(1:len2), '".' else if (prefix(len1:len1) == slash) then filnam=trim(prefix) // trim(filnam) else filnam=trim(prefix) // slash // trim(filnam) end if end if end subroutine concat ! ! Extract prefix from filnam ! subroutine extprefix(filnam, suffix) character (len=*), intent(inout) :: filnam character (len=*), intent(in) :: suffix integer :: i, slen slen=len_trim(filnam) if (suffix /= ' ') then i=len_trim(suffix) if (filnam((slen-i+1):slen) == trim(suffix)) then filnam=filnam(1:(slen-i)) end if else do i=slen, 1, -1 if (filnam(i:i) == '.') then filnam=filnam(1:(i-1)) return end if end do end if end subroutine extprefix ! ! Extract suffix from filnam - skipping past .gz etc ! subroutine extsuffix(filnam, suffix) character (len=*), intent(inout) :: filnam character (len=*), intent(out) :: suffix integer :: i, slen, suflen slen=len_trim(filnam) 1 continue suffix=' ' do i=slen, 1, -1 if (filnam(i:i) == '.') then suffix=filnam((i+1):slen) if (suffix == 'zip' .or. suffix == 'gz' .or. suffix == 'bgz') then slen=i-1 go to 1 else return end if end if end do end subroutine extsuffix ! ! Extract path from filnam ! subroutine extpath(filnam) character (len=*), intent(inout) :: filnam #if defined (WIN32) || defined (IFORT) || defined (NOESCAPE) character (len=1) :: bslash='\' #else character (len=1) :: bslash='\\' #endif character (len=1) :: fslash='/' integer :: i, slen slen=len_trim(filnam) do i=slen, 1, -1 #if defined (WIN32) if (filnam(i:i) == bslash .or. filnam(i:i) == fslash) then #else if (filnam(i:i) == fslash) then #endif filnam=filnam(1:(i-1)) return end if end do end subroutine extpath ! ! Test what character used to separate directories ! and append to directory ! subroutine slash(dirnam, lend) character (len=*), intent(inout) :: dirnam integer, intent(in out) :: lend character (len=1) :: sla #if defined (WIN32) sla='\\' #else sla='/' #endif if (dirnam(lend:lend) /= sla) then lend=lend+1 dirnam(lend:lend)=sla end if end subroutine slash ! ! Print a string, stripping out C-style escapes ! subroutine display(str) use outstream character (len=*), intent(in) :: str integer :: lent, fin, next, sta sta=1 fin=1 lent=len_trim(str) do while (fin < lent) #if defined (WIN32) || defined (IFORT) || defined (NOESCAPE) if (str(fin:fin) == '\') then #else if (str(fin:fin) == '\\') then #endif next=fin+1 if (str(next:next) == 'n' .or. str(next:next) == 'r' .or. str(next:next) == 'f') then write(outstr, '(a)') str(sta:(fin-1)) else if (str(next:next) == 'a') then write(outstr, '(2a)') str(sta:(fin-1)), ' *DING*' else if (str(next:next) == 't' .or. str(next:next) == 'v') then write(outstr, '(2a)', advance='no') str(sta:(fin-1)), ' ' else if (str(next:next) == 'b') then write(outstr, '(a)', advance='no') str(sta:(fin-1)) else write(outstr, '(2a)', advance='no') str(sta:(fin-1)), str(next:next) end if sta=next+1 fin=next end if fin=fin+1 end do write(outstr, '(a)') str(sta:lent) end subroutine display ! ! Display contents of a file ! subroutine cat(fil) use outstream use fileio character (len=*), intent(in) :: fil integer, parameter :: BUFLEN=32768 character (len=BUFLEN) :: buffer type (ioport) :: port integer :: ioerr call open_port(fil, port, 'r', ioerr) if (ioerr /= 0) then write(*,'(3a)') 'Cannot open "', trim(fil), '".' return end if do call readline(port, buffer, advance='no', ios=ioerr) if (ioerr == eolcode) then write(outstr,'(a)') trim(buffer) cycle else if (ioerr /= 0) then exit end if write(outstr,'(a)', advance='no') buffer end do call close_port(port, ioerr) end subroutine cat ! ! Display first N lines of a file ! subroutine head(fil, nlin) use outstream use fileio character (len=*), intent(in) :: fil integer, intent(in) :: nlin integer, parameter :: BUFLEN=80 character (len=BUFLEN) :: linbuf type (ioport) :: port integer :: ioerr, nread call open_port(fil, port, 'r', ioerr) if (ioerr /= 0) then write(*,'(3a,i0,a)') 'Cannot open "', trim(fil), '" ioerr=', ioerr, '.' return end if nread=0 do while (nread < nlin) call readline(port, linbuf, ios=ioerr) if (ioerr /= 0) exit nread=nread+1 write(outstr,'(a)') trim(linbuf) end do call close_port(port, ioerr) end subroutine head ! ! Display last N lines of a file ! subroutine tail(fil, nlin) use outstream use fileio use iocodes character (len=*), intent(in) :: fil integer, intent(in) :: nlin integer (kind=8), parameter :: BUFLEN=80 character (len=BUFLEN) :: linbuf integer :: i, ich, ioerr, nread, strm integer (kind=8) :: filsiz, offset, pos character (len=1) :: ch call newlun(strm) open(strm, file=fil, status='old', access='stream', form='formatted', iostat=ioerr) if (ioerr /= 0) then write(*,'(3a,i0,a)') 'Cannot open "', trim(fil), '" ioerr=', ioerr, '.' return end if inquire(file=fil, size=filsiz) nread=0 pos=0 offset=filsiz-1 do while (nread < nlin .and. offset > 0) read(strm,'(a1)',advance='no', pos=offset, iostat=ioerr) ch ich=ichar(ch) if (ioerr == eolcode) nread=nread+1 offset=offset-1 end do nread=0 do while (nread < nlin) linbuf=' ' read(strm, '(a)', advance='yes', iostat=ioerr) linbuf if (ioerr /= 0 .and. ioerr /= -2) exit write(outstr,'(a)') trim(linbuf) end do close(strm) end subroutine tail ! ! Utility to count number of columns in a file ! simpler scanner than args ! subroutine countfields(fil, exclude_comments, plevel) use outstream use fileio use scanner use statresults character (len=*), intent(in) :: fil logical, intent(in) :: exclude_comments integer, intent(in) :: plevel integer, parameter :: BUFLEN=32768, MAXCHANGES = 10 integer, dimension(MAXCHANGES) :: changepoints character (len=BUFLEN) :: buffer type (ioport) :: port integer :: eos, ich, ilen, ioerr, longest, lpos, longword, & narg, nchanges, ncomments, nwords, maxwords, totwords, wordlen logical :: incomment, inword, changed, nl character (len=1) :: ch character (len=3) :: ellipsis call open_port(fil, port, 'r', ioerr) if (ioerr /= 0) then write(outstr,'(3a,i0,a)') 'Cannot open "', trim(fil), '" ioerr=', ioerr, '.' return end if inword=.false. incomment=.false. nl=.true. changepoints=0 longest=0 longword=0 ilen=0 lpos=0 nlines=0 narg=0 nchanges=0 ncomments=0 nwords=-1 maxwords=0 totwords=0 if (plevel >= 0) then write(outstr, '(/3a/)') 'Field counts for "', trim(fil), '":' end if do call readline(port, buffer, advance='no', ios=ioerr) if (ioerr /= 0 .and. ioerr /= eolcode) then exit end if if (nl .and. (buffer(1:1) == '#' .or. buffer(1:1) == '!')) then ncomments=ncomments+1 if (exclude_comments) then if (ioerr /= eolcode) then call readline(port, buffer, advance='yes', ios=ioerr) end if cycle end if end if ! test if word spans boundary ich=ichar(buffer(1:1)) if (inword .and. ich /= 32 .and. ich /= 9) narg=narg-1 if (ioerr == eolcode) then eos=len_trim(buffer) else eos=BUFLEN end if lpos=1 lineloop: do whitespace: do if (lpos > eos) exit lineloop ich=ichar(buffer(lpos:lpos)) if (ich /= 32 .and. ich /= 9) then inword=.true. narg=narg+1 wordlen=0 exit whitespace end if lpos=lpos+1 end do whitespace wordloop: do if (lpos > eos) exit lineloop ich=ichar(buffer(lpos:lpos)) if (ich == 32 .or. ich == 9) then inword=.false. if (wordlen > longword) then longword=wordlen end if exit wordloop else wordlen=wordlen+1 end if lpos=lpos+1 end do wordloop end do lineloop if (ioerr == eolcode) then inword=.false. nl=.true. ilen=ilen+eos if (ilen > longest) longest=ilen nlines=nlines+1 totwords=totwords+narg changed=(narg /= nwords) if (changed) then nwords=narg nchanges=nchanges+1 if (nchanges <= MAXCHANGES) changepoints(nchanges)=nlines if (narg > maxwords) maxwords=narg end if if (changed .and. (plevel > 0 .or. & (plevel == 0 .and. nchanges < MAXCHANGES))) then write(outstr,'(3(a,i0),3a)') & 'L ', nlines, ' Len ', ilen, ' NFields ', narg, ': "', trim(buffer(1:50)), '"' end if narg=0 ilen=0 else nl=.false. ilen=ilen+BUFLEN end if end do call close_port(port, ioerr) ! save to statval: nr, nc, rectangular statval(1)=dble(maxwords) statval(2)=dble(nlines) statval(3)=dble(nchanges) if (plevel < 0) then write(outstr,'(2a,3(1x,i0),1x,l1)') & trim(fil), ': ', nlines, longest, totwords, maxwords, (nchanges == 1) else write(outstr, '(/a,i0)', advance='no') & 'Number of lines = ', nlines if (.not.exclude_comments .and. ncomments > 0) then write(outstr, '(a,i0,a)', advance='no') & ' (including ', ncomments, ' comment lines)' end if write(outstr, '(/a,i0,a,2(/a,i0)/a,l1/a,i0,a)') & 'Length of longest line = ', longest, ' chars', & 'Total number of words = ', totwords, & 'Maximum words per line = ', maxwords, & 'Constant word count per line? = ', (nchanges == 1), & 'Length of longest word = ', longword, ' chars' if (nchanges > 1) then ellipsis=' ' if (nchanges > MAXCHANGES) ellipsis='...' write(outstr,'(a,i0/a,10(1x,i0))', advance='no') & 'Changes in word count/line = ', nchanges-1, & 'Counts changed at lines = ', changepoints(2:min(nchanges,MAXCHANGES)) write(outstr,'(a)') ellipsis end if end if end subroutine countfields ! ! Utility routine to transpose contents of a file: multipass ! subroutine ftranspose(fil, misval, plevel) use outstream use fileio implicit none character (len=*), intent(in) :: fil character (len=*), intent(in) :: misval integer, intent(in) :: plevel integer, parameter :: BUFLEN=32768 character (len=BUFLEN) :: buffer type (ioport) :: port integer :: ioerr, longest call open_port(fil, port, 'r', ioerr) if (ioerr /= 0) then write(outstr,'(3a,i0,a)') 'Cannot open "', trim(fil), '" ioerr=', ioerr, '.' return end if call reclen(port, buffer, longest, -1, .false.) call ftranspose1(port, fil, misval, longest, plevel) call close_port(port, ioerr) end subroutine ftranspose ! ! Buffered out-of-core transpose ! subroutine ftranspose1(port, fil, misval, longest, plevel) use outstream use fileio use scanner implicit none type (ioport) :: port character (len=*), intent(in) :: fil character (len=*), intent(in) :: misval integer, intent(in) :: longest integer, intent(in) :: plevel integer, parameter :: TOTBUFWORDS= 2097152, WORDLEN=40 character (len=longest) :: buffer integer, dimension(:), allocatable :: linepos character (len=WORDLEN), dimension(:,:), allocatable :: words integer :: fin, i, ioerr, j, k, llen, maxargs, nlines, & astat, bufcols, pos, span, sta ! how many fields maxargs=0 nlines=0 do call readline(port, buffer, ios=ioerr) if (ioerr /= 0) exit maxargs=max(maxargs, countargs(buffer, ' ', SEP_WHITE)) nlines=nlines+1 end do if (plevel > 0) then write(outstr,'(/3a,i0,a,i0,a)') & '# transposed ', trim(fil), ' (', nlines, ' cols,', maxargs, ' rows)' end if bufcols=min(maxargs, TOTBUFWORDS/nlines) bufcols=max(bufcols, 1) call rewind_port(port, ioerr) do allocate(words(nlines,bufcols), stat=astat) if (astat == 0) exit bufcols=bufcols-1 if (bufcols == 0) then write(outstr,'(a)') & 'ERROR: Unable to allocate buffer for file transposition!' if (plevel > 0) then write(outstr,'(7x,a)') 'Requested ', WORDLEN*nlines, ' bytes.' end if return end if end do allocate(linepos(nlines)) linepos=1 ! do pos=1, maxargs, bufcols nlines=0 words=misval do call readline(port, buffer, ios=ioerr) if (ioerr /= 0) exit nlines=nlines+1 llen=len_trim(buffer) span=0 do i=pos, min(pos+bufcols-1, maxargs) span=span+1 sta=linepos(nlines) if (sta <= llen) then do if (sta > llen) exit if (buffer(sta:sta) /= ' ') exit sta=sta+1 end do fin=sta do if (fin > llen) exit if (buffer(fin:fin) == ' ') exit fin=fin+1 end do linepos(nlines)=fin words(nlines,span)=buffer(sta:(fin-1)) end if end do end do do k=1, span do j=1, nlines write(outstr,'(a,1x)', advance='no') trim(words(j,k)) end do write(outstr,*) end do call rewind_port(port, ioerr) end do end subroutine ftranspose1 ! ! Utility to extract columns from a file ! subroutine fprinter(nwords, words, linbuf, plevel) use interrupt use outstream use scanner use fileio use string_utilities integer, intent(in) :: nwords character (len=40), dimension(:), intent(inout) :: words character (len=*), intent(inout) :: linbuf integer, intent(in) :: plevel type (ioport) :: port integer :: ioerr integer :: stype, success integer :: eos, eow, hspan, i, inspan, iskip, ispan, narg, nchosen, & nrec, septyp, sta, sskip logical :: printn integer, dimension(size(words)) :: chosen character (len=1) :: sep, outsep character (len=256) :: fil, fstring, sstring, sstring2 logical :: isreal call get_filnam(linbuf, nwords, fil) if (plevel > 0) then write(outstr,'(3a/)') 'File: "', trim(fil), '".' end if call open_port(fil, port, 'r', ioerr) if (ioerr == 0) then ! read the format, if present iskip=0 ispan=0 printn=.false. fstring=' ' sskip=0 sstring=' ' sstring2=' ' sep=' ' outsep=' ' septyp=1 stype=0 sta=3 do eow=len_trim(words(sta)) if (words(sta)(1:1) == '(') then call getword(linbuf, sta, fstring) sta=sta+1 else if (words(sta)(1:1) == '/') then if (stype == 0) then stype=1 else if (stype == 1) then stype=2 sstring=sstring2 end if call getword(linbuf, sta, sstring2) i=2 if (sstring2 == '/') then sta=sta+1 i=1 call getword(linbuf, sta, sstring2) end if eos=len_trim(sstring2) if (sstring2(eos:eos) == '/') then eos=eos-1 end if sstring2='*' // sstring2(i:eos) // '*' sta=sta+1 else if (words(sta) == ',') then sta=sta+1 else if (words(sta)(1:1) == '+') then iskip=iskip+1 sta=sta+1 else if (words(sta) == 'S') then sskip=sskip+1 sta=sta+1 else if (words(sta) == 'NR') then printn=.true. sta=sta+1 else if (words(sta) == 'tab') then sep=achar(9) septyp=5 sta=sta+1 else if (words(sta) == 'csv') then sep=',' septyp=5 sta=sta+1 else if (words(sta)(eow:eow) == 'p') then stype=4 ispan=max(0,ival(words(sta)(1:(eow-1)))) sta=sta+1 else exit end if end do ! then column list hspan=0 nchosen=0 do i=sta, nwords-1 if (words(i) == '-' .or. words(i) == '--') then if (nchosen == 0) then hspan=1 else hspan=chosen(nchosen)+1 end if else if (isreal(words(i))) then if (hspan /= 0) then do j=hspan, ival(words(i)) nchosen=nchosen+1 chosen(nchosen)=j end do hspan=0 else nchosen=nchosen+1 chosen(nchosen)=ival(words(i)) end if end if end do if (stype == 1 .or. stype == 4) then sstring=sstring2 end if if (fstring==' ') then if (printn) then if (nchosen == 0) then fstring='(i0,1x,a)' else write(fstring,'(a,i0,a)') '(i0,', nchosen, '(1x,a))' end if else if (nchosen == 0) then fstring='(a)' else write(fstring,'(a,i0,1x,a)') '(', nchosen, '(1x,a))' end if end if else if (fstring == '(tab)' .or. fstring == '(tsv)') then outsep=achar(9) else if (fstring == '(csv)') then outsep=',' end if if (plevel > 1) then write(outstr, '(3a)') 'Print format "', trim(fstring),'".' if (stype > 0) then if (stype == 1) then write(outstr, '(3a)') & 'Searching for "', trim(sstring),'".' else write(outstr, '(5a)') & 'Searching for "', trim(sstring),'" -- "', trim(sstring2),'".' end if if (iskip > 0) then write(outstr, '(a,i0,a)') 'And skipping ', iskip, ' lines if found.' end if if (ispan > 0) then write(outstr, '(a,i0,a)') 'Printing ', ispan, ' lines.' end if end if end if nrec=0 success=0 ! skip first sskip records do i=1, sskip call readline(port, linbuf, ios=ioerr) if (ioerr /= 0) then call close_port(port, ioerr) return end if end do if (nchosen == 0) then if (stype == 0) then do call readline(port, linbuf, ios=ioerr) if (ioerr /= 0) exit if (irupt > 0) exit nrec=nrec+1 if (outsep /= ' ') then narg=size(words) call args(linbuf, narg, words, sep, septyp) call csvline(outsep, printn, nrec, narg, words) else if (printn) then write(outstr, fstring, err=999) nrec, trim(linbuf) else write(outstr, fstring, err=999) trim(linbuf) end if end do else do call readline(port, linbuf, ios=ioerr) if (ioerr /= 0) exit if (irupt > 0) exit call print_sstate(port, stype, iskip, ispan, & sstring, sstring2, linbuf, inspan, nrec, success) if (success > 0) then if (outsep /= ' ') then narg=size(words) call args(linbuf, narg, words, sep, septyp) call csvline(outsep, printn, nrec, narg, words) else if (printn) then write(outstr, fstring, err=999) nrec, trim(linbuf) else write(outstr, fstring, err=999) trim(linbuf) end if if (success == 1 .or. success == 3) success=0 end if end do end if else if (stype == 0) then do call readline(port, linbuf, ios=ioerr) if (ioerr /= 0) exit if (irupt > 0) exit narg=size(words) call args(linbuf, narg, words, sep, septyp) nrec=nrec+1 if (outsep /= ' ') then if (printn) then write(outstr,'(i0)', advance='no') nrec write(outstr,*) (outsep, trim(words(chosen(i))), i=1, nchosen) else if (nchosen > 0) then write(outstr,*) trim(words(chosen(1))), & (outsep, trim(words(chosen(i))), i=2, nchosen) else write(outstr,*) end if else if (printn) then write(outstr, fstring, err=999) nrec,(trim(words(chosen(i))), i=1, nchosen) else write(outstr, fstring, err=999) (trim(words(chosen(i))), i=1, nchosen) end if end do else do call readline(port, linbuf, ios=ioerr) if (ioerr /= 0) exit if (irupt > 0) exit call print_sstate(port, stype, iskip, ispan, & sstring, sstring2, linbuf, inspan, nrec, success) if (success > 0) then narg=size(words) call args(linbuf, narg, words, sep, septyp) if (outsep /= ' ') then if (printn) then write(outstr,'(i0)', advance='no') nrec write(outstr,*) (outsep, trim(words(chosen(i))), i=1, nchosen) else if (nchosen > 0) then write(outstr,*) trim(words(chosen(1))),(outsep, trim(words(chosen(i))), i=2, nchosen) else write(outstr,*) end if else if (printn) then write(outstr, fstring, err=999) nrec,(trim(words(chosen(i))), i=1, nchosen) else write(outstr, fstring, err=999) (trim(words(chosen(i))), i=1, nchosen) end if if (success == 1 .or. success == 3) success=0 end if end do end if end if call close_port(port, ioerr) else write(outstr,'(3a)') 'Cannot open "', trim(fil), '".' end if return ! format problems etc 999 continue write(outstr,'(3a/7x,3a)') & 'ERROR: Could not write "', linbuf(1:min(len_trim(linbuf),60)), '"', & 'using format "', trim(fstring), '".' call close_port(port, ioerr) return end subroutine fprinter ! ! Current line print status based on search strategy and state ! sstate action ! 0 nothing ! 1 found search string ! 2 in search block /start/, /end/ ! 3 end of search block ! 4 in search block /start/, Np ; inspan=line count in block ! subroutine print_sstate(port, stype, iskip, ispan, sstring, sstring2, & linbuf, inspan, nrec, sstate) use interrupt use scanner use fileio use string_utilities implicit none type (ioport) :: port integer, intent(in) :: stype, iskip, ispan character (len=*), intent(in) :: sstring, sstring2 character (len=*), intent(inout) :: linbuf integer, intent(inout) :: inspan, nrec, sstate integer :: i, ioerr nrec=nrec+1 if (strfind(trim(sstring), trim(linbuf), 1) & .and. sstate == 0) then sstate=stype if (ispan > 0) then sstate=4 inspan=ispan end if do i=1, iskip call readline(port, linbuf, ios=ioerr) if (ioerr /= 0) exit nrec=nrec+1 end do else if (stype == 2 .and. sstate == 2) then if (strfind(trim(sstring2), trim(linbuf), 1)) then sstate=3 end if else if (stype == 4 .and. sstate == 4) then inspan=inspan-1 if (inspan <= 1) sstate=3 end if end subroutine print_sstate ! ! one line of character separated output ! subroutine csvline(outsep, printn, linenumber, nwords, words) use outstream character (len=1), intent(in) :: outsep logical, intent(in) :: printn integer, intent(in) :: linenumber integer, intent(in) :: nwords character (len=40), dimension(nwords), intent(inout) :: words integer :: i if (printn) then write(outstr, '(i0)', advance='no') linenumber end if if (nwords > 0) then if (printn) then write(outstr, '(a)', advance='no') outsep end if write(outstr, '(a)', advance='no') trim(words(1)) do i=2, nwords write(outstr, '(2a)', advance='no') outsep, trim(words(i)) end do end if write(outstr,*) end subroutine csvline ! ! Invert a matrix read from text file, where each line ! comprises a row index, col index, and element value. ! for use with programs such as Wombat ! subroutine wrinverse(fil, typ, ridge_constant, invalg, plevel) use outstream use fileio use scanner character (len=*), intent(in) :: fil integer, intent(in) :: typ double precision, intent(in) :: ridge_constant integer, intent(in) :: invalg, plevel integer, parameter :: BUFLEN=1024, LOWER_TRI=1 character (len=BUFLEN) :: buffer character (len=40), dimension(4) :: words type (ioport) :: port integer :: i, j, k, ioerr, matrank, narg, pos integer :: nrows, header integer (kind=8) :: ii, nel double precision :: logdet, val double precision, dimension(:), allocatable :: mat, invmat ! functions integer :: clcpos, ival double precision :: fval call open_port(fil, port, 'r', ioerr) if (ioerr /= 0) then write(outstr,'(3a,i0,a)') 'Cannot open "', trim(fil), '" ioerr=', ioerr, '.' return end if ! matrix size header=0 nrows=0 call readline(port, buffer, ios=ioerr) if (ioerr /= 0) then write(outstr,'(3a,i0,a)') 'Cannot read "', trim(fil), '" ioerr=', ioerr, '.' call close_port(port, ioerr) return end if narg=4 call args(buffer, narg, words, ' ', SEP_WHITE) ! assumes one or two fields contain nrows else read all indices if (narg == 2) then header=1 i=ival(words(1)) j=ival(words(2)) nrows=max(i,j) else if (narg == 1) then header=1 nrows=ival(words(1)) else i=ival(words(1)) j=ival(words(2)) nrows=max(i,j) do call readline(port, buffer, ios=ioerr) if (ioerr /= 0) exit narg=4 call args(buffer, narg, words, ' ', SEP_WHITE) i=ival(words(1)) j=ival(words(2)) if (i > nrows) nrows=i if (j > nrows) nrows=j end do end if call rewind_port(port, ioerr) ii=int(nrows, kind=8) nel=ii*(ii+1)/2 allocate(mat(nel), invmat(nel), stat=ioerr) if (ioerr /= 0) then write(outstr,'(a)') 'ERROR: could not allocate matrix to invert!' call close_port(port, ioerr) return end if write(outstr,'(/a,i0,a)') & '# Inverse of symmetric matrix with ', nrows, ' rows:' matrank=nrows mat=0.0d0 do i=1, header call readline(port, buffer, ios=ioerr) end do do call readline(port, buffer, ios=ioerr) if (ioerr /= 0) exit narg=4 call args(buffer, narg, words, ' ', SEP_WHITE) i=ival(words(1)) j=ival(words(2)) val=fval(words(narg)) mat(clcpos(i,j))=val end do if (ridge_constant > 0.0d0) then ii=0 do i=1, nrows ii=ii+i mat(ii)=mat(ii)+ridge_constant end do end if if (typ > 2) then call geninv(mat, nrows, invmat, logdet, matrank, ioerr) else if (invalg == 0) then call syminv(mat, nrows, invmat, logdet, ioerr) else ioerr=0 call gibinv(mat, nrows, invmat, logdet, invalg, plevel) end if if (ioerr /= 0) then write(outstr,*) & 'Problem inverting matrix:', mat(1:5), '... IFAULT=', ioerr else if (mod(typ,2) == LOWER_TRI) then write(outstr,'(a, i0)') '# rank=', mrank write(outstr,'(a)', advance='no') '# logDet=' write(outstr,*) logdet ii=0 do i=1, nrows do j=1, i ii=ii+1 write(outstr,*) i, j, invmat(ii) end do end do else write(outstr,*) logdet ii=0 do i=1, nrows do j=1, i ii=ii+1 write(outstr,*) j, i, invmat(ii) end do end do end if end if call close_port(port, ioerr) end subroutine wrinverse ! ! Fisher combination of P values on each line of a file ! subroutine fisherp(fil, firstcol) use outstream use fileio use scanner use statfuns character (len=*), intent(in) :: fil integer, intent(in) :: firstcol integer, parameter :: BUFLEN=1024 character (len=BUFLEN) :: buffer character (len=40), dimension(10) :: words type (ioport) :: port integer :: df, i, ioerr, narg, pos double precision :: chisq, pval, val ! functions logical :: ismiss, isreal, zerop character (len=6) :: pstring double precision :: fval call open_port(fil, port, 'r', ioerr) if (ioerr /= 0) then write(outstr,'(3a,i0,a)') 'Cannot open "', trim(fil), '" ioerr=', ioerr, '.' return end if do call readline(port, buffer, ios=ioerr) if (ioerr /= 0) exit narg=10 call args(buffer, narg, words, ' ', SEP_WHITE) chisq=0.0d0 df=0 zerop=.false. do i=firstcol, narg if (.not.ismiss(words(i))) then if (isreal(words(i))) then df=df+1 val=fval(words(i)) if (val <= 0.0d0) then zerop=.true. else chisq=chisq+log(val) end if end if end if end do if (zerop) then pval=0.0d0 else chisq=-chisq-chisq pval=chip(chisq, 2*df) end if write(outstr,'(a,1x,i0,1x,a)') trim(buffer), df, pstring(pval) end do call close_port(port, ioerr) end subroutine fisherp ! ! Combine multiple files (one per study) containing beta, se into single wide ! format for the Metasoft program ! the master list of loci is contained in loc ! subroutine tometasoft(lin, plevel) use outstream use fileio use scanner use string_utilities use statfuns use nucleotides use locus_data implicit none character (len=*), intent(in) :: lin integer, intent(in) :: plevel integer, parameter :: TWRK=7, MISS=-9999 integer, parameter :: BUFLEN=4096, NTERMS=7 character (len=BUFLEN) :: buffer, curfil character (len=40) :: curloc, curval character (len=40), dimension(20) :: words character (len=40), dimension(NTERMS) :: colnames integer, dimension(NTERMS) :: termpos character (len=3) :: all1, all2, altall, map_altall, map_refall, refall double precision :: oddsr, pval, val double precision, dimension(:,:), allocatable :: beta, ase type (ioport) :: port integer :: f, fpos, i, ievery, ioerr, j, narg, nfil, n, nb, nse, nlines, pos integer (kind=8) :: ncomplete ! functions double precision :: fval colnames(1)='SNP' colnames(2)='A1' colnames(3)='A2' colnames(4)='BETA' colnames(5)='OR' colnames(6)='SE' colnames(7)='P' wloc=0 ievery=1000000 if (plevel == 1) then ievery=100000 else if (plevel > 1) then ievery=10000 end if nfil=countargs(trim(lin), ' ', SEP_WHITE)-2 allocate(beta(nloci, nfil), ase(nloci, nfil)) beta=MISS ase=MISS fpos=2 each_file: do f=1, nfil fpos=fpos+1 call get_filnam(lin, fpos, curfil) call open_port(curfil, port, 'r', ioerr) if (ioerr /= 0) then write(outstr,'(3a,i0,a)') 'Cannot open "', trim(curfil), '" ioerr=', ioerr, '.' else call readline(port, buffer, ios=ioerr) narg=countargs(trim(buffer), ' ', SEP_WHITE) call args(buffer, narg, words, ' ', SEP_WHITE) n=0 nb=0 nse=0 termpos=0 do i=1, narg call toupper(words(i)) if (words(i) == 'SNP') then if (termpos(1) == 0) n=n+1 termpos(1)=i else if (words(i) == 'AL1' .or. words(i) == 'A1' .or. words(i) == 'REF') then if (termpos(2) == 0) n=n+2 termpos(2)=i else if (words(i) == 'AL2' .or. words(i) == 'A2' .or. words(i) == 'ALT') then if (termpos(3) == 0) n=n+4 termpos(3)=i else if (words(i) == 'BETA') then if (termpos(4) == 0) nb=nb+1 termpos(4)=i else if (words(i) == 'OR' .or. words(i) == 'ODDSR' .or. words(i) == 'ODDSRATIO') then if (termpos(5) == 0) nb=nb+2 termpos(5)=i else if (words(i) == 'SE' .or. words(i) == 'ASE' .or. words(i) == 'STDERR') then if (termpos(6) == 0) nse=nse+1 termpos(6)=i else if (words(i) == 'P' .or. words(i) == 'PRB' .or. words(i) == 'PVAL') then if (termpos(7) == 0) nse=nse+2 termpos(7)=i end if if (n == 7 .and. nb > 0 .and. nse > 0) exit end do if (n == 7 .and. nb > 0 .and. nse > 0) then write(outstr,'(/2a/a)') 'File: ', trim(curfil), & 'Variable Column' do j=1, NTERMS if (termpos(j) > 0) then write(outstr,'(a10,1x,i6)') words(termpos(j)), termpos(j) end if end do nlines=0 do call readline(port, buffer, ios=ioerr) if (ioerr /= 0) exit nlines=nlines+1 call getword(buffer, termpos(1), curloc) call find_hashtab(trim(curloc), loc, lochash, pos) if (pos > 0) then wloc(pos)=wloc(pos)+1 call get_refalleles(locnotes(pos), map_refall, map_altall) call getword(buffer, termpos(2), refall) call getword(buffer, termpos(3), altall) call toupper(map_refall) call toupper(map_altall) call toupper(refall) call toupper(altall) val=0.0d0 if (termpos(4) > 0) then call getword(buffer, termpos(4), curval) val=fval(curval) else if (termpos(5) > 0) then call getword(buffer, termpos(5), curval) oddsr=fval(curval) val=log(oddsr) end if beta(pos,f)=val ! simple swap if (refall == map_altall .and. altall == map_refall) then beta(pos,f)=-beta(pos,f) ! strand and allele swap elseif (complement(refall) == map_altall .and. & complement(altall) == map_refall .and. & complement(refall) /= altall) then beta(pos,f)=-beta(pos,f) end if val=0.0d0 if (termpos(6) > 0) then call getword(buffer, termpos(6), curval) val=fval(curval) else if (termpos(7) > 0) then call getword(buffer, termpos(7), curval) pval=fval(curval) if (pval >= 0.0d0 .and. pval <= 1.0d0) then val=abs(beta(pos,f))/ppnd(1.0d0-pval) end if end if ase(pos,f)=val end if if (plevel > -1 .and. mod(nlines, ievery) == 0) then write(outstr, '(a,1x,a,i0,1x,a)') trim(curfil), 'Line ', nlines, buffer(1:40) end if end do else do i=1, NTERMS if (termpos(i) == 0) then write(outstr,'(5a/7x,a)') & 'ERROR: Missing "', trim(colnames(i)), '" column in ', & trim(curfil), ':', trim(buffer) end if end do end if end if call close_port(port, ioerr) end do each_file ! open(TWRK, file='sp-metasoft.dat') n=0 ncomplete=0 do i=1, nloci if (wloc(i) > 0) then n=n+1 write(TWRK,'(a)', advance='no') trim(loc(i)) do j=1, nfil if (beta(i,j) /= MISS .and. ase(i,j) > 0.0d0) then ncomplete=ncomplete+1 write(TWRK, '(1x,g12.4,1x,g12.4)', advance='no') beta(i,j), ase(i,j) else write(TWRK,'(a)', advance='no') ' NA NA' end if end do write(TWRK,*) end if end do close(TWRK, status='keep') write(outstr, '(/a,i0,a,i0,a)') & 'Wrote data for ', n, ' markers, ', ncomplete, ' statistics, to sp-metasoft.dat' end subroutine tometasoft ! ! write Sib-pair locus declarations ! subroutine sibloci(ostr, nloci, loc, loctyp, outpos, group, map, locnotes) use interrupt use string_utilities use locus_types use categorical_data integer, intent(in) :: ostr integer, intent(in) :: nloci character (len=20), dimension(nloci), intent(in) :: loc integer, dimension(nloci), intent(in) :: loctyp integer, dimension(nloci), intent(in) :: outpos character (len=*), dimension(nloci), intent(inout) :: group double precision, dimension(nloci), intent(in) :: map character (len=*), dimension(nloci), intent(in) :: locnotes integer, parameter :: MISS = -9999 integer :: i, ltyp character(len=16) :: mappos character (len=512) :: annot do i=1, nloci if (isactive(loctyp(i))) then ltyp=mod(loctyp(i), LOC_CMP) mappos='.' if (map(i) /= MISS) then write(mappos,'(f12.6)') map(i) if (group(i) /= ' ') then mappos=adjustl(trim(adjustl(group(i))) // ':' // trim(adjustl(mappos))) end if end if if (ismarker(ltyp)) then write(ostr,'(2(a,1x),a12,2(1x,a))') & 'set locus', loc(i), adjustl(typlloc(ltyp)), trim(mappos), trim(locnotes(i)) else if (istrait(ltyp)) then annot=get_notes(loc(i), locnotes(i)) call escape(annot, ';') write(ostr,'(2(a,1x),a12,2(1x,a))') & 'set locus', loc(i), adjustl(typlloc(ltyp)), trim(mappos), trim(annot) end if end if end do end subroutine sibloci ! ! Write FImpute SNPinfo file ! Note requires 2 or fewer alleles ! subroutine fimpmap(ostr, chip, dataset) use outstream use ped_class use locus_types use locus_data use alleles_class use contingency_table use categorical_data implicit none integer, intent(in) :: ostr integer, intent(in) :: chip type (ped_data) :: dataset integer, parameter :: MISS = -9999 type (allele_data) :: allele_buffer type (table_data) :: traittable integer :: i, j, k, nchips, nsnps, ped, pos, tpos character(len=20) :: cval double precision, dimension(1) :: val integer, dimension(:), allocatable :: chip_pos logical, dimension(:), allocatable :: chip_fnd ! functions integer :: tobp tpos=locpos(chip) call setup_table(1, 30, traittable) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (dataset%plocus(i,tpos) /= MISS) then val(1)=dataset%plocus(i,tpos) call insert_table(1, val, traittable, 1) end if end do end if end do nchips=traittable%ncells allocate(chip_pos(nchips)) allocate(chip_fnd(nchips)) chip_pos=0 write(ostr,'(a)', advance='no') 'SNP Chr Pos' do k=1, nchips pos=traittable%idx(k) call wrtrait(traittable%categories(pos,1)%rvalue, cval, & loctyp(chip), get_notes(loc(chip), & locnotes(chip)), 9, 0) write(ostr, '(1x,a)', advance='no') trim(cval) end do write(ostr,*) nsnps=0 do j=1, nloci if (isactive(loctyp(j)) .and. ismarker(loctyp(j))) then call freq(locpos(j), loctyp(j), 0, dataset, allele_buffer) if (allele_buffer%numal <= 2) then if (map(j) /= MISS) then nsnps=nsnps+1 call onchip(tpos, locpos(j), nchips, traittable, chip_fnd, dataset) write(ostr,'(a,11x,a2,1x,i12)', advance='no') & loc(j), group(j), tobp(map(j)) do k=1, nchips if (chip_fnd(k)) then chip_pos(k)=chip_pos(k)+1 write(ostr, '(1x,i0)', advance='no') chip_pos(k) else write(ostr, '(a)', advance='no') ' 0' end if end do write(ostr,*) end if end if end if end do write(outstr,'(a,i0,a)') 'Declared ', nsnps, ' loci (<= 2 alleles).' end subroutine fimpmap ! ! Indicate categories that include typed second trait ! subroutine onchip(trait, gene, nchips, traittable, chip_fnd, dataset) use ped_class use contingency_table implicit none integer, intent(in) :: trait, gene, nchips type (table_data), intent(in) :: traittable logical, dimension(nchips), intent(out) :: chip_fnd type (ped_data), intent(in) :: dataset integer, parameter :: MISS = -9999 integer :: i, iaff, nfnd, ped nfnd=0 chip_fnd=.false. mainloop: do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (dataset%plocus(i,trait) /= MISS .and. observed(i, gene, dataset)) then iaff=findlev(dataset%plocus(i,trait), traittable) if (.not.chip_fnd(iaff)) then nfnd=nfnd+1 chip_fnd(iaff)=.true. if (nfnd == nchips) exit mainloop end if end if end do end if end do mainloop end subroutine onchip ! ! Write map ! ! 10 = table for Sib-pair output ! 0 = LINKAGE ! 1 = LINKAGE plus dummy binary trait ! 2 = GENEHUNTER plus dummy binary trait ! 3 = GENEHUNTER ! 4 = MENDEL ! 14 = MENDEL free format ! 20 = MENDEL .var file ! 21 = MENDEL SNP DEF file ! 5 = ASPEX ! 6 = MERLIN ! 7 = LOKI ! 8 = STRUCTURE ! 9 = SOLAR ! 11 = MORGAN ! 12 = Haploview ! 13 = PLINK ! 22 = hapfind ! 23 = BLUPF90 ! subroutine wrmap(ostr, typ, mapf) use interrupt use outstream use automatic_data use genetic_maps use scanner use locus_types use locus_data integer, intent(in) :: ostr integer, intent(in) :: typ integer, intent(in) :: mapf integer, parameter :: MISS=-9999 integer :: i, j, k, narg ! hasfilter marks whether map should be filtered using ! value of locstat logical :: frst, hasfilter character (len=21), dimension(1) :: tnam character (len=2) :: chr character (len=3) :: all1, all2 character (len=7) :: mapfmt integer :: bpdist double precision :: dir, dist ! functions logical :: isint, isreal integer :: ival , tobp double precision :: fval ! show map bpdist=0 dist=0.0d0 chr=' ' dir=MISS frst=.true. hasfilter=.false. mapfmt=mapformat(mapunits, '12') if (typ == 10) then write(outstr,'(/a//3a/a)') & 'User specified marker map:', & 'Marker Pos (', mapunitname(mapunits) , & ') Theta Chrom' , & '---------------- ------------ ----- -----' do k=1, nord i=locord(k) if (isactive(loctyp(i))) then if (map(i) /= MISS) then if (frst) then frst=.not.frst dist=0.0d0 else dist=map(i)-dist if (dir == MISS) dir=sign(1.0d0,dist) end if if (dir*dist < 0.0d0 .or. & (chr /= ' ' .and. group(i) /= ' ' .and. & group(i) /= chr)) then dist=1000.0 end if write(outstr,'(a20)', advance='no') loc(i) write(outstr, mapfmt, advance='no') map(i)/mapconstant if (ishaploid(loctyp(i))) then write(outstr,'(4x,a1,8x,a,3x,a)') & 'x' , group(i), trim(locnotes(i)) else write(outstr,'(f8.3,5x,a,3x,a)') & invmap(dist,mapf), group(i), trim(locnotes(i)) end if dist=map(i) chr=group(i) else if (ismarker(loctyp(i))) then write(outstr,'(a15,5x,a1,10x,a1,8x,a,3x,a)') & loc(i), 'x', 'x', group(i), trim(locnotes(i)) end if end if if (irupt > 0) exit end do write(outstr,*) ! write Linkage or Genehunter locus file map else if (typ >= 0 .and. typ <= 3) then dist=MISS if (typ == 1 .or. typ == 2) write(ostr,'(a,$)') ' .000' do k=1, nord i=locord(k) if (isactive(loctyp(i)) .and. .not.isspecial(loctyp(i))) then if (frst) then frst=.not.frst else if (dist /= MISS .and. map(i) >= dist) then if (typ == 2 .or. typ == 3) then write(ostr,'(1x,f6.3)', advance='no') max(0.01d0, map(i)-dist) else write(ostr,'(1x,f6.4)', advance='no') invmap(map(i)-dist, mapf) end if else if (typ == 2 .or. typ == 3) then write(ostr,'(a,$)') ' 0.0' else write(ostr,'(a,$)') ' .4999' end if end if dist=map(i) end if end do ! MENDEL map file else if (typ == 4) then do i=ENVNUM+1, nloci if (isactive(loctyp(i))) then if (frst) then frst=.not.frst else if (dist /= MISS .and. map(i) >= dist .and. & (group(i) == chr .or. group(i) == ' ')) then dist=map(i)-dist write(ostr,'(8x,f8.4,f8.4)') invmap(dist,mapf), invmap(dist,mapf) else write(ostr,'(8x,f8.4,f8.4)') 0.5, 0.5 end if if (group(i) /= ' ') chr=group(i) dist=map(i) call shorten(i, nloci, loc, 8, tnam(1)) write(ostr,'(a8)') tnam(1) end if end do ! MENDEL map file free format for MENDEL 8.0 else if (typ == 14) then do i=ENVNUM+1, nloci if (isactive(loctyp(i))) then if (frst) then frst=.not.frst else if (dist /= MISS .and. map(i) >= dist .and. & (group(i) == chr .or. chr == ' ')) then dist=map(i)-dist write(ostr,'(8x,f8.4,1x,f8.4)') invmap(dist,mapf), invmap(dist,mapf) else write(ostr,'(8x,f8.4,1x,f8.4)') 0.5, 0.5 end if if (group(i) /= ' ') chr=group(i) dist=map(i) write(ostr,'(a)') loc(i) end if end do ! MENDEL var file else if (typ == 20) then do i=1, nloci if (same_loctyp(loctyp(i), LOC_QUA)) then call shorten(i, nloci, loc, 8, tnam(1)) write(ostr,'(a8)') tnam(1) end if end do ! MENDEL SNP Def file else if (typ == 21) then write(ostr,'(a)') ' 3.00 = FILE FORMAT VERSION NUMBER.' do i=ENVNUM+1, nloci if (isactive(loctyp(i)) .and. ismarker(loctyp(i))) then if (map(i) /= MISS) then bpdist=int(1.0d6*(map(i))) else bpdist=bpdist+1 end if write(ostr,'(4a,i0)') loc(i), ',', group(i), ',', bpdist end if end do ! ASPEX map else if (typ == 5) then k=0 write(ostr,'(a,$)') 'set dist {' do i=1, nloci if (isactdip(loctyp(i))) then k=k+1 if (map(i) /= MISS .and. map(i) >= dist) then write(ostr, '(1x,f5.3,$)') max(0.001, 0.01*(map(i)-dist)) dist=map(i) else if (dist == 0.0d0) then write(ostr,'(a,$)') ' 0.001' dist=-100.0d0 else write(ostr,'(a,$)') ' 0.50' dist=-100.0d0 end if if (k == 6) then k=0 write(ostr,'(/a,$)') ' ' end if end if end do write(ostr,'(a)') ' 0.01 }' ! MERLIN map file else if (typ == 6) then chr='1 ' do i=1, nloci if (isactdip(loctyp(i))) then if (map(i) /= MISS) then if (group(i) /= ' ') chr=group(i) write(ostr,'(a,1x,a,1x,f12.6)') chr, loc(i), map(i) dist=map(i) else write(ostr,'(a,1x,a,1x,f12.6)') chr ,loc(i), 1000.0d0+dist dist=dist+1000.0d0 end if end if end do ! LOKI parameter file map positions else if (typ == 7) then write(ostr,'(a/a//a,f9.3/)') & 'iterations 1000', 'start output 50,1', 'total map 3600.0' do i=1, nloci if (same_loctyp(loctyp(i), LOC_CODOM) .and. map(i) /= MISS) then call addlet(loc(i), tnam(1)) write(ostr,'(a,a20,f9.3)') 'position ', tnam(1), map(i) end if end do ! STRUCTURE datafile map positions else if (typ == 8) then do i=1, nloci if (isactdip(loctyp(i))) then write(ostr,'(1x,a,$)') loc(i) end if end do write(ostr,'(a)') ' ' do i=1, nloci if (isactdip(loctyp(i))) then if (frst) then frst=.not.frst write(ostr,'(1x,a2,$)') '-1' else if (dist /= MISS .and. map(i) >= dist) then dist=map(i)-dist write(ostr,'(1x,f7.2,$)') dist else write(ostr,'(1x,a2,$)') '-1' end if dist=map(i) end if end do write(ostr,*) ! SOLAR map file else if (typ == 9) then write(ostr,'(a)') '1' do i=1, nloci if (isactdip(loctyp(i))) then if (map(i) /= MISS) then write(ostr,'(a,f9.3)') loc(i), map(i) dist=map(i) else write(ostr,'(a,f9.3)') loc(i), 1000.0d0+dist dist=dist+1000.0d0 end if end if end do ! MORGAN map positions -- all on one line (per chromosome) else if (typ == 11) then write(ostr,'(a)', advance='no') 'map markers position' do i=1, nloci if (same_loctyp(loctyp(i), LOC_CODOM) .and. map(i) /= MISS) then write(ostr,'(1x,f9.3)', advance='no') map(i) end if end do write(ostr,*) ! ! Haploview info file -- marker name, coordinate [, annotation] ! Filled from annotation, if first word looks like to be sequence position, ! or from map, assuming 1 cM=1 Mbp ! else if (typ == 12) then do i=1, nloci if (isactdip(loctyp(i))) then narg=1 call args(locnotes(i), narg, tnam, ' ', SEP_WH_RES) if (isint(tnam(1))) then bpdist=ival(tnam(1)) else if (map(i) /= MISS) then bpdist=tobp(map(i)) end if write(ostr,'(a,i10)') loc(i), bpdist end if end do write(ostr,*) ! ! PLINK format ! Note that if the last column of the locus annotation is an integer, then ! Sib-pair thinks this is the bp genomic position, so one can provide ! a genetic and a genomic coordinate map. This is only if ! the chosen mapunits are "cM" or "M" ! else if (typ == 13) then chr='1 ' do i=1, nloci if (isactive(loctyp(i)) .and. ismarker(loctyp(i))) then if (map(i) /= MISS) then if (group(i) /= ' ') chr=group(i) if (chr == 'X' .and. same_loctyp(loctyp(i), LOC_CODOM)) then chr='XY' end if dist=map(i) narg=1 call args(locnotes(i), narg, tnam, ' ', SEP_WH_RES) if (isint(tnam(1)) .and. mapunits < 3) then bpdist=ival(tnam(1)) else bpdist=tobp(dist) end if call get_refalleles(locnotes(i), all1, all2) else bpdist=bpdist+1 end if write(ostr,'(a,1x,a,1x,f14.6,1x,i10,1x,a,1x,a)') & chr, loc(i), dist, bpdist, all1, all2 end if end do write(ostr,*) ! hapfind chromosome.data file else if (typ == 22) then write(ostr,'(a)') 'SNPname chrome within overall location n_chips chip1' chr='1 ' j=0 k=0 do i=1, nloci if (isactive(loctyp(i)) .and. ismarker(loctyp(i))) then if (map(i) /= MISS) then if (group(i) /= ' ') then if (chr /= group(i)) k=0 chr=group(i) end if if (chr == 'X' .and. same_loctyp(loctyp(i), LOC_CODOM)) then chr='XY' end if end if j=j+1 k=k+1 write(ostr,'(a,1x,a,1x,i0,1x,i0,1x,i12,1x,a,1x,i0)') & loc(i), chr, j, k, nint(1000000*map(i)), '1', j end if end do write(ostr,*) ! BLUPF90 SNP map file ! SNP_ID - identification of the SNP (alphanumeric) ! CHR - chromosome number (numeric), starting from 1 ! POS - position bp (numeric) ! else if (typ == 23) then hasfilter=(whichstat(1:11) == 'Output SNPs') write(ostr,'(a)') 'SNP_ID CHR POS' chr='1 ' if (hasfilter) then do i=1, nloci if (locstat(i) /= MISS) then if (map(i) /= MISS) then if (group(i) /= ' ') then chr=group(i) end if if (chr == 'X' .and. same_loctyp(loctyp(i), LOC_CODOM)) then chr='XY' end if end if write(ostr,'(a,1x,a,1x,i12)') & loc(i), chr, nint(1000000*map(i)) end if end do else do i=1, nloci if (isactive(loctyp(i)) .and. ismarker(loctyp(i))) then if (map(i) /= MISS) then if (group(i) /= ' ') then chr=group(i) end if if (chr == 'X' .and. same_loctyp(loctyp(i), LOC_CODOM)) then chr='XY' end if end if write(ostr,'(a,1x,a,1x,i12)') & loc(i), chr, nint(1000000*map(i)) end if end do end if end if end subroutine wrmap ! ! Write out pedigree header with locus names ! either multiline (typ=1) or simple ! subroutine pedhead(strm, typ, pedmask, name_widths, name_formats, & nwid, ncatvars, labwidths, nloci, loc, loctyp) use locus_types use automatic_data integer, intent(in) :: strm integer, intent(in) :: typ logical, dimension(:), intent(in) :: pedmask integer, dimension(4), intent(in) :: name_widths character (len=*), dimension(4), intent(in) :: name_formats integer, intent(in) :: nwid integer, intent(in) :: ncatvars integer, dimension(*), intent(in) :: labwidths integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp ! local variables integer :: catidx, eos, i, j, k, pos, wid character (len=3) :: sex = 'sex' character (len=8), dimension(4) :: words = & (/ 'pedigree', 'id ', & 'father ', 'mother ' /) if (typ == 1) then do i=1, 3 write(strm,'(a)', advance='no') '!' k=0 do j=1, 4 if (pedmask(j)) then k=k+1 wid=name_widths(j) if (k == 1) wid=name_widths(j)-2 call onestripe(strm, i, 3, wid, words(j), 1) end if end do if (pedmask(5)) then write(strm,'(1x,a)', advance='no') sex(i:i) end if catidx=0 do j=1, nloci if (isactive(loctyp(j))) then if (ismarker(loctyp(j))) then call onestripe(strm, i, 3, 7, loc(j), 0) else if(loctyp(j) == LOC_QUA) then call onestripe(strm, i, 3, nwid, loc(j), 0) else if(loctyp(j) == LOC_CAT) then if (ncatvars == 0) then catidx=1 else catidx=catidx+1 end if call onestripe(strm, i, 3, labwidths(catidx), loc(j), 0) else if(loctyp(j) == LOC_AFF) then call onestripe(strm, i, 3, 1, loc(j), 0) end if end if end do write(strm,*) end do write(strm,'(a)') '!' else if (typ == 2) then do j=1, 4 if (pedmask(j)) then write(strm, '(a,1x)', advance='no') trim(words(j)) end if end do if (pedmask(5)) then write(strm, '(a,1x)', advance='no') sex end if do j=ENVNUM+1, nloci if (isactive(loctyp(j))) then write(strm, '(a,1x)', advance='no') trim(loc(j)) end if end do write(strm,*) end if end subroutine pedhead ! ! Writing a string within a given rectangle: one line ! subroutine onestripe(strm, linenum, totlines, width, string, truncate) integer, intent(in) :: strm integer, intent(in) :: linenum, totlines, width character (len=*), intent(in) :: string integer, intent(in) :: truncate integer :: height, lev, slen, pos, sta, fin character (len=width) :: sbuffer if (width <= 0) then write(strm,'(a)', advance='no') ' ' return end if sbuffer=' ' slen=len_trim(string) if (truncate > 0 .and. width > truncate) then if (linenum < totlines) then sbuffer=repeat(' ', width) else sbuffer=string(1:min(slen,width)) end if else height=slen/width+1 lev=linenum+min(totlines, height)-totlines if (slen > width .and. slen <= totlines) then sbuffer=repeat(' ', width/2) // string(linenum:linenum) else if (lev > 0) then sta=1+width*(lev-1) fin=min(sta+width-1, slen) sbuffer=string(sta:fin) else sbuffer=repeat(' ', width) end if end if call juststr('c', sbuffer, width) write(strm,'(1x,a)', advance='no') sbuffer end subroutine onestripe ! ! Write out GAS style pedigree ! header=print variable names as header ! pedmask=control printing of ped,id,fa,mo,sex fields ! fieldsep=field separator ! allsep=allele separator ! imp=show imputed genotypes ! nwid,ndec=format for quantitative trait values ! misval=missing data token ! nrc=number of records to print ! skip=number of records to skip at beginning ! filter=(1=show all) (2=flagged) ! show_cat=(1=levels) (2=labels) ! subroutine pedout(strm, header, pedmask, fieldsep, allsep, imp, nwid, ndec, & ncatwid, sexcode, misval, nrc, skip, filter, show_cat, & nloci, loc, loctyp, locpos, locnotes, dataset) use interrupt use scanner use ped_class use locus_types use categorical_data integer, intent(in) :: strm integer, intent(in) :: header logical, dimension(:), intent(in) :: pedmask character (len=1), intent(in) :: fieldsep character (len=1), intent(in) :: allsep integer, intent(in) :: imp integer, intent(in) :: ncatwid, nwid integer, intent(in) :: ndec character (len=*), dimension(2), intent(in) :: sexcode character (len=*), intent(in) :: misval integer, intent(in) :: nrc, skip, filter, show_cat integer, intent(in) :: nloci character (len=*), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=*), dimension(:), intent(in) :: locnotes type (ped_data) :: dataset integer, parameter :: KNOWN=0, MISS=-9999 ! Categorical trait levels type (cat_data) :: categories integer :: ncatvars integer, dimension(nloci) :: catidx integer, dimension(:), allocatable :: labwidths ! local variables character (len=8) :: adec, fdec, idec character (len=10) :: cdec character (len=7) :: loc7, mis7 character (len=10) :: formid1, formid2, formid3, formid4 character (len=80) :: str character (len=nwid) :: bigmiss character (len=3), dimension(4) :: name_formats integer, dimension(4) :: name_widths integer :: fin, g1, g2, i, j, llen, nobs, pos, sta logical :: noimp, qwrite double precision :: toobig, x ! functions interface subroutine pedhead(strm, typ, pedmask, name_widths, name_formats, nwid, & ncatvars, labwidths, nloci, loc, loctyp) integer, intent(in) :: strm integer, intent(in) :: typ logical, dimension(:), intent(in) :: pedmask integer, dimension(4), intent(in) :: name_widths character (len=*), dimension(4), intent(in) :: name_formats integer, intent(in) :: nwid integer, intent(in) :: ncatvars integer, dimension(*), intent(in) :: labwidths integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp end subroutine pedhead end interface interface subroutine juststr(just, string, length) character (len=1), intent(in) :: just character (len=*), intent(inout) :: string integer, intent(in) :: length end subroutine juststr end interface ! quantitative variable format call wrform('f', nwid, ndec, fdec) call wrform('i', nwid, ndec, idec) call wrform('a', nwid, ndec, adec) call wrform('a', ncatwid, ndec, cdec) toobig=dble(10**(nwid-ndec-1)) ! ID string widths call idwidths(dataset, name_widths, name_formats) formid1='(' // trim(name_formats(1)) // ')' formid2='(' // trim(name_formats(2)) // ')' formid3='(' // trim(name_formats(3)) // ')' formid4='(' // trim(name_formats(4)) // ')' ! ! extract categorical trait levels if necessary ! this will allow locus specific print widths ncatvars=0 if (show_cat == 2) then do i=1, nloci if (isactive(loctyp(i)) .and. iscattrait(loctyp(i))) then ncatvars=ncatvars+1 catidx(ncatvars)=i end if end do call load_cat_levels(ncatvars, catidx, categories) allocate(labwidths(ncatvars)) do i=1, ncatvars labwidths(i)=categories%longest_label(i) llen=len_trim(loc(catidx(i))) if (llen > labwidths(i) .and. (llen-labwidths(i)) < 4) then labwidths(i)=llen end if end do else allocate(labwidths(1)) labwidths=ncatwid end if if (strm == 6 .or. header > 1) then call pedhead(strm, header, pedmask, name_widths, name_formats, & nwid, ncatvars, labwidths, nloci, loc, loctyp) end if bigmiss=' ' pos=nwid-ndec bigmiss(pos:pos+len_trim(misval)-1)=misval if (allsep == ' ') then mis7=trim(misval) // ' ' // trim(misval) else mis7=trim(misval) // trim(allsep) // trim(misval) end if call juststr('c', mis7, 7) noimp=(imp /= 2) sta=1+skip fin=dataset%nobs if (sta > fin) return nobs=0 if (nrc /= 0) then if (nrc>0) then fin=sta do if (dataset%actset(dataset%iped(fin)) > 0) then nobs=nobs+1 end if if (nobs==nrc .or. fin==dataset%nobs) exit fin=fin+1 end do else sta=fin do if (dataset%actset(dataset%iped(sta)) > 0) then nobs=nobs-1 end if if (nobs==nrc .or. sta==1) exit sta=sta-1 end do end if end if if (filter == 1) then do i=sta, fin dataset%untyped(i)=(dataset%actset(dataset%iped(i)) <= 0) end do end if do i=sta, fin if (.not.dataset%untyped(i)) then ! compulsory data if (pedmask(1)) then write(strm, formid1, advance='no') dataset%pedigree(dataset%iped(i)) end if if (pedmask(2)) then if (pedmask(1)) write(strm,'(a1)', advance='no') fieldsep write(strm, formid2, advance='no') dataset%id(i) end if if (pedmask(3)) then write(strm,'(a1)', advance='no') fieldsep if (dataset%fa(i) == MISS) then write(strm, formid3, advance='no') trim(misval) // ' ' else write(strm, formid3 ,advance='no') dataset%id(dataset%fa(i)) end if end if if (pedmask(4)) then write(strm,'(a1)', advance='no') fieldsep if (dataset%mo(i) == MISS) then write(strm, formid4, advance='no') trim(misval) // ' ' else write(strm, formid4, advance='no') dataset%id(dataset%mo(i)) end if end if if (pedmask(5)) then write(strm,'(a1)', advance='no') fieldsep if (dataset%sex(i) == 1 .or. dataset%sex(i) == 2) then write(strm,'(1x,a)',advance='no') sexcode(dataset%sex(i)) else write(strm,'(1x,a)',advance='no') trim(misval) end if end if ! phenotypes ncatvars=0 do j=1, nloci if (isactive(loctyp(j))) then if (.not.isspecial(loctyp(j))) then write(strm,'(a)',advance='no') fieldsep end if ltyp=mod(loctyp(j), LOC_CMP) if (ltyp ==LOC_CODOM .or. ltyp == LOC_XLIN .or. ltyp == LOC_HAP .or. & ltyp == LOC_MIT .or. ltyp == LOC_YHA) then call get_geno(i, locpos(j), locpos(j)+1, dataset, g1, g2) if (g1 == MISS .or. (noimp .and. g1 <= KNOWN)) then loc7=mis7 else call wrgtp(abs(g1), abs(g2), loc7, allsep, '', 3) end if write(strm,'(a)',advance='no') loc7 else if (ltyp == LOC_QUA .or. ltyp == LOC_CAT) then qwrite=.true. x=dataset%plocus(i,locpos(j)) if (ltyp == LOC_CAT) then ncatvars=ncatvars+1 if (show_cat == 2) then call wrform('a', labwidths(ncatvars), ndec, cdec) if (x == MISS) then str=misval write(strm, cdec, advance='no') str qwrite=.false. else call get_label_tab(x, categories%cat_tables(ncatvars), str) qwrite=(str == ' ') if (.not.qwrite) then write(strm, cdec, advance='no') str end if end if end if end if if (qwrite) then if (x == MISS) then write(strm,'(a)',advance='no') bigmiss else if (x >= toobig .or. (x < 0.0d0 .and. -10.0d0*x >= toobig)) then if (anint(x) == x) then write(strm, idec, advance='no') int(x) else write(strm,'(g12.6)',advance='no') x end if else if (anint(x) == x) then write(strm, idec, advance='no') int(x) else write(strm, fdec,advance='no') x end if end if end if end if else if (ltyp == LOC_AFF) then if (dataset%plocus(i,locpos(j)) == MISS .or. & dataset%plocus(i,locpos(j)) == 0.0d0) then write(strm,'(a)',advance='no') trim(misval) else if(dataset%plocus(i,locpos(j)) == 1.0d0) then write(strm,'(a)',advance='no') 'n' else if(dataset%plocus(i,locpos(j)) == 2.0d0) then write(strm,'(a)',advance='no') 'y' end if end if end if end do write(strm,*) if (irupt > 0) return end if end do end subroutine pedout ! ! write out Linkage type file pre- or post- Makeped style ! ! style typ property ! --------- --- -------- ! lin, pre 1 ! ppd 2 extra pedigree pointer fields ! gh 3 MISS='-', ordering binary_trait1, marker1...markerN, quantitative traits ! asp, tcl 4 marker names prepended to file ! hap 5 SNP alleles coded ACGT 1234 ! mer 6 If present, zygosity indicator in column 6: 1,3,5...for each MZ set ! ! pre: ped id fa mo sex ... ! ppd: ped.n id.n fa.n mo.n child1.n patsibid.n matsibid.n sex proband.n ... ! where ped.n, id.n are sequential numerical ID number ! subroutine wrlink(strm, typ, imp, addummy, liabclass, & renumall, twinning, twintype, nwid, ndec, & nloci, loctyp, locpos, nord, locord, dataset) use alleles_class use ped_class use locus_types use nucleotides integer, intent(in) :: strm integer, intent(in) :: typ integer, intent(in) :: imp integer, intent(in) :: addummy integer, intent(in) :: liabclass integer, intent(in) :: renumall integer, intent(in) :: twinning integer, intent(in) :: twintype integer, intent(in) :: nwid, ndec integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos integer, intent(in) :: nord integer, dimension(:), intent(in) :: locord type (ped_data) :: dataset ! integer, parameter :: KNOWN=0, MISS=-9999 ! ! all the alleles ! type (allele_data), dimension(:), pointer :: alleles character (len=8) :: fdec, idec character (len=15) :: formid12, formid34, fped character (len=22) :: formid567 character (len=20) :: miss20 character (len=1) :: sx integer :: all3, eop, g1, g2, i, j, k, kid1, l, matsib, & nped, patsib, ped, pedoffset, pos, pro logical :: noimp character (len=3), dimension(4) :: name_formats integer, dimension(4) :: name_widths ! functions integer :: getnam interface subroutine freq(gene, loctyp, fndr, dataset, allele_buffer) use ped_class use alleles_class integer, intent(in) :: gene integer, intent(in) :: loctyp integer, intent(in) :: fndr type (ped_data), intent(in) :: dataset type (allele_data), intent(inout) :: allele_buffer end subroutine freq end interface ! noimp=(imp /= 2) ! quantitative variable format call wrform('f', nwid, ndec, fdec) call wrform('i', nwid, ndec, idec) miss20=' ' pos=min(nwid-ndec, 19) if (typ == 3 .or. typ==7) then miss20(pos:pos)='-' else miss20(pos:pos)='0' end if ! width of ID columns if (typ == 2) then write(name_formats(1), '(i3)') int(log10(dble(dataset%nped)))+1 write(name_formats(2), '(i3)') int(log10(dble(dataset%maxsiz)))+1 formid12= '(i' // trim(adjustl(name_formats(1))) // ',1x,i' // trim(adjustl(name_formats(2))) // ')' formid34='(1x,i' // trim(adjustl(name_formats(2))) // ',1x,i' // trim(adjustl(name_formats(2))) // ')' formid567='(3(1x,i' // trim(adjustl(name_formats(2))) // '),1x,a1,1x,i1)' call idwidths(dataset, name_widths, name_formats) ! pedigree names still appear at end fped='(1x,a,1x,' // trim(name_formats(1)) // ')' else call idwidths(dataset, name_widths, name_formats) formid12= '(' // trim(name_formats(1)) // ',1x,' // trim(name_formats(2)) // ')' formid34='(1x,' // trim(name_formats(3)) // ',1x,' // trim(name_formats(4)) // ')' end if ! ! Alleles for all active markers ! as recoding alleles to 1..n ! if (renumall == 1) then allocate(alleles(nloci)) do l=1, nord j=locord(l) if (same_loctyp(loctyp(j), LOC_CODOM) .or. same_loctyp(loctyp(j), LOC_XLIN)) then call freq(locpos(j), loctyp(j), 0, dataset, alleles(j)) end if end do end if ! nped=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then nped=nped+1 pedoffset=dataset%num(ped-1) ! write records do i=pedoffset+1, dataset%num(ped) sx='1' if (dataset%sex(i) == 2) sx='2' if (typ == 2) then write(strm, formid12, advance='no') nped, i-pedoffset else write(strm, formid12, advance='no') & dataset%pedigree(ped), dataset%id(i) end if if (typ == 2) then if (dataset%fa(i) == MISS) then write(strm, formid34, advance='no') 0, 0 else write(strm, formid34, advance='no') & dataset%fa(i)-pedoffset, dataset%mo(i)-pedoffset end if else if (dataset%fa(i) == MISS) then write(strm, formid34, advance='no') '0', '0' else write(strm, formid34, advance='no') & dataset%id(dataset%fa(i)), dataset%id(dataset%mo(i)) end if write(strm, '(1x,a1)', advance='no') sx end if ! ! ppd pointers if (typ == 2) then kid1=0 matsib=0 patsib=0 pro=0 if (i == pedoffset+1) pro=1 ! find first child do j=max(pedoffset+dataset%nfound(ped)+1,i+1), dataset%num(ped) if (kid1 == 0 .and. (dataset%fa(j) == i .or. dataset%mo(j) == i)) then kid1=j-pedoffset exit end if end do all3=0 ! find first paternal and maternal sibs if (i > pedoffset+dataset%nfound(ped)) then do j=i+1, dataset%num(ped) if (patsib == 0 .and. dataset%fa(j) == dataset%fa(i)) then all3=all3+1 patsib=j-pedoffset end if if (matsib == 0 .and. dataset%mo(j) == dataset%mo(i)) then all3=all3+2 matsib=j-pedoffset end if if (all3 == 3) exit end do end if write(strm, formid567, advance='no') kid1, patsib, matsib, sx, pro end if ! Add zygosity to Merlin file if appropriate ! In the MERLIN format, MZ pairs have an odd-numbered index if (typ == 7 .and. twinning /= MISS) then if (dataset%plocus(i,twinning) == MISS) then write(strm,'(a)', advance='no') ' 0' else j=int(dataset%plocus(i, twinning)) if (twintype == 1 .and. j>0) j=2*(j-1)+1 write(strm,'(1x,i1)', advance='no') j end if end if ! Add dummy binary trait when asked if (addummy == 1) then write(strm, '(a)', advance='no') ' 2' end if do l=1, nord j=locord(l) if (same_loctyp(loctyp(j), LOC_CODOM) .or. same_loctyp(loctyp(j), LOC_XLIN)) then if (noimp .and. .not.observed(i, locpos(j), dataset)) then write(strm,'(1x,a3,1x,a3)', advance='no') '0','0' else if (renumall == 1) then call get_namedgeno(i, locpos(j), locpos(j)+1, & dataset, alleles(j), g1, g2) else if (renumall == 0) then call get_geno(i, locpos(j), locpos(j)+1, dataset, g1, g2) g1=abs(g1) g2=abs(g2) else if (renumall == 2) then call get_geno(i, locpos(j), locpos(j)+1, dataset, g1, g2) g1=nttonum(g1) g2=nttonum(g2) end if write(strm,'(1x,i3,1x,i3)', advance='no') g1, g2 end if else if (loctyp(j) == LOC_QUA .or. loctyp(j) == LOC_CAT) then write(strm, '(a)', advance='no') ' ' if (dataset%plocus(i,locpos(j)) == MISS) then if (j /= liabclass) then write(strm,'(a)', advance='no') miss20(1:nwid) else write(strm, idec, advance='no') 1 end if else if (dataset%plocus(i,locpos(j)) == 0.0d0) then if (j /= liabclass) then write(strm, '(a)', advance='no') ' 0.000001' else write(strm, idec, advance='no') 1 end if else if (j /= liabclass) then write(strm, fdec, advance='no') dataset%plocus(i,locpos(j)) else write(strm, idec, advance='no') int(dataset%plocus(i,locpos(j))) end if end if else if (loctyp(j) == LOC_AFF) then if (dataset%plocus(i,locpos(j)) == 1.0D0) then write(strm, '(a)', advance='no') ' 1' else if (dataset%plocus(i,locpos(j)) == 2.0D0) then write(strm, '(a)', advance='no') ' 2' else write(strm, '(a)', advance='no') ' 0' end if end if end do if (typ == 2) then write(strm, fped, advance='no') 'Ped:', dataset%pedigree(ped) write(strm, '(1x,a,1x,a)', advance='no') 'Per:', trim(dataset%id(i)) end if write(strm, *) end do end if end do if (renumall==1) then deallocate(alleles) end if end subroutine wrlink ! ! write out Mapmaker-Sibs/FBAT/etc phenotype file ! whitespace delimited ped id trait1...traitN ! write out Mapmaker-Sibs phenotype file ! subroutine wrphe(strm, typ, nwid, ndec, & nloci, loc, loctyp, locpos, dataset) use locus_types use ped_class implicit none integer, intent(in) :: strm integer, intent(in) :: typ integer, intent(in) :: nwid integer, intent(in) :: ndec integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data) :: dataset integer, parameter :: KNOWN=0, MISS=-9999 ! local variables character (len=1) :: na, sep character (len=7) :: gtp character (len=10) :: fdec character (len=20) :: loc20 integer :: i, j, ped, pednum sep=' ' na='-' pednum=0 ! quantitative variable format call wrform('f', nwid, ndec, fdec) ! header if (typ == 1) then do i=1, nloci if (istrait(loctyp(i))) then write(strm,'(2a)', advance='no') trim(loc(i)), sep end if end do write(strm,*) else na='0' end if do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pednum=pednum+1 do i=dataset%num(ped-1)+1, dataset%num(ped) if (typ == 1) then write(strm,'(a,1x,a)', advance='no') & trim(dataset%pedigree(ped)), trim(dataset%id(i)) else write(strm,'(i0,1x,i0,1x)', advance='no') pednum, i end if do j=1, nloci if (loctyp(j) == LOC_QUA .or. loctyp(j) == LOC_CAT) then write(strm, '(a)', advance='no') sep if (dataset%plocus(i,locpos(j)) /= MISS) then write(loc20, fdec) dataset%plocus(i,locpos(j)) write(strm, '(a)', advance='no') trim(adjustl(loc20)) else write(strm,'(a)', advance='no') na end if else if (loctyp(j) == LOC_AFF) then write(strm, '(a)', advance='no') sep if(dataset%plocus(i,locpos(j)) == 1.0) then write(strm, '(a)', advance='no') '1' else if(dataset%plocus(i,locpos(j)) == 2.0) then write(strm, '(a)', advance='no') '2' else write(strm, '(a)', advance='no') na end if end if end do write(strm,*) end do end if end do end subroutine wrphe ! ! Write out pedigree as character-delimited ! typ ! 1 full pedigree ! 2 id,fa,mo,sex,ped,mztwin,hhid (for SOLAR) ! 3 ped, id, phenotype_data ! 4 id, phenotype_data ! 5 ped, id, genotype_data ! 6 id, genotype_data ! 10 full pedigree with mztwin, na=' ' (for MENDEL 8.0) ! 11 full pedigree with mztwin, na='.' (for SAS) ! subroutine wrcsv(strm, typ, pedmask, imp, nwid, ndec, sep, allsep, misval, gmisval, & twinning, twintype, nloci, loc, loctyp, locpos, locnotes, & nord, locord, dataset) use ped_class use locus_types use scanner use categorical_data implicit none integer, intent(in) :: strm integer, intent(in) :: typ logical, dimension(:), intent(in) :: pedmask integer, intent(in) :: imp integer, intent(in) :: nwid integer, intent(in) :: ndec character (len=1), intent(in) :: sep character (len=1), intent(in) :: allsep character (len=*), intent(in) :: misval, gmisval integer, intent(in) :: twinning, twintype integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=*), dimension(:), intent(in) :: locnotes integer, intent(in) :: nord integer, intent(in) :: locord(nord) type (ped_data) :: dataset integer, parameter :: KNOWN=0, MISS=-9999 ! Categorical trait levels type (cat_data) :: categories integer :: ncatvars integer, dimension(nloci) :: catidx ! local variables logical :: noimp, first double precision :: toobig, val character (len=3) :: na, gna character (len=7) :: famid, gtp, twinid character (len=10) :: fdec, idec character (len=20) :: loc20 type (table_cell) :: labellev integer :: currf, currm, fam, g1, g2, i, j, k, lpos, & ntwins, ped, pos, prevtwin, twinship, twinidx ! functions logical :: isatwin fam=0 twinid=' ' prevtwin=0 twinship=0 noimp=(imp /= 2) na='NA' gna='NA' if (misval /= ' ') then na=misval gna=misval end if if (gmisval /= ' ') then gna=gmisval end if ncatvars=0 do k=1, nord i=locord(k) if (isactive(loctyp(i)) .and. iscattrait(loctyp(i))) then ncatvars=ncatvars+1 catidx(ncatvars)=i end if end do call load_cat_levels(ncatvars, catidx, categories) ! quantitative variable format toobig=dble(10**(nwid-ndec-1)) call wrform('f', nwid, ndec, fdec) call wrform('i', nwid, 0, idec) ! header if (typ == 1) then if (all(pedmask)) then write(strm, '(9a)', advance='no') & 'ped',sep,'id',sep,'fa',sep,'mo',sep,'sex' else first=.true. if (pedmask(1)) then write(strm, '(a)', advance='no') 'ped' first=.false. end if if (pedmask(2)) then if (.not.first) then write(strm, '(a)', advance='no') sep end if write(strm, '(a)', advance='no') 'id' first=.false. end if if (pedmask(3)) then if (.not.first) then write(strm, '(a)', advance='no') sep end if write(strm, '(a)', advance='no') 'fa' first=.false. end if if (pedmask(4)) then if (.not.first) then write(strm, '(a)', advance='no') sep end if write(strm, '(a)', advance='no') 'mo' first=.false. end if if (pedmask(5)) then if (.not.first) then write(strm, '(a)', advance='no') sep end if write(strm, '(a)', advance='no') 'sex' end if end if else if (typ == 2) then write(strm, '(a)', advance='no') 'famid,id,fa,mo,sex,mztwin,hhid' na=' ' gna=' ' else if (typ == 3 .or. typ == 5) then write(strm, '(a)', advance='no') 'famid,id' na=' ' gna=' ' else if (typ == 4 .or. typ == 6) then write(strm, '(a)', advance='no') 'id' na=' ' gna=' ' else if (typ == 10) then na=' ' gna=' ' ! SAS script header else if (typ == 11) then write(strm, '(a/3a)') 'data peddata;', & ' infile cards missover delimiter="', sep, '" ;' write(strm, '(4(a,i0),a)') ' length pedigree $', ped_width, & '. id $', id_width, '. fa $', id_width, '. mo $', id_width, '. sex $1. ;' write(strm, '(a)') ' input pedigree $ id $ fa $ mo $ sex $ mztwin ' na='.' gna='.' end if ! ! variable names if (typ == 1) then do k=1, nord i=locord(k) if (isactive(loctyp(i)) .and. .not.isspecial(loctyp(i))) then write(strm,'(2a)', advance='no') sep, trim(loc(i)) end if end do else if (typ == 5 .or. typ == 6) then do k=1, nord i=locord(k) if (isactive(loctyp(i)) .and. ismarker(loctyp(i))) then write(strm,'(2a)', advance='no') sep, trim(loc(i)) end if end do else if (typ == 3 .or. typ == 4) then do k=1, nord i=locord(k) if (istrait(loctyp(i)) .and. .not.isspecial(loctyp(i))) then write(strm,'(2a)', advance='no') sep, trim(loc(i)) end if end do else if (typ == 11) then lpos=9 write(strm, '(a)', advance='no') ' ' do k=1, nord i=locord(k) if (isactive(loctyp(i)) .and. .not.isspecial(loctyp(i))) then if (ismarker(loctyp(i)) .or. loctyp(i) == LOC_AFF) then lpos=lpos+len_trim(loc(i))+1 if (lpos > 74) then write(strm, '(/a)', advance='no') ' ' lpos=9+len_trim(loc(i)) end if write(strm,'(1x,2a)', advance='no') trim(loc(i)), ' $' else if (loctyp(i) == LOC_QUA .or. loctyp(i) == LOC_CAT) then lpos=lpos+len_trim(loc(i))+1 if (lpos > 74) then write(strm, '(/a)', advance='no') ' ' lpos=9+len_trim(loc(i)) end if write(strm,'(1x,a)', advance='no') trim(loc(i)) end if end if end do write(strm, '(a/a)') ' ;', ' cards4 ;' end if if (typ /= 10 .and. typ /= 11) write(strm,*) ! do ped=1, dataset%nped if (dataset%actset(ped) > 0) then fam=fam+1 write(famid,'(i7)') fam famid=adjustl(famid) ntwins=0 if (twinning > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (isatwin(twintype, dataset%plocus(i,twinning))) then ntwins=ntwins+1 end if end do end if twinid=' ' prevtwin=0 currf=MISS currm=MISS do i=dataset%num(ped-1)+1, dataset%num(ped) ! test if new sibship and rezero twin indicator if (dataset%fa(i)/=currf .or. dataset%mo(i)/=currm) then prevtwin=0 currf=dataset%fa(i) currm=dataset%mo(i) end if ! compulsory data twinid=na if (ntwins > 1) then if (isatwin(twintype, dataset%plocus(i,twinning))) then if (prevtwin == 0 .or. twinidx /= int(dataset%plocus(i,twinning)) ) then twinship=twinship+1 prevtwin=twinship twinidx=int(dataset%plocus(i,twinning)) end if write(twinid,'(i7)') prevtwin twinid=adjustl(twinid) end if end if ! if (typ == 1) then first=.true. if (pedmask(1)) then write(strm, '(a)', advance='no') trim(dataset%pedigree(ped)) first=.false. end if if (pedmask(2)) then if (.not.first) write(strm,'(a1)', advance='no') sep write(strm, '(a)', advance='no') trim(dataset%id(i)) first=.false. end if if (pedmask(3)) then if (.not.first) write(strm,'(a1)', advance='no') sep if (dataset%fa(i) == MISS) then write(strm,'(a)',advance='no') trim(na) else write(strm,'(a)',advance='no') trim(dataset%id(dataset%fa(i))) end if first=.false. end if if (pedmask(4)) then if (.not.first) write(strm,'(a1)', advance='no') sep if (dataset%mo(i) == MISS) then write(strm,'(a)',advance='no') trim(na) else write(strm, '(a)', advance='no') dataset%id(dataset%mo(i)) end if first=.false. end if if (pedmask(5)) then if (dataset%sex(i) == 1) then write(strm,'(2a)', advance='no') sep, 'm' else if (dataset%sex(i) == 2) then write(strm,'(2a)', advance='no') sep, 'f' else write(strm,'(2a)', advance='no') sep, trim(na) end if end if else if (typ <= 3 .or. typ == 5 .or. typ == 10 .or. typ == 11) then write(strm,'(3a)', advance='no') & trim(dataset%pedigree(ped)), sep, trim(dataset%id(i)) if (typ <= 2 .or. typ == 10 .or. typ == 11) then if (ntwins > 1) then if (dataset%plocus(i,twinning) > KNOWN) then ntwins=ntwins+1 end if end if if (dataset%fa(i) == MISS) then write(strm,'(4a)', advance='no') sep, trim(na), sep, trim(na) else write(strm,'(4a)', advance='no') sep, trim(dataset%id(dataset%fa(i))), & sep, trim(dataset%id(dataset%mo(i))) end if if (dataset%sex(i) == 1) then write(strm,'(2a)', advance='no') sep, 'm' else if (dataset%sex(i) == 2 .or. typ == 2 .or. typ == 10) then write(strm,'(2a)', advance='no') sep, 'f' else write(strm,'(2a)', advance='no') sep, trim(na) end if if (typ == 2) then write(strm,'(4a)', advance='no') sep, trim(twinid), sep, trim(famid) else if (typ == 10 .or. typ == 11) then write(strm,'(4a)', advance='no') sep, trim(twinid) end if end if else if (typ == 4 .or. typ == 6) then write(strm,'(a)', advance='no') trim(dataset%id(i)) end if ! phenotypes if (typ /= 2) then ncatvars=0 do k=1, nord j=locord(k) if (iscattrait(loctyp(j))) then ncatvars=ncatvars+1 end if if (typ /= 3 .and. typ /= 4 .and. & (isactive(loctyp(j)) .and. ismarker(loctyp(j)))) then write(strm, '(a)', advance='no') sep if (noimp .and. .not.observed(i, locpos(j), dataset)) then write(strm, '(a)', advance='no') trim(gna) else call get_geno(i, locpos(j), locpos(j)+1, dataset, g1, g2) call wrgtp(abs(g1), abs(g2), gtp, allsep, '', 1) write(strm, '(a)', advance='no') trim(adjustl(gtp)) end if else if (typ /= 5 .and. typ /= 6 .and. & (loctyp(j) == LOC_QUA .or. loctyp(j) == LOC_CAT)) then write(strm, '(a)', advance='no') sep val=dataset%plocus(i,locpos(j)) if (val /= MISS) then pos=0 if (iscattrait(loctyp(j))) then call set_table_cell(labellev, ivalue=int(val)) pos=search_table_key(labellev, categories%cat_tables(ncatvars)) end if if (pos > 0) then call get_table_cell(categories%cat_tables(ncatvars)%categories(pos,2), string=loc20) else if (val == anint(val)) then write(loc20, idec) int(val) else if (abs(val) <= toobig) then write(loc20, fdec) val else write(loc20, '(g20.12)') val end if end if write(strm, '(a)', advance='no') trim(adjustl(loc20)) else write(strm,'(a)', advance='no') trim(na) end if else if (typ /= 5 .and. typ /= 6 .and. loctyp(j) == LOC_AFF) then write(strm, '(a)', advance='no') sep if (dataset%plocus(i,locpos(j)) == 1.0d0) then if (typ==1) then write(strm, '(a)', advance='no') 'n' else if (typ==10) then write(strm, '(a)', advance='no') 'NORMAL' else write(strm, '(a)', advance='no') '1' end if else if (dataset%plocus(i,locpos(j)) == 2.0d0) then if (typ==1) then write(strm, '(a)', advance='no') 'y' else if (typ==10) then write(strm, '(a)', advance='no') 'AFFECTED' else write(strm, '(a)', advance='no') '2' end if else write(strm, '(a)', advance='no') trim(na) end if end if end do end if write(strm,*) end do end if end do if (typ == 11) then write(strm,'(a)') ';;;;' end if end subroutine wrcsv ! ! Write out pedigree for Morgan ! typ ! 1 pedigree and traits ! 2 id, markers ! subroutine wrmorg(strm, typ, nwid, ndec, nloci, loc, loctyp, locpos, & smlfreq, smlpen, dataset) use ped_class use alleles_class use locus_types implicit none integer, intent(in) :: strm integer, intent(in) :: typ integer, intent(in) :: nwid integer, intent(in) :: ndec integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos double precision, dimension(2) :: smlfreq double precision, dimension(3) :: smlpen type (ped_data) :: dataset integer, parameter :: KNOWN=0, MISS=-9999 ! local variables type (allele_data), dimension(:), pointer :: alleles character (len=1) :: na character (len=7) :: gtp character (len=10) :: fdec character (len=20) :: loc20 integer :: g1, g2, i, j, n, ped ! functions integer :: getnam n=0 na='0' if (typ==1) then ! quantitative variable format call wrform('f', nwid, ndec, fdec) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then n=n+dataset%num(ped)-dataset%num(ped-1) end if end do i=0 do j=1, nloci if (istrait(loctyp(j))) then i=i+1 end if end do write(strm, '(a/a/a,i6/a,i6/a/a)') & '# Morgan format pedigee file', '# written by Sib-pair', & 'input pedigree size ', n, & 'input pedigree record names 3 integers ', i+1, & 'input pedigree record gender present', & '# select all markers' i=0 do j=1, nloci if (loctyp(j) == LOC_AFF) then i=i+1 write(strm, '(a,i3/a,i3,a,f5.3,1x,f5.3/a/a,3(1x,f5.3))') & '# set affected individuals trait ', i, & '# set trait ', i, ' freq ', smlfreq(2), smlfreq(1), & 'set trait data discrete', & '# set incomplete penetrances', smlpen(3), smlpen(2), smlpen(1) end if end do write(strm,'(/a)') '************' do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) ! compulsory data write(strm,'(a)', advance='no') trim(dataset%id(i)) if (dataset%fa(i) == MISS) then write(strm,'(1x,a,1x,a)', advance='no') na, na else write(strm,'(1x,a,1x,a)', advance='no') & trim(dataset%id(dataset%fa(i))), trim(dataset%id(dataset%mo(i))) end if if (dataset%sex(i) == 1) then write(strm,'(1x,a)', advance='no') '1' else if (dataset%sex(i) == 2) then write(strm,'(1x,a)', advance='no') '2' else write(strm,'(1x,a)', advance='no') na end if ! phenotypes do j=1, nloci if (loctyp(j) == LOC_QUA .or. loctyp(j) == LOC_CAT) then if (dataset%plocus(i,locpos(j)) /= MISS) then write(loc20, fdec) dataset%plocus(i,locpos(j)) write(strm, '(1x,a)', advance='no') trim(adjustl(loc20)) else write(strm,'(1x,a)', advance='no') na end if else if (loctyp(j) == LOC_AFF) then if(dataset%plocus(i,locpos(j)) == 1.0d0) then write(strm, '(1x,a)', advance='no') '1' else if(dataset%plocus(i,locpos(j)) == 2.0d0) then write(strm, '(1x,a)', advance='no') '2' else write(strm, '(1x,a)', advance='no') na end if end if end do write(strm,*) end do end if end do else if (typ==2) then ! write genotype data allocate(alleles(nloci)) write(strm, '(a)', advance='no') 'set marker names ' do i=1, nloci if (same_loctyp(loctyp(i), LOC_CODOM)) then write(strm, '(1x,a)', advance='no') trim(loc(i)) end if end do write(strm,*) i=0 do j=1, nloci if (same_loctyp(loctyp(j), LOC_CODOM)) then i=i+1 call freq(locpos(j), loctyp(j), 0, dataset, alleles(j)) write(strm, '(a,i4,a,100(1x,f6.4):)') & 'set marker ', i, ' allele freqs', & alleles(j)%allele_freqs(1:alleles(j)%numal) end if end do write(strm, '(a,i6,a)') 'set markers ', i, ' data' do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) n=0 do j=1, nloci if (same_loctyp(loctyp(j), LOC_CODOM) .and. observed(i, locpos(j), dataset)) then n=n+1 exit end if end do if (n>0) then write(strm,'(3x, a)', advance='no') trim(dataset%id(i)) do j=1, nloci if (same_loctyp(loctyp(j), LOC_CODOM)) then if (observed(i, locpos(j), dataset)) then call get_namedgeno(i, locpos(j), locpos(j)+1, & dataset, alleles(j), g1, g2) write(strm,'(1x,i3,1x,i3)', advance='no') g1, g2 else write(strm,'(1x,a,1x,a)', advance='no') na, na end if end if end do write(strm, *) end if end do end if end do deallocate(alleles) end if end subroutine wrmorg ! ! write out FISHER or MENDEL type pedigree file ! subroutine wrfish(strm, ndec, twinning, twintype, & nloci, loctyp, locpos, nord, locord, dataset, fstyle, plevel) use outstream use ped_class use locus_types implicit none integer, intent(in) :: strm integer, intent(in) :: ndec integer, intent(in) :: twinning integer, intent(in) :: twintype integer, intent(in) :: nloci integer, dimension(nloci), intent(in) :: loctyp integer, dimension(nloci), intent(in) :: locpos integer, intent(in) :: nord integer, intent(in) :: locord(nord) type (ped_data) :: dataset integer, intent(in) :: fstyle integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS=-9999 character (len=8), dimension(2) :: affcode character (len=9) :: fdec, loc1 character (len=1) :: sx, tw integer :: g1, g2, i, j, k, ped, nlp, ntwins, nmz ! functions logical :: isatwin ! ! quantitative variable format ! i=ndec if (i > 7) i=7 write(fdec, '(a,i1,a)') '(1x,f8.', i, ')' nlp=0 do i=1, nloci if (loctyp(i) < LOC_DEL) nlp=nlp+1 end do if (fstyle == 1) then write(strm,'(1x,a/1x,a,i4,a)') & '(2(i4,1x),a8)','(a8,2(1x,a8),2(1x,a1),',nlp,'(1x,a8))' else write(strm,'(1x,a/1x,a,i4,a)') & '(i4,1x,a8)','(a8,2(1x,a8),2(1x,a1),',nlp,'(1x,a8))' end if affcode(1)='NORMAL ' affcode(2)='AFFECTED' if (fstyle == 1) then affcode(1)='0 ' affcode(2)='1 ' else if (fstyle == 3) then affcode(1)='1 ' affcode(2)='2 ' end if nmz=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then ntwins=0 if (twinning > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (isatwin(twintype, dataset%plocus(i,twinning))) then ntwins=ntwins+1 end if end do end if if (fstyle == 1) then write(strm,'(2(i4,1x),a8)') & 0, dataset%num(ped)-dataset%num(ped-1), dataset%pedigree(ped)(1:8) else write(strm,'(i4,1x,a8)') & dataset%num(ped)-dataset%num(ped-1), dataset%pedigree(ped)(1:8) end if do i=dataset%num(ped-1)+1, dataset%num(ped) tw=' ' if (ntwins > 1 .and. isatwin(twintype, dataset%plocus(i,twinning))) then nmz=nmz+1 write(tw, '(i1)') int(dataset%plocus(i, twinning)) if (plevel>0) then write(outstr,'(6a)') & trim(dataset%pedigree(ped)), '--', trim(dataset%id(i)), & ' marked as a MZ twin (zyg=', tw, ')' end if end if sx='M' if (dataset%sex(i) == 2) then sx='F' end if write(strm, '(a8)', advance='no') dataset%id(i) if (dataset%fa(i) == MISS) then write(strm, '(1x,a8,1x,a8,1x,a1,1x,a1)', advance='no') & ' ',' ',sx,tw else write(strm, '(1x,a8,1x,a8,1x,a1,1x,a1)', advance='no') & dataset%id(dataset%fa(i)), dataset%id(dataset%mo(i)), sx, tw end if do k=1, nord j=locord(k) loc1=' ' if (ismarker(loctyp(j))) then if (observed(i, locpos(j), dataset)) then call get_geno(i, locpos(j), locpos(j)+1, dataset, g1, g2) call wrgtp(g1, g2, loc1, '/', '', 1) end if else if(loctyp(j) == LOC_QUA .or. loctyp(j) == LOC_CAT) then if (dataset%plocus(i,locpos(j)) /= MISS) then write(loc1,fdec) dataset%plocus(i,locpos(j)) end if else if(loctyp(j) == LOC_AFF) then if (dataset%plocus(i,locpos(j)) == 1.0d0) then write(loc1,'(1x,a8)') affcode(1) else if(dataset%plocus(i,locpos(j)) == 2.0d0) then write(loc1,'(1x,a8)') affcode(2) end if end if write(strm, '(a9)', advance='no') loc1 end do write(strm,*) end do end if end do if (nmz>0) then write(outstr,'(a,i5,a)') 'Marked ', nmz, ' individuals as MZ twins.' end if end subroutine wrfish ! ! Describe pedigree using dot graphics language ! subroutine wrdot(strm, trait, gene, loctyp, nwid, ndec, allsep, & dotfixedsep, dotcrossings, & dotnodesep, dotranksep, dotboxsize, & trcoly, trcoln, trcolx, gcolor, dataset) use locus_types use ped_class implicit none integer, intent(in) :: strm integer, intent(in) :: trait integer, intent(in) :: gene, loctyp integer, intent(in) :: nwid integer, intent(in) :: ndec character(len=1), intent(in) :: allsep ! symbol size and spacing logical, intent(in) :: dotfixedsep double precision, intent(in) :: dotcrossings, dotnodesep, & dotranksep, dotboxsize ! Colours for affected, unaffected, missing character(len=*), intent(in) :: trcoly, trcoln, trcolx, gcolor type (ped_data) :: dataset integer, parameter :: KNOWN=0, MISS=-9999 ! local variables character (len=max(7,nwid)) :: gtp character (len=8) :: marriage, shap, shade character(len=8), dimension(4) :: trait_colour character(len=13) :: line_colour integer :: currf, currm, g1, g2, gen2, i, nfam, ped, pedoffset ! flag inbred individuals call doinbred(1000, dataset, MISS, -2) trait_colour(1)='white' trait_colour(2)='grey' trait_colour(3)='white' trait_colour(4)='white' if (trcoln /= ' ') trait_colour(1)=trcoln if (trcoly /= ' ') trait_colour(2)=trcoly if (trcolx /= ' ') trait_colour(3)=trcolx if (gcolor /= ' ') trait_colour(4)=gcolor gen2=gene+1 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then i=index(dataset%pedigree(ped),'.') do while (i > 0) dataset%pedigree(ped)(i:i)='_' i=index(dataset%pedigree(ped),'.') end do write(strm,'(3a,2(/a)/a,f3.1,a)') & 'digraph Ped_', dataset%pedigree(ped), ' {', & '# page = "8.2677165,11.692913" ;', 'ratio = "auto" ;', & 'mincross = ', dotcrossings ,' ;' if (dotfixedsep) then write(strm,'(a,f3.1,a/a,f3.1,a)') & 'nodesep=', dotnodesep, ' ;', & 'ranksep=', dotranksep, ' ;' end if write(strm,'(/3a/a/)') & 'label = "Pedigree ', trim(dataset%pedigree(ped)), '" ;','rotate = 90 ;' pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) if (dataset%sex(i) == 1) then shap='box' else if (dataset%sex(i) == 2) then shap='circle' else shap='diamond' end if shade=trait_colour(3) if (trait /= MISS) then if (dataset%plocus(i,trait) == 1) then shade=trait_colour(1) else if (dataset%plocus(i,trait) == 2) then shade=trait_colour(2) end if end if write(strm,'(4a)', advance='no') & '"',trim(dataset%id(i)), '" [shape=', shap if (gene /= MISS) then gtp=' ' if (ismarker(loctyp)) then if (observed(i, gene, dataset)) then call get_geno(i, gene, gen2, dataset, g1, g2) call wrgtp(g1, g2, gtp, allsep, '', 1) end if else if (dataset%plocus(i,gene) /= MISS) then call wrtrait(dataset%plocus(i,gene), gtp, loctyp, ' ', nwid, ndec) end if end if write(strm,'(5a)', advance='no') & 'label=<<TABLE BORDER="0" CELLBORDER="0" CELLSPACING="0">', & '<TR><TD COLSPAN="3" PORT="id">', trim(dataset%id(i)), '</TD></TR>', & '<TR><TD> </TD><TD PORT="pheno"' if (gtp /= ' ') then write(strm,'(3a)', advance='no') & ' BGCOLOR="', trim(trait_colour(4)), '"' end if write(strm,'(3a)', advance='no') & '>', trim(adjustl(gtp)), '</TD><TD> </TD></TR></TABLE>>' end if write(strm,'(a)', advance='no') ', regular=1, style=filled' if (dotfixedsep) then write(strm,'(a,f3.1,a,f3.1)', advance='no') & ', fixedsize=true, height=', dotboxsize, ', width=', dotboxsize end if write(strm,'(3a)') ', fillcolor=', shade, '] ;' end do nfam=0 currf=MISS currm=MISS do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped) if (dataset%fa(i) /= currf .or. dataset%mo(i) /= currm) then nfam=nfam+1 write(marriage,'(a4,i4.4)') 'marr', nfam currf=dataset%fa(i) currm=dataset%mo(i) line_colour='black' if (dataset%untyped(i)) then line_colour='"black:black"' end if write(strm,'(4a/7a/7a)') & '"', marriage,'" [shape=diamond,', & 'style=filled,label="",height=.1,width=.1] ;', & '"', trim(dataset%id(currf)), '" -> "', marriage, & '" [dir=none,weight=1,color=', trim(line_colour),'] ;', & '"', trim(dataset%id(currm)), '" -> "', marriage, & '" [dir=none,weight=1,color=', trim(line_colour),'] ;' end if write(strm,'(5a)') & '"', marriage,'" -> "', trim(dataset%id(i)), '" [dir=none, weight=2] ;' end do write(strm,'(a)') '}' end if end do end subroutine wrdot ! ! write out Arlequin data file (haplotype or genotype data) ! subroutine wrarl(strm, popind, typ, nloci, loc, loctyp, locpos, dataset) use outstream use ped_class use contingency_table use locus_types implicit none integer, intent(in) :: strm integer, intent(in) :: popind integer, intent(in) :: typ integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data) :: dataset ! local variables integer, parameter :: KNOWN=0, MISS=-9999 ! ! Population tabulation ! type (table_data) :: poptable double precision, dimension(1) :: val integer, dimension(dataset%nobs) :: pop ! Active loci integer :: nmark integer, dimension(:), allocatable :: mark integer, dimension(:,:), allocatable :: geno ! integer :: curpop, i, istep, j, ipop, n, nsamp, ped, pedoffset, poplevels character (len=4) :: sall ! ! Active markers nmark=0 do j=1, nloci if (same_loctyp(loctyp(j), LOC_CODOM)) then nmark=nmark+1 end if end do allocate(mark(nmark), geno(nmark,2)) nmark=0 do j=1, nloci if (same_loctyp(loctyp(j), LOC_CODOM)) then nmark=nmark+1 mark(nmark)=locpos(j) end if end do ! Useful individuals nsamp=0 pop=MISS do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) n=dataset%num(ped) do i=pedoffset+1, n do j=1, nmark if (observed(i, mark(j), dataset)) then pop(i)=1 nsamp=nsamp+1 exit end if end do end do end if end do ! Populations if (popind /= MISS) then call setup_table(1, 30, poptable) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) n=dataset%num(ped) do i=pedoffset+1, n if (pop(i) /= MISS) then if (dataset%plocus(i,popind) /= MISS) then pop(i)=int(dataset%plocus(i,popind)) val(1)=dataset%plocus(i,popind) call insert_table(1, val, poptable, 1) else nsamp=nsamp-1 pop(i)=MISS end if end if end do end if end do poplevels=poptable%ncells else call setup_table(1, 1, poptable) poptable%icount(i)=nsamp poplevels=1 end if write(outstr,'(a,i0,a,i0,a)') & 'Writing ', poplevels, ' populations, ',nsamp, ' records.' ! ! Write haplotypes ! write(strm,'(a/a/a/a)') & '#','# Arlequin format data written by Sib-pair','#','[Profile]' if (typ == 0) then write(strm,'(3x,a)') & 'Title="Genotype data: All genotyped individuals"' else if (typ == 1) then write(strm,'(3x,a)') & 'Title="Haplotype data: one child per family"' else write(strm,'(3x,a)') & 'Title="Haplotype data: two parents per family"' end if write(strm,'(3x,a,i0)') 'NbSamples=', poplevels write(strm,'(3x,a)') 'GenotypicData=1' write(strm,'(3x,a,i1)') 'GameticPhase=', min(typ,1) write(strm,'(3x,a)') & 'RecessiveData=0','DataType=STANDARD', & 'LocusSeparator=WHITESPACE','MissingData="x"' write(strm,'(a/3x,a/6x,a/6x,a,i5/6x,a)') & '[Data]','[[Samples]]' ! do ipop=1, poplevels curpop=int(poptable%categories(poptable%idx(ipop),1)%rvalue) write(strm,'(6x,a,i0,a/6x,a,i5/6x,a)') & 'SampleName="Population ', ipop, '"', & 'SampleSize=', poptable%icount(ipop), & 'SampleData= {' do i=1, dataset%nobs if (pop(i) == curpop) then do j=1, nmark call get_geno(i, mark(j), mark(j)+1, dataset, geno(j,1), geno(j,2)) if (geno(j,1) < KNOWN) then geno(j,1)=MISS geno(j,2)=MISS end if end do write(strm, '(4a)', advance='no') & trim(dataset%pedigree(dataset%iped(i))), '-', trim(dataset%id(i)), ' 1' istep=len_trim(dataset%pedigree(dataset%iped(i))) + & len_trim(dataset%id(i)) + 3 do j=1, nmark call wrall(geno(j,1), sall) write(strm,'(1x,a)', advance='no') trim(adjustl(sall)) end do write(strm,'(/a)', advance='no') repeat(' ',istep) do j=1, nmark call wrall(geno(j,2), sall) write(strm,'(1x,a)', advance='no') trim(adjustl(sall)) end do write(strm,*) end if end do write(strm,'(6x,a)') '}' end do end subroutine wrarl ! ! write out data file used by Jonathon Pritchard's structure program ! subroutine wrprd(strm, typ, trait, nloci, loc, loctyp, locpos, dataset) use ped_class use locus_types implicit none integer, intent(in) :: strm integer, intent(in) :: typ integer, intent(in) :: trait integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data) :: dataset integer, parameter :: KNOWN=0, MISS=-9999 integer, parameter :: lmiss=-9 ! integer :: fin, g1, g2, i, j, n, ped, tval ! do ped=1, dataset%nped if (dataset%actset(ped) > 0) then n=dataset%num(ped) if (typ==2) n=dataset%num(ped-1)+dataset%nfound(ped) do i=dataset%num(ped-1)+1, n if (trait == MISS) then tval=0 else tval=int(dataset%plocus(i,trait))-1 end if write(strm, '(3a,2(1x,i2))', advance='no') & trim(dataset%pedigree(ped)), '-', trim(dataset%id(i)), 1, tval do j=1, nloci if (same_loctyp(loctyp(j), LOC_CODOM)) then call get_geno(i, locpos(j), locpos(j)+1, dataset, g1, g2) if (g1 <= KNOWN) then g1=lmiss g2=lmiss end if write(strm,'(1x,i3,1x,i3)', advance='no') g1, g2 end if end do write(strm,*) end do end if end do end subroutine wrprd ! ! write out data file used by Browning and Browning's Beagle program ! exclude MZ cotwins ! subroutine wrbeagle(strm, typ, dataset) use ped_class use locus_types use locus_data implicit none integer, intent(in) :: strm integer, intent(in) :: typ type (ped_data) :: dataset integer, parameter :: KNOWN=0, MISS=-9999 integer, parameter :: lmiss=-9 character (len=2) :: alleles ! list of active individuals integer :: nactiv integer, dimension(3*dataset%nobs) :: activ ! integer :: fin, g1, g2, gene, gen2, i, idx, j, n, ped, tval character (len=3) :: all1, all2 ! alleles='12' nactiv=0 write(strm,'(a)', advance='no') 'I id' ! unrelated if (typ < 3) then do ped=1, dataset%nped if (dataset%actset(ped) > 0) then n=dataset%num(ped) if (typ==2) n=dataset%num(ped-1)+dataset%nfound(ped) do i=dataset%num(ped-1)+1, n if (dataset%imztwin(i) == MISS) then nactiv=nactiv+1 activ(nactiv)=i write(strm,'(2(1x,3a))', advance='no') & trim(dataset%pedigree(ped)), '-', trim(dataset%id(i)), & trim(dataset%pedigree(ped)), '-', trim(dataset%id(i)) end if end do end if end do ! trios fa, mo, ego else do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+dataset%nfound(ped)+1, dataset%num(ped) if (dataset%imztwin(i) == MISS) then nactiv=nactiv+1 activ(nactiv)=dataset%fa(i) write(strm,'(2(1x,3a))', advance='no') & trim(dataset%pedigree(ped)), '-', trim(dataset%id(activ(nactiv))), & trim(dataset%pedigree(ped)), '-', trim(dataset%id(activ(nactiv))) nactiv=nactiv+1 activ(nactiv)=dataset%mo(i) write(strm,'(2(1x,3a))', advance='no') & trim(dataset%pedigree(ped)), '-', trim(dataset%id(activ(nactiv))), & trim(dataset%pedigree(ped)), '-', trim(dataset%id(activ(nactiv))) nactiv=nactiv+1 activ(nactiv)=i write(strm,'(2(1x,3a))', advance='no') & trim(dataset%pedigree(ped)), '-', trim(dataset%id(i)), & trim(dataset%pedigree(ped)), '-', trim(dataset%id(i)) end if end do end if end do end if do j=1, nloci if (same_loctyp(loctyp(j), LOC_CODOM)) then gene=locpos(j) gen2=gene+1 write(strm, '(/2a)', advance='no') 'M ', loc(j) ! If compressed SNP storage, retrieve allele names if (dataset%hassnps == 2 .and. iscompressed(loctyp(j))) then call get_snpallele1(locnotes(j), alleles) do i=1, nactiv idx=activ(i) if (observed(idx, gene, dataset)) then call get_geno(idx, gene, gen2, dataset, g1, g2) write(strm,'(1x,a3,1x,a3)', advance='no') alleles(g1:g1), alleles(g2:g2) else write(strm,'(1x,a3,1x,a3)', advance='no') '?', '?' end if end do else do i=1, nactiv idx=activ(i) if (observed(idx, gene, dataset)) then call get_geno(idx, gene, gen2, dataset, g1, g2) call wrall(g1, all1) call wrall(g2, all2) write(strm,'(1x,a3,1x,a3)', advance='no') all1, all2 else write(strm,'(1x,a3,1x,a3)', advance='no') '?', '?' end if end do end if else if (istrait(loctyp(j))) then gene=locpos(j) if (loctyp(j) == LOC_AFF) then write(strm, '(/2a)', advance='no') 'A ', loc(j) else if (loctyp(j) == LOC_CAT) then write(strm, '(/2a)', advance='no') 'C ', loc(j) else write(strm, '(/2a)', advance='no') 'T ', loc(j) end if do i=1, nactiv idx=activ(i) if (dataset%plocus(idx, gene) /= MISS) then tval=int(dataset%plocus(idx, gene)) write(strm,'(4x,i1,3x,i1)', advance='no') tval, tval else write(strm,'(1x,a)', advance='no') '? ? ' end if end do end if end do write(strm,*) end subroutine wrbeagle ! ! Simpler pedigree writer - for findhap sex,id,fa,mo,dob ! subroutine wrped(strm, typ, censor, trait, misval, dataset) use iobuff use fileio use scanner use ped_class use string_utilities implicit none integer, intent(in) :: strm integer, intent(in) :: typ integer, intent(in) :: censor, trait character (len=1), intent(in) :: misval type (ped_data), intent(inout) :: dataset integer, parameter :: KNOWN=0, MISS = -9999 integer :: i character (len=1) :: sx call filter_snp(censor, dataset) if (typ == 1) then if (trait == MISS) then do i=1, dataset%nobs if (.not.dataset%untyped(i)) then sx='F' if (dataset%sex(i) == 1) sx='M' write(strm,'(a,1x,a)', advance='no') sx, dataset%id(i) if (dataset%fa(i) == MISS) then write(strm,'(2(1x,a),1x,i0)') misval, misval, i else write(strm,'(2(1x,a),1x,i0)') & dataset%id(dataset%fa(i)), dataset%id(dataset%mo(i)), i end if end if end do else do i=1, dataset%nobs if (.not.dataset%untyped(i)) then sx='F' if (dataset%sex(i) == 1) sx='M' write(strm,'(a,1x,a)', advance='no') sx, dataset%id(i) if (dataset%fa(i) == MISS) then write(strm,'(2(1x,a),1x,i0)', advance='no') misval, misval else write(strm,'(2(1x,a))', advance='no') & dataset%id(dataset%fa(i)), dataset%id(dataset%mo(i)) end if if (dataset%plocus(i, trait) == MISS) then write(strm,'(1x,a)') misval else write(strm,'(1x,i0)') nint(dataset%plocus(i,trait)) end if end if end do end if end if close(strm, status='keep') end subroutine wrped ! ! filter markers on indicator trait ! subroutine filter_snp(trait, dataset) use ped_class use locus_types use locus_data implicit none integer, intent(in) :: trait type (ped_data) :: dataset integer, parameter :: KNOWN=0, MISS=-9999 integer :: i, ped ! if (.not.allocated(dataset%untyped)) return dataset%untyped(:)=.true. if (trait /= MISS) then do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) dataset%untyped(i)=(dataset%plocus(i,trait) == MISS) end do end if end do else do ped=1, dataset%nped if (dataset%actset(ped) > 0) then dataset%untyped((dataset%num(ped-1)+1):dataset%num(ped))=.false. end if end do end if end subroutine filter_snp ! ! Write out SNPs as ID-major dosages ! typ=1 row ID and column headers - FImpute ! typ=2 unadorned ! typ=3 BLUPF90 style ! typ=5 gs3 style ! typ=4 findhap style ! For FImpute genotype files, pheno = array/source ! For findhap genotype files, currently array/source is fixed to 1, ! and has nsnps before genotypes ! For gs3, wants SNPs to start before col 50 ! ! reference allele now defaults to annotation if present 20180828 ! subroutine wrsnp_col(typ, strm, trait, pheno, sep, gsep, misval, dataset) use outstream use nucleotides use ped_class use alleles_class use locus_types use locus_data implicit none integer, intent(in) :: typ integer, intent(in) :: strm integer, intent(in) :: trait, pheno character (len=*), intent(in) :: sep, gsep character (len=*), intent(in) :: misval type (ped_data) :: dataset integer, parameter :: KNOWN=0, MISS=-9999 integer, dimension(nloci) :: snp_pos, snp_topall type (allele_data) :: allele_buffer ! integer :: g, g1, g2, gene, gen2, i, j, nsnps, nunused, nused, ped character (len=1) :: refall, altall double precision :: altfreq ! functions interface subroutine freq(gene, loctyp, fndr, dataset, allele_buffer) use ped_class use alleles_class integer, intent(in) :: gene integer, intent(in) :: loctyp integer, intent(in) :: fndr type (ped_data), intent(in) :: dataset type (allele_data), intent(inout) :: allele_buffer end subroutine freq end interface ! call setup_stat('Output SNPs 1=yes', typ=2) altfreq=0.5d0 nsnps=0 nunused=0 nused=0 do j=1, nloci if (isactive(loctyp(j)) .and. ismarker(loctyp(j))) then call freq(locpos(j), loctyp(j), 0, dataset, allele_buffer) if (allele_buffer%numal <= 2) then nsnps=nsnps+1 snp_pos(nsnps)=locpos(j) locstat(j)=1 call get_refalleles(locnotes(j), refall, altall) if (refall /= ' ') then call load_refallele(refall, altall, altfreq, allele_buffer) end if snp_topall(nsnps)=allele_buffer%allele_names(allele_buffer%topall) locord(nsnps)=j end if end if end do write(outstr,'(a,i0,a)') 'Writing ', nsnps, ' loci (<= 2 alleles).' ! header if (typ == 1) then write(strm,'(a)', advance='no') 'id' if (pheno /= MISS) then write(strm,'(2a)', advance='no') sep, ' pheno ' end if do j=1, nsnps write(strm,'(2a)', advance='no') sep, trim(loc(locord(j))) end do write(strm,*) end if if (trait == MISS .and. pheno /= MISS) then call filter_snp(pheno, dataset) else call filter_snp(trait, dataset) end if ! records do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (.not.dataset%untyped(i)) then nused=nused+1 if (typ == 1) then write(strm,'(a)', advance='no') dataset%id(i) if (pheno /= MISS) then if (dataset%plocus(i, pheno) == MISS) then write(strm,'(4a)', advance='no') & sep, ' ', misval, ' ' else write(strm, '(2a,i0,a)', advance='no') & sep, ' ', int(dataset%plocus(i, pheno)), ' ' end if end if ! BLUPF90 seems to read these using '(a50,400000i1)' else if (typ == 3) then write(strm,'(a50)', advance='no') dataset%id(i) else if (typ == 4) then write(strm,'(4a,i0,a)', advance='no') & dataset%id(i), sep, '1', sep, nsnps, sep ! gs3 makes a format to read these by moving backwards from pos 50 to find start of SNP genotypes else if (typ == 5) then write(strm,'(a,a)', advance='no') dataset%id(i), sep end if do j=1, nsnps gene=snp_pos(j) if (observed(i, gene, dataset)) then call get_geno(i, gene, gene+1, dataset, g1, g2) g=2 if (g1 == snp_topall(j)) g=g-1 if (g2 == snp_topall(j)) g=g-1 write(strm,'(a,i0)', advance='no') gsep, g else write(strm,'(2a)', advance='no') gsep, misval end if end do write(strm,*) else nunused=nunused+1 end if end do end if end do write(outstr,'(a,i0,a)') 'Wrote ', nused, ' records.' if (nunused > 0) then write(outstr,'(a,i0,a)') 'Skipped ', nunused, ' records.' end if end subroutine wrsnp_col ! ! Write out SNP-major data file with ! typ=1 SNP and column names ! typ=2 no SNP and column names ! typ=3 integer genotype encoding used by ROADTRIPS ! genotypes are -9,0,1,2 ! subroutine wrsnp_row(typ, strm, trait, sep, misval, dataset) use ped_class use alleles_class use locus_types use locus_data implicit none integer, intent(in) :: typ integer, intent(in) :: strm integer, intent(in) :: trait character (len=*), intent(in) :: sep character (len=*), intent(in) :: misval type (ped_data) :: dataset integer, parameter :: KNOWN=0, MISS=-9999 ! ! index to matching pedigree record integer, dimension(dataset%nobs) :: idx type (allele_data) :: allele_buffer integer :: a1, g, g1, g2, gene, gen2, i, j, nobs, ped character (len=1) :: lsep character (len=2) :: lmiss ! functions interface subroutine freq(gene, loctyp, fndr, dataset, allele_buffer) use ped_class use alleles_class integer, intent(in) :: gene integer, intent(in) :: loctyp integer, intent(in) :: fndr type (ped_data), intent(in) :: dataset type (allele_data), intent(inout) :: allele_buffer end subroutine freq end interface ! call filter_snp(trait, dataset) nobs=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (.not.dataset%untyped(i)) then nobs=nobs+1 idx(nobs)=i end if end do end if end do if (typ == 3) then lsep=' ' lmiss='-9' else lsep=sep lmiss=misval if (typ == 1) then write(strm,'(a)', advance='no') 'snp' do i=1, nobs write(strm,'(2a)', advance='no') sep, trim(dataset%id(idx(i))) end do write(strm,*) end if end if do j=1, nloci if (isactdip(loctyp(j))) then if (typ == 1) then write(strm,'(a)') trim(loc(j)) end if gene=locpos(j) call freq(gene, loctyp(j), 0, dataset, allele_buffer) if (allele_buffer%numal == 1 .or. allele_buffer%numal == 2) then a1=allele_buffer%allele_names(1) gen2=gene+1 do i=1, nobs if (observed(idx(i), gene, dataset)) then call get_geno(idx(i), gene, gen2, dataset, g1, g2) g=2 if (g1 == a1) g=g-1 if (g2 == a1) g=g-1 write(strm,'(a,i2)', advance='no') lsep, g else write(strm,'(2a)', advance='no') lsep, lmiss end if end do write(strm,*) end if end if end do end subroutine wrsnp_row ! ! Write out PLINK's SNP-major .tped data file format ! genotypes are 0 0, 1 1, 1 2, 2 2 as required by CARAT, MQLS_XM ! typ=1 SNP and column names ! typ=2 no SNP and column names ! subroutine wrsnp2(typ, strm, trait, misval, dataset) use ped_class use alleles_class use scanner use locus_types use locus_data implicit none integer, intent(in) :: typ integer, intent(in) :: strm integer, intent(in) :: trait character (len=*), intent(in) :: misval type (ped_data) :: dataset integer, parameter :: KNOWN=0, MISS=-9999 type (allele_data) :: allele_buffer ! integer, dimension(dataset%nobs) :: idx integer :: g1, g2, gene, gen2, i, j, misnum, narg, nobs, ped character (len=2) :: chr character (len=20), dimension(1) :: tnam double precision :: bpdist, dist ! functions integer :: ival logical :: isint interface subroutine freq(gene, loctyp, fndr, dataset, allele_buffer) use ped_class use alleles_class integer, intent(in) :: gene integer, intent(in) :: loctyp integer, intent(in) :: fndr type (ped_data), intent(in) :: dataset type (allele_data), intent(inout) :: allele_buffer end subroutine freq end interface ! misnum=0 if (misval /= 'x') then misnum=ival(misval) end if call filter_snp(trait, dataset) nobs=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (.not.dataset%untyped(i)) then nobs=nobs+1 idx(nobs)=i end if end do end if end do if (typ == 1) then write(strm,'(a)', advance='no') 'Chr SNP cm bp' do i=1, nobs write(strm,'(1x,a)', advance='no') trim(dataset%id(idx(i))) end do write(strm,*) end if do j=1, nloci if (isactdip(loctyp(j))) then gene=locpos(j) call freq(gene, loctyp(j), 0, dataset, allele_buffer) if (allele_buffer%numal == 1 .or. allele_buffer%numal == 2) then gen2=gene+1 chr=' ' dist=0.0d0 bpdist=dist if (map(j) /= MISS) then if (group(j) /= ' ') chr=group(j) dist=map(j) narg=1 call args(locnotes(j), narg, tnam, ' ', SEP_WH_RES) if (isint(tnam(1))) then bpdist=ival(tnam(1)) else bpdist=int(1.0d6*dist) end if end if write(strm,'(a,1x,a,1x,f14.5,1x,i0)', advance='no') & chr, trim(loc(j)), dist, int(bpdist) do i=1, nobs g1=misnum g2=misnum if (observed(idx(i), gene, dataset)) then call get_namedgeno(idx(i), gene, gen2, dataset, allele_buffer, g1, g2) end if write(strm,'(1x,i1,1x,i1)', advance='no') g1, g2 end do write(strm,*) end if end if end do end subroutine wrsnp2 ! ! Write out CHIAMO/IMPUTE etc genotype probability file ! ! 20 rs1 1000 A C 1 0 0 1 0 0 ! 20 rs2 2000 G T 1 0 0 0 1 0 ! subroutine wrsnp3(strm, trait, dataset) use ped_class use alleles_class use scanner use locus_types use locus_data implicit none integer, intent(in) :: strm integer, intent(in) :: trait type (ped_data) :: dataset integer, parameter :: KNOWN=0, MISS=-9999 type (allele_data) :: allele_buffer ! integer :: bpdist, g, g1, g2, gene, gen2, i, j, k, ped character (len=2) :: chr character (len=3), dimension(2) :: allele character (len=5), dimension(4) :: geno = & (/ '0 0 0', '1 0 0', '0 1 0', '0 0 1' /) ! functions integer :: ival, tobp logical :: isint interface subroutine freq(gene, loctyp, fndr, dataset, allele_buffer) use ped_class use alleles_class integer, intent(in) :: gene integer, intent(in) :: loctyp integer, intent(in) :: fndr type (ped_data), intent(in) :: dataset type (allele_data), intent(inout) :: allele_buffer end subroutine freq end interface ! call filter_snp(trait, dataset) do j=1, nloci if (isactdip(loctyp(j))) then gene=locpos(j) call freq(gene, loctyp(j), 0, dataset, allele_buffer) if (allele_buffer%numal == 1 .or. allele_buffer%numal == 2) then gen2=gene+1 chr=' ' bpdist=0 if (map(j) /= MISS) then if (group(j) /= ' ') chr=group(j) bpdist=tobp(map(j)) end if allele='0' do k=1, allele_buffer%numal call wrall(allele_buffer%allele_names(k), allele(k)) end do write(strm,'(a,1x,a,1x,i0,1x,a,1x,a)', advance='no') & chr, trim(loc(j)), bpdist, allele(1), allele(2) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) g=1 if (.not.dataset%untyped(i)) then if (observed(i, gene, dataset)) then call get_namedgeno(i, gene, gen2, dataset, allele_buffer, & g1, g2) g=g1+g2 end if end if write(strm, '(1x,a)', advance='no') geno(g) end do end if end do write(strm,*) end if end if end do end subroutine wrsnp3 ! ! Write out SNP-major data file with ! real allelic dose encoding used by WOMBAT ! imputing any missing genotypes ! subroutine wrsnp4(strm, trait, dose, key, dataset) use ped_class use alleles_class use locus_types use locus_data implicit none integer, intent(in) :: strm integer, intent(in) :: trait integer, intent(in) :: dose integer, intent(in) :: key type (ped_data) :: dataset integer, parameter :: KNOWN=0, MISS=-9999 type (allele_data) :: allele_buffer ! integer :: gene, gen2, i, j, ped double precision :: mlik ! functions interface subroutine freq(gene, loctyp, fndr, dataset, allele_buffer) use ped_class use alleles_class integer, intent(in) :: gene integer, intent(in) :: loctyp integer, intent(in) :: fndr type (ped_data), intent(in) :: dataset type (allele_data), intent(inout) :: allele_buffer end subroutine freq end interface ! call filter_snp(trait, dataset) if (key /= MISS) then do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (.not.dataset%untyped(i)) then write(strm,'(1x,i0)', advance='no') int(dataset%plocus(i, key)) end if end do end if end do write(strm,*) end if do j=1, nloci if (isactdip(loctyp(j))) then gene=locpos(j) call freq(gene, loctyp(j), 0, dataset, allele_buffer) if (allele_buffer%numal == 1 .or. allele_buffer%numal == 2) then call dopeel(2, gene, dose, 20, allele_buffer, dataset, mlik, -1) gen2=gene+1 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (.not.dataset%untyped(i)) then write(strm,'(1x,f6.4)', advance='no') dataset%plocus(i, dose) end if end do end if end do write(strm,*) end if end if end do end subroutine wrsnp4 ! ! Write out SNP-major data file for SuperlinkSNP ! SNP Chromosome Position mom dad son1 son2 ! rs884080 1 2016609 AG AG AG -- ! subroutine wrsnp5(strm, trait, dataset) use ped_class use alleles_class use locus_types use locus_data implicit none integer, intent(in) :: strm integer, intent(in) :: trait type (ped_data) :: dataset integer, parameter :: KNOWN=0, MISS=-9999 ! ! index to matching pedigree record integer, dimension(dataset%nobs) :: idx type (allele_data) :: allele_buffer integer :: a1, g, g1, g2, gene, gen2, i, j, nobs, ped character (len=1) :: lsep character (len=2) :: lmiss character (len=1) :: all1, all2 ! functions integer :: tobp interface subroutine freq(gene, loctyp, fndr, dataset, allele_buffer) use ped_class use alleles_class integer, intent(in) :: gene integer, intent(in) :: loctyp integer, intent(in) :: fndr type (ped_data), intent(in) :: dataset type (allele_data), intent(inout) :: allele_buffer end subroutine freq end interface ! call filter_snp(trait, dataset) nobs=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (.not.dataset%untyped(i)) then nobs=nobs+1 idx(nobs)=i end if end do end if end do lsep=achar(9) lmiss='--' write(strm,'(5a)', advance='no') 'SNP', lsep, 'Chromosome', lsep, 'Position' do i=1, nobs write(strm,'(2a)', advance='no') lsep, trim(dataset%id(idx(i))) end do write(strm,*) do j=1, nloci if (isactdip(loctyp(j)) .and. group(j) /= ' ' .and. map(j) /= MISS) then gene=locpos(j) call freq(gene, loctyp(j), 0, dataset, allele_buffer) if (allele_buffer%numal == 2) then write(strm,'(4a,i0)', advance='no') trim(loc(j)), lsep, group(j), lsep, tobp(map(j)) gen2=gene+1 do i=1, nobs if (observed(idx(i), gene, dataset)) then call get_geno(idx(i), gene, gen2, dataset, g1, g2) call wrall(g1, all1) call wrall(g2, all2) write(strm,'(3a)', advance='no') lsep, all1, all2 else write(strm,'(2a)', advance='no') lsep, lmiss end if end do write(strm,*) end if end if end do end subroutine wrsnp5 ! ! Write out old-style PAP pedigree ! subroutine wrpap(trip, phen, nloci, loc, loctyp, locpos, dataset) use ped_class use alleles_class use locus_types use sorts implicit none integer, intent(in) :: trip, phen integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data) :: dataset integer, parameter :: KNOWN=0, MISS=-9999 ! local variables type (allele_data), dimension(:), pointer :: alleles character (len=1) :: na character (len=7) :: gtp character (len=10) :: fdec character (len=20) :: loc20 integer :: g1, g2, i, ii, j, k, nuse, num, ped, pedoffset, pos integer :: famcnt, famno, nex, nfam, sx character (len=24), dimension(dataset%maxsiz) :: sortkey integer, dimension(dataset%maxsiz) :: ord ! functions integer :: getnam interface subroutine freq(gene, loctyp, fndr, dataset, allele_buffer) use ped_class use alleles_class integer, intent(in) :: gene integer, intent(in) :: loctyp integer, intent(in) :: fndr type (ped_data), intent(in) :: dataset type (allele_data), intent(inout) :: allele_buffer end subroutine freq end interface allocate(alleles(nloci)) do j=1, nloci if (isactdip(loctyp(j))) then call freq(locpos(j), loctyp(j), 0, dataset, alleles(j)) end if end do ! ! A unique ID number is obtained for each individual by adding the famno ! (which increases in multiples of famcnt, minimum 1000) to their position ! 1..num ! famcnt=int(10.0**int(max(3.0,1.0+log10(float(dataset%maxsiz))))) famno=0 nfam=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-dataset%num(ped-1) nfam=nfam+1 famno=famno+famcnt if (num == dataset%nfound(ped)) then ii=pedoffset do i=1, num ii=ii+1 nex=0 if (dataset%sex(ii) == 2) nex=num write(trip, '(4i8,4a)') & nfam, famno+nex+i,famno+num-nex+i, 0, & ' # ', trim(dataset%pedigree(ped)),'-', trim(dataset%id(ii)) end do end if ! sort on parental and individual IDs ii=pedoffset nuse=0 do i=1, num ii=ii+1 if (dataset%fa(ii) /= MISS .and. dataset%mo(ii) /= MISS) then nuse=nuse+1 write(sortkey(nuse),'(3i8)') famno+dataset%fa(ii)-pedoffset, & famno+dataset%mo(ii)-pedoffset, famno+i ord(nuse)=i end if end do call csort(nuse, sortkey, ord) ii=pedoffset do k=1, nuse i=ord(k) ii=pedoffset+i write(trip, '(4i8,9a)') & nfam, famno+dataset%fa(ii)-pedoffset, famno+dataset%mo(ii)-pedoffset, famno+i, & ' # ', trim(dataset%pedigree(ped)),'-', trim(dataset%id(ii)), & ' (', trim(dataset%id(dataset%fa(ii))), ' x ', & trim(dataset%id(dataset%mo(ii))),')' end do ii=pedoffset do i=1, num ii=ii+1 sx=1 if (dataset%sex(ii) == 2) sx=2 write(phen,'(i8,i8)', advance='no') famno+i, sx pos=17 do j=1, nloci if (pos > 122) then write(phen,'(/a)', advance='no') ' ' pos=1 end if if (isactdip(loctyp(j))) then if (.not.observed(ii, locpos(j), dataset)) then write(phen,'(a8)', advance='no') ' -9999' else call get_namedgeno(ii, locpos(j), locpos(j)+1, & dataset, alleles(j), g1, g2) if (same_loctyp(loctyp(j), LOC_XLIN) .and. dataset%sex(ii) /= 2) then write(phen,'(i8)', advance='no') alleles(j)%numal*(alleles(j)%numal+1)/2+g1 else write(phen,'(i8)', advance='no') g2*(g2-1)/2+g1 end if end if pos=pos+8 else if (loctyp(j) == LOC_QUA .or. loctyp(j) == LOC_CAT) then if (dataset%plocus(ii,locpos(j)) == MISS) then write(phen, '(a8)', advance='no') ' -9999' else write(phen, '(f8.4)', advance='no') dataset%plocus(ii,locpos(j)) end if pos=pos+8 else if (loctyp(j) == LOC_AFF) then if (dataset%plocus(ii,locpos(j)) == MISS) then write(phen,'(a8)', advance='no') ' -9999' else if (dataset%plocus(ii,locpos(j)) == 1) then write(phen,'(a8)', advance='no') '1' else if (dataset%plocus(ii,locpos(j)) == 2) then write(phen,'(a8)', advance='no') '2' end if pos=pos+8 end if end do if (pos > 1) then write(phen,*) pos=1 end if end do end if end do deallocate(alleles) end subroutine wrpap ! ! Write out .gen pedigree file for CRI-MAP ! subroutine wrcri(strm, nloci, loc, loctyp, locpos, locord, dataset) use ped_class use alleles_class use locus_types use locus_list implicit none integer, intent(in) :: strm integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(inout) :: locord type (ped_data) :: dataset integer, parameter :: MISS=-9999 ! local variables type (allele_data), dimension(:), pointer :: alleles integer :: g1, g2, i, j, jj, nord, nmark integer :: fa, mo, sx, num, ped, pedoffset call cntmark(nloci, loctyp, nmark, 1) write(strm,'(i0,1x,i0)') dataset%nact, nmark allocate(alleles(nmark)) nord=0 do j=1, nloci if (isactdip(loctyp(j))) then nord=nord+1 locord(nord)=j call freq(locpos(j), loctyp(j), 0, dataset, alleles(nord)) write(strm,'(a)') trim(loc(j)) end if end do write(strm,*) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset write(strm,'(a)') trim(dataset%pedigree(ped)) write(strm,'(i0)') num do i=pedoffset+1, dataset%num(ped) fa=dataset%fa(i) mo=dataset%mo(i) if (fa == MISS) fa=0 if (mo == MISS) mo=0 sx=dataset%sex(i) if (sx == MISS) then sx=3 else sx=2-sx end if write(strm,'(i0,1x,i0,1x,i0,1x,i0)', advance='no') i, fa, mo, sx do jj=1, nord j=locord(jj) if (observed(i, locpos(j), dataset)) then call get_namedgeno(i, locpos(j), locpos(j)+1, & dataset, alleles(jj), g1, g2) write(strm,'(1x,i3,1x,i3)', advance='no') g1, g2 else write(strm,'(1x,i1,1x,i1)', advance='no') 0, 0 end if end do write(strm, *) end do end if end do deallocate(alleles) end subroutine wrcri ! ! Write VCF GT format ! typ=1 id ! 2 ped_id ! 3 locus information only ! subroutine wrvcf(strm, typ, trait, filnam, allele_buffer, dataset, plevel) use alleles_class use locus_types use locus_data use timelib use iobuff use fileio use scanner use locus_data use ped_class use genetic_maps implicit none integer, intent(in) :: strm integer, intent(in) :: typ integer, intent(in) :: trait character (len=*), intent(inout) :: filnam type (allele_data), intent(inout) :: allele_buffer type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS = -9999 character (len=1), parameter :: tab = achar(9) ! index to matching pedigree record integer, dimension(dataset%nobs) :: idx ! buffer for genotype data integer (kind=1), dimension(:), allocatable :: ibuff ! mapping of alleles to those in VCF file - default 1->0, 2->1 etc integer :: numal integer, dimension(50) :: allele_map ! contigs type (chromosome_data) :: chrom_table character (len=2) :: chrom character (len=256) :: all1, all2, alt_allele, ref_allele character (len=20) :: slin character (len=2048) :: alt_alleles character (len=256) :: prefix integer :: an_count, base, g1, g2, i, ii, ios, j, k, kk, lpos, & nsnps, pos, pos2 integer :: nobs, ped, pedoffset integer (kind=8) :: ngeno integer :: it1, it2, ticks ! functions integer :: aval, ival double precision :: fval call system_clock(it1) call tabulate_chroms(nloci, loc, loctyp, map, group, chrom_table) open(strm, file=filnam, iostat=ios) if (ios /= 0) then write(outstr,'(3a)') 'ERROR: Could not write VCF file "', trim(filnam),'".' return end if write(strm,'(a/a,i8/a)') & '##fileformat=VCFv4.1', & '##filedate=', isodate(), & '##source=Sib-pair' do j=1, chrom_table%nchrom write(strm,'(3a,i0,a)') & '##contig=<ID=', trim(adjustl(chrom_table%chromlabel(j))), ',length=', & nint(1.0d6*chrom_table%chromend(j,1)), '>' end do write(strm,'(a,3(/a))') & '##FORMAT=<ID=GT,Number=1,Type=String,Description="Genotype">', & '##INFO=<ID=AC,Number=A,Type=Integer,Description="Alternate allele count in called genotypes">', & '##INFO=<ID=AN,Number=1,Type=Integer,Description="Total number of alleles in called genotypes">', & '##INFO=<ID=AF,Number=A,Type=Float,Description="Alternate allele frequency from called genotypes">' write(strm,'(15a)',advance='no') & '#CHROM', tab, 'POS', tab, 'ID', tab, 'REF', tab, 'ALT', tab, & 'QUAL', tab, 'FILTER', tab, 'INFO' if (typ /= 3) then write(strm,'(2a)',advance='no') tab, 'FORMAT' end if ! ! Filtering ! call filter_snp(trait, dataset) ! ! IDs ! nobs=0 if (typ == 1) then do i=1, dataset%nobs if (.not.dataset%untyped(i)) then nobs=nobs+1 idx(nobs)=i write(strm,'(2a)',advance='no') tab, trim(dataset%id(i)) end if end do else if (typ == 2) then do i=1, dataset%nobs if (.not.dataset%untyped(i)) then nobs=nobs+1 idx(nobs)=i write(strm,'(2a)',advance='no') & tab, trim(dataset%pedigree(dataset%iped(i))) // '_' // trim(dataset%id(i)) end if end do end if write(strm,*) nsnps=0 ngeno=0 chrom='1 ' if (nobs > 0) then do k=1, nord j=locord(k) if (isactive(loctyp(j)) .and. ismarker(loctyp(j))) then call freq(locpos(j), loctyp(j), 0, dataset, allele_buffer) if (allele_buffer%numal > 0) then nsnps=nsnps+1 numal = allele_buffer%numal an_count=2*allele_buffer%typed ! 20190301 recode STRs to fake polyA repeat ! reordering so major allele appears as reference allele call wrall2(allele_buffer%topall, allele_buffer, all1) ref_allele=trim(adjustl(all1)) alt_alleles='.' allele_map(allele_buffer%topall)=0 ii=0 do i=1, numal if (i /= allele_buffer%topall) then if (ii == 0) then call wrall2(i, allele_buffer, all2) alt_alleles=trim(adjustl(all2)) else call wrall2(i, allele_buffer, all2) alt_alleles=trim(alt_alleles) // ',' // trim(adjustl(all2)) end if ii=ii+1 allele_map(i)=ii end if end do ! ! Check annotation for reference alleles if (numal == 1) then call get_refalleles(locnotes(j), all1, all2) if (all1 == ref_allele .and. all2 /= '0') then alt_alleles=trim(adjustl(all2)) else if (all2 == ref_allele .and. all1 /= '0') then alt_alleles=trim(adjustl(all1)) end if ! Assume annotation alleles are ordered REF, ALT else if (numal == 2) then call get_refalleles(locnotes(j), all1, all2) if (all2 /= ' ' .and. all2 /= '0') then if (all2 == ref_allele .and. all1 == alt_alleles) then if (plevel > 1) then write(outstr,'(6a)') & 'Using ', trim(adjustl(all1)), '/', trim(adjustl(all2)), & ' as reference alleles for ', trim(loc(j)) end if allele_map(1)=1-allele_map(1) allele_map(2)=1-allele_map(2) ref_allele=all1 alt_alleles=all2 end if end if end if if (group(j) /= ' ') chrom=group(j) call frommega(map(j), slin) write(strm,'(13a)', advance='no') & trim(chrom), tab, trim(slin), tab, trim(loc(j)), tab, & trim(adjustl(ref_allele)), tab, trim(adjustl(alt_alleles)), & tab, '.' , tab, '.' ! summary allele counts and frequencies in INFO write(strm,'(2a)', advance='no') tab, 'AC=' if (numal > 1) then ii=0 do i=1, numal if (i /= allele_buffer%topall) then if (ii > 0) then write(strm,'(a)', advance='no') ',' end if write(strm,'(i0)', advance='no') & nint(allele_buffer%allele_freqs(i)*dble(an_count)) ii=ii+1 end if end do else write(strm,'(a)', advance='no') '0' end if write(strm,'(a,i0)', advance='no') ';AN=', an_count if (numal > 0) then write(strm,'(a)', advance='no') ';AF=' ii=0 do i=1, numal if (i /= allele_buffer%topall) then if (ii > 0) then write(strm,'(a)', advance='no') ',' end if write(slin,'(g12.5)') allele_buffer%allele_freqs(i) write(strm,'(a)', advance='no') trim(adjustl(slin)) ii=ii+1 end if end do end if ! genotypes if (typ /= 3) then write(strm,'(2a)', advance='no') tab, 'GT' pos=locpos(j) pos2=pos+1 do i=1, nobs if (.not.observed(idx(i), pos, dataset)) then write(strm,'(2a)', advance='no') tab, './.' else call get_namedgeno(idx(i), pos, pos2, dataset, allele_buffer, g1, g2) ngeno=ngeno+1 write(strm,'(a,i0,a,i0)', advance='no') & tab, allele_map(g1), '/', allele_map(g2) end if end do end if write(strm,*) end if end if end do else do k=1, nord j=locord(k) if (isactive(loctyp(j)) .and. ismarker(loctyp(j))) then nsnps=nsnps+1 call get_refalleles(locnotes(j), ref_allele, alt_alleles) if (group(j) /= ' ') chrom=group(j) call frommega(map(j), slin) write(strm,'(14a)') & trim(chrom), tab, trim(slin), tab, trim(loc(j)), tab, & trim(adjustl(ref_allele)), tab, trim(adjustl(alt_alleles)), & tab, '.' , tab, '.', tab end if end do end if close(strm, status='keep') call system_clock(it2, count_rate=ticks) write(slin, '(f20.2)') float(it2-it1)/float(ticks) slin=adjustl(slin) if (typ /= 3) then write(outstr,'(a,i0,a/6x,i0,a)') & 'Wrote ', nobs, ' individuals', & ngeno, ' nonmissing SNP genotypes (' // trim(slin) // ' s).' else write(outstr,'(a,i0,a)') & 'Wrote locus data for ', nsnps, ' loci.' end if end subroutine wrvcf ! ! Write PLINK .bed format (also used by MENDEL 10.0+) ! subroutine wrbed(strm, filnam, trait, censor, allele_buffer, dataset) use alleles_class use locus_types use locus_data use iobuff use fileio use scanner use locus_data use ped_class implicit none integer, intent(in) :: strm character (len=*), intent(inout) :: filnam integer, intent(inout) :: trait integer, intent(in) :: censor type (allele_data), intent(inout) :: allele_buffer type (ped_data), intent(inout) :: dataset integer, parameter :: KNOWN=0, MISS = -9999 ! index to matching pedigree record integer, dimension(dataset%nobs) :: idx ! buffer for genotype data integer (kind=1), dimension(:), allocatable :: ibuff character (len=2) :: chrom character (len=3) :: all1, all2 character (len=20) :: slin character (len=256) :: prefix integer :: bpos, g1, g2, i, ii, ios, j, k, lpos, & nbytes, nsnps, pos, pos2, sx, tval integer :: nobs, ped, pedoffset integer (kind=8) :: ngeno integer :: it1, it2, ticks logical :: filexist, useable ! functions integer :: aval, ival double precision :: fval call system_clock(it1) prefix=filnam filnam=trim(prefix) // '.bim' ! .bim open(strm, file=filnam, iostat=ios) if (ios /= 0) then write(outstr,'(3a)') 'ERROR: Could not write .bim file "', trim(filnam),'".' return end if nsnps=0 do j=1, nloci if (isactive(loctyp(j)) .and. ismarker(loctyp(j))) then call freq(locpos(j), loctyp(j), 0, dataset, allele_buffer) if (allele_buffer%issnp) then call get_snpallele2(locnotes(j), allele_buffer) end if if (allele_buffer%numal <= 2) then nsnps=nsnps+1 locord(nsnps)=j all1='0' all2='0' if (allele_buffer%numal == 1) then call wrall(allele_buffer%allele_names(1), all2) else if (allele_buffer%numal == 2) then call wrall(allele_buffer%allele_names(1), all1) call wrall(allele_buffer%allele_names(2), all2) end if chrom='1 ' if (group(j) /= ' ') chrom=group(j) if (chrom == 'X' .and. same_loctyp(loctyp(j), LOC_CODOM)) then chrom='XY' end if call frommega(map(j), slin) write(strm,'(a,1x,a,1x,f12.6,1x,a10,1x,a3,1x,a3)') & chrom, loc(j), map(j), slin, all1, all2 end if end if end do close(strm) ! .fam filnam=trim(prefix) // '.fam' open(strm, file=filnam, iostat=ios) if (ios /= 0) then write(outstr,'(3a)') 'ERROR: Could not write .fam file "', trim(filnam),'".' return end if ! filter on filtering trait (censor) nobs=0 call filter_snp(censor, dataset) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (.not.dataset%untyped(i)) then nobs=nobs+1 idx(nobs)=i sx=0 if (dataset%sex(i) /= MISS) sx=int(dataset%sex(i)) tval=2 if (trait /= MISS) then tval=0 if (dataset%plocus(i,trait) /= MISS) tval=dataset%plocus(i, trait) end if if (dataset%fa(i) == MISS) then write(strm,'(a,1x,a,4(1x,i0))') & trim(dataset%pedigree(ped)), trim(dataset%id(i)), 0, 0, sx, tval else write(strm,'(a,3(1x,a),2(1x,i0))') & trim(dataset%pedigree(ped)), trim(dataset%id(i)), & trim(dataset%id(dataset%fa(i))), trim(dataset%id(dataset%mo(i))), sx, tval end if end if end do end if end do close(strm) ! ! write SNP data ! filnam=trim(prefix) // '.bed' inquire(file=trim(filnam), exist=filexist) if (filexist) then write(outstr,'(3a)') 'NOTE: Overwriting existing .bed file "', trim(filnam),'".' call delfile(filnam, -1) end if open(strm, file=filnam, access=stream_access, form=stream_form, iostat=ios) if (ios /= 0) then write(outstr,'(3a)') 'ERROR: Could not write .bed file "', trim(filnam),'".' return end if ! .bed files start 01101100 00011011. write(strm, iostat=ios) int(108, kind=1), int(27, kind=1), int(1, kind=1) ! ! In SNP-major mode, write nobs/4 byte chunks ! 00 Homozygote 1/1 ! 01 Heterozygote 1/2 ! 11 Homozygote 2/2 ! 10 Missing x/x ! ngeno=0 nbytes=int(ceiling(0.25d0*dble(nobs))) allocate(ibuff(nbytes)) do j=1, nsnps lpos=locord(j) pos=locpos(locord(j)) pos2=pos+1 call freq(pos, loctyp(lpos), 0, dataset, allele_buffer) bpos=1 k=0 ibuff=0 do i=1, nobs call get_geno(idx(i), pos, pos2, dataset, g1, g2) if (g1 <= KNOWN) then ibuff(bpos)=ibset(ibuff(bpos),k) else ngeno=ngeno+1 if (g1 == g2) then if (g1 == allele_buffer%allele_names(2)) then ibuff(bpos)=ibset(ibuff(bpos),k) ibuff(bpos)=ibset(ibuff(bpos),k+1) end if else ibuff(bpos)=ibset(ibuff(bpos),k+1) end if end if k=mod(k+2,8) if (k==0) bpos=bpos+1 end do write(strm) ibuff end do close(strm, status='keep') call system_clock(it2, count_rate=ticks) write(slin, '(f20.2)') float(it2-it1)/float(ticks) slin=adjustl(slin) write(outstr,'(a,i0,a/6x,i0,a)') & 'Wrote ', nobs, ' individuals', & ngeno, ' nonmissing SNP genotypes (' // trim(slin) // ' s)' end subroutine wrbed ! ! Write a file of simulated pedigrees ! subroutine simdata(strm, nped, ngen, nminoff, nmaxoff, & pedprefix, totloc, nsimped) use rngs implicit none integer, intent(in) :: strm integer, intent(in) :: nped integer, intent(in) :: ngen integer, intent(in) :: nminoff integer, intent(in) :: nmaxoff character (len=*), intent(in) :: pedprefix integer, intent(in) :: totloc integer, intent(inout) :: nsimped integer, parameter :: MAXSIZ=50000, MISS=-9999 integer :: i, lo, nid, noff, num, ped, thisfa, thismo integer, dimension(MAXSIZ) :: gen, fa, mo, sex character (len=1), dimension(2) :: sx = (/ 'm', 'f' /) do ped=1, nped nsimped=nsimped+1 nid=1 num=nid gen(nid)=1 fa(nid)=MISS mo(nid)=MISS sex(nid)=irandom(1, 2) lo=max(1, nminoff) do while (nid <= num .and. gen(nid) < ngen .and. num<=MAXSIZ) if (gen(nid)>0) then noff=irandom(lo, nmaxoff) if (noff>0 .and. (num+noff+1)<=MAXSIZ) then num=num+1 gen(num)=0 sex(num)=3-sex(nid) fa(num)=MISS mo(num)=MISS if (sex(nid)==1) then thisfa=nid thismo=num else thisfa=num thismo=nid end if do i=1, noff num=num+1 gen(num)=gen(nid)+1 fa(num)=thisfa mo(num)=thismo sex(num)=irandom(1, 2) end do end if end if nid=nid+1 lo=nminoff end do do i=1, num if (fa(i)==MISS) then write(strm,'(a,i0,1x,i0,a,1x,a)', advance='no') & pedprefix, nsimped, i, ' x x', sx(sex(i)) else write(strm,'(a,i0,3(1x,i0),1x,a)', advance='no') & pedprefix, nsimped, i, fa(i), mo(i), sx(sex(i)) end if write(strm,*) repeat(' x', totloc) end do end do end subroutine simdata ! ! Write out data for particular pedigree or particular person ! subroutine showdata(fped, fid, larg, words, near, & nloci, loc, loctyp, locpos, locnotes, & dataset, pedmask, nwid, ndec, ncatwid, sexcode, misval, & show_cat, fieldsep, allsep, pstyle, plevel) use ped_class use outstream use string_utilities integer, intent(in) :: fped integer, intent(in) :: fid integer, intent(in) :: larg character (len=*), dimension(larg), intent(in) :: words integer, intent(in) :: near integer, intent(in) :: nloci character (len=*), dimension(nloci), intent(in) :: loc integer, dimension(nloci), intent(in) :: loctyp integer, dimension(nloci), intent(in) :: locpos character (len=*), dimension(nloci), intent(in) :: locnotes type (ped_data) :: dataset logical, dimension(:), intent(in) :: pedmask integer, intent(in) :: nwid, ndec, ncatwid character (len=*), dimension(2), intent(in) :: sexcode character (len=*), intent(in) :: misval integer, intent(in) :: show_cat character (len=1), intent(in) :: fieldsep character (len=1), intent(in) :: allsep integer, intent(in) :: pstyle, plevel integer :: i, j, hi, k, lo, nrec, ped logical :: found interface subroutine wrind(idx, nloci, loc, loctyp, locpos, dataset, & pedmask, nwid, ndec, misval, allsep, pstyle) use ped_class integer, intent(in) :: idx integer, intent(in) :: nloci character (len=20), dimension(nloci), intent(in) :: loc integer, dimension(nloci), intent(in) :: loctyp integer, dimension(nloci), intent(in) :: locpos type (ped_data) :: dataset logical, dimension(:), intent(in) :: pedmask integer, intent(in) :: nwid integer, intent(in) :: ndec character (len=*), intent(in) :: misval character (len=1), intent(in) :: allsep integer, intent(in) :: pstyle end subroutine subroutine pedout(strm, header, pedmask, fieldsep, allsep, imp, nwid, ndec, & ncatwid, sexcode, misval, nrc, skip, filter, show_cat, & nloci, loc, loctyp, locpos, locnotes, dataset) use ped_class integer, intent(in) :: strm integer, intent(in) :: header logical, dimension(:), intent(in) :: pedmask character (len=1), intent(in) :: fieldsep character (len=1), intent(in) :: allsep integer, intent(in) :: imp integer, intent(in) :: ncatwid, nwid integer, intent(in) :: ndec character (len=*), dimension(2), intent(in) :: sexcode character (len=*), intent(in) :: misval integer, intent(in) :: nrc, skip, filter, show_cat integer, intent(in) :: nloci character (len=*), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=*), dimension(:), intent(in) :: locnotes type (ped_data) :: dataset end subroutine pedout subroutine wrvert(nloci, loc, loctyp, locpos, locnotes, & dataset, nwid, ndec, ncatwid, allsep, plevel) use outstream use ped_class use locus_types integer, intent(in) :: nloci character (len=20), dimension(nloci), intent(in) :: loc integer, dimension(nloci), intent(in) :: loctyp integer, dimension(nloci), intent(in) :: locpos character (len=*), dimension(nloci), intent(in) :: locnotes type (ped_data) :: dataset integer, intent(in) :: ncatwid, nwid integer, intent(in) :: ndec character (len=1), intent(in) :: allsep integer, intent(in) :: plevel end subroutine wrvert end interface ! functions ! logical :: strfind dataset%untyped(:)=.true. nrec=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then found=.false. do j=fped, fid-2 if (strfind(words(j)(1:ped_width), dataset%pedigree(ped), 1)) then found=.not.found exit end if end do if (found) then if (fid > larg) then do i=dataset%num(ped-1)+1, dataset%num(ped) dataset%untyped(i)=.false. nrec=nrec+1 end do else do i=dataset%num(ped-1)+1, dataset%num(ped) do j=fid, larg if (strfind(words(j)(1:id_width), dataset%id(i), 1)) then ! ego and <near> nearest neighbours lo=max(dataset%num(ped-1)+1, i-near) hi=min(dataset%num(ped), i+near) do k=lo, hi if (dataset%untyped(k)) then dataset%untyped(k)=.false. nrec=nrec+1 end if end do end if end do end do end if end if end if end do ! write records in standard format if (pstyle == 1) then call pedout(outstr, 1, pedmask, fieldsep, allsep, 0, nwid, ndec, & ncatwid, sexcode, misval, 0, 0, 2, show_cat, nloci, & loc, loctyp, locpos, locnotes, dataset) ! write records vertically else if (pstyle == 4) then call wrvert(nloci, loc, loctyp, locpos, locnotes, & dataset, nwid, ndec, ncatwid, allsep, plevel) ! write records as name=value pairs else do i=1, dataset%nobs if (.not.dataset%untyped(i)) then call wrind(i, nloci, loc, loctyp, locpos, dataset, & pedmask, nwid, ndec, misval, allsep, pstyle) end if end do end if write(outstr,'(/a,i0,a)') 'Printed ',nrec,' records.' end subroutine showdata ! ! Write out data for an individual ! subroutine wrind(idx, nloci, loc, loctyp, locpos, dataset, & pedmask, nwid, ndec, misval, allsep, pstyle) use outstream use ped_class use locus_types use automatic_data integer, intent(in) :: idx integer, intent(in) :: nloci character (len=20), dimension(nloci), intent(in) :: loc integer, dimension(nloci), intent(in) :: loctyp integer, dimension(nloci), intent(in) :: locpos type (ped_data) :: dataset logical, dimension(:), intent(in) :: pedmask integer, intent(in) :: nwid integer, intent(in) :: ndec character (len=*), intent(in) :: misval character (len=1), intent(in) :: allsep integer, intent(in) :: pstyle ! local variables integer, parameter :: KNOWN=0, MISS=-9999 integer :: g1, g2, j, lpos character (len=1) :: ch character (len=7) :: gtp character (len=10) :: fdec character (len=20) :: curloc, loc20 call wrform('f', nwid, ndec, fdec) call wrsex(dataset%sex(idx),ch) if (pedmask(1)) then write(outstr,'(2a)', advance='no') & 'ped=', trim(dataset%pedigree(dataset%iped(idx))) end if if (pedmask(2)) then write(outstr,'(1x,2a)', advance='no') 'id=', trim(dataset%id(idx)) end if if (pedmask(3)) then if (dataset%fa(idx) == MISS) then write(outstr,'(2a)', advance='no') ' fa=', trim(misval) else write(outstr,'(2a)', advance='no') & ' fa=', trim(dataset%id(dataset%fa(idx))) end if end if if (pedmask(4)) then if (dataset%mo(idx) == MISS) then write(outstr,'(2a)', advance='no') ' mo=', trim(misval) else write(outstr,'(2a)', advance='no') & ' mo=', trim(dataset%id(dataset%mo(idx))) end if end if if (pedmask(5)) then write(outstr,'(2a)', advance='no') ' sex=', ch end if do j=ENVNUM+1, nloci if (isactive(loctyp(j))) then lpos=locpos(j) curloc=loc(j) if (ismarker(loctyp(j))) then if (.not.observed(idx, lpos, dataset)) then if (pstyle == 2) then write(outstr,'(1x,3a)', advance='no') & trim(curloc), '=', trim(misval) end if else call get_geno(idx, lpos, lpos+1, dataset, g1, g2) call wrgtp(g1, g2, gtp, allsep, '', 1) call juststr('l',gtp,7) write(outstr,'(1x,3a)', advance='no') trim(curloc), '=', trim(gtp) end if else if (dataset%plocus(idx,lpos) == MISS) then if (pstyle == 2) then write(outstr,'(1x,3a)', advance='no') & trim(curloc), '=', trim(misval) end if else if (loctyp(j) == LOC_AFF) then if (pstyle == 2 .or. dataset%plocus(idx,lpos) /= MISS) then call wraff(dataset%plocus(idx,lpos),ch,1) write(outstr,'(1x,3a)', advance='no') trim(curloc), '=', ch end if else if (pstyle == 2 .or. dataset%plocus(idx,lpos) /= MISS) then if (anint(dataset%plocus(idx,lpos)) == dataset%plocus(idx,lpos)) then write(loc20,'(i0)') int(dataset%plocus(idx,lpos)) else write(loc20,fdec) dataset%plocus(idx,lpos) call juststr('l',loc20,20) end if write(outstr,'(1x,3a)', advance='no') trim(curloc), '=', trim(loc20) end if end if end do write(outstr,*) end subroutine wrind ! ! Write out data for individuals vertically ! subroutine wrvert(nloci, loc, loctyp, locpos, locnotes, & dataset, nwid, ndec, ncatwid, allsep, plevel) use outstream use ped_class use locus_types use automatic_data use read_data use categorical_data integer, intent(in) :: nloci character (len=20), dimension(nloci), intent(in) :: loc integer, dimension(nloci), intent(in) :: loctyp integer, dimension(nloci), intent(in) :: locpos character (len=*), dimension(nloci), intent(in) :: locnotes type (ped_data) :: dataset integer, intent(in) :: ncatwid, nwid integer, intent(in) :: ndec character (len=1), intent(in) :: allsep integer, intent(in) :: plevel ! local variables integer, parameter :: MAXCOL=6, MISS=-9999 integer :: g1, g2, i, j, loclen, slen integer :: nelig, nids integer, dimension(MAXCOL) :: idlist character (len=6) :: adec character (len=:), allocatable :: gtp double precision :: res loclen=10 do j=ENVNUM+1, nloci if (isactive(loctyp(j))) then loclen=max(len_trim(loc(j)), loclen) end if end do call wrform('a', loclen, 0, adec) slen=max(15, ncatwid) allocate(character(len=slen) :: gtp) nelig=0 nids=0 do idx=1, dataset%nobs if (.not.dataset%untyped(idx)) then nelig=nelig+1 if (nelig <= MAXCOL) then nids=nids+1 idlist(nids)=idx end if end if end do if (nelig > MAXCOL) then write(outstr,'(a,i0,a/7x,a,i0,a/)') & 'NOTE: There are ', nelig, ' eligible records,', & 'but only ', nids, ' will be shown!' end if write(outstr, adec, advance='no') 'Pedigree: ' do k=1, nids idx=idlist(k) gtp=dataset%pedigree(dataset%iped(idx)) call juststr('c',gtp,slen) write(outstr,'(a1,a)', advance='no') tabsep, gtp end do write(outstr,*) write(outstr, adec, advance='no') 'Person: ' do k=1, nids idx=idlist(k) gtp=dataset%id(idx) call juststr('c',gtp,slen) write(outstr,'(a1,a)', advance='no') tabsep, gtp end do write(outstr,*) write(outstr,'(a,1x,a)') repeat('-',loclen), repeat('-',slen*nids) if (plevel > 1) then do j=1, ENVNUM write(outstr, adec, advance='no') loc(j) do i=1, nids idx=idlist(i) call autovar(idx, j, nloci, loctyp, locpos, dataset, res) call wrtrait(res, gtp, loctyp(j), get_notes(loc(j), locnotes(j)), & nwid, ndec) write(outstr,'(a1,a)', advance='no') tabsep, gtp end do if (nids < 4) then write(outstr,'(a1,a)', advance='no') tabsep, trim(locnotes(j)) end if write(outstr,*) end do end if do j=ENVNUM+1, nloci if (isactive(loctyp(j))) then write(outstr, adec, advance='no') loc(j) if (ismarker(loctyp(j))) then do i=1, nids idx=idlist(i) if (.not.observed(idx, locpos(j), dataset)) then gtp=' x/x' else call get_geno(idx, locpos(j), locpos(j)+1, dataset, g1, g2) call wrgtp(g1, g2, gtp, allsep, '', 1) end if write(outstr,'(a1,a)', advance='no') tabsep, gtp end do else do i=1, nids idx=idlist(i) call wrtrait(dataset%plocus(idx,locpos(j)), gtp, & loctyp(j), get_notes(loc(j), locnotes(j)), nwid, ndec) write(outstr,'(a1,a)', advance='no') tabsep, gtp end do end if if (nids < 4) then write(outstr,'(a1,a)', advance='no') tabsep, trim(locnotes(j)) end if write(outstr,*) end if end do end subroutine wrvert ! ! print one genotype from dataset ! subroutine prgtp(idx, gene, dataset, gtp) use ped_class integer, intent(in) :: idx integer, intent(in) :: gene type (ped_data) :: dataset character (len=*), intent(out) :: gtp integer, parameter :: KNOWN=0, MISS=-9999 integer :: g1, g2 if (observed(idx, gene, dataset)) then call get_geno(idx, gene, gene+1, dataset, g1, g2) call wrgtp(g1, g2, gtp, '/', '', 1) else call wrgtp(MISS, MISS, gtp, '/', '', 1) end if end subroutine prgtp ! ! Write id as justified (l,c,r) string, possibly indicating sex ! as male [101] or female (102) ! subroutine wrid(just, id, chid, sx) character (len=1), intent(in) :: just character (len=*), intent(in) :: id character (len=*), intent(out) :: chid integer, intent(in) :: sx ! local variables integer :: lench, lenid, sta character (len=1), dimension(2) :: left=(/'[','('/), right=(/']',')'/) chid=' ' lench=len(chid)-2 lenid=len_trim(id) sta=max(1,lenid-lench+1) if (sx == 1 .or. sx == 2) then chid=left(sx) // id(sta:lenid) // right(sx) else chid=id(sta:lenid) end if call juststr(just,chid,len(chid)) return end subroutine wrid ! ! Write out a percentage ! function wrpercent(num, den) character (len=8) :: wrpercent integer, intent(in) :: num, den character (len=5) :: str if (num==0 .or. den==0) then str='0' else write(str, '(f5.1)') dble(100*num)/dble(den) end if wrpercent='(' // trim(adjustl(str)) // '%)' end function wrpercent ! function wrpercentd(num, den) character (len=8) :: wrpercentd double precision, intent(in) :: num, den character (len=5) :: str if (num == 0.0d0 .or. den == 0.0d0) then str='0' else write(str, '(f5.1)') 100.0d0*num/den end if wrpercentd='(' // trim(adjustl(str)) // '%)' end function wrpercentd ! function wrpercentl(num, den) character (len=8) :: wrpercentl integer (kind=8), intent(in) :: num, den character (len=5) :: str if (num == 0 .or. den == 0) then str='0' else write(str, '(f5.1)') 100.0d0*dble(num)/dble(den) end if wrpercentl='(' // trim(adjustl(str)) // '%)' end function wrpercentl ! ! Write out trait value to a string ! subroutine wrtrait(val, str, typ, catlabels, nwid, ndec) use locus_types use recast_data use scanner double precision, intent(in) :: val character (len=*), intent(out) :: str integer, intent(in) :: typ character (len=*), intent(in) :: catlabels integer, intent(in) :: nwid, ndec integer, parameter :: MISS=-9999 integer :: nblank, g1, g2, mid, slen double precision :: toobig character (len=10) :: fstring character (len=50) :: buffer if (val == MISS) then str=repeat(' ',nwid-ndec) // 'x' return end if str=' ' if (isactdip(typ)) then call decgtp(val, g1, g2) call wrgtp(g1, g2, str, '/', catlabels, 1) else if (same_loctyp(typ, LOC_HAP)) then call decgtp(val, g1, g2) if (g1 == g2) then call wrall(g1, str) nblank=len(str)-len_trim(adjustl(str)) str=repeat(' ', nblank/2 + 1) // adjustl(str) else call wrgtp(g1, g2, str, '/', catlabels, 1) end if else if (typ == LOC_AFF) then call get_label(val, catlabels, str, .true.) if (str == '1') then str=repeat(' ',nwid-ndec) // 'n' else if (str == '2') then str=repeat(' ',nwid-ndec) // 'y' else if (str(1:2) == '1=') then str='n' // str(2:len(str)) else if (str(1:2) == '2=') then str='y' // str(2:len(str)) end if else if (typ == LOC_CAT .or. typ == LOC_SPECIAL) then call get_label(val, catlabels, str, .true.) end if if (str == ' ') then slen=len(str) toobig=dble(10**(nwid-ndec-1)) if (val > toobig .or. & (val < 0.0d0 .and. -10.0d0*val > toobig)) then if (anint(val) == val) then call wrform('i', nwid, 0, fstring) write(buffer,fstring) int(val) else call wrform('g', nwid, ndec, fstring) write(buffer,fstring) val end if buffer=adjustl(buffer) if (len_trim(buffer) > slen) then str=buffer(1:(slen-1)) // '*' else str=buffer end if else if (anint(val) == val) then call wrform('i', min(nwid-ndec+1,slen), 0, fstring) write(str,fstring) int(val) else call wrform('f', slen, max(0, slen-nwid+ndec), fstring) write(str,fstring) val end if end if end if end if end subroutine wrtrait ! ! Extract annotations from locnotes or from macro variable ! dumb version (ie size fixed by caller and length cbuff) ! function get_notes0(loc, locnote) use string_utilities use scheme_lang character (len=*) :: get_notes0 character (len=*), intent(in) :: loc, locnote integer :: fin, istat, sta character (len=16384) :: cbuff cbuff='%labels_' // loc istat=0 sta=1 fin=len_trim(cbuff) call get_var(cbuff, sta, fin, istat) if (cbuff == ' ') cbuff=locnote get_notes0=trim(cbuff) end function get_notes0 ! ! Extract alleles from locus annotation of form "A/B" to string "AB" ! subroutine get_snpallele1(locnote, alleles) character (len=*), intent(in) :: locnote character (len=*), intent(out) :: alleles integer :: pos alleles='12' pos=index(locnote, '/', back=.true.) if (pos > 1) then alleles(1:1)=locnote((pos-1):(pos-1)) alleles(2:2)=locnote((pos+1):(pos+1)) if (verify(alleles, 'ABCGTabcgt12') /= 0) then alleles='12' end if end if end subroutine get_snpallele1 ! ! Extract alleles from locus annotation of form "A/B" to allele data structure ! subroutine get_snpallele2(locnote, allele_buffer) use alleles_class character (len=*), intent(in) :: locnote type (allele_data), intent(inout) :: allele_buffer integer :: i, pos character (len=1) :: ch allele_buffer%allele_names(1)=1 allele_buffer%allele_names(2)=2 pos=index(locnote, '/', back=.true.) if (pos > 1) then i=1 ch=locnote((pos-1):(pos-1)) if (verify(ch, 'ABCGTabcgt') == 0) then allele_buffer%allele_names(i)=10000+ichar(ch) i=i+1 end if ch=locnote((pos+1):(pos+1)) if (verify(ch, 'ABCGTabcgt') == 0) then allele_buffer%allele_names(i)=10000+ichar(ch) end if end if end subroutine get_snpallele2 ! ! Write out a genotype ! typ 1=unobserved and observed same style ! typ 2=unobserved genotypes separated by ":", observed " " ! gtp must be a minimum of 7 characters ! subroutine wrgtp(all1, all2, gtp, allsep, locnote, typ) use scanner integer, intent(in) :: all1 integer, intent(in) :: all2 character (len=*), intent(out) :: gtp character (len=1), intent(in) :: allsep character (len=*), intent(in) :: locnote integer, intent(in) :: typ integer, parameter :: KNOWN=0, MISS=-9999 character (len=3) :: sall integer :: isep, mid isep=0 if (all1 < KNOWN .and. all1 /= MISS) isep=2 mid=len(gtp)/2+1 gtp=' ' if (all1 == MISS) then sall=' x' else if (all1 == KNOWN) then sall=' -' else if (abs(all1) > 10000) then sall=char(abs(all1)-10000) else if (locnote /= ' ') then call get_label(dble(abs(all1)), locnote, sall, .false.) if (sall == ' ') write(sall,'(i3)') abs(all1) else write(sall,'(i3)') abs(all1) end if end if end if call juststr('r', sall, 3) gtp((mid-3):(mid-1))=sall if (all2 == MISS) then sall='x ' else if (all2 == KNOWN) then sall='- ' else if (abs(all2) > 10000) then sall=char(abs(all2)-10000) else if (locnote /= ' ') then call get_label(dble(abs(all2)), locnote, sall, .false.) if (sall == ' ') write(sall,'(i3)') abs(all2) else write(sall,'(i3)') abs(all2) end if end if end if call juststr('l',sall, 3) gtp((mid+1):(mid+3))=sall if (mod(typ,2) == 1) then gtp(mid:mid)=allsep end if if (typ > 1 .and. isep /= 0) then gtp(mid:mid)=':' end if end subroutine wrgtp ! ! Write an allele ! subroutine wrall(iall, allel) integer, intent(in) :: iall character (len=*), intent(out) :: allel integer, parameter :: MISS=-9999 integer, parameter :: KNOWN=0 if (iall == MISS) then allel='x' else if (iall == KNOWN) then allel='-' else if (abs(iall) > 10000) then allel=char(abs(iall)-10000) else write(allel,'(i0)') abs(iall) end if allel=adjustr(allel) end subroutine wrall ! ! Code large numbered alleles, usually STRs, as ! fake polyA alleles ! subroutine wrall2(anum, allele_buffer, allel) use alleles_class type (allele_data), intent(inout) :: allele_buffer integer, intent(in) :: anum character (len=*), intent(out) :: allel integer, parameter :: MISS=-9999 integer, parameter :: KNOWN=0 integer :: ia if (anum == MISS) then allel='x' else if (anum == KNOWN) then allel='-' else ia=abs(allele_buffer%allele_names(anum)) if (ia > 10000) then allel=char(ia-10000) else allel=repeat('A', anum) end if end if allel=adjustr(allel) end subroutine wrall2 ! ! Justify a string of characters within a string ! subroutine juststr(just,string,length) character (len=1), intent(in) :: just character (len=*), intent(inout) :: string integer, intent(in) :: length integer :: fin,i,j,sta if (len_trim(string) == 0) return sta=1 do while (string(sta:sta) == ' '.and. sta <= length) sta=sta+1 end do fin=length do while (string(fin:fin) == ' '.and. fin > 0) fin=fin-1 end do i=length-fin+sta if (just == 'c') then i=(i+1)/2 else if (just == 'l') then i=1 end if j=i+fin-sta ! This seems to be quickest string(i:j)=string(sta:fin) string(1:i-1)=' ' string(j+1:length)=' ' end subroutine juststr ! ! Initialize array with value of index ! subroutine ascend(n, ia) integer, intent(in) :: n integer, dimension(:), intent(inout) :: ia integer :: i do i=1, n ia(i)=i end do end subroutine ascend ! ! See if all members of a pedigree are connected ! subroutine connect(num, fa, mo, set, nsub, maxgrp) integer, intent(in) :: num integer, dimension(:), intent(in) :: fa integer, dimension(:), intent(in) :: mo integer, dimension(:,:), intent(out) :: set integer, intent(out) :: nsub integer, intent(out) :: maxgrp integer, parameter :: MISS=-9999 interface subroutine addlist(pos,idx,set) integer, intent(in) :: pos integer, intent(in) :: idx integer, dimension(:,:), intent(inout) :: set end subroutine addlist end interface ! local variables integer :: biggrp,i,idx,numgrp logical :: fin, stillcluster fin = .false. stillcluster=.true. do i=1, num set(i,1)=MISS set(i,2)=MISS end do biggrp=1 idx=1 maxgrp=0 numgrp=1 nsub=1 set(idx,1)=nsub set(idx,2)=idx if (num == 1) return ! ! while able to update, indicate if individual is part of cluster ! connected to index individual ! do while (stillcluster) do fin=.true. do i=1, num if (set(i,1) == nsub .and. fa(i) /= MISS) then if (set(fa(i),1) == MISS) then call addlist(fa(i),idx,set) numgrp=numgrp+1 fin=.false. end if if (set(mo(i),1) == MISS) then call addlist(mo(i),idx,set) numgrp=numgrp+1 fin=.false. end if else if (set(i,1) == MISS) then if (fa(i) /= MISS) then if (set(fa(i),1) == nsub .or. set(mo(i),1) == nsub) then call addlist(i,idx,set) numgrp=numgrp+1 fin=.false. end if end if end if end do if (fin) exit end do ! ! Test whether ungrouped individuals remain in pedigree ! If yes, initiate new group around a new index and iterate ! if (numgrp > maxgrp) then biggrp=nsub maxgrp=numgrp end if stillcluster=.false. do i=1, num if (set(i,1) == MISS) then idx=i nsub=nsub+1 set(idx,1)=nsub set(idx,2)=idx numgrp=1 stillcluster=.true. exit end if end do end do ! ! Make biggest subpedigree No. 1 ! if (biggrp /= 1) then do i=1, num if (set(i,1) == biggrp) then set(i,1)=1 else if (set(i,1) == 1) then set(i,1)=biggrp end if end do end if end subroutine connect ! ! Shift an individual from the list of ungrouped individuals ! to the appropriate group (subpedigree) nucleating around the index person. ! subroutine addlist(pos, idx, set) integer, intent(in) :: pos integer, intent(in) :: idx integer, dimension(:,:), intent(inout) :: set ! ! add the current person to the list after the index person for that family ! set(pos,2)=set(idx,2) set(pos,1)=set(idx,1) set(idx,2)=pos end subroutine addlist ! ! Find list number <target> ! subroutine findlist(trget, num, set, pos) integer, intent(in) :: trget integer, intent(in) :: num integer, dimension(:,:), intent(in) :: set integer, intent(out) :: pos integer, parameter :: MISS=-9999 do pos=1, num if (set(pos,1) == trget) then return end if end do ! list not found pos=MISS end subroutine findlist ! ! Find pathological loops in current pedigree ! subroutine badloop(pedigree, num, id, key, fa, mo, nerr) use idstring_widths use outstream character (len=*) :: pedigree integer, intent(in) :: num character (len=*), dimension(:), intent(in) :: id integer, dimension(:), intent(in) :: key, fa, mo integer, intent(inout) :: nerr integer, parameter :: MISS=-9999 integer :: bad, i, j, k logical :: unchanged character (len=id_width) :: cfa, cmo integer, dimension(num, num) :: link link=0 do i=1, num if (fa(i) /= MISS) then link(fa(i),i)=1 link(mo(i),i)=1 end if end do do unchanged=.true. do i=1, num do j=1, num if (link(i,j) > 0) then do k=1, j-1 if (link(j,k) > 0 .and. link(i,k)==0) then link(i,k)=link(i,j)+link(j,k) unchanged=.false. end if end do do k=j+1, num if (link(j,k) > 0 .and. link(i,k)==0) then link(i,k)=link(i,j)+link(j,k) unchanged=.false. end if end do end if end do end do if (unchanged) exit end do unchanged=.true. do i=1, num if (link(i,i) > 0) then unchanged=.false. nerr=nerr+1 exit end if end do if (.not.unchanged) then write(outstr,'(/a//a/a)') & 'ERROR: Pathological loop involving: ', & 'Pedigree ID Father Mother', & '--------------- -------------- -------------- --------------' do i=1, num if (link(i,i) > 0) then cfa='x' cmo='x' if (fa(i) /= MISS) then cfa=id(key(fa(i))) cmo=id(key(mo(i))) end if write(outstr,'(a15,3(1x,a14))') trim(pedigree), id(key(i)), cfa, cmo end if end do write(outstr,*) end if end subroutine badloop ! ! List the members of pedigree(s) ! subroutine wrsubped(pedigree, num, id, key, set, nsub, maxgrp, plevel) use outstream use idstring_widths character (len=ped_width), intent(inout) :: pedigree integer, intent(in) :: num character (len=id_width), dimension(:), intent(inout) :: id integer, dimension(:), intent(inout) :: key integer, dimension(:,:), intent(inout) :: set integer, intent(inout) :: nsub integer, intent(in) :: maxgrp integer, intent(in) :: plevel integer, parameter :: MISS=-9999 ! local variables integer :: i write(outstr,'(/3a,i6,a/7x,a,i7,a/)') 'NOTE: Pedigree ', & trim(pedigree),' contains ',nsub,' disjoint pedigrees.', & 'The largest subpedigree contains ',maxgrp,' members.' if (num-maxgrp < 20 .and. maxgrp > num/3) then do i=1, num if (set(i,1) /= 1) then write(outstr,'(/5a)') & 'NOTE: ',trim(pedigree),'-', trim(id(key(i))), & ' is not a member of the main pedigree.' end if end do write(outstr,*) end if if (plevel > 1) then write(outstr,'(/a,i3,a/)') 'Members of largest subpedigree (N=',maxgrp,')' do i=1, num if (set(i,1) == 1) then write(outstr,'(3a)') trim(pedigree),'-', trim(id(key(i))) end if end do write(outstr,*) end if end subroutine wrsubped ! ! Work out generation number ord(). ! Visit every person in each subpedigree in turn. ! The missing value for generation must be a large negative value. ! subroutine gener(pedigree, num, fa, mo, nsub, set, ord, higen, nerr, plevel) use outstream use idstring_widths character (len=ped_width), intent(in out) :: pedigree integer, intent(in) :: num integer, dimension(:), intent(in) :: fa integer, dimension(:), intent(in) :: mo integer, intent(in) :: nsub integer, dimension(:,:), intent(in) :: set integer, dimension(:), intent(out) :: ord integer, intent(out) :: higen integer, intent(out) :: nerr integer, intent(in) :: plevel integer, parameter :: MISGEN=-999999 integer, parameter :: MISS=-9999 integer :: cfa, cgen, cmo, curped, dit, i, idx, it, maxit integer :: logen, upgen logical :: fin, fin2 interface subroutine findlist(trget, num, set, pos) integer, intent(in) :: trget integer, intent(in) :: num integer, dimension(:,:), intent(in) :: set integer, intent(out) :: pos end subroutine findlist end interface nerr=0 higen=1 maxit=2*num do i=1, num ord(i)=MISGEN end do ! ! do each subpedigree in turn ! do curped=1, nsub call findlist(curped, num, set, idx) upgen=0 logen=0 ord(idx)=0 if (plevel > 1) then write(outstr,'(a,i5,a,i5)') 'Evaluating sub-pedigree ',curped, & ' via index individual ',idx end if it=0 i=idx ! ! Each iteration moves as far down the pedigree as possible then ! moves up no more than one generation ! do it=it+1 fin=.true. ! down leg dit=0 do fin2=.true. dit=dit+1 if (dit > maxit) then write(outstr,'(/5a/)') & 'ERROR: Probable pathological loop (eg own grandfather) ', & 'in pedigree ', trim(pedigree), '.' nerr=1 return end if do if (fa(i) /= MISS) then cfa=fa(i) cmo=mo(i) cgen=max(ord(cfa),ord(cmo))+1 ! cgen=min(ord(cfa),ord(cmo))+1 if ((ord(cfa) /= MISGEN .or. ord(cmo) /= MISGEN) .and. & ord(i) /= cgen) then fin2=.false. ord(i)=cgen end if end if i=set(i,2) if (i == idx) exit end do if (fin2) exit end do ! up leg do if (fa(i) /= MISS) then cgen=ord(i) if (cgen /= MISGEN) then cfa=fa(i) cmo=mo(i) if (ord(cfa) == MISGEN .or. & (fa(cfa) == MISS .and. cgen <= ord(cfa))) then ord(cfa)=cgen-1 fin=.false. end if if (ord(cmo) == MISGEN .or. & (fa(cmo) == MISS .and. cgen <= ord(cmo))) then ord(cmo)=cgen-1 fin=.false. end if end if end if i=set(i,2) if (i == idx) exit end do ! check if finished and update max and min generation number if (fin .or. it > maxit) exit end do if (it > maxit) then write(outstr,'(/a,i3,a/7x,4a/)') & 'NOTE: Exceeded ',maxit,' iterations while calculating', & 'generation number for pedigree ', trim(pedigree), & ', subpedigree ',curped end if ! ! end of main loop ! ! adjust generation numbering to 1..G for founders, marry-ins etc ! do if (ord(i) > upgen) then upgen=ord(i) else if (ord(i) < logen) then logen=ord(i) end if i=set(i,2) if (i == idx) exit end do logen=1-logen upgen=upgen+logen ! do if (fa(i) == MISS) then ord(i)=ord(i)+logen else ord(i)=MISGEN end if i=set(i,2) if (i == idx) exit end do ! ! redo nonfounders, now that all founders set correctly ! it=0 do it=it+1 fin=.true. ! ! if both parents have a known generation number, set index to ! max(fa_gen,mo_gen)+1 ! do if (fa(i) /= MISS) then cfa=fa(i) cmo=mo(i) if (ord(i) == MISGEN) then if (ord(cfa) /= MISGEN .and. ord(cmo) /= MISGEN) then ord(i)=max(ord(cfa),ord(cmo))+1 else fin=.false. end if end if end if i=set(i,2) if (i == idx) exit end do if (fin) exit end do if (upgen > higen) higen=upgen end do end subroutine gener ! ! Write out pedigrees as list of nuclear families plus marry-ins by ! generation number ! subroutine dogen(dataset, trait, typ, plevel) use outstream use ped_class implicit none type (ped_data) :: dataset integer, intent(in) :: trait integer, intent(in) :: typ integer, intent(in) :: plevel ! local variables integer, parameter :: MISS=-9999 integer :: biggest, curped, deepest, higen, i, ii, maxgrp, nped, nsub, & onegen, onemem, nerr, nobs, num, ped, pedoffset, totgen integer, dimension(dataset%maxsiz) :: fa, mo, imztwin, ord integer, dimension(dataset%maxsiz, 2) :: set character (len=ped_width) :: bigped, deeped interface subroutine connect(num,fa,mo,set,nsub,maxgrp) integer, intent(in) :: num integer, dimension(:), intent(in) :: fa integer, dimension(:), intent(in) :: mo integer, dimension(:,:), intent(out) :: set integer, intent(out) :: nsub integer, intent(out) :: maxgrp end subroutine connect subroutine gener(pedigree,num,fa,mo,nsub,set,ord,higen, nerr,plevel) use idstring_widths character (len=ped_width), intent(in out) :: pedigree integer, intent(in) :: num integer, dimension(:), intent(in) :: fa integer, dimension(:), intent(in) :: mo integer, intent(in) :: nsub integer, dimension(:,:), intent(in) :: set integer, dimension(:), intent(out) :: ord integer, intent(out) :: higen integer, intent(out) :: nerr integer, intent(in) :: plevel end subroutine gener end interface ! biggest=0 bigped=' ' deeped=' ' deepest=0 nerr=0 nobs=0 nped=0 onegen=0 onemem=0 totgen=0 if (plevel < 1) then write(outstr,'(/a/a)') & 'Pedigree Size Fndrs Gens Disjoint', & '-------------- ------- ----- ----- --------' end if ! do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset if (num > 1) then call workpointers(ped, dataset, fa, mo, imztwin) call connect(num, fa, mo, set, nsub, maxgrp) call gener(dataset%pedigree(ped), num, fa, mo, nsub, set, ord, higen, nerr, 0) else nsub=1 higen=1 ord(1)=1 onemem=onemem+1 end if if (plevel > 0) then write(outstr,'(/a,a14,a,i5,a,i5,a,i2/)') & 'Pedigree ', dataset%pedigree(ped), ' No=', num, & ' No founders=', dataset%nfound(ped), ' No generations=', higen if (nsub > 1) then write(outstr,'(3x,3a,i4,a/)') & 'Disjoint sub-pedigree ', trim(dataset%pedigree(ped)), '-001 (largest, N=',maxgrp,')' end if call wrgen(ped, dataset, 1, set, higen, ord) if (nsub > 1 .and. (nsub <= 10 .or. plevel > 0)) then do curped=2, nsub write(outstr,'(/3x,3a,i3.3/)') & 'Disjoint sub-pedigree ', trim(dataset%pedigree(ped)), '-', curped call wrgen(ped, dataset, curped, set, higen, ord) end do end if else if (nsub > 1) then write(outstr,'(a14,i8,2(1x,i5),3x,a,i4)') & dataset%pedigree(ped), num, dataset%nfound(ped), higen, 'y,', nsub else write(outstr,'(a14,i8,2(1x,i5))') & dataset%pedigree(ped), num, dataset%nfound(ped), higen end if if (higen == 1) onegen=onegen+1 if (num > biggest) then biggest=num bigped=dataset%pedigree(ped) end if if (higen > deepest) then deepest=higen deeped=dataset%pedigree(ped) end if totgen=totgen+higen nped=nped+1 nobs=nobs+num ! ! save the generation number to a quantitative variable if requested if (trait /= MISS) then ii=pedoffset if (typ==1) then do i=1, num ii=ii+1 dataset%plocus(ii,trait)=dble(ord(i)) end do else do i=1, num ii=ii+1 dataset%plocus(ii,trait)=dble(higen-ord(i)+1) end do end if end if end if end do write(outstr,'(/a,i10/a,i10)') & 'Total number of pedigrees = ',nped, & 'Number with only 1 member = ',onemem write(outstr,'(a,i10,3a/a,i0,3a)') & 'Largest pedigree size = ',biggest, ' (Pedigree ', trim(bigped), ')', & 'Deepest pedigree (genrtns) = ',deepest, ' (Pedigree ', trim(deeped), ')' write(outstr,'(/a,f10.1/a,f10.1)') & 'Mean size of pedigrees = ',dble(nobs)/dble(nped), & 'Mean pedigree depth = ',dble(totgen)/dble(nped) if (nped > onegen) then write(outstr,'(a,f10.1/a,f10.1)') & 'Mean size where >1 members = ', dble(nobs-onegen)/dble(nped-onemem), & 'Mean depth where >1 members= ', dble(totgen-onegen)/dble(nped-onegen) end if end subroutine dogen ! ! Write out structure and generation numbers ! List of sibships by generation number ! subroutine wrgen(ped, dataset, curped, set, higen, ord) use outstream use ped_class integer, intent(in) :: ped type (ped_data) :: dataset integer, intent(in) :: curped integer, dimension(dataset%maxsiz,2), intent(in) :: set integer, intent(in) :: higen integer, dimension(dataset%maxsiz), intent(in) :: ord ! assorted counters, indices integer, parameter :: MISS=-9999 integer :: cfa, cmo, eoi, eoi2, i, ii, j, k, mat, pedoffset, pos ! pedoffset=dataset%num(ped-1) do j=1, higen cfa=MISS cmo=MISS pos=0 write(outstr,'(1x,i3,a,$)') j, ': ' ii=0 do i= pedoffset+1, dataset%num(ped) ii=ii+1 if (ord(ii) == j .and. set(ii,1) == curped) then if (dataset%fa(i) /= MISS) then if (dataset%fa(i) /= cfa .or. dataset%mo(i) /= cmo) then cfa=dataset%fa(i) cmo=dataset%mo(i) eoi=len_trim(dataset%id(cfa)) eoi2=len_trim(dataset%id(cmo)) mat=eoi+eoi2+12 pos=mat write(outstr,'(/7x,5a,$)') '{',dataset%id(cfa)(1:eoi),' x ',dataset%id(cmo)(1:eoi2),'}' end if eoi=len_trim(dataset%id(i)) pos=pos+eoi+2 if (pos > 78) then pos=mat+eoi+2 write(outstr,'(/a,$)') ' ' do k=13, mat-1 write(outstr,'(a1,$)') ' ' end do write(outstr,'(a,$)') '+' end if write(outstr,'(2a,$)') '--',dataset%id(i)(1:eoi) else eoi=len_trim(dataset%id(i)) pos=pos+eoi+3 if (pos > 78) then write(outstr,'(/a,$)') ' ' pos=eoi+9 end if write(outstr,'(1x,3a,$)') '(',dataset%id(i)(1:eoi),')' end if end if end do write(outstr,*) end do end subroutine wrgen ! ! Round up allele sizes etc ! subroutine tidydata(nloci, loctyp, locpos, dataset, tottyp) use ped_class use locus_types integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data), intent(inout) :: dataset integer, intent(out) :: tottyp integer, parameter :: MISS=-9999 integer :: g1, g2, gene, gen2, i, j integer (kind=2) :: tmp do j=1, nloci if (isactdip(loctyp(j))) then gene=locpos(j) gen2=gene+1 do i=1, dataset%nobs ! make males homozygotes if X-linked and second allele set to missing call get_geno(i, gene, gen2, dataset, g1, g2) if (same_loctyp(loctyp(j), LOC_XLIN) .and. dataset%sex(i) == 1 .and. & g1 /= MISS .and. g1 /= 0 .and. (g2 == MISS .or. g2 == 0)) then g2=g1 call set_geno(i, gene, gen2, dataset, g1, g2) end if ! order allele values if (g1 == 0 .or. g2 == 0 .or. g1 == MISS .or. g2 == MISS) then g1=MISS g2=MISS call set_geno(i, gene, gen2, dataset, g1, g2) else if (g1 > g2) then call order(g1, g2) call set_geno(i, gene, gen2, dataset, g1, g2) tottyp=tottyp+1 else tottyp=tottyp+1 end if end do else if (loctyp(j) == LOC_AFF) then gene=locpos(j) do i=1, dataset%nobs if (dataset%plocus(i,gene) /= 1.0d0 .and. & dataset%plocus(i,gene) /= 2.0d0) then dataset%plocus(i,gene)=MISS end if end do end if end do end subroutine tidydata ! ! Check for duplicate pedigrees or records ! subroutine duplicates(dataset, plevel) use sorts use ped_class implicit none type (ped_data), intent(in) :: dataset integer, intent(in) :: plevel ! local variables integer, dimension(dataset%nped) :: pedpos character (len=ped_width), dimension(dataset%nped) :: pedname integer :: i, ic1, ic2, j, k, ped, pos, ncopies interface subroutine ascend(n, ia) integer, intent(in) :: n integer, dimension(:), intent(inout) :: ia end subroutine end interface pedname=dataset%pedigree call ascend(dataset%nped, pedpos) call csort(dataset%nped, pedname, pedpos) ncopies=1 pos=1 do ped=2, dataset%nped if (pedname(ped)==pedname(pos)) then ncopies=ncopies+1 else if (ncopies>1) then call showdups(pos, ncopies, pedname, pedpos, dataset, plevel) ncopies=1 pos=ped else pos=ped end if end do if (ncopies>1) then call showdups(pos, ncopies, pedname, pedpos, dataset, plevel) end if end subroutine duplicates ! ! Print the duplicates for current pedigree ! subroutine showdups(pos, ncopies, pedname, pedpos, dataset, plevel) use outstream use ped_class implicit none type (ped_data), intent(in) :: dataset integer, intent(in) :: pos, ncopies integer, dimension(dataset%nped), intent(in) :: pedpos character (len=ped_width), dimension(dataset%nped), intent(in) :: pedname integer, intent(in) :: plevel integer :: ic1, ic2, j, k write(outstr, '(3a,i0,a)') & 'NOTE: Pedigree name "', trim(pedname(pos)), '" has been used for ', & ncopies, ' separate pedigrees in the dataset.' if (plevel > 0) then do ic1=1, ncopies-1 do ic2=ic1+1, ncopies do j=dataset%num(pos+ic1-2)+1, dataset%num(pos+ic1-1) do k=dataset%num(pos+ic2-2)+1, dataset%num(pos+ic2-1) if (dataset%id(j)==dataset%id(k)) then write(outstr,*) trim(pedname(pos)), '--', trim(dataset%id(j)), & ' is duplicated in copies Ped #', pedpos(pos+ic1-1), & ' and Ped #', pedpos(pos+ic2-1) end if end do end do end do end do end if end subroutine showdups ! ! Check haploid markers 1=Y 2=Mit ! subroutine testhap(typ, nloci, loc, loctyp, locpos, & dataset, inconsist, plevel) use outstream use ped_class use locus_types implicit none integer, intent(in) :: typ integer, intent(in) :: nloci character(len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data), intent(inout) :: dataset integer, intent(inout) :: inconsist integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS=-9999 integer :: gene, hapcon, i, incon, j, k, nhloc, & nlin, num, ped, pedoffset, tottyp integer :: g1, g2, g3, g4, ii, kk character (len=3) :: all1, all2 character (len=9) :: snum, relate ! work arrays integer, dimension(nloci) :: hloc, hlocpos, nproblems, ncompared, nprobpeds, & thisprob integer, dimension(dataset%maxsiz) :: lineage ! functions interface subroutine wrall(iall, allel) integer, intent(in) :: iall character (len=*), intent(out) :: allel end subroutine wrall end interface ! ! check if any haploid type markers nhloc=0 do j=1, nloci if (same_loctyp(loctyp(j), LOC_HAP)) then if ((typ == 1 .and. .not.same_loctyp(loctyp(j), LOC_MIT)) .or. & (typ == 2 .and. .not.same_loctyp(loctyp(j), LOC_YHA))) then nhloc=nhloc+1 hloc(nhloc)=j hlocpos(nhloc)=locpos(j) nproblems(nhloc)=0 nprobpeds(nhloc)=0 ncompared(nhloc)=0 end if end if end do if (nhloc == 0) then write(outstr,'(/a)') 'No haploid markers.' return else write(outstr,'(/a,i5,a/)') 'There are', nhloc, ' eligible haploid markers.' end if ! do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) dataset%untyped(i)=.true. hapcon=0 do j=1, nhloc if (observed(i, hlocpos(j), dataset)) then hapcon=hapcon+1 end if end do if (hapcon > 0) then if (dataset%sex(i) == 1 .or. typ == 2) then dataset%untyped(i)=.false. else if (dataset%sex(i) == 2) then write(snum, '(i9)') hapcon snum=adjustl(snum) write(outstr,'(7a)') 'NOTE: ', & trim(dataset%pedigree(ped)), '--', trim(dataset%id(i)), & ' is female and is typed at ', trim(snum), ' Y-chromosome loci.' end if end if end do end if end do ! if (plevel >= 0) then write(outstr,'(/a/a)') & 'Pedigree Person1 Person2 Relation Marker All1 All2', & '------------ ------------ ------------ -------- ------------- ---- ----' else write(outstr,*) end if ! do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset ii=pedoffset nlin=0 if (typ==1) then do i=1, dataset%nfound(ped) ii=ii+1 if (dataset%sex(ii)==1) then nlin=nlin+1 lineage(i)=nlin else lineage(i)=0 end if end do do i=dataset%nfound(ped)+1, num ii=ii+1 if (dataset%sex(ii)==1) then lineage(i)=lineage(dataset%fa(ii)-pedoffset) end if end do else if (typ==2) then do i=1, dataset%nfound(ped) ii=ii+1 nlin=nlin+1 lineage(i)=nlin end do do i=dataset%nfound(ped)+1, num ii=ii+1 lineage(i)=lineage(dataset%mo(ii)-pedoffset) end do end if do j=1, nhloc thisprob(j)=0 end do ii=pedoffset do i=1, num-1 ii=ii+1 if (.not.dataset%untyped(ii)) then kk=max(pedoffset+dataset%nfound(ped)-1, ii) do k=max(dataset%nfound(ped), i+1), num kk=kk+1 if (.not.dataset%untyped(kk) .and. lineage(k)==lineage(i)) then tottyp=0 hapcon=0 do j=1, nhloc gene=hlocpos(j) if (observed(kk, gene, dataset) .and. & observed(ii, gene, dataset)) then tottyp=tottyp+1 ncompared(j)=ncompared(j)+1 call get_geno(ii, gene, gene+1, dataset, g1, g2) call get_geno(kk, gene, gene+1, dataset, g3, g4) if (g1 == g3) then hapcon=hapcon+1 else thisprob(j)=thisprob(j)+1 nproblems(j)=nproblems(j)+1 if (plevel >= 0) then relate=' ' if (k > dataset%nfound(ped)) then if (typ==1) then if (dataset%fa(kk)==ii) then relate='Paternal' else if (dataset%fa(kk)==dataset%fa(ii)) then relate='Fraternal' end if else if (typ==2) then if (dataset%mo(kk)==ii) then relate='Maternal' else if (dataset%mo(kk)==dataset%mo(ii)) then relate='Sibling' end if end if end if call wrall(g1, all1) call wrall(g3, all2) write(outstr,'(a12,2(1x,a12),4(1x,a))') & dataset%pedigree(ped), dataset%id(ii), & dataset%id(kk), relate, loc(hloc(j)), all1, all2 end if end if end if end do if (plevel < 0 .and. hapcon < tottyp) then write(snum, '(i9)') tottyp-hapcon snum=adjustl(snum) if (typ == 1) then write(outstr,'(7a)') & 'Y-haplotype inconsistencies (', trim(snum), ') involving ', & trim(dataset%pedigree(ped)), '--', trim(dataset%id(ii)), '.' else if (typ == 2) then write(outstr,'(7a)') & 'Mitochondrial haplotype inconsistencies (', trim(snum), ') involving ', & trim(dataset%pedigree(ped)), '--', trim(dataset%id(ii)), '.' end if end if end if end do end if end do do j=1, nhloc if (thisprob(j) /= 0) then nprobpeds(j)=nprobpeds(j)+1 end if end do end if end do write(outstr, '(/a/a)') 'Locus Incon Compared Prop N Peds', & '------------ ------ -------- ------ --------' do j=1, nhloc write(outstr, '(a12,i8,i10,1x,f6.4,1x,i9)') & loc(hloc(j)), nproblems(j), ncompared(j), & dble(nproblems(j))/dble(max(1,ncompared(j))), nprobpeds(j) end do end subroutine testhap ! ! Check sex using sex-linked markers assuming false het call rate z ! ! Male outcomes A AB B ! p(1-z) z q(1-z) ! ! Female outcomes AA AB BB ! pp(1-z) 2pq+z(1-2pq) qq(1-z) ! ! LR(G=AB) = Pr(AB|Sex=M)/Pr(AB|Sex=Female) ! z ! = ----------------------- ! 2pq+z(1-2pq) ! = z/(2pq+z(1-2pq)) ! ! LR(G=AA) = Pr(A|Sex=M)/Pr(AA|Sex=Female) ! p ! = ----------------------- ! p^2 ! = 1/p ! ! Absence of Y-haplotype data can be female sex or ungenotyped ! With core exome data at least, a subset of Y snps regularly appear ! typed in females, but Scott Gordon points out there is still strongly ! informative bimodality in total typed per individual. ! subroutine testsex(seximpute, sexcrit, sexmarker, heterror, & nloci, loc, lochash, loctyp, locpos, & dataset, allele_buffer, inconsist, plevel) use outstream use ped_class use alleles_class use locus_types use locus_list use idhash_class use contingency_table use statfuns implicit none ! impute sex where possible integer, intent(in) :: seximpute ! sexcrit=threshold for significant sex test double precision, intent(in) :: sexcrit character(len=20), intent(in) :: sexmarker ! heterror=overall error rate true homozygotes -> apparent heterozygotes double precision, intent(in) :: heterror integer, intent(in) :: nloci character(len=20), dimension(:), intent(in) :: loc type (hash_table) :: lochash integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data), intent(inout) :: dataset type (allele_data), intent(inout) :: allele_buffer integer, intent(inout) :: inconsist integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS=-9999 integer :: g1, g2, gene, gen2, i, isex1, isex2, isex3, isex4, j, ped, & sexpos, sexp2, totmalhet, totmalgeno, xgene, ygene, yerrs, & ymaleclass integer :: nchanges logical :: incon character (len=1) :: sx character (len=7) :: sexgtp double precision :: p ! classification matrix: X, Y, AMEL integer, dimension(3, 9) :: classed ! ! zerr=assumed false X-heterozygote call rate ! emperr=empirical X-hom -> het error rate in males double precision :: emperr, zerr ! ymalethresh=assumed number of Y-genotypes observable in females integer :: ymalethresh ! work arrays integer, dimension(:), allocatable :: nxloci, nyloci, xhets double precision, dimension(:), allocatable :: sexrat ! tabulate numbers of heterozygote X marker genotypes per individual type (table_data) :: xtable ! tabulate numbers of genotyped Y markers type (table_data) :: ytable double precision, dimension(1) :: val ! Fit mixture model for presence of Y-haplotypes or X-hets double precision :: alpha(3), mean(3), sd(3), logl(3) integer :: df(3) double precision :: pval, lrts ! Likelihood contributions double precision, dimension(:,:), allocatable :: prob, xprob double precision, dimension(:), allocatable :: den, xden ! functions character (len=6) :: pstring interface function getfreq(allele, allele_set) use alleles_class double precision getfreq integer :: allele type (allele_data), intent(in) :: allele_set end function getfreq subroutine wrsex(sex,ch) integer, intent(in) :: sex character (len=*), intent(out) :: ch end subroutine wrsex end interface ! ! check if any sex-informative markers xgene=0 ygene=0 do j=1, nloci if (same_loctyp(loctyp(j), LOC_XLIN)) then xgene=xgene+1 else if (same_loctyp(loctyp(j), LOC_YHA)) then ygene=ygene+1 end if end do sexpos=MISS if (sexmarker /= ' ') then call gettrait(sexmarker, LOC_CODOM, LOC_XLIN, nloci, & loc, lochash, loctyp, sexpos, -1) if (sexpos /= MISS) then sexpos=locpos(sexpos) sexp2=sexpos+1 end if end if if ((ygene+xgene) == 0 .and. sexpos == MISS) then write(outstr,'(a)') 'No sex-informative markers.' return end if ymalethresh=1 zerr=0.001d0 if (heterror /= MISS) zerr=heterror ! classed=0 df=0 yerrs=0 logl=0.0d0 allocate(sexrat(dataset%nobs)) allocate(xhets(dataset%nobs)) allocate(nxloci(dataset%nobs)) allocate(nyloci(dataset%nobs)) do i=1, dataset%nobs nxloci(i)=0 nyloci(i)=0 xhets(i)=0 sexrat(i)=0.0d0 end do totmalhet=0 totmalgeno=0 emperr=0.0d0 if (xgene > 0) then do j=1, nloci if (same_loctyp(loctyp(j), LOC_XLIN)) then gene=locpos(j) gen2=gene+1 call freq(gene, loctyp(j), 0, dataset, allele_buffer) if (allele_buffer%numal > 1) then do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (observed(i, gene, dataset)) then nxloci(i)=nxloci(i)+1 call get_geno(i, gene, gen2, dataset, g1, g2) p=getfreq(g1, allele_buffer) if (g1 /= g2) then xhets(i)=xhets(i)+1 p=p*getfreq(g2, allele_buffer) p=p+p sexrat(i)=sexrat(i)+log(zerr)-log(p+zerr*(1.0d0-p)) else sexrat(i)=sexrat(i)-log(p) end if end if end do end if end do end if end if end do ! Test for mixture of X-het proportions in sample call setup_table(1, 50, xtable) do i=1, dataset%nobs if (nxloci(i) > 0) then val(1)=dble(xhets(i))/dble(nxloci(i)) call insert_table(1, val, xtable, 1) end if end do call sort_table(xtable) call dohist('X-het rate', min(xtable%ncells, 20), 1, xtable, 6, 3, ' ') allocate(xprob(xtable%ncells, 3)) allocate(xden(xtable%ncells)) call fitmix(1, 1, xtable, xprob, xden, alpha, mean, sd, logl(1), df(1), plevel-1) call fitmix(2, 1, xtable, xprob, xden, alpha, mean, sd, logl(2), df(2), plevel-1) call fitmix(3, 1, xtable, xprob, xden, alpha, mean, sd, logl(3), df(3), plevel-1) lrts=logl(2)-logl(1) pval=chip(lrts, df(2)-df(1)) write(outstr,'(/a,g12.1,a,i0,3a/)') & 'Test for mixture of X-het proportions = ', lrts, & ' (df=', df(2)-df(1), ', P=', pstring(pval), ')' end if if (ygene > 0) then nyloci=0 do j=1, nloci if (same_loctyp(loctyp(j), LOC_YHA)) then gene=locpos(j) gen2=gene+1 call freq(gene, loctyp(j), 0, dataset, allele_buffer) if (allele_buffer%numal >= 1) then do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (observed(i, gene, dataset)) then nyloci(i)=nyloci(i)+1 call get_geno(i, gene, gen2, dataset, g1, g2) if (g1 /= g2) then yerrs=yerrs+1 inconsist=inconsist+1 call wrgtp(g1, g2, sexgtp, '/', '', 1) if (yerrs < 5 .or. plevel > 1) then write(outstr,'(4a/7x,5a)') & 'ERROR: Putative Y-marker heterozygote at locus "', & trim(loc(j)) ,'": ', sexgtp, 'for individual ', & trim(dataset%pedigree(ped)), '--', trim(dataset%id(i)), '.' end if end if end if end do end if end do end if end if end do if (yerrs > 4) then write(outstr,'(/a,i0,a)') & 'ERROR: A total of ', yerrs, ' putative Y-marker heterozygote genotypes present.' end if ! fit mixture model for number of ymarkers genotyped call setup_table(1, 50, ytable) do i=1, dataset%nobs if (dataset%actset(dataset%iped(i)) > 0) then val(1)=dble(nyloci(i)) call insert_table(1, val, ytable, 1) end if end do call sort_table(ytable) allocate(prob(ytable%ncells, 2)) allocate(den(ytable%ncells)) call fitmix(1, 4, ytable, prob, den, alpha, mean, sd, logl(1), df(1), plevel-1) call fitmix(2, 4, ytable, prob, den, alpha, mean, sd, logl(2), df(2), plevel-1) lrts=logl(2)-logl(1) pval=chip(lrts, df(2)-df(1)) write(outstr,'(a,g12.1,a,i0,3a)') & 'Test for mixture of Y-marker counts = ', lrts, & ' (df=', df(2)-df(1), ', P=', pstring(pval), ')' if (pval < 0.0001d0) then ymaleclass=2 if (mean(1) > mean(2)) ymaleclass=1 do j=1, ytable%ncells if (alpha(ymaleclass)*prob(j,ymaleclass)/den(ymaleclass) > 0.99d0) then ymalethresh=ytable%categories(ytable%idx(j),1)%rvalue exit end if end do end if write(outstr,'(a,i0,a)') & 'Males defined as genotyped at >= ', ymalethresh, ' Y-markers.' end if ! ! Combined inference for each individual in turn ! write(outstr,'(/a)', advance='no') & 'Pedigree Individual Sex Post.Pr(M) X-marker hets Y-haplos' if (sexpos /= MISS) then write(outstr,'(5x,a)') sexmarker end if write(outstr,'(/a,1x,a,2x,a,2x,a,3x,a,1x,a)', advance='no') & repeat('-',12), repeat('-',14), repeat('-',3), repeat('-',10), & repeat('-',14), repeat('-',8) if (sexpos /= MISS) write(outstr,'(2x,a)', advance='no') repeat('-',11) write(outstr,*) ! ! isex1 = reported sex 1=M 2=? 3=F ! isex2 = X-marker sex ! isex3 = Amelogenin sex ! isex4 = Y-marker sex ! nchanges=0 do i=1, dataset%nobs if (dataset%actset(dataset%iped(i)) > 0) then if (sexrat(i) > 100) then sexrat(i)=1.0d0 else sexrat(i)=exp(sexrat(i))/(1.0D0+exp(sexrat(i))) end if isex1=2 if (dataset%sex(i)==1) then isex1=1 else if (dataset%sex(i)==2) then isex1=3 end if isex2=2 if (sexrat(i) >= sexcrit) then isex2=1 else if (sexrat(i) <= (1.0d0-sexcrit)) then isex2=3 end if classed(isex1, isex2)=classed(isex1, isex2)+1 ! AMEL isex3=2 if (sexpos /= MISS) then if (observed(i, sexpos, dataset)) then call get_geno(i, sexpos, sexp2, dataset, g1, g2) if (g1 /= g2) then isex3=1 else if (g1 == g2) then isex3=3 end if classed(isex1, 6+isex3)=classed(isex1, 6+isex3)+1 end if end if ! Y data isex4=0 if (ygene > 0) then isex4=2 if (nyloci(i) >= ymalethresh) isex4=1 classed(isex1, 3+isex4)=classed(isex1, 3+isex4)+1 end if if (isex1 == 1 .or. isex2 == 1 .or. isex3 == 1 .or. isex4 == 1) then totmalhet=totmalhet+xhets(i) totmalgeno=totmalgeno+nxloci(i) end if ! inconsistent results? incon= (isex1<3 .and. (isex2==3 .or. isex3==3)) .or. & (isex1>1 .and. (isex2==1 .or. isex3==1 .or. isex4==1)) if (plevel > 1 .or. incon) then call wrsex(dataset%sex(i),sx) sexgtp=' ' if (sexpos /= MISS) then if (observed(i, sexpos, dataset)) then call get_geno(i, sexpos, sexpos+1, dataset, g1, g2) call wrgtp(g1, g2, sexgtp, '/', '', 1) end if end if if (plevel > 1 .and. incon) then sexgtp(7:7)='*' end if write(outstr,'(a12,1x,a15,2x,a1,4x,f8.6,4x,i6,a,i7,1x,i8,5x,a)') & dataset%pedigree(dataset%iped(i)), dataset%id(i), sx, sexrat(i), & xhets(i), '/', nxloci(i), nyloci(i), sexgtp end if if (incon) then inconsist=inconsist+1 if (seximpute > 1) then if (isex1 /= 3 .and. ((isex2 == 3 .and. isex3 /= 1) .or. & (isex2 /= 1 .and. isex3 == 3))) then ! write(*,*) dataset%id(i), dataset%sex(i), isex1, isex2, isex3, isex4 ! write(*,*) 'Changing ', dataset%id(i), dataset%sex(i), ' to 2' dataset%sex(i)=2 nchanges=nchanges+1 else if (isex1 /= 1 .and. ((isex2 == 1 .and. isex3 /= 3) .or. & (isex2 /= 3 .and. isex3 == 1))) then ! write(*,*) dataset%id(i), dataset%sex(i), isex1, isex2, isex3, isex4 ! write(*,*) 'Changing ', dataset%id(i), dataset%sex(i), ' to 1' dataset%sex(i)=1 nchanges=nchanges+1 end if end if end if end if end do write(outstr,'(/a/a/a,3(/a,i10,4x,i10,4x,i10)/)') & 'Designated Sex inferred via sex-linked markers', & 'Sex Likely Male Uncertain Likely Female', & '---------- ----------- --------- -------------', & ' Male ', classed(1,1), classed(1,2), classed(1,3), & ' Unknown ', classed(2,1), classed(2,2), classed(2,3), & ' Female ', classed(3,1), classed(3,2), classed(3,3) if (ygene > 0) then write(outstr,'(/a/a/a,3(/a,i10,4x,i10)/)') & 'Designated Sex inferred via presence of Y data', & 'Sex Likely Male Uncertain ', & '---------- ----------- --------- ', & ' Male ', classed(1,4), classed(1,5), & ' Unknown ', classed(2,4), classed(2,5), & ' Female ', classed(3,4), classed(3,5) end if if (sexpos /= MISS) then write(outstr,'(/3a/a/a,3(/a,i10,4x,i10,4x,i10)/)') & 'Designated Sex inferred via marker "', trim(sexmarker), '"', & 'Sex Likely Male Uncertain Likely Female', & '---------- ----------- --------- -------------', & ' Male ', classed(1,7), classed(1,8), classed(1,9), & ' Unknown ', classed(2,7), classed(2,8), classed(2,9), & ' Female ', classed(3,7), classed(3,8), classed(3,9) end if emperr=dble(totmalhet)/dble(max(1,totmalgeno)) write(outstr,'(a,f6.4/)') & 'Putative male per-locus X-heterozygote rate = ', emperr if (seximpute > 1) then write(outstr,'(a,i0,a/)') & 'Changed ', nchanges, ' sex codes.' end if deallocate(xhets) deallocate(nxloci) deallocate(nyloci) deallocate(sexrat) end subroutine testsex ! ! Test consistency of sexes ! Assign consistent sexes where missing, allowing for possible MZ twins ! subroutine imputesex(seximpute, dataset, plevel) use interrupt use outstream use ped_class use rngs ! imputation level for sex integer, intent(in) :: seximpute type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel integer, parameter :: MISS=-9999 integer :: errgrp, i, it, idx, j, k, num, p1, p2, ped, pedoffset, thispos integer, dimension(dataset%maxsiz) :: grp, impsex logical :: fin, showimp character (len=1) :: sx character (len=3) :: cimp showimp=.false. do ped=1, dataset%nped if (dataset%actset(ped) > 0) then if (irupt /= 0) exit pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset ! ! loop until resolve all missing sexes errgrp=0 it=0 idx=0 grp=0 impsex(1:num)=dataset%sex(pedoffset+1:dataset%num(ped)) do newidx=0 do i=idx+1, num if (dataset%sex(pedoffset+i) == MISS) then newidx=i exit end if end do if (newidx == 0) exit idx=newidx grp(idx)=idx newsex=MISS pos1=0 pos2=0 do fin=.true. it=it+1 ! write(*,*) 'Idx=', idx, it j=pedoffset do i=1, num j=j+1 if (dataset%fa(j) /= MISS .and. dataset%mo(j) /= MISS) then p1=dataset%fa(i)-pedoffset p2=dataset%mo(i)-pedoffset if (idx == p1) pos1=pos1+1 if (idx == p2) pos2=pos2+1 if (abs(grp(p1)) == idx .and. abs(grp(p2)) /= idx) then ! write(*,*) p1, '(', grp(p1),')', p2, '(', grp(p2),')' grp(p2) = -sign(idx, grp(p1)) if (dataset%sex(pedoffset+p2) /= MISS) then if (newsex == MISS) then if (grp(p2) > 0) then newsex=dataset%sex(pedoffset+p2) else newsex=3-dataset%sex(pedoffset+p2) end if else if ((grp(p2) > 0 .and. & newsex /= dataset%sex(pedoffset+p2)) .or. & (grp(p2) < 0 .and. & newsex == dataset%sex(pedoffset+p2))) then write(outstr,'(5a)') 'ERROR: Sex inconsistency due to ', & trim(dataset%pedigree(ped)), '-', & trim(dataset%id(pedoffset+p2)), ' !' end if end if fin=.false. else if (abs(grp(p1)) /= idx .and. abs(grp(p2)) == idx) then ! write(*,*) p1, '(', grp(p1),')', p2, '(', grp(p2),')' grp(p1) = -sign(idx,grp(p2)) if (dataset%sex(pedoffset+p1) /= MISS) then if (newsex == MISS) then if (grp(p1) > 0) then newsex=dataset%sex(pedoffset+p1) else newsex=3-dataset%sex(pedoffset+p1) end if else if ((grp(p1) > 0 .and. & newsex /= dataset%sex(pedoffset+p1)) .or. & (grp(p1) < 0 .and. & newsex == dataset%sex(pedoffset+p1))) then write(outstr,'(a)') 'ERROR: Inconsistent sexes!' write(outstr,'(5a)') 'ERROR: Sex inconsistency due to ', & trim(dataset%pedigree(ped)), '-', & trim(dataset%id(pedoffset+p1)), ' !' end if end if fin=.false. end if end if end do if (fin) exit end do if (mzmiss /= 0) then j=pedoffset do i=1, num j=j+1 if (dataset%imztwin(j) /= 0) then if (grp(i) == 0) then thispos=dataset%imztwin(j)-pedoffset do while (thispos /= i) if (grp(thispos) /= 0) then grp(i)=grp(thispos) mzmiss=mzmiss-1 exit end if thispos=dataset%imztwin(pedoffset+thispos)-pedoffset end do end if end if end do end if sxcode=3 if (newsex == MISS) then sxcode=4 newsex=1 if (pos1 == 0 .and. pos2 > 0) then newsex=2 else if (pos2 > pos1) then newsex=2 else if (pos1 == pos2) then newsex=irandom(1,2) end if end if j=pedoffset do i=1, num j=j+1 if (grp(i) == idx) then impsex(i)=sxcode dataset%sex(j)=newsex ! write(*,*) idx, i, dataset%sex(i) else if (grp(i) == -idx) then impsex(i)=sxcode dataset%sex(j)=3-newsex ! write(*,*) idx, i, dataset%sex(i) end if end do end do ! order father then mother j=pedoffset do i=1, num j=j+1 if (dataset%fa(j) /= MISS .and. dataset%mo(j) /= MISS) then p1=dataset%fa(j) p2=dataset%mo(j) if (dataset%sex(p1) == 2 .and. dataset%sex(p2) == 1) then k=dataset%fa(j) dataset%fa(j)=dataset%mo(j) dataset%mo(j)=k else if (dataset%sex(p1) == dataset%sex(p2)) then if (impsex(p1-pedoffset) > 2 .and. impsex(p2-pedoffset) > 2) then write(outstr,'(/5a/7x,4a/7x,5a)') & 'ERROR: Parents of ', & trim(dataset%pedigree(ped)), '-', trim(dataset%id(j)), & ' are obliged to be the same sex:', & trim(dataset%id(p1)), ' x ', trim(dataset%id(p2)),'.', & 'Sexes inferred from relationships to ', & trim(dataset%pedigree(ped)), '-', & trim(dataset%id(pedoffset+abs(grp(p1-pedoffset)))),'.' dataset%sex(p1) = MISS dataset%sex(p2) = MISS errgrp=abs(grp(p1-pedoffset)) else write(outstr,'(/5a/7x,4a)') & 'ERROR: Parents of ', & trim(dataset%pedigree(ped)), '-', trim(dataset%id(j)), & ' appear to be the same sex:', & trim(dataset%id(p1)), ' x ', trim(dataset%id(p2)), '.' end if end if end if end do if (plevel > 0) then showimp=.false. do i=1, num if (impsex(i) > 2) then showimp=.true. exit end if end do if (showimp) then write(outstr,'(/a/a)') & 'Pedigree ID New sex', & '--------------- ------------ -------' j=pedoffset do i=1, num j=j+1 if (impsex(i) > 2) then call wrsex(dataset%sex(j), sx) cimp=' ' if (impsex(i) > 3) cimp='[i]' write(outstr,'(a15,1x,a12,2x,a,1x,a)') & trim(dataset%pedigree(ped)), & dataset%id(j), sx, cimp end if end do write(outstr,*) end if end if end if end do end subroutine imputesex ! ! Test monozygotic twins ! subroutine mzgtp(mztwin, gt, thresh, nloci, loc, loctyp, locpos, & dataset, inconsist, plevel) use interrupt use outstream use ped_class use locus_types use sorts implicit none integer, intent(in) :: mztwin integer, intent(in) :: gt double precision, intent(in) :: thresh integer, intent(in) :: nloci character(len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data), intent(inout) :: dataset integer, intent(inout) :: inconsist integer, intent(in) :: plevel ! local integer, parameter :: KNOWN=0, MISS=-9999 logical :: ssx, samefa, samemo integer :: con, den, g1, g2, g3, g4, gene, i, j, k, npairs, & ped, sexdis, twin1, uninf integer :: err(nloci), idx(nloci), tot(nloci) character (len=1) :: sx(2) = (/'m','f'/) character (len=7) :: gtp1, gtp2 character (len=40) :: disloci ! functions double precision :: isaff npairs=0 uninf=0 do i=1, nloci idx(i)=i err(i)=0 tot(i)=0 end do sexdis=0 if (plevel > -2) then write(outstr,'(3(/a))') & '------------------------------------------------------------', & 'Checking for MZ discordance at marker loci', & '------------------------------------------------------------' end if call countmz(mztwin, gt, thresh, dataset, plevel) if (plevel > 0) then write(outstr,'(a)') 'Pedigree Person1 Person2 Locus Geno1 Geno2' else write(outstr,'(a)') 'Pedigree Person1 Person2 Con Dis %Dis' end if do ped=1, dataset%nped if (dataset%actset(ped) > 0) then if (irupt /= 0) exit ! only iterate nonfounders do i=dataset%num(ped-1)+dataset%nfound(ped)+1, dataset%num(ped)-1 if (int(isaff(dataset%plocus(i,mztwin),thresh,gt)) == 2) then do j=i+1, dataset%num(ped) samefa=(dataset%fa(i) == dataset%fa(j)) samemo=(dataset%mo(i) == dataset%mo(j)) if (.not.samefa .or. .not.samemo) exit ! ! Share parents and zygosity indicator ! if (int(isaff(dataset%plocus(j,mztwin),thresh,gt)) == 2 .and. & dataset%plocus(i,mztwin)==dataset%plocus(j,mztwin)) then twin1=i do while (dataset%imztwin(twin1) /= MISS) twin1=dataset%imztwin(twin1) end do dataset%imztwin(j)=twin1 ssx=.true. con=0 den=0 disloci=' ' if ((dataset%sex(i) == 1 .and. dataset%sex(j) == 2) .or. & (dataset%sex(i) == 2 .and. dataset%sex(j) == 1)) then ssx=.false. disloci=' Sex' sexdis=sexdis+1 inconsist=inconsist+1 den=den+1 if (plevel > 0) then write(outstr,'(a11,2(1x,a),1x,a10,2(1x,a7))') & dataset%pedigree(ped)(1:11), dataset%id(i), dataset%id(j), & '**SEX**', sx(dataset%sex(i)), sx(dataset%sex(j)) end if end if do k=1, nloci if (isactdip(loctyp(k))) then gene=locpos(k) call get_geno(i, gene, gene+1, dataset, g1, g2) call get_geno(j, gene, gene+1, dataset, g3, g4) if (g1 > KNOWN .and. g3 > KNOWN) then den=den+1 tot(k)=tot(k)+1 if ((g1 == g3 .and. g2 == g4) .or. (g1 == g4 .and. g2 == g3)) then con=con+1 else err(k)=err(k)+1 inconsist=inconsist+1 if (plevel > 0) then call wrgtp(g1, g2, gtp1, '/', '', 1) call wrgtp(g3, g4, gtp2, '/', '', 1) write(outstr,'(3(1x,a),1x,a10,2(1x,a7))') & dataset%pedigree(ped), dataset%id(i), dataset%id(j), & loc(k), gtp1, gtp2 else call append(loc(k), disloci) end if end if end if end if end do if (den > 0) then npairs=npairs+1 if (plevel<1 .and. (den-con > 0 .or. .not.ssx)) then write(outstr,'(a11,2(1x,a), 2(1x,i7), 2x, f5.1, 1x, a)') & dataset%pedigree(ped)(1:11), dataset%id(i), dataset%id(j), & con, den-con, 1.0d2*dble(den-con)/dble(den), & trim(disloci) end if else uninf=uninf+1 end if end if end do end if end do end if end do if (npairs > 0) then write(outstr,'(/a/a)') 'Locus Dis Pairs Prop', & '-------------- ----- ----- ------' call isort(1, nloci, err, idx, 2) do k=nloci, 1, -1 if (isactdip(loctyp(idx(k)))) then if (tot(idx(k)) > 0) then if (plevel > 0 .or. err(k)>0) then write(outstr,'(a15, 1x, i5, 1x, i5, 2x, f6.4)') & loc(idx(k)), err(k), tot(idx(k)), dble(err(k))/dble(tot(idx(k))) end if end if end if end do if (sexdis > 0) then write(outstr,'(a15, 1x, i5, 1x, i5, 2x, f6.4)') & 'SEX', sexdis, npairs, dble(sexdis)/dble(npairs) end if write(outstr,'(/a,i5,a)') 'Checked ', npairs, ' twin pairs.' else write(outstr,'(/a)') 'No useful monozygotic twin pairs.' end if if (uninf > 0) then write(outstr,'(a,i5,a)') 'Skipped ', uninf, ' ungenotyped (same-sex) pairs.' end if write(outstr,*) end subroutine mzgtp ! ! Delete MZ twin with least phenotype information out of pair ! or clean MZ genotypes ! subroutine dropt2(mztwin, gt, thresh, typ, & nloci, loc, loctyp, locpos, dataset, plevel) use outstream use ped_class use locus_types implicit none integer, intent(in) :: mztwin integer, intent(in) :: gt double precision, intent(in) :: thresh integer, intent(in) :: typ integer, intent(in) :: nloci character(len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel ! local integer, parameter :: KNOWN=0, MISS=-9999 ! local variables integer :: i, g1, g2, g3, g4, gene, hitwin, k, lotwin, multip, & nchanges, ndeleted, npairs, nphen1, nphen2, nrelchange, & ped, twin1, twin2, twinship character (len=7) :: gtp1, gtp2 ! functions double precision :: isaff write(outstr,'(/a)') & 'Pedigree Twin1 Twin2 Locus Geno1 Geno2' multip=0 nchanges=0 ndeleted=0 npairs=0 nphen1=0 nrelchange=0 twinship=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then ! only iterate nonfounders twin1=MISS do i=dataset%num(ped-1)+dataset%nfound(ped)+1, dataset%num(ped) if (int(isaff(dataset%plocus(i,mztwin), thresh, gt)) == 2) then if (twin1 == MISS) then twinship=1 twin1=i nphen1=0 do k=1, nloci if (istrait(loctyp(k)) .and. locpos(k) /= MISS) then nphen1=nphen1+1 end if end do ! ! putative cotwin has to have same parents *and exactly* same zygosity code ! else if (dataset%fa(i) == dataset%fa(twin1) .and. & dataset%mo(i) == dataset%mo(twin1) .and. & dataset%plocus(i, mztwin) == dataset%plocus(twin1, mztwin)) then dataset%imztwin(i)=twin1 twinship = twinship + 1 npairs=npairs+1 if (twinship == 3) then multip=multip+1 end if twin2=i nphen2=0 ! reconcile sexes then genotypes if (dataset%sex(twin1)/=MISS .and. dataset%sex(twin2)==MISS) then dataset%sex(twin2)=dataset%sex(twin1) else if (dataset%sex(twin1)==MISS .and. dataset%sex(twin2)/=MISS) then dataset%sex(twin1)=dataset%sex(twin2) end if do k=1, nloci if (isactive(loctyp(k))) then if (ismarker(loctyp(k))) then gene=locpos(k) call get_geno(twin1, gene, gene+1, dataset, g1, g2) call get_geno(i, gene, gene+1, dataset, g3, g4) if (g1 > KNOWN .and. g3 > KNOWN) then if (g1 /= g3 .or. g2 /= g4) then call wrgtp(g1, g2, gtp1, '/', '', 1) call wrgtp(g3, g4, gtp2, '/', '', 1) write(outstr,'(a12,2(1x,a),1x,a10,2(1x,a))') & dataset%pedigree(ped)(1:12), dataset%id(twin1), dataset%id(i), & loc(k), gtp1, gtp2 call set_geno(twin1, gene, gene+1, dataset, -g1, -g2) call set_geno(i, gene, gene+1, dataset, -g3, -g4) ndeleted=ndeleted+2 end if else if (g1 <= KNOWN .and. g3 > KNOWN) then call set_geno(twin1, gene, gene+1, dataset, g3, g4) nchanges=nchanges+1 else if (g1 > KNOWN .and. g3 <= KNOWN) then call set_geno(i, gene, gene+1, dataset, g1, g2) nchanges=nchanges+1 end if else if (istrait(loctyp(k))) then if (dataset%plocus(i,locpos(k)) /= MISS) then nphen2=nphen2+1 end if end if end if end do ! ! Pick twin with most phenotype to save, drop other twins data, except for ! mztwin indicator, and average over quantitative trait values ! If unlinking descendants of twin (typ=3) , always drop twin later in pedigree ! if (typ == 2 .or. typ == 3) then lotwin=i hitwin=twin1 if (typ == 2 .and. nphen2 > nphen1) then lotwin=twin1 hitwin=i twin1=i nphen1=nphen2 end if if (plevel > 1) then write(outstr,*) 'Dropping MZ twin ', & trim(dataset%pedigree(ped)), '--', trim(dataset%id(lotwin)) end if do k=1, nloci if (isactive(loctyp(k))) then if (ismarker(loctyp(k))) then gene=locpos(k) if (observed(lotwin, gene, dataset)) then call get_geno(lotwin, gene, gene+1, dataset, g1, g2) call set_geno(lotwin, gene, gene+1, dataset, -g1, -g2) end if else if (loctyp(k) == LOC_QUA) then gene=locpos(k) if (dataset%plocus(hitwin, gene) /= MISS .and. & dataset%plocus(lotwin, gene) /= MISS) then dataset%plocus(hitwin, gene)= 0.5*(dataset%plocus(hitwin,gene)+ & dataset%plocus(lotwin, gene)) else if (dataset%plocus(hitwin, gene) == MISS) then dataset%plocus(hitwin, gene)= dataset%plocus(lotwin, gene) end if if (gene /= mztwin) then dataset%plocus(lotwin, gene)=MISS end if else if (loctyp(k) == LOC_AFF .or. loctyp(k) == LOC_CAT) then gene=locpos(k) if (gene /= mztwin) then dataset%plocus(lotwin, gene)=MISS end if end if end if end do end if else twinship=1 twin1=i nphen1=0 do k=1, nloci if (isactdip(loctyp(k)) .and. locpos(k) /= MISS) then nphen1=nphen1+1 end if end do end if else twin1=MISS end if end do if (typ == 3) then do i=dataset%num(ped-1)+dataset%nfound(ped)+1, dataset%num(ped) if (dataset%imztwin(dataset%fa(i)) /= MISS) then nrelchange=nrelchange+1 dataset%fa(i)=dataset%imztwin(dataset%fa(i)) end if if (dataset%imztwin(dataset%mo(i)) /= MISS) then nrelchange=nrelchange+1 dataset%mo(i)=dataset%imztwin(dataset%mo(i)) end if end do end if end if end do if (typ == 2 .or. typ == 3) then write(outstr,'(/a,i5,a)') 'Dropped one member of ', npairs, ' sets of MZ twins.' if (multip > 0) then write(outstr,'(a,i3,a)') 'Dropped two or more members of ', multip, & ' sets of MZ higher order multiples.' end if if (nrelchange > 0) then write(outstr,'(/a,i5,a)') & 'Altered parentage of ', nrelchange, ' MZ twin offspring.' end if write(outstr,*) else if (typ == 4) then write(outstr,'(2(/a,i0,a)/)') & 'Reconciled ', nchanges, ' MZ twin pair genotypes.', & 'Deleted ', ndeleted, ' inconsistent MZ twin pair genotypes.' end if end subroutine dropt2 ! ! Count up MZ twins, triplets, quads, higher ! subroutine countmz(mztwin, gt, thresh, dataset, plevel) use outstream use ped_class implicit none integer, intent(in) :: mztwin integer, intent(in) :: gt double precision, intent(in) :: thresh type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel ! local integer, parameter :: KNOWN=0, MISS=-9999 ! local variables integer :: currf, currm, i, j, maxmz, nmz, num, ped, twinship integer, dimension(6) :: shipsize character (len=1) :: sx character (len=50), dimension(6) :: multiples double precision :: currz ! functions double precision :: isaff if (plevel > 1) then write(outstr,'(a12,3(1x,a12),1x,a1,1x,a6)') & 'Pedigree', 'ID', 'Father', 'Mother', ' ', 'Zyg' end if nmz=0 maxmz=0 do i=1, 6 shipsize(i)=0 multiples(i)=' ' end do dataset%untyped=.false. do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped-1)+dataset%nfound(ped) if (int(isaff(dataset%plocus(i,mztwin),thresh,gt)) == 2) then shipsize(6)=shipsize(6)+1 call append(dataset%pedigree(ped), multiples(6)) end if end do do i=dataset%num(ped-1)+dataset%nfound(ped)+1, dataset%num(ped) if (.not.dataset%untyped(i) .and. & int(isaff(dataset%plocus(i,mztwin),thresh,gt)) == 2) then if (plevel > 1) then call wrsex(dataset%sex(i), sx) write(outstr,'(/a12, 3(1x, a12), 1x, a1, 1x, f6.0)') & dataset%pedigree(ped), dataset%id(i), & dataset%id(dataset%fa(i)), dataset%id(dataset%mo(i)), & sx, dataset%plocus(i, mztwin) end if nmz=nmz+1 dataset%untyped(i)=.true. currf=dataset%fa(i) currm=dataset%mo(i) currz=dataset%plocus(i,mztwin) twinship=1 j=i+1 do if (j > dataset%num(ped)) exit if (dataset%fa(j) /= currf .or. dataset%mo(i) /= currm) exit if (dataset%plocus(j,mztwin) == currz) then twinship=twinship+1 dataset%untyped(j)=.true. if (plevel > 1) then call wrsex(dataset%sex(j), sx) write(outstr,'(a12, 3(1x, a12), 1x, a1, 1x, f6.0)') & dataset%pedigree(ped), dataset%id(j), & dataset%id(dataset%fa(j)), dataset%id(dataset%mo(j)), & sx, dataset%plocus(j, mztwin) end if end if j=j+1 end do if (twinship > maxmz) maxmz=twinship shipsize(min(5,twinship))=shipsize(min(5,twinship))+1 call append(dataset%pedigree(ped), multiples(min(5,twinship))) end if end do end if end do if (nmz > 0) then write(outstr,'(/a/a)') 'MZ sibships Number Pedigrees', & '-------------------- ------ -----------' if (shipsize(1)>0) then write(outstr,'(a,i7,3x,a)') & 'MZ singletons * ', shipsize(1), multiples(1) end if if (shipsize(2)>0) then write(outstr,'(a,i7,3x,a)') & 'MZ pairs ', shipsize(2), multiples(2) end if if (shipsize(3)>0) then write(outstr,'(a,i7,3x,a)') & 'MZ triplets ** ', shipsize(3), multiples(3) end if if (shipsize(4)>0) then write(outstr,'(a,i7,3x,a)') & 'MZ quadruplets ***', shipsize(4), multiples(4) end if if (shipsize(5)>0) then write(outstr,'(a,i7,3x,a)') & 'Higher Multiples ***', shipsize(5), multiples(5) write(outstr,'(a,i0,a)') '(Up to ', maxmz, ' members)' end if write(outstr,*) end if if (shipsize(6) > 0) then write(outstr,'(a,i0,a/7x,2a)') & 'ERROR: There were ', shipsize(6), & ' founder individuals marked as twins!', & 'Affected pedigrees include: ', trim(multiples(6)) end if end subroutine countmz ! ! Find MZ twins/duplicates based on genotype concordance ! Abort pairwise comparison after <nfailure> mismatches ! subroutine mzfind(typ, mztrait, mistyping, minmarkers, nloci, loc, loctyp, locpos, & locstat, dataset, plevel) use interrupt use outstream use ped_class use locus_types use locus_list implicit none integer, intent(in) :: typ integer, intent(in) :: mztrait integer, intent(in) :: nloci double precision, intent(in) :: mistyping integer, intent(in) :: minmarkers character(len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos double precision, dimension(:), intent(out) :: locstat type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel ! local integer, parameter :: KNOWN=0, MISS=-9999 integer :: nmark integer, dimension(:), allocatable :: mark, markid logical :: istwin integer :: g1, g2, g3, g4, gene, i, j, k, nonmatch, nfailure, npairs, & ped, pedoffset, mztwin, totpairs, typed, unhelpful, useful ! functions character (len=8) :: wrpercent mztwin=0 if (mztrait /= MISS) mztwin=locpos(mztrait) npairs=0 call cntmark(nloci, loctyp, nmark, 1) if (nmark < minmarkers) then write(outstr,'(a,i0,a)') & 'Insufficient markers (', nmark, ') for diagnosis of MZ twins/duplicates!' return end if nfailure=max(min(nmark,10), int(mistyping*dble(nmark))) allocate(mark(nmark), markid(nmark)) nmark=0 do k=1, nloci if (isactdip(loctyp(k))) then nmark=nmark+1 markid(nmark)=k locstat(k)=0.0d0 mark(nmark)=locpos(k) end if end do unhelpful=0 useful=0 dataset%untyped=.true. do ped=1, dataset%nped if (dataset%actset(ped) > 0) then ind: do i=dataset%num(ped-1)+1, dataset%num(ped) typed=0 do k=1, nmark if (observed(i, mark(k), dataset)) then typed=typed+1 if (typed >= minmarkers) then useful=useful+1 dataset%untyped(i)=.false. exit end if end if end do if (typed > 0 .and. typed < minmarkers) then unhelpful=unhelpful+1 end if end do ind end if end do if (plevel > -2) then write(outstr,'(3(/a),2(/a,i0)/a,i0,a,i0,a/a,i0,a,f5.3,a)') & '------------------------------------------------', & 'Searching for likely MZ twin pairs or duplicates', & '------------------------------------------------', & 'Maximum number of marker loci = ', nmark, & 'Number of individuals tested = ', useful, & 'Number of individuals skipped = ', unhelpful, & ' (<', minmarkers,' markers)', & 'Threshold for nonidentity = ', nfailure, & ' markers (', dble(nfailure)/dble(nmark), ')' if (mztwin /= 0) then if (typ == 1) then write(outstr,'(3a)') & 'Writing MZ twin indicator to "', trim(loc(mztrait)), '".' else write(outstr,'(3a)') & 'Writing duplicate indicator to "', trim(loc(mztrait)), '".' end if end if if (plevel > 0 .or. (typ == 2 .and. plevel > -1)) then if (typ == 1) then write(outstr,'(/a,7x,a,22x,a,22x,a)') & 'Pedigree', 'ID1', 'ID2', 'Concordance' else write(outstr,'(/2(a,11x,a,22x),1x,a)') & 'Ped1', 'ID1', 'Ped2', 'ID2', 'Concordance' end if end if end if totpairs=0 if (typ == 1) then do ped=1, dataset%nped if (dataset%actset(ped) > 0) then if (irupt /= 0) exit pedoffset=dataset%num(ped-1) if (mztwin /= 0) then do i=pedoffset+1, dataset%num(ped) dataset%plocus(i,mztwin)=MISS end do end if do i=pedoffset+1, dataset%num(ped)-1 if (.not.dataset%untyped(i)) then rel: do j=i+1, dataset%num(ped) if (.not.dataset%untyped(j)) then totpairs=totpairs+1 call mztest(i, j, nmark, mark, dataset, nfailure, nonmatch, & typed, istwin) if (istwin .or. plevel > 1) then if (dble(nonmatch)/dble(typed) <= mistyping .and. & typed > minmarkers) then npairs=npairs+1 if (mztwin /= 0) then dataset%plocus(i,mztwin)=1 dataset%plocus(j,mztwin)=1 end if if (plevel > -1) then write(outstr,'(a14,2(1x,a24),1x,i0,a1,i0,a,f6.4,a)') & dataset%pedigree(ped), dataset%id(i), dataset%id(j), & typed-nonmatch, '/', typed, & ' (', dble(typed-nonmatch)/dble(typed), ')' end if call mzdiscord(i, j, nmark, markid, mark, dataset) end if end if end if end do rel end if end do end if end do if (plevel > -1) write(outstr,*) write(outstr,'(a,i0,a,i0,a)') & 'Total putative MZ pairs = ', npairs, & ' of ', totpairs, ' relative pairs tested.' else if (mztwin /= 0) then do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) dataset%plocus(i,mztwin)=MISS end do end if end do end if do i=1, dataset%nobs if (.not.dataset%untyped(i)) then if (irupt /= 0) exit !$OMP PARALLEL PRIVATE(istwin, j, nonmatch, typed) !$OMP DO do j=i+1, dataset%nobs if (.not.dataset%untyped(j)) then totpairs=totpairs+1 call mztest(i, j, nmark, mark, dataset, nfailure, nonmatch, & typed, istwin) if (istwin) then if (dble(nonmatch)/dble(typed) <= mistyping .and. & typed > minmarkers) then npairs=npairs+1 if (mztwin /= 0) then if (dataset%plocus(i,mztwin) > 0) then dataset%plocus(j,mztwin)=dataset%plocus(i,mztwin) else dataset%plocus(i,mztwin)=0 dataset%plocus(j,mztwin)=i end if end if if (plevel > -1) then write(outstr,'(2(a14,1x,a26),1x,i0,a1,i0,a,f6.4,a)') & dataset%pedigree(dataset%iped(i)), dataset%id(i), & dataset%pedigree(dataset%iped(j)), dataset%id(j), & typed-nonmatch, '/', typed, & ' (', dble(typed-nonmatch)/dble(typed), ')' end if call mzdiscord(i, j, nmark, markid, mark, dataset) end if else if (plevel > 1) then write(outstr,'(2(a14,1x,a14),1x,i0,a1,i0,a,f6.4,a)') & dataset%pedigree(dataset%iped(i)), dataset%id(i), & dataset%pedigree(dataset%iped(j)), dataset%id(j), & typed-nonmatch, '/', typed, & ' (', dble(typed-nonmatch)/dble(typed), ')' end if end if end do !$OMP END DO !$OMP END PARALLEL end if end do if (plevel > -1) write(outstr,*) write(outstr,'(a,i0,a,i0,1x,2a)') & 'Total putative duplicates = ', npairs, & ' of ', totpairs, & wrpercent(totpairs, useful*(useful+1)/2),' pairwise comparisons.' end if end subroutine mzfind ! ! Test if pair are genetically identical, aborting if ! nfailure nonmatches ! subroutine mztest(id1, id2, nmark, mark, dataset, nfailure, nonmatch, & typed, istwin) use interrupt use outstream use ped_class use locus_types implicit none integer, intent(in) :: id1, id2 integer, intent(in) :: nmark integer, dimension(nmark), intent(in) :: mark type (ped_data), intent(inout) :: dataset integer, intent(in) :: nfailure integer, intent(out) :: nonmatch logical, intent(out) :: istwin integer, intent(out) :: typed ! local integer, parameter :: KNOWN=0, MISS=-9999 integer :: g1, g2, g3, g4, gene, k istwin=.true. nonmatch=0 typed=0 do k=1, nmark gene=mark(k) call get_geno(id1, gene, gene+1, dataset, g1, g2) call get_geno(id2, gene, gene+1, dataset, g3, g4) if (g1 > KNOWN .and. g3 > KNOWN) then typed=typed+1 if (g1 /= g3 .or. g2 /= g4) then nonmatch=nonmatch+1 if (nonmatch >= nfailure) then istwin=.false. return end if end if end if end do end subroutine mztest ! ! If pair are assumed genetically identical, score SNPs for ! discordance saving to locstat ! subroutine mzdiscord(id1, id2, nmark, markid, mark, dataset) use interrupt use outstream use ped_class use locus_types use locus_data implicit none integer, intent(in) :: id1, id2 integer, intent(in) :: nmark integer, dimension(nmark), intent(in) :: markid integer, dimension(nmark), intent(in) :: mark type (ped_data), intent(inout) :: dataset ! local integer, parameter :: KNOWN=0, MISS=-9999 integer :: g1, g2, g3, g4, gene, k do k=1, nmark gene=mark(k) call get_geno(id1, gene, gene+1, dataset, g1, g2) call get_geno(id2, gene, gene+1, dataset, g3, g4) if (g1 > KNOWN .and. g3 > KNOWN) then if (g1 /= g3 .or. g2 /= g4) then locstat(markid(k))=locstat(markid(k))+1 end if end if end do end subroutine mzdiscord ! ! Genotype diff for two individuals ! subroutine prdiscord(id1, id2, nloci, loc, loctyp, locpos, locnotes, & dataset, plevel) use interrupt use outstream use alleles_class use ped_class use locus_types use comp_ops use sorts implicit none integer, intent(in) :: id1, id2 integer, intent(in) :: nloci character(len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=*), dimension(:), intent(in out) :: locnotes type (ped_data), intent(in) :: dataset integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS=-9999 integer :: g1, g2, g3, g4, gene, incon, j, k, typed character (len=7) :: gtp1, gtp2 write(outstr,'(/9a)') 'Comparing ', & trim(dataset%pedigree(dataset%iped(id1))), '--', trim(dataset%id(id1)), ' to ', & trim(dataset%pedigree(dataset%iped(id2))), '--', trim(dataset%id(id2)), '.' incon=0 typed=0 write(outstr, '(a)') 'Locus Person1 Person2 Annotations' do j=1, nloci if (same_loctyp(loctyp(j), LOC_CODOM)) then gene=locpos(j) call get_geno(id1, gene, gene+1, dataset, g1, g2) call get_geno(id2, gene, gene+1, dataset, g3, g4) if (g1 > KNOWN .and. g3 > KNOWN) then typed=typed+1 if (g1 /= g3 .or. g2 /= g4) then incon=incon+1 if (plevel > 0 .or. incon < 40) then call wrgtp(g1, g2, gtp1, '/', '', 1) call wrgtp(g3, g4, gtp2, '/', '', 1) write(outstr,'(a,3(1x,a))') loc(j), gtp1, gtp2, locnotes(j) end if end if end if if (irupt /= 0) exit end if end do if (plevel < 1 .and. incon >= 40) then write(outstr, '(a)') '...' end if write(outstr, '(/a,i0,a,i0,a,g9.4,a)') & 'Total discordant genotypes = ', incon, ' of ', typed, & ' (', dble(incon)/dble(typed), ')' end subroutine prdiscord ! ! Test only identical individual IDs as genetic duplicates ! subroutine duptest(typ, nloci, loc, loctyp, locpos, dataset, & thresh, mintyp, plevel) use outstream use locus_types use ped_class use locus_list integer, intent(in) :: typ, nloci character(len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data) :: dataset double precision, intent(in) :: thresh ! threshold integer, intent(in) :: mintyp integer, intent(in) :: plevel integer, dimension(dataset%nobs) :: key, icount, nextcopy integer :: nmark integer, dimension(:), allocatable :: mark integer :: dups, hi, i, idlen, idpos, idx, idx2, j, k, lo, lpos, & nids, ped, pos, totnum integer :: gene, g1, g2, nchanges=0 integer :: nfailure, nonmatch, typed logical :: istwin call make_idlist(dataset, nids, key, icount, nextcopy) dups=0 nchanges=0 totnum=0 idlen=2 do k=1, nids if (icount(k) > 1) then dups=dups+1 totnum=totnum+icount(k) end if idlen=max(idlen, len_trim(dataset%id(key(k)))) end do if (dups == 0) then write(outstr,'(a)') 'No duplicated IDs.' return end if call cntmark(nloci, loctyp, nmark, 3) if (nmark == 0) then write(outstr,'(a)') & 'No usable markers for diagnosis of duplicates.' return end if nfailure=max(min(nmark,10), int(thresh*dble(nmark))) allocate(mark(nmark)) nmark=0 do j=1, nloci if (ismarker(loctyp(j)) .and. isactive(loctyp(j))) then nmark=nmark+1 mark(nmark)=locpos(j) end if end do write(outstr,'(3(/a)/a,i0/a,i0,a,i0,a/a,i0,a,f5.3,a)') & '---------------------------------------------', & 'Testing genetic similarity for duplicated IDs', & '---------------------------------------------', & 'Maximum number of marker loci = ', nmark, & 'Number of individuals tested = ', totnum, ' (', dups, ' IDs)', & 'Threshold for nonidentity = ', nfailure, & ' markers (', dble(nfailure)/dble(nmark), ')' if (typ == 2) then write(outstr, '(/a)') & 'Filling in missing genotype data with values from duplicates.' end if write(outstr,'(/a,11x,a,11x,a,11x,a/4(a,1x))') & 'Ped1', 'Ped2', 'ID', 'Concordance', & repeat('-',14), repeat('-',14), repeat('-',12), repeat('-',13) do k=1, nids if (icount(k) > 1) then lpos=idlen+9 nlin=1 idx=key(k) do idx2=nextcopy(idx) do call mztest(idx, idx2, nmark, mark, dataset, nfailure, nonmatch, & typed, istwin) write(outstr,'(a14,1x,a14,1x,a12,1x,i0,a1,i0,a,f6.4,a)') & dataset%pedigree(dataset%iped(idx)), & dataset%pedigree(dataset%iped(idx2)), & dataset%id(idx), typed-nonmatch, '/', typed, & ' (', dble(typed-nonmatch)/dble(typed), ')' if (typ == 2 .and. istwin .and. typed >= mintyp) then do j=1, nmark gene=mark(j) if (observed(idx2, gene, dataset) .and. & .not.observed(idx, gene, dataset)) then call get_geno(idx2, gene, gene+1, dataset, g1, g2) call set_geno(idx, gene, gene+1, dataset, g1, g2) nchanges=nchanges+1 else if (observed(idx, gene, dataset) .and. & .not.observed(idx2, gene, dataset)) then call get_geno(idx, gene, gene+1, dataset, g1, g2) call set_geno(idx2, gene, gene+1, dataset, g1, g2) nchanges=nchanges+1 end if end do end if if (idx2==nextcopy(idx2)) exit idx2=nextcopy(idx2) end do if (idx == nextcopy(idx) .or. idx2 == nextcopy(idx)) exit idx=nextcopy(idx) end do end if end do if (typ == 2) then write(outstr, '(/a,i0,a)') & 'Filled in ', nchanges, ' genotypes.' end if end subroutine duptest ! ! Test for sibs with same DOB ! subroutine testsibage(typ, locnam, trait, dupnam, dupidx, thresh, dataset) use outstream use ped_class use julian_epoch use timelib implicit none integer, intent(in) :: typ character (len=*), intent(in) :: locnam, dupnam integer, intent(in) :: trait, dupidx double precision, intent(in) :: thresh type (ped_data) :: dataset integer, parameter :: MISS=-9999 integer :: currf, currm, fin, i, j, k, pedoffset, ped, sibnum double precision :: diff, prevy, y1, y2 character (len=10) :: sdate1, sdate2 write(outstr, '(/3a)') & 'Checking for siblings with same DOB using variable "', trim(locnam), '".' if (dupidx /= MISS) then write(outstr, '(3a)') & 'Writing duplication indicator variable "', trim(dupnam), '".' end if write(outstr, '(/a/a)') & 'Pedigree Sib 1 Sib 1 DOB Sib 2 Sib 2 DOB ', & '------------ ------------ --------------- ------------ ----------------' do ped=1, dataset%nped if (dataset%actset(ped) > 0) then fin=dataset%num(ped) currf=dataset%fa(fin) currm=dataset%mo(fin) do k=dataset%num(ped)-1, pedoffset+dataset%nfound(ped), -1 ! next sibship if (dataset%fa(k) /= currf .or. dataset%mo(k) /= currm) then prevy=MISS sibnum=0 do i=k+1, fin y1=dataset%plocus(i,trait) if (y1 /= MISS) then do j=k+1, i-1 y2=dataset%plocus(j,trait) if (abs(y1-y2) <= thresh) then ! if more than one shared DOB, then bump indicator value (MERLIN type, so 2,4...) if (prevy == MISS) then sibnum=sibnum+2 else if (abs(y1-prevy) >= thresh .and. (abs(y2-prevy) >= thresh)) then sibnum=sibnum+2 end if if (typ==3) then call wrdate(y1, sdate1, 2) call wrdate(y2, sdate2, 2) write(outstr,'(a12,1x,a12,3x,a10,4x,a12,3x,a10)') & dataset%pedigree(ped), trim(dataset%id(i)), sdate1, & trim(dataset%id(j)), sdate2 else write(outstr,'(a12,1x,a12,f16.4,1x,a12,f16.4)') & dataset%pedigree(ped), trim(dataset%id(i)), y1, & trim(dataset%id(j)), y2 end if if (dupidx /= MISS) then if (dataset%plocus(i,dupidx) == MISS .and. & dataset%plocus(j,dupidx) == MISS) then dataset%plocus(i,dupidx)=dfloat(sibnum) dataset%plocus(j,dupidx)=dfloat(sibnum) else if (dataset%plocus(i,dupidx) /= MISS) then dataset%plocus(j,dupidx)=dataset%plocus(i,dupidx) else if (dataset%plocus(j,dupidx) /= MISS) then dataset%plocus(i,dupidx)=dataset%plocus(j,dupidx) end if end if end if prevy=y2 end do end if end do ! Now update to next sibship fin=k currf=dataset%fa(fin) currm=dataset%mo(fin) end if end do end if end do end subroutine testsibage ! ! Test ages or DOB for consistency ! subroutine testage(typ, locnam, trait, thresh, dataset, droperr) use outstream use ped_class implicit none integer, intent(in) :: typ character (len=*), intent(in) :: locnam integer, intent(in) :: trait double precision, intent(in) :: thresh type (ped_data) :: dataset integer, intent(in) :: droperr ! integer, parameter :: MISS=-9999 ! regressions integer :: i, pedoffset, ped character (len=5) :: units units=' ' if (typ==3) then units='(yrs)' end if if (typ==1) then write(outstr, '(/3a)') & 'Checking for age inconsistencies using variable "', trim(locnam), '".' else write(outstr, '(/3a)') & 'Checking for DOB inconsistencies using variable "', trim(locnam), '".' end if if (thresh > 0.0d0) then if (typ==3) then write(outstr, '(a,i11,a,f4.1,a)') & 'Threshold for inconsistencies = ', & int(thresh), ' days (', thresh/365.25d0, ' years)' else write(outstr, '(a, f16.4)') & 'Threshold for inconsistencies = ', thresh end if end if if (droperr > 0) then write(outstr, '(a)') & 'Dropping any parental values that give rise to an inconsistency.' end if write(outstr, '(/a,a/a)') & 'Pedigree Parent ID Parental DOB Child ID Child DOB Diff ', units, & '------------ ------------ --------------- ------------ --------------- ----------------' do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1)+dataset%nfound(ped) do i=pedoffset+1, dataset%num(ped) if (dataset%plocus(i,trait)/=MISS) then call testpage(typ, trait, ped, i, 1, thresh, dataset, droperr) call testpage(typ, trait, ped, i, 2, thresh, dataset, droperr) end if end do end if end do end subroutine testage ! ! Test a parent ! subroutine testpage(typ, trait, ped, idx, parent, thresh, dataset, droperr) use outstream use ped_class use timelib implicit none integer, intent(in) :: typ integer, intent(in) :: ped, idx, parent, trait double precision, intent(in) :: thresh type (ped_data) :: dataset integer, intent(in) :: droperr ! integer, parameter :: MISS=-9999 integer :: par character (len=10) :: sdate1, sdate2 double precision :: diff if (parent==1) then par=dataset%fa(idx) else par=dataset%mo(idx) end if if (dataset%plocus(par, trait) /= MISS) then if (typ==1) then diff=dataset%plocus(par,trait)-dataset%plocus(idx,trait) else if (typ==2) then diff=dataset%plocus(idx,trait)-dataset%plocus(par,trait) else if (typ==3) then diff=tojulian(dataset%plocus(idx,trait))-tojulian(dataset%plocus(par,trait)) end if if (diff <= thresh) then if (typ==3) then call wrdate(dataset%plocus(par, trait), sdate1, 2) call wrdate(dataset%plocus(idx, trait), sdate2, 2) write(outstr,'(a12,1x,a12,3x,a10,4x,a12,3x,a10,3x,sp,f14.2)') & dataset%pedigree(ped), dataset%id(par), sdate1, & trim(dataset%id(idx)), sdate2, diff/365.25d0 else write(outstr,'(a12,1x,a12,f16.4,1x,a12,f16.4,sp,f16.4)') & dataset%pedigree(ped), & dataset%id(par), dataset%plocus(par, trait), & trim(dataset%id(idx)), dataset%plocus(idx, trait), diff end if if (droperr > 0) then dataset%plocus(par, trait)=MISS end if end if end if end subroutine testpage ! ! Check if multilocus ibs sharing for pairs of sibs is consistent ! with purported relationship. Again as per Bishop et al 1990 ! subroutine ckibs(nloci, loctyp, locpos, allele_buffer, dataset) use outstream use alleles_class use ped_class use locus_types use locus_list implicit none integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (allele_data) :: allele_buffer type (ped_data), intent(in) :: dataset integer, parameter :: KNOWN=0 ! expected ibs statistics for each marker integer :: nmark integer, dimension(:), allocatable :: mark double precision, dimension(:,:), allocatable :: e2 double precision :: p, p2, p4 ! integer :: den, g1, g2, g3, g4, gene, gen2, i, j, k, npairs, ped, pedoffset, sib double precision :: ex, mibs, mean, var, z logical :: ismzpair, samefa, samemo ! mean=0.0D0 npairs=0 var=0.0d0 ! Calculate expected values for ibs=2 statistic call cntmark(nloci, loctyp, nmark, 1) allocate(mark(nmark)) allocate(e2(nmark, 2)) nmark=0 do k=1, nloci if (isactdip(loctyp(k))) then nmark=nmark+1 mark(nmark)=locpos(k) call freq(locpos(k), 1, 0, dataset, allele_buffer) p2=0.0d0 p4=0.0d0 do i=1, allele_buffer%numal p=allele_buffer%allele_freqs(i) p=p*p p2=p2+p p4=p4+p*p end do e2(nmark, 1)=0.25d0*(1.0d0+2.0d0*p2*(1.0d0+p2)-p4) e2(nmark, 2)=0.5d0*(p2*(1.0d0+p2+p2)-p4) end if end do ! write(outstr,'(4(/a))') & '----------------------------------------------------', & 'Estimated Prob(IBS=2) over all markers for sib-pairs', & '----------------------------------------------------', & 'Pedigree Pers-1 Pers-2 ibs=2 Exp Dev Mrkrs' do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped)-1 do j=i+1, dataset%num(ped) samefa=(dataset%fa(i) == dataset%fa(j)) samemo=(dataset%mo(i) == dataset%mo(j)) ! ! Share a parent ! if (samefa.or.samemo) then den=0 ex=0.0D0 mibs=0.0D0 if (samefa .and. samemo) then sib=1 else sib=2 end if do k=1, nmark gene=mark(k) call get_geno(i, gene, gene+1, dataset, g1, g2) call get_geno(j, gene, gene+1, dataset, g3, g4) if (g1 > KNOWN .and. g3 > KNOWN) then den=den+1 gen2=gene+1 ex=ex+e2(k,sib) if ((g1 == g3 .and. g2 == g4).or. (g1 == g4 .and. g2 == g3)) then mibs=mibs+1.0D0 end if end if end do if (den > 0) then npairs=npairs+1 if (ismzpair(i, j, dataset)) ex=dble(den) z=sqrt(mibs)+sqrt(mibs+1)-sqrt(4*ex+1) mibs=mibs/dble(den) ex=ex/dble(den) call moment(npairs, mibs, mean, var) write(outstr,'(a10,2(1x,a10),2(2x,f6.4),1x,f7.2,2x,i3)') & dataset%pedigree(ped), dataset%id(i), dataset%id(j), mibs, ex, z, den end if end if end do end do end if end do if (npairs > 1) var=var/(npairs-1) write(outstr,'(/a,f6.4,a,f6.4,a/)') & 'Grand mean P(ibs=2)=', mean, ' (SD=', sqrt(var), ')' end subroutine ckibs ! ! Estimate kinship coefficients based on overall ibs sharing diallelic markers ! Shrinkage estimator of Endelman and Jannink [2012] ! Either founders only (typ=1), all individuals (typ=2), ! all individuals written to kinmat (typ=3), ! or subsetted on a phenotype (typ=4) ! subroutine momentibs(typ, trait, gt, thresh, nloci, loc, loctyp, locpos, & dataset, plevel) use interrupt use outstream use alleles_class use ped_class use locus_types use comp_ops use popgen_kinship implicit none integer, intent(in) :: typ integer, intent(in) :: trait integer, intent(in) :: gt double precision, intent(in) :: thresh integer, intent(in) :: nloci character(len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data), intent(in) :: dataset integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS=-9999 ! allele frequencies for each marker listed in mark integer, dimension(:), allocatable :: mark type (allele_data) :: allele_buffer integer, dimension(:), allocatable :: allele double precision, dimension(:), allocatable :: afreq ! coefficients to estimate kinship coefficients from IBS integer :: nmark double precision, dimension(:), allocatable :: mean, x double precision, dimension(:), allocatable :: s ! list of active individuals integer :: nactiv integer, dimension(dataset%nobs) :: activ ! integer :: astat, g, g1, g2, gene, gen2, i, ifail, idx, j, k, n, nobs, & ped, pedoffset, peri, perj, useful integer (kind=8) :: nn, nel, ncov double precision :: freq1, pqsum double precision, dimension(3) :: gtp ! functions double precision :: isaff ! ! count markers nmark=0 do j=1, nloci if (same_loctyp(loctyp(j), LOC_CODOM)) then nmark=nmark+1 end if end do ! ! list of individuals to be tested nactiv=0 if (typ == 1 .or. typ == 2 .or. typ == 3) then do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) n=dataset%num(ped) if (typ==1) n=pedoffset+dataset%nfound(ped) do i=pedoffset+1, n nactiv=nactiv+1 activ(nactiv)=i end do end if end do else if (typ == 4) then gene=locpos(trait) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (isaff(dataset%plocus(i,gene),thresh,gt) == 2.0d0) then nactiv=nactiv+1 activ(nactiv)=i end if end do end if end do end if if (plevel > -1 .or. nactiv < 2 .or. nmark == 0) then write(outstr,'(3(/a)/a,i0/a,i0/)') & '----------------------------------------------------', & 'Shrinkage type SNP IBS based kinship estimates', & '----------------------------------------------------' if (typ == 4 .and. trait /= MISS) then write(outstr,'(3a)') 'Subsetting on "', trim(loc(trait)), '".' call defpro(gt, thresh, .true.) end if write(outstr,'(a,i0/a,i0/)') & 'Number of individuals = ', nactiv, & 'Number of markers = ', nmark end if if (nactiv < 2 .or. nmark == 0) return ! ! allele frequencies pqsum=0.0d0 allocate(mark(nmark)) allocate(allele(nmark)) allocate(afreq(nmark)) nmark=0 do j=1, nloci if (same_loctyp(loctyp(j), LOC_CODOM)) then call freq(locpos(j), loctyp(j), 0, dataset, allele_buffer) if (allele_buffer%numal == 2 .and. allele_buffer%typed > 0) then nmark=nmark+1 mark(nmark)=j allele(nmark)=allele_buffer%allele_names(1) freq1=allele_buffer%allele_freqs(1) afreq(nmark)=2*freq1 pqsum=pqsum+freq1*(1.0d0-freq1) end if end if end do ! calculate ibs kinship coefficients for all pairs nel=int(nactiv, kind=8)*(int(nactiv,kind=8)+1)/2 allocate(mean(nactiv), x(nactiv)) allocate(s(nel), stat=astat) if (astat /= 0) then write(outstr,'(a,i0,a)') & 'ERROR: Failed to allocate ', nel, ' element kinship matrix.' deallocate(mean, x, mark, allele, afreq) return else write(outstr,'(a,i0,a)') 'Calculating ', nel, ' kinship coefficients.' end if nobs=0 mean=0.0d0 s=0.0d0 do j=1, nmark k=mark(j) gene=locpos(k) gen2=gene+1 gtp(1)=-afreq(j) gtp(2)=1.0d0-afreq(j) gtp(3)=2.0d0-afreq(j) useful=0 do i=1, nactiv peri=activ(i) call get_geno(peri, gene, gen2, dataset, g1, g2) if (g1 > KNOWN) then useful=useful+1 g=1 if (g1 == allele(j)) g=g+1 if (g2 == allele(j)) g=g+1 x(i)=gtp(g) else x(i)=0.0d0 end if end do if (useful > 0) then nobs=nobs+1 call dssp(nactiv, nobs, 1, x, mean, s) end if end do s=0.5d0*s/pqsum if (typ == 3) then nn=int(dataset%nobs, kind=8) ncov=nn*(nn-1)/2 call setup_kinmat(nn, ncov, 0.0d0, plevel, ifail) kinmat_nobs=int(n, kind=8) if (n == nactiv) then kinmat=s else idx=0 do i=1, nactiv peri=activ(i) do j=1, i perj=activ(j) idx=idx+1 kinmat(idx)=s(idx) end do end do end if else write(outstr,'(a)') 'ped1 id1 ped2 id2 kin' idx=0 do i=1, nactiv peri=activ(i) do j=1, i perj=activ(j) idx=idx+1 !----- write(outstr,'(1x,g14.6,1x)', advance='no') s(idx) write(outstr,'(4(a,1x),f7.5)') & trim(dataset%pedigree(dataset%iped(peri))), trim(dataset%id(peri)), & trim(dataset%pedigree(dataset%iped(perj))), trim(dataset%id(perj)), & s(idx) end do end do end if deallocate(s) deallocate(afreq) deallocate(mean) deallocate(mark) end subroutine momentibs ! ! fill array of allele frequencies for all active markers ! subroutine load_allele_array(nloci, loctyp, locpos, dataset, nmark, alleles) use alleles_class use ped_class use locus_types integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data), intent(in) :: dataset integer, intent(out) :: nmark type (allele_array) :: alleles type (allele_data) :: allele_buffer integer :: j nmark=0 do j=1, nloci if (same_loctyp(loctyp(j), LOC_CODOM)) then nmark=nmark+1 end if end do call setup_allele_array(nmark, alleles) nmark=0 do j=1, nloci if (same_loctyp(loctyp(j), LOC_CODOM)) then call freq(locpos(j), loctyp(j), 0, dataset, allele_buffer) if (allele_buffer%numal > 1 .and. allele_buffer%typed > 0) then nmark=nmark+1 alleles%mark(nmark)=j call freq(locpos(j), loctyp(j), 0, dataset, alleles%alleles(nmark)) end if end if end do alleles%nmark=nmark end subroutine load_allele_array ! ! Estimate kinship coefficients based on overall ibs sharing ! EM algorithm of Choi et al Genet Epidemiol 33:668-678 ! Either founders only (typ=1), all individuals (typ=2), ! within pedigrees (typ=3), subsetted on a phenotype (typ=4), ! or all v. index individual (typ=5). ! subroutine ibskin(typ, trait, gt, thresh, nloci, loc, loctyp, locpos, & dataset, plevel) use interrupt use outstream use alleles_class use ped_class use locus_types use comp_ops use sorts implicit none integer, intent(in) :: typ integer, intent(in) :: trait integer, intent(in) :: gt double precision, intent(in) :: thresh integer, intent(in) :: nloci character(len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data), intent(in) :: dataset integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS=-9999 ! allele frequencies for each marker listed in mark integer :: nmark type (allele_array) :: alleles ! coefficients to estimate kinship coefficients from IBS double precision, dimension(:,:), allocatable :: ibscoef ! numerator relationship matrix double precision, dimension(:), allocatable :: kin ! list of active individuals integer :: nactiv integer, dimension(dataset%nobs) :: activ ! integer :: den, g1, g2, g3, g4, gene, gen2, i, idx, j, k, n, & ped, pedoffset, peri, perj, useful, istate logical :: hom1, hom2 double precision :: k0, k1, k2, kval, p1, p2, p3, p4, p12, lik ! functions double precision :: isaff interface subroutine load_allele_array(nloci, loctyp, locpos, dataset, nmark, alleles) use alleles_class use ped_class use locus_types integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data), intent(in) :: dataset integer, intent(out) :: nmark type (allele_array) :: alleles end subroutine load_allele_array subroutine kinship(ped, dataset, kin) use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(in) :: dataset double precision, dimension(:), intent(inout) :: kin end subroutine kinship subroutine ibskin_one(peri, perj, locpos, alleles, dataset, useful, ibscoef) use outstream use alleles_class use ped_class use locus_types integer, intent(in) :: peri, perj integer, dimension(:), intent(in) :: locpos type (allele_array) :: alleles type (ped_data), intent(in) :: dataset integer, intent(out) :: useful double precision, dimension(alleles%nmark,3), intent(out) :: ibscoef end subroutine ibskin_one end interface ! call load_allele_array(nloci, loctyp, locpos, dataset, nmark, alleles) ! list of individuals to be tested nactiv=0 if (typ == 1 .or. typ == 2 .or. typ == 3 .or. typ == 5) then do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) n=dataset%num(ped) if (typ==1) n=pedoffset+dataset%nfound(ped) do i=pedoffset+1, n nactiv=nactiv+1 activ(nactiv)=i end do end if end do else if (typ == 4) then gene=locpos(trait) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (isaff(dataset%plocus(i,gene),thresh,gt) == 2.0d0) then nactiv=nactiv+1 activ(nactiv)=i end if end do end if end do end if if (plevel > -1 .or. nactiv < 2 .or. nmark == 0) then write(outstr,'(3(/a)/a,i0/a,i0/)') & '----------------------------------------------------', & 'IBS based kinship estimates', & '----------------------------------------------------' if (typ == 4 .and. trait /= MISS) then write(outstr,'(3a)') 'Subsetting on "', trim(loc(trait)), '".' call defpro(gt, thresh, .true.) end if write(outstr,'(a,i0/a,i0/)') & 'Number of individuals = ', nactiv, & 'Number of markers = ', nmark end if if (nactiv < 2 .or. nmark == 0) return allocate(ibscoef(nmark,3)) ! calculate ibs kinship coefficients for all pairs if (typ == 1 .or. typ == 2 .or. typ == 4) then write(outstr,'(a)') 'ped1 id1 ped2 id2 nloci k0 k1 k2 kin' do i=1, nactiv-1 peri=activ(i) do j=i+1, nactiv perj=activ(j) call ibskin_one(peri, perj, locpos, alleles, dataset, useful, ibscoef) if (useful > 0) then call emibskin(alleles%nmark, useful, ibscoef, k0, k1, k2, plevel) kval=k2+0.5d0*k1 write(outstr,'(4(a,1x),i0,4(1x,f7.5))') & trim(dataset%pedigree(dataset%iped(peri))), trim(dataset%id(peri)), & trim(dataset%pedigree(dataset%iped(perj))), trim(dataset%id(perj)), & useful, k0, k1, k2, kval end if end do if (irupt /= 0) exit end do ! kinship versus index individual else if (typ == 5) then allocate(kin(dataset%nobs)) kin=MISS peri=trait do j=1, nactiv perj=activ(j) call ibskin_one(peri, perj, locpos, alleles, dataset, useful, ibscoef) if (useful > 0) then call emibskin(alleles%nmark, useful, ibscoef, k0, k1, k2, plevel) kin(j)=k2+0.5d0*k1 end if if (irupt /= 0) exit end do call srank(nactiv, kin, activ) write(outstr,'(a)') 'ped1 id1 ped2 id2 nloci k0 k1 k2 kin' do j=min(nactiv, 10), 1, -1 perj=activ(j) call ibskin_one(peri, perj, locpos, alleles, dataset, useful, ibscoef) if (useful > 0) then call emibskin(alleles%nmark, useful, ibscoef, k0, k1, k2, plevel) kval=k2+0.5d0*k1 write(outstr,'(4(a,1x),i0,4(1x,f7.5))') & trim(dataset%pedigree(dataset%iped(peri))), trim(dataset%id(peri)), & trim(dataset%pedigree(dataset%iped(perj))), trim(dataset%id(perj)), & useful, k0, k1, k2, kval end if end do ! else calculate ibs kinship within all pedigrees else if (typ == 3) then allocate(kin(dataset%maxact*(dataset%maxact+1)/2)) write(outstr,'(a)') & 'Pedigree Person-1 Person-2 emp-R R Markers' do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) call kinship(ped, dataset, kin) idx=0 do i=pedoffset+2, dataset%num(ped) idx=idx+1 do j=pedoffset+1, i-1 idx=idx+1 call ibskin_one(i, j, locpos, alleles, dataset, useful, ibscoef) if (useful > 0) then call emibskin(alleles%nmark, useful, ibscoef, k0, k1, k2, plevel) kval=k2+0.5d0*k1 else kval=0.0d0 end if write(outstr,'(a10,2(1x,a14),1x,f6.4,1x,f6.4,1x,i10)') & dataset%pedigree(ped), dataset%id(i), dataset%id(j), & kval, kin(idx), useful end do if (irupt /= 0) exit end do end if end do deallocate(kin) end if deallocate(ibscoef) call cleanup_allele_array(alleles) end subroutine ibskin ! ! Estimate kinship based on overall ibs sharing ! EM algorithm of Choi et al Genet Epidemiol 33:668-678 ! Saves empirical kinship matrix for current pedigree ! subroutine empkin(ped, dataset, kin, plevel) use interrupt use outstream use alleles_class use ped_class use locus_types use locus_data use comp_ops implicit none integer, intent(in) :: ped type (ped_data), intent(in) :: dataset integer, intent(in) :: plevel ! numerator relationship matrix double precision, dimension(:), intent(out) :: kin integer, parameter :: KNOWN=0, MISS=-9999 ! allele frequencies for each marker listed in mark type (allele_array) :: alleles ! coefficients to estimate kinship coefficients from IBS integer :: nmark double precision, dimension(:,:), allocatable :: ibscoef ! integer :: i, idx, j, k, maxused, minused, n, & pedoffset, peri, perj, sumused, useful double precision :: k0, k1, k2 ! functions interface subroutine load_allele_array(nloci, loctyp, locpos, dataset, nmark, alleles) use alleles_class use ped_class use locus_types integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data), intent(in) :: dataset integer, intent(out) :: nmark type (allele_array) :: alleles end subroutine load_allele_array subroutine ibskin_one(peri, perj, locpos, alleles, dataset, useful, ibscoef) use outstream use alleles_class use ped_class use locus_types integer, intent(in) :: peri, perj integer, dimension(:), intent(in) :: locpos type (allele_array) :: alleles type (ped_data), intent(in) :: dataset integer, intent(out) :: useful double precision, dimension(alleles%nmark,3), intent(out) :: ibscoef end subroutine ibskin_one subroutine kinship(ped, dataset, kin) use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(in) :: dataset double precision, dimension(:), intent(inout) :: kin end subroutine kinship end interface ! call load_allele_array(nloci, loctyp, locpos, dataset, nmark, alleles) allocate(ibscoef(nmark,3)) ! calculate ibs kinship within current pedigree ! initialize with pedigree based value call kinship(ped, dataset, kin) pedoffset=dataset%num(ped-1) idx=0 sumused=0 minused=nmark maxused=0 do i=pedoffset+2, dataset%num(ped) idx=idx+1 do j=pedoffset+1, i-1 idx=idx+1 call ibskin_one(i, j, locpos, alleles, dataset, useful, ibscoef) if (useful > 0) then call emibskin(alleles%nmark, useful, ibscoef, k0, k1, k2, plevel) kin(idx)=k2+0.5d0*k1 end if if (useful < minused) minused=useful if (useful > maxused) maxused=useful sumused=sumused+useful end do if (irupt /= 0) exit end do deallocate(ibscoef) call cleanup_allele_array(alleles) if (plevel > 1) then write(outstr,'(a,i0,a,i0,a,i0,a)') & 'Mean number of markers used = ', & int(dble(sumused)/dble(idx)), ' (', minused, ' to ', maxused, ')' idx=1 do i=1, min(dataset%num(ped)-dataset%num(ped-1), 4) write(outstr,'(a,4(1x,f5.3))') dataset%id(pedoffset+i), kin(idx:(idx+i-1)) idx=idx+i end do end if end subroutine empkin ! ! Estimate kinship coefficients based on overall ibs sharing ! One pair of relatives ! subroutine ibskin_one(peri, perj, locpos, alleles, dataset, useful, ibscoef) use outstream use alleles_class use ped_class use locus_types implicit none integer, intent(in) :: peri, perj integer, dimension(:), intent(in) :: locpos type (allele_array) :: alleles type (ped_data), intent(in) :: dataset integer, intent(out) :: useful double precision, dimension(alleles%nmark,3), intent(out) :: ibscoef integer, parameter :: KNOWN=0 ! integer :: g1, g2, g3, g4, gene, i, ishare, j, k, istate logical :: hom1, hom2 double precision :: p1, p2, p3, p4, p12 ! functions double precision :: getfreq ! useful=0 do k=1, alleles%nmark gene=locpos(alleles%mark(k)) ibscoef(k,1:3)=0.0d0 call get_geno(peri, gene, gene+1, dataset, g1, g2) call get_geno(perj, gene, gene+1, dataset, g3, g4) if (g1 > KNOWN .and. g3 > KNOWN) then useful=useful+1 hom1=(g1 == g2) hom2=(g3 == g4) if (hom1 .and. hom2) then p1=getfreq(g1, alleles%alleles(k)) ! State 2 if (g1 /= g3) then istate=2 p3=getfreq(g3, alleles%alleles(k)) ibscoef(k,1)=p1*p1*p3*p3 ! State 1 else istate=1 ibscoef(k,3)=p1*p1 ibscoef(k,2)=ibscoef(k,3)*p1 ibscoef(k,1)=ibscoef(k,2)*p1 end if else if (.not.hom1 .and. .not.hom2) then p1=getfreq(g1, alleles%alleles(k)) p2=getfreq(g2, alleles%alleles(k)) ishare=0 if (g1 == g3 .or. g1 == g4) ishare=ishare+1 if (g2 == g3 .or. g2 == g4) ishare=ishare+1 ! State 5 (IBS7) if (ishare == 2) then istate=5 p12=p1*p2 ibscoef(k,1)=4*p12*p12 ibscoef(k,2)=p12*(p1+p2) ibscoef(k,3)=2*p12 ! State 7 (IBS9) else if (ishare == 0) then istate=7 p3=getfreq(g3, alleles%alleles(k)) p4=getfreq(g4, alleles%alleles(k)) ibscoef(k,1)=4*p1*p2*p3*p4 ! State 6 (IBS8, p1, p2, p3 are the 3 unique alleles) else istate=6 if (g1 /= g3 .and. g2 /= g3) then p3=getfreq(g3, alleles%alleles(k)) p4=getfreq(g4, alleles%alleles(k)) else p3=getfreq(g4, alleles%alleles(k)) p4=getfreq(g3, alleles%alleles(k)) end if ibscoef(k,2)=p1*p2*p3 ibscoef(k,1)=4*p4*ibscoef(k,2) end if else ! State 4 (IBS4 + IBS6) if (g1 /= g3 .and. g2 /= g4 .and. g1 /= g4 .and. g2 /= g3) then istate=4 if (hom1) then p1=getfreq(g1, alleles%alleles(k)) p2=getfreq(g3, alleles%alleles(k)) p3=getfreq(g4, alleles%alleles(k)) else p1=getfreq(g3, alleles%alleles(k)) p2=getfreq(g1, alleles%alleles(k)) p3=getfreq(g2, alleles%alleles(k)) end if ibscoef(k,1)=2*p1*p1*p2*p3 ! State 3 (IBS3 + IBS5) else istate=3 if (hom1) then p1=getfreq(g1, alleles%alleles(k)) if (g1 == g3) then p2=getfreq(g4, alleles%alleles(k)) else p2=getfreq(g3, alleles%alleles(k)) end if else p1=getfreq(g3, alleles%alleles(k)) if (g1 == g3) then p2=getfreq(g2, alleles%alleles(k)) else p2=getfreq(g1, alleles%alleles(k)) end if end if ibscoef(k,2)=p1*p1*p2 ibscoef(k,1)=2*p1*ibscoef(k,2) end if end if end if end do end subroutine ibskin_one ! ! EM approach of Choi et al 2009 ! subroutine emibskin(nmark, nused, ibscoef, k0, k1, k2, plevel) use outstream implicit none integer, intent(in) :: nmark, nused double precision, dimension(nmark,3), intent(in) :: ibscoef double precision, intent(out) :: k0, k1, k2 integer, intent(in) :: plevel ! IBDs ! double precision, dimension(nmark, 3) :: ibds integer :: it, k double precision :: delta, est0, est1, est2, lik, & prevk0, prevk1, prevk2, ptot double precision, parameter :: tol = 1.0d-4 delta=1.0d0 k0=0.4d0 k1=0.3d0 k2=0.3d0 it=0 if (plevel > 2) then write(outstr,'(a)') '! Iter k0 k1 k2 loglik' end if do while (delta > tol) it=it+1 prevk0=k0 prevk1=k1 prevk2=k2 est0=0.0d0 est1=0.0d0 est2=0.0d0 lik=0.0d0 do k=1, nmark ptot=ibscoef(k,1)*k0+ibscoef(k,2)*k1+ibscoef(k,3)*k2 if (ptot /= 0.0d0) then lik=lik+log(ptot) est0=est0+k0*ibscoef(k,1)/ptot est1=est1+k1*ibscoef(k,2)/ptot est2=est2+k2*ibscoef(k,3)/ptot end if end do k0=est0/dble(nused) k1=est1/dble(nused) k2=est2/dble(nused) delta=abs(prevk0-k0)+abs(prevk1-k1)+abs(prevk2-k2) if (plevel > 2) then write(outstr,'(a,i4,4(1x,f12.5))') '! ', it, k0, k1, k2, lik end if end do end subroutine emibskin ! ! BLUE allele frequency estimator of McPeek et al 2004 ! ! a = (1' L^(-1) 1)^(-1) 1' L^(-1) Z ! Var(a) = 0.5 * (1' L^(-1) 1)^(-1) a(1-a) ! Z=ith allele count L=NRM ! subroutine bluefreq(gene, filter, gt, thresh, dataset, allele_buffer, plevel) use ped_class use alleles_class use locus_types use outstream use symmetric_matrix use popgen_kinship integer, intent(in) :: gene integer, intent(in) :: filter integer, intent(in) :: gt double precision, intent(in) :: thresh type (ped_data) :: dataset type (allele_data) :: allele_buffer integer, intent(in) :: plevel integer, parameter :: MISS = -9999 integer :: g, g1, g2, gen2, i, iall, ii, & nobs, num, ped, pedoffset, tfound, totobs character (len=3) :: allel double precision :: afreq, a1, a2, logdet, minfreq, topfreq double precision, dimension(allele_buffer%numal) :: ns, ds logical, dimension(dataset%maxact) :: active double precision, dimension(dataset%maxact) :: xval, ones double precision, dimension(dataset%maxact*(dataset%maxact+1)/2) :: a, ainv ! functions double precision :: isaff interface subroutine kinship(ped, dataset, kin) use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(in) :: dataset double precision, dimension(:), intent(inout) :: kin end subroutine kinship subroutine thincov(nfull, nreduced, active, cov) integer, intent(in) :: nfull integer, intent(in) :: nreduced logical, dimension(:), intent(in) :: active double precision, dimension(:) :: cov end subroutine thincov end interface if (allele_buffer%typed == 0) return gen2=gene+1 tfound=0 totobs=0 ns=0.0D0 ds=0.0D0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset nobs=0 ii=pedoffset if (filter /= MISS) then do i=1, num ii=ii+1 active(i)=.false. if (observed(ii, gene, dataset) .and. & dataset%imztwin(ii) == MISS .and. & int(isaff(dataset%plocus(ii,filter),thresh,gt)) == 2) then nobs=nobs+1 if (i <= dataset%nfound(ped)) tfound=tfound+1 active(i)=.true. end if end do else do i=1, num ii=ii+1 active(i)=.false. if (observed(ii, gene, dataset) .and. dataset%imztwin(ii) == MISS) then nobs=nobs+1 if (i <= dataset%nfound(ped)) tfound=tfound+1 active(i)=.true. end if end do end if if (plevel > 1) then write(outstr,'(2a,1x,i0,a)') & 'Pedigree ', trim(dataset%pedigree(ped)), nobs, ' usable genotypes.' end if if (nobs > 0) then ! Additive genetic effects call kinship(ped, dataset, a) call thincov(num, nobs, active, a) call hash_kinship(num, active) call kininv(a, nobs, ainv, logdet, i, plevel) do iall=1, allele_buffer%numal nobs=0 ii=pedoffset do i=1, num ii=ii+1 if (active(i)) then nobs=nobs+1 call get_namedgeno(ii, gene, gen2, & dataset, allele_buffer, g1, g2) g=0 if (g1 == iall) g=g+1 if (g2 == iall) g=g+1 xval(nobs)=0.5d0*dble(g) ones(nobs)=1.0d0 end if end do call quadmult(1, nobs, ones, ainv, a1) call quadmult(2, nobs, xval, ainv, a2) ns(iall)=ns(iall)+a2 ds(iall)=ds(iall)+a1 end do totobs=totobs+nobs end if end if end do call save_bluefreqs(filter, allele_buffer, totobs, ns, ds, plevel) end subroutine bluefreq ! ! BLUE allele frequency estimator of McPeek et al 2004 ! using empirical kinship matrix for entire sample ! ! a = (1' L^(-1) 1)^(-1) 1' L^(-1) Z ! Var(a) = 0.5 * (1' L^(-1) 1)^(-1) a(1-a) ! Z=ith allele count L=NRM ! subroutine bigblue(gene, filter, gt, thresh, dataset, allele_buffer, plevel) use ped_class use alleles_class use locus_types use outstream use symmetric_matrix use kinship_io integer, intent(in) :: gene integer, intent(in) :: filter integer, intent(in) :: gt double precision, intent(in) :: thresh type (ped_data) :: dataset type (allele_data) :: allele_buffer integer, intent(in) :: plevel integer, parameter :: MISS = -9999 integer :: astat, g, g1, g2, gen2, i, iall, ii, & nn, nobs, num, ped, pedoffset, tfound, totobs character (len=3) :: allel double precision :: afreq, a1, a2, logdet, topfreq double precision, dimension(allele_buffer%numal) :: ns, ds ! total elapsed time integer :: it1, it2 character (len=20) :: slin double precision, dimension(:), allocatable :: xval, ones double precision, dimension(:), allocatable :: a, ainv ! functions double precision :: isaff if (allele_buffer%typed == 0) return gen2=gene+1 tfound=0 totobs=0 ns=0.0D0 ds=0.0D0 dataset%untyped=.false. do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset ii=pedoffset if (filter /= MISS) then do i=1, num ii=ii+1 if (observed(ii, gene, dataset) .and. & int(isaff(dataset%plocus(ii,filter),thresh,gt)) == 2) then totobs=totobs+1 if (i <= dataset%nfound(ped)) tfound=tfound+1 dataset%untyped(ii)=.TRUE. end if end do else do i=1, num ii=ii+1 if (observed(ii, gene, dataset)) then totobs=totobs+1 if (i <= dataset%nfound(ped)) tfound=tfound+1 dataset%untyped(ii)=.TRUE. end if end do end if end if end do ! nn=totobs*(totobs+1)/2 allocate(ones(totobs), xval(totobs)) allocate(a(nn), ainv(nn), stat=astat) if (astat /= 0) then write(outstr,'(a,i0,a)') & 'ERROR: Unable to allocate memory for ', nn, ' correlations.' return end if ! Additive genetic effects call get_kinship(dataset%nobs, totobs, dataset%untyped, a) call kininv(a, totobs, ainv, logdet, i, plevel) do iall=1, allele_buffer%numal nobs=0 do ii=1, dataset%nobs if (dataset%untyped(ii)) then nobs=nobs+1 call get_namedgeno(ii, gene, gen2, & dataset, allele_buffer, g1, g2) g=0 if (g1 == iall) g=g+1 if (g2 == iall) g=g+1 xval(nobs)=0.5d0*dble(g) ones(nobs)=1.0d0 end if end do call quadmult(1, nobs, ones, ainv, a1) call quadmult(2, nobs, xval, ainv, a2) ns(iall)=ns(iall)+a2 ds(iall)=ds(iall)+a1 end do call save_bluefreqs(filter, allele_buffer, totobs, ns, ds, plevel) end subroutine bigblue ! ! Save BLUE estimates to allele_buffer ! subroutine save_bluefreqs(filter, allele_buffer, totobs, ns, ds, plevel) use alleles_class use outstream integer, intent(in) :: filter type (allele_data) :: allele_buffer integer, intent(in) :: totobs double precision, dimension(allele_buffer%numal) :: ns, ds integer, intent(in) :: plevel integer, parameter :: MISS = -9999 integer :: i character (len=3) :: allel double precision :: afreq, minfreq, topfreq minfreq=1.0d0 topfreq=0.0d0 if (allocated(allele_buffer%freq_stderrs)) then deallocate(allele_buffer%freq_stderrs) end if allocate(allele_buffer%freq_stderrs(allele_buffer%numal)) do i=1, allele_buffer%numal afreq=ns(i)/ds(i) allele_buffer%allele_freqs(i)=afreq allele_buffer%freq_stderrs(i)=sqrt(0.5d0*afreq*(1.0d0-afreq)/ds(i)) if (allele_buffer%allele_freqs(i) > topfreq) then topfreq=allele_buffer%allele_freqs(i) allele_buffer%topall=i end if if (allele_buffer%allele_freqs(i) < minfreq) then minfreq=allele_buffer%allele_freqs(i) allele_buffer%minall=i end if end do allele_buffer%cum_freqs(1)=allele_buffer%allele_freqs(1) allele_buffer%cum_freqs(allele_buffer%numal)=1.0d0 do i=2, allele_buffer%numal-1 allele_buffer%cum_freqs(i)= allele_buffer%cum_freqs(i-1) + & allele_buffer%allele_freqs(i) end do if (plevel > 1 .or. (plevel >= 0 .and. filter /= MISS)) then write(outstr,'(/a,i0//a/a)') & 'Observed genotypes = ', totobs, & 'All Neff Tot Freq ASE', & '--- -------- -------- ------ ------' do i=1, allele_buffer%numal call wrall(allele_buffer%allele_names(i), allel) write(outstr,'(a3,2(1x,f8.2),1x,f6.4,1x,f6.4)') & allel, ns(i), ds(i), allele_buffer%allele_freqs(i), & allele_buffer%freq_stderrs(i) end do write(outstr,*) end if end subroutine save_bluefreqs ! ! Print big tabulation of BLUE allele frequencies versus strata ! subroutine blutab(nloc, loclist, filter, nloci, loc, locpos, loctyp, locnotes, & dataset, iter, nwid, ndec, pval, plevel) use outstream use ped_class use alleles_class use categorical_data use read_data use locus_types use comp_ops integer, intent(in) :: nloc ! number of dimensions integer, intent(in) :: loclist(nloc) ! variable list integer, intent(in) :: filter ! temporary for stratum membership integer, intent(in) :: nloci ! total loci character (len=*), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp character (len=*), dimension(:), intent(in) :: locnotes type (ped_data) :: dataset integer, intent(in) :: iter integer, intent(in) :: nwid, ndec double precision, intent(out) :: pval integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS=-9999 ! ! data table ! type (table_data) :: table, martable type (allele_data) :: allele_buffer, allele_buffer2 integer, dimension(nloc) :: chosen double precision, dimension(nloc) :: val type (table_cell), dimension(nloc) :: cell_values double precision, dimension(:,:), allocatable :: alfrq integer :: astat, i, gene, gt, j, jlev, k, klev, nmiss, mark, stratum logical :: allinteger character (len=3) :: allel character (len=10) :: cval1 double precision :: thresh ! functions interface subroutine ascend(n, ia) integer, intent(in) :: n integer, dimension(:), intent(inout) :: ia end subroutine end interface pval=1.0d0 mark=loclist(nloc) if (.not.ismarker(loctyp(mark))) then write(outstr,'(a)') 'Expected marker!' return end if gene=locpos(mark) call setup_freq(20, allele_buffer) call setup_freq(20, allele_buffer2) call freq(gene, loctyp(mark), 0, dataset, allele_buffer) if (allele_buffer%typed == 0 .or. allele_buffer%numal == 1) then write(outstr,'(3a)') 'Marker ', loc(mark),' is uninformative!' return end if write(outstr,'(/a/5a/a)') & '------------------------------------------------------------------------', & 'Cross-tabulation of "', & trim(loc(loclist(1))), '" ... "', trim(loc(loclist(nloc))),'" BLUE allele frequencies' , & '------------------------------------------------------------------------' call maketab(0, 0, nloc, loclist, nloci, loc, locpos, loctyp, & dataset, nmiss, table) call setup_table(nloc-1, 100, martable) call ascend(nloc-1, chosen) call marginal_table(nloc-1, chosen, table, martable) ! allocate(alfrq(martable%ncells, allele_buffer%numal)) alfrq=0.0d0 ! indicate individuals matching this stratum do i=1, dataset%nobs dataset%plocus(i,filter)=MISS call readval(0, i, nloc-1, loclist, nloci, loc, locpos, loctyp, & dataset, val, astat) if (astat == 0) then do j=1, nloc-1 call set_table_cell(cell_values(j), rvalue=val(j)) end do stratum=search_table(nloc-1, cell_values, martable, plevel-2) if (stratum > 0) then dataset%plocus(i,filter)=stratum end if end if end do call reorder_cat(martable, filter, dataset, allinteger) gt=COMP_EQ do j=1, martable%ncells jlev=martable%idx(j) thresh=dble(jlev) call copyfreq(allele_buffer, allele_buffer2) call bluefreq(gene, filter, gt, thresh, dataset, allele_buffer2, plevel-1) alfrq(jlev,1:allele_buffer2%numal)=allele_buffer2%allele_freqs end do ! print table write(outstr,'(30x,a)') trim(loc(mark)) do j=1, nloc-1 cval1=loc(loclist(j)) call juststr('c', cval1, 10) write(outstr,'(a10,a)', advance='no') cval1, ' ' end do write(outstr,'(a10)', advance='no') 'N' do j=1, allele_buffer%numal call wrall(allele_buffer%allele_names(j), allel) write(outstr,'(a10)', advance='no') allel end do write(outstr,*) do j=1, nloc-1 write(outstr,'(a,1x)', advance='no') repeat('-',10) end do write(outstr,'(a)') repeat('-',10+allele_buffer%numal*11) do j=1, martable%ncells jlev=martable%idx(j) do k=1, nloc-1 klev=loclist(k) call wrtrait(martable%categories(jlev,k)%rvalue, cval1, & loctyp(klev), get_notes(loc(klev), locnotes(klev)), nwid, ndec) write(outstr,'(a10,1x)', advance='no') cval1 end do write(outstr,'(i10,1x)', advance='no') martable%icount(jlev) write(outstr,'(50(4x,f6.4):)') alfrq(jlev,:) end do end subroutine blutab ! ! MQLS of Bourgain et al 2003, Thornton et al 2007 ! subroutine domqls(typ, trait, gt, thresh, gene, locnam, prev, nulltyp, & dataset, allele_buffer, iter, pval, plevel) use ped_class use alleles_class use locus_types use outstream use symmetric_matrix use rngs use statfuns integer, intent(in) :: typ integer, intent(in) :: trait integer, intent(in) :: gt double precision, intent(in) :: thresh integer, intent(in) :: gene character (len=*) :: locnam double precision, intent(in) :: prev integer, intent(in) :: nulltyp type (ped_data) :: dataset type (allele_data) :: allele_buffer integer, intent(in) :: iter double precision, intent(out) :: pval integer, intent(in) :: plevel integer, parameter :: MISS = -9999 integer :: aff, g, g1, g2, gen2, i, ia, ii, j, naff, nobs, num, ped, & pedoffset, tailp, totaff, totobs integer :: astat, nn character (len=3) :: allel character (len=4) :: cstat double precision :: afreq, a1, a2, a3, alt1, alt2, cfreq, chi2, corrz, & logdet, mfreq, topfreq, unaff, var, v, wmax, z, zmax double precision :: stat1, stat2, pval1, pval2 ! Simulated P-values double precision :: afreq1, cfreq1, chisq, ediff, ochisq, empvar, ovar ! MQLS double precision, dimension(dataset%maxact) :: ymqls, yreg, ywork double precision :: ma2, mcs, mds1, mds2, v_mqls, vm, zm ! WQLS 1=null 2=WQLS 3=MQLS double precision, dimension(3, allele_buffer%numal) :: ns ! Pieces of robust variance for allele freq double precision, dimension(allele_buffer%numal) :: robvar double precision :: cs, ds1, ds2, nullvar, v_wqls, vf ! corrX2 integer, dimension(allele_buffer%numal) :: casall, totall double precision :: corfact, corvar, corzero, term1, term2, term3 logical, dimension(dataset%maxact) :: active integer, dimension(dataset%maxact,2) :: set double precision, dimension(dataset%maxact) :: yval, xval, ones ! correlation matrices double precision, dimension(:), allocatable :: fulla double precision, dimension(:), allocatable :: a, ainv ! functions character (len=3) :: histo character (len=6) :: pstring double precision :: bonf, isaff interface subroutine kinship(ped, dataset, kin) use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(in) :: dataset double precision, dimension(:), intent(inout) :: kin end subroutine kinship subroutine thincov(nfull, nreduced, active, cov) integer, intent(in) :: nfull integer, intent(in) :: nreduced logical, dimension(:), intent(in) :: active double precision, dimension(:) :: cov end subroutine thincov subroutine predmat(nfull, yindicator, cov, xval, yp) integer, intent(in) :: nfull logical, dimension(:), intent(in) :: yindicator double precision, dimension(:), intent(in) :: cov double precision, dimension(:), intent(in) :: xval double precision, dimension(:), intent(out) :: yp end subroutine predmat subroutine simped(ped, dataset, allele_buffer, set) use alleles_class use ped_class integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data), intent(in) :: allele_buffer integer, dimension(:,:), intent(out) :: set end subroutine simped end interface totaff=0 totobs=0 if (allele_buffer%typed == 0 .or. allele_buffer%numal == 1) then if (plevel == -1 .or. plevel == 0) then write(outstr,'(a20,2(a1,i6),a1,f10.1,3(a1,a))') & locnam, tabsep, totobs, tabsep, allele_buffer%numal, tabsep, & 0.0d0, tabsep, '- ', tabsep, 'MQLS', tabsep, ' ' else if (plevel > 0) then write(outstr,'(3a)') & 'NOTE: Marker "', trim(locnam), '" is uninformative.' end if return end if nn=dataset%maxact*(dataset%maxact+1)/2 allocate(fulla(nn), a(nn), ainv(nn), stat=astat) if (astat /= 0) then write(outstr,'(a,i0,a)') & 'ERROR: Unable to allocate memory for ', nn, ' correlations.' return end if ! Per family results if (plevel > 0) then write(outstr,'(/2a/)') 'MQLS results for: ', locnam if (plevel > 1 .and. iter > 0) then write(outstr, '(a/a)') & 'Pedigree Allele Freq E(Freq) ASE Emp SE Asy P Emp P Iters', & '---------- ------ ------ ------- ------ ------ ------ ------ -------' end if end if gen2=gene+1 mns=0.0D0 mds1=0.0D0 mds2=0.0D0 ns=0.0D0 ds1=0.0D0 ds2=0.0D0 cs=0.0d0 robvar=0.0d0 term1=0.0d0 term2=0.0d0 term3=0.0d0 unaff=0.0d0 if (prev /= MISS) then unaff=-prev/(1.0d0-prev) end if casall=0 totall=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset naff=0 nobs=0 nunobs=-1 ii=pedoffset do i=1, num ii=ii+1 active(i)=.false. aff=int(isaff(dataset%plocus(ii,trait),thresh,gt)) if (observed(ii, gene, dataset) .and. dataset%imztwin(ii) == MISS) then nobs=nobs+1 active(i)=.true. ones(nobs)=1.0d0 yval(nobs)=0.0d0 ymqls(nobs)=0.0d0 if (aff == 2) then naff=naff+1 totaff=totaff+1 yval(nobs)=1.0d0 ymqls(nobs)=1.0d0 else if (aff == 1) then ymqls(nobs)=unaff end if else nunobs=nunobs+1 ymqls(num-nunobs)=0.0d0 if (aff == 2) then ymqls(num-nunobs)=1.0d0 else if (aff == 1) then ymqls(num-nunobs)=unaff end if end if end do if (nobs > 0) then ! Additive genetic effects call kinship(ped, dataset, fulla) a=fulla call thincov(num, nobs, active, a) call kininv(a, nobs, ainv, logdet, i, plevel) ! corrected chi-square variance call quadmult(1, nobs, yval, a, a1) call quadxy(nobs, ones, a, yval, a2) call quadmult(1, nobs, ones, a, a3) term1=term1+a1 term2=term2+a2 term3=term3+a3 ! terms for WQLS (1c' V~ 1c), (1c' V~ 1) call sumsym(nobs, ainv, a2) ds1=ds1+a2 call quadmult(2, nobs, yval, ainv, alt2) ds2=ds2+alt2 call quadmult(1, nobs, yval, ainv, v) cs=cs+v ! terms for MQLS w_test, (w_test' V w_test), (w_test' 1) call predmat(num, active, fulla, ymqls, ywork) call postmult(nobs, ywork, ainv, yreg) do i=1, nobs yreg(i)=yreg(i)+ymqls(i) end do if (plevel > 2) then j=0 write(outstr,'(a12,1x,a12,2(1x,a7))') 'ped', 'id', 'ymqls', 'yreg' do i=1, num if (active(i)) then j=j+1 write(outstr,'(a12,1x,a12,2(1x,f7.5))') & dataset%pedigree(ped), dataset%id(pedoffset+i), & ymqls(j), yreg(j) end if end do end if call quadmult(1, nobs, yreg, a, ma2) mds1=mds1+ma2 do i=1, nobs mds2=mds2+yreg(i) end do ! do ia=1, allele_buffer%numal nobs=0 ii=pedoffset do i=1, num ii=ii+1 if (active(i)) then nobs=nobs+1 call get_namedgeno(ii, gene, gen2, & dataset, allele_buffer, g1, g2) g=0 if (g1 == ia) g=g+1 if (g2 == ia) g=g+1 xval(nobs)=0.5d0*dble(g) totall(ia)=totall(ia)+g if (isaff(dataset%plocus(ii,trait),thresh,gt) == 2.0d0) then casall(ia)=casall(ia)+g end if end if end do ! null, including terms for robust estimate of variance of allele freq call quadmult(2, nobs, xval, ainv, a1) ns(1,ia)=ns(1,ia)+a1 call quadmult(1, nobs, xval, ainv, vf) robvar(ia)=robvar(ia)+vf ! WQLS alternative call quadxy(nobs, yval, ainv, xval, alt1) ns(2,ia)=ns(2,ia)+alt1 ! MQLS alternative do j=1, nobs ns(3,ia)=ns(3,ia)+yreg(j)*xval(j) end do ! ! within-pedigree empirical variance and P-value if (plevel > 1 .and. iter > 0 .and. a2 /= 0.0d0 .and. alt2 /= 0.0d0) then afreq=a1/a2 cfreq=alt1/alt2 ovar=0.5d0*afreq*(1-afreq)*(v/alt2/alt2-1.0d0/a2) if (ovar > 0.0d0) then ochisq=(afreq-cfreq) ochisq=ochisq*ochisq/ovar ediff=0.0d0 empvar=0.0d0 tailp=0 do it=1, iter call simped(ped, dataset, allele_buffer, set) nobs=0 do i=1, num if (active(i)) then nobs=nobs+1 g=0 if (set(i,1) == ia) g=g+1 if (set(i,2) == ia) g=g+1 xval(nobs)=0.5d0*dble(g) end if end do call quadmult(2, nobs, xval, ainv, a1) afreq1=a1/a2 call quadxy(nobs, yval, ainv, xval, alt1) cfreq1=alt1/alt2 var=0.5d0*afreq*(1-afreq)*(v/alt2/alt2-1.0d0/a2) chisq=(afreq1-cfreq1) chisq=chisq*chisq/var call moment(it, afreq1-cfreq1, ediff, empvar) if (chisq > ochisq .or. (chisq == ochisq .and. random() > 0.5)) then tailp=tailp+1 end if end do empvar=empvar/dble(max(iter,1)) call wrall(allele_buffer%allele_names(ia), allel) write(outstr,'(a12,1x,a3,2x,4(2x,f6.4),2(1x,a6),1x,i7)') & dataset%pedigree(ped), allel, afreq, cfreq, sqrt(ovar), & sqrt(empvar), pstring(chip(ochisq,1)), & pstring(dble(tailp)/dble(iter)), iter end if end if end do end if totobs=totobs+nobs end if end do if (totaff == totobs .or. totaff == 0) then if (plevel == -1 .or. plevel == 0) then write(outstr,'(a20,2(a1,i6),a1,f10.1,3(a1,a))') & locnam, tabsep, totobs, tabsep, allele_buffer%numal, tabsep, & 0.0d0, tabsep, '- ', tabsep, cstat, tabsep, ' ' else if (plevel > 0) then write(outstr,'(3a,i0,a)') & 'NOTE: Marker "', trim(locnam), '" is uninformative: ', naff, ' affecteds.' end if return end if ! ! CorrX2 correction corzero=dble(totobs-totaff)/dble(totobs*totaff) corfact=term1/dble(totaff*totaff) - & 2*term2/dble(totobs*totaff) + & term3/dble(totobs*totobs) v_mqls=(mds1/mds2/mds2-1.0d0/ds1) v_wqls=(cs/ds2/ds2-1.0d0/ds1) wmax=0.0d0 zmax=0.0d0 if (plevel > 0) then write(outstr,'(/a,i0)') & 'Number of typed cases = ', totaff write(outstr,'(/a,f7.4//a/a)') & 'Chi-square correction = ', corfact/corzero, & 'Allele Case Freq E(Freq) SD Z Value P-value', & '------- ---------- ------- ------- -------- -------' end if do i=1, allele_buffer%numal ! WQLS variance afreq=ns(1,i)/ds1 cfreq=ns(2,i)/ds2 if (nulltyp == 1) then nullvar=0.5d0*afreq*(1.0d0-afreq) else nullvar=(robvar(i)-ns(1,i)*ns(1,i)/ds1)/dble(max(1,totobs-1)) end if v=nullvar*v_wqls z=(cfreq-afreq)/sqrt(v) if (abs(z) > abs(wmax)) wmax=z ! MQLS variance mfreq=ns(3,i)/mds2 vm=nullvar*v_mqls zm=(mfreq-afreq)/sqrt(vm) if (abs(zm) > abs(zmax)) zmax=zm ! CorrX2 variance afreq1=0.5d0*dble(totall(i))/dble(totobs) cfreq1=0.5d0*dble(casall(i))/dble(totaff) corvar=nullvar*corfact corrz=(cfreq1-afreq1)/sqrt(corvar) if (plevel > 0) then call wrall(allele_buffer%allele_names(i), allel) write(outstr,'(1x,a3,2x,f9.4,2x,2(f8.4,2x),f8.2,2(2x,a))') & allel, mfreq, afreq, sqrt(vm), zm, pstring(chip(zm*zm,1)), 'MQLS' write(outstr,'(1x,a3,2x,f9.4,2x,2(f8.4,2x),f8.2,2(2x,a))') & allel, cfreq, afreq, sqrt(v), z, pstring(chip(z*z,1)), 'WQLS' write(outstr,'(1x,a3,3x,3(2x,f6.4,2x),f8.2, 2(2x,a))') & allel, cfreq1, afreq1, sqrt(corvar), corrz, & pstring(chip(corrz*corrz,1)), 'corrX2' end if end do ! Zmax based P value stat1=zmax*zmax pval1=chip(stat1,1) * max(1,allele_buffer%numal-1) stat2=wmax*wmax pval2=chip(stat2,1) * max(1,allele_buffer%numal-1) if (typ == 1) then cstat='MQLS' chi2=stat1 pval=pval1 else if (typ == 2) then cstat='WQLS' chi2=stat2 pval=pval2 end if if (plevel == -1 .or. plevel == 0) then call phist(pval, 1.0d0, histo) write(outstr,'(a20,2(a1,i6),a1,f10.1,3(a1,a))') & locnam, tabsep, totobs, tabsep, allele_buffer%numal, tabsep, & chi2, tabsep, pstring(pval), tabsep, cstat, tabsep, histo else if (plevel > 0) then write(outstr,'(2(/a,f8.2,3a))') & 'MQLS statistic = ', stat1, ' (P = ', pstring(pval1), ')', & 'WQLS statistic = ', stat2, ' (P = ', pstring(pval2), ')' end if end subroutine domqls ! ! MQLS of Bourgain et al 2003, Thornton et al 2007 ! using empirical kinship matrix for entire sample ! subroutine big_mqls(typ, trait, gt, thresh, gene, locnam, prev, nulltyp, & dataset, allele_buffer, pval, plevel) use ped_class use alleles_class use locus_types use outstream use symmetric_matrix use rngs use statfuns use kinship_io integer, intent(in) :: typ integer, intent(in) :: trait integer, intent(in) :: gt double precision, intent(in) :: thresh integer, intent(in) :: gene character (len=*) :: locnam double precision, intent(in) :: prev integer, intent(in) :: nulltyp type (ped_data) :: dataset type (allele_data) :: allele_buffer double precision, intent(out) :: pval integer, intent(in) :: plevel integer, parameter :: MISS = -9999 integer :: aff, g, g1, g2, gen2, i, ia, ii, j, naff, nobs, num, ped, & pedoffset, tailp, totaff, totobs integer :: astat, nn character (len=3) :: allel character (len=4) :: cstat double precision :: afreq, a1, a2, a3, alt1, alt2, cfreq, chi2, corrz, & logdet, mfreq, topfreq, unaff, var, v, wmax, z, zmax double precision :: stat1, stat2, stat3, pval1, pval2, pval3 double precision :: afreq1, cfreq1 ! MQLS double precision, dimension(:), allocatable :: ymqls, yreg, ywork double precision :: ma2, mcs, mds1, mds2, v_mqls, vm, zm ! WQLS 1=null 2=WQLS 3=MQLS double precision, dimension(3, allele_buffer%numal) :: ns ! Pieces of robust variance for allele freq double precision, dimension(allele_buffer%numal) :: robvar double precision :: cs, ds1, ds2, nullvar, v_wqls, vf ! corrX2 integer, dimension(allele_buffer%numal) :: casall, totall double precision :: corfact, corvar, corzero, term1, term2, term3 logical, dimension(dataset%nobs) :: active logical, dimension(:), allocatable :: filter double precision, dimension(:), allocatable :: yval, xval, ones ! correlation matrices double precision, dimension(:), allocatable :: fulla double precision, dimension(:), allocatable :: a, ainv ! functions character (len=3) :: histo character (len=6) :: pstring double precision :: bonf, isaff interface subroutine thincov(nfull, nreduced, active, cov) integer, intent(in) :: nfull integer, intent(in) :: nreduced logical, dimension(:), intent(in) :: active double precision, dimension(:) :: cov end subroutine thincov subroutine predmat(nfull, yindicator, cov, xval, yp) integer, intent(in) :: nfull logical, dimension(:), intent(in) :: yindicator double precision, dimension(:), intent(in) :: cov double precision, dimension(:), intent(in) :: xval double precision, dimension(:), intent(out) :: yp end subroutine predmat end interface if (typ == 1) then cstat='MQLS' else if (typ == 2) then cstat='WQLS' end if naff=0 nobs=0 totaff=0 totobs=0 if (allele_buffer%numal > 1) then active=.false. dataset%untyped=.false. do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset totobs=totobs+num ii=pedoffset do i=1, num ii=ii+1 active(ii)=.true. aff=int(isaff(dataset%plocus(ii,trait), thresh, gt)) if (aff == 2) totaff = totaff + 1 if (observed(ii, gene, dataset) .and. dataset%imztwin(ii) == MISS) then nobs=nobs+1 dataset%untyped(ii)=.true. if (aff == 2) naff = naff + 1 end if end do end if end do end if if (naff == nobs .or. naff == 0) then pval=MISS if (plevel == -1 .or. plevel == 0) then write(outstr,'(a20,2(a1,i6),a1,f10.1,3(a1,a))') & locnam, tabsep, nobs, tabsep, allele_buffer%numal, tabsep, & 0.0d0, tabsep, '- ', tabsep, cstat, tabsep, ' ' else if (plevel > 0) then write(outstr,'(3a,i0,a)') & 'NOTE: Marker "', trim(locnam), '" is uninformative: ', naff, ' affecteds.' end if return end if if (plevel > 0) then write(outstr,'(/2a/)') 'MQLS results for: ', locnam end if allocate(yval(nobs), xval(nobs), ones(nobs), stat=astat) if (astat == 0) then allocate(ymqls(totobs), yreg(totobs), ywork(totobs), & filter(totobs), stat=astat) end if nn=totobs*(totobs+1)/2 if (astat == 0) then allocate(fulla(nn), a(nn), ainv(nn), stat=astat) end if if (astat /= 0) then write(outstr,'(a,i0,a)') & 'ERROR: Unable to allocate memory for ', nn, ' correlations.' return end if gen2=gene+1 mns=0.0D0 mds1=0.0D0 mds2=0.0D0 ns=0.0D0 ds1=0.0D0 ds2=0.0D0 cs=0.0d0 robvar=0.0d0 term1=0.0d0 term2=0.0d0 term3=0.0d0 unaff=0.0d0 if (prev /= MISS) then unaff=-prev/(1.0d0-prev) end if casall=0 totall=0 filter=.false. nobs=0 nunobs=-1 i=0 do ii=1, dataset%nobs if (active(ii)) then i=i+1 aff=int(isaff(dataset%plocus(ii,trait), thresh, gt)) if (dataset%untyped(ii)) then nobs=nobs+1 filter(i)=.true. ones(nobs)=1.0d0 yval(nobs)=0.0d0 ymqls(nobs)=0.0d0 if (aff == 2) then yval(nobs)=1.0d0 ymqls(nobs)=1.0d0 else if (aff == 1) then ymqls(nobs)=unaff end if else nunobs=nunobs+1 ymqls(totobs-nunobs)=0.0d0 if (aff == 2) then ymqls(totobs-nunobs)=1.0d0 else if (aff == 1) then ymqls(totobs-nunobs)=unaff end if end if end if end do call get_kinship(dataset%nobs, totobs, active, fulla) a=fulla call big_hash_kinship(totobs, filter) call thincov(totobs, nobs, filter, a) call kininv(a, nobs, ainv, logdet, i, plevel) ! corrected chi-square variance call quadmult(1, nobs, yval, a, term1) call quadxy(nobs, ones, a, yval, term2) call quadmult(1, nobs, ones, a, term3) ! terms for WQLS (1c' V~ 1c), (1c' V~ 1) call sumsym(nobs, ainv, a2) ds1=ds1+a2 call quadmult(2, nobs, yval, ainv, alt2) ds2=ds2+alt2 call quadmult(1, nobs, yval, ainv, v) cs=cs+v ! terms for MQLS w_test, (w_test' V w_test), (w_test' 1) call predmat(totobs, filter, fulla, ymqls, ywork) call postmult(nobs, ywork, ainv, yreg) do i=1, nobs yreg(i)=yreg(i)+ymqls(i) end do if (plevel > 2) then j=0 write(outstr,'(a12,1x,a12,2(1x,a7))') 'ped', 'id', 'ymqls', 'yreg' do ii=1, dataset%nobs if (dataset%untyped(ii)) then j=j+1 write(outstr,'(a12,1x,a12,2(1x,f7.5))') & dataset%pedigree(dataset%iped(ii)), dataset%id(ii), & ymqls(j), yreg(j) end if end do end if call quadmult(1, nobs, yreg, a, ma2) mds1=mds1+ma2 do i=1, nobs mds2=mds2+yreg(i) end do ! do ia=1, allele_buffer%numal nobs=0 do ii=1, dataset%nobs if (dataset%untyped(ii)) then nobs=nobs+1 call get_namedgeno(ii, gene, gen2, & dataset, allele_buffer, g1, g2) g=0 if (g1 == ia) g=g+1 if (g2 == ia) g=g+1 totall(ia)=totall(ia)+g xval(nobs)=0.5d0*dble(g) if (yval(nobs) == 1.0d0) casall(ia)=casall(ia)+g end if end do ! null, including terms for robust estimate of variance of allele freq call quadmult(2, nobs, xval, ainv, a1) ns(1,ia)=ns(1,ia)+a1 call quadmult(1, nobs, xval, ainv, vf) robvar(ia)=robvar(ia)+vf ! WQLS alternative call quadxy(nobs, yval, ainv, xval, alt1) ns(2,ia)=ns(2,ia)+alt1 ! MQLS alternative do j=1, nobs ns(3,ia)=ns(3,ia)+yreg(j)*xval(j) end do end do ! ! CorrX2 correction corzero=dble(nobs-naff)/dble(nobs*naff) corfact=term1/dble(naff*naff) - & 2*term2/dble(nobs*naff) + & term3/dble(nobs*nobs) v_mqls=(mds1/mds2/mds2-1.0d0/ds1) v_wqls=(cs/ds2/ds2-1.0d0/ds1) wmax=0.0d0 zmax=0.0d0 stat3=0.0d0 if (plevel > 0) then write(outstr,'(/a,i0/a,i0)') & 'Number of typed cases = ', naff, & 'Total number of cases = ', totaff write(outstr,'(/a,f7.4//a/a)') & 'Chi-square correction = ', corfact/corzero, & 'Allele Case Freq E(Freq) SD Z Value P-value', & '------- ---------- ------- ------- -------- -------' end if do i=1, allele_buffer%numal ! WQLS variance afreq=ns(1,i)/ds1 cfreq=ns(2,i)/ds2 if (nulltyp == 1) then nullvar=0.5d0*afreq*(1.0d0-afreq) else nullvar=(robvar(i)-ns(1,i)*ns(1,i)/ds1)/dble(max(1,nobs-1)) end if v=nullvar*v_wqls z=(cfreq-afreq)/sqrt(v) if (abs(z) > abs(wmax)) wmax=z ! MQLS variance mfreq=ns(3,i)/mds2 vm=nullvar*v_mqls zm=(mfreq-afreq)/sqrt(vm) if (abs(zm) > abs(zmax)) zmax=zm ! CorrX2 variance afreq1=0.5d0*dble(totall(i))/dble(nobs) cfreq1=0.5d0*dble(casall(i))/dble(naff) corvar=nullvar*corfact corrz=(cfreq1-afreq1)/sqrt(corvar) stat3=stat3+corrz*corrz if (plevel > 0) then call wrall(allele_buffer%allele_names(i), allel) write(outstr,'(1x,a3,2x,f9.4,2x,2(f8.4,2x),f8.2,2(2x,a))') & allel, mfreq, afreq, sqrt(vm), zm, pstring(chip(zm*zm,1)), 'MQLS' write(outstr,'(1x,a3,2x,f9.4,2x,2(f8.4,2x),f8.2,2(2x,a))') & allel, cfreq, afreq, sqrt(v), z, pstring(chip(z*z,1)), 'WQLS' write(outstr,'(1x,a3,3x,3(2x,f6.4,2x),f8.2, 2(2x,a))') & allel, cfreq1, afreq1, sqrt(corvar), corrz, & pstring(chip(corrz*corrz,1)), 'corrX2' end if end do stat1=zmax*zmax pval1=chip(stat1,1) * max(1,allele_buffer%numal-1) stat2=wmax*wmax pval2=chip(stat2,1) * max(1,allele_buffer%numal-1) if (allele_buffer%numal == 2) then stat3=0.5d0*stat3 end if pval3=chip(stat3, max(1,allele_buffer%numal-1)) if (typ == 1) then chi2=stat1 pval=pval1 else if (typ == 2) then chi2=stat2 pval=pval2 end if if (plevel == -1 .or. plevel == 0) then call phist(pval, 1.0d0, histo) write(outstr,'(a20,2(a1,i6),a1,f10.1,3(a1,a))') & locnam, tabsep, nobs, tabsep, allele_buffer%numal, tabsep, & chi2, tabsep, pstring(pval), tabsep, cstat, tabsep, histo else if (plevel > 0) then write(outstr,'(3(/a,f8.2,3a))') & 'MQLS statistic = ', stat1, ' (P = ', pstring(pval1), ')', & 'WQLS statistic = ', stat2, ' (P = ', pstring(pval2), ')', & 'Corrected chi-square = ', stat3, ' (P = ', pstring(pval3), ')' end if end subroutine big_mqls ! ! WQLS association chi-square ! extending Bourgain et al 2003 to categorical traits with more than 2 levels ! subroutine corchi(kintyp, trait, loctyp, gene, locnam, & hashtab, dataset, allele_buffer, iter, pval, plevel) use ped_class use alleles_class use idhash_class use locus_types use outstream use symmetric_matrix use contingency_table use rngs use statfuns use kinship_io integer, intent(in) :: kintyp integer, intent(in) :: trait integer, intent(in) :: loctyp integer, intent(in) :: gene character (len=*), intent(in) :: locnam type (ped_data) :: dataset type (hash_table) :: hashtab type (allele_data) :: allele_buffer integer, intent(in) :: iter double precision, intent(out) :: pval integer, intent(in) :: plevel integer, parameter :: MISS = -9999 integer :: astat, df, g, g1, g2, gpos, i, ii, ilev, j, k, & n, nn, nobs, num, nuntyp, & ped, pedoffset, pos, totobs character (len=3) :: allel character (len=10) :: cval double precision :: contrib, chi2, logdet logical, dimension(dataset%maxact) :: active ! phenotypes and genotypes integer :: ncats, traitcols double precision, dimension(:,:), allocatable :: genos, phenos ! correlation matrices double precision, dimension(:), allocatable :: a, ainv double precision, dimension(:), allocatable :: allcov, allinv ! scores and their covariances double precision, dimension(:,:), allocatable :: fam_uscore, uscore double precision :: fam_u11, u11 double precision, dimension(:), allocatable :: fam_u12, u12 double precision, dimension(:,:), allocatable :: fam_u22, u22 double precision, dimension(:), allocatable :: uvar, uinv ! ! Marginal trait tabulation ! type (table_data) :: traittable double precision, dimension(1) :: val integer :: traitlevels, traitterms ! functions character (len=3) :: histo character (len=6) :: pstring character (len=8) :: wrpercentd double precision :: bonf, isaff interface subroutine wrall(iall, allel) integer, intent(in) :: iall character (len=*), intent(out) :: allel end subroutine wrall subroutine kinship(ped, dataset, kin) use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(in) :: dataset double precision, dimension(:), intent(inout) :: kin end subroutine kinship subroutine thincov(nfull, nreduced, active, cov) integer, intent(in) :: nfull integer, intent(in) :: nreduced logical, dimension(:), intent(in) :: active double precision, dimension(:) :: cov end subroutine thincov subroutine loadphenos(trait, loctyp, gene, offset, num, & allele_buffer, dataset, & ncats, traitcols, traittable, & phenos, genos) use ped_class use alleles_class use locus_types use contingency_table integer, intent(in) :: trait, gene, loctyp integer, intent(in) :: num, offset type (allele_data) :: allele_buffer type (ped_data) :: dataset ! phenotypes and genotypes integer :: ncats, traitcols type (table_data) :: traittable double precision, dimension(:,:), intent(inout) :: genos, phenos end subroutine loadphenos subroutine corchi_one(nobs, ncats, traitcols, & phenos, genos, ainv, u11, uscore, u12, u22) use symmetric_matrix integer, intent(in) :: nobs ! phenotypes and genotypes integer, intent(in) :: ncats, traitcols double precision, dimension(:,:), intent(in) :: genos, phenos double precision, dimension(:), intent(in) :: ainv ! scores and their covariances double precision, intent(out) :: u11 double precision, dimension(:,:), intent(out) :: uscore double precision, dimension(:), intent(out) :: u12 double precision, dimension(:,:), intent(out) :: u22 end subroutine corchi_one end interface if (plevel > 0) then write(outstr,'(/2a/)') 'WQLS chi-square results for: ', locnam end if pval=1.0d0 traitcols=1 ncats=allele_buffer%numal-1 ! ! tabulation of trait categories ! nmiss=0 nuntyp=0 totobs=0 call setup_table(1, 30, traittable) dataset%untyped=.false. do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do ii=pedoffset+1, dataset%num(ped) if (dataset%plocus(ii,trait) /= MISS) then if (observed(ii, gene, dataset)) then totobs=totobs+1 dataset%untyped(ii)=.true. if (loctyp /= LOC_QUA) then val(1)=dataset%plocus(ii,trait) call insert_table(1, val, traittable, 1) end if else nuntyp=nuntyp+1 end if else nmiss=nmiss+1 end if end do end if end do if (loctyp /= LOC_QUA) traitcols=traittable%ncells-1 ! if (allele_buffer%typed == 0 .or. ncats == 0 .or. & traitcols <= 0) then if (plevel == -1 .or. plevel == 0) then call phist(pval, 1.0d0, histo) write(outstr,'(a20,2(a1,i6),a1,f10.1,3(a1,a))') & locnam, tabsep, totobs, tabsep, ncats+1, tabsep, & 0.0d0, tabsep, '1.0000', tabsep, 'WQLS', tabsep, ' ' else if (plevel > 0) then if (allele_buffer%typed == 0 .or. ncats == 0) then write(outstr,'(3a)') & 'NOTE: Marker "', trim(locnam), '" is uninformative.' else write(outstr,'(3a)') & 'NOTE: Trait is uninformative for marker "', trim(locnam), '".' end if end if return end if ! ! multinomial covariance matrix for alleles ! nn=ncats*(ncats+1)/2 allocate(allcov(nn), allinv(nn), stat=astat) if (astat /= 0) then write(outstr,'(a,i0,a)') & 'ERROR: Unable to allocate memory for ', nn, ' allele correlations.' return end if pos=0 do j=1, ncats do k=1, j-1 pos=pos+1 allcov(pos)=-0.5d0*allele_buffer%allele_freqs(j)*allele_buffer%allele_freqs(k) end do pos=pos+1 allcov(pos)=0.5d0*allele_buffer%allele_freqs(j)*(1.0d0-allele_buffer%allele_freqs(j)) end do call syminv(allcov, ncats, allinv, logdet, i) ! ! score statistic calculations ! nn=traitcols*(traitcols+1)/2 allocate(fam_u12(traitcols), u12(traitcols)) allocate(fam_uscore(traitcols,ncats), uscore(traitcols,ncats)) allocate(fam_u22(traitcols,traitcols), u22(traitcols,traitcols)) allocate(uvar(nn), uinv(nn)) u11=0.0d0 u12=0.0d0 u22=0.0d0 uscore=0.0d0 uvar=0.0d0 ! ! Y, X, kinship matrices ! if (kintyp == 1) then n=dataset%maxact else if (kintyp == 2) then n=totobs end if nn=n*(n+1)/2 allocate(genos(n, ncats)) allocate(phenos(n, traitcols)) allocate(a(nn), ainv(nn), stat=astat) if (astat /= 0) then write(outstr,'(a,i0,a)') & 'ERROR: Unable to allocate memory for ', nn, ' correlations.' return end if if (kintyp == 1) then do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset nobs=0 ii=pedoffset do i=1, num ii=ii+1 active(i)=.false. if (dataset%untyped(ii)) then nobs=nobs+1 active(i)=.true. end if end do ! calculate contribution from this pedigree if (nobs > 0) then call kinship(ped, dataset, a) call thincov(num, nobs, active, a) call big_hash_kinship(num, active) call kininv(a, nobs, ainv, logdet, i, plevel) call loadphenos(trait, loctyp, gene, pedoffset, num, & allele_buffer, dataset, & ncats, traitcols, traittable, & phenos, genos) call corchi_one(nobs, ncats, traitcols, & phenos, genos, ainv, & fam_u11, fam_uscore, fam_u12, fam_u22) u11=u11+fam_u11 uscore=uscore+fam_uscore u12=u12+fam_u12 u22=u22+fam_u22 end if end if end do else call get_kinship(dataset%nobs, totobs, dataset%untyped, a) call kininv(a, totobs, ainv, logdet, i, plevel) call loadphenos(trait, loctyp, gene, 0, dataset%nobs, & allele_buffer, dataset, & ncats, traitcols, traittable, & phenos, genos) call corchi_one(totobs, ncats, traitcols, & phenos, genos, ainv, & u11, uscore, u12, u22) end if ! I2.1 = u22 - u12' u11~ u12 pos=0 do j=1, traitcols do k=1, j pos=pos+1 uvar(pos)=u22(j,k)-u12(j)*u12(k)/u11 end do end do call syminv(uvar, traitcols, uinv, logdet, i) chi2=0.0d0 gpos=0 do g1=1, ncats do g2=1, g1 gpos=gpos+1 call quadxy(traitcols, uscore(:,g1), uinv, uscore(:,g2), contrib) if (g1 /= g2) contrib=2*contrib chi2=chi2+allinv(gpos)*contrib end do end do df=traitcols*ncats pval=chip(chi2, df) if (plevel > 0) then write(outstr,'(/a/a)') & 'Allele Trait Score X2 Covariances', & '------ ----- -------- -------- --------------' gpos=0 do g=1, ncats call wrall(allele_buffer%allele_names(g), allel) gpos=gpos+g pos=0 do j=1, traitcols call quadxy(traitcols, uscore(:,g), uinv, uscore(:,g), contrib) write(outstr,'(a6,1x,i5,3x,f10.4,1x,f8.4,10(1x,f7.3))') & allel, j, uscore(j,g), allinv(gpos)*contrib, & allinv(gpos)*uinv((pos+1):(pos+j)) pos=pos+j end do end do write(outstr,'(2(/a,i7)/a,f9.2/a,i6/a,5x,a)') & ' No. trait(+) marker(+) =', totobs, & ' No. trait(+) marker(-) =', nuntyp, & ' Corrected Chi-square = ', chi2, & ' Degrees of freedom = ', df, & ' Nominal P-value = ', trim(pstring(pval)) else if (plevel == -1 .or. plevel == 0) then call phist(pval, 1.0d0, histo) write(outstr,'(a20,2(a1,i6),a1,f10.1,3(a1,a))') & locnam, tabsep, totobs, tabsep, allele_buffer%numal, tabsep, & chi2, tabsep, pstring(pval), tabsep, 'WQLS', tabsep, histo end if end subroutine corchi ! ! Set up phenotype and genotype matrices ! subroutine loadphenos(trait, loctyp, gene, offset, num, & allele_buffer, dataset, & ncats, traitcols, traittable, & phenos, genos) use ped_class use alleles_class use locus_types use contingency_table integer, intent(in) :: trait, gene, loctyp integer, intent(in) :: num, offset type (allele_data) :: allele_buffer type (ped_data) :: dataset ! phenotypes and genotypes integer :: ncats, traitcols type (table_data) :: traittable double precision, dimension(:,:), intent(inout) :: genos, phenos integer :: g1, g2, gen2, i, ii, nobs, pos gen2=gene+1 nobs=0 phenos=0.0d0 genos=0.0d0 ii=offset do i=1, num ii=ii+1 if (dataset%untyped(ii)) then nobs=nobs+1 if (loctyp == LOC_QUA) then phenos(nobs,1)=dataset%plocus(ii,trait) else pos=findlev(dataset%plocus(ii,trait), traittable) if (pos <= traitcols) then phenos(nobs,pos)=1.0d0 end if end if call get_namedgeno(ii, gene, gen2, & dataset, allele_buffer, g1, g2) if (g1 <= ncats) then genos(nobs,g1)=genos(nobs,g1)+0.5d0 end if if (g2 <= ncats) then genos(nobs,g2)=genos(nobs,g2)+0.5d0 end if end if end do do i=1, nobs do j=1, ncats genos(i,j)=genos(i,j)-allele_buffer%allele_freqs(j) end do end do end subroutine loadphenos ! ! S = u2' I21~ u2 ! I21 = U22-(U21' U11~ U21) ! subroutine corchi_one(nobs, ncats, traitcols, & phenos, genos, ainv, u11, uscore, u12, u22) use symmetric_matrix integer, intent(in) :: nobs ! phenotypes and genotypes integer, intent(in) :: ncats, traitcols double precision, dimension(:,:), intent(in) :: genos, phenos double precision, dimension(:), intent(in) :: ainv ! scores and their covariances double precision, intent(out) :: u11 double precision, dimension(:,:), intent(out) :: uscore double precision, dimension(:), intent(out) :: u12 double precision, dimension(:,:), intent(out) :: u22 ! u11 = ones Ainv ones call sumsym(nobs, ainv, u11) ! write(*,*) 'u11 calculated: ', u11 ! u2 = phenos' Ainv genos call quadxym(nobs, traitcols, ncats, phenos, ainv, genos, uscore) ! write(*,*) 'u2 calculated: ', uscore ! u12 = 1' Ainv phenos call quadxy1(nobs, traitcols, ainv, phenos, u12) ! write(*,*) 'u12 calculated: ', u12 ! u22 = phenos' Ainv phenos call quadxym(nobs, traitcols, traitcols, phenos, ainv, phenos, u22) ! write(*,*) 'u22 calculated: ', u22 end subroutine corchi_one ! ! Count alleles in entire sample -- codominant system ! Either unweighted or weighted by number of founders in pedigree ! ! If imputation has been done and fndr=2, then return the ! count of alleles in the founders, both observed and imputed ! subroutine freq(gene, loctyp, fndr, dataset, allele_buffer) use ped_class use alleles_class use locus_types integer, intent(in) :: gene integer, intent(in) :: loctyp integer, intent(in) :: fndr type (ped_data), intent(in) :: dataset type (allele_data), intent(inout) :: allele_buffer integer, parameter :: KNOWN=0, MISS=-9999 integer :: tfound, typed, untyped integer :: act, den, g1, g2, gen2, i, nfall, ped, totall integer :: ind1, indn, pos logical, dimension(dataset%maxsiz) :: xmale double precision :: minfreq, topfreq, w, wei act=fndr gen2=gene+1 ! ! global restart if unimputed genotypes present and fndr=2 ! 999 continue allele_buffer%numal=0 allele_buffer%xlinkd=same_loctyp(loctyp, LOC_XLIN) allele_buffer%issnp=(iscompressed(loctyp) .and. dataset%hassnps == 2) if (.not.allocated(allele_buffer%allele_names)) then i=50 if (iscompressed(loctyp)) i=2 allocate(allele_buffer%allele_names(i)) allocate(allele_buffer%allele_freqs(i)) allocate(allele_buffer%cum_freqs(i)) end if nfall=0 tfound=0 totall=0 typed=0 untyped=0 indn=0 do ped=1, dataset%nped ind1=1+dataset%num(ped-1) indn=dataset%num(ped) pos=0 ! Count observed alleles and skip if none if (dataset%actset(ped) > 0) then den=0 do i=ind1, indn pos=pos+1 if (observed(i, gene, dataset)) then typed=typed+1 den=den+1 else untyped=untyped+1 end if xmale(pos)=same_loctyp(loctyp, LOC_HAP) .or. & (same_loctyp(loctyp, LOC_XLIN) .and. dataset%sex(i) == 1) if (.not.xmale(pos) .and. observed(i, gene, dataset)) then den=den+1 end if end do if (den == 0) cycle ! ! If fndr=2 only count alleles in founders ! If fndr=1 weight count in this pedigree by number of founders ! A compromise weighting to allow for putative male X heterozygotes: contribute ! 1/2 an allele for each ! tfound=tfound+dataset%nfound(ped) totall=totall+den wei=1.0d0 if (act == 1) wei=dble(dataset%nfound(ped))/dble(den) if (act < 2) then pos=0 do i=ind1, indn pos=pos+1 if (observed(i, gene, dataset)) then w=wei if (xmale(pos)) w=0.5d0*wei call get_geno(i, gene, gen2, dataset, g1, g2) call tab(g1, allele_buffer, w) call tab(g2, allele_buffer, w) end if end do else ! count imputed founder alleles (bail out if unimputed!) pos=0 do i=ind1, ind1+dataset%nfound(ped)-1 pos=pos+1 call get_geno(i, gene, gen2, dataset, g1, g2) if (g1 /= MISS) then if (g1 /= KNOWN) then nfall=nfall+1 call tab(abs(g1),allele_buffer,wei) end if else act=0 go to 999 end if if (.not.xmale(pos) .and. g2 /= MISS) then if (g2 /= KNOWN) then nfall=nfall+1 call tab(abs(g2),allele_buffer,wei) end if else act=0 go to 999 end if end do end if end if end do if (act == 0) then wei=1.0d0/dble(max(1,totall)) else if (act == 1) then wei=1.0d0/dble(tfound) else if (act == 2) then wei=1.0d0/dble(nfall) end if allele_buffer%numgtp=allele_buffer%numal*(allele_buffer%numal+1)/2 allele_buffer%typed=typed allele_buffer%untyped=untyped allele_buffer%totall=totall if (allele_buffer%numal > 0) then minfreq=1.0d0 topfreq=0.0d0 do i=1, allele_buffer%numal allele_buffer%allele_freqs(i)=wei * allele_buffer%allele_freqs(i) if (allele_buffer%allele_freqs(i) > topfreq) then topfreq=allele_buffer%allele_freqs(i) allele_buffer%topall=i end if if (allele_buffer%allele_freqs(i) < minfreq) then minfreq=allele_buffer%allele_freqs(i) allele_buffer%minall=i end if end do allele_buffer%cum_freqs(1)=allele_buffer%allele_freqs(1) allele_buffer%cum_freqs(allele_buffer%numal)=1.0d0 do i=2, allele_buffer%numal-1 allele_buffer%cum_freqs(i)= allele_buffer%cum_freqs(i-1) + & allele_buffer%allele_freqs(i) end do end if end subroutine freq ! ! update table of counts of alleles -- binary search and insertion sort ! if allele_buffer too small, increase size ! subroutine tab(curr, allele_buffer, wei) use alleles_class integer, intent(in) :: curr type (allele_data), intent(inout) :: allele_buffer double precision, intent(in) :: wei integer :: hi, i, lo, pos hi=allele_buffer%numal lo=1 do while (hi >= lo) pos=lo+(hi-lo)/2 if (curr > allele_buffer%allele_names(pos)) then lo=pos+1 else if (curr < allele_buffer%allele_names(pos)) then hi=pos-1 else allele_buffer%allele_freqs(pos)=allele_buffer%allele_freqs(pos)+wei return end if end do ! ! else make room if needed, and insert new allele ! if (allele_buffer%numal >= size(allele_buffer%allele_names)) then call expand_alleles(allele_buffer, 10) end if do i=allele_buffer%numal,lo,-1 allele_buffer%allele_names(i+1)=allele_buffer%allele_names(i) allele_buffer%allele_freqs(i+1)=allele_buffer%allele_freqs(i) end do allele_buffer%numal=allele_buffer%numal+1 allele_buffer%allele_names(lo)=curr allele_buffer%allele_freqs(lo)=wei end subroutine tab ! ! Write out frequencies in 19 different styles ! subroutine wrfreq(strm, locnam, group, mappos, locnote, allele_buffer, fstyle) use outstream use alleles_class implicit none integer, intent(in) :: strm character (len=20), intent(in) :: locnam type (allele_data), intent(inout) :: allele_buffer character (len=*), intent(in) :: group double precision, intent(in) :: mappos character (len=*), intent(in) :: locnote integer, intent(in) :: fstyle ! local variables integer :: ichr, i, j, nlines, nobs, pos character (len=2) :: chr character (len=4) :: allel, allel2 character (len=6) :: afreq character (len=8) :: mentyp double precision :: corr, het, morganpos interface subroutine wrall(iall, allel) integer, intent(in) :: iall character (len=*), intent(out) :: allel end subroutine wrall end interface ! functions character (len=6) :: pstring integer :: tobp double precision :: thetaf, uninf chr='1' nobs=allele_buffer%typed + allele_buffer%untyped corr=1.0d0 het=0.0d0 if (allele_buffer%issnp) then call get_snpallele2(locnote, allele_buffer) end if if (fstyle == 1 .or. fstyle == 11 .or. fstyle == 21) then write(outstr,'(/a)') & '------------------------------------------------' if (fstyle == 1) then write(outstr,'(a)', advance='no') 'Allele' else allel='MCEM' if (fstyle == 21) allel='BLUE' write(outstr,'(2a)', advance='no') allel, ' allele' end if write(outstr,'(3a/a)') & ' frequencies for locus "',trim(locnam),'"', & '------------------------------------------------' write(outstr,'(a)') ' Allele Frequency Count Histogram' if (allele_buffer%numal == 0) then write(outstr,'(/6x,a)') 'No nonmissing genotypes' else do i=1, allele_buffer%numal call wrall(allele_buffer%allele_names(i), allel) afreq=pstring(allele_buffer%allele_freqs(i)) write(outstr,'(4x,a4,5x,a6,i9,2x,20a1:)') & allel, afreq, & nint(float(allele_buffer%totall)*allele_buffer%allele_freqs(i)), & ('*',j=1,max(1,nint(20.0D0*allele_buffer%allele_freqs(i)))) het=het+allele_buffer%allele_freqs(i)*allele_buffer%allele_freqs(i) end do if (allele_buffer%totall > 1) then corr=dble(allele_buffer%totall)/dble(allele_buffer%totall-1) end if het=1.0D0-het write(outstr,'(/a,i4,2(/a,3x,f6.4))') & 'Number of alleles = ', allele_buffer%numal, & 'Heterozygosity (Hu) = ',corr*het, & 'Poly. Inf. Content = ',het-uninf(allele_buffer%numal, allele_buffer%allele_freqs) if (fstyle == 1 .or. fstyle == 21) then write(outstr,'(a,f13.8/a,i6,1x,a,f5.1,a)') & '4 Neff mu (SSMM) = ',thetaf(het, allele_buffer%typed), & 'Number persons typed = ',allele_buffer%typed, & '(',float(100*allele_buffer%typed)/float(nobs),'%)' else write(outstr,'(a,f13.8/a,i6,1x,a,f5.1,a)') & '4 Neff mu (SSMM) = ',thetaf(het, allele_buffer%totall/2), & 'Number of founders = ',allele_buffer%totall/2, & '(',float(50*allele_buffer%typed)/float(allele_buffer%totall),'% typed)' end if end if ! abbreviated output else if (fstyle == 2) then do i=1,allele_buffer%numal het=het+allele_buffer%allele_freqs(i)*allele_buffer%allele_freqs(i) end do het=1.0D0-het if (allele_buffer%totall > 1) then corr=dble(allele_buffer%totall)/dble(allele_buffer%totall-1) end if ! SNPs if (allele_buffer%numal == 2) then do i=1, allele_buffer%numal if (allele_buffer%allele_freqs(i) <= 0.5) then call wrall(allele_buffer%allele_names(i), allel) call wrall(allele_buffer%allele_names(3-i), allel2) mentyp=' (' // trim(adjustl(allel2)) // ')' write(outstr,'(a20,a1,i4,a1,1x,a4,a8,2(a1,f6.4),a1,i6,a1,a)') & locnam, tabsep, 2, tabsep, allel, mentyp, & tabsep, allele_buffer%allele_freqs(i), & tabsep, corr*het, tabsep, allele_buffer%typed, tabsep, trim(locnote) exit end if end do ! other else if (allele_buffer%typed == 0) then write(outstr,'(a20,a1,3x,a1,a1,1x,a1,13x,a1,a1,5x,a1,a1,5x,a1,3x,a1,a1,a)') & locnam, tabsep, '-', tabsep, '-', tabsep, '-', tabsep, '-', & tabsep, '0', tabsep, trim(locnote) else if (allele_buffer%numal == 1) then call wrall(allele_buffer%allele_names(1), allel) write(outstr,'(a20,a1,i4,a1,1x,a4,8x,2(a1,a6),a1,i6,a1,a)') & locnam, tabsep, 1, tabsep, allel, tabsep, '1.0000', tabsep, & ' - ', tabsep, allele_buffer%typed, tabsep, trim(locnote) else call wrall(allele_buffer%allele_names(1), allel) call wrall(allele_buffer%allele_names(allele_buffer%numal), allel2) write(outstr,'(a20,a1,i4,a1,1x,a4,a2,a4,2x,a1,a6,a1,f6.4,a1,i6,a1,a)') & locnam, tabsep, allele_buffer%numal, tabsep, allel, '..', allel2, tabsep, & ' - ', tabsep, corr*het, tabsep, allele_buffer%typed, tabsep, trim(locnote) end if ! scratch file else if (fstyle == 3) then write(strm) allele_buffer%numal, & allele_buffer%allele_names(1:allele_buffer%numal), & allele_buffer%allele_freqs(1:allele_buffer%numal) ! GAS locus file else if (fstyle == 4) then CALL precis(allele_buffer%numal,allele_buffer%allele_freqs,4) write(strm,'(1x,i3,100(1x,f6.4):)') & allele_buffer%numal, allele_buffer%allele_freqs(1:allele_buffer%numal) write(strm,'(1x,a,100(1x,i3):)') & 'name ', allele_buffer%allele_names(1:allele_buffer%numal) ! SAGE locus file else if (fstyle == 5) then call precis(allele_buffer%numal,allele_buffer%allele_freqs,4) write(strm,'(a20)') locnam do i=1,allele_buffer%numal write(strm,'(1x,i4.4,a,f6.4)') & allele_buffer%allele_names(i),' = ',allele_buffer%allele_freqs(i) end do write(strm,'(1x,a1)') ';' do i=1, allele_buffer%numal do j=i, allele_buffer%numal write(strm,'(1x,4(i4.4,a))') & allele_buffer%allele_names(i),'/',allele_buffer%allele_names(j), & ' = {',allele_buffer%allele_names(i),'/',allele_buffer%allele_names(j),'}' end do end do write(strm,'(1x,a1)') ';' ! MENDEL 6.0-7.0 locus file -- used by Simwalk2 too else if (fstyle == 7 .or. fstyle == 10) then mentyp='AUTOSOME' if (fstyle == 10) mentyp='X-LINKED' call precis(allele_buffer%numal,allele_buffer%allele_freqs,6) write(strm,'(2a8,2i2,2x,a2,1x,f8.3)') & locnam, mentyp, allele_buffer%numal, 0, chr, max(0.0,0.01*mappos) do i=1, allele_buffer%numal call wrall(allele_buffer%allele_names(i), allel) write(strm,'(4x,a4,f8.6)') allel, allele_buffer%allele_freqs(i) end do ! MENDEL 8.0 locus file: free formatted else if (fstyle == 16 .or. fstyle == 19) then mentyp='AUTOSOME' if (fstyle == 19) mentyp='X-LINKED' call precis(allele_buffer%numal,allele_buffer%allele_freqs,6) write(strm,*) & locnam, mentyp, allele_buffer%numal do i=1, allele_buffer%numal call wrall(allele_buffer%allele_names(i), allel) write(strm,'(a,1x,f8.6)') allel, allele_buffer%allele_freqs(i) end do ! Linkage locus file else if (fstyle == 8) then if (allele_buffer%numal == 0) then write(strm,'(3a/a)') '3 2 # ',trim(locnam), ' #', ' 0.5 0.5' else call precis(allele_buffer%numal,allele_buffer%allele_freqs,4) write(strm,'(i1,1x,i5,3a)') 3,allele_buffer%numal,' # ', trim(locnam), ' #' write(strm,'(100(1x,f6.4):)') allele_buffer%allele_freqs(1:allele_buffer%numal) end if ! pap popln.dat file else if (fstyle == 9) then nlines=(allele_buffer%numal+4)/5 write(strm,'(i4,2a)') nlines,' F F # ',locnam write(strm,'(i3,5(d15.7))') allele_buffer%numal, & allele_buffer%allele_freqs(1:allele_buffer%numal) ! new style RELPAIR locus file else if (fstyle == 12 .or. fstyle == 13) then morganpos=0.01d0*mappos if (group == ' ' .and. morganpos > 50) then ichr=int(morganpos)/10 write(chr,'(i2)') ichr morganpos=morganpos-10.0d0*dble(ichr) else if (group == ' ') then call getchr(locnam, locnote, chr) if (chr == ' ') chr='1' else chr=group end if mentyp='AUTOSOME' if (fstyle == 13) then mentyp='X-LINKED' chr='23' end if call precis(allele_buffer%numal,allele_buffer%allele_freqs,6) write(strm,'(a,1x,a,1x,i3,2x,a2,1x,f8.3)') & locnam(1:max(8,len_trim(locnam))), mentyp, allele_buffer%numal, & chr, max(0.0, morganpos) do i=1, allele_buffer%numal call wrall(allele_buffer%allele_names(i), allel) write(strm,'(a8,1x,f8.6)') allel, allele_buffer%allele_freqs(i) end do ! ECLIPSE locus file else if (fstyle == 14) then morganpos=0.01d0*mappos if (morganpos > 50) then ichr=int(morganpos)/10 write(chr,'(i2)') ichr morganpos=morganpos-10.0d0*dble(ichr) else call getchr(locnam, locnote, chr) if (chr == ' ') chr='1' end if call precis(allele_buffer%numal,allele_buffer%allele_freqs,6) write(strm,'(a3,1x,f8.3,1x,i3,100(1x,i5,1x,f6.4):)') & chr, mappos, allele_buffer%numal, & (j, allele_buffer%allele_freqs(j), j=1, allele_buffer%numal) ! Beagle marker file else if (fstyle == 20) then pos=0 if (mappos > 0.0d0) pos=tobp(mappos) write(strm,'(a,1x,i0)', advance='no') locnam, pos do i=1, allele_buffer%numal call wrall(allele_buffer%allele_names(i), allel) write(strm,'(1x,a)',advance='no') allel end do write(strm,*) ! brief summary for notes else if (fstyle == 15) then pos=8 write(strm, '(a)', advance='no') ' ' do i=1, allele_buffer%numal if (pos>80) then pos=8 write(strm, '(/a)', advance='no') ' ' end if call wrall(allele_buffer%allele_names(i), allel) afreq=pstring(allele_buffer%allele_freqs(i)) write(strm, '(1x,3a)', advance='no') & trim(adjustl(allel)),'=', afreq pos=len_trim(allel)+8 end do write(strm,*) ! inline, starting at major allele else if (fstyle == 22) then i=allele_buffer%topall do call wrall(allele_buffer%allele_names(i), allel) afreq=pstring(allele_buffer%allele_freqs(i)) write(strm, '(1x,3a)', advance='no') & trim(adjustl(allel)),'=', afreq i=i+1 if (i > allele_buffer%numal) i=1 if (i == allele_buffer%topall) exit end do end if end subroutine wrfreq ! ! Get set of reference alleles from an annotation of form [x/y] where x,y ~ {ACGT} ! y may be comma-delimited set of alternates - only return first ! subroutine get_refalleles(locnote, all1, all2) implicit none character (len=*), intent(in) :: locnote character (len=*), intent(out) :: all1, all2 integer :: comma, left, longall, right, sep all1=' ' all2=' ' longall=48 left=index(locnote, '[') if (left > 0) then sep=index(locnote, '/') right=index(locnote, ']') if (sep > left .and. sep < right) then all1=adjustl(locnote((left+1):(sep-1))) all2=adjustl(locnote((sep+1):(right-1))) if ((sep-left) > 2) then longall=longall+1 all1=achar(longall) end if if ((right-sep) > 2) then comma=index(locnote((sep+1):(right-1)), ',') if (comma /= 2) then longall=longall+1 all2=achar(longall) end if end if end if end if end subroutine get_refalleles ! ! Set reference alleles as an annotation of form [x/y] where x,y ~ {ACGT} ! subroutine set_refalleles(all1, all2, locnote) implicit none character (len=*), intent(in) :: all1, all2 character (len=*), intent(inout) :: locnote integer :: pos if (all1 == ' ' .or. all2 == ' ') return pos=index(locnote, '[') if (locnote((pos+2):(pos+2)) == '/' .and. & locnote((pos+4):(pos+4)) == ']') then locnote((pos+1):(pos+1))=all1 locnote((pos+3):(pos+3))=all2 else locnote='[' // trim(all1) // '/' // trim(all2) // '] ' // & trim(adjustl(locnote)) end if end subroutine set_refalleles ! ! Get chromosome number from a locus name of form "DnnSn" ^[Dd][0-9]+[Ss]$ ! or an annotation of form "chr NN" \<[Cc][Hh][Rr][ :]*[0-9]+\> ! subroutine getchr(locnam, locnote, chr) implicit none character (len=*), intent(in) :: locnam character (len=*), intent(in) :: locnote character (len=*), intent(in out) :: chr integer :: eos, ich, pos, targt logical :: bound, inword, start character (len=1) :: ch character (len=len(chr)) :: oldchr character (len=10), parameter :: chrom='chromosome' oldchr=chr chr=' ' eos=len_trim(locnote) pos=1 targt=1 bound=.true. inword=.false. do while (pos <= eos) start=.false. ch=locnote(pos:pos) ich=ichar(ch) if (ich > 64 .and. ich < 91) ch=char(ich+32) if (ch == chrom(targt:targt)) then if (targt == 1 .and. bound) then inword=.true. else if (targt == 10) then pos=pos+1 targt=0 start=.true. end if targt=targt+1 else if (targt > 3 .and. inword) start=.true. targt=1 inword=.false. end if if (start) then do while (pos <= eos) ch=locnote(pos:pos) if (ch /= ' ' .and. ch /= ':') exit pos=pos+1 end do call thischr(locnote, eos, pos, chr) end if bound=(ch == ' ' .or. ch == '(') pos=pos+1 end do if (chr == ' ' .and. (locnam(1:1) == 'D' .or. locnam(1:1) == 'd')) then pos=2 eos=len_trim(locnam) call thischr(locnam, eos, pos, chr) end if if (chr == ' ' .and. oldchr /= ' ') chr=oldchr end subroutine getchr ! ! Read a chromosome number from a string after the start position [1-9]|[1-4][0-9]|X|Y ! subroutine thischr(string, eos, pos, chr) implicit none character (len=*) :: string integer, intent(in) :: eos integer, intent(inout) :: pos character (len=*), intent(inout) :: chr integer :: fin, ich character (len=len(chr)) :: oldchr oldchr=chr chr=' ' if (string(pos:pos) == 'x' .or. string(pos:pos) == 'X') then chr='X' else if (string(pos:pos) == 'y' .or. string(pos:pos) == 'Y') then chr='Y' else fin=pos do while (fin <= eos) ich=ichar(string(fin:fin)) if (ich<48 .or. ich>57) exit fin=fin+1 end do fin=fin-1 if ((fin-pos) < 2) then chr=string(pos:fin) end if end if if (chr == ' ') then chr=oldchr end if end subroutine thischr ! ! Convert the chromosome number to an integer ! function chrnum(chr) implicit none integer :: chrnum character (len=2) :: chr chrnum=0 if (chr == ' ' .or. chr == '.' .or. chr == 'NA') then continue else if (chr == 'X') then chrnum=123 else if (chr == 'Y') then chrnum=124 else if (chr == 'XY') then chrnum=125 else if (chr == 'M' .or. chr == 'MT' .or. chr == 'Mt') then chrnum=126 else if (verify(trim(chr),'0123456789') == 0) then read(chr, '(i20)', err=99) chrnum else chrnum=transfer(chr, chrnum) end if 99 continue return end function chrnum ! ! remove rounding errors in allele frequencies printed out to precision ndec ! from f3.1 to f9.7 ! subroutine precis(numal, allele_freqs, ndec) integer, intent(in) :: numal double precision, dimension(numal), intent(inout) :: allele_freqs integer, intent(in) :: ndec ! ! topall is most common allele, and the one where we add our correction integer :: i, topall character (len=1) :: ch character (len=6) :: fdec character (len=10) :: buff double precision :: rounded, topfreq, tot ! ! set print format fdec='(f0.0)' write(ch,'(i1)') ndec+2 fdec(3:3)=ch write(ch,'(i1)') ndec fdec(5:5)=ch ! rewrite to given precision, and calculate accumulated error topall=1 topfreq=0.0D0 tot=0.0D0 do i=1,numal write(buff,fdec) allele_freqs(i) read(buff,fdec) rounded allele_freqs(i)=rounded if (rounded > topfreq) then topfreq=rounded topall=i end if tot=tot+rounded end do allele_freqs(topall)=allele_freqs(topall)+1.0D0-tot end subroutine precis ! ! Frequency of uninformative matings for marker locus ! function uninf(numal, allele_freqs) double precision :: uninf integer, intent(in) :: numal double precision, intent(in) :: allele_freqs(numal) integer :: i, j uninf=0.0D0 do i=1, numal-1 do j=i+1, numal uninf=uninf+2.0D0*allele_freqs(i)*allele_freqs(j)*allele_freqs(i)*allele_freqs(j) end do end do end function uninf ! ! find allele frequency ! function getfreq(allele, allele_set) use alleles_class double precision getfreq integer :: allele type (allele_data), intent(in) :: allele_set integer :: i, iall character (len=3) :: sall iall=abs(allele) call match(iall, allele_set%numal, allele_set%allele_names, i) if (i /= 0) then getfreq=allele_set%allele_freqs(i) else call wrall(iall, sall) write(*,'(a/3a)') 'Error in routine getfreq','Looking for "', trim(adjustl(sall)),'" in:' do i=1, allele_set%numal call wrall(allele_set%allele_names(i), sall) write(*,'(a,1x,f6.4)') sall, allele_set%allele_freqs(i) end do getfreq=0.0D0 end if end function getfreq ! ! find index for allele ! function getnam(rall, allele_set) use alleles_class integer getnam integer, intent(in) :: rall type (allele_data), intent(in) :: allele_set integer, parameter :: MISS=-9999 integer :: i,iall character (len=3) :: sall getnam=MISS if (rall == MISS) return iall=abs(rall) call match(iall, allele_set%numal, allele_set%allele_names, i) if (i /= 0) then getnam=i else if (rall < 0) then getnam=allele_set%topall else call wrall(iall, sall) write(*,'(a/3a)') 'In routine getnam', 'Looked for "', trim(adjustl(sall)), '" in:' do i=1, allele_set%numal call wrall(allele_set%allele_names(i), sall) write(*,'(a,1x,f6.4)') sall, allele_set%allele_freqs(i) end do end if end function getnam ! ! find indices for i'th individual's genotype ! subroutine get_namedgeno(idx, gene, gen2, dataset, allele_set, g1, g2) use ped_class use alleles_class integer, intent(in) :: idx integer, intent(in) :: gene, gen2 type (ped_data), intent(in) :: dataset type (allele_data), intent(in) :: allele_set integer, intent(out) :: g1, g2 integer :: a1, a2 ! functions integer getnam call get_geno(idx, gene, gen2, dataset, a1, a2) g1=getnam(a1, allele_set) g2=getnam(a2, allele_set) end subroutine get_namedgeno ! ! Binary search for position of value in an ascending sorted array -- integer ! subroutine match(ival,num,key,pos) integer, intent(in) :: ival integer, intent(in) :: num integer, intent(in) :: key(num) integer, intent(out) :: pos integer :: hi, lo hi=num lo=1 do while (hi >= lo) pos=lo + (hi-lo)/2 if (ival > key(pos)) then lo=pos+1 else if (ival < key(pos)) then hi=pos-1 else return end if end do pos=0 end subroutine match ! ! Binary search for position of value in an ascending sorted array -- double precision ! subroutine dmatch(val, num, key, pos) double precision, intent(in) :: val integer, intent(in) :: num double precision, dimension(num), intent(in) :: key(num) integer, intent(out) :: pos integer :: hi, lo hi=num lo=1 do while (hi >= lo) pos=lo + (hi-lo)/2 if (val > key(pos)) then lo=pos+1 else if (val < key(pos)) then hi=pos-1 else return end if end do pos=0 end subroutine dmatch ! ! summarize current pedigree file ! typ=1 as for info ! 2 numbers typed at each locus ! 3 numbers typed at active loci ! 4 numbers missing at active loci ! subroutine actped(typ, red, pedfil, nloci, loc, loctyp, locpos, & outpos, locnotes, typed, locstat, dataset, plevel) use interrupt use outstream use locstring_widths use automatic_data use ped_class use locus_types use locus_list use contingency_table integer, intent(in) :: typ logical, intent(in out) :: red character (len=*), intent(in) :: pedfil integer, intent(in) :: nloci character (len=*), dimension(:), intent(in out) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in out) :: locpos, outpos character (len=annotation_width), dimension(:), intent(in out) :: locnotes integer, dimension(:), intent(inout) :: typed double precision, dimension(:), intent(inout) :: locstat type (ped_data) :: dataset integer, intent(in) :: plevel ! Tabulation of missingness/nonmissingness type (table_data) :: table ! local variables integer :: cumn, j, lclass, ltyp, nmark, nt, tnum, tped logical :: show , show_table character (len=1) :: ch character (len=8) :: wtype character (len=20) :: wstring double precision :: meanval, percent double precision, dimension(1) :: val ! functions double precision :: dataset_uses interface subroutine coutyp(nloci, loctyp, locpos, dataset, eligible, typed) use ped_class integer, intent(in) :: nloci integer, intent(in) :: loctyp(:) integer, intent(in) :: locpos(:) type (ped_data) :: dataset integer, intent(out) :: eligible integer, intent(out) :: typed(:) end subroutine coutyp end interface show_table=.true. meanval=0.0d0 if (typ == 1) then call cntmark(nloci, loctyp, nmark, 2) write(outstr,'(3a/a,i0,a,i0)') & 'Pedigree file = "', trim(pedfil),'"', & 'Number of active loci = ',nmark, ' of ', nloci-ENVNUM end if if (red) then tnum=0 do i=1, dataset%nped if (dataset%actset(i) > 0) then tnum=tnum+dataset%num(i)-dataset%num(i-1) end if end do if (typ == 1) then write(outstr,'((a,i0,a,i0))') & 'Number of active peds = ', dataset%nact , ' of ', dataset%nped, & 'Number of active inds = ',tnum , ' of ', size(dataset%id) write(outstr,'(a,i0)') & 'Largest active ped size = ', dataset%maxact write(wstring, '(f20.3)') dataset_uses(dataset) wstring=adjustl(wstring) write(outstr,'(3a)') & 'Dataset occupies = ', trim(wstring), ' MB' end if call cntclasses(nloci, loctyp) show_table=(plevel > 0 .or. (plevel >= 0 .and. nloci < 100)) if (typ > 1 .or. show_table) then call setup_table(1, 100, table) wtype='Typed' if (typ == 4) wtype='Missing' call coutyp(nloci, loctyp, locpos, dataset, tnum, typed) if (show_table) then write(outstr,'(/2a/a)') & 'Locus Type Position ', wtype, & '--------------- ---- ---------------- ------------' end if do j=1, nloci ltyp=loctyp(j) if (typ > 2) then show=isactive(ltyp) else show=.true. end if if (ismarker(ltyp) .and. show) then ltyp=mod(ltyp, LOC_DEL) if (.not.isactive(loctyp(j))) ltyp=12 if (typ < 4) then nt=typed(j) else nt=tnum-typed(j) end if val(1)=dble(nt) if (typ > 1) locstat(j)=val(1) call insert_table(1, val, table, 1) if (show_table) then percent=100.0*float(nt)/float(tnum) write(outstr,'(a15,2x,a1,4x,i7,a2,i7,1x,i7,1x,a,f5.1,a,3x,a)') & loc(j),typloc(ltyp),outpos(j)+5,'--',outpos(j)+6, & nt, '(', percent,'%)', trim(locnotes(j)) end if else if (istrait(ltyp) .and. show) then ltyp=mod(ltyp, LOC_DEL) if (.not.isactive(loctyp(j))) ltyp=12 if (typ < 4) then nt=typed(j) else nt=tnum-typed(j) end if val(1)=dble(nt) if (typ > 1) locstat(j)=val(1) call insert_table(1, val, table, 1) if (show_table) then percent=100.0*float(nt)/float(tnum) write(outstr,'(a15,2x,a1,4x,i7,10x,i7,1x,a,f5.1,a,3x,a)') & loc(j), typloc(ltyp), outpos(j)+5, & nt, '(', percent,'%)', trim(locnotes(j)) end if end if if (irupt /= 0) exit end do call sort_table(table) cumn=0 meanval=0.0d0 if (plevel > 1) then write(outstr,'(/a13,a/a)') & wtype, ' Number Prop', & ' --------------------------' do j=1, table%ncells nt=table%icount(j) cumn=cumn+nt meanval=meanval+dble(nt)*table%categories(j,1)%rvalue write(outstr,'(i12,i8,2x,f5.3)') & int(table%categories(j,1)%rvalue), nt, & dble(cumn)/dble(max(1,table%ntot)) end do else do j=1, table%ncells nt=table%icount(j) meanval=meanval+dble(nt)*table%categories(j,1)%rvalue end do end if meanval=meanval/dble(max(1,table%ntot)) percent=100.0*meanval/float(tnum) if (typ == 4) then write(outstr,'(/a,f9.1,1x,a,f5.1,a)') & 'Mean number of missing values = ', meanval, '(', percent,'%)' else write(outstr,'(/a,f9.1,1x,a,f5.1,a)') & 'Mean number of usable values = ', meanval, '(', percent,'%)' end if call dohist(wtype, min(table%ncells, 10), 1, table, 9, 1, ' ') end if else call cntclasses(nloci, loctyp) write(outstr,'(/a)') 'NOTE: Dataset not yet read in.' end if end subroutine actped ! ! Summary statistics on families ! subroutine sumped(nloci, loctyp, locpos, dataset) use outstream use ped_class use locus_types integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data) :: dataset integer, parameter :: KNOWN=0, MISS=-9999 integer :: currf, currm, i, istyp, j, nships, onemem, ntyped, tottyp character (len=8) :: wrpercent currf=0 currm=0 nships=0 ntyped=0 onemem=0 tottyp=0 do j=1, dataset%nped if ((dataset%num(j)-dataset%num(j-1))==1) onemem=onemem+1 end do do i=1, dataset%nobs if (dataset%fa(i) /= MISS .and. & (dataset%fa(i) /= currf .or. dataset%mo(i) /= currm)) then currf=dataset%fa(i) currm=dataset%mo(i) nships=nships+1 end if istyp=0 do j=1, nloci if (isactdip(loctyp(j))) then if (observed(i, locpos(j), dataset)) then istyp=1 tottyp=tottyp+1 end if end if end do ntyped=ntyped+istyp end do write(outstr,'(4(/a,i10))') & 'Total number of pedigrees = ', dataset%nped, & 'Number with only 1 member = ', onemem, & 'Total number of sibships = ', nships, & 'Total number of subjects = ', dataset%nobs write(outstr,'(a,i10,1x,a/a,i10)') & 'Total subjects genotyped = ', ntyped, & trim(wrpercent(ntyped, dataset%nobs)), & 'Total number of genotypes = ', tottyp write(outstr,'(a,i10)') & 'Size of largest pedigree = ', dataset%maxsiz if (dataset%maxsiz /= dataset%maxact) then write(outstr,'(a,i10)') & 'Size of largest active ped = ', dataset%maxact end if write(outstr,'(/a,f12.1)') & 'Mean size of pedigrees = ', dble(dataset%nobs)/dble(max(1,dataset%nped)) if (onemem>0 .and. dataset%nped > onemem) then write(outstr,'(a,f12.1)') & 'Mean size where >1 members = ', dble(dataset%nobs-onemem)/dble(dataset%nped-onemem) end if end subroutine sumped ! ! Count matings/sibships in current family ! function countships(ped, dataset) use ped_class integer :: countships integer, intent(in) :: ped type (ped_data) :: dataset integer :: cfa, cmo, i countships=0 cfa=0 cmo=0 do i=dataset%num(ped-1)+dataset%nfound(ped)+1, dataset%num(ped) if (dataset%fa(i) /= cfa .or. dataset%mo(i) /= cmo) then countships=countships+1 cfa=dataset%fa(i) cmo=dataset%mo(i) end if end do end function countships ! ! List all pedigree IDs ! subroutine listpeds(typ, dataset, nwords, words) use outstream use ped_class use string_utilities integer, intent(in) :: typ type (ped_data) :: dataset integer, intent(in) :: nwords character (len=*), dimension(nwords), intent(in) :: words integer :: eop, j, ped, pos logical :: fnd if (typ == 1) then write(outstr,'(/a)') 'Pedigrees:' pos=1 do ped=1, dataset%nped fnd=.true. if (nwords > 2) then fnd=.false. do j=3, nwords if (strfind(words(j)(1:ped_width), dataset%pedigree(ped), 1)) then fnd=.true. exit end if end do end if if (fnd) then eop=len_trim(dataset%pedigree(ped)) if (dataset%actset(ped)>0) then pos=pos+eop+1 call newlin(1,78,pos,eop+2) write(outstr,'(a,1x)', advance='no') & trim(dataset%pedigree(ped)) else pos=pos+eop+3 call newlin(1,78,pos,eop+2) write(outstr,'(3a)', advance='no') & '(', trim(dataset%pedigree(ped)), ') ' end if end if end do write(outstr,*) else do ped=1, dataset%nped if (dataset%actset(ped)>0) then write(outstr,'(a)') trim(dataset%pedigree(ped)) end if end do end if end subroutine listpeds ! ! Tabulate all active IDs ! subroutine make_idlist(dataset, nids, key, icount, nextcopy) use outstream use ped_class type (ped_data) :: dataset integer, intent(out) :: nids integer, dimension(dataset%nobs), intent(out) :: key, icount, nextcopy integer :: hi, i, idpos, idx, k, lo, ped, pos nids=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then person: do i=dataset%num(ped-1)+1, dataset%num(ped) hi=nids lo=1 pos=lo search: do while (hi >= lo) pos=lo+(hi-lo)/2 idpos=key(pos) ! test if higher if (dataset%id(i) > dataset%id(idpos)) then lo=pos+1 cycle search end if ! test if lower if (dataset%id(i) < dataset%id(idpos)) then hi=pos-1 cycle search end if nextcopy(i)=i idx=nextcopy(idpos) do while (idx /= nextcopy(idx)) idx=nextcopy(idx) end do nextcopy(idx)=i icount(pos)=icount(pos)+1 cycle person end do search do k=nids, lo, -1 key(k+1)=key(k) icount(k+1)=icount(k) end do nids=nids+1 icount(lo)=1 key(lo)=i nextcopy(i)=i end do person end if end do end subroutine make_idlist ! ! Tabulate all active IDs and write an indicator variable if requested ! subroutine listids(dataset, ithresh, trait, plevel) use outstream use ped_class type (ped_data) :: dataset integer, intent(in) :: ithresh ! threshold for printing record integer, intent(in) :: trait integer, intent(in) :: plevel integer, parameter :: MISS = -9999, KNOWN = 0 integer, dimension(dataset%nobs) :: key, icount, nextcopy integer :: hi, i, idlen, idpos, idx, j, k, lo, lpos, nids, nactive, nlin, ped, pos integer :: totnum character (len=id_width) :: idhead = 'ID' character (len=6) :: cnum nactive=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then nactive=nactive+dataset%num(ped)-dataset%num(ped-1) if (trait > KNOWN) then dataset%plocus((dataset%num(ped-1)+1):dataset%num(ped), trait)=MISS end if end if end do call make_idlist(dataset, nids, key, icount, nextcopy) idlen=2 do k=1, nids idlen=max(idlen, len_trim(dataset%id(key(k)))) end do ! mark duplicates if (trait > KNOWN) then do k=1, nids i=0 idx=key(k) do i=i+1 dataset%plocus(idx, trait) = dble(i) if (idx == nextcopy(idx)) exit idx=nextcopy(idx) end do end do end if ! tabulate IDs if (plevel > 0 .or. nids < 20 .or. ithresh > 1) then write(outstr,'(/a,1x,a,2x,a/a,1x,a,2x,a)') & idhead(1:idlen), ' Count', ' Pedigrees', & repeat('-',idlen), '------', '--------------------' do k=1, nids if (icount(k) >= ithresh) then write(outstr,'(a,1x,i6)', advance='no') dataset%id(key(k))(1:idlen), icount(k) lpos=idlen+9 nlin=1 idx=key(k) do if (lpos>72) then nlin=nlin+1 if (nlin<4) then lpos=idlen+9 write(outstr,'(/a)', advance='no') repeat(' ', idlen+7) end if end if write(outstr,'(2x,a)', advance='no') trim(dataset%pedigree(dataset%iped(idx))) lpos=lpos+2+len_trim(dataset%pedigree(dataset%iped(idx))) totnum=0 if (plevel > 1) then j=dataset%iped(idx) totnum=totnum+dataset%num(j)-dataset%num(j-1) end if if (idx==nextcopy(idx) .or. nlin>=4) exit idx=nextcopy(idx) end do if (plevel > 1) then write(cnum,'(i6)') totnum write(outstr,'(3a)', advance='no') ' [ ', trim(adjustl(cnum)), ' ]' end if write(outstr,*) end if end do end if write(outstr,'(/a,i0,a,i0,a)') & 'Found ', nids, ' unique IDs in ', nactive, ' records.' end subroutine listids ! ! Tabulate columns of locnotes ! subroutine tabulate_anno(nterms, terms) use scanner use automatic_data use locus_types use locus_data use contingency_table integer, intent(in) :: nterms character (len=*), dimension(nterms) :: terms integer, parameter :: MISS=-9999 type (table_data) :: table type (table_cell), dimension(nterms) :: val integer, dimension(nterms) :: icol integer :: i, j character (len=80) :: cval ! functions integer :: ival do j=1, nterms icol(j)=ival(terms(j)) end do call setup_table(nterms, 20, table) do i=ENVNUM+1, nloci if (isactive(loctyp(i))) then do j=1, nterms call getword(locnotes(i), icol(j), cval, style=1) call set_table_cell(val(j), string=trim(cval)) end do call insert_table_cells(nterms, val, table, 1) end if end do call sort_table(table) call print_table(table) end subroutine tabulate_anno ! ! Table of number of markers or traits per chromosome ! subroutine tabulate_chroms(nloci, loc, loctyp, map, group, chrom_table) use outstream use locus_types use genetic_maps use contingency_table use recast_data integer, intent(in) :: nloci character (len=20), dimension(nloci), intent(in) :: loc integer, dimension(nloci), intent(in) :: loctyp double precision, dimension(nloci), intent(in) :: map character (len=*), dimension(nloci), intent(in) :: group type (chromosome_data) :: chrom_table integer, parameter :: MISS=-9999 type (table_data) :: table integer :: i, j, k, nchrom, nlevels, nmark, ntrait double precision, dimension(1) :: val character (len=2) :: thischr character (len=7) :: mapfmt double precision :: totmaplen nmark=0 ntrait=0 call setup_table(1, 5, table) do i=1, nloci if (isactive(loctyp(i))) then call encchr(group(i), val(1)) if (ismarker(loctyp(i))) then nmark=nmark+1 call insert_table(1, val, table, 1) else if (val(1) /= MISS) then ntrait=ntrait+1 call insert_table(1, val, table, 1) end if end if end do call sort_table(table) nchrom=table%ncells nlevels=1 if (ntrait > 0) nlevels=nlevels+1 call setup_chroms(nchrom, nlevels, chrom_table) chrom_table%totcount(1)=nmark if (nlevels > 1) then chrom_table%totcount(2)=ntrait end if do j=1, nchrom call decchr(table%categories(table%idx(j),1)%rvalue, chrom_table%chromlabel(j)) if (chrom_table%chromlabel(j) == 'Un') chrom_table%chromlabel(j)=' ' chrom_table%mapcount(j)=table%icount(table%idx(j)) end do ! now find map ends for each chromosome j=1 do i=1, nloci if (isactive(loctyp(i))) then k=1 if (.not.ismarker(loctyp(i))) then k=k+1 if (group(i) == ' ') cycle end if thischr=group(i) if (thischr == 'Mt' .or. thischr == 'mt') thischr = 'MT' do if (thischr == chrom_table%chromlabel(j)) exit j=j+1 if (j > nchrom) j=1 end do if (map(i) /= MISS) then if (map(i) >= chrom_table%chromend(j,k)) then chrom_table%mapend(j,k)=i chrom_table%chromend(j,k) = map(i) end if if (map(i) < chrom_table%chromstart(j,k)) then chrom_table%mapstart(j,k)=i chrom_table%chromstart(j,k) = map(i) end if else if (chrom_table%mapstart(j,k) == 0) then chrom_table%mapstart(j,k)=i else if (chrom_table%mapend(j,k) == 0) then chrom_table%mapend(j,k)=i end if end if end do end subroutine tabulate_chroms subroutine listchroms(nloci, loc, loctyp, map, group) use outstream use locus_types use genetic_maps use contingency_table use recast_data integer, intent(in) :: nloci character (len=20), dimension(nloci), intent(in) :: loc integer, dimension(nloci), intent(in) :: loctyp double precision, dimension(nloci), intent(in) :: map character (len=*), dimension(nloci), intent(in) :: group integer, parameter :: MISS=-9999 type (chromosome_data) :: chrom_table integer :: j, k, ntot character (len=7) :: mapfmt double precision :: lowest, highest, totmaplen call tabulate_chroms(nloci, loc, loctyp, map, group, chrom_table) ! table mapfmt=mapformat(mapunits, '12') write(outstr,'(21x,3a/a/a)') & 'Position (', trim(mapunitname(mapunits)), ')', & 'Chrom Count Start Finish', & '----- --------- ------------ ------------' ntot=0 totmaplen=0.0d0 do j=1, chrom_table%nchrom if (chrom_table%chromlabel(j) == ' ') chrom_table%chromlabel(j)='Un' lowest=1.0d20 highest=-1.0d0 do k=1, chrom_table%ntypes if (chrom_table%chromstart(j,k) == 1.0d20) then chrom_table%chromstart(j,k)=0.0d0 end if if (chrom_table%chromend(j,k) == -1.0d0) then chrom_table%chromend(j,k)=chrom_table%chromstart(j,k) end if if (chrom_table%chromstart(j,k) < lowest) lowest=chrom_table%chromstart(j,k) if (chrom_table%chromend(j,k) > highest) highest=chrom_table%chromend(j,k) end do if (chrom_table%chromlabel(j) /= 'Un') then totmaplen=totmaplen+highest-lowest end if ntot=ntot+chrom_table%mapcount(j) write(outstr,'(3x,a2,i9,1x)', advance='no') & chrom_table%chromlabel(j), chrom_table%mapcount(j) write(outstr, mapfmt, advance='no') lowest/mapconstant write(outstr, mapfmt, advance='no') highest/mapconstant do k=1, chrom_table%ntypes if (chrom_table%mapstart(j,k) /= 0) then write(outstr, '(2x,a)', advance='no') trim(loc(chrom_table%mapstart(j,k))) if (chrom_table%mapstart(j,k) /= chrom_table%mapend(j,k) .and. & chrom_table%mapend(j,k) /= 0) then write(outstr, '(2a)', advance='no') ' -- ', trim(loc(chrom_table%mapend(j,k))) end if end if end do write(outstr,*) end do write(outstr,'(6x,a/5x,i9//a)', advance='no') & '---------', ntot, 'Total map length =' write(outstr, mapfmt, advance='no') totmaplen/mapconstant write(outstr,'(1x,a)') mapunitname(mapunits) if (chrom_table%ntypes > 1) then if (chrom_table%totcount(2) > 0) then write(outstr,'(a,i0,a)') 'This includes ', chrom_table%totcount(2), & ' trait loci with map positions.' end if end if call clean_chroms(chrom_table) end subroutine listchroms ! ! check for identical map positions ! subroutine testmap(typ, thresh, nloci, loc, loctyp, locpos, locnotes, & group, map, locstat, dataset, plevel) use outstream use sorts use locstring_widths use locus_types use locus_list use genetic_maps use contingency_table use ped_class integer, intent(in) :: typ double precision, intent(in) :: thresh integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=annotation_width), dimension(:), intent(inout) :: locnotes character (len=chromosome_width), dimension(:), intent(in) :: group double precision, dimension(:), intent(in) :: map double precision, dimension(:), intent(inout) :: locstat type (ped_data) :: dataset integer, intent(in) :: plevel integer, parameter :: MISS=-9999 integer :: duplicates, i, ichr, ordered, nzero, placed, pos, & pos1, pos2, prev, unplaced ! map sort integer (kind=8), dimension(nloci) :: mapidx integer, dimension(nloci) :: ord double precision, dimension(2) :: val character (len=2) :: chrom character (len=7) :: mapfmt ! functions integer :: chrnum interface subroutine mergeloci(first, second, thresh, nloci, loc, loctyp, locpos, & locnotes, group, map, dataset, plevel) use outstream use nucleotides use alleles_class use ped_class use locus_types implicit none integer, intent(in) :: first, second double precision, intent(in) :: thresh integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=*), dimension(:), intent(inout) :: locnotes character (len=*), dimension(:), intent(in) :: group double precision, dimension(:), intent(in) :: map type (ped_data) :: dataset integer, intent(in) :: plevel end subroutine mergeloci end interface mapfmt=mapformat(mapunits, '12') duplicates=0 nzero=0 ordered=0 unplaced=0 placed=0 prev=1 ! find start of map (first mapped locus) do prev=findmk(prev, nloci, loctyp) if (prev == MISS) exit if (map(prev) == MISS) then unplaced=unplaced+1 prev=prev+1 else exit end if end do if (prev /= MISS) then ordered=2 if (unplaced > 0) ordered=0 pos=prev do i=pos, nloci if (ismarker(loctyp(i)) .and. isactive(loctyp(i))) then if (map(i) == MISS) then unplaced=unplaced+1 else placed=placed+1 ichr=chrnum(group(i)) mapidx(placed)=1000000000_8*int(ichr, kind=8) + anint(1.0d6*map(i), kind=8) ord(placed)=i if (ordered > 0) then if (group(i) == group(prev)) then if (map(i) < map(prev)) then ordered=0 if (group(i) == ' ') ordered=ordered+1 end if end if end if prev=i end if end if end do if (placed > 1) then call long_isort(1, placed, mapidx, ord, 2) locstat(ord(1))=0 do i=2, placed pos1=ord(i-1) pos2=ord(i) if (mapidx(i) == mapidx(i-1)) then if (map(pos2) == 0.0d0) nzero=nzero+1 duplicates=duplicates+1 if (locstat(pos1) > 0) then locstat(pos2)=locstat(pos1) + 1 else locstat(pos1)=1 locstat(pos2)=2 end if else locstat(pos2)=0 end if end do end if end if write(outstr,'(/a,i0/a,i0/a)', advance='no') & 'Number of markers placed on map = ', placed, & 'Number of unplaced markers = ', unplaced, & 'Marker order = ' if (ordered == 2) then write(outstr,'(a)') 'Map Order' else if (ordered == 1) then write(outstr,'(a)') 'Ambiguous (not all chromosomes specified)' else write(outstr,'(a)') 'Unordered' end if write(outstr,'(a,i0)') & 'Duplicated map positions = ', duplicates if (nzero > 0) then write(outstr,'(a,i0)') & 'Duplicates where position zero = ', nzero end if if (duplicates > 0 .and. plevel > -2) then write(outstr,'(/a/a)') 'Chr Position Count', & '--- ------------ ------' prev=1 i=2 do while (i <= placed) if (mapidx(i) == mapidx(prev)) then do while (mapidx(i) == mapidx(prev) .and. i <= placed) i=i+1 end do i=i-1 write(outstr,'(1x,a2,1x)', advance='no') group(ord(i)) write(outstr, mapfmt, advance='no') map(ord(i)) write(outstr,'(i7)', advance='no') i-prev+1 do pos=prev, i write(outstr,'(1x,a)', advance='no') trim(loc(ord(pos))) end do write(outstr,'(1x,a,1x,a)') ':', trim(locnotes(ord(prev))) end if prev=i i=i+1 end do write(outstr,*) ! ! merge loci on position ! if (typ == 2) then prev=1 i=2 do while (i <= placed) if (mapidx(i) == mapidx(prev)) then do while (mapidx(i) == mapidx(prev) .and. i <= placed) call mergeloci(ord(prev), ord(i), thresh, nloci, loc, loctyp, & locpos, locnotes, group, map, dataset, plevel) i=i+1 end do i=i-1 end if prev=i i=i+1 end do end if end if end subroutine testmap ! ! Summary table for allelic spectrum ! subroutine show_spectrum(dataset) use interrupt use outstream use nucleotides use ped_class use locus_types use locus_list use locus_data use alleles_class type (ped_data) :: dataset integer, dimension(4) :: monomorphic integer, dimension(6) :: dimorphic character(len=1), dimension(4), parameter :: malleles = & (/ 'A', 'C','G', 'T' /) character(len=2), dimension(6), parameter :: dalleles = & (/ 'AC', 'AG', 'AT', 'CG', 'CT', 'GT' /) type (allele_data) :: allele_buffer integer :: g1, g2, i, nd, nm ! functions character (len=8) :: wrpercent monomorphic = 0 dimorphic = 0 do i=1, nloci if (isactive(loctyp(i)) .and. ismarker(loctyp(i))) then if (dataset%hassnps == 2 .and. iscompressed(loctyp(i))) then call get_snpallele2(locnotes(i), allele_buffer) else call freq(locpos(i), loctyp(i), 0, dataset, allele_buffer) end if if (allele_buffer%numal == 1) then g1=allele_buffer%allele_names(1) if (is_a(g1)) then monomorphic(1) = monomorphic(1) + 1 else if (is_c(g1)) then monomorphic(2) = monomorphic(2) + 1 else if (is_g(g1)) then monomorphic(3) = monomorphic(3) + 1 else if (is_t(g1)) then monomorphic(4) = monomorphic(4) + 1 end if else if (allele_buffer%numal == 2) then g1=allele_buffer%allele_names(1) g2=allele_buffer%allele_names(2) if (is_a(g1)) then if (is_c(g2)) then dimorphic(1) = dimorphic(1) + 1 else if (is_g(g2)) then dimorphic(2) = dimorphic(2) + 1 else if (is_t(g2)) then dimorphic(3) = dimorphic(3) + 1 end if else if (is_c(g1)) then if (is_g(g2)) then dimorphic(4) = dimorphic(4) + 1 else if (is_t(g2)) then dimorphic(5) = dimorphic(5) + 1 end if else if (is_g(g1) .and. is_t(g2)) then dimorphic(6) = dimorphic(6) + 1 end if end if end if end do nm=monomorphic(1)+monomorphic(2)+monomorphic(3)+monomorphic(4) nd=dimorphic(1)+dimorphic(2)+dimorphic(3)+dimorphic(4)+ & dimorphic(5)+dimorphic(6) write(outstr,'(/a/)') 'SNP allelic spectrum:' if (nm+nd > 0) then write(outstr,'(a/a)') 'Alleles Count', & '------- -------' if (nm > 0) then do i=1, 4 write(outstr,'(a5,i10,1x,a)') & malleles(i), monomorphic(i), wrpercent(monomorphic(i), nm) end do end if if (nd > 0) then do i=1, 4 write(outstr,'(a5,i10,1x,a)') & dalleles(i), dimorphic(i), wrpercent(dimorphic(i), nd) end do end if else write(outstr,'(a)') 'No suitable loci!' end if end subroutine show_spectrum ! ! check for simple inconsistencies between child and parent ! if requested, delete any problem genotypes (up to and including ! all genotypes for a nuclear family) ! ! error action if droperr ! ---------------------------------------- ---------------------------- ! 11=single parent-offspring inconsistency delete child genotype ! 12=Multiple p-o inconsistencies delete all nuclear fam genos ! 13=Inconsistencies between siblings delete all nuclear fam genos ! 14=More than 4 alleles segregating delete all nuclear fam genos ! subroutine check(checkall, nloci, loc, loctyp, locpos, locnotes, locstat, & dataset, droperr, ndiscard, inconsist, plevel) use interrupt use outstream use sorts use ped_class use locstring_widths use locus_types use locus_list logical, intent(in) :: checkall integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=annotation_width), dimension(:), intent(in) :: locnotes double precision, dimension(:), intent(inout) :: locstat type (ped_data) :: dataset integer, intent(in) :: droperr integer, intent(inout) :: ndiscard integer, intent(inout) :: inconsist integer, intent(in) :: plevel integer, parameter :: KNOWN=0 integer, parameter :: MISS=-9999 ! sibship genotypes integer, dimension(dataset%maxsiz,2) :: set logical, dimension(dataset%maxsiz) :: xmale ! count of segregating alleles integer :: nall, allele(4) ! count of errors by locus and by pedigree integer, dimension(dataset%nped) :: family_index, family_errors integer, dimension(:), allocatable :: locus_index, locus_errors ! other local variables integer :: nmark, pedoffset, ped integer :: c1, c2, currf, currm, gene, gen2, i, j, imark, nkids, & nused, p11, p12, p21, p22, sta integer :: bad1, bad2, badchild, errthresh, errtyp, tottyp integer :: ptyped logical :: ferr, pederr, thiserr, xlinkd, ylinkd character (len=7) :: gtp interface subroutine nuchek(xlinkd, ptyped, p11, p12, p21, p22, & nkids, set, xmale, nall, allele, thiserr) logical, intent(inout) :: xlinkd integer, intent(inout) :: ptyped integer, intent(inout) :: p11 integer, intent(inout) :: p12 integer, intent(inout) :: p21 integer, intent(inout) :: p22 integer, intent(in) :: nkids integer, dimension(:,:), intent(in) :: set logical, dimension(:), intent(in) :: xmale integer, intent(in) :: nall integer, dimension(:), intent(in) :: allele logical, intent(out) :: thiserr end subroutine end interface ! functions integer :: parcon logical :: opcon do ped=1, dataset%nped family_index(ped)=ped family_errors(ped)=0 end do call cntmark(nloci, loctyp, nmark, 3) if (nmark == 0) then if (plevel > 0) then write(outstr,'(a)') 'NOTE: No eligible markers to be checked for errors.' end if return end if allocate(locus_index(nmark), locus_errors(nmark)) nused=0 tottyp=0 do j=1, nloci if (ismarker(loctyp(j)) .and. isactive(loctyp(j))) then nused=nused+1 locus_index(nused)=j locus_errors(nused)=0 do i=1, dataset%nobs if (observed(i, locpos(j), dataset)) then tottyp=tottyp+1 end if end do end if end do do ped=1, dataset%nped if (checkall .or. dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do imark=1, nused j=locus_index(imark) ferr=.false. pederr=.false. xlinkd=(same_loctyp(loctyp(j), LOC_XLIN)) ylinkd=(same_loctyp(loctyp(j), LOC_YHA)) badchild=MISS gene=locpos(j) gen2=gene+1 nkids=0 ptyped=0 currf=MISS currm=MISS ! Check for Y marker heterozygotes if (ylinkd) then do i=pedoffset+1, dataset%num(ped) call get_geno(i, gene, gen2, dataset, c1, c2) if (c1 > KNOWN .and. (c1 /= c2 .or. dataset%sex(i) == 2)) then pederr=.true. call wrgtp(c1, c2, gtp, '/', '', 1) if (c1 /= c2) then write(outstr,'(/9a/)') & 'ERROR: Heterozygous genotype ', & trim(dataset%pedigree(ped)),'-',trim(dataset%id(i)), & ' at Y marker ',trim(loc(j)),' {',gtp,'}' else write(outstr,'(/9a/)') & 'ERROR: Putative female ', & trim(dataset%pedigree(ped)),'-',trim(dataset%id(i)), & ' with genotype at Y marker ',trim(loc(j)),' {',gtp,'}' end if if (droperr > 0) then call set_geno(i, gene, gen2, dataset, MISS, MISS) else inconsist=inconsist+1 end if end if end do ! Check for male X-linked heterozygotes else if (xlinkd) then do i=pedoffset+1, dataset%num(ped) call get_geno(i, gene, gen2, dataset, c1, c2) if (dataset%sex(i) == 1 .and. c1 > KNOWN .and. c1 /= c2) then pederr=.true. call wrgtp(c1, c2, gtp, '/', '', 1) write(outstr,'(/9a/)') & 'ERROR: Heterozygous male ', & trim(dataset%pedigree(ped)),'-',trim(dataset%id(i)), & ' at X-linked locus ',trim(loc(j)),' {',gtp,'}' if (droperr > 0) then call set_geno(i, gene, gen2, dataset, MISS, MISS) else inconsist=inconsist+1 end if else if (dataset%sex(i) == MISS .and. c1 > KNOWN) then call wrgtp(c1, c2, gtp, '/', '', 1) write(outstr,'(/9a/)') & 'NOTE: Unspecified sex for ', & trim(dataset%pedigree(ped)),'-',trim(dataset%id(i)), & ' at X-linked locus ', trim(loc(j)),' {',gtp,'}' end if end do end if ! ! Check each nuclear family ! ferr=.false. do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped) ! Print results of previous sibship and do parents of current sibship if (dataset%fa(i) /= currf .or. dataset%mo(i) /= currm) then if (ferr) then pederr=.true. if (nall > 4) errtyp=14 ! Temporarily put back deleted genotype if errtyp=11 if (badchild /= MISS) then call set_geno(badchild, gene, gen2, dataset, bad1, bad2) end if ! ! print only the list of genotypes for the family if verbosity low ! otherwise a pedigree drawing ! call famerr(loc(j), gene, xlinkd, ped, dataset, & currf, currm, badchild, sta, i-1, errtyp, plevel) ! and delete nuclear family genotypes causing problem call remfam(currf, currm, sta, i-1, gene, dataset, ndiscard) ferr=.false. end if ! initialize current sibship errtyp=0 badchild=MISS sta=i nkids=0 currf=dataset%fa(i) currm=dataset%mo(i) call get_geno(currf, gene, gen2, dataset, p11, p12) call get_geno(currm, gene, gen2, dataset, p21, p22) nall=0 ptyped=0 if (p11 > KNOWN) then ptyped=ptyped+1 call addall(p11,nall,4,allele) call addall(p12,nall,4,allele) end if if (p21 > KNOWN) then ptyped=ptyped+2 call addall(p21,nall,4,allele) call addall(p22,nall,4,allele) end if end if ! ! do current child if typed ! if (observed(i, gene, dataset)) then thiserr=.false. call get_geno(i, gene, gen2, dataset, c1, c2) nkids=nkids+1 xmale(nkids)=(xlinkd .and. dataset%sex(i) /= 2) set(nkids,1)=c1 set(nkids,2)=c2 ! ! test for simple parent-offspring inconsistency ! if single error, try deleting just child ! if (ylinkd .and. dataset%sex(i) /= 2) then if (c1 /= p11) then if (errtyp == 0) then errtyp=11 badchild=i bad1=c1 bad2=c2 call set_geno(i, gene, gen2, dataset, MISS, MISS) else if (errtyp == 11) then errtyp=12 end if end if else if ((ptyped == 3 .and. & parcon(c1,c2,p11,p12,p21,p22,xmale(nkids)) == 0) .or. & (ptyped == 1 .and. .not.xmale(nkids) .and. & .not.opcon(c1,c2,p11,p12)) .or. & (ptyped == 2 .and. .not.opcon(c1,c2,p21,p22))) then thiserr=.true. if (errtyp == 0) then errtyp=11 badchild=i bad1=c1 bad2=c2 call set_geno(i, gene, gen2, dataset, MISS, MISS) else if (errtyp == 11) then errtyp=12 end if ! or too many alleles segregating in sibship else call addall(c1,nall,4,allele) call addall(c2,nall,4,allele) if (nall > 4 .or. (xlinkd .and. nall > 3)) then thiserr=.true. errtyp=14 ! else test for more complex errors else if (.not.ferr .and. ptyped /= 3 .and. nkids > 1) then call nuchek(xlinkd, ptyped, p11, p12, p21, p22, & nkids, set, xmale, nall, allele, thiserr) errtyp=13 end if end if ! If an error, note the responsible child if (thiserr) then ferr=.true. if (droperr == 0) inconsist=inconsist+1 if (plevel > -2) then call wrgtp(c1, c2, gtp, '/', '', 1) write(outstr,'(/9a/)') & 'NOTE: inconsistency due child ', & trim(dataset%pedigree(ped)),'-',trim(dataset%id(i)), & ' at locus ', trim(loc(j)),' {',gtp,'}' end if end if end if end do ! ! Last sibship ! if (ferr) then pederr=.true. if (nall > 4 .or. (xlinkd .and. nall > 3)) errtyp=14 if (badchild /= MISS) then call set_geno(badchild, gene, gen2, dataset, bad1, bad2) end if call famerr(loc(j), gene, xlinkd, ped, dataset, & currf, currm, badchild, sta, i-1, errtyp, plevel) if (droperr > 0 .and. errtyp >= 11) then call remfam(currf, currm, sta, i-1, gene, dataset, ndiscard) end if end if if (pederr) then family_errors(ped)=family_errors(ped)+1 locus_errors(imark)=locus_errors(imark)+1 end if end do if (irupt /= 0) exit end if end do do imark=1, nmark locstat(locus_index(imark))=locus_errors(imark)/dble(dataset%nped) end do call isort(1, dataset%nped, family_errors, family_index, 2) call isort(1, nmark, locus_errors, locus_index, 2) errthresh=1 if (plevel > 0 .or. dataset%nped < 10) errthresh=0 if (dataset%nped == 0) then write(outstr,'(/a)') 'No pedigrees!' else if (family_errors(dataset%nped) > errthresh) then write(outstr,'(/a/a)') 'Pedigree Loci with Mendel errors', & '--------------- -----------------------' ped=dataset%nped do while (ped > 0) if (family_errors(ped) > errthresh) then write(outstr,'(a15,5x,i5,3x,f5.1,a)') & dataset%pedigree(family_index(ped)), family_errors(ped), & 100.0d0*family_errors(ped)/dble(nmark), '%' end if ped=ped-1 end do write(outstr,'(/a/a)') 'Locus Peds with Mendel errors', & '--------------- -----------------------' imark=nmark do while (imark > 0) if (locus_errors(imark) > errthresh) then write(outstr,'(a15,5x,i5,3x,f5.1,a,1x,a)') & loc(locus_index(imark)), locus_errors(imark), & 100.0d0*locus_errors(imark)/dble(dataset%nped), '%', & locnotes(locus_index(imark)) end if imark=imark-1 end do write(outstr,*) else if (plevel > 0) then write(outstr,'(2a)', advance='no') & 'No nuclear family level Mendelian errors detected for ' , & trim(loc(locus_index(1))) if (nmark > 1) then write(outstr,'(2a)', advance='no') & ' .. ' , trim(loc(locus_index(nmark))) end if write(outstr,'(a)') '.' end if end subroutine check ! ! identify parental alleles in nuclear family ! subroutine addall(iall, nall, allmax, allele) integer, intent(in) :: iall integer, intent(in out) :: nall integer, intent(in) :: allmax integer, dimension(allmax), intent(in out) :: allele integer :: i ! find a match do i=1, min(allmax,nall) if (iall == allele(i)) then return end if end do ! else create new allele entry nall=nall+1 if (nall <= allmax) allele(nall)=iall end subroutine addall ! ! nuclear family consistency check (untyped parents) ! subroutine nuchek(xlinkd, ptyped, p11, p12, p21, p22, & nkids, set, xmale, nall, allele, thiserr) logical, intent(inout) :: xlinkd integer, intent(inout) :: ptyped integer, intent(inout) :: p11 integer, intent(inout) :: p12 integer, intent(inout) :: p21 integer, intent(inout) :: p22 integer, intent(in) :: nkids integer, dimension(:,:), intent(in) :: set logical, dimension(:), intent(in) :: xmale integer, intent(in) :: nall integer, dimension(:), intent(in) :: allele logical, intent(out) :: thiserr integer, parameter :: KNOWN=0, MISS=-9999 ! ! other local variables integer :: g1,g2,g3,g4 integer :: mg1,mg2,pg1,pg2 integer :: i1,i2,t1,t2 interface function shipcon(pg1, pg2, mg1, mg2, nkids, set, xmale) logical shipcon integer, intent(in) :: pg1, pg2, mg1, mg2 integer, intent(in) :: nkids integer, dimension(:,:), intent(in) :: set logical, dimension(:), intent(in) :: xmale end function shipcon function whall(iall,nall,allele) integer whall integer, intent(in) :: iall integer, intent(in) :: nall integer, intent(in) :: allele(:) end function whall end interface ! ! loop through all possible parental genotypes ! initialize genotype indices ! if (ptyped == 1) then t1=1 i1=1 g1=whall(p11, nall, allele) g2=whall(p12, nall, allele) else t1=nall*(nall+1)/2 i1=0 g1=1 g2=0 if (t1 == 1) g2=g2+1 end if if (ptyped == 2) then t2=1 i2=1 g3=whall(p21,nall,allele) g4=whall(p22,nall,allele) else t2=nall*(nall+1)/2 i2=t2 g3=1 g4=0 if (t2 == 1) g4=g4+1 end if ! ! simulated nested do-loops ! check if inner loop completed once ! thiserr=.true. ! do while (thiserr .and. (i1 /= t1 .or. i2 /= t2)) iloop=0 do iloop=iloop+1 if (i2 == t2) then call couple(i1,t1,nall,g1,g2) pg1=allele(g1) pg2=allele(g2) if (xlinkd) pg2=pg1 if (t2 > 1) i2=0 end if call couple(i2,t2,nall,g3,g4) mg1=allele(g3) mg2=allele(g4) thiserr=.not.shipcon(pg1, pg2, mg1, mg2, nkids, set, xmale) if (.not.thiserr .or. (i1 == t1 .and. i2 == t2)) exit end do end subroutine nuchek ! ! Write out nuclear family error ! subroutine famerr(locnam, gene, xlinkd, ped, dataset, & currf, currm, badchild, sta, fin, errtyp, plevel) use ped_class character (len=20), intent(in) :: locnam integer, intent(in) :: gene logical, intent(in) :: xlinkd integer, intent(in) :: ped type (ped_data) :: dataset integer, intent(in) :: currf integer, intent(in) :: currm integer, intent(in) :: badchild integer, intent(in) :: sta integer, intent(in) :: fin integer, intent(inout) :: errtyp integer, intent(in) :: plevel integer, parameter :: MISS=-9999 integer :: i, gen2 gen2=gene+1 if (plevel >= 0) then call describe(locnam, gene, xlinkd, ped, dataset, & currf, currm, sta, fin, errtyp) else call inderr(currf, locnam, gene, gen2, dataset) call inderr(currm, locnam, gene, gen2, dataset) if (badchild /= MISS) then call inderr(badchild, locnam, gene, gen2, dataset) else do i=sta, fin call inderr(i, locnam, gene, gen2, dataset) end do end if end if end subroutine famerr ! ! write genotype for an individual flagged as a Mendelian error ! subroutine inderr(idx, locnam, gene, gen2, dataset) use outstream use idstring_widths use ped_class integer, intent(in) :: idx, gene, gen2 character (len=20), intent(in) :: locnam type (ped_data) :: dataset integer :: g1, g2 integer, parameter :: MISS=-9999 character (len=7) :: gtp call get_geno(idx, gene, gen2, dataset, g1, g2) if (g1 == MISS) return call wrgtp(g1, g2, gtp, '/', '', 1) write(outstr,'(3a,1x,a,1x,a,a)') & trim(dataset%pedigree(dataset%iped(idx))),'-', trim(dataset%id(idx)), & trim(locnam), gtp, ' Possible Mendelian error' end subroutine inderr ! ! Remove a genotype from data ! subroutine remove(idx, gene, dataset, ndiscard) use ped_class integer, intent(in) :: idx integer, intent(in) :: gene type (ped_data) :: dataset integer, intent(inout) :: ndiscard integer, parameter :: KNOWN=0, MISS=-9999 if (observed(idx, gene, dataset)) then ndiscard=ndiscard+1 call set_geno(idx, gene, gene+1, dataset, MISS, MISS) end if end subroutine remove ! ! drop a nuclear family's genotypes ! subroutine remfam(currf, currm, sta, fin, gene, dataset, ndiscard) use ped_class integer, intent(in) :: currf integer, intent(in) :: currm integer, intent(in) :: sta integer, intent(in) :: fin integer, intent(in) :: gene type (ped_data) :: dataset integer, intent(inout) :: ndiscard integer :: i call remove(currf, gene, dataset, ndiscard) call remove(currm, gene, dataset, ndiscard) do i=sta, fin call remove(i, gene, dataset, ndiscard) end do end subroutine remfam ! ! Tests if child genotype consistent with parental genotypes: ! parcon=4*Pr(Child_genotype|Father_genotype,Mother_genotype) ! if xmale TRUE then X-linked locus *and* male child ! function parcon(c1, c2, p11, p12, p21, p22, xmale) integer :: parcon integer, intent(in) :: c1 integer, intent(in) :: c2 integer, intent(in) :: p11 integer, intent(in) :: p12 integer, intent(in) :: p21 integer, intent(in) :: p22 logical, intent(in) :: xmale parcon=0 if (xmale) then if (c1 == p21) parcon=parcon+2 if (c1 == p22) parcon=parcon+2 return end if if ((c1 == p11 .and. c2 == p21) .or. (c1 == p21 .and. c2 == p11)) parcon=parcon+1 if ((c1 == p11 .and. c2 == p22) .or. (c1 == p22 .and. c2 == p11)) parcon=parcon+1 if ((c1 == p12 .and. c2 == p21) .or. (c1 == p21 .and. c2 == p12)) parcon=parcon+1 if ((c1 == p12 .and. c2 == p22) .or. (c1 == p22 .and. c2 == p12)) parcon=parcon+1 end function parcon ! ! test if child genotype consistent with one parental genotype ! function opcon(c1,c2,p1,p2) logical opcon integer, intent(in) :: c1 integer, intent(in) :: c2 integer, intent(in) :: p1 integer, intent(in) :: p2 opcon=(c1 == p1 .or. c1 == p2 .or. c2 == p1 .or. c2 == p2) end function opcon ! ! test consistency of a sibship with parents ! function shipcon(pg1, pg2, mg1, mg2, nkids, set, xmale) logical shipcon integer, intent(in) :: pg1, pg2, mg1, mg2 integer, intent(in) :: nkids integer, dimension(:,:), intent(in) :: set logical, dimension(:), intent(in) :: xmale integer :: i ! functions integer parcon shipcon=.false. do i=1, nkids if (parcon(set(i,1), set(i,2), pg1, pg2, mg1, mg2, xmale(i)) == 0) then return end if end do shipcon=.true. end function shipcon ! ! Enumerate all combinations of i ~ I(1..range) with itself ! If index=tot then return last tuple ! subroutine couple(idx,tot,rang,i1,i2) integer, intent(inout) :: idx integer, intent(in) :: tot integer, intent(in) :: rang integer, intent(inout) :: i1 integer, intent(inout) :: i2 if (idx == tot) return idx=idx+1 i2=i2+1 if (i2 > rang) then i1=i1+1 if (i1 > rang) i1=1 i2=i1 end if return end subroutine couple ! ! Find index of allele segregating in nuclear family ! function whall(iall,nall,allele) integer whall integer, intent(in) :: iall integer, intent(in) :: nall integer, intent(in) :: allele(:) integer :: i do i=1, nall-1 if (iall == allele(i)) then whall=i return end if end do whall=nall return end function whall ! ! write out genotypes in nuclear family and grandparents ! subroutine describe(locnam, gene, xlinkd, ped, dataset, & currf, currm, sta, fin, mesg) use outstream use ped_class character (len=20), intent(in) :: locnam integer, intent(in) :: gene logical, intent(in) :: xlinkd integer, intent(in) :: ped type (ped_data) :: dataset integer, intent(in) :: currf, currm integer, intent(in) :: sta, fin integer, intent(in) :: mesg integer, parameter :: KNOWN=0, MISS=-9999 integer, parameter :: WIDE=12 integer :: g1, g2, i, eol, eop, gen2, leftm, npars, pos, nsibs logical :: gp1, gp2 character (len=7) :: gtp character (len=10) :: chid character (len=128) :: lin ! Check if useful to view if (mesg < 10) then npars=0 if (observed(currf, gene, dataset)) npars=npars+1 if (observed(currm, gene, dataset)) npars=npars+1 nsibs=0 do i=sta, fin if (observed(i, gene, dataset)) then nsibs=nsibs+1 end if end do if (nsibs == 0 .or. (nsibs == 1 .and. npars == 0)) return end if ! if useful gen2=gene+1 eop=len_trim(dataset%pedigree(ped)) lin=' ' if (.not.xlinkd) then write(outstr,'(3a/a)') 'Locus "',locnam(1:len_trim(locnam)),'"', '------------------' else write(outstr,'(3a/a)') 'X-linked locus "',locnam(1:len_trim(locnam)),'"', '---------' end if write(outstr,'(8a/)') & 'Sibship: ',trim(dataset%pedigree(ped)),'-', trim(dataset%id(currf)), & ' x ',trim(dataset%pedigree(ped)),'-', trim(dataset%id(currm)) ! ! write an edifying message, if supplied if (mesg == 10) then write(outstr,'(a/)') 'Multigenerational inconsistency between genotypes.' else if (mesg == 11) then write(outstr,'(a/)') 'Inconsistency between parent and child genotypes.' else if (mesg == 12) then write(outstr,'(a/)') & 'Multiple inconsistencies between parent and child genotypes.' else if (mesg == 13) then write(outstr,'(a/)') 'Inconsistency between sibling genotypes.' else if (mesg == 14) then write(outstr,'(a/)') 'More than 4 alleles segregating in nuclear family.' else if (mesg == 15) then write(outstr,'(a/)') 'Inconsistency between imputed parent and child genotypes.' end if gp1=(dataset%fa(currf) /= MISS) gp2=(dataset%fa(currm) /= MISS) ! ! Show grandparental generation if useful and present ! if (mesg < 11 .and. (gp1 .or. gp2)) then if (gp1) then call wrid('c',dataset%id(dataset%fa(currf)),chid,dataset%sex(dataset%fa(currf))) lin(17:26)=chid call wrid('c',dataset%id(dataset%mo(currf)),chid,dataset%sex(dataset%mo(currf))) lin(27:36)=chid eol=36 end if if (gp2) then call wrid('c',dataset%id(dataset%fa(currm)),chid,dataset%sex(dataset%fa(currm))) lin(37:46)=chid call wrid('c',dataset%id(dataset%mo(currm)),chid,dataset%sex(dataset%mo(currm))) lin(47:56)=chid eol=56 end if write(outstr,'(a)') lin(1:eol) lin=' ' if (gp1) then call get_geno(dataset%fa(currf), gene, gen2, dataset, g1, g2) if (g1 < KNOWN) then g1=MISS g2=MISS end if if (.not.xlinkd) then call wrgtp(g1, g2, gtp, '/', '', 1) else call wrgtp(g1, 0, gtp, '/', '', 1) end if lin(18:24)=gtp call get_geno(dataset%mo(currf), gene, gen2, dataset, g1, g2) if (g1 < KNOWN) then g1=MISS g2=MISS end if call wrgtp(g1, g2, gtp, '/', '', 1) lin(28:34)=gtp eol=34 end if if (gp2) then call get_geno(dataset%fa(currm), gene, gen2, dataset, g1, g2) if (g1 < KNOWN) then g1=MISS g2=MISS end if if (.not.xlinkd) then call wrgtp(g1, g2, gtp, '/', '', 1) else call wrgtp(g1, 0, gtp, '/', '', 1) end if lin(38:44)=gtp call get_geno(dataset%mo(currm), gene, gen2, dataset, g1, g2) if (g1 < KNOWN) then g1=MISS g2=MISS end if call wrgtp(g1, g2, gtp, '/', '', 1) lin(48:54)=gtp eol=54 end if write(outstr,'(a)') lin(1:eol) lin=' ' if (gp1) then lin(21:21)='|' lin(31:31)='|' eol=31 end if if (gp2) then lin(41:41)='|' lin(51:51)='|' eol=51 end if write(outstr,'(a)') lin(1:eol) lin=' ' if (gp1) then lin(21:31)='+====+====+' eol=31 end if if (gp2) then lin(41:51)='+====+====+' eol=51 end if write(outstr,'(a)') lin(1:eol) lin=' ' if (gp1) then lin(26:26)='|' eol=26 end if if (gp2) then lin(46:46)='|' eol=46 end if write(outstr,'(a)') lin(1:eol) lin=' ' end if ! ! Now the parents of the nuclear family ! call wrid('c',dataset%id(currf),chid,dataset%sex(currf)) lin(22:31)=chid call wrid('c',dataset%id(currm),chid,dataset%sex(currm)) lin(42:51)=chid write(outstr,'(a)') lin(1:51) lin=' ' call get_geno(currf, gene, gen2, dataset, g1, g2) if (g1 < KNOWN) then g1=MISS g2=MISS end if if (.not.xlinkd) then call wrgtp(g1, g2, gtp, '/', '', 1) else call wrgtp(g1, 0, gtp, '/', '', 1) end if lin(23:29)=gtp call get_geno(currm, gene, gen2, dataset, g1, g2) if (g1 < KNOWN) then g1=MISS g2=MISS end if call wrgtp(g1, g2, gtp, '/', '', 1) lin(43:49)=gtp write(outstr,'(a)') lin(1:49) lin=' ' write(outstr,'(25x,a1,19x,a1/25x,a21/35x,a1)') '|','|','+=========+=========+','|' ! ! then the children ! nsibs=fin-sta+1 if (nsibs == 1) then call wrid('c',dataset%id(sta),chid,dataset%sex(sta)) call get_geno(sta, gene, gen2, dataset, g1, g2) if (g1 < KNOWN) then g1=MISS g2=MISS end if if (xlinkd .and. dataset%sex(sta)==1) then call wrgtp(g1, 0, gtp, '/', '', 1) else call wrgtp(g1, g2, gtp, '/', '', 1) end if write(outstr,'(35x,a1/31x,a10/32x,a7)') '|',chid,gtp else if (nsibs > wide) then do i=sta, fin call get_geno(i, gene, gen2, dataset, g1, g2) if (g1 < KNOWN) then g1=MISS g2=MISS end if if (xlinkd .and. dataset%sex(i)==1) then call wrgtp(g1, 0, gtp, '/', '', 1) else call wrgtp(g1, g2, gtp, '/', '', 1) end if write(outstr,'(28x,a8,1x,a7)') dataset%id(i),gtp end do else leftm=max(3,38-5*nsibs) pos=leftm+3 do i=1,nsibs-1 lin(pos:pos+10)='+---------+' pos=pos+10 end do lin(36:36)='+' write(outstr,'(a)') lin(1:pos) lin=' ' pos=leftm+3 do i=1,nsibs lin(pos:pos)='|' pos=pos+10 end do write(outstr,'(a)') lin(1:pos) lin=' ' pos=leftm-1 do i=sta, fin call wrid('c',dataset%id(i), chid, dataset%sex(i)) lin(pos:pos+9)=chid pos=pos+10 end do write(outstr,'(a)') lin(1:pos) lin=' ' pos=leftm do i=sta, fin call get_geno(i, gene, gen2, dataset, g1, g2) if (g1 < KNOWN) then g1=MISS g2=MISS end if if (xlinkd .and. dataset%sex(i)==1) then call wrgtp(g1, 0, gtp, '/', '', 1) else call wrgtp(g1, g2, gtp, '/', '', 1) end if lin(pos:pos+6)=gtp pos=pos+10 end do write(outstr,'(a)') lin(1:pos) end if write(outstr,*) end subroutine describe ! ! Write out phenoset for a nuclear family (plus grandparents and halfsibs) ! Useful in detecting sources of long distance Mendelian inconsistencies. ! subroutine famset(ped, dataset, currf, currm, sta, fin, gene, set, gset) use outstream use ped_class integer, intent(in) :: ped type (ped_data) :: dataset integer, intent(in) :: currf integer, intent(in) :: currm integer, intent(in) :: sta integer, intent(in) :: fin integer, intent(in) :: gene integer, intent(in) :: set(:,:) integer, intent(in) :: gset(:,:,:) ! integer, parameter :: KNOWN=0, MISS=-9999 integer :: g1, g2, gen2, gfa, gmo, i, ngeno integer :: num, pedoffset logical :: found ! functions interface function allinset(idx, iall, ngeno, gset) logical :: allinset integer, intent(in) :: idx integer, intent(in) :: iall integer, intent(in) :: ngeno integer, intent(in) :: gset(:,:,:) end function allinset subroutine indset(idx, gene, pedoffset, dataset, set, gset) use ped_class integer, intent(in) :: idx integer, intent(in) :: gene integer, intent(in) :: pedoffset type (ped_data) :: dataset integer, intent(in) :: set(:,:) integer, intent(in) :: gset(:,:,:) end subroutine subroutine cntbad(idx, ngeno, gset) integer, intent(in) :: idx integer, intent(out) :: ngeno integer, intent(in) :: gset(:,:,:) end subroutine end interface ! pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset gen2=gene+1 ! write(outstr,'(a/a)') 'ID Count Problem phenosets', & '---------- -------- -----------------' ! Grandparental phenosets if (dataset%fa(pedoffset+currf) /= MISS) then write(outstr,'(/a)') 'Paternal Gparents' call indset(dataset%fa(pedoffset+currf)-pedoffset, gene, pedoffset, dataset, set, gset) call indset(dataset%mo(pedoffset+currf)-pedoffset, gene, pedoffset, dataset, set, gset) end if if (dataset%fa(pedoffset+currm) /= MISS) then write(outstr,'(/a)') 'Maternal Gparents' call indset(dataset%fa(pedoffset+currm)-pedoffset, gene, pedoffset, dataset, set, gset) call indset(dataset%mo(pedoffset+currm)-pedoffset, gene, pedoffset, dataset, set, gset) end if ! Uncles and aunts phenosets if (dataset%fa(pedoffset+currf) /= MISS) then gfa=dataset%fa(pedoffset+currf) gmo=dataset%mo(pedoffset+currf) found=.false. do i=dataset%nfound(ped)+1, num if (dataset%fa(pedoffset+i) == gfa .and. & dataset%mo(pedoffset+i) == gmo .and. i /= currf) then if (.not.found) then write(outstr,'(/a)') 'Paternal Uncles/Aunts' found=.true. end if call indset(i, gene, pedoffset, dataset, set, gset) end if end do end if if (dataset%fa(pedoffset+currm) /= MISS) then gfa=dataset%fa(pedoffset+currm) gmo=dataset%mo(pedoffset+currm) found=.false. do i=dataset%nfound(ped)+1, num if (dataset%fa(pedoffset+i) == gfa .and. & dataset%mo(pedoffset+i) == gmo .and. i /= currm) then if (.not.found) then write(outstr,'(/a)') 'Maternal Uncles/Aunts' found=.true. end if call indset(i, gene, pedoffset, dataset, set, gset) end if end do end if ! Parental phenosets write(outstr,'(/a)') 'Father' call indset(currf, gene, pedoffset, dataset, set, gset) write(outstr,'(/a)') 'Mother' call indset(currm, gene, pedoffset, dataset, set, gset) ! Sibship phenosets write(outstr,'(/a)') 'Children' do i=sta, fin call indset(i, gene, pedoffset, dataset, set, gset) end do ! Half-sib phenosets found=.false. do i=dataset%nfound(ped)+1, num if (dataset%fa(pedoffset+i) == pedoffset+currf .and. & dataset%mo(pedoffset+i) /= pedoffset+currm) then if (.not.found) then write(outstr,'(/a)') 'Paternal Half-sibs' found=.true. end if call indset(i, gene, pedoffset, dataset, set, gset) end if end do found=.false. do i=dataset%nfound(ped)+1, num if (dataset%fa(pedoffset+i) /= pedoffset+currf .and. & dataset%mo(pedoffset+i) == pedoffset+currm) then if (.not.found) then write(outstr,'(/a)') 'Maternal Half-sibs' found=.true. end if call indset(i, gene, pedoffset, dataset, set, gset) end if end do write(outstr,*) ! ! See if single allele might explain inconsistency between untyped parent ! and offspring ! do i=sta, fin if (.not.missing(pedoffset+i, gene, dataset)) then call get_geno(pedoffset+i, gene, gen2, dataset, g1, g2) if (set(currf,1) == 0) then call cntbad(currf, ngeno, gset) if (.not.allinset(currf, g1, ngeno, gset)) then call wroddall(dataset%pedigree(ped), & dataset%id(pedoffset+currf), dataset%id(pedoffset+i), g1, & observed(pedoffset+currf, gene, dataset)) end if if (.not.allinset(currf,g2,ngeno,gset)) then call wroddall(dataset%pedigree(ped), & dataset%id(pedoffset+currf), dataset%id(pedoffset+i), g2, & observed(pedoffset+currf, gene, dataset)) end if end if if (set(currm,1) == 0) then call cntbad(currm,ngeno,gset) if (.not.allinset(currm,g1,ngeno,gset)) then call wroddall(dataset%pedigree(ped), & dataset%id(pedoffset+currm), dataset%id(pedoffset+i), g1, & observed(pedoffset+currm, gene, dataset)) end if if (.not.allinset(currm,g2,ngeno,gset)) then call wroddall(dataset%pedigree(ped), & dataset%id(pedoffset+currm), dataset%id(pedoffset+i), g2, & observed(pedoffset+currm, gene, dataset)) end if end if end if end do write(outstr,*) end subroutine famset ! ! write out phenoset for an individual ! subroutine indset(idx, gene, pedoffset, dataset, set, gset) use outstream use ped_class integer, intent(in) :: idx integer, intent(in) :: gene integer, intent(in) :: pedoffset type (ped_data) :: dataset integer, intent(in) :: set(:,:) integer, intent(in) :: gset(:,:,:) ! integer, parameter :: MISS=-9999 integer :: g1, g2, idx2, j, ngeno character (len=7) :: gtp interface subroutine cntbad(idx, ngeno, gset) integer, intent(in) :: idx integer, intent(out) :: ngeno integer, intent(in) :: gset(:,:,:) end subroutine cntbad end interface idx2=pedoffset+idx if (.not.missing(idx2, gene, dataset)) then call get_geno(idx2, gene, gene+1, dataset, g1, g2) call wrgtp(g1, g2, gtp, '/', '', 1) gtp=adjustl(gtp) write(outstr,'(a10,1x,a8,1x,a)') dataset%id(idx2), 'Typed', trim(gtp) else if (set(idx,1) == 0) then call cntbad(idx, ngeno, gset) write(outstr,'(a10,1x,a8)', advance='no') dataset%id(idx2), 'Problem' do j=1, min(ngeno, 7) call wrgtp(gset(idx,j,1), gset(idx,j,2), gtp, '/', '', 1) write(outstr, '(1x,a)', advance='no') trim(adjustl(gtp)) end do write(outstr,*) else ngeno=set(idx,1) write(outstr,'(a10,1x,i8)', advance='no') dataset%id(idx2), ngeno do j=1, min(ngeno, 7) call wrgtp(gset(idx,j,1), gset(idx,j,2), gtp, '/', '', 1) write(outstr, '(1x,a)', advance='no') trim(adjustl(gtp)) end do write(outstr,*) end if end subroutine indset ! ! see if particular allele in phenoset for idx person ! function allinset(idx, iall, ngeno, gset) logical :: allinset integer, intent(in) :: idx integer, intent(in) :: iall integer, intent(in) :: ngeno integer, intent(in) :: gset(:,:,:) ! integer :: i allinset=.true. do i=1, ngeno if (gset(idx,i,1) == iall .or. gset(idx,i,2) == iall) then return end if end do ! else if not found allinset=.false. end function allinset ! ! If phenoset contains zero legal genotypes, reconstruct last state ! subroutine cntbad(idx, ngeno, gset) integer, intent(in) :: idx integer, intent(out) :: ngeno integer, intent(in) :: gset(:,:,:) integer :: i do i=1, size(gset, 2) if (gset(idx,i,1) == 0) then ngeno=i-1 return end if end do ngeno=0 end subroutine cntbad ! ! If find an odd-allele-out, write out its location ! subroutine wroddall(pedigree, parent, child, iall, partyp) use outstream use idstring_widths character (len=ped_width), intent(in) :: pedigree character (len=id_width), intent(in) :: parent character (len=id_width), intent(in) :: child integer, intent(in) :: iall logical, intent(in) :: partyp character (len=3) :: allel call wrall(iall, allel) allel=adjustl(allel) if (partyp) then write(outstr,'(11a)') 'Parent ', trim(pedigree),'-', & trim(parent), ' does not carry the "', & trim(allel), '" allele found in child ', trim(pedigree), '-', trim(child), '.' else write(outstr,'(11a)') 'Parent ', trim(pedigree),'-', & trim(parent), ' cannot carry the "', & trim(allel), '" allele found in child ', trim(pedigree), '-', trim(child),'.' end if end subroutine wroddall ! ! If Lange-Goradia algorithm not used, initialize genotypes for random walk ! algorithms via a conditional gene dropping algorithm ! subroutine start(maxtry, nloci, loc, loctyp, locpos, dataset, allele_buffer, & inconsist, plevel) use outstream use ped_class use alleles_class use locus_types implicit none integer, intent(in) :: maxtry integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data) :: dataset type (allele_data), intent(inout) :: allele_buffer integer, intent(inout) :: inconsist integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS=-9999 ! workspace for locally pointing parental indicators integer, dimension(dataset%maxsiz) :: fa, mo, imztwin ! workspaces for genotypes, ibd, founder alleles integer, dimension(dataset%maxsiz,2) :: set, sibd integer, dimension(2*dataset%maxsiz) :: key ! pointer to person causing failure for that pedigree integer failid ! other local variables integer fin, g1, gene, gen2, i, j, num, nfound, pedoffset, ped, sta logical xlinkd interface subroutine dattoset(sta,fin,gene,dataset,allele_buffer,set) use alleles_class use ped_class integer, intent(in) :: sta, fin integer, intent(in) :: gene type (ped_data) :: dataset type (allele_data), intent(inout) :: allele_buffer integer, dimension(:,:), intent(inout) :: set end subroutine end interface interface subroutine startone(maxtry, allele_buffer, num, nfound, & fa, mo, sex, set, sibd, key, failid, plevel) use alleles_class integer, intent(in) :: maxtry type (allele_data), intent(inout) :: allele_buffer integer, intent(in) :: num, nfound integer, dimension(:), intent(inout) :: fa, mo integer, dimension(:), intent(inout) :: sex integer, dimension(:,:), intent(inout) :: set, sibd integer, dimension(:), intent(inout) :: key integer, intent(inout) :: failid integer, intent(in) :: plevel end subroutine end interface interface subroutine fillin(allele_buffer, num, nfound, set, sibd, key, sta, fin, gene, dataset) use alleles_class use ped_class type (allele_data), intent(inout) :: allele_buffer integer, intent(in) :: num, nfound integer, dimension(:,:), intent(inout) :: set integer, dimension(:,:), intent(inout) :: sibd integer, dimension(:), intent(inout) :: key integer, intent(in) :: sta, fin integer, intent(in) :: gene type (ped_data) :: dataset end subroutine fillin end interface do j=1, nloci if (isactdip(loctyp(j))) then xlinkd=same_loctyp(loctyp(j), LOC_XLIN) gene=locpos(j) gen2=gene+1 call freq(gene, loctyp(j), 0, dataset, allele_buffer) if (allele_buffer%numal <= 1) then if (allele_buffer%numal == 1) then g1= -allele_buffer%allele_names(1) do i=1, dataset%nobs if (.not.observed(i, gene, dataset)) then call set_geno(i, gene, gen2, dataset, g1, g1) end if end do else g1= -1 do i=1, dataset%nobs call set_geno(i, gene, gen2, dataset, g1, g1) end do end if else do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) sta=pedoffset+1 fin=dataset%num(ped) num=fin-pedoffset nfound=dataset%nfound(ped) call workpointers(ped, dataset, fa, mo, imztwin) call dattoset(sta, fin, gene, dataset, allele_buffer, set) call startone(maxtry, allele_buffer, num, nfound, & fa, mo, dataset%sex(sta:fin), & set, sibd, key, failid, plevel) if (failid /= MISS) then write(outstr,'(4a/7x,3a,3(/7x,a)/)') & 'ERROR: Unable to generate starting genotypes at locus ', & trim(loc(j)), ' for pedigree ', trim(dataset%pedigree(ped)), & 'due to parent(s) of individual ', trim(dataset%id(failid)), '.', & 'This is either due to a Mendelian inconsistency, ', & 'or because the pedigree is very large,', & 'in which case it may disappear if the job is rerun.' inconsist=inconsist+1 else call fillin(allele_buffer, num, nfound, & set, sibd, key, sta, fin, gene, dataset) end if end if end do end if end if end do end subroutine start ! ! make parental pointers offset for local work array ! subroutine workpointers(ped, dataset, fa, mo, imztwin) use ped_class implicit none integer, intent(in) :: ped type (ped_data) :: dataset integer, dimension(dataset%maxsiz), intent(out) :: fa, mo, imztwin integer :: i, ii, pedoffset integer, parameter :: MISS=-9999 do i=1, dataset%nfound(ped) fa(i)=MISS mo(i)=MISS imztwin(i)=MISS end do ii=dataset%nfound(ped) pedoffset=dataset%num(ped-1) do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped) ii=ii+1 fa(ii)=dataset%fa(i)-pedoffset mo(ii)=dataset%mo(i)-pedoffset if (dataset%imztwin(i) /= MISS) then imztwin(ii)=dataset%imztwin(i)-pedoffset else imztwin(ii)=MISS end if end do end subroutine workpointers ! ! transfer genotypes to working array ! subroutine dattoset(sta, fin, gene, dataset, allele_buffer, set) use alleles_class use ped_class integer, intent(in) :: sta, fin integer, intent(in) :: gene type (ped_data) :: dataset type (allele_data), intent(inout) :: allele_buffer integer, dimension(:,:), intent(inout) :: set integer, parameter :: KNOWN=0 integer, parameter :: MISS=-9999 integer :: g1, g2, gen2, i, pos gen2=gene+1 pos=0 do i=sta, fin pos=pos+1 if (.not.observed(i, gene, dataset)) then set(pos,1)=MISS set(pos,2)=MISS else call get_namedgeno(i, gene, gen2, dataset, allele_buffer, & set(pos,1), set(pos,2)) if (set(pos,1)==MISS .or. set(pos,2)==MISS) then write(*,*) dataset%pedigree(dataset%iped(i)),dataset%id(i), & set(pos,1), set(pos,2) end if end if end do end subroutine dattoset ! ! start genotypes for one pedigree ! subroutine startone(maxtry, allele_buffer, num, nfound, & fa, mo, sex, set, sibd, key, failid, plevel) use outstream use alleles_class integer, intent(in) :: maxtry type (allele_data), intent(inout) :: allele_buffer integer, intent(in) :: num integer, intent(in) :: nfound integer, dimension(:), intent(inout) :: fa integer, dimension(:), intent(inout) :: mo integer, dimension(:), intent(inout) :: sex ! marker genotype integer, dimension(:,:), intent(inout) :: set ! ibd integer, dimension(:,:), intent(inout) :: sibd ! founder allele integer, dimension(:), intent(inout) :: key integer, intent(inout) :: failid integer, intent(in) :: plevel integer, parameter :: MISS=-9999 ! local variables integer :: found, i, restart logical :: fin, xmale interface subroutine genof3(idx, fa, mo, xmale, set, sibd, key, failid) integer, intent(in) :: idx integer, intent(in) :: fa integer, intent(in) :: mo logical, intent(in) :: xmale integer, dimension(:,:), intent(inout) :: set integer, dimension(:,:), intent(inout) :: sibd integer, dimension(:), intent(inout) :: key integer, intent(out) :: failid end subroutine end interface found=0 failid=MISS do i=1,nfound found=found+1 sibd(i,1)=found found=found+1 sibd(i,2)=found end do ! ! start of loop -- terminated by either a successful simulation ! of ibd, or bailout due <maxtry> iterations without success ! restart=1 main: do while (restart <= maxtry) found=0 do i=1,nfound found=found+1 key(found)=set(i,1) found=found+1 key(found)=set(i,2) end do do i=nfound+1,num sibd(i,1)=MISS sibd(i,2)=MISS end do do fin=.true. do i=nfound+1, num if (sibd(i,1) == MISS) then if (sibd(fa(i),1) /= MISS .and. sibd(mo(i),1) /= MISS) then xmale=(allele_buffer%xlinkd .and. sex(i) /= 2) call genof3(i, fa(i), mo(i), xmale, set, sibd, key, failid) if (failid /= MISS) then if (plevel > 1) then write(outstr,*) 'Trial ', restart, ' failed due to indiv ', failid end if restart=restart+1 cycle main end if else fin=.false. end if end if end do if (fin) return end do end do main end subroutine startone ! ! Drop ibd-alleles conditional on observed markers ! and randomly where marker genotype not observed -- restart ! if later generates inconsistency ! subroutine genof3(idx, fa, mo, xmale, set, sibd, key, failid) use rngs integer, intent(in) :: idx integer, intent(in) :: fa integer, intent(in) :: mo logical, intent(in) :: xmale integer, dimension(:,:), intent(inout) :: set integer, dimension(:,:), intent(inout) :: sibd integer, dimension(:), intent(inout) :: key integer, intent(out) :: failid integer, parameter :: MISS=-9999 integer :: a1, a2, first, i, maxtrials, second, tr1, tr2, trials ! ! sample without replacement from {{1,2},{1,2},{1,2}} integer :: choice, seed integer, dimension(8) :: sspace failid=MISS maxtrials=8 trials=0 do i=1, maxtrials sspace(i)=i end do ! ! emits the 8 possible ibd constellations in random order ! 1 continue trials=trials+1 choice=irandom(trials, maxtrials) seed=sspace(choice) sspace(choice)=sspace(trials) tr1=iand(seed,4)/4+1 tr2=iand(seed,2)/2+1 first=iand(seed,1)+1 second=3-first a1=sibd(fa,tr1) a2=sibd(mo,tr2) if (xmale) a1=a2 ! ! first filter ! if (a1 == a2 .and. set(idx,1) /= set(idx,2)) then if (trials < maxtrials) go to 1 failid=idx return end if ! ! second filter: meets one of six legal scenarios ! if (set(idx,1) == MISS) then sibd(idx,1)=a1 sibd(idx,2)=a2 else if (key(a1) == MISS .and. key(a2) == MISS) then key(a1)=set(idx,first) key(a2)=set(idx,second) sibd(idx,1)=a1 sibd(idx,2)=a2 else if (key(a1) == MISS .and. & (set(idx,1) == key(a2) .or. set(idx,2) == key(a2))) then if (set(idx,1) == key(a2)) then key(a1)=set(idx,2) sibd(idx,1)=a2 sibd(idx,2)=a1 else key(a1)=set(idx,1) sibd(idx,1)=a1 sibd(idx,2)=a2 end if else if (key(a2) == MISS .and. & (set(idx,1) == key(a1) .or. set(idx,2) == key(a1))) then if (set(idx,1) == key(a1)) then key(a2)=set(idx,2) sibd(idx,1)=a1 sibd(idx,2)=a2 else key(a2)=set(idx,1) sibd(idx,1)=a2 sibd(idx,2)=a1 end if else if (set(idx,1) == key(a1) .and. set(idx,2) == key(a2)) then sibd(idx,1)=a1 sibd(idx,2)=a2 else if (set(idx,1) == key(a2) .and. set(idx,2) == key(a1)) then sibd(idx,1)=a2 sibd(idx,2)=a1 else if (trials < maxtrials) then go to 1 else failid=idx end if end subroutine genof3 ! ! infer missing genotypes based on sibd values after run of start ! subroutine fillin(allele_buffer, num, nfound, set, sibd, key, & sta, fin, gene, dataset) use alleles_class use ped_class type (allele_data), intent(inout) :: allele_buffer integer, intent(in) :: num, nfound integer, dimension(:,:), intent(inout) :: set integer, dimension(:,:), intent(inout) :: sibd integer, dimension(:), intent(inout) :: key integer, intent(in) :: sta, fin integer, intent(in) :: gene type (ped_data) :: dataset integer, parameter :: KNOWN=0, MISS=-9999 ! local variables integer :: g1, g2, gen2, i, j, pos, tmp interface subroutine found(cumfrq, allele) double precision, dimension(:), intent(in) :: cumfrq integer, intent(out) :: allele end subroutine end interface gen2=gene+1 do j=1, 2*nfound if (key(j) == MISS) then do i=1, num if (sibd(i,1) == j .and. set(i,1) /= MISS) then key(j)=set(i,1) exit else if (sibd(i,2) == j .and. set(i,2) /= MISS) then key(j)=set(i,2) exit end if end do if (key(j) == MISS) then call found(allele_buffer%cum_freqs, g1) key(j)=g1 end if end if end do pos=0 do i=sta, fin pos=pos+1 if (set(pos,1) == MISS) then g1=allele_buffer%allele_names(key(sibd(pos,1))) g2=allele_buffer%allele_names(key(sibd(pos,2))) call order(g1, g2) call set_geno(i, gene, gen2, dataset, -g1, -g2) end if end do end subroutine fillin ! ! founder frequency ! subroutine found(cumfrq, allele) use rngs double precision, dimension(:), intent(in) :: cumfrq integer, intent(out) :: allele real :: x x=random() allele=1 do while (x > cumfrq(allele)) allele=allele+1 end do end subroutine found ! ! Give count of individuals typed at one phenotype ! subroutine countp(trait, dataset, typed) use ped_class use locus_types integer, intent(in) :: trait type (ped_data) :: dataset integer, intent(out) :: typed ! local variables integer :: i, ped integer, parameter :: MISS=-9999 typed=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (dataset%plocus(i,trait) /= MISS) typed=typed+1 end do end if end do end subroutine countp ! ! Give counts of typed individuals for each locus ! subroutine coutyp(nloci, loctyp, locpos, dataset, eligible, typed) use ped_class use locus_types integer, intent(in) :: nloci integer, intent(in) :: loctyp(:) integer, intent(in) :: locpos(:) type (ped_data) :: dataset integer, intent(out) :: eligible integer, intent(out) :: typed(:) ! local variables integer :: i, ind1, indn, j, ltyp, ped integer, parameter :: KNOWN=0, MISS=-9999 eligible=0 do j=1, nloci typed(j)=0 end do indn=0 do ped=1, dataset%nped ind1=1+indn indn=dataset%num(ped) ! Count observed alleles and skip if none if (dataset%actset(ped) > 0) then eligible=eligible+indn-ind1+1 !$OMP PARALLEL DO do j=1, nloci if (ismarker(loctyp(j))) then do i=ind1, indn if (observed(i, locpos(j), dataset)) typed(j)=typed(j)+1 end do else if (.not.isspecial(loctyp(j))) then do i=ind1, indn if (dataset%plocus(i,locpos(j)) /= MISS) typed(j)=typed(j)+1 end do end if end do !$OMP END PARALLEL DO end if end do end subroutine coutyp ! ! Xu and Fu 2004 correction for thetaf=4Nu=1/2(1/F^2-1) ! where F is the observed homozygosity for the locus is: ! 1/2 (1/F^2-1) = a thetaf + b sqrt(thetaf) ! where ! thetaf <=10 >10 ! a 1.1313+3.4882/n+28.2878/n^2ltyp, 1.1675+3.3232/n+63.698/n^2 ! b 0.3998 0.2569 ! function thetaf(het, n) double precision :: thetaf double precision, intent(in) :: het integer, intent(in) :: n double precision :: a, b2, th th=1.0d0-het th=0.5d0*(1/(th*th)-1.0d0) if (th <= 10.0d0) then a=1.1313d0+3.4882d0/dble(n)+28.2878d0/dble(n*n) b2=0.15984004d0 else a=1.1675d0+3.3232d0/dble(n)+63.698d0/dble(n*n) b2=0.06599761d0 end if thetaf=(b2+sqrt(b2*(4.0d0*a*th+b2)))/(2.0d0*a**2) + th/a ! thetaf=(b2-sqrt(b2*(4.0d0*a*th+b2)))/(2.0d0*a**2) + th/a end function thetaf ! ! Age of an allele (Ohta, Nei, Rannala & Slatkin) ! subroutine mutage(p, ne, r) use outstream double precision, intent(in) :: p double precision, intent(in) :: ne double precision, intent(in) :: r if (r == 0.0d0) then write(outstr,'(a,f10.1)') 'Kimura & Ohta (1973) g = ', -4 * ne * p/(1.0d0-p) * log(p) write(outstr,'(a,f10.1)') 'Rannala & Slatkin (1997) g = ', 2 * ne * p else write(outstr,'(a,f10.1)') 'Rannala & Slatkin (1997) g = ', log(2 * ne * p * r + 1)/r end if end subroutine mutage ! ! Calculate variances for a given SML model ! subroutine qtlpars(p,m1,m2,m3,sd1,sd2,sd3) use outstream double precision, intent(in) :: p double precision, intent(in) :: m1 double precision, intent(in) :: m2 double precision, intent(in) :: m3 double precision, intent(in) :: sd1 double precision, intent(in) :: sd2 double precision, intent(in) :: sd3 integer :: i double precision :: expx, iqr, h2, midp, mu,q, sd, va,vd,ve,vt q=1.0D0-p mu=p*p*m1+2*q*p*m2+q*q*m3 va=2*p*q*(p*(m1-m2)+q*(m2-m3))**2 vd=p*p*q*q*(m1-2*m2+m3)**2 ve=p*p*sd1*sd1 + 2*p*q*sd2*sd2 + q*q*sd3*sd3 vt=va+vd+ve sd=sqrt(vt) h2=(va+vd)/vt write(outstr,'(/a,f5.3/a/a,3(4x,f5.3,4x),2(/a,3(1x,f12.6)))') & 'A allele frequency = ', p, & 'Genotypes = A/A A/B B/B', & 'Genotype frequencies = ', p*p, 2*p*q, q*q, & 'Genotypic means =', m1, m2, m3, & 'Genotypic SDs =', sd1, sd2, sd3 write(outstr,'(/a,f12.6,a,f12.6,a/a,3(1x,f12.6)/a,5x,f5.3)') & 'Expected trait mean (SD) = ', mu, ' (',sd,')', & 'Variances (A, D, E) =', va, vd, ve, & 'Broad heritability =', h2 midp=mu-4*sd h2=va/vt iqr=0.67449D0*vt*(1.0D0-0.5D0*h2*h2) write(outstr,'(/a/a)') ' Midparent E(Child) Expected IQR', & ' ----------- ------------ -------------------------' do i=1, 7 midp=midp+sd expx= mu+h2*(midp-mu) write(outstr,'(f12.4,3(1x,f12.4))') midp, expx, expx-iqr, expx+iqr end do return end subroutine qtlpars ! ! Calculate penetrances for a particular prevalence and ! case and control allele frequencies, assuming multiplicative model ! Controls are unaffected (1), or population (2) ! subroutine ccpen(prev, pca, pco, typ) double precision, intent(in) :: prev double precision, intent(in) :: pca double precision, intent(in) :: pco integer, intent(in) :: typ double precision :: f1, f2, f3, grr, p, q q=pco if (typ == 1) q=pca*prev + pco*(1.0d0-prev) p=1.0d0-q grr=pca*p/q/(1.0d0-pca) f3=prev/(q*grr*(q*grr + p + p) + p*p) f2=grr*f3 f1=grr*f2 call recrisk(q,f1,f2,f3) end subroutine ccpen ! ! Calculate penetrances for a particular prevalence and genotypic RR ! subroutine grrpen(model, prev, q, grr) character (len=3), intent(in out) :: model double precision, intent(in) :: prev double precision, intent(in) :: q double precision, intent(in) :: grr double precision :: f1, f2, f3, p, r r=1.0d0/grr p=1.0d0-q ! recessive if (model == 'rec') then f1 = prev/((q*(q+(2.0d0*p*r)))+(p*p*r)) f2 = r*f1 f3 = f2 ! additive else if (model == 'add') then f1 = prev/((q*(q+(2.0d0*p*r)))+((p*r)**2)) f2 = r*f1 f3 = r*f2 ! dominant else f1 = prev/((q*(q+(p+p)))+((p*p)*r)) f2 = f1 f3 = r * f1 end if if (f1 < 0.0d0) f1=0.0d0 if (f2 < 0.0d0) f2=0.0d0 if (f3 < 0.0d0) f3=0.0d0 if (f1 > 1.0d0) f1=1.0d0 if (f2 > 1.0d0) f2=1.0d0 if (f3 > 1.0d0) f3=1.0d0 call recrisk(q,f1,f2,f3) end subroutine grrpen ! ! Calculate recurrence risks and risk ratios for given SML model ! subroutine recrisk(q,f1,f2,f3) use outstream double precision, intent(in) :: q double precision, intent(in) :: f1 double precision, intent(in) :: f2 double precision, intent(in) :: f3 double precision :: p, qa, qu integer :: rel,ii,jj double precision :: r(3,3),a(3),b(3) double precision :: riska(4),risku(4),rr(4) double precision :: ff(3),kp,kq,va,vd,oddsr(4),mating(3),pap ! functions double precision :: tetcor p=1.0d0-q kp=q*q*f1+2.0d0*p*q*f2+p*p*f3 kq=1.0d0-kp qa=(q*q*f1+q*(1-q)*f2)/kp qu=(q*q*(1.0d0-f1)+q*p*(1.0d0-f2))/kq a(1)=q*q*f1/kp a(2)=2*p*q*f2/kp a(3)=p*p*f3/kp b(1)=q*q*(1.0d0-f1)/kq b(2)=2*p*q*(1.0d0-f2)/kq b(3)=p*p*(1.0d0-f3)/kq do rel=1, 4 call ito(rel, q, r) riska(rel)=0.0d0 risku(rel)=0.0d0 ff(1)=f1*r(1,1)+f2*r(1,2)+f3*r(1,3) ff(2)=f1*r(2,1)+f2*r(2,2)+f3*r(2,3) ff(3)=f1*r(3,1)+f2*r(3,2)+f3*r(3,3) do ii=1,3 riska(rel)=riska(rel)+ff(ii)*a(ii) risku(rel)=risku(rel)+ff(ii)*b(ii) end do if (risku(rel) <= 0.0d0) then rr(rel)=9999.9d0 oddsr(rel)=9999.9d0 else if (riska(rel)/risku(rel) > 10000.0d0) then rr(rel)=9999.9d0 oddsr(rel)=9999.9d0 else rr(rel)=riska(rel)/risku(rel) oddsr(rel)=riska(rel)/(1.0d0-riska(rel))* (1.0d0-risku(rel))/risku(rel) end if end if end do va=2*q*p*(q*(f1-f2)+p*(f2-f3))**2 vd=q*q*p*p*(f1-2.0d0*f2+f3)**2 mating(1)=qu*qu*f1+2.0d0*(1.0d0-qu)*qu*f2+(1.0d0-qu)*(1.0d0-qu)*f3 mating(2)=qa*qu*f1+((1.0d0-qu)*qa+ (1.0d0-qa)*qu)*f2+(1.0d0-qa)*(1.0d0-qu)*f3 mating(3)=qa*qa*f1+2.0d0*(1.0d0-qa)*qa*f2+(1.0d0-qa)*(1.0d0-qa)*f3 pap=100.d0*(1.0d0-min(f1,f2,f3)/kp) write(outstr,993) q,f1,f2,f3 write(outstr,994) kp,pap,va,vd write(outstr,995) write(outstr,996) & 'Rec Risk', riska(1), riska(2), riska(3), riska(4), & 'Rel Risk', rr(1), rr(2), rr(3), rr(4), & 'Odds Rat', oddsr(1), oddsr(2), oddsr(3), oddsr(4), & 'PRR ', riska(1)/kp, riska(2)/kp,riska(3)/kp,riska(4)/kp, & 'Tet Corr', tetcor(kp, riska(1)/kp), tetcor(kp, riska(2)/kp), & tetcor(kp, riska(3)/kp), tetcor(kp, riska(4)/kp) write(outstr,996) & 'ibd|A-A ', 1.0, 0.25*(riska(1)+riska(3))/riska(2), & 0.5, 0.5*riska(3)/(riska(3)+kp), & 'ibd|A-U ', 1.0, (0.5-0.25*(riska(1)+riska(3)))/(1.0-riska(2)), & 0.5, (0.25-0.25*riska(3))/(1.0-riska(4)) write(outstr,997) & qa, q*q*f1/kp, 2.0*q*(1.0-q)*f2/kp, (1.0-q)*(1.0-q)*f3/kp, & qu, q*q*(1.0-f1)/kq, 2.0*q*(1.0-q)*(1.0-f2)/kq, (1.0-q)*(1.0-q)*(1.0-f3)/kq write(outstr,998) (1.0-kp)**2,mating(1),2.0*kp*(1.0-kp), mating(2),kp*kp,mating(3) 993 format(/1X,'Frequency(A): ',f8.6,'; Pen(AA): ',f5.3, & '; Pen(AB): ',f5.3,'; Pen(BB): ',f5.3) 994 format( 1X,'Trait Prev : ',f8.6,'; Pop AR: ',f5.1, & '%; Var(Add): ',f8.6,'; Var(Dom): ',f8.6) 995 format(/1X,'Measure MZ Twin Sib-Sib Par-Off ', & ' Second '/ '---------- ---------- ---------- ---------', & ' ----------') 996 format((1X,a8,2X,4(1X,f11.3,2X))) 997 format(/1X,'Freq of A if Affected: ',f8.6, & ' (',f5.3,',',f5.3,',',f5.3,') '/1X,'Freq of A if Unaffctd: ', & f8.6,' (',f5.3,',',f5.3,',',f5.3,')') 998 format(/1X,'Mating Proportion Risk to offspring'/ & '---------- ----------- ------------------ '/ & 'UnA x UnA',2X,2(1X,f11.3,2X)/ 'Aff x UnA',2X,2(1X,f11.3,2X)/ & 'Aff x Aff',2X,2(1X,f11.3,2X)) end subroutine recrisk ! ! Calculate GPE for a relative: ITO method ! subroutine doito(typ, pars) use outstream integer, intent(in) :: typ double precision, dimension(8), intent(in) :: pars integer :: rel, ii, jj double precision :: p, q double precision, dimension(3) :: a double precision, dimension(3,13) :: r q=pars(1) if (q <= 0.0d0 .or. q >= 1.0d0) then q=0.5d0 end if p=1.0d0-q r(1,1)=q*q r(3,1)=p*p r(2,1)=1.0d0-r(1,1)-r(3,1) ii=2 do rel=2, 5 jj=ii+2 call ito(rel, q, r(1:3,ii:jj)) ii=ii+3 end do write(outstr,'(15x,a,11x,a,11x,a,8x,a)') & 'Sibling', 'Par-Off', '2nd degree', '3rd degree' write(outstr,'(2a)') 'Proband Freq A/A A/B B/B A/A A/B B/B', & ' A/A A/B B/B A/A A/B B/B' write(outstr,'(2a)') '------- ---- ----- ----- ----- ----- ----- -----', & ' ----- ----- ----- ----- ----- -----' if (typ==1) then write(outstr,'(a,f5.3,1x,12f6.3)') 'A/A ', r(1,1:13) write(outstr,'(a,f5.3,1x,12f6.3)') 'A/B ', r(2,1:13) write(outstr,'(a,f5.3,1x,12f6.3)') 'B/B ', r(3,1:13) else p=r(1,1)*pars(2)+r(2,1)*pars(3)+r(3,1)*pars(4) q=1.0d0-p write(outstr,'(a,f5.3,1x)', advance='no') 'Aff ', p do ii=1, 3 a(ii)=r(ii,1)*pars(1+ii)/p end do do ii=2, 13 write(outstr,'(f6.3)', advance='no') a(1)*r(1,ii) + a(2)*r(2,ii) + a(3)*r(3,ii) end do write(outstr,'(/a,f5.3,1x)', advance='no') 'UnA ', q do ii=1, 3 a(ii)=r(ii,1)*(1.0d0-pars(1+ii))/q end do do ii=2, 13 write(outstr,'(f6.3)', advance='no') a(1)*r(1,ii) + a(2)*r(2,ii) + a(3)*r(3,ii) end do write(outstr,*) end if end subroutine doito ! ! ITO calculation ! subroutine ito(rel, q, r) integer, intent(in) :: rel double precision, intent(in) :: q double precision, dimension(3,3), intent(out) :: r integer :: ii, jj double precision :: p double precision, dimension(3,3) :: i, t, o double precision, dimension(5) :: ci = (/1.0d0, 0.25d0, 0.0d0, 0.0d0, 0.0d0 /) double precision, dimension(5) :: ct = (/0.0d0, 0.5d0 , 1.0d0, 0.5d0, 0.25d0/) double precision, dimension(5) :: co = (/0.0d0, 0.25d0, 0.0d0, 0.5d0, 0.75d0/) p=1.0d0-q do ii=1,3 do jj=1,3 i(ii,jj)=0.0d0 t(ii,jj)=0.0d0 end do end do do ii=1, 3 i(ii,ii)=1.0d0 o(ii,1)=q*q o(ii,2)=2.0d0*q*p o(ii,3)=p*p end do t(1,1)=q t(3,2)=q t(1,2)=p t(3,3)=p t(2,1)=0.5d0*q t(2,2)=0.5d0 t(2,3)=0.5d0*p do ii=1, 3 do jj=1, 3 i(ii,jj)=i(ii,jj)*ci(rel) t(ii,jj)=t(ii,jj)*ct(rel) o(ii,jj)=o(ii,jj)*co(rel) r(ii,jj)=i(ii,jj)+t(ii,jj)+o(ii,jj) end do end do end subroutine ito ! ! MFT heritability ! Tetrachoric correlation for given prevalence and recurrence risk ratio ! function tetcor(prev, prrr) use outstream use statfuns use brent_mft double precision :: tetcor double precision, intent(in) :: prev, prrr ! functions double precision :: brent, brent_tet external :: brent_tet obsp=prev*prev*prrr dev=-ppnd(prev) tetcor=brent(0.0d0, 1.0d0, brent_tet, 1.0d-12) end function tetcor ! ! likelihood function for tetrachoric r ! function brent_tet(r) use statfuns use brent_mft double precision :: brent_tet double precision, intent(in) :: r double precision :: res res=obsp-mvbvu(dev, dev, r) brent_tet=res*res end function brent_tet ! ! Call tetcor for oberved recurrence counts and specified prevalence ! and return naive bounds under complete ascertainment ! subroutine tetcor_tab(ncon, ndis, prev, tetr, tetrlo, tetrhi) integer, intent(in) :: ncon, ndis double precision, intent(in) :: prev double precision, intent(out) :: tetr, tetrlo, tetrhi double precision :: p_hat, p_hi, p_lo, recr ! functions double precision :: tetcor recr=dble(2*ncon)/dble(2*ncon+ndis) tetr=tetcor(prev, recr/prev) call propci(ncon, ncon+ndis, 95.0d0, p_hat, p_lo, p_hi) p_lo=(p_lo+p_lo)/(1.0d0+p_lo) tetrlo=tetcor(prev, p_lo/prev) p_hi=(p_hi+p_hi)/(1.0d0+p_hi) tetrhi=tetcor(prev, p_hi/prev) end subroutine tetcor_tab ! ! Two-stage polychoric r - fixed thresholds ! subroutine polycor(nr, nc, tab, polyr, assocX2, modelX2) use outstream use statfuns use brent_mft integer, intent(in) :: nr, nc integer, dimension(nr,nc), intent(in) :: tab double precision, intent(out) :: polyr double precision, intent(out) :: assocX2, modelX2 integer, dimension(nr) :: rowtot integer, dimension(nc) :: coltot integer :: i, j, n, num double precision :: tot ! functions double precision :: brent, brent_polyr external :: brent_polyr assocX2=0.0d0 modelX2=0.0d0 polyr=0.0d0 obs_table_nr = nr obs_table_nc = nc allocate(row_thresh(nr), col_thresh(nc)) allocate(obs_table(nr, nc), obs_table_probs(nr, nc)) n=0 rowtot=0 coltot=0 do i=1, nr do j=1, nc n=n+tab(i,j) obs_table(i,j) = dble(tab(i,j)) rowtot(i)=rowtot(i)+tab(i,j) coltot(j)=coltot(j)+tab(i,j) end do end do tot=dble(n) obs_table_probs = obs_table/tot num=rowtot(1) row_thresh(1)=-99.0d0 do i=2, nr row_thresh(i)=ppnd(dble(num)/tot) num=num+rowtot(i) end do num=coltot(1) col_thresh(1)=-99.0d0 do j=2, nc col_thresh(j)=ppnd(dble(num)/tot) num=num+coltot(j) end do polyr=brent(-1.0d0, 1.0d0, brent_polyr, 1.0d-12) modelX2=2.0d0*brent_polyr(polyr) assocX2=2.0d0*brent_polyr(0.0d0)-modelX2 deallocate(row_thresh, col_thresh) deallocate(obs_table, obs_table_probs) end subroutine polycor ! ! Likelihood function for 1-dim ML estimation of polychoric r, ! fixed threshholds in module brent_mft ! function brent_polyr(r) use statfuns use brent_mft double precision :: brent_polyr double precision, parameter :: tol = 1.0d-6 double precision, intent(in) :: r double precision, dimension(obs_table_nr+1, obs_table_nc+1) :: cump integer :: i, j double precision :: e, lrts, rowcum cump=0.0d0 lrts=0.0d0 do i=obs_table_nr,1,-1 rowcum=0.0d0 do j=obs_table_nc,1,-1 cump(i,j)=mvbvu(row_thresh(i), col_thresh(j), r) e=cump(i,j) - rowcum - cump(i+1,j) rowcum=rowcum+e if (obs_table(i,j) > 0.0d0 .and. e > tol) then lrts=lrts+obs_table(i,j)*log(obs_table_probs(i,j)/e) end if end do end do brent_polyr=lrts end function brent_polyr ! ! size of pedigree structure ! #if SUN || OPEN64 || WIN32 || ALL_DOUBLEINT function dataset_uses(dataset) use idstring_widths use ped_class double precision :: dataset_uses type (ped_data) :: dataset dataset_uses=0.0d0 dataset_uses=dataset_uses + dble(16*size(dataset%iped)) dataset_uses=dataset_uses + dble(int(id_width)*size(dataset%id)) dataset_uses=dataset_uses + dble(8*size(dataset%plocus)) dataset_uses=dataset_uses + dble(2*size(dataset%glocus)) if (dataset%hassnps /= 0) then dataset_uses=dataset_uses + dble(matrix_size(dataset%slocus)) end if dataset_uses=dataset_uses + dble(int(ped_width)*size(dataset%pedigree)) dataset_uses=dataset_uses + dble(12*size(dataset%num)) dataset_uses=1.0d-6*dataset_uses end function dataset_uses #else function dataset_uses(dataset) use idstring_widths use ped_class double precision :: dataset_uses type (ped_data) :: dataset dataset_uses=0.0d0 dataset_uses=dataset_uses + dble(16*size(dataset%iped, kind=8)) dataset_uses=dataset_uses + dble(int(id_width, kind=8)*size(dataset%id, kind=8)) dataset_uses=dataset_uses + dble(8*size(dataset%plocus, kind=8)) dataset_uses=dataset_uses + dble(2*size(dataset%glocus, kind=8)) if (dataset%hassnps /= 0) then dataset_uses=dataset_uses + dble(matrix_size(dataset%slocus)) end if dataset_uses=dataset_uses + dble(int(ped_width, kind=8)*size(dataset%pedigree, kind=8)) dataset_uses=dataset_uses + dble(12*size(dataset%num, kind=8)) dataset_uses=1.0d-6*dataset_uses end function dataset_uses #endif ! ! Perform simple macro substitutions on contents of command buffer ! subroutine macsub(narg, words, commands, plevel) use outstream use rngs implicit none integer, intent(in) :: narg character (len=*), dimension(narg), intent(in) :: words character (len=*), intent(inout) :: commands integer, intent(in) :: plevel integer :: arglen, eos, extent, fin, i, iarg, pos, sta character (len=5) :: procid character (len=len_trim(commands)) :: restofline ! functions integer :: ival logical :: isreal call uniqnam(5, procid) if (plevel>1) then write(outstr,'(2a)') 'Macro procid=', procid do i=1, narg write(outstr,'(a,i3.3,3a)') 'arg', i, '="', trim(words(i)),'"' end do end if arglen=0 eos=len_trim(commands) pos=0 do while (pos < eos) pos=pos+1 ! write(*,*) pos, eos, commands(pos:pos) #if defined (WIN32) || defined (IFORT) || defined (NOESCAPE) if (commands(pos:pos)=='\') then #else if (commands(pos:pos)=='\\') then #endif pos=pos+1 else if (commands(pos:pos)=='%') then sta=pos+1 fin=sta if (sta <= eos) then arglen=5 if (commands(sta:sta)=='%' .and. (eos+fin-pos+2+arglen)<=len(commands)) then commands=commands(1:(pos-1)) // procid // commands((fin+1):eos) eos=eos-fin+pos-1+arglen pos=pos-3+arglen else extent=0 if (commands(sta:sta)=='+') then extent=1 sta=sta+1 fin=sta end if do while (ichar(commands(fin:fin))>47 .and. & ichar(commands(fin:fin))<58 .and. fin <= eos) fin=fin+1 end do fin=fin-1 ! write(*,*) extent, pos, eos, sta, fin, commands(sta:fin), ival(commands(sta:fin)) if (fin >= sta .and. isreal(commands(sta:fin))) then iarg=ival(commands(sta:fin))+1 if (iarg > 0) then if (iarg <= narg) then arglen=0 if (iarg == 1 .or. extent > 0) then extent=iarg if (iarg==1) extent=extent+1 do i=extent, narg arglen=arglen+len_trim(words(i))+1 end do if (narg >= extent) arglen=arglen-1 else arglen=len_trim(words(iarg)) end if if ((eos+fin-pos+2+arglen)>len(commands)) then write(outstr,'(a)',advance='no') 'ERROR: Substitution of "' if (extent > 0) then do i=extent, narg write(outstr,'(2a)',advance='no') trim(words(i)), ' ' end do else write(outstr,'(a)',advance='no') trim(words(iarg)) end if write(outstr,'(3a)') & '" for ', commands(pos:fin), ' causes an overflow.' commands=' ' return else restofline=commands(fin+1:eos) if (extent > 0) then commands=commands(1:pos-1) do i=extent, narg commands=trim(commands) // ' ' // trim(words(i)) end do else commands=commands(1:pos-1) // trim(words(iarg)) end if commands=trim(commands) // trim(restofline) eos=eos-fin+pos-1+arglen pos=pos-3+arglen ! write(*,*) 'Substituted ', words(iarg) ! write(*,*) eos, trim(commands) end if else if (plevel >= 0) then write(outstr,'(5a)') & 'NOTE: No value for ', commands(pos:fin), ' supplied.' end if commands=commands(1:pos-1) // commands(fin+1:eos) eos=eos-fin+pos-1 pos=pos-3 end if end if end if end if end if end if end do end subroutine macsub ! ! Expand an iterator list of tokens in a command ! These implicit loops are signalled by a list surrounded by braces ! Implemented as a naive immediate macro expansion so: ! ! {1 2} + 1 -> 1 + 1; 2 + 1 ! {1 : 3} -> 1;2;3 ! {1 2} + {1 2} -> 1 + {1 2}; 2 + {1 2} requiring further evaluation ! subroutine macloop(lin, nloci, loc, loctyp, commands, plevel) use outstream use scanner use locus_types implicit none character (len=*), intent(in) :: lin integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp character (len=*), intent(inout) :: commands integer, intent(in) :: plevel integer :: i, eol, fin, j, narg, rest, seq1, seq2, seqdir, sta integer :: big character (len=20), dimension(:), allocatable :: words character (len=256), dimension(:), allocatable :: bigwords character (len=256) :: token ! functions logical :: isint integer :: ival eol=len_trim(lin) i=1 sta=0 fin=0 do while (i <= eol) #if defined (WIN32) || defined (IFORT) || defined (NOESCAPE) if (lin(i:i)=='\') then #else if (lin(i:i)=='\\') then #endif i=i+1 continue else if (lin(i:i)=='{') then sta=i else if (sta > 0 .and. lin(i:i)=='}') then fin=i exit end if i=i+1 end do if (sta > 0 .and. fin > (sta+1)) then big=2 narg=countargs(lin((sta+1):(fin-1)), ' ', SEP_WHITE) allocate(bigwords(narg)) call args(lin((sta+1):(fin-1)), narg, bigwords, ' ', SEP_WHITE) ! Special treatment for a locus list -- expand first if *sole* iterator if (narg==1 .and. bigwords(1)(1:1)=='$') then big=1 j=0 j=loccode(bigwords(1)(2:2)) if (j > 0) then narg=0 do i=1, nloci if (same_loctyp(loctyp(i), j)) then narg=narg+1 end if end do deallocate(bigwords) allocate(words(narg)) narg=0 do i=1, nloci if (same_loctyp(loctyp(i), j)) then narg=narg+1 words(narg)=loc(i) end if end do else if (bigwords(1)(2:2) == 'A') then narg=0 do i=1, nloci if (isactive(loctyp(i))) then narg=narg+1 end if end do deallocate(bigwords) allocate(words(narg)) narg=0 do i=1, nloci if (isactive(loctyp(i))) then narg=narg+1 words(narg)=loc(i) end if end do else narg=0 end if ! or a sequence in the shorthand N:M else if (narg == 3 .and. bigwords(2) == ':') then if (isint(bigwords(1)) .and. isint(bigwords(3))) then big=1 seq1=ival(bigwords(1)) seq2=ival(bigwords(3)) narg=abs(seq2-seq1)+1 seqdir=1 if (seq2 < seq1) seqdir=-1 deallocate(bigwords) allocate(words(narg)) j=0 do i=seq1, seq2, seqdir j=j+1 write(words(j), '(i5)') i words(j)=adjustl(words(j)) end do else narg=0 end if end if if (plevel > 1) then if (big == 1) then write(outstr,'(a)') 'word length 20' do i=1, narg write(outstr,*) i, 'th iterator value: "', trim(words(i)), '"' end do else write(outstr,'(a)') 'word length 256' do i=1, narg write(outstr,*) i, 'th iterator value: "', trim(bigwords(i)), '"' end do end if end if rest=sta+eol-fin do i=narg, 1, -1 if (big == 1) then token=words(i) else token=bigwords(i) end if if (len_trim(commands)+len_trim(token)+rest <= len(commands)) then commands = lin(1:(sta-1)) // trim(token) // & lin((fin+1):eol) // ';' // trim(commands) else write(outstr,'(a)') 'ERROR: Command buffer exhausted' commands='' exit end if end do if (big == 1) then deallocate(words) else deallocate(bigwords) end if else ! on-line help, allowing for unquoted braces narg=countargs(lin, ' ', SEP_WHITE) if (narg==2 .and. lin(1:3)=='hel') then write(outstr,'(a/a)') & 'Matching braces enclose a list for macro style iteration eg ', & '"{1 2}+2" => "3; 4"; "{1 : 3}" => "1;2;3"; "a{1 2}" => "a1;a2"' else write(outstr,'(a)') 'ERROR: Unbalanced braces in list to be iterated' if (sta>0 .and. fin==0) then write(outstr,'(7x,a,i4,a)') '"{" at ', sta, '; no matching "}".' else if (sta==0 .and. fin>0) then write(outstr,'(7x,a,i4,a)') '"}" at ', fin, '; no matching "{".' end if end if end if if (plevel > 0) then write(outstr,'(3a)') '-> "', trim(commands), '"' end if end subroutine macloop ! ! Perform simple macro variable substitutions on contents of command buffer ! cf macro functions which are handled by macsub ! want to tokenize eg echo %a%b [ "key value" ] ! subroutine macvar(lin, commands, plevel) use scheme_lang use outstream implicit none character (len=*), intent(inout) :: lin character (len=*), intent(inout) :: commands integer, intent(in) :: plevel integer :: eos, fin, i, istat, k, pos, sta eos=len_trim(lin) pos=0 do while (pos < eos) pos=pos+1 #if defined (WIN32) || defined (IFORT) || defined (NOESCAPE) if (lin(pos:(pos+1))=='\%') pos=pos+1 #else if (lin(pos:(pos+1))=='\\%') pos=pos+2 #endif if (lin(pos:pos)=='%') then sta=pos+1 fin=sta if (sta <= eos) then if (lin(sta:sta) == '(') then call findbracket('(',')',lin, sta, fin, istat) if (istat /= 0) then write(outstr,'(2a)') & 'ERROR: Unmatched bracket in macro variable reference: ', & lin(pos:fin) end if else #if defined (WIN32) || defined (IFORT) || defined (NOESCAPE) do while (scan(lin(fin:fin),' ./*+-^\)(]["%') == 0 .and. fin <= eos) #else do while (scan(lin(fin:fin),' ./*+-^\\)(]["%') == 0 .and. fin <= eos) #endif fin=fin+1 end do fin=fin-1 end if if (plevel > 1) then write(outstr, '(2a)') & 'Evaluating macro variable %', lin(sta:fin) end if call get_var(lin, pos, fin, istat) if (istat == -2) then write(outstr,'(a)') 'ERROR: Command buffer exhausted.' else if (istat == -1) then write(outstr,'(a/7x,a)') & 'ERROR: Macro variable not found.', & 'For more information, rerun after "set plevel verbose"' else if (istat == -4) then write(outstr,'(a)') & 'ERROR: Macro variable is list. Index not in range.' else if (istat == -5) then write(outstr,'(a)') & 'ERROR: Macro variable is list. Need index for list element eg v[1].' end if eos=len_trim(lin) else write(outstr,'(3a)') 'ERROR: Macro variable name not given.' lin=lin(1:(eos-1)) pos=eos end if end if end do if ((len_trim(lin)+len_trim(commands)) < len(commands)) then commands=trim(lin) // ';' // trim(commands) else write(outstr,*) 'ERROR: macro expansion lead to an overlong command string.' commands=trim(lin) end if end subroutine macvar ! ! Other syntactic transformations ! replace category labels in expressions with corresponding values ! eg 'Hair_colour == red' -> 'Hair_colour == 1' ! subroutine preparser(first, narg, words) use outstream use scanner use comp_ops use locus_list use locus_types use locus_data use categorical_data integer, intent(in) :: first integer, intent(in) :: narg character (len=*), dimension(narg) :: words integer, parameter :: MISS=-9999 integer :: i, sta, trait character (len=40) :: cval ! functions logical :: isint i=first+1 do if (i >= narg) exit if (words(i) == '^' .or. words(i) == '=') then call gettrait(words(i-1), LOC_CAT, 0, nloci, loc, lochash, loctyp, trait, -1) if (trait /= MISS) then sta=i-1 i=i+1 if (words(i) == '=') then if (i >= narg) exit i=i+1 end if call getpairval(trim(words(i)), trim(get_notes(loc(trait), locnotes(trait))), & opsimple, cval, forward=.false.) if (cval /= ' ') then if (isint(words(i))) then words(i)=cval else if (.not. isinuse(.true., words(i), loc, lochash)) then words(i)=cval else write(outstr,'(a)', advance='no') 'ERROR: Ambiguous syntax in "' do j=sta, i write(outstr,'(a)', advance='no') trim(words(j)) end do write(outstr,'(a/7x,5a/7x,a)') '"', & '"', trim(words(i)), '" is either locus or category of "', & trim(words(sta)), '".', 'Interpreted as locus.' end if end if end if end if i=i+1 end do end subroutine preparser ! ! Evaluate and apply simple expressions either ! ! (1) pure arithmetic, so no effect on pedigree file ! (2) Dry run, so can test if will lead to a legal effect on pedigree file ! all variables set to MISS ! (3) Pedigree operation -- individual-wise calculation and update ! ! The parser ! subroutine parser(nterm, wtyp, wtag, expr, error) use parser_data integer, intent(inout) :: nterm integer (kind=1), dimension(:), intent(inout) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(inout) :: expr integer, intent(out) :: error ! To allow if-then-else, start and end of block for parsing integer, parameter :: MISS=-9999 integer :: fin, posif, posth, posel, posen, res, sta logical :: ismis, isop, isvar, switch, more interface subroutine simpev(sta, fin, nterm, wtyp, wtag, expr, error) use parser_data integer, intent(in) :: sta integer, intent(inout) :: fin integer, intent(inout) :: nterm integer (kind=1), dimension(:), intent(inout) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(inout) :: expr integer, intent(out) :: error end subroutine simpev subroutine pull(pos, dec, fin, nterm, typ, tag, expr) integer, intent(in) :: pos integer, intent(in) :: dec integer, intent(inout) :: fin integer, intent(inout) :: nterm integer (kind=1), dimension(:), intent(inout) :: typ integer, dimension(:), intent(inout) :: tag double precision, dimension(:,:), intent(inout) :: expr end subroutine pull subroutine findth(nterm, wtyp, wtag, posif, posth, posel, posen) integer, intent(in) :: nterm integer (kind=1), intent(in out) :: wtyp(nterm) integer, intent(inout) :: wtag(nterm) integer, intent(out) :: posif integer, intent(out) :: posth integer, intent(out) :: posel integer, intent(out) :: posen end subroutine findth subroutine addcolon(nterm, wtyp, wtag, expr) use parser_data integer, intent(in out) :: nterm integer (kind=1), dimension(:), intent(inout) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(in out) :: expr end subroutine addcolon end interface ! ! Convert (expr) (expr) to (expr) : (expr) ! call addcolon(nterm, wtyp, wtag, expr) it=0 more=.true. error=0 res=0 ! Main eval loop do while (it < 20 .and. more .and. error == 0) it=it+1 ! Read tag of each token and see if compound expression call findth(nterm, wtyp, wtag, posif, posth, posel, posen) ! simple expression if (posif == MISS) then ! empty list if (nterm <= 0) then nterm=1 wtyp(nterm)=partra expr(nterm,1)=MISS expr(nterm,2)=MISS more=.false. ! ! evaluate simple sequence of expression else call findend(res, nterm, nterm, wtyp, wtag, posen) sta=res+1 fin=posen call simpev(sta, fin, nterm, wtyp, wtag, expr, error) if (sta == fin) then ! update any local copies of a just-changed variable res=res+1 if (res > 0) then if (isvar(wtyp(res))) then do i=res+1, nterm if (isvar(wtyp(i))) then if (wtag(i) == wtag(res)) then wtyp(i)=wtyp(res) expr(i,1:2) = expr(res,1:2) end if end if end do end if end if else error=1 end if if (fin == nterm) then more=.false. else call pull(res+1, 1, fin, nterm, wtyp, wtag, expr) end if end if ! complex expression -- evaluate if clause else if ((posth-posif) > 1) then sta=posif+1 fin=posth-1 call simpev(sta, fin, nterm, wtyp, wtag, expr, error) ! if successfully evaluated if (sta == fin .and. .not.ismis(wtyp(sta))) then switch=(int(expr(sta,1)) /= 0) call findth(nterm, wtyp, wtag, posif, posth, posel, posen) call pull(posif, 3, fin, nterm, wtyp, wtag, expr) if (posth /= MISS) posth=posth-3 if (posel /= MISS) posel=posel-3 if (posen /= MISS) posen=posen-3 ! remove either `else' predicate if (switch) then if (posel /= MISS) then sta=posel fin=posen call pull(sta, fin-sta+1, fin, nterm, wtyp, wtag, expr) end if ! or remove `then' predicate else if (posel == MISS) posel=nterm sta=res+1 fin=posel call pull(sta, fin-sta+1, fin, nterm, wtyp, wtag, expr) end if else error=1 end if ! no `then' else error=1 end if end do end subroutine parser ! ! The non-compound evaluator ! subroutine simpev(sta, fin, nterm, wtyp, wtag, expr, error) use parser_data integer, intent(in) :: sta integer, intent(inout) :: fin integer, intent(inout) :: nterm integer (kind=1), dimension(:), intent(inout) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(inout) :: expr integer, intent(out) :: error logical :: change, done, three integer :: adh1, adh2, adh3, adh4, iter, pos integer (kind=1) :: cand1, cand2, cand3 integer :: tag1, tag2, tag3 ! functions logical :: isdata, isenv, isop interface subroutine compop(pos, sta, fin, nterm, wtyp, wtag, expr, error) use parser_data integer, intent(in) :: pos integer, intent(in) :: sta integer, intent(in out) :: fin integer, intent(in out) :: nterm integer (kind=1), dimension(:), intent(in out) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(in out) :: expr integer, intent(out) :: error end subroutine compop subroutine zerop(pos, wtyp, wtag, expr, error) use parser_data integer, intent(in) :: pos integer (kind=1), dimension(:), intent(in out) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(in out) :: expr integer, intent(out) :: error end subroutine zerop subroutine unop(pos, sta, fin, nterm, wtyp, wtag, expr, error) use parser_data integer, intent(in) :: pos integer, intent(in) :: sta integer, intent(in out) :: fin integer, intent(in out) :: nterm integer (kind=1), dimension(:), intent(in out) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(in out) :: expr integer, intent(out) :: error end subroutine unop subroutine binop(pos, sta, fin, nterm, wtyp, wtag, expr, error) use parser_data use recast_data integer, intent(in) :: pos integer, intent(in) :: sta integer, intent(in out) :: fin integer, intent(in out) :: nterm integer (kind=1), dimension(:), intent(in out) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(in out) :: expr integer, intent(out) :: error end subroutine binop subroutine pull(pos, dec, fin, nterm, typ, tag, expr) integer, intent(in) :: pos integer, intent(in) :: dec integer, intent(inout) :: fin integer, intent(inout) :: nterm integer (kind=1), dimension(:), intent(inout) :: typ integer, dimension(:), intent(inout) :: tag double precision, dimension(:,:), intent(inout) :: expr end subroutine pull end interface ! ! First convert compound operators (==,^=,<=,>=) to equivalent token ! pos=fin do while (pos > sta) if (wtyp(pos) == partok .and. wtyp(pos-1) == partok .and. & wtag(pos) == TOK_EQUAL .and. pos > sta) then cand2=wtag(pos-1) if (cand2 == TOK_EQUAL .or. cand2 == TOK_POW .or. & cand2 == TOK_LT .or. cand2 == TOK_GT .or. cand2 == TOK_DIVIDE) then call compop(pos-1, sta, fin, nterm, wtyp, wtag, expr, error) pos=pos-1 end if end if pos=pos-1 end do ! ! Then main eval loop ! change=.false. iter=0 pos=sta-1 do iter=iter+1 call incpos(pos, sta, fin) done=.false. error=0 ! -- DEBUG ! write(*,'(i0,a,i0,1x)', advance='no') sta, ' to ', fin ! do kk=sta,fin ! if (isenv(wtyp(kk))) then ! write(*,'(a)', advance='no') env(wtag(kk))(1:len_trim(env(wtag(kk)))) ! else if (isop(wtyp(kk))) then ! write(*,'(1x,a,1x)', advance='no') token(wtag(kk))(1:len_trim(token(wtag(kk)))) ! else if (wtyp(kk).eq.2) then ! write(*,'(a,f5.1,a)', advance='no') ' ',expr(kk,1),' ' ! else if (wtyp(kk).eq.3) then ! write(*,'(2(a,i5),a)', advance='no') ' ', & ! int(expr(kk,1)),'/', int(expr(kk,2)),' ' ! else if (isdata(wtyp(kk))) then ! if (expr(kk,1).eq. -9999) then ! write(*,'(a)', advance='no') ' {x} ' ! else ! write(*,'(a,f12.4,a)', advance='no') ' {',expr(kk,1),'} ' ! end if ! end if ! end do ! write(*,*) ! -- DEBUG ! ! an answer? if (sta == fin) then if (isdata(wtyp(sta))) then done=.true. else if (isop(wtyp(sta)) .and. op(wtag(pos)) == 10) then call zerop(pos, wtyp, wtag, expr, error) done=.true. else if (error /= 0) then done=.true. end if else ! ! check next token and its neighbours (lookahead 1 and lookback 1) ! cand1=-1 cand2=wtyp(pos) tag2=wtag(pos) cand3=-1 adh1=0 adh2=0 adh3=0 adh4=0 if (isop(cand2)) then adh2=lbp(tag2) adh3=rbp(tag2) end if if (pos > sta) then cand1=wtyp(pos-1) tag1=wtag(pos-1) if (isop(cand1)) then adh2=rbp(tag1) end if end if if (pos > (sta+1)) then if (isop(wtyp(pos-2))) then adh1=rbp(wtag(pos-2)) end if end if if (pos < fin) then cand3=wtyp(pos+1) tag3=wtag(pos+1) if (isop(cand3)) then adh3=lbp(tag3) end if end if if (pos < (fin-1)) then if (isop(wtyp(pos+2))) then adh4=lbp(wtag(pos+2)) end if end if ! ! Cases: v v v, v v o, v o o, o v v, o o o illegal ! v o v, u o v binary operation ! o v o unary operation, brackets ! o o v unary ! ! note (20130712) mod(x, TOKNUM+1) to avoid segfaults if eval order ! three=((pos-sta) > 0 .and. (fin-pos) > 0) ! Zero function operation if (isop(cand2) .and. op(mod(tag2, TOKNUM+1)) == 10) then call zerop(pos, wtyp, wtag, expr, error) pos=pos-1 change=.true. ! Brackets else if (three .and. tag1 == TOK_LBRACKET .and. .not.isop(cand2) .and. & tag3 == TOK_RBRACKET) then expr(pos-1,1)=expr(pos,1) expr(pos-1,2)=expr(pos,2) wtyp(pos-1)=wtyp(pos) wtag(pos-1)=wtag(pos) call pull(pos, 2, fin, nterm, wtyp, wtag, expr) pos=pos-1 change=.true. ! Unary minus or plus else if ((cand1 == -1 .or. & (three .and. isop(cand1) .and. tag1 /= TOK_RBRACKET)) .and. & (tag2 == TOK_ADD .or. tag2 == TOK_SUBTRACT) .and. & isdata(cand3)) then if (tag2 == TOK_SUBTRACT) then wtag(pos)=TOK_NEG else wtag(pos)=TOK_POS end if pos=pos-1 change=.true. ! Binary operation else if (three .and. .not.isop(cand1) .and. & isop(cand2) .and. .not.isop(cand3) .and. & op(mod(tag2,TOKNUM+1)) == 2 .and. & adh2 >= adh1 .and. adh3 >= adh4) then call binop(pos, sta, fin, nterm, wtyp, wtag, expr, error) pos=pos-1 change=.true. ! Unary operation else if (isop(cand2) .and. isdata(cand3) .and. & op(mod(tag2,TOKNUM+1)) == 1 .and. adh3 >= adh4) then call unop(pos, sta, fin, nterm, wtyp, wtag, expr, error) pos=pos-1 change=.true. end if if (error /= 0) then done=.true. end if end if ! ! test if expression unevaluable: a complete scan without any operations ! if (pos == fin) then if (change) then change=.false. else if (.not.done) then done=.true. error=1 end if end if if (done .or. iter == 5000) exit end do end subroutine simpev ! ! write out results of command line expression evaluation ! subroutine wrans(prefix, nterm, expr, wtyp, wtag, val) use outstream use parser_data character (len=*), intent(in) :: prefix integer, intent(in) :: nterm double precision, dimension(:,:), intent(in) :: expr integer (kind=1), dimension(:), intent(in) :: wtyp integer, dimension(:), intent(in) :: wtag double precision, intent(out) :: val integer, parameter :: MISS=-9999 integer :: i character (len=9) :: gtp ! functions logical :: legall val=MISS do i=1, nterm if (wtyp(i) == partra) then val=expr(i,1) write(outstr,'(a)', advance='no') prefix write(outstr,*) val else if (wtyp(i) == pargen) then ! Check bounds on result if a genotype if (legall(expr(i,1)) .and. legall(expr(i,2))) then val=expr(i,1) call wrgtp(int(expr(i,1)),int(expr(i,2)),gtp,'/', '', 1) write(outstr,'(2a)') prefix, gtp else write(outstr,'(2a)') prefix, 'Allele out of range ' end if else if (wtyp(i) == parmge) then write(outstr,'(2a)') prefix, ' x/x' else if (wtag(i) == TOK_COLON) then continue else write(outstr,'(2a)') prefix, 'MISS' end if end do end subroutine wrans ! ! the legal range of alleles ! function legall(xall) logical :: legall double precision, intent(in) :: xall integer, parameter :: MISS=-9999 integer :: iall legall=.true. iall=int(xall) if (iall /= MISS) THEN iall=abs(iall) legall=(iall >= 1 .and. iall <= 999) .or. & (iall >= 10065 .and. iall <= 10090) .or. & (iall >= 10097 .and. iall <= 10122) end if end function legall ! ! Is a stack element a number, variable or operator ! function isdata(idx) use parser_data logical isdata integer (kind=1), intent(in) :: idx isdata=(idx >= partra) end function isdata ! ! Is a stack element an automatic variable ! function isenv(idx) use parser_data logical isenv integer (kind=1), intent(in) :: idx isenv=(idx == parenv) end function isenv ! ! Is a stack element data ! function isvar(idx) use parser_data logical isvar integer (kind=1), intent(in) :: idx isvar=(idx > parvar) end function isvar ! ! Is a stack element an operator ! function isop(idx) use parser_data logical isop integer (kind=1), intent(in) :: idx isop=(idx == partok) end function isop ! ! Is a stack element a genotype - both values of interest ! function isvec(idx) use parser_data logical isvec integer (kind=1), intent(in) :: idx isvec=(mod(idx, parvar) == pargen .or. mod(idx, parvar) == parmge) end function isvec ! ! Is a stack element missing data ! function ismis(idx) use parser_data logical :: ismis integer (kind=1), intent(in) :: idx ismis=(mod(idx, parvar) == parmtr .or. mod(idx, parvar) == parmge) end function ismis ! ! Convert (expr) (expr) to (expr : expr) ! subroutine addcolon(nterm, wtyp, wtag, expr) use parser_data integer, intent(inout) :: nterm integer (kind=1), dimension(:), intent(inout) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(inout) :: expr integer :: fin, pos interface subroutine pull(pos, dec, fin, nterm, typ, tag, expr) integer, intent(in) :: pos integer, intent(in) :: dec integer, intent(inout) :: fin integer, intent(inout) :: nterm integer (kind=1), dimension(:), intent(inout) :: typ integer, dimension(:), intent(inout) :: tag double precision, dimension(:,:), intent(inout) :: expr end subroutine pull end interface fin=nterm pos=1 do while (pos < nterm) pos=pos+1 op1=wtag(pos-1) op2=wtag(pos) if (op1 == TOK_RBRACKET .and. op2 == TOK_LBRACKET) then nterm=nterm+1 do i=nterm, pos+1, -1 wtyp(i)=wtyp(i-1) wtag(i)=wtag(i-1) expr(i,1:2)=expr(i-1,1:2) end do wtag(pos)=TOK_COLON end if end do end subroutine addcolon ! ! compound operators eg <= >= == ^= ! subroutine compop(pos, sta, fin, nterm, wtyp, wtag, expr, error) use parser_data integer, intent(in) :: pos integer, intent(in) :: sta integer, intent(in out) :: fin integer, intent(in out) :: nterm integer (kind=1), dimension(:), intent(in out) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(in out) :: expr integer, intent(out) :: error integer, parameter :: MISS=-9999 integer :: newop, op1, op2 interface subroutine pull(pos, dec, fin, nterm, typ, tag, expr) integer, intent(in) :: pos integer, intent(in) :: dec integer, intent(inout) :: fin integer, intent(inout) :: nterm integer (kind=1), dimension(:), intent(inout) :: typ integer, dimension(:), intent(inout) :: tag double precision, dimension(:,:), intent(inout) :: expr end subroutine pull end interface if (pos == fin) then error=1 return end if error=0 op1=wtag(pos) op2=wtag(pos+1) newop=MISS if (op2 == TOK_EQUAL) then if (op1 == TOK_EQUAL) then newop=TOK_EQ else if (op1 == TOK_LT) then newop=TOK_LE else if (op1 == TOK_GT) then newop=TOK_GE else if (op1 == TOK_POW .or. op1 == TOK_DIVIDE) then newop=TOK_NE end if else error=1 return end if wtag(pos)=newop call pull(pos+1, 1, fin, nterm, wtyp, wtag, expr) end subroutine compop ! ! zero argument functions ! subroutine zerop(pos, wtyp, wtag, expr, error) use parser_data use rngs integer, intent(in) :: pos integer (kind=1), dimension(:), intent(in out) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(in out) :: expr integer, intent(out) :: error integer, parameter :: MISS=-9999 integer :: curr, restyp double precision :: res error=0 curr=wtag(pos) restyp=partra if (curr == TOK_RAND) then res=dble(random()) else if (curr == TOK_RNORM) then res=dble(randn()) else if (curr == TOK_PI) then res=3.14159265358979323846d0 else if (curr == TOK_EPS) then res=epsilon(1.0d0) else if (curr == TOK_Y) then res=1.0d0 else if (curr == TOK_N) then res=0.0d0 else if (curr == TOK_X) then res=MISS restyp=parmtr else if (curr == TOK_NUM) then res=MISS restyp=parnum else res=MISS restyp=parmtr error=1 end if wtyp(pos)=restyp expr(pos,1)=res expr(pos,2)=res return end subroutine zerop ! ! unary operators ! subroutine unop(pos, sta, fin, nterm, wtyp, wtag, expr, error) use parser_data use statfuns use julian_epoch use timelib integer, intent(in) :: pos integer, intent(in) :: sta integer, intent(in out) :: fin integer, intent(in out) :: nterm integer (kind=1), dimension(:), intent(in out) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(in out) :: expr integer, intent(out) :: error integer, parameter :: KNOWN=0, MISS=-9999 integer :: curr, restyp double precision :: res, x, x2 ! functions logical :: ismis, isvec double precision :: inht interface subroutine pull(pos, dec, fin, nterm, typ, tag, expr) integer, intent(in) :: pos integer, intent(in) :: dec integer, intent(inout) :: fin integer, intent(inout) :: nterm integer (kind=1), dimension(:), intent(inout) :: typ integer, dimension(:), intent(inout) :: tag double precision, dimension(:,:), intent(inout) :: expr end subroutine pull end interface if (pos == fin) then error=1 return end if restyp=partra if (isvec(wtyp(pos+1))) restyp=pargen res=MISS error=0 curr=wtag(pos) if (ismis(wtyp(pos+1))) then if (curr == TOK_ISTYP) then res=0.0d0 else if (curr == TOK_UNTYP) then res=1.0d0 else restyp=parmtr if (isvec(wtyp(pos+1))) restyp=parmge res=MISS end if expr(pos,1)=res expr(pos,2)=res else if (curr == TOK_ISTYP .or. curr == TOK_UNTYP) then x=expr(pos+1, 1) if ((restyp == pargen .and. x > KNOWN) .or. & (restyp == partra .and. x /= MISS)) then res=1.0d0 else res=0.0d0 end if if (curr == TOK_UNTYP) res=1.0d0-res restyp=partra expr(pos,1)=res expr(pos,2)=res else if (curr == TOK_ISHET .or. curr == TOK_ISHOM) then restyp=partra x=expr(pos+1, 1) x2=expr(pos+1, 2) if (x > KNOWN .and. x2 > KNOWN) then res=0.0d0 if (x == x2) res=1.0d0 if (curr == TOK_ISHET) res=1.0d0-res end if expr(pos,1)=res expr(pos,2)=res else if (curr == TOK_ALLA) then restyp=partra expr(pos,1)=expr(pos+1, 1) expr(pos,2)=expr(pos+1, 1) else if (curr == TOK_ALLB) then restyp=partra expr(pos,1)=expr(pos+1, 2) expr(pos,2)=expr(pos+1, 2) else do i=1, 2 x=expr(pos+1, i) if (curr == TOK_NOT) then if (x == 0.0d0) then res=1.0d0 else res=0.0d0 end if else if (curr == TOK_SQRT) then if (x >= 0.0d0) then res=sqrt(x) else res=MISS restyp=parnum end if else if (curr == TOK_NEG) then res=-1.0d0*x else if (curr == TOK_ABS) then res=abs(x) else if (curr == TOK_LOG) then if (x > 0.0d0) then res=log(x) else res=MISS restyp=parnum end if else if (curr == TOK_LOG10) then if (x > 0.0d0) then res=log10(x) else res=MISS restyp=parnum end if else if (curr == TOK_EXP) then res=exp(x) else if (curr == TOK_SIN) then res=sin(x) else if (curr == TOK_COS) then res=cos(x) else if (curr == TOK_TAN) then res=tan(x) else if (curr == TOK_ASIN) then res=asin(x) else if (curr == TOK_ACOS) then res=acos(x) else if (curr == TOK_ATAN) then res=atan(x) else if (curr == TOK_INHT) then res=inht(x) else if (curr == TOK_INT) then res=int(x) else if (curr == TOK_ROUND) then res=anint(x) else if (curr == TOK_POS) then res=x else if (curr == TOK_JULIAN) then res=tojulian(x)-epoch else if (curr == TOK_GREG) then res=togreg(x+epoch) else if (curr == TOK_PNORM) then res=zp(x) else if (curr == TOK_QNORM) then res=ppnd(1.0d0-x) else if (curr == TOK_FACT) then res=fact(int(x)) else restyp=parnum res=MISS error=1 end if expr(pos,i)=res end do end if wtyp(pos)=restyp call pull(pos+1, 1, fin, nterm, wtyp, wtag, expr) end subroutine unop ! ! binary operators ! subroutine binop(pos, sta, fin, nterm, wtyp, wtag, expr, error) use parser_data use recast_data integer, intent(in) :: pos integer, intent(in) :: sta integer, intent(in out) :: fin integer, intent(in out) :: nterm integer (kind=1), dimension(:), intent(in out) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(in out) :: expr integer, intent(out) :: error integer, parameter :: MISS=-9999 integer :: curr, i integer (kind=1) :: wx, wy integer (kind=1) :: restyp(2) integer :: restag(2) ! scalar versus genotype comparison logical :: scal_vec double precision :: res(2), tmp, x, y ! functions logical :: ismis, isvar, isvec interface subroutine pull(pos, dec, fin, nterm, typ, tag, expr) integer, intent(in) :: pos integer, intent(in) :: dec integer, intent(inout) :: fin integer, intent(inout) :: nterm integer (kind=1), dimension(:), intent(inout) :: typ integer, dimension(:), intent(inout) :: tag double precision, dimension(:,:), intent(inout) :: expr end subroutine pull end interface if (pos == sta .or. pos == fin) then error=1 return end if restyp(1)=partra restyp(2)=partra if (isvec(wtyp(pos-1)) .or. isvec(wtyp(pos+1))) then restyp(1)=pargen restyp(2)=pargen end if scal_vec=.not.(isvec(wtyp(pos-1)) .eqv. isvec(wtyp(pos+1))) res(1)=MISS res(2)=MISS error=0 do i=1, 2 x=expr(pos-1,i) y=expr(pos+1,i) wx=wtyp(pos-1) wy=wtyp(pos+1) tx=wtag(pos-1) ty=wtag(pos+1) curr=wtag(pos) ! ! Generic number NUM: NUM <- NUM op <any> (used for detecting parse error) if (wx == parnum .or. wy == parnum) then res(i)=MISS restyp(i)=parnum ! ! Equality or inequality: allows comparison with missing values else if (curr == TOK_NE .or. curr == TOK_EQ) then restyp(i)=partra if (x == y) then res(i)=1.0d0 else res(i)=0.0d0 end if if (curr == TOK_NE) then res(i)=1.0d0-res(i) end if ! ! Assignment: <var> <- MISS or <var> <- <const> ! else if (curr == TOK_EQUAL) then if (ismis(wy)) then res(i)=MISS restyp(i)=parmtr if (.not.ismis(wx)) then if (isvec(wx)) then restyp(i)=parmge+iand(wx, parvar) restag(i)=tx else if (isvar(wx)) then restyp(i)=parmtr+iand(wx, parvar) restag(i)=tx end if end if else res(i)=y restyp(i)=wx if (ismis(wx)) then if (isvec(wx)) then restyp(i)=pargen+iand(wx, parvar) restag(i)=tx else if (isvar(wx)) then restyp(i)=partra+iand(wx, parvar) restag(i)=tx end if end if end if ! ! AND and OR allows (lazy) combination with missing values ! (T && x) = x (T || x) = T (F && x) = F (F || x) = x ! else if (curr == TOK_AND) then restyp(i)=partra res(i)=1.0d0 if (x == 0.0d0 .or. y == 0.0d0) then res(i)=0.0d0 else if (ismis(wx) .or. ismis(wy)) then res(i)=MISS restyp(i)=parmtr end if else if (curr == TOK_OR) then restyp(i)=partra res(i)=0.0d0 if (x == 1.0d0 .or. y == 1.0d0) then res(i)=1.0d0 else if (ismis(wx) .or. ismis(wy)) then res(i)=MISS restyp(i)=parmtr end if ! ! All other operations with missing values lead to MISS as outcome else if (ismis(wx) .or. ismis(wy)) then res(i)=MISS restyp(i)=parmtr if (isvec(wx) .or. isvec(wy)) restyp(i)=parmge ! ! All other operations else if (curr == TOK_MULT) then res(i)=x*y else if (curr == TOK_DIVIDE) then if (y == 0.0d0) then expr(pos-1,1)=MISS expr(pos-1,2)=MISS return else res(i)=x/y end if else if (curr == TOK_ADD) then res(i)=x+y else if (curr == TOK_SUBTRACT) then res(i)=x-y else if (curr == TOK_POW) then res(i)=x**y else if (curr == TOK_GT) then restyp(i)=partra if (x > y) then res(i)=1.0d0 else res(i)=0.0d0 end if else if (curr == TOK_LT) then restyp(i)=partra if (x < y) then res(i)=1.0d0 else res(i)=0.0d0 end if else if (curr == TOK_GE) then restyp(i)=partra if (x >= y) then res(i)=1.0d0 else res(i)=0.0d0 end if else if (curr == TOK_LE) then restyp(i)=partra if (x <= y) then res(i)=1.0d0 else res(i)=0.0d0 end if else if (curr == TOK_MOD) then res(i)=mod(x,y) else error=1 return end if end do if (restyp(1) /= restyp(2)) then error=1 return end if ! ! Comparisons are joint for alleles of genotypes ! all equal or all not equal ! But if scalar v. genotype comparison, then ! any equal or any not equal ! any greater or less ! >= is then tricky for geno v. geno, ! so redo using genotype collation order ! if ((curr == TOK_GE .or. curr == TOK_LE) .and. & (isvec(wtyp(pos-1)) .and. isvec(wtyp(pos+1)))) then x=encgtp(int(expr(pos-1,1)),int(expr(pos-1,2))) y=encgtp(int(expr(pos+1,1)),int(expr(pos+1,2))) if ((curr == TOK_GE .and. x >= y) .or. (curr == TOK_LE .and. x <= y)) then res(1)=1.0d0 res(2)=1.0d0 else res(1)=0.0d0 res(2)=0.0d0 end if else if (res(1) /= res(2)) then if (curr == TOK_EQ) then if (scal_vec) then res(1)=1.0d0 res(2)=1.0d0 else res(1)=0.0d0 res(2)=0.0d0 end if else if (curr >= TOK_AND .and. curr <= TOK_NE) then res(1)=1.0d0 res(2)=1.0d0 else if (res(1) > res(2)) then tmp=res(1) res(1)=res(2) res(2)=tmp end if end if wtyp(pos-1)=restyp(1) expr(pos-1, 1)=res(1) expr(pos-1, 2)=res(2) call pull(pos, 2, fin, nterm, wtyp, wtag, expr) end subroutine binop ! ! Evaluate type of each term in expression word(farg...larg) and actn ! actn=0 error =1 purely arithmetic =2 legal ! ! Types are: wtyp wtag expr ! ---- -------- -------- ! tokens 0 0...TOKNUM - ! env 1 1...ENVNUM (value) ! constant 2 value ! trait data 2 1...NLOCI (value) ! constant genotype 3 value, value ! genotype data 3 1...NLOCI (value, value) ! MISS 4 MISS ! missing trait 4 1...NLOCI MISS ! MISS genotype 5 MISS/MISS ! missing trait 5 1...NLOCI MISS/MISS ! NUM 6 - ! subroutine typwords(farg, larg, words, nloci, loc, lochash, loctyp, & wtyp, wtag, expr, actn) use parser_data use locus_types use locstring_widths use lochash_class integer, intent(in) :: farg integer, intent(in) :: larg character (len=*), dimension(:), intent(in out) :: words integer, intent(in) :: nloci character (len=*), dimension(nloci), intent(in) :: loc type (hash_table) :: lochash integer, dimension(nloci), intent(in) :: loctyp integer (kind=1), dimension(:), intent(inout) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(inout) :: expr integer, intent(out) :: actn integer, parameter :: MISS=-9999 integer :: i, ienv, ilok, itok ! functions logical :: isgeno, ismiss, isreal integer :: isinenv double precision :: fval if (.not.lochash%current) then call make_lochash(nloci, loc, lochash) end if actn=1 do i=farg, larg wtag(i)=0 expr(i,1)=MISS expr(i,2)=MISS ienv=isinenv(words(i), ENVNUM, env) itok=isinenv(words(i), TOKNUM, token) call find_hashtab(trim(words(i)(1:loc_width)), loc, lochash, ilok) if (itok > 0) then wtyp(i)=partok wtag(i)=itok else if (ienv > 0) then wtyp(i)=parenv wtag(i)=ienv else if (ilok > 0) then if (ismarker(loctyp(ilok))) then wtyp(i)=pargen+parvar wtag(i)=ilok else wtyp(i)=partra+parvar wtag(i)=ilok end if actn=2 else if (ismiss(words(i))) then wtyp(i)=parmtr else if (isgeno(words(i))) then call getgeno(words(i), expr(i,1), expr(i,2), wtyp(i)) else if (isreal(words(i))) then wtyp(i)=partra expr(i,1)=fval(words(i)) expr(i,2)=expr(i,1) else actn=0 write(*,'(3a)') 'ERROR: token "', trim(words(i)), '" not recognised.' return end if end do end subroutine typwords ! ! If checking arguments via dry run of parser, ! replace variable values with (generic) NUM ! subroutine dryrun(farg, larg, wtyp) use parser_data integer, intent(in) :: farg integer, intent(in) :: larg integer (kind=1), dimension(:), intent(inout) :: wtyp integer :: i do i=farg, larg if (wtyp(i) == parenv .or. wtyp(i) == partra .or. wtyp(i) == pargen) then wtyp(i)=parnum end if end do end subroutine dryrun ! ! Pull up expr ! subroutine pull(pos, dec, fin, nterm, typ, tag, expr) integer, intent(in) :: pos integer, intent(in) :: dec integer, intent(inout) :: fin integer, intent(inout) :: nterm integer (kind=1), dimension(:), intent(inout) :: typ integer, dimension(:), intent(inout) :: tag double precision, dimension(:,:), intent(inout) :: expr integer :: i, j do j=pos, nterm-dec typ(j)=typ(j+dec) tag(j)=tag(j+dec) do i=1, 2 expr(j,i)=expr(j+dec,i) end do end do nterm=nterm-dec if (fin >= pos) fin=fin-dec end subroutine pull ! ! See if a string is a valid genotype ! function isgeno(string) logical :: isgeno character (len=*), intent(in) :: string integer, parameter :: MISS=-9999 integer :: a1, a2, i, lent, slash ! functions integer :: aval isgeno=.false. if (string == 'x/x' .or. string == 'X/X' .or. string == './.') then isgeno=.true. else slash=0 lent=len_trim(string) do i=1, lent if (string(i:i) == '/') then if (slash == 0) slash=i end if end do if (slash /= 0) then ! an allele of the form /a/? if (slash < lent .and. string(lent:lent) == '/') then a1=aval(trim(string((slash+1):(lent-1))), 1) isgeno=(a1 /= MISS) ! legal genotype? else a1=aval(string(1:(slash-1)),1) a2=aval(string((slash+1):lent),1) isgeno=(a1 /= MISS .and. a2 /= MISS) end if end if end if end function isgeno ! ! Get a valid genotype ! subroutine getgeno(string, a1, a2, wtyp) use parser_data character (len=*), intent(in) :: string double precision, intent(out) :: a1 double precision, intent(out) :: a2 integer (kind=1), intent(out) :: wtyp integer, parameter :: MISS=-9999 double precision :: tmp integer :: i, lent, slash ! functions integer :: aval a1=MISS a2=MISS wtyp=parmge if (string == 'x/x' .or. string == 'X/X' .or. string == './.') then return else slash=0 lent=len_trim(string) do i=1, lent if (string(i:i) == '/' .and. slash == 0) slash=i end do if (slash /= 0) then ! an allele of the form /a/? if (slash < lent .and. string(lent:lent) == '/') then a1=aval(trim(string((slash+1):(lent-1))),1) a2=a1 wtyp=partra ! legal genotype? else a1=dble(aval(string(1:(slash-1)),1)) a2=dble(aval(string((slash+1):lent),1)) if (a1 > a2) then tmp=a1 a1=a2 a2=tmp end if wtyp=pargen end if end if end if end subroutine getgeno ! ! Increment counter mod maxpos ! subroutine incpos(pos, minpos, maxpos) integer, intent(inout) :: pos integer, intent(in) :: minpos integer, intent(in) :: maxpos if (pos >= maxpos) then pos=minpos else pos=pos+1 end if end subroutine incpos ! ! Get values for trait in all members of given class ! subroutine getclassval(stratvar, trait, sumval, summary, & nloci, loc, locpos, loctyp, locnotes, dataset, plevel) use outstream use ped_class use scanner use categorical_data use contingency_table use read_data use locus_types implicit none integer, intent(in) :: stratvar, trait, sumval character (len=3), intent(in) :: summary integer, intent(in) :: nloci character (len=*), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp character (len=*), dimension(:), intent(in) :: locnotes type (ped_data) :: dataset integer, intent(in) :: plevel integer, parameter :: MISS=-9999 integer, dimension(dataset%nobs) :: stratum type (table_data) :: table type (table_cell), dimension(1) :: cell_val integer :: astat, i, is, lpos, ltrait, nmiss, nstrata, ped, pos character(len=10) :: slabel double precision :: val integer, dimension(1) :: loclist double precision, dimension(:), allocatable :: mean, minv, maxv integer, dimension(:), allocatable :: n loclist(1)=stratvar call maketab(0, 0, 1, loclist, nloci, loc, locpos, loctyp, & dataset, nmiss, table) call sort_table(table) nstrata=table%ncells allocate(n(nstrata)) allocate(mean(nstrata), minv(nstrata), maxv(nstrata)) n=0 mean=0.0d0 minv=1.0d99 maxv=-1.0d99 if (plevel > -1) then write(outstr,'(3a,i0,a)') & 'Classifying variable "', trim(loc(stratvar)), & '" has ', nstrata, ' levels.' end if lpos=locpos(stratvar) ltrait=locpos(trait) stratum=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) val=dataset%plocus(i, lpos) if (val /= MISS) then call set_table_cell(cell_val(1), rvalue=val) is=search_table(1, cell_val, table, plevel-2) if (is > 0) then val=dataset%plocus(i, ltrait) if (val /= MISS) then stratum(i)=is n(is)=n(is)+1 mean(is)=mean(is)+val if (val < minv(is)) minv(is)=val if (val > maxv(is)) maxv(is)=val end if end if end if end do end if end do write(outstr, '(/a10,a)') & loc(stratvar),' N mean minimum maximum' do is=1, nstrata mean(is)=mean(is)/dfloat(n(is)) pos = table%idx(is) call get_label(table%categories(pos,1)%rvalue, & get_notes(loc(stratvar), locnotes(stratvar)), slabel, .false.) write(outstr, '(a10, i8,3(1x,g14.4))') & slabel, n(is), mean(is), minv(is), maxv(is) end do if (sumval /= MISS) then lpos=locpos(sumval) do i=1, dataset%nobs if (stratum(i) /= 0) then if (summary=='mea') then dataset%plocus(i, lpos) = mean(stratum(i)) else if (summary=='max') then dataset%plocus(i, lpos) = maxv(stratum(i)) else if (summary=='min') then dataset%plocus(i, lpos) = minv(stratum(i)) else if (summary=='cou') then dataset%plocus(i, lpos) = n(stratum(i)) else if (summary=='sum') then dataset%plocus(i, lpos) = dble(n(stratum(i)))*mean(stratum(i)) end if end if end do end if end subroutine getclassval ! ! Get values for trait in relatives ! subroutine getrelval(relate, summary, locnam, loctyp, trait, & sumval, dataset, plevel) use outstream use ped_class implicit none character (len=3), intent(in) :: relate, summary character (len=*), intent(in) :: locnam integer, intent(in) :: loctyp integer, intent(in) :: trait, sumval type (ped_data) :: dataset integer, intent(in) :: plevel ! integer, parameter :: MISS=-9999, MAXREC=20 ! trait values in relatives integer, dimension(dataset%maxsiz) :: nobs integer, dimension(dataset%maxsiz, MAXREC) :: relid integer :: currf, currm, fin, i, idx, itwin, j, k, nsibs, num, pedoffset, & ped, pos, reltyp, sta, totmis, totobs logical :: spouse1, spouse2 character (len=1) :: ch character (len=9), dimension(14) :: relnam = (/ & 'All ', & 'Offspring', 'Son ', 'Daughter ', & 'Parent ', 'Father ', 'Mother ', & 'Sibling ', 'Brother ', 'Sister ', & 'Spouse ', 'Husband ', 'Wife ', & 'MZ twin ' /) reltyp=1 if (relate=='chi' .or. relate=='off') then reltyp=2 else if (relate=='son') then reltyp=3 else if (relate=='dau') then reltyp=4 else if (relate=='par') then reltyp=5 else if (relate=='fat') then reltyp=6 else if (relate=='mot') then reltyp=7 else if (relate=='sib') then reltyp=8 else if (relate=='bro') then reltyp=9 else if (relate=='sis') then reltyp=10 else if (relate=='spo') then reltyp=11 else if (relate=='hus') then reltyp=12 else if (relate=='wif') then reltyp=13 else if (relate=='mzt') then reltyp=14 end if if (plevel >= 0) then write(outstr, '(/3a/a)') & 'Pedigree ID Rel Summary (', summary, ')', & '------------ ------------ --- --------------------' end if totmis=0 totobs=0 ! All family members if (reltyp==1) then do ped=1, dataset%nped if (dataset%actset(ped) > 0) then call priallval(summary, trait, loctyp, ped, sumval, totobs, totmis, dataset, plevel) end if end do ! Offspring else if (reltyp==2 .or. reltyp==3 .or. reltyp==4) then do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset do k=1, num nobs(k)=-1 end do do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped) if (reltyp==2 .or. (reltyp==3 .and. dataset%sex(i)==1) .or. & (reltyp==4 .and. dataset%sex(i)==2)) then currf=dataset%fa(i)-pedoffset currm=dataset%mo(i)-pedoffset if (nobs(currf)<0) nobs(currf)=0 if (nobs(currm)<0) nobs(currm)=0 if (dataset%plocus(i,trait) /= MISS) then if (nobs(currf) < MAXREC) then nobs(currf)=nobs(currf)+1 relid(currf, nobs(currf))=i end if if (nobs(currm) < MAXREC) then nobs(currm)=nobs(currm)+1 relid(currm, nobs(currm))=i end if end if end if end do call prirelval(relnam(reltyp), summary, trait, loctyp, ped, nobs, relid, & sumval, totobs, totmis, dataset, plevel) end if end do ! Parents else if (reltyp==5 .or. reltyp==6 .or. reltyp==7) then do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset do k=1, num nobs(k)=-1 end do do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped) idx = i-pedoffset if (nobs(idx)<0) nobs(idx)=0 currf=dataset%fa(i) currm=dataset%mo(i) if (reltyp/=7) then if (dataset%plocus(currf,trait)/=MISS .and. nobs(idx) < MAXREC) then nobs(idx)=nobs(idx)+1 relid(idx, nobs(idx))=currf end if end if if (reltyp/=6) then if (dataset%plocus(currm,trait)/=MISS .and. nobs(idx) < MAXREC) then nobs(idx)=nobs(idx)+1 relid(idx, nobs(idx))=currm end if end if end do call prirelval(relnam(reltyp), summary, trait, loctyp, ped, nobs, relid, & sumval, totobs, totmis, dataset, plevel) end if end do ! Siblings else if (reltyp==8 .or. reltyp==9 .or. reltyp==10) then do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) pos=pedoffset+dataset%nfound(ped) num=dataset%num(ped)-dataset%num(ped-1) nobs(1:dataset%nfound(ped))=-1 nobs((dataset%nfound(ped)+1):num)=0 currf=MISS currm=MISS fin=dataset%num(ped) do while (fin > pos) currf=dataset%fa(fin) currm=dataset%mo(fin) nsibs=1 sta=fin-1 do while (dataset%fa(sta)==currf .and. dataset%mo(sta)==currm) nsibs=nsibs+1 sta=sta-1 end do sta=sta+1 do i=sta, fin idx=i-pedoffset do j=sta, fin if (i /= j) then if (reltyp == 8 .or. (reltyp == 9 .and. dataset%sex(j) == 1) .or. & (reltyp == 10 .and. dataset%sex(j) == 2)) then if (dataset%plocus(j,trait) /= MISS .and. & dataset%imztwin(j) /= i .and. & dataset%imztwin(i) /= j .and. & nobs(idx) < MAXREC) then nobs(idx)=nobs(idx)+1 relid(idx, nobs(idx))=j end if end if end if end do end do fin=sta-1 end do call prirelval(relnam(reltyp), summary, trait, loctyp, ped, nobs, relid, & sumval, totobs, totmis, dataset, plevel) end if end do ! Spouses else if (reltyp==11 .or. reltyp==12 .or. reltyp==13) then do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset do k=1, num nobs(k)=-1 end do currf=MISS currm=MISS do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped) if (dataset%fa(i)/=currf .or. dataset%mo(i)/=currm) then spouse1 = (dataset%fa(i) /= currf) spouse2 = (dataset%mo(i) /= currm) currf=dataset%fa(i) currm=dataset%mo(i) if (reltyp /= 13 .and. spouse1) then idx = currm-pedoffset if (nobs(idx) < 0) nobs(idx)=0 if (dataset%plocus(currf,trait) /= MISS .and. nobs(idx) < MAXREC) then nobs(idx)=nobs(idx)+1 relid(idx, nobs(idx))=currf end if end if if (reltyp /= 12 .and. spouse2) then idx = currf-pedoffset if (nobs(idx)<0) nobs(idx)=0 if (dataset%plocus(currm,trait) /= MISS .and. nobs(idx) < MAXREC) then nobs(idx)=nobs(idx)+1 relid(idx, nobs(idx))=currm end if end if end if end do call prirelval(relnam(reltyp), summary, trait, loctyp, ped, nobs, relid, & sumval, totobs, totmis, dataset, plevel) end if end do ! MZ Twins else if (reltyp==14) then do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset do k=1, num nobs(k)=-1 end do do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped) if (dataset%imztwin(i) /= MISS) then idx=i-pedoffset itwin=dataset%imztwin(i)-pedoffset if (nobs(idx) < 0) nobs(idx)=0 if (nobs(itwin) < 0) nobs(itwin)=0 if (dataset%plocus(itwin+pedoffset,trait) /= MISS .and. nobs(idx) < MAXREC) then nobs(idx)=nobs(idx)+1 relid(idx,nobs(idx))=pedoffset+itwin end if if (dataset%imztwin(itwin+pedoffset) == MISS .and. & dataset%plocus(idx+pedoffset,trait) /= MISS .and. nobs(itwin) < MAXREC) then nobs(itwin)=nobs(itwin)+1 relid(itwin, nobs(itwin))=pedoffset+idx end if end if end do call prirelval(relnam(reltyp), summary, trait, loctyp, ped, nobs, relid, & sumval, totobs, totmis, dataset, plevel) end if end do end if if (plevel <= 0 .and. totobs>=30) then write(outstr, '(a)') '...' end if write(outstr, '(/a,i0,a)', advance='no') & 'Processed ', totobs, ' trait values from relatives' if (totmis > 0) then write(outstr, '(a,i0,a)', advance='no') & ' (Unable to evaluate ', totmis, ' records)' end if write(outstr,'(a)') '.' end subroutine getrelval ! ! Output single summary value for entire pedigree ! subroutine priallval(summary, trait, loctyp, ped, sumval, totobs, totmis, dataset, plevel) use outstream use ped_class use locus_types use rngs implicit none character (len=3), intent(in) :: summary integer, intent(in) :: trait, loctyp integer, intent(in) :: ped integer, intent(in) :: sumval integer, intent(inout) :: totobs, totmis type (ped_data) :: dataset integer, intent(in) :: plevel ! integer, parameter :: MISS=-9999 double precision, parameter :: BIG=1.0d99 integer :: i, idx, j, n, pedoffset double precision :: minx, maxx, cumx, res character (len=1) :: ch n=0 pedoffset=dataset%num(ped-1) cumx=0.0d0 minx=BIG maxx=-BIG do i=pedoffset+1, dataset%num(ped) if (dataset%plocus(i, trait) /= MISS) then n=n+1 cumx=cumx+dataset%plocus(i, trait) minx=min(minx, dataset%plocus(i, trait)) maxx=max(maxx, dataset%plocus(i, trait)) else totmis=totmis+1 end if end do totobs=totobs+n if (n > 0) then if (summary=='sam') then if (sumval /= MISS) then do i=pedoffset+1, dataset%num(ped) dataset%plocus(i, sumval)=dataset%plocus(i, trait) end do call sample(sumval, ped, dataset, 2) if (plevel>=0) then write(outstr, '(a12,1x,a12,1x,a3,2x,a)') & dataset%pedigree(ped), ' -' , 'All', 'Permuted' end if end if return else if (loctyp == LOC_AFF) cumx=cumx-dble(n) if (summary=='sum') then res=cumx else if (summary=='mea') then res=cumx/dble(n) else if (summary=='min') then res=minx else if (summary=='max') then res=maxx else if (summary=='cou') then res=dble(n) end if if (plevel >= 0) then write(outstr, '(a12,1x,a12,1x,a3,1x,f16.4)') & dataset%pedigree(ped), ' -' , 'All', res end if end if else res=MISS if (plevel >= 0) then write(outstr, '(a12,1x,a12,1x,a3,12x,a)') & dataset%pedigree(ped), ' -' , 'All', 'x' end if end if if (sumval /= MISS) then do i=pedoffset+1, dataset%num(ped) dataset%plocus(i,sumval)=res end do end if end subroutine priallval ! ! Output values for each eligible person ! subroutine prirelval(relate, summary, trait, loctyp, ped, & nobs, relid, sumval, totobs, totmis, dataset, plevel) use outstream use ped_class use locus_types use rngs implicit none integer, parameter :: MAXREC=20 character (len=3), intent(in) :: relate character (len=3), intent(in) :: summary integer, intent(in) :: trait, loctyp integer, intent(in) :: ped type (ped_data) :: dataset ! trait values in relatives integer, dimension(dataset%maxsiz) :: nobs integer, dimension(dataset%maxsiz, MAXREC) :: relid integer, intent(in) :: sumval integer, intent(inout) :: totobs, totmis integer, intent(in) :: plevel ! integer, parameter :: MISS=-9999 integer :: chosen, i, idx, j, n, pedoffset double precision :: res character (len=1) :: ch ! ! Detailed output ! pedoffset=dataset%num(ped-1) if (plevel > 1) then idx=0 do i=pedoffset+1, dataset%num(ped) idx=idx+1 if (nobs(idx) == 0) then write(outstr, '(a12,1x,a12,1x,a3,2x,a)') & dataset%pedigree(ped), dataset%id(i), relate, 'Nil' else if (nobs(idx) > 0) then write(outstr, '(a12,1x,a12,1x,a3,1x,i3)', advance='no') & dataset%pedigree(ped), dataset%id(i), relate, nobs(idx) if (loctyp == LOC_AFF) then do j=1, nobs(idx) call wraff(dataset%plocus(relid(idx,j),trait), ch, 1) write(outstr,'(1x,3a)', advance='no') & trim(dataset%id(relid(idx,j))), ': ', ch end do write(outstr,*) else write(outstr, *) & (' ', trim(dataset%id(relid(idx,j))), ': ', & dataset%plocus(relid(idx,j),trait), '; ', j=1, nobs(idx)) end if end if end do write(outstr, *) end if if (summary == 'sum' .or. summary == 'mea') then idx=0 do i=pedoffset+1, dataset%num(ped) idx=idx+1 res=MISS if (nobs(idx) > 0) then totobs=totobs+1 res=0.0d0 do j=1, nobs(idx) res=res+dataset%plocus(relid(idx,j),trait) end do if (loctyp == LOC_AFF) res=res-dble(nobs(idx)) if (summary=='mea') res=res/dble(nobs(idx)) if (plevel>0 .or. (plevel==0 .and. totobs<30)) then write(outstr, '(a12,1x,a12,1x,a3,1x,f16.4)') & dataset%pedigree(ped), dataset%id(i), relate, res end if else if (nobs(idx) == 0) then totmis=totmis+1 if (plevel > 0 .or. (plevel == 0 .and. totobs < 30 .and. totmis < 30)) then write(outstr, '(a12,1x,a12,1x,a3,12x,a)') & dataset%pedigree(ped), dataset%id(i), relate, 'x' end if end if if (sumval /= MISS) dataset%plocus(i, sumval)=res end do else if (summary == 'min') then idx=0 do i=pedoffset+1, dataset%num(ped) idx=idx+1 res=MISS if (nobs(idx) > 0) then totobs=totobs+1 res=dataset%plocus(relid(idx,1),trait) do j=2, nobs(idx) res=min(res,dataset%plocus(relid(idx,j),trait)) end do if (plevel > 0 .or. (plevel == 0 .and. totobs < 30)) then write(outstr, '(a12,1x,a12,1x,a3,1x,f16.4)') & dataset%pedigree(ped), dataset%id(i), relate, res end if else if (nobs(idx) == 0) then totmis=totmis+1 if (plevel > 0 .or. (plevel == 0 .and. totobs < 30 .and. totmis < 30)) then write(outstr, '(a12,1x,a12,1x,a3,12x,a)') & dataset%pedigree(ped), dataset%id(i), relate, 'x' end if end if if (sumval /= MISS) dataset%plocus(i, sumval)=res end do else if (summary == 'max') then idx=0 do i=pedoffset+1, dataset%num(ped) idx=idx+1 res=MISS if (nobs(idx) > 0) then totobs=totobs+1 res=dataset%plocus(relid(idx,1),trait) do j=2, nobs(idx) res=max(res,dataset%plocus(relid(idx,j),trait)) end do if (plevel > 0 .or. (plevel == 0 .and. totobs < 30)) then write(outstr, '(a12,1x,a12,1x,a3,1x,f16.4)') & dataset%pedigree(ped), dataset%id(i), relate, res end if else if (nobs(idx) == 0) then totmis=totmis+1 if (plevel > 0 .or. (plevel == 0 .and. totobs < 30 .and. totmis < 30)) then write(outstr, '(a12,1x,a12,1x,a3,12x,a)') & dataset%pedigree(ped), dataset%id(i), relate, 'x' end if end if if (sumval /= MISS) dataset%plocus(i, sumval)=res end do else if (summary=='cou') then idx=0 do i=pedoffset+1, dataset%num(ped) idx=idx+1 res=MISS if (nobs(idx) >= 0) then totobs=totobs+1 res=dble(nobs(idx)) if (plevel>0 .or. (plevel==0 .and. totobs<30)) then write(outstr, '(a12,1x,a12,1x,a3,i13)') & dataset%pedigree(ped), dataset%id(i), relate, int(res) end if else if (nobs(idx) == 0) then totmis=totmis+1 if (plevel > 0 .or. (plevel == 0 .and. totobs < 30 .and. totmis < 30)) then write(outstr, '(a12,1x,a12,1x,a3,12x,a)') & dataset%pedigree(ped), dataset%id(i), relate, 'x' end if end if if (sumval /= MISS) dataset%plocus(i, sumval)=res end do else if (summary=='sam') then idx=0 do i=pedoffset+1, dataset%num(ped) idx=idx+1 res=MISS if (nobs(idx) > 0) then totobs=totobs+1 ! ! sibships include ego -- useful for sibship mean etc, ! but possibly not for sampling do chosen=relid(idx,irandom(1, nobs(idx))) if (chosen /= i .or. nobs(idx) == 1) exit end do res=dataset%plocus(chosen, trait) if (plevel>0 .or. (plevel==0 .and. totobs<30)) then if (loctyp == LOC_AFF) then call wraff(res, ch, 1) write(outstr, '(a12,1x,a12,1x,a3,12x,a1)') & dataset%pedigree(ped), dataset%id(i), relate, ch else write(outstr, '(a12,1x,a12,1x,a3,1x,f16.4)') & dataset%pedigree(ped), dataset%id(i), relate, res end if end if else if (nobs(idx) == 0) then totmis=totmis+1 if (plevel > 0 .or. (plevel == 0 .and. totobs < 30 .and. totmis < 30)) then write(outstr, '(a12,1x,a12,1x,a3,12x,a)') & dataset%pedigree(ped), dataset%id(i), relate, 'x' end if end if if (sumval /= MISS) dataset%plocus(i, sumval)=res end do end if end subroutine prirelval ! ! Evaluate expression for each pedigree member ! subroutine evalped(narg, words, nloci, loc, lochash, loctyp, locpos, & locnotes, locstat, wtyp, wtag, expr, allele_buffer, & dataset, chek, imp, maxtry, droperr, plevel) use outstream use parser_data use ped_class use alleles_class use locus_types use locus_list use lochash_class integer, intent(in) :: narg character (len=*), dimension(:), intent(in out) :: words integer, intent(in out) :: nloci character (len=*), dimension(:), intent(in out) :: loc type (hash_table) :: lochash integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=*), dimension(:), intent(in) :: locnotes double precision, dimension(:), intent(inout) :: locstat integer (kind=1), dimension(:), intent(inout) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(inout) :: expr type (allele_data), intent(inout) :: allele_buffer type (ped_data) :: dataset logical, intent(in) :: chek integer, intent(in) :: imp integer, intent(in) :: maxtry integer, intent(in) :: droperr integer, intent(in) :: plevel ! local variables integer, parameter :: KNOWN=0, MISS=-9999 integer :: actn, eop, error, g1, g2, i, ians, nchange, nev, nerr, nmark, & nmiss, nped, nterm, ped, sta, tot, trget, tarpos, tartyp integer :: ndiscard, inconsist, pedincon integer, dimension(nloci) :: temptyp character (len=7) :: gtp, ogtp double precision :: tmp, x1, x2 ! Copy of master evaluation stack integer :: mterm integer (kind=1), dimension(:), allocatable :: mtyp integer, dimension(:), allocatable :: mtag double precision, dimension(:,:), allocatable :: mexpr ! functions logical :: ismis, isvar, isvec, legall interface subroutine typwords(farg, larg, words, nloci, loc, lochash, loctyp, & wtyp, wtag, expr, actn) use parser_data use locus_types use lochash_class integer, intent(in) :: farg integer, intent(in) :: larg character (len=*), dimension(:), intent(in out) :: words integer, intent(in) :: nloci character (len=*), dimension(nloci), intent(in) :: loc type (hash_table) :: lochash integer, dimension(nloci), intent(in) :: loctyp integer (kind=1), dimension(:), intent(inout) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(inout) :: expr integer, intent(out) :: actn end subroutine typwords subroutine loadvar(idx, nloci, loctyp, locpos, & dataset, sta, fin, wtyp, wtag, expr) use parser_data use ped_class integer, intent(in) :: idx integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data) :: dataset integer, intent(in) :: sta integer, intent(in) :: fin integer (kind=1), dimension(:), intent(inout) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(inout) :: expr end subroutine loadvar subroutine parser(nterm, wtyp, wtag, expr, error) use parser_data integer, intent(inout) :: nterm integer (kind=1), dimension(:), intent(inout) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(inout) :: expr integer, intent(out) :: error end subroutine parser subroutine wrans(prefix, nterm, expr, wtyp, wtag, val) use parser_data character (len=*), intent(in) :: prefix integer, intent(in) :: nterm double precision, dimension(:,:), intent(in) :: expr integer (kind=1), dimension(:), intent(in) :: wtyp integer, dimension(:), intent(in) :: wtag double precision, intent(out) :: val end subroutine wrans subroutine check(checkall, nloci, loc, loctyp, locpos, locnotes, locstat, & dataset, droperr, ndiscard, inconsist, plevel) use ped_class use locstring_widths logical, intent(in) :: checkall integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=annotation_width), dimension(:), intent(in) :: locnotes double precision, dimension(:), intent(inout) :: locstat type (ped_data) :: dataset integer, intent(in) :: droperr integer, intent(inout) :: ndiscard integer, intent(inout) :: inconsist integer, intent(in) :: plevel end subroutine check subroutine start(maxtry, nloci, loc, loctyp, locpos, dataset, allele_buffer, & inconsist, plevel) use ped_class use alleles_class integer, intent(in) :: maxtry integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data) :: dataset type (allele_data), intent(inout) :: allele_buffer integer, intent(inout) :: inconsist integer, intent(in) :: plevel end subroutine start end interface call cntmark(nloci, loctyp, nmark, 1) nterm=narg call typwords(1, nterm, words, nloci, loc, lochash, loctyp, & wtyp, wtag, expr, actn) mterm=nterm allocate(mtyp(mterm), mtag(mterm), mexpr(mterm,2)) do j=1, mterm mtyp(j)=wtyp(j) mtag(j)=wtag(j) mexpr(j,1)=expr(j,1) mexpr(j,2)=expr(j,2) end do nchange=0 ndiscard=0 inconsist=0 nerr=0 nev=0 nmiss=0 nped=0 tot=0 trget=MISS ! evaluate for each member of pedigree do ped=1, dataset%nped if (dataset%actset(ped) > 0) then nped=nped+1 do i=dataset%num(ped-1)+1, dataset%num(ped) nev=nev+1 sta=1 nterm=mterm do j=1, mterm wtyp(j)=mtyp(j) wtag(j)=mtag(j) expr(j,1)=mexpr(j,1) expr(j,2)=mexpr(j,2) end do ! ! init variables in expr with value from locus() or environment ! call loadvar(i, nloci, loctyp, locpos, & dataset, sta, nterm, wtyp, wtag, expr) call parser(nterm, wtyp, wtag, expr, error) ! Update pedigree value if appropriate if (error == 0) then do ians=1, nterm if (.not.isvar(wtyp(ians))) then if (plevel > 1) then call wrans(trim(dataset%pedigree(dataset%iped(i))) // '-' // & trim(dataset%id(i)) // ' => ',nterm, expr, wtyp, wtag, tmp) end if else if (ismis(wtyp(ians))) then if (isvec(wtyp(ians))) then trget=wtag(ians) else trget=wtag(ians) end if else if (isvec(wtyp(ians))) then trget=wtag(ians) else trget=wtag(ians) end if if (expr(ians,1) == MISS) expr(ians,1)= -9999.001d0 end if tarpos=locpos(trget) tartyp=mod(loctyp(trget), LOC_DEL) x1=expr(ians,1) if (loctyp(trget) == LOC_AFF .and. x1 /= MISS) then if (x1 <= 0.0d0) then x1=1.0d0 else x1=2.0d0 end if end if if (ismarker(tartyp)) then if (isactive(tartyp)) then if (observed(i, tarpos, dataset) .and. x1 <= KNOWN) nmiss=nmiss+1 end if else if ((dataset%plocus(i,tarpos) /= MISS .and. x1 == MISS)) then nmiss=nmiss+1 end if nchange=nchange+1 ! If result is a trait, set to new value if (isspecial(tartyp)) then write(outstr,'(6a,f12.4)') & trim(dataset%pedigree(dataset%iped(i))),'-', & trim(dataset%id(i)), & ' at "', trim(loc(trget)), '" => ', x1 else if (istrait(tartyp)) then if (plevel > 1) then write(outstr,'(7a,f12.4,a,f12.4)') & 'Recoded ', trim(dataset%pedigree(dataset%iped(i))),'-', & trim(dataset%id(i)), & ' at "', trim(loc(trget)), '" from ', & dataset%plocus(i,tarpos),' to ', x1 end if dataset%plocus(i,tarpos)=x1 ! ! Else if result of evaluation is a marker, ! Genotype can change sign via arithmetic operations ! (go from + -> - == typed to untyped, and vice-versa, ! and change range of allele codes ! else if (x1 /= MISS) then x1=anint(x1) if (x1 == 0.0d0) x1=MISS x2=anint(expr(ians,2)) if (x2 == 0.0d0) x2=MISS else x2=MISS end if if (x1 > x2) then tmp=x2 x2=x1 x1=tmp end if if (legall(x1) .and. legall(x2)) then call get_geno(i, tarpos, tarpos+1, dataset, g1, g2) call wrgtp(g1, g2, gtp, '/', '', 1) call wrgtp(int(x1), int(x2), ogtp, '/', '', 1) if (plevel > 1) then write(outstr,'(10a)') & 'Recoded ', trim(dataset%pedigree(dataset%iped(i))),'-', & trim(dataset%id(i)), & ' at "', trim(loc(trget)), '" from ', & gtp, ' to ', ogtp end if call set_geno(i, tarpos, tarpos+1, dataset, int(x1), int(x2)) else nerr=nerr+1 if (plevel > 1 .or. (plevel == 1 .and. nerr <= 10)) then write(outstr,'(5a)') & 'NOTE: Expression gives illegal genotype result ', & 'for ', trim(dataset%pedigree(dataset%iped(i))),'-', & trim(dataset%id(i)),'.' end if end if end if end if end do else nerr=nerr+1 if (plevel > 1 .or. (plevel == 1 .and. nerr <= 10)) then write(outstr,'(5a)') 'NOTE: Could not evaluate expression for ', & trim(dataset%pedigree(dataset%iped(i))),'-', trim(dataset%id(i)),'.' end if end if end do tot=tot+dataset%num(ped)-dataset%num(ped-1) end if end do ! ! Mendel check if result a marker and regenerate genotype start values ! if (chek .and. trget /= MISS) then if (ismarker(loctyp(trget)) .and. .not.ishaploid(loctyp(trget))) then temptyp(1:nloci)=loctyp(1:nloci) do i=1, nloci if (ismarker(loctyp(i)) .and. isactive(loctyp(i)) .and. i /= trget) then temptyp(i)=temptyp(i)+LOC_DEL else if (i == trget .and. .not.isactive(loctyp(trget))) then temptyp(i)=temptyp(i)-LOC_DEL end if end do call check(.true., nloci, loc, temptyp, locpos, locnotes, locstat, & dataset, droperr, ndiscard, inconsist, plevel) if (imp == 3) then call exclude_onelocus(imp, locpos(trget), loc(trget), loctyp(trget), dataset, & inconsist, imputd, pedincon, plevel) else if (imp >= 0) then call freq(locpos(trget), temptyp(trget), 0, dataset, allele_buffer) call start(maxtry, nloci, loc, temptyp, locpos, dataset, allele_buffer, & inconsist, plevel) end if end if end if ! if (plevel >= 0) then write(outstr,'(a,i0,a)') 'Recoded ',nchange,' values.' if (nmiss > 0) then write(outstr,'(a,i0,a)') 'Including ',nmiss,' values to missing.' end if if (nerr > 0) then write(*,'(a,i0,a,f5.1,a)') & 'Could not evaluate expression for ',nerr,' records (', & dble(100*nerr)/dble(nev),'%), which are left unchanged.' end if if (inconsist > 0) then write(outstr,'(/a,i0,a,f5.1,a/7x,a)') & 'NOTE: Evaluation of expressions gave rise to ',inconsist, & ' Mendelian inconsistencies (', dble(100*inconsist)/dble(nev),'%)' if (droperr >= 2) then write(outstr,'(7x,a,i0,a)') & 'Resolved these by deleting ',ndiscard,' genotypes.' end if end if end if end subroutine evalped ! ! Find if/then/else ! subroutine findth(nterm, wtyp, wtag, posif, posth, posel, posen) use parser_data integer, intent(in) :: nterm integer (kind=1), intent(inout) :: wtyp(nterm) integer, intent(inout) :: wtag(nterm) integer, intent(out) :: posif integer, intent(out) :: posth integer, intent(out) :: posel integer, intent(out) :: posen integer, parameter :: MISS=-9999 integer :: i, lev posif=MISS posth=MISS posel=MISS posen=nterm lev=0 do i=1, nterm if (wtyp(i) == partok) then if (wtag(i) == TOK_IF) then if (posif == MISS) then posif=i end if lev=lev+1 else if (wtag(i) == TOK_THEN .and. posth == MISS) then posth=i else if (wtag(i) == TOK_ELSE) then if (lev == 1 .and. posel == MISS) then posel=i end if lev=lev-1 end if end if end do end subroutine findth ! ! Find end of block ! subroutine findend(sta, fin, nterm, wtyp, wtag, posen) use parser_data integer, intent(in) :: sta, fin, nterm integer (kind=1), dimension(nterm), intent(in out) :: wtyp integer, dimension(nterm), intent(in out) :: wtag integer, intent(out) :: posen integer, parameter :: MISS=-9999 integer :: i, lev posen=fin lev=0 do i=max(1,sta), fin if (wtyp(i) == partok) then if (wtag(i) == TOK_END .or. wtag(i) == TOK_COLON) then if (lev == 0) then posen=i-1 return end if lev=lev-1 else if (wtag(i) == TOK_IF) then lev=lev+1 else if (wtag(i) == TOK_ELSE) then if (lev == 0) then posen=i-1 return end if lev=lev-1 end if end if end do end subroutine findend ! ! Find the start of a "where" clause on command line ! function findwh(farg, larg, narg, args) integer :: findwh integer, intent(in) :: farg, larg integer, intent(in) :: narg character (len=*), intent(in) :: args(narg) integer :: i do i=farg, larg if (args(i) == 'whe' .or. args(i) == 'where') then findwh=i return end if end do findwh=0 end function findwh ! ! Find a keyword -- exact match ! function findword(word, farg, larg, narg, args) integer :: findword character (len=*), intent(in) :: word integer, intent(in) :: farg, larg integer, intent(in) :: narg character (len=*), intent(in) :: args(narg) integer :: i do i=farg, larg if (args(i) == word) then findword=i return end if end do findword=0 end function findword ! ! Find matching bracket in string starting at a left bracket ! if unmatched, returns to end of line ! rb may equal lb, brackets may be nested ! subroutine findbracket(lb, rb, lin, sta, fin, istat) character (len=1), intent(in) :: lb, rb character (len=*), intent(in) :: lin integer, intent(in) :: sta integer, intent(out) :: fin integer, intent(out) :: istat integer :: eos, nb, pos eos=len_trim(lin) pos=sta fin=eos istat=-1 nb=1 do while (pos < eos) pos=pos+1 if (lin(pos:pos) == rb) nb=nb-1 if (nb == 0) then istat=0 fin=pos return end if if (lin(pos:pos) == lb) nb=nb+1 end do end subroutine findbracket ! ! Load variable values for ith individual ! code y and n as 1 and 0 ! tot records number of active records evaluated to date ! nped records number of active pedigrees evaluated to date ! subroutine loadvar(idx, nloci, loctyp, locpos, & dataset, sta, fin, wtyp, wtag, expr) use parser_data use ped_class use locus_types use read_data integer, intent(in) :: idx integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data) :: dataset integer, intent(in) :: sta integer, intent(in) :: fin integer (kind=1), dimension(:), intent(inout) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(inout) :: expr integer, parameter :: KNOWN=0, MISS=-9999 integer :: g1, g2, i, j, iloc, lpos, marcom integer (kind=1) :: ctyp integer :: ctag double precision :: res ! functions logical :: isenv, isvar, isvec do j=sta,fin ctyp=wtyp(j) ctag=wtag(j) ! automatic/environmental variables if (isenv(ctyp)) then wtyp(j)=partra expr(j,1)=MISS call autovar(idx, ctag, nloci, loctyp, locpos, dataset, res) if (res == MISS) then wtyp(j)=parmtr else expr(j,1)=res end if expr(j,2)=expr(j,1) ! user defined variables else if (isvar(ctyp)) then if (isvec(ctyp)) then call get_geno(idx, locpos(ctag), locpos(ctag)+1, dataset, g1, g2) expr(j,1)=dble(g1) expr(j,2)=dble(g2) if (expr(j,1) <= KNOWN) then wtyp(j)=parmge+parvar wtag(j)=ctag end if else lpos=locpos(ctag) if ((loctyp(ctag) == LOC_AFF .or. loctyp(ctag) == DEL_AFF) .and. & dataset%plocus(idx,lpos) >= 1) then expr(j,1)=dataset%plocus(idx,lpos)-1.0d0 else expr(j,1)=dataset%plocus(idx,lpos) end if expr(j,2)=expr(j,1) if (expr(j,1) == MISS) wtyp(j)=parmtr+parvar end if end if end do end subroutine loadvar ! ! Select pedigrees where probands meet a given criterion v2 ! subroutine doselect(typ, nprob, farg, larg, words, & nloci, loc, lochash, loctyp, locpos, wtyp, wtag, expr, & dataset, nobs, plevel) use outstream use parser_data use ped_class use lochash_class use locus_list integer, intent(in) :: typ integer, intent(in) :: nprob integer, intent(in) :: farg, larg character (len=*), dimension(:), intent(in out) :: words integer, intent(in out) :: nloci character (len=*), dimension(:), intent(in out) :: loc type (hash_table) :: lochash integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos integer (kind=1), dimension(:), intent(inout) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(in out) :: expr type (ped_data) :: dataset integer, intent(inout) :: nobs integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS=-9999 integer :: actn, error, fin, idx, maxact, nmark, nped, num, & nuse, ped, sta, tot, uped logical :: useful interface subroutine typwords(farg, larg, words, nloci, loc, lochash, loctyp, & wtyp, wtag, expr, actn) use parser_data use locus_types use lochash_class integer, intent(in) :: farg integer, intent(in) :: larg character (len=*), dimension(:), intent(in out) :: words integer, intent(in) :: nloci character (len=*), dimension(nloci), intent(in) :: loc type (hash_table) :: lochash integer, dimension(nloci), intent(in) :: loctyp integer (kind=1), dimension(:), intent(inout) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(inout) :: expr integer, intent(out) :: actn end subroutine typwords subroutine loadvar(idx, nloci, loctyp, locpos, & dataset, sta, fin, wtyp, wtag, expr) use parser_data use ped_class integer, intent(in) :: idx integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data) :: dataset integer, intent(in) :: sta integer, intent(in) :: fin integer (kind=1), dimension(:), intent(inout) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(inout) :: expr end subroutine loadvar subroutine prexpr(typ, nprob, farg, larg, words) integer, intent(in) :: typ integer, intent(in) :: nprob integer, intent(in) :: farg integer, intent(in) :: larg character (len=*), dimension(:), intent(inout) :: words end subroutine prexpr subroutine simpev(sta, fin, nterm, wtyp, wtag, expr, error) use parser_data integer, intent(in) :: sta integer, intent(inout) :: fin integer, intent(inout) :: nterm integer (kind=1), dimension(:), intent(inout) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(inout) :: expr integer, intent(out) :: error end subroutine simpev end interface if (plevel > -2) call prexpr(typ, nprob, farg, larg, words) call cntmark(nloci,loctyp,nmark,1) maxact=0 nped=0 uped=0 maxact=0 nobs=0 tot=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then useful=.false. nped=nped+1 num=dataset%num(ped)-dataset%num(ped-1) nuse=0 do idx=dataset%num(ped-1)+1, dataset%num(ped) sta=farg fin=larg nterm=larg call typwords(sta, fin, words, nloci, loc, lochash, loctyp, & wtyp, wtag, expr, actn) ! init variables in expr with value from locus() or environment call loadvar(idx, nloci, loctyp, locpos, & dataset, sta, fin, wtyp, wtag, expr) call simpev(sta, fin, nterm, wtyp, wtag, expr, error) ! test if condition true if (sta == fin .and. error == 0 .and. & expr(sta,1) /= MISS .and. expr(sta,1) /= 0.0d0) then nuse=nuse+1 if (typ /= 5 .and. nuse >= nprob) then useful=.true. exit end if end if end do if (typ == 5 .and. nuse == nprob) useful=.true. if (useful) then uped=uped+1 nobs=nobs+num maxact=max(maxact, num) if (plevel > 1) then write(outstr,'(3a,a8)') & 'Pedigree ', trim(dataset%pedigree(ped)), & ' selected via individual ', trim(dataset%id(idx)) end if dataset%actset(ped)=dataset%actset(ped)+1 else dataset%actset(ped)=-abs(dataset%actset(ped)) end if tot=tot+num end if end do dataset%maxact=maxact dataset%nact=uped if (plevel > -2) then write(outstr,'(/a,i0,a,i0,a/)') & 'Number of pedigrees selected=',uped,' (',nobs,' individuals)' end if end subroutine doselect ! ! Edit alleles for particular gene for particular person ! subroutine edit(tped, tid, gene, loc, loctyp, all1, all2, dataset, plevel) use outstream use ped_class use locus_types use string_utilities implicit none character (len=ped_width), intent(in) :: tped character (len=id_width), intent(in) :: tid integer, intent(in) :: gene character(len=20), intent(in) :: loc integer, intent(in) :: loctyp double precision, intent(in) :: all1, all2 type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel ! local integer, parameter :: MISS=-9999, KNOWN=0 integer :: i, ios, j, eop, gen2, nchanges, old1, old2, ped integer (kind=1), dimension(1) :: zero = (/ 0 /) logical :: allids double precision :: g1, g2, tmp character (len=1) :: newbin, oldbin character (len=7) :: newgtp, oldgtp ! functions ! logical :: strfind allids=(tid == 'all') gen2=gene+1 nchanges=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0 .and. & strfind(tped, dataset%pedigree(ped), 1)) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (allids .or. strfind(tid, dataset%id(i), 1)) then if (gene == MISS) then if ((plevel > -1 .and. nchanges < 5) .or. plevel > 1) then write(outstr,'(4a)') 'Deleting all data for ', & trim(dataset%pedigree(ped)), '--', trim(dataset%id(i)) end if do j=1, dataset%numloc(PCLASS) dataset%plocus(i,j)=MISS end do do j=1, dataset%numloc(GCLASS) dataset%glocus(i,j)=MISS end do if (dataset%hassnps /= 0) then call matrix_set_row(zero, i, dataset%slocus, ios) end if else if (isactdip(loctyp)) then call get_geno(i, gene, gen2, dataset, old1, old2) if (all1 > all2) then g2=all1 g1=all2 else g1=all1 g2=all2 end if call wrgtp(int(g1), int(g2), newgtp, '/', '', 1) call wrgtp(old1, old2, oldgtp, '/', '', 1) if ((plevel > -1 .and. nchanges < 5) .or. plevel > 1) then write(outstr,'(10a)') & 'Changing ', trim(dataset%pedigree(ped)),'--', trim(dataset%id(i)), & ' at locus "', trim(loc), '" from ', oldgtp, ' to ', newgtp end if call set_geno(i, gene, gen2, dataset, int(g1), int(g2)) else if (same_loctyp(loctyp, LOC_CAT) .or. & same_loctyp(loctyp, LOC_QUA)) then if ((plevel > -1 .and. nchanges < 5) .or. plevel > 1) then write(outstr,'(7a,f8.4,a,f8.4)') & 'Changing ', trim(dataset%pedigree(ped)),'--', trim(dataset%id(i)), & ' at locus "', trim(loc), '" from ', & dataset%plocus(i,gene), ' to ', all1 end if dataset%plocus(i,gene)=all1 else if (same_loctyp(loctyp, LOC_AFF)) then call wraff(all1, newbin, 1) call wraff(dataset%plocus(i,gene), oldbin, 1) if ((plevel > -1 .and. nchanges < 5) .or. plevel > 1) then write(outstr,'(7a,a8,a,a8)') & 'Changing ', trim(dataset%pedigree(ped)),'--', trim(dataset%id(i)), & ' at locus "', trim(loc), '" from ', oldbin,' to ', newbin end if dataset%plocus(i,gene)=all1 else if (ishaploid(loctyp) .and. isactive(loctyp)) then call get_geno(i, gene, gen2, dataset, old1, old2) call wrall(old1, oldgtp) call wrall(int(g1), newgtp) if ((plevel > -1 .and. nchanges < 5) .or. plevel > 1) then write(outstr,'(10a)') & 'Changing ', trim(dataset%pedigree(ped)),'--', trim(dataset%id(i)), & ' at locus "', trim(loc), '" from ', oldgtp, ' to ', newgtp end if call set_geno(i, gene, gen2, dataset, int(g1), int(g1)) end if nchanges=nchanges+1 end if end do end if end do if (nchanges == 0) then write(outstr,'(5a)') 'ERROR: Did not find any record matching "', & trim(tped), '--', trim(tid), '".' else if (nchanges > 1 .and. plevel > -2) then if (nchanges>4 .and. plevel < 2) then write(outstr,'(a)') 'Further edits not shown...' end if if (gene==MISS) then write(outstr,'(a,i0,a/)') 'Deleted ', nchanges, ' records.' else write(outstr,'(a,i0,a/)') 'Altered ', nchanges, ' records.' end if end if end subroutine edit ! ! Copy data for person A to person B ! typ=1 overwrite at B if A nonmissing for that variable ! typ=2 insert data only where B is missing for that variable ! subroutine copydata(typ, ped1, id1, ped2, id2, & nloci, loc, loctyp, locpos, & dataset, hashtab, plevel) use outstream use idhash_class use ped_class use locus_types implicit none integer, intent(in) :: typ character (len=*), intent(in) :: ped1, ped2 character (len=*), intent(in) :: id1, id2 integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data), intent(inout) :: dataset type (hash_table) :: hashtab integer, intent(in) :: plevel ! local integer, parameter :: MISS=-9999 integer :: g1, g2, g3, g4, j, idx1, idx2, nchanges, nedits, pos character (len=9) :: gtp1, gtp2 nchanges=0 nedits=0 idx1=0 idx2=0 if (.not.hashtab%current) then call hashids(1, dataset, hashtab, 80, plevel-1) end if call matchid(1, ped1, id1, dataset, hashtab, idx1, plevel) call matchid(1, ped2, id2, dataset, hashtab, idx2, plevel) if (idx1 /= 0 .and. idx2 /= 0) then if (typ == 1) then write(outstr,'(9a)') & 'Replacing data for ', trim(ped2),'--', trim(id2), & ' with nonmissing data from ', trim(ped1), '--', trim(id1),'.' else write(outstr,'(9a)') & 'Updating missing data for ', trim(ped2),'--', trim(id2), & ' with nonmissing data from ', trim(ped1), '--', trim(id1),'.' end if if (plevel > 0) write(outstr,*) do j=1, nloci if (isactive(loctyp(j))) then if (ismarker(loctyp(j))) then pos=locpos(j) if (observed(idx1, pos, dataset) .and. & (typ == 1 .or. (typ == 2 .and. & .not.observed(idx2, pos, dataset)))) then nedits=nedits+1 call get_geno(idx1, pos, pos+1, dataset, g1, g2) if (observed(idx2, pos, dataset)) then call get_geno(idx2, pos, pos+1, dataset, g3, g4) if (g1 /= g3 .or. g2 /= g4) nchanges=nchanges+1 if (plevel > 0) then call wrgtp(g1, g2, gtp1, '/', '', 1) call wrgtp(g3, g4, gtp2, '/', '', 1) write(outstr,'(7a)') & 'Changing ', trim(loc(j)), & ' from "', trim(adjustl(gtp2)), '" to "', & trim(adjustl(gtp1)), '".' end if else if (plevel > 0) then call wrgtp(g1, g2, gtp1, '/', '', 1) write(outstr,'(5a)') & 'Changing ', trim(loc(j)), & ' from "x/x" to "', trim(adjustl(gtp1)), '".' end if end if call set_geno(idx2, pos, pos+1, dataset, g1, g2) end if else if (.not.isspecial(loctyp(j))) then pos=locpos(j) if (dataset%plocus(idx1,pos) /= MISS .and. & (typ == 1 .or. (typ == 2 .and. & dataset%plocus(idx2,pos) == MISS))) then nedits=nedits+1 if (dataset%plocus(idx2,pos) /= MISS .and. & dataset%plocus(idx2,pos) /= dataset%plocus(idx1,pos)) then nchanges=nchanges+1 end if if (plevel > 0) then call wrtrait(dataset%plocus(idx1,pos), gtp1, loctyp(j), ' ', 9, 4) call wrtrait(dataset%plocus(idx2,pos), gtp2, loctyp(j), ' ', 9, 4) write(outstr,'(7a)') & 'Changing ', trim(loc(j)), & ' from "', trim(adjustl(gtp2)), '" to "', & trim(adjustl(gtp1)), '".' end if dataset%plocus(idx2,pos)=dataset%plocus(idx1,pos) end if end if end if end do if (plevel > 0) write(outstr,*) write(outstr,'(a,i0,a,i0,a)') & 'Made ', nedits, ' changes (', nchanges,' destructive).' else if (idx1 == 0) then write(outstr,'(5a)') & 'ERROR: Could not find ID "', trim(ped1), '--', trim(id1), '".' end if if (idx2 == 0) then write(outstr,'(5a)') & 'ERROR: Could not find ID "', trim(ped2), '--', trim(id2), '".' end if end if end subroutine copydata ! ! Merge genotype data for two loci together eg same map position ! subroutine mergeloci(first, second, thresh, nloci, loc, loctyp, locpos, & locnotes, group, map, dataset, plevel) use outstream use nucleotides use alleles_class use ped_class use locstring_widths use locus_types implicit none integer, intent(in) :: first, second double precision, intent(in) :: thresh integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=*), dimension(:), intent(inout) :: locnotes character (len=*), dimension(:), intent(in) :: group double precision, dimension(:), intent(in) :: map type (ped_data) :: dataset integer, intent(in) :: plevel ! local integer, parameter :: MISS=-9999, KNOWN=0 type (allele_data) :: allele_buffer, allele_buffer2 integer :: amatch, nchanges, g11, g12, g21, g22, & gene1, gene12, gene2, gene22, & i, inconsist, j, nshared, totall logical :: can_flip character (len=2) :: oldall, newall character (len=3) :: sall character (len=7) :: oldgtp, newgtp double precision :: discord if (.not.(ismarker(loctyp(first)) .and. & same_loctyp(loctyp(first), loctyp(second)))) then write(outstr,'(a)') 'ERROR: Incompatible locus types!' return end if call freq(locpos(first), loctyp(first), 0, dataset, allele_buffer) call freq(locpos(second), loctyp(second), 0, dataset, allele_buffer2) if (plevel > 0) then call wrfreq(outstr, loc(first), group(first), map(first), & locnotes(first), allele_buffer, 15) call wrfreq(outstr, loc(second), group(second), map(second), & locnotes(second), allele_buffer2, 15) end if if (allele_buffer2%numal == 0) then if (plevel > 0) then write(outstr,'(3a)') & 'NOTE: "', trim(loc(second)), '" has no observed genotypes.' end if return end if ! ! totall amatch ! 4 2 unequivocal ! 3 2 ! 3 1 ! 3 0 ! if (allele_buffer%numal < 3 .and. allele_buffer2%numal < 3) then newall=' ' oldall=' ' do i=1, allele_buffer%numal call wrall(allele_buffer%allele_names(i), sall) if (len_trim(adjustl(sall)) == 1) then oldall(i:i)=trim(adjustl(sall)) end if end do do j=1, allele_buffer2%numal call wrall(allele_buffer2%allele_names(j), sall) if (len_trim(adjustl(sall)) == 1) then newall(j:j)=trim(adjustl(sall)) end if end do can_flip = ((newall == 'AG' .and. oldall == 'CT') .or. & (newall == 'CT' .and. oldall == 'AG') .or. & (newall == 'GT' .and. oldall == 'AC') .or. & (newall == 'AC' .and. oldall == 'GT')) end if totall=allele_buffer%numal + allele_buffer2%numal amatch=0 do i=1, allele_buffer%numal do j=1, allele_buffer2%numal if (allele_buffer%allele_names(i) == allele_buffer2%allele_names(j)) then amatch=amatch+1 end if end do end do if (totall > 2 .and. amatch == 0 .and. .not.can_flip) then write(outstr,'(6a)') & 'Skipped merging loci "', trim(loc(first)), '" and "', & trim(loc(second)), '" as possible strand mixup.' return end if gene1=locpos(first) gene12=gene1+1 gene2=locpos(second) gene22=gene2+1 nchanges=0 nshared=0 inconsist = 0 discord=0.0d0 do i=1, dataset%nobs call get_geno(i, gene1, gene12, dataset, g11, g12) call get_geno(i, gene2, gene22, dataset, g21, g22) if (observed(i, gene1, dataset) .and. observed(i, gene2, dataset)) then nshared=nshared+1 if (can_flip) then g21=flip_atgc(g21) g22=flip_atgc(g22) call order(g21,g22) end if if (g11 /= g21 .and. g12 /= g22) then inconsist=inconsist+1 if (plevel > 0) then call wrgtp(g21, g22, newgtp, '/', '', 1) call wrgtp(g11, g12, oldgtp, '/', '', 1) write(outstr,'(12a)') & 'NOTE: ', trim(dataset%pedigree(dataset%iped(i))), & '--', trim(dataset%id(i)), & ' at locus "', trim(loc(first)), '" is ', oldgtp, ' and at "', & trim(loc(second)), '" is ', newgtp end if end if end if end do discord=dble(inconsist)/dble(max(1,nshared)) if (discord <= thresh) then do i=1, dataset%nobs call get_geno(i, gene1, gene12, dataset, g11, g12) call get_geno(i, gene2, gene22, dataset, g21, g22) if (can_flip) then g21=flip_atgc(g21) g22=flip_atgc(g22) call order(g21,g22) end if if (.not.observed(i, gene1, dataset)) then if (plevel > 0) then call wrgtp(g21, g22, newgtp, '/', '', 1) write(outstr,'(8a)') & 'Changing ', trim(dataset%pedigree(dataset%iped(i))),'--', & trim(dataset%id(i)), & ' at locus "', trim(loc(first)), '" from x/x to ', newgtp end if nchanges=nchanges+1 call set_geno(i, gene1, gene12, dataset, g21, g22) else if (observed(i, gene2, dataset)) then if (g11 /= g21 .and. g12 /= g22) then inconsist=inconsist+1 if (plevel > 0) then call wrgtp(g21, g22, newgtp, '/', '', 1) call wrgtp(g11, g12, oldgtp, '/', '', 1) write(outstr,'(12a)') & 'NOTE: ', trim(dataset%pedigree(dataset%iped(i))), & '--', trim(dataset%id(i)), & ' at locus "', trim(loc(first)), '" is ', oldgtp, ' and at "', & trim(loc(second)), '" is ', newgtp end if end if end if end do write(outstr, '(a,i0,5a)') & 'Merged ', nchanges, ' genotypes from "', trim(loc(second)), & '" to "', trim(loc(first)), '".' write(newgtp,'(i7)') nchanges locnotes(second) = '*Merged* ' // trim(loc(first)) // & trim(newgtp) // ' genos' else write(outstr,'(5a,f5.1,a)') & 'Skipped merging loci "', trim(loc(first)), '" and "', & trim(loc(second)), '" as discordance exceeded ', 1.0d2*thresh, '%.' end if if (inconsist > 0) then write(outstr, '(a,i0,5a,f5.1,a)') & 'Encountered ', inconsist, ' genotype inconsistencies between "', & trim(loc(second)), '" and "', trim(loc(first)), & '" (', 1.0d2*discord, '%).' end if end subroutine mergeloci ! ! include or exclude a list of pedigrees ! subroutine selped(typ, farg, larg, words, dataset, plevel) use outstream use ped_class use string_utilities integer, intent(in) :: typ integer, intent(in) :: farg integer, intent(in) :: larg character (len=*), dimension(:), intent(in out) :: words type (ped_data) :: dataset integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS=-9999 integer :: i, maxact, nfam, ped, pos logical :: act, found, ltyp ! functions ! logical :: strfind ltyp=(typ == 2 .or. typ == 4) nfam=0 maxact=0 do ped=1, dataset%nped act=(dataset%actset(ped) > 0) found=ltyp if (typ <= 2) then family: do i=farg, larg if (act .and. strfind(trim(words(i)), dataset%pedigree(ped), 1)) then found=.not.found exit family end if end do family else person: do pos=dataset%num(ped-1)+1, dataset%num(ped) do i=farg, larg if (act .and. strfind(trim(words(i)), dataset%id(pos), 1)) then found=.not.found exit person end if end do end do person end if if (found) then nfam=nfam+1 maxact=max(maxact, dataset%num(ped)-dataset%num(ped-1)) dataset%actset(ped)=dataset%actset(ped)+1 if (plevel > 0) then write(outstr,'(2a)') 'Selected pedigree ', dataset%pedigree(ped) end if else dataset%actset(ped)=-abs(dataset%actset(ped)) end if end do dataset%nact=nfam dataset%maxact=maxact write(outstr,'(/a,i0,a)') 'Selected ', nfam, ' pedigrees.' end subroutine selped ! ! select pedigrees listed in file ! subroutine selped_fil(typ, port, hashtab, dataset, plevel) use outstream use ped_class use string_utilities use fileio use idhash_class use scanner implicit none type (ioport) :: port integer, intent(in) :: typ type (hash_table) :: hashtab type (ped_data) :: dataset integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS=-9999 logical, dimension(dataset%nped) :: pedstat integer :: i, ioerr, maxact, nfam, ped logical :: act, found, ltyp character (len=128) :: lin ! functions ! logical :: strfind logical :: iscomment ltyp=(typ == 2 .or. typ == 4) nfam=0 maxact=0 pedstat=ltyp if (typ < 3) then do call readline(port, lin, ios=ioerr) if (ioerr /= 0) then exit end if if (iscomment(lin)) cycle found=ltyp do ped=1, dataset%nped act=(dataset%actset(ped) > 0) if (act .and. strfind(lin(1:ped_width), dataset%pedigree(ped), 1)) then pedstat(ped) = .not.ltyp exit end if end do end do else call findids(port, lin, 0, 1, hashtab, dataset, plevel) do i=1, dataset%nobs if (.not.dataset%untyped(i)) then pedstat(dataset%iped(i))= .not.ltyp end if end do end if do ped=1, dataset%nped if (pedstat(ped)) then nfam=nfam+1 maxact=max(maxact, dataset%num(ped)-dataset%num(ped-1)) dataset%actset(ped)=dataset%actset(ped)+1 if (plevel > 0) then write(outstr,'(2a)') 'Selected pedigree ', dataset%pedigree(ped) end if else dataset%actset(ped)=-abs(dataset%actset(ped)) end if end do dataset%nact=nfam dataset%maxact=maxact write(outstr,'(/a,i0,a)') 'Selected ', nfam, ' pedigrees.' end subroutine selped_fil ! ! unselect ! subroutine unsel(dataset, rollback, plevel) use outstream use ped_class type (ped_data) :: dataset integer, intent(in) :: rollback integer, intent(in) :: plevel integer :: level, maxact, minlev, nact, nobs, num, ped maxact=0 nact=0 nobs=0 if (rollback == 0) then do ped=1, dataset%nped dataset%actset(ped)=1 end do dataset%nact=dataset%nped dataset%maxact=dataset%maxsiz nobs=dataset%nobs else if (plevel > 2) then write(outstr, '(a/a)') 'Pedigree Level', '---------- -----' end if minlev=0 do ped=1, dataset%nped if (plevel > 1) then write(outstr, '(a10,1x,i5)') & dataset%pedigree(ped), dataset%actset(ped) end if if (dataset%actset(ped) < minlev) then minlev=dataset%actset(ped) end if end do level=abs(minlev+rollback-1) if (plevel > 2) then write(outstr, '(/a,i0)') & 'Active pedigrees will be level >=', level end if do ped=1, dataset%nped if (abs(dataset%actset(ped)) >= level) then dataset%actset(ped)=abs(dataset%actset(ped)) nact=nact+1 num=dataset%num(ped)-dataset%num(ped-1) nobs=nobs+num maxact=max(maxact, num) else dataset%actset(ped)=-abs(dataset%actset(ped)) end if end do dataset%nact=nact dataset%maxact=maxact end if if (plevel > -2) then write(outstr,'(/a,i6,a,i0,a/)') & 'Number of active pedigrees=', dataset%nact, & ' (', nobs, ' individuals)' end if end subroutine unsel ! ! Count or print individuals per pedigree fulfilling criterion ! subroutine docount(typ, farg, larg, words, & nloci, loc, lochash, loctyp, locpos, locnotes, & wtyp, wtag, expr, & dataset, pedmask, nwid, ncatwid, ndec, sexcode, & misval, fieldsep, & allsep, show_cat, pstyle, plevel) use outstream use interrupt use parser_data use ped_class use lochash_class use locus_list integer, intent(in) :: typ integer, intent(in) :: farg integer, intent(in) :: larg character (len=40), dimension(:), intent(in out) :: words integer, intent(in out) :: nloci character (len=20), dimension(:), intent(in out) :: loc type (hash_table) :: lochash integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=*), dimension(nloci), intent(in) :: locnotes integer (kind=1), dimension(:), intent(inout) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(in out) :: expr type (ped_data) :: dataset logical, dimension(:), intent(in) :: pedmask integer, intent(in) :: nwid, ncatwid, ndec character (len=*), dimension(2), intent(in) :: sexcode character (len=*), intent(in) :: misval character (len=1), intent(in) :: fieldsep character (len=1), intent(in) :: allsep integer, intent(in) :: show_cat, pstyle, plevel ! Local variables integer, parameter :: MISS=-9999 integer :: actn, arg1, argn, currf, currm, contrib, error, fin, idx, k, nmark integer :: naff, nped, nasp, nast, nasq, nuse, taff, tasp, tast, tasq, tot integer :: ped, pedoffset ! functions character (len=8) :: wrpercent interface subroutine wrind(idx, nloci, loc, loctyp, locpos, dataset, & pedmask, nwid, ndec, misval, allsep, pstyle) use ped_class integer, intent(in) :: idx integer, intent(in) :: nloci character (len=20), dimension(nloci), intent(in) :: loc integer, dimension(nloci), intent(in) :: loctyp integer, dimension(nloci), intent(in) :: locpos type (ped_data) :: dataset logical, dimension(:), intent(in) :: pedmask integer, intent(in) :: nwid integer, intent(in) :: ndec character (len=*), intent(in) :: misval character (len=1), intent(in) :: allsep integer, intent(in) :: pstyle end subroutine subroutine prexpr(typ, nprob, farg, larg, words) integer, intent(in) :: typ integer, intent(in) :: nprob integer, intent(in) :: farg integer, intent(in) :: larg character (len=*), dimension(:), intent(inout) :: words end subroutine prexpr subroutine typwords(farg, larg, words, nloci, loc, lochash, loctyp, & wtyp, wtag, expr, actn) use parser_data use locus_types use lochash_class integer, intent(in) :: farg integer, intent(in) :: larg character (len=*), dimension(:), intent(in out) :: words integer, intent(in) :: nloci character (len=*), dimension(nloci), intent(in) :: loc type (hash_table) :: lochash integer, dimension(nloci), intent(in) :: loctyp integer (kind=1), dimension(:), intent(inout) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(inout) :: expr integer, intent(out) :: actn end subroutine typwords subroutine loadvar(idx, nloci, loctyp, locpos, & dataset, sta, fin, wtyp, wtag, expr) use parser_data use ped_class integer, intent(in) :: idx integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data) :: dataset integer, intent(in) :: sta integer, intent(in) :: fin integer (kind=1), dimension(:), intent(inout) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(inout) :: expr end subroutine loadvar subroutine simpev(sta, fin, nterm, wtyp, wtag, expr, error) use parser_data integer, intent(in) :: sta integer, intent(inout) :: fin integer, intent(inout) :: nterm integer (kind=1), dimension(:), intent(inout) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(inout) :: expr integer, intent(out) :: error end subroutine simpev subroutine pedout(strm, header, pedmask, fieldsep, allsep, imp, nwid, ndec, & ncatwid, sexcode, misval, nrc, skip, filter, show_cat, & nloci, loc, loctyp, locpos, locnotes, dataset) use ped_class integer, intent(in) :: strm integer, intent(in) :: header logical, dimension(:), intent(in) :: pedmask character (len=1), intent(in) :: fieldsep character (len=1), intent(in) :: allsep integer, intent(in) :: imp integer, intent(in) :: ncatwid, nwid integer, intent(in) :: ndec character (len=*), dimension(2), intent(in) :: sexcode character (len=*), intent(in) :: misval integer, intent(in) :: nrc, skip, filter, show_cat integer, intent(in) :: nloci character (len=*), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=*), dimension(:), intent(in) :: locnotes type (ped_data) :: dataset end subroutine pedout subroutine wrvert(nloci, loc, loctyp, locpos, locnotes, & dataset, nwid, ndec, ncatwid, allsep, plevel) use outstream use ped_class use locus_types integer, intent(in) :: nloci character (len=20), dimension(nloci), intent(in) :: loc integer, dimension(nloci), intent(in) :: loctyp integer, dimension(nloci), intent(in) :: locpos character (len=*), dimension(nloci), intent(in) :: locnotes type (ped_data) :: dataset integer, intent(in) :: ncatwid, nwid integer, intent(in) :: ndec character (len=1), intent(in) :: allsep integer, intent(in) :: plevel end subroutine wrvert end interface if (plevel >= 0) then call prexpr(typ, 1, farg, larg, words) end if if (typ == 1) then write(outstr,'(a/a)') & 'Pedigree Con=T Num ASPs Trios 4+', & '-------------------- ------ ------- ------ ------ ------' end if call cntmark(nloci, loctyp, nmark, 1) nped=0 nuse=0 taff=0 tasp=0 tast=0 tasq=0 tot=0 do ped=1, dataset%nped pedoffset=dataset%num(ped-1) if (dataset%actset(ped) > 0) then naff=0 nasp=0 nast=0 nasq=0 nped=nped+1 ! founders do idx= pedoffset+1, pedoffset + dataset%nfound(ped) arg1=farg argn=larg nterm=larg call typwords(arg1, argn, words, nloci, loc, lochash, loctyp, & wtyp, wtag, expr, actn) call loadvar(idx, nloci, loctyp, locpos, & dataset, arg1, argn, wtyp, wtag, expr) call simpev(arg1, argn, nterm, wtyp, wtag, expr, error) if (arg1 == argn .and. error == 0 .and. & ((expr(arg1,1) /= MISS .and. expr(arg1,1) /= 0.0d0) .or. & (expr(arg1,2) /= MISS .and. expr(arg1,2) /= 0.0d0))) then naff=naff+1 dataset%untyped(idx)=.false. else dataset%untyped(idx)=.true. end if end do ! nonfounders fin=dataset%num(ped) currf=dataset%fa(fin) currm=dataset%mo(fin) do k=dataset%num(ped)-1, pedoffset+dataset%nfound(ped), -1 if (dataset%fa(k) /= currf .or. dataset%mo(k) /= currm) then nfam=nfam+1 contrib=0 do idx=k+1,fin arg1=farg argn=larg nterm=larg call typwords(arg1, argn, words, nloci, loc, lochash, loctyp, & wtyp, wtag, expr, actn) ! init variables in expr with value from locus() or environment call loadvar(idx, nloci, loctyp, locpos, & dataset, arg1, argn, wtyp, wtag, expr) call simpev(arg1, argn, nterm, wtyp, wtag, expr, error) ! test if condition true if (arg1 == argn .and. error == 0 .and. & ((expr(arg1,1) /= MISS .and. expr(arg1,1) /= 0.0d0) .or. & (expr(arg1,2) /= MISS .and. expr(arg1,2) /= 0.0d0))) then naff=naff+1 contrib=contrib+1 dataset%untyped(idx)=.false. else dataset%untyped(idx)=.true. end if end do ! Now update to next sibship if (contrib == 2) then nasp=nasp+1 else if (contrib == 3) then nast=nast+1 else if (contrib > 3) then nasq=nasq+1 end if fin=k currf=dataset%fa(fin) currm=dataset%mo(fin) end if end do if (typ == 1 .and. plevel >= 0 .and. naff > 0) then write(outstr,'(a20,a1,i6,a1,i7,3(a1,i6))') & dataset%pedigree(ped), tabsep, naff, tabsep, & dataset%num(ped)-pedoffset, tabsep, nasp, tabsep, nast, tabsep, nasq end if taff=taff+naff tasp=tasp+nasp tast=tast+nast tasq=tasq+nasq tot=tot+dataset%num(ped)-pedoffset if (naff > 0) then nuse=nuse+1 end if else dataset%untyped((pedoffset+1):dataset%num(ped))=.true. end if end do if (typ == 1) then write(outstr,'(a20,a1,i6,a1,i7,3(a1,i6))') & 'Total', tabsep, taff, tabsep, tot, tabsep, tasp, tabsep, tast, tabsep, tasq ! write records in standard format else if (pstyle == 1) then call pedout(outstr, 1, pedmask, fieldsep, allsep, 0, nwid, ndec, & ncatwid, sexcode, misval, 0, 0, 2, show_cat, & nloci, loc, loctyp, locpos, locnotes, dataset) ! write records vertically else if (pstyle == 4) then call wrvert(nloci, loc, loctyp, locpos, locnotes, & dataset, nwid, ndec, ncatwid, allsep, plevel) ! write records as name=value pairs else do idx=1, dataset%nobs if (.not.dataset%untyped(idx)) then call wrind(idx, nloci, loc, loctyp, locpos, dataset, & pedmask, nwid, ndec, misval, allsep, pstyle) end if end do end if if (plevel >= 0) then write(outstr,'(/2(/a,i0,a,i0,1x,a))') & 'Number of matched persons = ',taff,' out of ',tot, & trim(wrpercent(taff, tot)), & 'Number of matched pedigrees = ',nuse,' out of ', nped, & trim(wrpercent(nuse, nped)) end if end subroutine docount ! ! Delete data for individuals fulfilling criterion ! subroutine seldel(nord, locord, farg, larg, words, & nloci, loc, lochash, loctyp, locpos, wtyp, wtag, expr, & dataset, plevel) use outstream use parser_data use ped_class use locus_types use lochash_class integer, intent(in) :: nord integer, dimension(:), intent(in) :: locord integer, intent(in) :: farg, larg character (len=*), dimension(:), intent(in out) :: words integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc type (hash_table) :: lochash integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos integer (kind=1), dimension(:), intent(inout) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(inout) :: expr type (ped_data) :: dataset integer, intent(in out) :: plevel ! Local variables integer, parameter :: KNOWN=0, MISS=-9999 integer :: actn, arg1, argn, error, g1, g2, idx, k, nmark, nterm, pos integer :: ndel,nped,tot interface subroutine prexpr(typ, nprob, farg, larg, words) integer, intent(in) :: typ integer, intent(in) :: nprob integer, intent(in) :: farg integer, intent(in) :: larg character (len=*), dimension(:), intent(inout) :: words end subroutine prexpr subroutine typwords(farg, larg, words, nloci, loc, lochash, loctyp, & wtyp, wtag, expr, actn) use parser_data use locus_types use lochash_class integer, intent(in) :: farg integer, intent(in) :: larg character (len=*), dimension(:), intent(in out) :: words integer, intent(in) :: nloci character (len=*), dimension(nloci), intent(in) :: loc type (hash_table) :: lochash integer, dimension(nloci), intent(in) :: loctyp integer (kind=1), dimension(:), intent(inout) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(inout) :: expr integer, intent(out) :: actn end subroutine typwords subroutine loadvar(idx, nloci, loctyp, locpos, & dataset, sta, fin, wtyp, wtag, expr) use parser_data use ped_class integer, intent(in) :: idx integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data) :: dataset integer, intent(in) :: sta integer, intent(in) :: fin integer (kind=1), dimension(:), intent(inout) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(inout) :: expr end subroutine loadvar subroutine simpev(sta, fin, nterm, wtyp, wtag, expr, error) use parser_data integer, intent(in) :: sta integer, intent(inout) :: fin integer, intent(inout) :: nterm integer (kind=1), dimension(:), intent(inout) :: wtyp integer, dimension(:), intent(inout) :: wtag double precision, dimension(:,:), intent(inout) :: expr integer, intent(out) :: error end subroutine simpev end interface if (plevel > -2) call prexpr(6, nord, farg, larg, words) ndel=0 nped=0 tot=0 do i=1, dataset%nobs if (dataset%actset(dataset%iped(i)) > 0) then tot=tot+1 arg1=farg argn=larg nterm=larg call typwords(arg1, argn, words, nloci, loc, lochash, loctyp, & wtyp, wtag, expr, actn) call loadvar(i, nloci, loctyp, locpos, & dataset, arg1, argn, wtyp, wtag, expr) call simpev(arg1, argn, nterm, wtyp, wtag, expr, error) if (arg1 == argn .and. error == 0 .and. & ((expr(arg1,1) /= MISS .and. expr(arg1,1) /= 0.0d0) .or. & (expr(arg1,2) /= MISS .and. expr(arg1,2) /= 0.0d0))) then ndel=ndel+1 if (plevel > 1) then write(outstr,'(4a)') & 'Deleting ', trim(dataset%pedigree(dataset%iped(i))), '-', trim(dataset%id(i)) end if do j=1, nord k=locord(j) pos=locpos(k) if (isactdip(loctyp(k)) .and. observed(i, pos, dataset)) then call get_geno(i, pos, pos+1, dataset, g1, g2) call set_geno(i, pos, pos+1, dataset, -g1, -g2) else if (.not.ismarker(loctyp(k)) .and. isactive(loctyp(k))) then dataset%plocus(i,pos)=MISS end if end do end if end if end do write(outstr,'(/2(/a,i5,a,i5,a,f5.1,a))') & 'Number of deleted records =',ndel,' out of ',tot, & ' (',100.0D0*dble(ndel)/dble(tot),'%)' end subroutine seldel ! ! Echo action to be performed ! subroutine prexpr(typ, nprob, farg, larg, words) use outstream integer, intent(in) :: typ integer, intent(in) :: nprob integer, intent(in) :: farg integer, intent(in) :: larg character (len=*), dimension(:), intent(inout) :: words ! Local variables integer :: k if (typ == 1) then write(outstr,'(/2a)', advance='no') 'Count where "', trim(words(farg)) else if (typ == 2) then write(outstr,'(/2a)', advance='no') 'Print where "', trim(words(farg)) else if (typ == 3) then write(outstr,'(/2a)', advance='no') & 'Selecting pedigrees where "', trim(words(farg)) else if (typ == 4) then write(outstr,'(/a,i0,2a)', advance='no') 'Selecting pedigrees to contain ',nprob, & ' or more individuals where "', trim(words(farg)) else if (typ == 5) then write(outstr,'(/a,i0,2a)', advance='no') 'Selecting pedigrees to contain exactly ', & nprob,' individuals where "', trim(words(farg)) else if (typ == 6) THEN write(outstr,'(/a,i0,2a)', advance='no') & 'Zeroing ',nprob,' variables in each record where "', & trim(words(farg)) end if do k=farg+1, larg write(outstr,'(1x,a)', advance='no') trim(words(k)) end do write(outstr,'(a/)') '":' end subroutine prexpr ! ! Hash IDs ! subroutine hashids(typ, dataset, hashtab, load, plevel) use outstream use ped_class use idhash_funs integer, intent(in) :: typ type (ped_data) :: dataset type (hash_table) :: hashtab integer, intent(in) :: load integer, intent(in) :: plevel if (typ == HK_PED_ID) then call dohashids(typ, dataset, hashtab, load, & dohash_ped_id, domatch_ped_id, plevel) else if (typ == HK_ID) then call dohashids(typ, dataset, hashtab, load, & dohash_id, domatch_id, plevel) end if end subroutine hashids ! subroutine dohashids(typ, dataset, hashtab, load, & hasher, matcher, plevel) use outstream use ped_class use idhash_funs integer, intent(in) :: typ type (ped_data) :: dataset type (hash_table) :: hashtab integer, intent(in) :: load integer, intent(in) :: plevel ! local variables integer, parameter :: DUPLISTCHARS=72, MISS=-9999 integer :: curr, exactdup, i, iaddress, idx, iprobe, & j, ncollision, ndup character (len=DUPLISTCHARS) :: dupids ! functions interface hasher_generic function hasher(idx, dataset, maxkey) use ped_class integer :: hasher integer, intent(in) :: idx type (ped_data) :: dataset integer, intent(in) :: maxkey end function hasher end interface hasher_generic interface matcher_generic function matcher(idx, iaddress, dataset) use ped_class logical :: matcher integer, intent(in) :: idx, iaddress type (ped_data) :: dataset end function matcher end interface matcher_generic call setup_hash(typ, dataset%nobs, hashtab, load) ncollision=0 ndup=0 dupids='' do i=1, dataset%nobs idx=hasher(i, dataset, hashtab%nrec) j=idx iprobe=hashtab%primroot exactdup=0 do while (hashtab%address(j+1) /= 0) ncollision=ncollision+1 iaddress=hashtab%address(j+1) if (matcher(i, iaddress, dataset)) then exactdup=exactdup+1 end if j=mod(idx+iprobe, hashtab%nrec) iprobe=mod(iprobe*hashtab%primroot, hashtab%nrec) end do hashtab%address(j+1) = i if (exactdup > 0) then ndup=ndup+1 if (len_trim(dupids) < DUPLISTCHARS) then dupids=trim(dupids) // ' ' // trim(dataset%id(i)) end if if (plevel > 1) then write(outstr,'(a)', advance='no') 'NOTE: The ID "' if (typ == HK_PED_ID) then write(outstr,'(2a)', advance='no') & trim(dataset%pedigree(dataset%iped(i))), '--' end if write(outstr,'(2a,i0,a)') trim(dataset%id(i)), & '" appears ', exactdup+1, ' times in the dataset!' end if end if end do if (plevel > 0) then write(outstr, '(a,i0,a,i0,a,i0,a)') & 'Hashed ', dataset%nobs, ' observations with ', & ncollision, ' collisions (', hashtab%nrec, ' table slots).' end if if (ndup > 0) then hashtab%hasdups=.true. if (plevel >= 0) then write(outstr, '(/a,i0,a/7x,a/7x,a)') & 'NOTE: Duplicates for ', ndup, ' IDs are present in the dataset:', & trim(dupids), 'Only the first instance will be indexed.' end if end if hashtab%current=.true. end subroutine dohashids subroutine hashprint(hashtab, dataset, loc, plevel) use outstream use ped_class use idhash_class type (hash_table) :: hashtab type (ped_data) :: dataset character (len=20), dimension(:) :: loc integer, intent(in) :: plevel ! local variables integer :: curr, i, n n=min(100, hashtab%nrec) if (plevel > 0) n=hashtab%nrec if (.not.hashtab%current) then write(outstr,'(a)') 'Hash table is not up to date!' else write(outstr,'(a)') 'Hash table is up to date,' end if write(outstr,'(a,i0,a/)') 'Hash table has ', hashtab%nrec, ' slots.' if (hashtab%keytyp == HK_PED_ID) then do i=1, n curr=hashtab%address(i) if (curr /= 0) then write(outstr, '(i7,1x,i7,1x,3a)') & i, curr, trim(dataset%pedigree(dataset%iped(curr))), & '--', trim(dataset%id(curr)) end if end do else if (hashtab%keytyp == HK_ID) then do i=1, n curr=hashtab%address(i) if (curr /= 0) then write(outstr, '(i7,1x,i7,1x,a)') & i, curr, trim(dataset%id(curr)) end if end do else if (hashtab%keytyp == HK_LOCNAM) then do i=1, n curr=hashtab%address(i) if (curr /= 0) then write(outstr, '(i7,1x,i7,1x,a)') & i, curr, trim(loc(curr)) end if end do end if end subroutine hashprint ! ! Search for ID using hash ! subroutine matchid(keytyp, idstr1, idstr2, dataset, hashtab, iaddress, plevel) use outstream use ped_class use idhash_funs integer, intent(in) :: keytyp character (len=*), intent(in) :: idstr1, idstr2 type (ped_data) :: dataset type (hash_table) :: hashtab integer, intent(out) :: iaddress integer, intent(in) :: plevel ! local variables integer :: curr, i, idx, j, ncomp, iprobe iaddress=0 if (hashtab%nrec == 0) return ncomp=0 if (keytyp == HK_PED_ID) then idx=string_hash(trim(idstr1) // ' ' // trim(idstr2), hashtab%nrec) else idx=string_hash(trim(idstr2), hashtab%nrec) end if iprobe=hashtab%primroot j=idx do ncomp=ncomp+1 iaddress=hashtab%address(j+1) if (iaddress == 0) then if (plevel > 1) then write(outstr, '(2a,1x,2a,i0,a)') & 'ERROR: Could not match ', trim(idstr1), trim(idstr2), & '! Performed ', ncomp, ' comparisons.' end if return end if ! first exact match if (keytyp == HK_PED_ID) then if (domatch_string_ped_id(idstr1, idstr2, iaddress, dataset)) exit else if (domatch_string_id(idstr2, iaddress, dataset)) exit end if j=mod(idx+iprobe, hashtab%nrec) iprobe=mod(iprobe*hashtab%primroot, hashtab%nrec) end do if (plevel > 1) then write(outstr, '(/a,i0,1x,4a,i0,a)') 'Record ', iaddress, & trim(dataset%pedigree(dataset%iped(iaddress))), & '--', trim(dataset%id(iaddress)), & ' found after ', ncomp, ' comparisons.' end if end subroutine matchid ! ! Match list of IDs from file ! subroutine findids(port, lin, pedcol, idcol, hashtab, dataset, plevel) use outstream use fileio use scanner use ped_class use idhash_class implicit none type (ioport) :: port character (len=*), intent(inout) :: lin ! specified pedigree and individual ID column numbers integer, intent(in) :: pedcol, idcol type (hash_table) :: hashtab type (ped_data) :: dataset integer, intent(in) :: plevel ! local variables integer, parameter :: locsiz = 82 integer, parameter :: KNOWN = 0 integer :: dupmatch, i, idx, ioerr, matched, narg, keytyp, tot integer :: idpos, pedpos, nwords integer :: other_nloci, other_nped, other_nobs, other_ped_width, other_id_width integer (kind=8) :: offset logical :: iscomment character (len=4) :: byte character (len=3) :: filtyp character (len=2) :: chs character (len=80) :: slin character (len=40), dimension(:), allocatable :: words if (dataset%nobs == 0) return filtyp='txt' keytyp=HK_PED_ID pedpos=1 idpos=2 if (pedcol > KNOWN .and. idcol > KNOWN) then pedpos=pedcol idpos=idcol else if (idcol > KNOWN) then idpos=idcol keytyp=HK_ID else call readline(port, lin, ios=ioerr) if (ioerr == 0 .and. lin(1:12) == '##fileformat') then filtyp='vcf' keytyp=HK_ID if (idcol == -1) keytyp=HK_PED_ID call rewind_port(port, ioerr) else if (ioerr == 0 .and. lin(1:16) == 'Sib-pair raw ped') then filtyp='bin' keytyp=HK_ID ! if (idcol == -1) keytyp=HK_PED_ID call rewind_port(port, ioerr) else call filecols(port, lin, 10, narg, plevel-1) if (narg == 1) then keytyp=HK_ID idpos=1 end if end if end if if (.not.hashtab%current .or. (hashtab%keytyp /= keytyp)) then call hashids(keytyp, dataset, hashtab, 80, plevel-1) end if nwords=max(pedpos, idpos) allocate(words(nwords)) dataset%untyped=.true. dupmatch=0 matched=0 tot=0 if (filtyp == 'vcf') then do call readline(port, chs, advance='no', ios=ioerr) if (ioerr /= 0) exit if (chs /= '##') exit call readline(port, chs, ios=ioerr) end do do i=1, 9 call readtoken(port, slin, ioerr) if (ioerr /= 0) exit end do if (slin == 'FORMAT') then call readtoken(port, slin, ioerr) end if if (keytyp == HK_PED_ID) then do tot=tot+1 narg=2 call args(slin, narg, words, '_', SEP_CHAR) call matchid(keytyp, words(1), words(2), dataset, hashtab, idx, plevel) if (idx /= 0) then if (dataset%untyped(idx)) then matched=matched+1 dataset%untyped(idx)=.false. else dupmatch=dupmatch+1 end if else if (plevel > 0) then write(outstr,'(3a)') & 'NOTE: Failed to match ID in "', trim(slin), '".' end if if (ioerr /= 0) exit call readtoken(port, slin, ioerr) end do else do tot=tot+1 call matchid(keytyp, ' ', slin, dataset, hashtab, idx, plevel) if (idx /= 0) then if (dataset%untyped(idx)) then matched=matched+1 dataset%untyped(idx)=.false. else dupmatch=dupmatch+1 end if else if (plevel > 0) then write(outstr,'(3a)') & 'NOTE: Failed to match ID in "', trim(slin), '".' end if if (ioerr /= 0) exit call readtoken(port, slin, ioerr) end do end if else if (filtyp == 'bin') then offset=21 call seek_port(port, offset, ioerr) call readline(port, byte, advance='no', ios=ioerr) if (ioerr == 0) then other_nloci=transfer(byte, i) offset=25+int(other_nloci, kind=8)*locsiz call seek_port(port, offset, ioerr) call readline(port, byte, advance='no', ios=ioerr) if (ioerr == 0) other_nped=transfer(byte, i) call readline(port, byte, advance='no', ios=ioerr) if (ioerr == 0) other_nobs=transfer(byte, i) offset=offset+40 call seek_port(port, offset, ioerr) call readline(port, byte, advance='no', ios=ioerr) if (ioerr == 0) other_ped_width=transfer(byte, i) call readline(port, byte, advance='no', ios=ioerr) if (ioerr == 0) other_id_width=transfer(byte, i) if (plevel > 0) then write(outstr,'(a,i0,a,i0,a,i0)') & 'nloci=', other_nloci, ' nped=', other_nped, ' nobs=', other_nobs end if offset=offset+68+other_nped*(other_ped_width+12)+8*other_nobs call seek_port(port, offset, ioerr) do i=1, other_nobs slin=' ' call readline(port, slin(1:other_id_width), advance='no', ios=ioerr) tot=tot+1 call matchid(keytyp, ' ', slin(1:other_id_width), dataset, hashtab, idx, plevel) if (idx /= 0) then if (dataset%untyped(idx)) then matched=matched+1 dataset%untyped(idx)=.false. else dupmatch=dupmatch+1 end if else if (plevel > 0) then write(outstr,'(3a)') & 'NOTE: Failed to match ID in "', trim(slin), '".' end if end do end if else if (keytyp == HK_PED_ID) then write(outstr, '(/a)') 'Matching on pedigree and individual ID' do call readline(port, lin, ios=ioerr) if (ioerr /= 0) then exit end if if (iscomment(lin)) cycle narg=3-keytyp call args(lin, narg, words, ' ', SEP_WHITE) if (words(pedpos)(1:3) == 'ped' .and. words(idpos) == 'id') cycle if (narg > 1) then tot=tot+1 call matchid(keytyp, words(pedpos), words(idpos), dataset, & hashtab, idx, plevel) if (idx /= 0) then if (dataset%untyped(idx)) then matched=matched+1 dataset%untyped(idx)=.false. else dupmatch=dupmatch+1 end if else if (plevel > 0) then write(outstr,'(2a,1x,2a)') & 'NOTE: Failed to match ID in "', & trim(words(1)), trim(words(2)), '".' end if end if end do else if (keytyp == HK_ID) then write(outstr, '(/a)') 'Matching on individual ID' do call readline(port, lin, ios=ioerr) if (ioerr /= 0) then exit end if if (iscomment(lin)) cycle narg=3-keytyp call args(lin, narg, words, ' ', SEP_WH_SLASH_CAS) if (words(idpos) == 'id') cycle if (narg > 0) then tot=tot+1 call matchid(keytyp, ' ', words(idpos), dataset, hashtab, idx, plevel) if (idx /= 0) then if (dataset%untyped(idx)) then matched=matched+1 dataset%untyped(idx)=.false. else dupmatch=dupmatch+1 end if else if (plevel > 0) then write(outstr,'(3a)') & 'NOTE: Failed to match ID in "', trim(words(idpos)), '".' end if end if end do end if write(outstr,'(a,i0,a)') 'Read in ', tot, ' records.' write(outstr,'(/a,i0,a,f6.4,a)') & 'Number of ID matches = ', matched, & ' (', dble(matched)/dble(max(1,tot-dupmatch)), ')' if (dupmatch > 0) then write(outstr,'(a,i0,a)') & 'This excludes ', dupmatch, ' duplicates in the ID file.' end if write(outstr,'(a,f6.4,a,i0,a)') & 'Prop of current dataset = ', dble(matched)/dble(max(1,dataset%nobs)), & ' (', dataset%nobs-matched, ' unmatched)' end subroutine findids ! ! Wild card searching IDs ! subroutine searchid(sstrings, dataset) use outstream use ped_class use string_utilities integer, parameter :: MISS = -9999 character (len=*), dimension(:), intent(in) :: sstrings type (ped_data) :: dataset integer :: i, j, ns if (dataset%nobs == 0) return ns=len(sstrings) dataset%untyped=.true. dset: do i=1, dataset%nobs slist: do j=1, ns if (strfind(sstrings(j), dataset%id(i), 1)) then dataset%untyped(i)=.false. write(outstr,'(3a)') trim(dataset%pedigree(dataset%iped(i))), '--', dataset%id(i) exit slist end if end do slist end do dset end subroutine searchid ! ! Tabulate sexes ! subroutine sextable(dataset) use outstream use ped_class integer, parameter :: MISS = -9999 type (ped_data) :: dataset integer, dimension(3) :: table integer :: i double precision :: n table=0 do i=1, dataset%nobs if (dataset%actset(dataset%iped(i)) > 0) then if (dataset%sex(i) == MISS) then table(3)=table(3)+1 else table(dataset%sex(i))=table(dataset%sex(i))+1 end if end if end do n=dble(table(1)+table(2)) write(outstr, '(/a/a,2(/a,i8,2x,f5.3)/a,i8,1x,a1,f5.3,a1)') & 'Sex Count Prop', & '------ ------- -----', & 'Male ', table(1), dble(table(1))/max(1.0d0,n), & 'Female', table(2), dble(table(2))/max(1.0d0,n), & 'Unspec', table(3), '(',dble(table(3))/max(1.0d0,n+dble(table(3))),')' end subroutine sextable ! ! N-way cross-tabulation ! analys=1 simple cross-tab ! 2 K-W test ! 3 polychoric correlation ! 4 totals for last trait if numeric ! subroutine xtab(analys, table_order, mistyp, sample_weight, nloc, loclist, & nloci, loc, locpos, loctyp, locnotes, & dataset, iter, nwid, ndec, pval, plevel) use outstream use ped_class use contingency_table use read_data use locus_types integer, intent(in) :: analys integer, intent(in) :: table_order ! order if listwise 1=collation 2=frequency integer, intent(in) :: mistyp ! handling of missing data 0=drop integer, intent(in) :: sample_weight ! weight for observation integer, intent(in) :: nloc ! number of dimensions integer, intent(in) :: loclist(nloc) ! variable list integer, intent(in) :: nloci ! total loci character (len=*), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp character (len=*), dimension(:), intent(in) :: locnotes type (ped_data) :: dataset integer, intent(in) :: iter integer, intent(in) :: nwid, ndec double precision, intent(out) :: pval integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS=-9999 ! ! data table ! type (table_data) :: table integer :: nmiss ! functions interface subroutine wrtab(analys, table_order, mistyp, nloc, loclist, loc, loctyp, & locnotes, table, nmiss, iter, nwid, ndec, pval) use contingency_table integer, intent(in) :: analys integer, intent(in) :: table_order integer, intent(in) :: mistyp integer, intent(in) :: nloc integer, intent(in) :: loclist(nloc) character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp character (len=40), dimension(:), intent(in) :: locnotes type (table_data) :: table integer, intent(in) :: nmiss integer, intent(in) :: iter integer, intent(in) :: nwid, ndec double precision, intent(out) :: pval end subroutine wrtab subroutine listab(nloc, loclist, loc, loctyp, locnotes, & table, nmiss, nwid, ndec, table_order) use contingency_table integer, intent(in) :: nloc integer, dimension(:), intent(in) :: loclist character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp character (len=40), dimension(:), intent(in) :: locnotes type (table_data) :: table integer, intent(in) :: nmiss integer, intent(in) :: nwid, ndec integer, intent(in) :: table_order end subroutine listab end interface pval=1.0d0 call maketab(mistyp, sample_weight, nloc, loclist, nloci, loc, locpos, loctyp, & dataset, nmiss, table) ! write the table if (nloc == 1) then if (plevel > 0) then write(outstr,'(/a/3a/a)') & '------------------------------------', & 'Tabulation of "',loc(loclist(1)),'"' , & '------------------------------------' end if else if (analys /= 4) then write(outstr,'(/a/5a/a)') & '------------------------------------------------', & 'Cross-tabulation of "', & trim(loc(loclist(1))), '" ... "', trim(loc(loclist(nloc))),'"' , & '------------------------------------------------' end if if (sample_weight /= MISS) then write(outstr,'(3a)') 'Sample weight = "', trim(loc(sample_weight)), '".' end if ! print rectangular or listwise table if (nloc == 1 .and. analys == 4) then call summate(table, pval) write(outstr,'(a,g14.8)') 'Sum = ', pval else if (nloc == 1 .and. plevel < 1) then call onetab(loc(loclist(1)), loctyp(loclist(1)), locnotes(loclist(1)), & table, nmiss, nwid, ndec) else if (table%ntot == 0) then write(outstr,'(a)') 'No complete observations.' else if (((nloc > 1 .and. nloc < 5) .or. analys == 2) .and. table_order == 1) then call wrtab(analys, table_order, mistyp, nloc, loclist, loc, loctyp, locnotes, & table, nmiss, iter, nwid, ndec, pval) else call listab(nloc, loclist, loc, loctyp, locnotes, & table, nmiss, nwid, ndec, table_order) end if end subroutine xtab ! ! print summary of one-way table ! subroutine onetab(loc, loctyp, locnote, table, nmiss, nwid, ndec) use outstream use contingency_table use locus_types use categorical_data ! character (len=20), intent(in) :: loc character (len=*), intent(in) :: loc integer, intent(in) :: loctyp ! character (len=40), intent(in) :: locnotes character (len=*), intent(in) :: locnote type (table_data) :: table integer, intent(in) :: nmiss integer, intent(in) :: nwid, ndec ! local variables integer :: idx, j, n1, n2 character (len=7) :: gtp, gtp2 if (loctyp == LOC_AFF) then n1=0 n2=0 do j=1, table%ncells idx=table%idx(j) if (table%categories(idx,1)%rvalue == 1.0d0) n1=table%icount(idx) if (table%categories(idx,1)%rvalue == 2.0d0) n2=table%icount(idx) end do write(outstr,'(a,1x,a,i6,2(7x,a,i6))') loc,'x:',nmiss,'y:',n2,'n:',n1 else if (table%ncells > 6) then call wrtrait(table%categories(table%idx(1),1)%rvalue, gtp, & loctyp, get_notes(loc, locnote), nwid, ndec) call wrtrait(table%categories(table%idx(table%ncells),1)%rvalue, gtp2, & loctyp, get_notes(loc, locnote), nwid, ndec) call juststr('l',gtp2,7) write(outstr,'(a,1x,a,i6,7x,a,i6,a,i0,5a)') & loc, 'x:', nmiss, 'y:', table%ntot, & ' (', table%ncells, ' unique values ', trim(gtp) ,'...', trim(gtp2), ')' else write(outstr,'(a,1x,a,i6)', advance='no') loc,'x:',nmiss do j=1, table%ncells idx=table%idx(j) call wrtrait(table%categories(idx,1)%rvalue, gtp, & loctyp, get_notes(loc, locnote), nwid, ndec) call juststr('r',gtp,7) write(outstr,'(1x,2a,i6)', advance='no') gtp,':', table%icount(idx) end do write(outstr,*) end if end subroutine onetab ! ! print listwise contingency table ! subroutine listab(nloc, loclist, loc, loctyp, locnotes, & table, nmiss, nwid, ndec, table_order) use interrupt use outstream use contingency_table use categorical_data integer, intent(in) :: nloc integer, dimension(:), intent(in) :: loclist character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp character (len=40), dimension(:), intent(in) :: locnotes type (table_data) :: table integer, intent(in) :: nmiss integer, intent(in) :: nwid, ndec integer, intent(in) :: table_order ! local variables integer :: i, j, pos, cwidth character (len=30) :: cfmt, cval double precision :: wt cwidth=30 if (nloc > 2) cwidth=10 write(cfmt,'(a,i0,a)') '(a', cwidth,',1x)' do j=1, nloc cval=loc(loclist(j)) call juststr('c', cval, cwidth) write(outstr, cfmt, advance='no') cval end do write(outstr,'(a/a)', advance='no') ' Count Percent', '------------------' do j=1, nloc write(outstr,'(a)', advance='no') repeat('-', cwidth+1) end do write(outstr,*) wt=100.0d0/dble(max(1, table%ntot)) if (table_order == 2) then call sort_table_by_counts(table) end if do i=1, table%ncells pos= table%idx(i) do j=1, nloc call wrtrait(table%categories(pos,j)%rvalue, cval(1:cwidth), & loctyp(loclist(j)), get_notes(loc(loclist(j)), & locnotes(loclist(j))), nwid, ndec) write(outstr, cfmt, advance='no') cval end do write(outstr,'(1x,i6,4x,f5.1)') table%icount(pos), wt*dble(table%icount(pos)) if (irupt /= 0) then write(outstr,'(/a/)') '...' exit end if end do ! table foot and total write(outstr,'(a)', advance='no') '------------------' do j=1, nloc write(outstr,'(a)', advance='no') repeat('-', cwidth+1) end do write(cfmt,'(a,i0,a)') '(/2x,a', cwidth-2,')' write(outstr, cfmt, advance='no') 'Total' do j=1, nloc-1 write(outstr,'(a)', advance='no') repeat(' ', cwidth+1) end do write(outstr,'(i8)', advance='no') table%ntot write(outstr,'(a,i0,a)') ' (and ', nmiss, ' missing)' end subroutine listab ! ! print RxC contingency table ! subroutine wrtab(analys, table_order, mistyp, nloc, loclist, loc, loctyp, locnotes, & table, nmiss, iter, nwid, ndec, pval) use outstream use contingency_table use locus_types use recast_data use statfuns use categorical_data integer, intent(in) :: analys integer, intent(in) :: table_order integer, intent(in) :: mistyp integer, intent(in) :: nloc integer, intent(in) :: loclist(nloc) character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp character (len=40), dimension(:), intent(in) :: locnotes type (table_data) :: table integer, intent(in) :: nmiss integer, intent(in) :: iter integer, intent(in) :: nwid, ndec double precision, intent(out) :: pval integer, parameter :: KNOWN=0, MISS=-9999 double precision, parameter :: tol=1.0d-6 ! ! marginal tables type (table_data) :: martable1, martable2 ! flat table for permutation P integer, dimension(:), allocatable :: tble ! expected values for table double precision, dimension(:), allocatable :: ex ! column width for printing cells integer :: colwidth, numwidth character (len=20) :: cellfmt ! other local variables integer :: allele(2), df, g1, g2, het, hwedf, i, icell, isor, issnp, j, k, & klev, n(4), ncol, pos, sexval, t1, t2, whichsex integer, dimension(nloc) :: chosen character (len=10) :: cval1, cval2 double precision :: curr, er, e, kwstat, nr, odds1, oddsr, pa, pvalue, & rankg, se1, se2, strat_hwe, ties double precision, dimension(1) :: mu, x, ss double precision, dimension(nloc) :: val ! functions character (len=6) :: pstring interface subroutine listab(nloc, loclist, loc, loctyp, locnotes, & table, nmiss, nwid, ndec, table_order) use contingency_table integer, intent(in) :: nloc integer, dimension(:), intent(in) :: loclist character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp character (len=40), dimension(:), intent(in) :: locnotes type (table_data) :: table integer, intent(in) :: nmiss integer, intent(in) :: nwid, ndec integer, intent(in) :: table_order end subroutine listab subroutine kwtest(typ, nloc, loclist, loc, loctyp, locnotes, & martable1, martable2, table, & nwid, ndec, pval) use outstream use contingency_table use locus_types integer, intent(in) :: typ integer, intent(in) :: nloc integer, intent(in) :: loclist(nloc) character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp character (len=40), dimension(:), intent(in) :: locnotes type (table_data) :: martable1, martable2, table integer, intent(in) :: nwid, ndec double precision, intent(out) :: pval end subroutine kwtest subroutine ascend(n, ia) integer, intent(in) :: n integer, dimension(:), intent(inout) :: ia end subroutine end interface if (nloc < 2) return strat_hwe=0.0d0 numwidth=5 colwidth=10 het=MISS hwedf=0 isor=0 issnp=0 ncol=0 pa=0.0d0 t1=loclist(1) t2=loclist(nloc) ! For use with X-linked loci, identify sex indicator sexval=0 whichsex=0 if (same_loctyp(loctyp(t2), LOC_XLIN)) then do i=1, nloc if (loclist(i) == 1) whichsex=i end do end if n(1)=0 n(2)=0 n(3)=0 n(4)=0 call setup_table(nloc-1, 100, martable1) call setup_table(1, 100, martable2) call ascend(nloc-1, chosen) call marginal_table(nloc-1, chosen, table, martable1) chosen(1)=nloc call marginal_table(1, chosen, table, martable2) ! ! print as 2x2 table if (nloc == 2 .and. mistyp == 0 .and. & loctyp(t1) == LOC_AFF .and. loctyp(t2) == LOC_AFF) then do i=1, table%ncells g1=int(table%categories(table%idx(i),1)%rvalue) g2=int(table%categories(table%idx(i),2)%rvalue) n(7-2*g1-g2)=table%icount(table%idx(i)) end do cval2=loc(t2) call juststr('c', cval2, 10) write(outstr,'(/19x,a10/a10,8x,a3,5x,a/a)') cval2, loc(t1), & 'Yes',' No Percent','--------------------------------------' write(outstr,'(7x,a3,5x,i6,2x,i6,4x,f5.1)') & 'Yes',n(1),n(2),1.0D2*dble(n(1))/dble(max(1,n(1)+n(2))) write(outstr,'(7x,a3,5x,i6,2x,i6,4x,f5.1)') & ' No',n(3),n(4),1.0D2*dble(n(3))/dble(max(1,n(3)+n(4))) write(outstr,'(a/7x,a3,5x,i6,2x,i6)') & '--------------------------------------', & 'Tot',n(1)+n(3),n(2)+n(4) er=(0.5D0+dble(n(1)))*(0.5D0+dble(n(4)))/ & (0.5D0+dble(n(2)))/(0.5D0+dble(n(3))) e=1.0d0/(0.5D0+dble(n(1))) + 1.0d0/(0.5D0+dble(n(2))) + & 1.0d0/(0.5D0+dble(n(3))) + 1.0d0/(0.5D0+dble(n(4))) e=sqrt(e) write(cval1,'(f8.3)') exp(log(er)-1.96d0*e) write(cval2,'(f8.3)') exp(log(er)+1.96d0*e) write(outstr,'(/a,i6/a,f10.3,5a)') & ' No. complete observations =',table%ntot, & ' Odds Ratio =', er, & ' (95%CI = ', trim(adjustl(cval1)), ' -- ', trim(adjustl(cval2)), ')' if (analys == 3) then call poltest(2, 2, n) end if ! ! one-way table of means or totals else if (analys == 2 .or. analys == 4 .or. & (martable1%ncells < 8 .and. loctyp(t2) == LOC_QUA)) then call kwtest(analys, nloc, loclist, loc, loctyp, locnotes, & martable1, martable2, table, & nwid, ndec, pval) ! ! print as RxC table ! else if ((martable1%ncells < 24 .or. loctyp(t1) /= LOC_QUA) .and. & martable2%ncells < 8 .and. (analys == 1 .or. analys == 3)) then write(cellfmt,'(a,i0,a)') '(', 15+10*(nloc-1), 'x,a)' write(outstr,cellfmt) loc(t2) ! pad out sparse representation if SNP marker if (isactdip(loctyp(t2)) .and. martable2%ncat <= 3) then do i=1, martable2%ncells pos=martable2%idx(i) call decgtp(martable2%categories(pos,1)%rvalue, g1, g2) if (g1 /= 0 .and. g1 /= MISS) then call addall(g1, issnp, 2, allele) end if if (g2 /= 0 .and. g2 /= MISS) then call addall(g2, issnp, 2, allele) end if end do if (issnp == 2) then do i=1, 2 do j=i, 2 x(1)=encgtp(allele(i), allele(j)) call insert_table(1, x, martable2, 0) do k=1, martable1%ncells pos=martable1%idx(k) do kk=1, nloc-1 val(kk)=martable1%categories(pos,kk)%rvalue end do val(nloc)=x(1) call insert_table(nloc, val, table, 0) end do end do end do else issnp=0 end if end if ! produce flat table allocate(tble(martable1%ncells*martable2%ncells)) allocate(ex(martable1%ncells*martable2%ncells)) call flat_table(martable1, martable2, table, tble) if (issnp == 0 .and. martable2%ncells == 2) then isor=isor+2 odds1=(0.5d0+dble(tble(1)))/(0.5d0+dble(tble(2))) se1=1.0d0/(0.5d0+dble(tble(1))) + 1.0d0/(0.5d0+dble(tble(2))) end if ! width for printing counts do i=1, martable2%ncells numwidth=max(numwidth, int(log10(float(martable2%icount(martable2%idx(i)))))+1) end do colwidth=numwidth+9 ! the variables used to construct the row labels do i=1, nloc-1 cval1=loc(loclist(i)) call juststr('c', cval1, 10) write(outstr,'(a10,a)', advance='no') cval1, ' ' end do write(outstr,'(a7,a)', advance='no') 'Total', ' ' ! levels of the last locus write(cellfmt,'(a,i0,a)') '(3x,a', numwidth+5, ')' do i=1, martable2%ncells call wrtrait(martable2%categories(martable2%idx(i),1)%rvalue, & cval2, loctyp(t2), get_notes(loc(t2), locnotes(t2)), nwid, ndec) write(outstr, cellfmt, advance='no') cval2 end do ! labels for extra columns if (issnp == 2) then write(outstr,'(2x,a11,2x,a11)', advance='no') 'Allele Freq', 'Exact HWE-P' else if (isor == 2) then write(outstr,'(2x,a)', advance='no') 'Odds Ratio (95%CI)' end if write(outstr,*) ! divider do i=1, nloc-1 write(outstr,'(a,1x)', advance='no') repeat('-',10) end do write(outstr,'(a,1x)', advance='no') repeat('-',7) write(outstr,'(a)') repeat('-',colwidth*(martable2%ncells+issnp+isor)) ! table rows write(cellfmt,'(a,i0,a)') '(1x,i', numwidth, ',1x)' icell=0 do i=1, martable1%ncells do k=1, martable1%ncat klev=loclist(k) call wrtrait(martable1%categories(martable1%idx(i),k)%rvalue, cval1, & loctyp(klev), get_notes(loc(klev), locnotes(klev)), nwid, ndec) write(outstr,'(a10,1x)', advance='no') cval1 if (k == whichsex) then sexval=int(martable1%categories(martable1%idx(i),k)%rvalue) end if end do write(outstr,'(i7,1x)', advance='no') martable1%icount(martable1%idx(i)) nr=dble(martable1%icount(martable1%idx(i))) er=nr/dble(max(1,martable1%ntot)) pa=0.0d0 do j=1, martable2%ncells icell=icell+1 write(outstr, cellfmt, advance='no') tble(icell) e=dble(tble(icell))/max(1.0d0,nr) if (e == 1.0d0) then write(outstr,'(a)', advance='no') '(1.00)' else write(outstr,'(a,f4.3,a)', advance='no') '(',e,')' end if if (issnp == 2) then n(j)=tble(icell) end if ex(icell)=er*dble(martable2%icount(martable2%idx(j))) end do if (issnp == 2) then ! check if SNP levels include missing value (showmiss) if (martable2%ncells == 4) then call hwe2(n(2), n(3), n(4), pa, pvalue) else call hwe2(n(1), n(2), n(3), pa, pvalue) end if if (sexval == 1) then pvalue=MISS else strat_hwe=strat_hwe+log(pvalue) hwedf=hwedf+1 end if write(outstr,'(2(2x,f6.4),4x,a)', advance='no') & pa, 1.0d0-pa, pstring(pvalue) else if (isor == 2) then if (icell /= 2) then oddsr=odds1/(0.5d0+dble(tble(icell-1)))*(0.5d0+dble(tble(icell))) se2=sqrt(se1+1.0d0/(0.5d0+dble(tble(icell-1))) + & 1.0d0/(0.5d0+dble(tble(icell)))) write(cval1,'(f10.2)') exp(log(oddsr)-1.96*se2) write(cval2,'(f10.2)') exp(log(oddsr)+1.96*se2) write(outstr,'(2x,f8.2,5a)', advance='no') & min(oddsr, 99999.0d0), ' (', & trim(adjustl(cval1)), '--', trim(adjustl(cval2)), ')' else write(outstr,'(2x,f8.2)', advance='no') 1.0d0 end if end if write(outstr,*) end do ! column totals write(outstr,'(2a)') repeat(' ',8+(nloc-1)*11), & repeat('-',colwidth*(martable2%ncells+issnp+isor)) write(outstr,'(2a,14x)', advance='no') & repeat(' ',(nloc-2)*11), 'Total' do j=1, martable2%ncells write(outstr, cellfmt, advance='no') martable2%icount(martable2%idx(j)) e=dble(martable2%icount(martable2%idx(j)))/dble(max(1,martable2%ntot)) if (e == 1.0d0) then write(outstr,'(a)', advance='no') '[1.00]' else write(outstr,'(a,f4.3,a)', advance='no') '[',e,']' end if end do if (issnp == 2) then strat_hwe=-strat_hwe-strat_hwe pvalue=chip(strat_hwe, 2*hwedf) write(outstr,'(20x,a)', advance='no') pstring(pvalue) end if write(outstr,*) if (analys == 3 .and. nloc == 2) then call poltest(martable1%ncells, martable2%ncells, tble) else call rctest(martable1%ncells, martable2%ncells, tble, ex, iter) end if else call listab(nloc, loclist, loc, loctyp, locnotes, & table, nmiss, nwid, ndec, table_order) end if end subroutine wrtab ! ! Kruskal-Wallis test ! subroutine kwtest(typ, nloc, loclist, loc, loctyp, locnotes, & martable1, martable2, table, & nwid, ndec, pval) use outstream use contingency_table use locus_types use statfuns use categorical_data integer, intent(in) :: typ integer, intent(in) :: nloc integer, intent(in) :: loclist(nloc) character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp character (len=40), dimension(:), intent(in) :: locnotes type (table_data) :: martable1, martable2, table integer, intent(in) :: nwid, ndec double precision, intent(out) :: pval integer, parameter :: KNOWN=0, MISS=-9999 character (len=30) :: cfmt, cval1, cval2 integer :: catpos, cwidth, df, i, icell, j, k, klev, pos double precision :: curr, er, e, kwstat, nr, odds1, oddsr, pa, pvalue, & rankg, se1, se2, ties, tot double precision, dimension(1) :: mu, x, ss double precision, dimension(nloc) :: val ! functions double precision :: encgtp character (len=6) :: pstring if (.not.table%sorted) then call sort_table(table) end if if (.not.martable1%sorted) then call sort_table(martable1) end if if (.not.martable2%sorted) then call sort_table(martable2) end if cwidth=30 if (nloc > 2) cwidth=10 write(cfmt,'(a,i0,a)') '(a', cwidth,',1x)' kwstat=0.0D0 df=0 cval1=loc(loclist(nloc)) call juststr('c', cval1, cwidth) write(outstr,'(/2a)') repeat(' ',(nloc-1)*(cwidth+1)), cval1 do i=1, nloc-1 cval1=loc(loclist(i)) call juststr('c', cval1, cwidth) write(outstr,cfmt, advance='no') cval1 end do if (typ == 4) then write(outstr,'(8x,a,11x,a,5x,a)') 'Total', 'Variance', 'Count' else write(outstr,'(6x,a,14x,a,7x,a)') 'Mean', 'SD', 'Count' end if do i=1, nloc-1 write(outstr,'(a,1x)', advance='no') repeat('-',cwidth+1) end do write(outstr,'(a)') repeat('-',41) pos=1 tot=0.0d0 do i=1, martable1%ncells rankg=0.0D0 mu(1)=0.0D0 ss(1)=0.0D0 icell=0 curr=0.0d0 do k=1, nloc-1 val(k)=martable1%categories(martable1%idx(i),k)%rvalue end do strata: do if (pos > table%ncells) exit catpos=table%idx(pos) do k=1, nloc-1 if (table%categories(catpos,k)%rvalue /= val(k)) exit strata end do icell=icell+table%icount(catpos) x(1)=table%categories(catpos, nloc)%rvalue curr=curr+x(1) rankg=rankg+dble(table%icount(catpos))*findrank(x(1), martable2) call dssp(1, icell, table%icount(catpos), x, mu, ss) pos=pos+1 end do strata kwstat=kwstat+rankg*rankg/dble(icell) do k=1, nloc-1 klev=loclist(k) call wrtrait(val(k), cval1, loctyp(klev), & get_notes(loc(klev), locnotes(klev)), nwid, ndec) write(outstr, cfmt, advance='no') cval1 end do if (typ == 4) then tot=tot+curr if (curr == anint(curr)) then write(outstr,'(3x,i14,3x,g14.4,1x,i7)') & int(curr), ss(1)/dble(max(icell-1,1)), icell else write(outstr,'(3x,g14.6,3x,g14.4,1x,i7)') & curr, ss(1)/dble(max(icell-1,1)), icell end if else write(outstr,'(3x,f12.4,4x,f12.4,3x,i7)') & mu(1), sqrt(ss(1)/dble(max(icell-1,1))), icell end if end do if (typ == 4) then write(outstr,*) do i=1, nloc-2 write(outstr,'(11x)', advance='no') end do write(outstr,'(a)', advance='no') repeat(' ',(nloc-2)*(cwidth+1)) cval1='Total' write(outstr, cfmt, advance='no') adjustl(cval1) if (anint(tot) == tot) then write(outstr,'(1x,i16)') int(tot) else write(outstr,'(1x,g16.6)') tot end if end if ! Kruskal-Wallis test statistic, then correction for ties kwstat=12.0d0*kwstat/dble(table%ntot*(table%ntot+1)) - & dble(3*(table%ntot+1)) ties=0.0d0 do j=1, martable2%ncells ties=ties+dble(martable2%icount(martable2%idx(j))**3-martable2%icount(martable2%idx(j))) end do ties=1.0d0 - ties/dble(table%ntot**3-table%ntot) if (ties > 0.0d0) then kwstat=kwstat/ties else kwstat=0.0d0 end if df=(martable1%ncells-1) pval=chip(kwstat,df) write(outstr,'(/a,i0/a,g9.2,a,i3,3a)') & 'No. usable observations = ', table%ntot, & 'Kruskal-Wallis H = ', kwstat, & ' df=',df,' (P=', trim(pstring(pval)), ')' end subroutine kwtest ! ! plot a histogram ! subroutine histogram(trait, nloci, loc, locpos, loctyp, histcat, & dataset, nwid, ndec, outfil, plevel) use outstream use ped_class use contingency_table use read_data use locus_types integer, intent(in) :: trait integer, intent(in) :: nloci character (len=*), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp integer, intent(in) :: histcat type (ped_data) :: dataset integer, intent(in) :: nwid, ndec character (len=*), intent(in) :: outfil integer, intent(in) :: plevel type (table_data) :: table integer :: nmiss integer, dimension(1) :: loclist loclist(1)=trait call maketab(0, 0, 1, loclist, nloci, loc, locpos, loctyp, & dataset, nmiss, table) call sort_table(table) if (plevel > -1) then call dohist(loc(trait), min(table%ncells, histcat), 1, table, & nwid, ndec, outfil) end if call filliben(table, plevel) call symtest(table, plevel) end subroutine histogram ! ! Logrank test: table 1..(nloc-2)=covariate levels (nloc-1)=time nloc=censor ! subroutine logrank(typ, nloc, loclist, nloci, loc, loctyp, locpos, locnotes, & dataset, nwid, ndec, lrstat, df, pval, plevel) use outstream use ped_class use contingency_table use read_data use locus_types use statfuns use categorical_data integer, intent(in) :: typ integer, intent(in) :: nloc integer, dimension(:), intent(in) :: loclist integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=40), dimension(:), intent(in) :: locnotes type (ped_data) :: dataset integer, intent(in) :: nwid, ndec double precision, intent(out) :: lrstat integer, intent(out) :: df double precision, intent(out) :: pval integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS=-9999 ! ! complete table, covariate levels, survival times ! type (table_data) :: table, martable1, martable2 character (len=3) :: histo character (len=10) :: cval1, cval2 integer :: estimable, i, iev, j, j2, k, klev, nmiss, & ngroups, ns2, pos, timelev, totaff double precision :: den, expaff, logdet, pvalue, zstat ! work array: list of selected variables for a table integer, dimension(nloc-2) :: chosen ! ! survival tabulation ! integer, dimension(:), allocatable :: di, ni, naff integer, dimension(:,:), allocatable :: cij, dij, nij ! data vector double precision, dimension(nloc) :: val ! log-rank statistics double precision, dimension(:), allocatable :: ediff, vardiff, vinv ! functions character (len=6) :: pstring interface subroutine ascend(n, ia) integer, intent(in) :: n integer, dimension(:), intent(inout) :: ia end subroutine end interface lrstat=0.0d0 df=0 call maketab(0, 0, nloc, loclist, nloci, loc, locpos, loctyp, & dataset, nmiss, table) call setup_table(nloc-2, 100, martable1) call setup_table(1, 100, martable2) call ascend(nloc-2, chosen) call marginal_table(nloc-2, chosen, table, martable1) chosen(1)=nloc-1 call marginal_table(1, chosen, table, martable2) ngroups=martable1%ncells timelev=martable2%ncells ns2=ngroups*(ngroups+1)/2 allocate(naff(ngroups)) allocate(ediff(ngroups)) allocate(vardiff(ns2), vinv(ns2)) allocate(di(timelev), ni(timelev)) allocate(cij(timelev,ngroups), dij(timelev,ngroups), nij(timelev,ngroups)) dij=0 cij=0 ediff=0.0d0 vardiff=0.0d0 if (typ == 3 .or. plevel > 0) then write(outstr,'(/a,i0/a,i0)') 'Number of groups = ', ngroups, & 'Number of distinct times = ', timelev end if ! ! dij(1..nev, 1..ngroups) events di(1..nev) ! cij(1..nev, 1..ngroups) censored ! nij(1..nev, 1..ngroups) riskset ni(1..nev) ! si(1..nev) = di-ni ! totaff=0 pos=1 do j=1, ngroups do k=1, nloc-2 val(k)=martable1%categories(martable1%idx(j),k)%rvalue end do ! iterate over times ingroups: do if (pos > table%ncells) exit do k=nloc-2, 1, -1 if (table%categories(table%idx(pos),k)%rvalue /= val(k)) then exit ingroups end if end do iev=findlev(table%categories(table%idx(pos), nloc-1)%rvalue, martable2) if (table%categories(table%idx(pos), nloc)%rvalue == 2.0d0) then totaff=totaff+1 dij(iev,j)=dij(iev,j)+table%icount(table%idx(pos)) else cij(iev,j)=cij(iev,j)+table%icount(table%idx(pos)) end if pos=pos+1 end do ingroups end do call survtab(timelev, ngroups, martable1, dij, cij, nij, ni, di) ! if (plevel > 1) then write(outstr,'(/3x,a,4x)',advance='no') 'Time' do j=1, ngroups+1 write(outstr,'(a)',advance='no') ' Obs N' end do write(outstr,*) do i=1, timelev write(outstr,'(f11.4)',advance='no') martable2%categories(martable2%idx(i),1)%rvalue do j=1, ngroups write(outstr,'(i4,1x,i5)',advance='no') dij(i,j), nij(i,j) end do write(outstr,'(i4,1x,i5)') di(i), ni(i) end do end if call calclogrank(timelev, ngroups, ns2, di, ni, naff, cij, dij, nij, & ediff, vardiff, vinv, lrstat, df) if (df == 0) then write(outstr, '(a)') 'NOTE: Insufficient usable groups.' end if pval=chip(lrstat, df) if (typ == 3 .or. plevel > 0) then write(outstr,'(/2a)') repeat(' ',nloc*11), loc(loclist(nloc)) do i=1, nloc-3 cval1=loc(loclist(i)) call juststr('c', cval1, 10) write(outstr,'(a10,a)', advance='no') cval1, ' ' end do i=nloc-2 if (len_trim(loc(loclist(i))) >= 10) then write(outstr,'(a16,a)', advance='no') loc(loclist(i)), ' ' else cval1=loc(loclist(i)) call juststr('c', cval1, 10) write(outstr,'(a10,a)', advance='no') cval1, ' ' end if write(outstr,'(a4,4a10)') 'N', 'Obs', 'Exp', 'Var', 'Z ' do i=1, nloc-2 write(outstr,'(a,1x)', advance='no') repeat('-',10) end do write(outstr,'(a)') repeat('-',50) pos=0 do j=1, ngroups pos=pos+j do k=1, nloc-2 klev=loclist(k) call wrtrait(martable1%categories(martable1%idx(j),k)%rvalue, cval1, & loctyp(klev), get_notes(loc(klev), locnotes(klev)), nwid, ndec) write(outstr,'(a10,1x)', advance='no') cval1 end do zstat=0.0d0 if (vardiff(pos) > 0.0d0) zstat=ediff(j)/sqrt(vardiff(pos)) write(outstr,'(2i10,3f10.2)') & nij(1,j), naff(j), dble(naff(j))-ediff(j), vardiff(pos), zstat end do write(outstr,'(/a,f7.2,a,i3,3a)') & 'Log-rank Chi-square=', lrstat, & ' df=', df, ' (P=', trim(pstring(pval)), ')' else if (typ == 4 .and. (plevel == -1 .or. plevel == 0)) then call phist(pval, 1.0d0, histo) write(outstr,'(a20,2(a1,i6),a1,f10.1,2(a1,a),a1,i6,a1,a,a1,a)') & loc(loclist(1)), tabsep, ni(1), tabsep, totaff, tabsep, lrstat, tabsep, & pstring(pval), tabsep, pstring(pval), tabsep, 0, tabsep, & 'Surv', tabsep, histo end if end subroutine logrank ! ! Logrank association test: gene time censor ! subroutine simlogrank(locnam, gene, onset, censor, iter, mincnt, norder, & dataset, allele_buffer, pval, plevel) use interrupt use outstream use alleles_class use ped_class use contingency_table use locus_types use rngs use statfuns use sorts character (len=*), intent(in) :: locnam integer, intent(in) :: gene integer, intent(in) :: onset, censor integer, intent(in) :: iter, mincnt, norder type (ped_data) :: dataset type (allele_data), intent(inout) :: allele_buffer double precision, intent(out) :: pval integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS=-9999 ! ! complete table, covariate levels, survival times ! type (table_data) :: table1, table2 integer, dimension(allele_buffer%numgtp) :: gstrata character (len=3) :: histo character (len=10) :: cval1 integer :: df, estimable, g, g1, g2, gen2, i, iev, ii, it, j, j2, k, & ngroups, ns2, ped, pos, tailp, timelev, totaff double precision :: asyp, chisq, lrstat, mchisq, vchisq, zstat double precision, dimension(1) :: val ! ! rank of ith observation's age and genotype ! integer, dimension(dataset%nobs) :: irank, geno ! ! genotype permutation ! integer, dimension(dataset%maxact,2) :: set, set2 ! ! survival tabulation ! ! dij(1..nev, 1..ngroups) events di(1..nev) ! cij(1..nev, 1..ngroups) censored ! nij(1..nev, 1..ngroups) riskset ni(1..nev) ! si(1..nev) = di-ni ! integer, dimension(:), allocatable :: di, ni, naff integer, dimension(:,:), allocatable :: cij, dij, nij ! log-rank statistics double precision, dimension(:), allocatable :: ediff, vardiff, vinv ! extreme tail empirical P values integer :: ntopvals double precision, dimension(norder+2) :: topvals ! functions integer :: clcpos double precision :: encgtp, evdtailp character (len=6) :: pstring interface subroutine simped(ped, dataset, allele_buffer, set) use alleles_class use ped_class integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data), intent(in) :: allele_buffer integer, dimension(:,:), intent(out) :: set end subroutine simped subroutine xsimped(ped, dataset, allele_buffer, set) use alleles_class use ped_class integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data), intent(in) :: allele_buffer integer, dimension(:,:), intent(out) :: set end subroutine xsimped end interface gen2=gene+1 ngroups=allele_buffer%numgtp lrstat=0.0d0 ntopvals = norder+2 topvals=0.0d0 df=0 ! Tabulate ages at onset and genotypes call setup_table(1, ngroups, table1) do g1=1, allele_buffer%numal do g2=g1, allele_buffer%numal val(1)=clcpos(g1, g2) call insert_table(1, val, table1, 0) end do end do call sort_table(table1) call setup_table(1, 100, table2) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) dataset%untyped(i)=.true. if (dataset%plocus(i,onset) /= MISS .and. & dataset%plocus(i,censor) /= MISS .and. & observed(i, gene, dataset)) then dataset%untyped(i)=.false. call get_namedgeno(i, gene, gen2, dataset, allele_buffer, g1, g2) val(1)=clcpos(g1, g2) call insert_table(1, val, table1, 1) call insert_table(1, dataset%plocus(i, onset), table2, 1) end if end do end if end do call sort_table(table1) call sort_table(table2) timelev=table2%ncells ns2=ngroups*(ngroups+1)/2 if (plevel > 0) then write(outstr,'(3(/a,i0))') 'Number of genotypes = ', ngroups, & 'Number of distinct times = ', timelev, & 'Number of observations = ', table1%ntot end if if (timelev < 2 .or. ngroups < 2) then if (plevel == -1 .or. plevel == 0) then write(outstr,'(a20,2(a1,i6),a1,f10.1,2(a1,a),a1,i6,a1,a,a1)') & locnam, tabsep, 0, tabsep, 0, tabsep, lrstat, tabsep, & ' - ' , tabsep, ' - ' , tabsep, 0, tabsep, 'Surv', tabsep end if return end if allocate(naff(ngroups)) allocate(ediff(ngroups)) allocate(vardiff(ns2), vinv(ns2)) allocate(di(timelev), ni(timelev)) allocate(cij(timelev,ngroups), dij(timelev,ngroups), nij(timelev,ngroups)) dij=0 cij=0 totaff=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (.not.dataset%untyped(i)) then iev=findlev(dataset%plocus(i, onset), table2) call get_namedgeno(i, gene, gen2, dataset, allele_buffer, g1, g2) g=clcpos(g1, g2) if (dataset%plocus(i, censor) == 2.0d0) then totaff=totaff+1 dij(iev,g)=dij(iev,g)+1 else cij(iev,g)=cij(iev,g)+1 end if irank(i)=iev geno(i)=g end if end do end if end do call survtab(timelev, ngroups, table1, dij, cij, nij, ni, di) if (plevel > 1) then write(outstr,'(/11x)',advance='no') do g1=1, allele_buffer%numal do g2=g1, allele_buffer%numal g=g+1 pos=pos+g call wrgtp(allele_buffer%allele_names(g1), & allele_buffer%allele_names(g2), cval1, '/', '', 1) write(outstr,'(a10)', advance='no') cval1 end do end do write(outstr,'(a/3x,a,4x)',advance='no') ' Overall', 'Time' do j=1, ngroups+1 write(outstr,'(a)',advance='no') ' Obs N' end do write(outstr,'(/a)',advance='no') repeat('-',11) do j=1, ngroups+1 write(outstr,'(1x,a)',advance='no') repeat('-',9) end do write(outstr,*) do i=1, timelev write(outstr,'(f11.4)',advance='no') table2%categories(table2%idx(i),1)%rvalue do j=1, ngroups write(outstr,'(i4,1x,i5)',advance='no') dij(i,j), nij(i,j) end do write(outstr,'(1x,i4,1x,i5)') di(i), ni(i) end do end if call calclogrank(timelev, ngroups, ns2, di, ni, naff, cij, dij, nij, & ediff, vardiff, vinv, lrstat, df) asyp=chip(lrstat, df) if (plevel > 0) then cval1=locnam call juststr('c', cval1, 10) write(outstr,'(/a10,1x,5a10/a10,1x,a)') & cval1, 'N', 'Obs', 'Exp', 'Var', 'Z ', & repeat('-',10), repeat('-',50) g=0 pos=0 do g1=1, allele_buffer%numal do g2=g1, allele_buffer%numal g=g+1 pos=pos+g call wrgtp(allele_buffer%allele_names(g1), & allele_buffer%allele_names(g2), cval1, '/', '', 1) write(outstr,'(a10,1x)', advance='no') cval1 zstat=0.0d0 if (vardiff(pos) > 0.0d0) zstat=ediff(g)/sqrt(vardiff(pos)) write(outstr,'(2i10,3f10.2)') & nij(1,g), naff(g), dble(naff(g))-ediff(g), vardiff(pos), zstat end do end do write(outstr,'(/a,f9.2/a,i6/a,5x,a)') & ' Log-rank Chi-square = ', lrstat, & ' Nominal degrees of freedom = ', df, & ' Nominal P-value = ', trim(pstring(asyp)) end if ! ! if founders only, or no cases or no controls or iter=0, then ! Monte-Carlo procedure superfluous ! it=0 tailp=0 mchisq=0.0d0 vchisq=0.0d0 if (iter == 0) then pval=1.0d0 else ! ! Sequential Monte-Carlo P-value after Besag & Clifford Biometrika 1991 ! P= tailp/it if tailp=mincnt or (tailp+1)/(it+1) if tailp<mincnt && it=iter ! permute the survival table ! do while (it < iter .and. tailp < mincnt .and. irupt == 0) it=it+1 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset if (allele_buffer%xlinkd) then call xsimped(ped, dataset, allele_buffer, set) else call simped(ped, dataset, allele_buffer, set) end if ii=0 do i=dataset%num(ped-1)+1, dataset%num(ped) ii=ii+1 if (.not.dataset%untyped(i)) then g=clcpos(set(ii,1), set(ii,2)) if (geno(i) /= g) then iev=irank(i) if (dataset%plocus(i, censor) == 2.0d0) then dij(iev,geno(i))=dij(iev,geno(i))-1 dij(iev,g)=dij(iev,g)+1 else cij(iev,geno(i))=cij(iev,geno(i))-1 cij(iev,g)=cij(iev,g)+1 end if nij(1,geno(i))=nij(1,geno(i))-1 nij(1,g)=nij(1,g)+1 geno(i)=g end if end if end do end if end do do i=2, timelev do j=1, ngroups nij(i,j)=nij(i-1,j)-dij(i-1,j)-cij(i-1,j) end do end do call calclogrank(timelev, ngroups, ns2, di, ni, naff, cij, dij, nij, & ediff, vardiff, vinv, chisq, df) call moment(it, chisq, mchisq, vchisq) if (chisq > lrstat .or. (chisq == lrstat .and. random() > 0.5)) then tailp=tailp+1 end if topvals(1)=chisq call dsort(ntopvals,topvals) if (plevel > 1) then write(outstr,'(a,i8,a,f6.1)') 'Pseudosample ',it,': logrank statistic=', chisq if (plevel > 2) then write(outstr,'(/10x,1x,5a10/a10,1x,a)') & 'N', 'Obs', 'Exp', 'Var', 'Z ', & repeat('-',10), repeat('-',50) g=0 pos=0 do g1=1, allele_buffer%numal do g2=g1, allele_buffer%numal g=g+1 pos=pos+g call wrgtp(allele_buffer%allele_names(g1), & allele_buffer%allele_names(g2), cval1, '/', '', 1) write(outstr,'(a10,1x)', advance='no') cval1 zstat=0.0d0 if (vardiff(pos) > 0.0d0) zstat=ediff(g)/sqrt(vardiff(pos)) write(outstr,'(2i10,3f10.2)') & nij(1,g), naff(g), dble(naff(g))-ediff(g), vardiff(pos), zstat end do end do write(outstr,*) end if end if end do if (tailp < mincnt) then tailp=tailp+1 it=it+1 end if vchisq=vchisq/dble(max(1,it-1)) pval=evdtailp(tailp, it, ntopvals, topvals, lrstat) end if if (plevel > 0) then write(outstr, '(a,i0,a,i0,3a/a,f6.1,a,f6.1,a)') & ' Equalled or exceeded by = ',tailp,'/',it, & ' simulated values (', trim(pstring(pval)), ')', & ' Mean (Var) simulated chi-sqs =',mchisq, ' (', vchisq, ')' write(outstr,'(/a/11(1x,f6.1):)') ' Top simulated chi-sqs:', & topvals(2:ntopvals) else if (plevel == -1 .or. plevel == 0) then call phist(asyp, pval, histo) write(outstr,'(a20,2(a1,i6),a1,f10.1,2(a1,a),a1,i6,a1,a,a1,a)') & locnam, tabsep, ni(1), tabsep, totaff, tabsep, lrstat, tabsep, & pstring(asyp), tabsep, pstring(pval), tabsep, it, tabsep, & 'Surv', tabsep, histo end if if (iter == 0) pval=asyp end subroutine simlogrank ! ! Life table logrank test ! subroutine survtab(timelev, ngroups, table, dij, cij, nij, ni, di) use contingency_table integer, intent(in) :: timelev, ngroups integer, dimension(timelev), intent(inout) :: di, ni integer, dimension(timelev,ngroups), intent(inout) :: cij, dij, nij ! table of survival times type (table_data) :: table integer :: i, j ni=0 di=0 do j=1, ngroups nij(1,j)=table%icount(table%idx(j)) ni(1)=ni(1)+nij(1,j) di(1)=di(1)+dij(1,j) end do do i=2, timelev do j=1, ngroups nij(i,j)=nij(i-1,j)-dij(i-1,j)-cij(i-1,j) ni(i)=ni(i)+nij(i,j) di(i)=di(i)+dij(i,j) end do end do end subroutine survtab ! ! Calculate log rank statistic ! subroutine calclogrank(timelev, ngroups, ns2, di, ni, naff, cij, dij, nij, & ediff, vardiff, vinv, lrstat, df) integer, intent(in) :: timelev, ngroups, ns2 integer, dimension(ngroups), intent(inout) :: naff integer, dimension(timelev), intent(inout) :: di, ni integer, dimension(timelev,ngroups), intent(inout) :: cij, dij, nij ! log-rank statistics double precision, dimension(ngroups), intent(inout) :: ediff double precision, dimension(ns2), intent(inout) :: vardiff, vinv double precision, intent(out) :: lrstat integer, intent(out) :: df integer :: estimable, i, j, pos double precision :: den ediff=0.0d0 vardiff=0.0d0 estimable=0 pos=0 do j=1, ngroups naff(j)=0 ediff(j)=0.0d0 do i=1, timelev if (ni(i) > 0) then naff(j)=naff(j)+dij(i,j) ediff(j)=ediff(j) + dble(dij(i,j))-dble(nij(i,j))*dble(di(i)) / & dble(ni(i)) end if end do do j2=1, j-1 pos=pos+1 do i=1, timelev if (ni(i) > 1) then den=dble(ni(i)) den=den*den*(den-1.0d0) vardiff(pos)=vardiff(pos)+dble(-di(i)*(ni(i)-di(i))) * & dble(nij(i,j)*nij(i,j2))/den end if end do end do pos=pos+1 do i=1, timelev if (ni(i) > 1) then den=dble(ni(i)) den=den*den*(den-1.0d0) vardiff(pos)=vardiff(pos)+dble(di(i))*dble(ni(i)-di(i)) * & dble(nij(i,j)*(ni(i)-nij(i,j)))/den end if end do if (vardiff(pos) > 0.0d0) estimable=estimable+1 end do if (estimable < 2) then lrstat=0.0d0 else if (ngroups == 2) then lrstat=ediff(1)*ediff(1)/vardiff(1) else call iquadmult(ngroups, ediff, vardiff, lrstat) end if df=max(0, estimable-1) end subroutine calclogrank ! ! Nonparametric SNP association test for trend ! ! An exact (permutation) version of the ! Jonckheere-Terpstra test, but gene dropping. It uses the statistic ! ! Sum_{k<l} Sum_{ij} I(X_{ik} < X_{jl}) + 0.5 I(X_{ik} = X_{jl}), ! where i, j are observations in groups k and l respectively. ! subroutine simtrend(typ, locnam, gene, trait, iter, mincnt, norder, & dataset, allele_buffer, pval, plevel) use interrupt use outstream use alleles_class use ped_class use contingency_table use locus_types use rngs use sorts use statfuns integer, intent(in) :: typ character (len=*), intent(in) :: locnam integer, intent(in) :: gene, trait integer, intent(in) :: iter, mincnt, norder type (ped_data) :: dataset type (allele_data), intent(inout) :: allele_buffer double precision, intent(out) :: pval integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS=-9999 ! ! character (len=3) :: histo character (len=10) :: cval1 integer :: df, fin, g, g1, g2, gen2, i, icomp, iev, ii, it, j, j2, k, & k2, n, nall, ngroups, nobs, num, ped, pedoffset, pos, sta, tailp, & timelev, totaff double precision :: asyp, etau, tau, tmp, otau, vartau, zstat double precision, dimension(1) :: val ! ! rank of ith observation's trait and genotype ! type (table_data) :: ptable integer, dimension(allele_buffer%numgtp+1) :: gstrata integer, dimension(dataset%nobs) :: irank, geno double precision, dimension(dataset%nobs) :: pheno ! ! genotype permutation ! integer, dimension(dataset%maxact,2) :: set, set2 ! ! extreme tail empirical P values integer :: ntopvals double precision, dimension(norder+2) :: topvals ! functions integer :: clcpos double precision :: encgtp, evdtailp character (len=6) :: pstring interface subroutine groupgenos(nobs, geno, ngroups, gstrata) integer, intent(in) :: nobs integer, dimension(nobs), intent(inout) :: geno integer, intent(out) :: ngroups integer, dimension(:), intent(out) :: gstrata end subroutine groupgenos subroutine simped(ped, dataset, allele_buffer, set) use alleles_class use ped_class integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data), intent(in) :: allele_buffer integer, dimension(:,:), intent(out) :: set end subroutine simped subroutine xsimped(ped, dataset, allele_buffer, set) use alleles_class use ped_class integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data), intent(in) :: allele_buffer integer, dimension(:,:), intent(out) :: set end subroutine xsimped end interface nall=allele_buffer%numal gen2=gene+1 tau=0.0d0 asyp=1.0d0 pval=1.0d0 ntopvals = norder+2 topvals=0.0d0 df=0 it=0 nobs=0 if (nall < 2) then if (plevel > 0) then write(outstr,'(3a)') trim(locnam), ' is a monomorphic marker.' else if (plevel > -2) then call phist(asyp, pval, histo) write(outstr,'(a20,2(a1,i6),a1,f10.1,2(a1,a),a1,i8,a1,a,a1,a)') & locnam, tabsep, nobs, tabsep, nall, tabsep, tau, tabsep, & pstring(asyp), tabsep, pstring(pval), tabsep, it, tabsep, & 'Ass-JT', tabsep, histo end if return end if call setup_table(1, 100, ptable) idx=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) dataset%untyped(i)=.true. if (dataset%plocus(i,trait) /= MISS .and. & observed(i, gene, dataset)) then dataset%untyped(i)=.false. idx=idx+1 call get_namedgeno(i, gene, gen2, dataset, allele_buffer, g1, g2) irank(idx)=i geno(idx)=int(clcpos(g1, g2)) call insert_table(1, dataset%plocus(i, trait), ptable, 1) end if end do end if end do nobs=idx call isort(1, nobs, geno, irank, 2) call groupgenos(nobs, geno, ngroups, gstrata) do i=1, nobs pheno(i)=dataset%plocus(irank(i), trait) end do call terpstra(ngroups, gstrata, nobs, pheno, tau) if (plevel > 0) then write(outstr,'(3(/a,i0)/a,f9.1)') & 'Number of genotypes = ', ngroups, & 'Number of unique trait values = ', ptable%ncells, & 'Number of observations = ', nobs, & 'Jonckheere-Terpstra Statistic = ', tau end if asyp=1.0d0 etau=0.0d0 tailp=0 vartau=0.0d0 if (typ == 1) then ! ! Sequential Monte-Carlo P-value after Besag & Clifford Biometrika 1991 ! P= tailp/it if tailp=mincnt or (tailp+1)/(it+1) if tailp<mincnt && it=iter ! permute the survival table ! it=0 do while (it < iter .and. min(tailp, it-tailp) < mincnt .and. irupt == 0) it=it+1 idx=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset if (allele_buffer%xlinkd) then call xsimped(ped, dataset, allele_buffer, set) else call simped(ped, dataset, allele_buffer, set) end if ii=0 do i=dataset%num(ped-1)+1, dataset%num(ped) ii=ii+1 if (.not.dataset%untyped(i)) then idx=idx+1 irank(idx)=i geno(idx)=int(clcpos(set(ii,1), set(ii,2))) end if end do end if end do call isort(1, nobs, geno, irank, 2) call groupgenos(nobs, geno, ngroups, gstrata) do i=1, nobs pheno(i)=dataset%plocus(irank(i), trait) end do if (plevel > 2) then write(outstr,'(i5,1x,a,15(i4):)') it, 'Geno: ', geno(1:nobs) write(outstr,'(i5,1x,a,15(1x,f3.0):)') it, 'Pheno: ', pheno(1:nobs) write(outstr,'(i5,1x,a)', advance='no') it, 'Stat: ' write(outstr,*) otau end if call terpstra(ngroups, gstrata, nobs, pheno, otau) call moment(it, otau, etau, vartau) if (otau > tau .or. (otau == tau .and. random() > 0.5)) then tailp=tailp+1 end if topvals(1)=otau call dsort(ntopvals,topvals) if (plevel > 1) then write(outstr,'(a,i8,a,f6.1)') 'Pseudosample ',it,': JT statistic=', otau end if end do else if (typ == 2) then do it=1, iter do i=1, nobs ifro=irandom(1,nobs) ito=irandom(1,nobs) tmp=pheno(ito) pheno(ito)=pheno(ifro) pheno(ifro)=tmp end do call terpstra(ngroups, gstrata, nobs, pheno, otau) if (plevel > 2) then write(outstr,'(i5,1x,a,15(i4):)') it, 'Geno: ', geno(1:nobs) write(outstr,'(i5,1x,a,15(1x,f3.0):)') it, 'Pheno: ', pheno(1:nobs) write(outstr,'(i5,1x,a)', advance='no') it, 'Stat: ' write(outstr,*) otau end if call moment(it, otau, etau, vartau) if (otau > tau .or. (otau == tau .and. random() > 0.5)) then tailp=tailp+1 end if topvals(1)=otau call dsort(ntopvals,topvals) end do end if vartau=vartau/max(it,1) zstat=(tau-etau)/sqrt(vartau) asyp=2.0d0*zp(abs(zstat)) pval=evdtailp(2*min(tailp, it-tailp), it, ntopvals, topvals, tau) if (plevel > 0) then write(outstr, '(a,i0,a,i0,3a)') & ' Equalled or exceeded by = ',tailp,'/',it, & ' simulated values (', trim(pstring(pval)), ')' write(outstr,'(/a/11(1x,f9.1):)') ' Top simulated S:', & topvals(2:ntopvals) write(outstr,'(a,f9.1,a,g9.2,a/2a)') & 'Simulated mean (variance) = ', etau, ' (', vartau, ')', & 'Asymptotic (Wald) P value = ', trim(pstring(asyp)) else call phist(asyp, pval, histo) write(outstr,'(a20,2(a1,i6),a1,f10.1,2(a1,a),a1,i8,a1,a,a1,a)') & locnam, tabsep, nobs, tabsep, nall, tabsep, tau, tabsep, & pstring(asyp), tabsep, pstring(pval), tabsep, it, tabsep, & 'Ass-JT', tabsep, histo end if end subroutine simtrend ! ! partition ordered list of genotypes returning boundaries of each subset ! subroutine groupgenos(nobs, geno, ngroups, gstrata) integer, intent(in) :: nobs integer, dimension(nobs), intent(inout) :: geno integer, intent(out) :: ngroups integer, dimension(:), intent(out) :: gstrata integer, parameter :: MISS = -9999 integer i, prev ngroups=0 prev=MISS do i=1, nobs if (geno(i) /= prev) then prev=geno(i) ngroups=ngroups+1 gstrata(ngroups)=i end if end do gstrata(ngroups+1)=nobs+1 end subroutine groupgenos ! ! Sum_{k<l} Sum_{ij} I(X_{ik} < X_{jl}) + 0.5 I(X_{ik} = X_{jl}), ! where i, j are observations in groups k and l respectively. ! subroutine terpstra(ngroups, gstrata, nobs, pheno, tau) integer, intent(in) :: ngroups integer, dimension(ngroups+1), intent(in) :: gstrata integer, intent(in) :: nobs double precision, dimension(nobs), intent(in) :: pheno double precision, intent(out) :: tau integer :: i, icomp, j, k, l tau=0.0d0 do l=1, ngroups do k=1, l-1 do i=gstrata(l), gstrata(l+1)-1 icomp=0 do j=gstrata(k), gstrata(k+1)-1 if (pheno(j) == pheno(i)) then icomp=icomp+1 else if (pheno(i) > pheno(j)) then icomp=icomp+2 end if end do tau=tau+0.5d0*dble(icomp) end do end do end do end subroutine terpstra ! ! One-way tabulation by pedigree ! subroutine pedtab(trait, nloci, loc, loctyp, locpos, locnotes, & dataset, nwid, ndec, plevel) use outstream use locus_types use contingency_table use ped_class use read_data integer, intent(in) :: trait integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=40), dimension(:), intent(in) :: locnotes type (ped_data) :: dataset integer, intent(in) :: nwid, ndec integer, intent(in) :: plevel integer, parameter :: MISS=-9999 integer :: gene, gen2, g1, g2, ltyp, lpos, i, nmiss, ped type (table_data) :: traittable double precision :: res double precision, dimension(1) :: val call setup_table(1, 30, traittable) ltyp=loctyp(trait) gene=locpos(trait) gen2=gene+1 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then nmiss=0 if (ismarker(ltyp)) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (.not.observed(i, gene, dataset)) then nmiss=nmiss+1 else call get_geno(i, gene, gen2, dataset, g1, g2) val(1)=encgtp(g1, g2) call insert_table(1, val, traittable, 1) end if end do else if (isspecial(ltyp)) then do i=dataset%num(ped-1)+1, dataset%num(ped) call autovar(i, gene, nloci, loctyp, locpos, dataset, res) if (res /= MISS) then val(1)=res call insert_table(1, val, traittable, 1) else nmiss=nmiss+1 end if end do else do i=dataset%num(ped-1)+1, dataset%num(ped) if (dataset%plocus(i,gene) /= MISS) then val(1)=dataset%plocus(i,gene) call insert_table(1, val, traittable, 1) else nmiss=nmiss+1 end if end do end if call sort_table(traittable) call onetab(dataset%pedigree(ped), ltyp, locnotes(trait), & traittable, nmiss, nwid, ndec) call zero_table(traittable) end if end do call clean_table(traittable) end subroutine pedtab ! ! Fit poisson model to a contingency table ! subroutine fitloglin(sta, fin, terms, nloci, loc, lochash, loctyp, locpos, & locnotes, dataset, mlik, mpar, pval, nwid, ndec, plevel) use outstream use ped_class use formula_class use contingency_table use locus_types use locus_list use alleles_class use lochash_class use read_data use statfuns use categorical_data integer, intent(in) :: sta, fin character (len=*), dimension(:), intent(inout) :: terms integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc type (hash_table) :: lochash integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=40), dimension(:), intent(in) :: locnotes type (ped_data) :: dataset integer, intent(in) :: nwid, ndec double precision, intent(out) :: mlik integer, intent(out) :: mpar double precision, intent(out) :: pval integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS=-9999 ! model type (formula_data) :: formula ! ! full and marginal tables type (table_data) :: table type (table_data), dimension(:), allocatable :: martable ! values of each variable for ith person double precision, dimension(:), allocatable :: val integer, dimension(:), allocatable :: counters, mincounters ! ! main effect values for ith person double precision, dimension(:), allocatable :: xmain ! ! template for producing one row of design matrix integer, dimension(:,:), allocatable :: rowform integer, dimension(:,:), allocatable :: rowlevs ! loglinear model integer imod, ncells, ncov, npars, totpars double precision, dimension(:), allocatable :: counts double precision, dimension(:), allocatable :: model double precision, dimension(:), allocatable :: offset double precision, dimension(:), allocatable :: b double precision, dimension(:), allocatable :: cov integer :: df, sample_weight double precision :: lrts, pred, res, tval integer :: endarg, g1, g2, i, ifail, ilev, iloc, j, k, k2, lpos, ltyp, nel, & off, off1, off2, pos, pos2, xpos logical :: reading ! allelic and HWE models integer :: gene, genemod type (allele_data) :: allele_buffer ! integer, dimension(1) :: loclist logical :: anymain ! given interaction has a main effect included in model character (len=3) :: histo character (len=10) :: clev character (len=30) :: cval ! functions integer :: getnam double precision :: ftdev character (len=6) :: pstring interface subroutine loglin(ncells, totpars, npars, counts, model, offset, b, cov, lrts) integer, intent(in) :: ncells integer, intent(in) :: totpars integer, intent(in) :: npars double precision, dimension(:), intent(inout) :: counts double precision, dimension(:), intent(inout) :: model double precision, dimension(:), intent(inout) :: offset double precision, dimension(:) :: b double precision, dimension(:) :: cov double precision :: lrts end subroutine loglin end interface mlik=0.0d0 mpar=0 pval=1.0d0 sample_weight=MISS endarg=fin gene=MISS genemod=0 reading=.true. do while (reading) if (terms(endarg) == 'all' .or. terms(endarg) == 'allelic') then genemod=-1 endarg=endarg-1 else if (terms(endarg-1) == 'wei' .or. terms(endarg-1) == 'weight' .or. & terms(endarg-1) == 'sampleweight') then call gettrait(terms(endarg), LOC_TRA, 0, nloci, loc, lochash, & loctyp, sample_weight, 0) endarg=endarg-2 else reading=.false. end if end do call expand_form(sta, endarg, terms, ifail) if (ifail /= 0) then write(outstr,'(a,i0)') 'ERROR: Badly formed formula ifail=', ifail return end if call create_form(sta, endarg, terms, nloci, loc, lochash, formula) if (formula%nterms == 0) then write(outstr,'(a)') 'ERROR: No usable terms in formula.' return end if pos=len_trim(loc(formula%effects(1))) if (plevel > -2) then write(outstr,'(/a/3a)', advance='no') & '---------------------------------------------------------------------------', & 'Loglinear model of "', trim(loc(formula%effects(1))),'"' do j=2, formula%neff pos=pos+len_trim(loc(formula%effects(j)))+4 if (pos > 72 .and. j < formula%neff) then write(outstr,'(3a)',advance='no') '..."', trim(loc(formula%effects(formula%neff))), '"' exit else write(outstr,'(3a)',advance='no') ' * "', trim(loc(formula%effects(j))), '"' end if end do write(outstr,'(/a)') & '---------------------------------------------------------------------------' end if ! nmiss=0 allocate(val(formula%neff)) allocate(counters(formula%neff)) allocate(mincounters(formula%neff)) ! accumulate counts call maketab(0, sample_weight, formula%neff, formula%effects, & nloci, loc, locpos, loctyp, dataset, nmiss, table) if (table%ncells == 0) then write(outstr,'(a)') 'ERROR: No eligible data for specified loglinear model.' return end if ! ! all margins of the table, used to setup design matrix ! allocate(martable(formula%neff)) do j=1, formula%neff iloc=formula%effects(j) ltyp=loctyp(iloc) loclist(1)=j call setup_table(1, 30, martable(j)) call marginal_table(1, loclist, table, martable(j)) if (genemod /= 0 .and. gene == MISS .and. isactdip(ltyp)) then genemod=j gene=iloc call freq(locpos(gene), loctyp(gene), 0, dataset, allele_buffer) formula%nlev(j)=allele_buffer%numal formula%nrows(j)=allele_buffer%numal*(allele_buffer%numal+1)/2 else formula%nlev(j)=martable(j)%ncells formula%nrows(j)=martable(j)%ncells end if if (plevel > 0) then write(clev,'(i10)') martable(j)%ncells write(outstr,'(/4a)') trim(loc(iloc)), ': ', trim(adjustl(clev)), ' levels' do k=1, martable(j)%ncells write(cval,'(i10)') j cval='(' // trim(adjustl(cval)) // ')' pos=martable(j)%idx(k) call wrtrait(martable(j)%categories(pos,1)%rvalue, clev, & loctyp(iloc), get_notes(loc(iloc), locnotes(iloc)), & nwid, ndec) write(outstr,'(a6,a10,1x,i6)') cval, clev, martable(j)%icount(pos) end do end if end do if (plevel > -2) then write(outstr,'(/a)', advance='no') 'Model:' if (formula%intercept) then write(outstr, '(1x,a)', advance='no') 'Intercept' end if do i=1, formula%nterms pos=formula%termlist(i,1) write(cval, '(i10)') formula%nlev(pos) write(outstr, '(2x,4a)', advance='no') & trim(loc(formula%effects(pos))), '(', trim(adjustl(cval)), ')' do j=2, formula%termdim(i) pos=formula%termlist(i,j) write(cval, '(i10)') formula%nlev(pos) write(outstr, '(5a)', advance='no') & '*', trim(loc(formula%effects(pos))), '(', trim(adjustl(cval)), ')' end do if (mod(i,5) == 0) write(outstr,'(/4x,a)', advance='no') ' ' end do write(outstr,*) end if if (genemod /= 0) then if (gene /= MISS) then if (plevel > -2) then write(outstr,'(3a)') & 'Allelic model (including HWE) fitted for "', trim(loc(gene)), '".' end if else write(outstr,'(a)') & 'NOTE: Allelic model requested, but no eligible marker locus.' end if end if ! ! Complete the details of formula in formula structure call sumcols_form(formula) if (plevel > 1) then call show_form(formula) end if ! ! augment table with sampling zeroes ! it=0 counters=1 counters(formula%neff)=0 do while (it < formula%maxrows) it=it+1 counters(formula%neff)=counters(formula%neff)+1 do i=formula%neff, 1, -1 if (counters(i) > formula%nrows(i)) then counters(i)=1 counters(i-1)=counters(i-1)+1 end if end do do i=1, formula%neff if (counters(i) <= martable(i)%ncells) then pos=martable(i)%idx(counters(i)) val(i)=martable(i)%categories(pos,1)%rvalue end if end do call insert_table(formula%neff, val, table, 0) end do ! ! Setup vectors used to fill in design matrix ! allocate(xmain(0:formula%mainlen)) allocate(rowform(formula%designcols, formula%maxlev)) allocate(rowlevs(formula%designcols, formula%maxlev)) rowform=0 rowlevs=0 off=0 if (formula%intercept) off=off+1 nel=off do j=1, formula%nterms ! ! simulated nested do-loops to setup interactions allowing for aliasing ! anymain=.false. do k=1, formula%termdim(j) mincounters(k)=1 lpos=formula%termlist(j,k) if (formula%intercept .and. formula%inform(lpos) == 1) then anymain=.true. mincounters(k)=mincounters(k)+1 end if end do ! write(*,*) 'mincounters: ', mincounters counters=mincounters if (anymain) counters(formula%termdim(j))=counters(formula%termdim(j))-1 do pos=1, formula%termlev(j) nel=nel+1 counters(formula%termdim(j))=counters(formula%termdim(j))+1 do k=formula%termdim(j), 1, -1 lpos=formula%termlist(j,k) if (counters(k) > formula%nlev(lpos)) then counters(k)=mincounters(k) counters(k-1)=counters(k-1)+1 end if ! write(*,*) k, counters rowform(nel,k)=formula%sta(lpos)+counters(k)-1 rowlevs(nel,k)=counters(k) ! write(*,*) j, ': ' ! do ii=1, formula%maxlev ! write(*,*) rowform(1:formula%designcols,ii) ! end do end do end do end do ! ! Now set up loglinear model totpars=formula%designcols mpar=totpars ncov=totpars*(totpars+1)/2 allocate(counts(table%ncells), offset(table%ncells)) allocate(b(totpars), cov(ncov), model(table%ncells*totpars)) b=0.0d0 cov=0.0d0 offset=0.0d0 model=0.0d0 off=0 if (formula%intercept) off=off+1 mpos=0 ! moving through table of counts do i=1, table%ncells pos=table%idx(i) counts(i)=dble(table%icount(pos)) ! main effects for ith row of design matrix xmain=0.0d0 xmain(0)=1.0d0 xpos=0 do j=1, formula%neff if (j == genemod) then call decgtp(table%categories(pos,j)%rvalue, g1, g2) g1=getnam(g1, allele_buffer) g2=getnam(g2, allele_buffer) xmain(xpos+g1)=xmain(xpos+g1)+1 xmain(xpos+g2)=xmain(xpos+g2)+1 if (g1 /= g2) offset(i)=offset(i)+log(2.0d0) xpos=xpos+allele_buffer%numal else idx=findlev(table%categories(pos,j)%rvalue, martable(j)) xmain(xpos+idx)=xmain(xpos+idx)+1 xpos=xpos+martable(j)%ncells end if end do ! model terms if (formula%intercept) then mpos=mpos+1 model(mpos)=xmain(0) end if do j=off+1, formula%designcols mpos=mpos+1 model(mpos)=xmain(0) do k=1, formula%maxlev model(mpos)=model(mpos)*xmain(rowform(j,k)) end do end do end do call loglin(table%ncells, totpars, mpar, counts, model, offset, b, cov, mlik) if (plevel > -1) then write(outstr,'(/a/a)') & ' Term Beta Stand Error Exp(Beta) t-Value', & '-------------------------------------------------------------------------------' i=0 ii=0 if (formula%intercept) then i=i+1 ii=ii+i if (cov(ii) > 0.0d0) then tval=abs(b(i))/sqrt(cov(ii)) else tval=0.0d0 end if call phist(zp(tval),1.0d0,histo) cval='Intercept' write(outstr,'(a30,f10.4,3x,f10.4,3x,2(f11.3,1x),a3)') & cval, b(i), sqrt(cov(ii)), exp(b(i)), tval, histo end if nel=1 do k=1, formula%nterms do k2=1, formula%termlev(k) i=i+1 ii=ii+i if (cov(ii) > 0.0d0) then tval=abs(b(i))/sqrt(cov(ii)) else tval=0.0d0 end if pos=formula%termlist(k,1) cval=adjustl(trim(loc(formula%effects(pos)))) if (pos == genemod) then call wrall(allele_buffer%allele_names(rowlevs(i,1)), clev) else write(clev, '(i10)') rowlevs(i,1) end if cval=trim(cval) // '(' // trim(adjustl(clev)) // ')' do j=2, formula%termdim(k) pos=formula%termlist(k,j) if (pos == genemod) then call wrall(allele_buffer%allele_names(rowlevs(i,j)), clev) else write(clev, '(i10)') rowlevs(i,j) end if cval=trim(cval) // '*' // & trim(loc(formula%effects(pos))) // '(' // trim(adjustl(clev)) // ')' end do call phist(zp(tval), 1.0d0, histo) write(outstr,'(a30,f10.4,3x,f10.4,3x,2(f11.3,1x),a3)') & cval, b(i), sqrt(cov(ii)), exp(b(i)), tval, histo end do end do end if if (plevel > 1) then write(outstr,*) do j=1, formula%neff cval=loc(formula%effects(j)) call juststr('c',cval,10) write(outstr,'(a10,1x)', advance='no') cval end do write(outstr,'(a/)', advance='no') ' Observed Expected Deviate' do j=1, formula%neff write(outstr,'(a)', advance='no') '-----------' end do write(outstr,*) '---------- ----------- ----------' do i=1, table%ncells pos=table%idx(i) do j=1, formula%neff ilev=formula%effects(j) call wrtrait(table%categories(pos,j)%rvalue, clev, & loctyp(ilev), get_notes(loc(ilev), locnotes(ilev)), & nwid, ndec) write(outstr,'(a10,1x)', advance='no') clev end do pred=0.0d0 pos=(i-1)*totpars k=pos do j=1, mpar pos=pos+1 pred=pred+b(j)*model(pos) end do pred=exp(pred+offset(i)) write(outstr,'(i11,1x,f11.1,2x,f9.2)') & int(counts(i)), pred, ftdev(counts(i), pred) end do end if if (plevel > 2) then write(outstr, '(/a,i0,a,i0/a)') & 'Cell Offset Design Matrix ', table%ncells, ' * ', mpar, & '---- ------ -----------------------------------------------' do i=1, table%ncells k=(i-1)*totpars write(outstr,'(i4,1x,f7.3)', advance='no') i, offset(i) do i2=k+1, k+min(40, mpar) write(outstr, '(1x,i1)', advance='no') int(model(i2)) end do write(outstr,*) end do end if df=formula%maxrows-mpar ! df=table%ncells-mpar pval=chip(mlik, df) if (plevel > -2) then write(outstr,'(/a,i6,a,f5.1,a)') & ' No. of complete observations =', table%ntot, & ' (', dble(100*table%ntot)/dble(table%ntot+nmiss),'%)' write(outstr,'(/a,f9.2/a,i6/a,5x,a)') & ' Model LRTS =', mlik, & ' Degrees of freedom =', df, & ' Nominal P-value =', pstring(pval) end if call clean_table(table) do j=1, formula%neff call clean_table(martable(j)) end do call cleanup_form(formula) end subroutine fitloglin ! ! Tabulate counts of typed individuals for each locus versus ! stratifying variables ! subroutine strattyp(trait, nloci, loc, loctyp, locpos, locnotes, & locord, dataset, locstat, plevel) use interrupt use outstream use ped_class use contingency_table use locus_types use categorical_data integer, intent(in) :: trait integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=40), dimension(:), intent(in) :: locnotes integer, dimension(:), intent(inout) :: locord type (ped_data) :: dataset double precision, dimension(:), intent(inout) :: locstat integer, intent(in) :: plevel ! local variables integer, parameter :: KNOWN=0, MISS=-9999 integer :: i, j, jj, ltyp, nord, ntot, ped, pos, tpos, traitlevels, typlev character (len=14) :: cval ! ! Stratum tabulation ! type (table_data) :: traittable double precision, dimension(1) :: val ! Flat table of counts integer, dimension(:,:), allocatable :: typed integer, dimension(:), allocatable :: tottyped ! functions character (len=8) :: wrpercent tpos=locpos(trait) call setup_table(1, 30, traittable) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (dataset%plocus(i,tpos) /= MISS) then dataset%untyped(i)=.false. val(1)=dataset%plocus(i,tpos) call insert_table(1, val, traittable, 1) else dataset%untyped(i)=.true. end if end do end if end do traitlevels=traittable%ncells locstat(trait)=0 if (plevel < 2) then nord=0 do j=1, trait-1 if (isactive(loctyp(j)) .and. .not.isspecial(loctyp(j))) then nord=nord+1 locord(nord)=j end if end do do j=trait+1, nloci if (isactive(loctyp(j)) .and. .not.isspecial(loctyp(j))) then nord=nord+1 locord(nord)=j end if end do else nord=0 do j=1, trait-1 if (.not.isspecial(loctyp(j))) then nord=nord+1 locord(nord)=j end if end do do j=trait+1, nloci if (.not.isspecial(loctyp(j))) then nord=nord+1 locord(nord)=j end if end do end if allocate(typed(nord, traitlevels)) allocate(tottyped(traitlevels)) typed=0 tottyped=0 ! Count observed traits do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (.not.dataset%untyped(i)) then pos=findlev(dataset%plocus(i,tpos), traittable) do jj=1, nord j=locord(jj) ltyp=loctyp(j) if (isactive(ltyp)) then if (ismarker(ltyp)) then if (observed(i, locpos(j), dataset)) then typed(jj,pos)=typed(jj,pos)+1 end if else if (.not.isspecial(ltyp)) then if (dataset%plocus(i,locpos(j)) /= MISS) then typed(jj,pos)=typed(jj,pos)+1 end if end if end if end do end if end do if (irupt > 0) exit end if end do if (plevel >= -1) then write(outstr,'(/a,a10,2a)') & '--- Number typed v. "', loc(trait),'" --------', & repeat('-', 6+max(0,traitlevels-2)*14) write(outstr,'(a,12x)', advance='no') 'Locus' do k=1, traitlevels pos=traittable%idx(k) call wrtrait(traittable%categories(pos,1)%rvalue, cval, & loctyp(trait), get_notes(loc(trait), locnotes(trait)), 9, 4) write(outstr,'(a)',advance='no') cval end do write(outstr,'(/2a)') & '-----------------------------------------------', & repeat('-', max(0,traitlevels-2)*14) do jj=1, nord j=locord(jj) write(outstr,'(a14)', advance='no') loc(j) typlev=0 do k=1, traitlevels if (typed(jj,k) == 0) typlev=typlev+1 tottyped(k)=tottyped(k)+typed(jj,k) write(outstr,'(i5,1x,a8)', advance='no') & typed(jj,k), wrpercent(typed(jj,k), traittable%icount(traittable%idx(k))) end do locstat(j)=dble(typlev) if (traitlevels < 5) then write(outstr,'(1x,a)') trim(locnotes(j)(1:(66-14*traitlevels))) else write(outstr,*) end if if (irupt > 0) exit end do write(outstr,'(2a)') & '-----------------------------------------------', & repeat('-', max(0,traitlevels-2)*14) write(outstr,'(a14)', advance='no') loc(trait) do k=1, traitlevels-1 write(outstr,'(i5,9x)', advance='no') traittable%icount(traittable%idx(k)) end do write(outstr,'(i5,i14)') & traittable%icount(traittable%idx(traitlevels)), traittable%ntot write(outstr,'(/17x)', advance='no') do k=1, traitlevels pos=traittable%idx(k) call wrtrait(traittable%categories(pos,1)%rvalue, cval, & loctyp(trait), get_notes(loc(trait), locnotes(trait)), 9, 4) write(outstr,'(a)',advance='no') cval end do write(outstr,'(/a14)', advance='no') 'Mean typed ' do k=1, traitlevels write(outstr,'(f7.1,7x)', advance='no') & dble(tottyped(k))/max(1.0d0,dble(nord)) end do write(outstr,*) else do jj=1, nord j=locord(jj) typlev=0 do k=1, traitlevels if (typed(jj, k) == 0) typlev=typlev+1 end do locstat(j)=dble(typlev) end do end if end subroutine strattyp ! ! Monte-Carlo test for HWE ! subroutine dohwe(locnam, gene, loctyp, iter, mincnt, hwefnd, norder, & dataset, outp, restrand, plevel) use interrupt use outstream use alleles_class use ped_class use rngs use sorts use statfuns use nucleotides implicit none character (len=*), intent(in) :: locnam integer, intent(in) :: gene, loctyp integer, intent(in) :: iter integer, intent(in) :: mincnt logical, intent(in) :: hwefnd integer, intent(in) :: norder type (ped_data) :: dataset double precision, intent(out) :: outp integer, intent(in) :: restrand integer, intent(in) :: plevel integer, parameter :: KNOWN=0 ! ! work arrays and allele and genotype counts ! type (allele_data) :: allele_buffer integer, dimension(dataset%maxsiz, 2) :: set integer, dimension(:,:), allocatable :: gcount integer :: df, g1, g2, gen2, i, ii, it, j, k, n, ngcount, pedoffset, ped, & tailp, tot, totall, totmal double precision :: asyp, chisq, exactp, expf, invden, ochisq, mchisq, pval, vchisq character (len=3) :: sall, histo character (len=7) :: gtp logical :: found, xmale ! lists of intersegregating alleles integer :: nhetclasses, noninterseg integer, dimension(:), allocatable :: hetclasses ! ! used to extrapolate extreme tail empirical P values using ! David & Resnick ! integer :: ntopvals double precision, dimension(norder+2) :: topvals ! functions integer :: getnam character (len=6) :: pstring double precision :: evdtailp, ftdev, hwechi interface subroutine freq(gene, loctyp, fndr, dataset, allele_buffer) use ped_class use alleles_class integer, intent(in) :: gene integer, intent(in) :: loctyp integer, intent(in) :: fndr type (ped_data), intent(in) :: dataset type (allele_data), intent(inout) :: allele_buffer end subroutine freq subroutine simped(ped, dataset, allele_buffer, set) use alleles_class use ped_class integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data), intent(in) :: allele_buffer integer, dimension(:,:), intent(out) :: set end subroutine simped subroutine xsimped(ped, dataset, allele_buffer, set) use alleles_class use ped_class integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data), intent(in) :: allele_buffer integer, dimension(:,:), intent(out) :: set end subroutine xsimped end interface call setup_freq(10, allele_buffer) call freq(gene, loctyp, 0, dataset, allele_buffer) allocate(gcount(allele_buffer%numgtp,3)) allocate(hetclasses(allele_buffer%numal)) outp=1.0d0 gen2=gene+1 ngcount=allele_buffer%numgtp do j=1, ngcount gcount(j,1)=0 gcount(j,2)=0 gcount(j,3)=0 end do tot=0 totmal=0 ntopvals = norder+2 topvals=0.0d0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) n=dataset%num(ped) if (hwefnd) then n=pedoffset+dataset%nfound(ped) end if do i= pedoffset+1, n if (.not.observed(i, gene, dataset)) then dataset%untyped(i)=.true. else xmale=(allele_buffer%xlinkd .and. dataset%sex(i) == 1) tot=tot+1 if (xmale) totmal=totmal+1 dataset%untyped(i)=.false. call get_namedgeno(i, gene, gen2, dataset, allele_buffer, g1, g2) call tabgen(g1, g2, xmale, ngcount, gcount) end if end do end if end do ! produce subgroups of intersegregating alleles, based on ! observed heterozygotes nhetclasses=0 hetclasses=0 i=1 do j=2, allele_buffer%numal do k=1, j-1 i=i+1 if (gcount(i,1) > 0) then if (hetclasses(j) > 0 .or. hetclasses(k) > 0) then if (hetclasses(j) == 0) then hetclasses(j)=hetclasses(k) else hetclasses(k)=hetclasses(j) end if else nhetclasses=nhetclasses+1 hetclasses(j)=nhetclasses hetclasses(k)=nhetclasses end if end if end do i=i+1 end do noninterseg=0 do j=1, allele_buffer%numal if (hetclasses(j) == 0) noninterseg=noninterseg+1 end do ochisq=hwechi(allele_buffer%numal, ngcount, gcount, tot, totmal) df=allele_buffer%numal if (allele_buffer%xlinkd) df=1 df=ngcount-df asyp=chip(ochisq, df) outp=asyp exactp=-1.0d0 if (.not.allele_buffer%xlinkd .and. allele_buffer%numal == 2) then call hwe2(gcount(1,1), gcount(2,1), gcount(3,1), expf, exactp) outp=exactp end if if (plevel > 0) then write(outstr,'(/3a/a/a)') & ' -------- Observed Genotypes at "',trim(locnam),'" ----', & ' Genotype Observed Expected Deviate', & ' ----------------------------------------------------' totall=2*tot-totmal invden=dble(tot-totmal)/dble(totall*totall) i=0 do j=1, allele_buffer%numal do k=1, j i=i+1 call wrgtp(allele_buffer%allele_names(k), & allele_buffer%allele_names(j), gtp, '/', '', 1) expf=dble(gcount(j,2)*gcount(k,2)) * invden if (j /= k) expf=expf+expf write(outstr,'(8x,a7,3x,i8,a,f5.3,a,f10.1,1x,f8.1)') & gtp, gcount(i,1), ' (', dble(gcount(i,1))/dble(tot-totmal), ') ', & expf, ftdev(dble(gcount(i,1)),expf) end do end do if (totmal > 0) then invden=dble(totmal)/dble(totall) write(outstr,'(a)') ' Male Haplotype Observed Expected Deviate' do j=1, allele_buffer%numal call wrgtp(allele_buffer%allele_names(j), 0, gtp, '/', '', 1) expf=dble(gcount(j,2)) * invden write(outstr,'(8x,a7,3x,i8,a,f5.3,a,f10.1,1x,f8.1)') & gtp, gcount(j,3), ' (', dble(gcount(j,3))/dble(totmal), ') ', & expf, ftdev(dble(gcount(j,3)),expf) end do end if write(outstr,'(a/10x,a,3x,i8,a)') & ' ----------------------------------------------------', & 'Total', tot,' (1.000)' if (allele_buffer%xlinkd) then write(outstr,'(/a,i0,a,i0,a)') & ' Number of genotypes =',tot,' (',totmal,' male)' else write(outstr,'(/a,i0)') ' Number of genotypes =',tot end if write(outstr,'(a,f6.1/a,i0/a,3x,a)') & ' Hardy-Weinberg LR chi-sq =', ochisq, & 'Nominal degrees of freedom =', df, & ' Nominal P-value =', pstring(asyp) if (exactp /= -1.0d0) then write(outstr,'(a,3x,a)') & ' Exact P-value =', pstring(exactp) end if end if ! ! MC sequential P-value for HWE ! if (.not.hwefnd .and. iter > 0 .and. ngcount > 1) then it=0 mchisq=0.0D0 tailp=0 vchisq=0.0D0 do while (it < iter .and. tailp < mincnt .and. irupt == 0) it=it+1 do j=1, ngcount gcount(j,1)=0 gcount(j,2)=0 gcount(j,3)=0 end do do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) if (allele_buffer%xlinkd) then call xsimped(ped, dataset, allele_buffer, set) else call simped(ped, dataset, allele_buffer, set) end if i=0 do ii=pedoffset+1, dataset%num(ped) i=i+1 if (.not.dataset%untyped(ii)) then xmale=(allele_buffer%xlinkd .and. dataset%sex(ii) == 1) call tabgen(set(i,1),set(i,2), xmale, ngcount, gcount) end if end do end if end do chisq=hwechi(allele_buffer%numal, ngcount, gcount, tot, totmal) topvals(1)=chisq call dsort(ntopvals,topvals) call moment(it, chisq, mchisq, vchisq) if (chisq > ochisq .or. (chisq == ochisq .and. random() > 0.5)) then tailp=tailp+1 end if if (plevel > 1) then write(outstr,'(a,i8,a,f6.1)') 'Pseudosample ',it,': Chisq=',chisq if (plevel > 2) then write(outstr,*) 'Genos: ',(gcount(j,1), j=1, ngcount) write(outstr,*) 'Allel: ',(gcount(j,2), j=1, allele_buffer%numal) if (allele_buffer%xlinkd) then write(outstr,*) 'Males: ',(gcount(j,3), j=1, allele_buffer%numal) end if end if end if end do if (tailp < mincnt) then tailp=tailp+1 it=it+1 end if vchisq=vchisq/dble(max(1,it-1)) pval=evdtailp(tailp, it, ntopvals, topvals, ochisq) else it=0 tailp=0 pval=1.0d0 end if if (plevel > 0) then write(outstr,'(a,i4,a,i5,3a/a,f6.1,a,f6.1,a)') & ' Equalled or exceeded by =', tailp, '/', it, & ' simulated values (', trim(pstring(pval)), ')', & ' Mean (Var) simulated chi-sqs =', mchisq, ' (', vchisq,')' if (plevel > 1) then write(outstr,'(/a/11(1x,f6.1):)') ' Top simulated chi-sqs:', & topvals(2:ntopvals) end if if ((noninterseg > 0 .and. nhetclasses > 0) .or. nhetclasses > 1) then write(outstr,'(/a/a/)') 'Some heterozygotes were not observed,', & 'so alleles divide into segregating groups:' do i=0, nhetclasses write(outstr,'(a,i0,a)', advance='no') 'Group ', i, ':' do j=1, allele_buffer%numal if (hetclasses(j) == i) then call wrall(allele_buffer%allele_names(j), sall) write(outstr,'(1x,a)', advance='no') trim(adjustl(sall)) end if end do write(outstr,*) end do end if else if (plevel > -2 .and. restrand == 1) then if (exactp/=-1.0d0) asyp=exactp call phist(asyp, pval, histo) write(outstr,'(a20,2(a1,i6),a1,f10.1,2(a1,a),a1,i6,2(a1,a))') & locnam, tabsep, tot, tabsep, ngcount, tabsep, ochisq, tabsep, & pstring(asyp), tabsep, pstring(pval), tabsep, it, tabsep, & 'HWE', tabsep, histo end if if (iter == 0) pval=asyp outp=pval if (restrand == 2) then call strandhet(locnam, gene, dataset, allele_buffer, & nhetclasses, hetclasses, pval, plevel+2) end if end subroutine dohwe ! ! Increment counts of genotypes and alleles for HWE test ! Storage of allele counts in gcount(,2) indexed from 1..nall ! Genotypes indexed from 1..ngtp by gcount(,1). ! Males contribute to allele counts but not genotype counts ! subroutine tabgen(a1, a2, xmale, ngcount, gcount) integer, intent(in) :: a1 integer, intent(in) :: a2 logical, intent(in) :: xmale integer, intent(in) :: ngcount integer, dimension(ngcount,3), intent(inout) :: gcount integer idx ! allele counts if (xmale) then gcount(a1,2)=gcount(a1,2)+1 gcount(a1,3)=gcount(a1,3)+1 else gcount(a1,2)=gcount(a1,2)+1 gcount(a2,2)=gcount(a2,2)+1 ! genotype count idx=a2*(a2-1)/2+a1 gcount(idx,1)=gcount(idx,1)+1 end if end subroutine tabgen ! ! Calculate HWE Chi-square for table entered on command line ! subroutine hwep(numal) use outstream use statfuns integer, intent(in) :: numal ! genotype counts integer, dimension((numal*(numal+1)/2),3) :: gcount integer :: df, i, ioerr, j, ngcount, tot, totmal double precision :: chisq, pa, pvalue ! functions double precision :: hwechi character (len=6) :: pstring ngcount=0 tot=0 totmal=0 ngcount=numal*(numal+1)/2 df=ngcount-numal do i=1, ngcount gcount(i,2)=0 gcount(i,3)=0 end do write(outstr,'(i3,a)', advance='no') ngcount,' genotype counts> ' read(*,*, iostat=ioerr) (gcount(i,1), i=1, ngcount) if (ioerr == 0) then ngcount=0 do i=1, numal do j=1, i ngcount=ngcount+1 gcount(i,2)=gcount(i,2)+gcount(ngcount,1) gcount(j,2)=gcount(j,2)+gcount(ngcount,1) tot=tot+gcount(ngcount,1) end do end do chisq=hwechi(numal, ngcount, gcount, tot, totmal) ngcount=0 do i=1, numal write(outstr,'(/f6.4,$)') 0.5d0*dble(gcount(i,2))/dble(tot) do j=1, i ngcount=ngcount+1 write(outstr,'(i5,$)') gcount(ngcount,1) end do end do write(outstr,'(//a,1x,i0/a,f10.1,a,i0,3a)') & 'Total N =', tot, & 'HWE X2 =',chisq, & ' (df=',ngcount,'; P=', trim(pstring(chip(chisq,df))), ')' if (numal == 2) then call hwe2(gcount(1,1), gcount(2,1), gcount(3,1), pa, pvalue) write(outstr, '(a,4x,a)') 'Exact P =', pstring(pvalue) end if else ! input error write(outstr,'(a,i3,a)') 'ERROR: Expected ', ngcount, ' genotype counts!' end if end subroutine hwep ! ! Calculate Gibbs chi-square for HWE ! function hwechi(numal, ngcount, gcount, tot, totmal) double precision hwechi integer, intent(in) :: numal integer, intent(in) :: ngcount integer, dimension(ngcount,3), intent(in) :: gcount integer, intent(in) :: tot integer, intent(in) :: totmal double precision, parameter :: eps=1.0D-5 ! allele frequencies and genotype counts integer :: i,j,k, totall double precision :: c,e,o if (totmal == 0) then c=0.25d0/dble(tot) else totall=2*tot-totmal c=dble(tot-totmal)/dble(totall*totall) end if hwechi=0.0d0 i=0 do j=1, numal do k=1, j i=i+1 o=dble(gcount(i,1)) e=c*dble(gcount(j,2)*gcount(k,2)) if (j /= k) e=e+e if (e > eps .and. o > eps) then hwechi=hwechi+o*log(o/e) end if end do end do if (totmal /= 0) then c=dble(totmal)/dble(totall) do j=1, numal o=dble(gcount(j,3)) e=c*dble(gcount(j,2)) if (e > eps .and. o > eps) then hwechi=hwechi+o*log(o/e) end if end do end if hwechi=hwechi+hwechi end function hwechi ! ! calculate hwe test for diallelic autosomal marker ! subroutine hwe2(n11, n12, n22, pa, pvalue) integer, intent(in) :: n11 integer, intent(in) :: n12 integer, intent(in) :: n22 double precision, intent(out) :: pa double precision, intent(out) :: pvalue integer :: i, fin, n, n1, n2, sta double precision :: d, obsd ! functions double precision :: dhwe2 n=n11+n12+n22 n1=2*n11+n12 n2=2*n22+n12 pa=dble(n1)/dble(n+n) sta=mod(n1, 2) fin=min(n1, n2) obsd=dhwe2(n11, n12, n22) ! write(*,*) 'obsd=', obsd pvalue=0.0d0 do i=sta, fin, 2 d=dhwe2((n1-i)/2, i, (n2-i)/2) if (d <= obsd) pvalue=pvalue+d ! write(*,*) 'iterd=', (n1-i)/2, i, (n2-i)/2, d, pvalue end do end subroutine hwe2 ! ! hypergeometric for diallelic genotypes under hwe ! function dhwe2(n11, n12, n22) use statfuns double precision dhwe2 integer, intent(in) :: n11 integer, intent(in) :: n12 integer, intent(in) :: n22 integer :: n, n1, n2 n=n11+n12+n22 n1=2*n11+n12 n2=2*n22+n12 dhwe2=exp(log(2.0d0)*dble(n12) + lfact(n) - lfact(n11) & - lfact(n12) - lfact(n22) - lfact(2*n) + lfact(n1) + lfact(n2)) end function dhwe2 ! ! Do ibs sharing in parents ! subroutine domar(gene, dataset, allele_buffer, plevel) use outstream use alleles_class use ped_class use statfuns implicit none integer, intent(in) :: gene type (ped_data), intent(in) :: dataset type (allele_data), intent(in) :: allele_buffer integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS=-9999 ! ! calculate expected ibs statistics for marker double precision :: p, p2, p4, pp, pq, pq2, q, f(3) ! 2 df chi-square integer :: tab(3) double precision :: chisq, ef, expn, mu, obsn ! integer :: currf, currm, g1, g2, g3, g4, gen2, i, ibd, j, nmat integer :: nfound, ped double precision :: zibd ! functions ! chip character (len=6) :: pstring ! if (allele_buffer%numal < 2) return ! mu=0.0D0 do i=1, 3 tab(i)=0 end do gen2=gene+1 ! ! Calculate expected values for ibs statistic p2=0.0D0 p4=0.0D0 pp=0.0D0 pq2=0.0D0 do i=1, allele_buffer%numal p=allele_buffer%allele_freqs(i) q=1.0D0-p p=p*p q=q*q pq2=pq2+p*q p4=p4+p*p do j=i+1, allele_buffer%numal p=allele_buffer%allele_freqs(i) q=allele_buffer%allele_freqs(j) p2=p2+p*p*q*q pq=1.0D0-p-q pp=pp+p*q*pq*pq end do end do f(1)=pq2+pp+pp f(3)=4.0D0*p2+p4 f(2)=1.0D0-f(3)-f(1) ef=f(3)+0.5D0*f(2) ! do ped=1, dataset%nped if (dataset%actset(ped) > 0) then nfound=dataset%num(ped-1)+dataset%nfound(ped) currf=MISS currm=MISS do i=nfound+1, dataset%num(ped) if ((dataset%fa(i) /= currf .or. dataset%mo(i) /= currm) .and. & observed(dataset%fa(i), gene, dataset) .and. & observed(dataset%mo(i), gene, dataset)) then currf=dataset%fa(i) currm=dataset%mo(i) call get_geno(dataset%fa(i), gene, gen2, dataset, g1, g2) call get_geno(dataset%mo(i), gene, gen2, dataset, g3, g4) call sshare(g1,g2,g3,g4,zibd) ibd=int(2.0D0*zibd)+1 tab(ibd)=tab(ibd)+1 end if end do end if end do nmat=tab(3)+tab(2)+tab(1) if (nmat > 0) mu=0.5D0*dble(2*tab(3)+tab(2))/dble(nmat) write(outstr,'(/a,i4/a,3x,f6.4,a,f6.4,a)') ' Number of typed matings =',nmat, & ' Parental mean IBS sharing =', mu, ' (Expected=',ef,')' if (nmat > 0) then chisq=0.0D0 do i=1, 3 expn=dble(nmat)*f(i) obsn=dble(tab(i)) if (obsn > 0.001D0 .and. expn > 0.001D0) then chisq=chisq+obsn*log(obsn/expn) end if end do chisq=chisq+chisq write(outstr,'(a,f6.1,3a)') & ' Sharing Chi-square (2 df) =', chisq, & ' (P=', trim(pstring(chip(chisq,2))),')' end if if (plevel > 1) then q=1.0D0/dble(max(nmat,1)) write(outstr,'(2(/21x,a),2(/a,3f8.1))') & 'IBS Sharing', '2/2 1/2 0/2', 'Observed sharing', & q*dble(tab(3)), q*dble(tab(2)), q*dble(tab(1)), & 'Expected sharing', f(3), f(2), f(1) end if end subroutine domar ! ! Tabulate maternal v. paternal genotypes ! subroutine margen(gene, dataset, allele_buffer, iter, plevel) use outstream use alleles_class use ped_class implicit none integer, intent(in) :: gene type (ped_data), intent(in) :: dataset type (allele_data), intent(in) :: allele_buffer integer, intent(in) :: iter integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS=-9999 ! ! flat table for permutation P integer :: nr, nc integer, dimension(:), allocatable :: tble ! expected values for table double precision, dimension(:), allocatable :: ex ! integer :: currf, currm, g1, g2, g3, g4, gen2, i, j, k, nmat, pos integer :: nfound, ped character (len=7) :: gtp ! functions integer :: clcpos, getnam ! if (allele_buffer%numal < 2 .or. allele_buffer%numal > 4) return ! gen2=gene+1 nc=allele_buffer%numgtp nr=nc if (allele_buffer%xlinkd) nr=allele_buffer%numal allocate(tble(nc*nr), ex(nc*nr)) do i=1, nc*nr tble(i)=0 end do nmat=0 ! do ped=1, dataset%nped if (dataset%actset(ped) > 0) then nfound=dataset%num(ped-1)+dataset%nfound(ped) currf=MISS currm=MISS do i=nfound+1, dataset%num(ped) if ((dataset%fa(i) /= currf .or. dataset%mo(i) /= currm) .and. & observed(dataset%fa(i), gene, dataset) .and. & observed(dataset%mo(i), gene, dataset)) then nmat=nmat+1 currf=dataset%fa(i) currm=dataset%mo(i) call get_namedgeno(dataset%fa(i), gene, gen2, dataset, & allele_buffer, g1, g2) call get_namedgeno(dataset%mo(i), gene, gen2, dataset, & allele_buffer, g3, g4) if (allele_buffer%xlinkd) g1=1 pos=nc*(clcpos(g1,g2)-1)+clcpos(g3,g4) tble(pos)=tble(pos)+1 end if end do end if end do ! if (nmat > 0) then write(outstr,'(/12x,a/a,$)') 'Maternal Genotype','Pat Gtp ' do i=1, allele_buffer%numal do j=1, i call wrgtp(allele_buffer%allele_names(j), & allele_buffer%allele_names(i), gtp, '/', '', 1) write(outstr,'(1x,a7,$)') gtp end do end do write(outstr,*) pos=0 if (allele_buffer%xlinkd) then do i=1, nr call wrgtp(allele_buffer%allele_names(i), 0, gtp, '/', '', 1) write(outstr,'(a7,(10i8):)') gtp, (tble(pos+j), j=1, nc) pos=pos+nc end do else do i=1, allele_buffer%numal do j=1, i call wrgtp(allele_buffer%allele_names(j), & allele_buffer%allele_names(i), gtp, '/', '', 1) write(outstr,'(a7,(10i8):)') gtp, (tble(pos+k), k=1, nc) pos=pos+nc end do end do end if call rctest(nr, nc, tble, ex, iter) else write(outstr,'(a)') 'No useful matings' end if end subroutine margen ! ! Produce a scatterplot of two traits ! typ=1 scatterplot ! =2 dotplot (xtrait is categorical) ! subroutine doplot(fil, typ, xtrait, ytrait, ztrait, & xlab, ylab, zlab, pedfil, dataset) use outstream use timelib use ped_class use grapheps implicit none character (len=*), intent(in) :: fil integer, intent(in) :: typ integer, intent(in) :: xtrait, ytrait, ztrait character (len=*), intent(in) :: xlab, ylab, zlab, pedfil type (ped_data) :: dataset integer, parameter :: MISS=-9999 integer :: i, ios, ivalue, nobs, ped, pedoffset character (len=10) :: style character (len=80) :: title integer, dimension(:), allocatable :: symbols double precision, dimension(:), allocatable :: xvals, yvals style='circle' title='Sib-pair plot (' // current_time() // ')' if (pedfil /= 'inline.ped') then title='Data from ' // trim(pedfil) // ' (' // current_time() // ')' end if nobs=0 dataset%untyped=.true. if (ztrait == MISS) then do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) if (dataset%plocus(i,xtrait) /= MISS .and. & dataset%plocus(i,ytrait) /= MISS) then nobs=nobs+1 dataset%untyped(i)=.false. end if end do end if end do else do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) if (dataset%plocus(i,xtrait) /= MISS .and. & dataset%plocus(i,ytrait) /= MISS .and. & dataset%plocus(i,ztrait) /= MISS) then nobs=nobs+1 dataset%untyped(i)=.false. end if end do end if end do end if if (nobs > 0) then open(GSTRM, file=trim(fil), iostat=ios) if (ios /= 0) then write(outstr, '(a)') 'ERROR: Unable to open "', trim(fil), '".' return end if allocate(xvals(nobs), yvals(nobs)) if (ztrait /= MISS) then allocate(symbols(nobs)) nobs=0 do i=1, dataset%nobs if (.not.dataset%untyped(i)) then nobs=nobs+1 ivalue=int(dataset%plocus(i,ztrait)) if (ivalue <= 0 .or. ivalue > 10) ivalue=10 symbols(nobs)=ivalue xvals(nobs)=dataset%plocus(i,xtrait) yvals(nobs)=dataset%plocus(i,ytrait) end if end do call scatter_grapheps(GSTRM, nobs, symbols, xvals, yvals, & zlab, xlab, ylab, title, 1.2d0) else nobs=0 do i=1, dataset%nobs if (.not.dataset%untyped(i)) then nobs=nobs+1 xvals(nobs)=dataset%plocus(i,xtrait) yvals(nobs)=dataset%plocus(i,ytrait) end if end do call xy_grapheps(GSTRM, nobs, xvals, yvals, xlab, ylab, title, style, 1.2d0, typ) end if close(GSTRM, status='keep') else write(outstr, '(a)') 'NOTE: No nonmissing data to plot.' end if end subroutine doplot ! ! Produce a histogram with histcat intervals from sorted tabulation ! subroutine dohist(locnam, histcat, cat, table, nwid, ndec, outfil) use outstream use contingency_table use grapheps implicit none character (len=*) :: locnam integer, intent(in) :: histcat integer, intent(in) :: cat type (table_data) :: table integer, intent(in) :: ndec, nwid character (len=*) :: outfil integer :: cum, first, histcnt, histscale, i, ioerr, j, n, ncat, oldcum integer :: stats(3) character (len=1) :: ch character (len=9) :: fdec double precision :: histwidth, midval, upper double precision, dimension(:), allocatable :: xvals, yvals write(outstr,'(/a,i0,a,i0,a/a)') & ' Intvl Midpt Count Histogram (Nobs=', table%ntot, ', Nvals=', table%ncells,')', & ' ---------------------------------------------------------' if (table%ntot == 0) then write(outstr,'(a)') 'None' return end if allocate(xvals(histcat+1), yvals(histcat+1)) i=max(nwid, 13) call wrform('f', i, ndec, fdec) first=table%idx(1) stats(1)=table%ntot/4 stats(2)=table%ntot/2 stats(3)=3*table%ntot/4 histscale=max(1,table%ntot/100) histwidth=(table%categories(table%idx(table%ncells),cat)%rvalue- & table%categories(first,cat)%rvalue)/dble(histcat) histcnt=0 cum=0 oldcum=0 n=0 ncat=0 i=1 upper=table%categories(first,cat)%rvalue+histwidth do while (i <= table%ncells) if (table%categories(table%idx(i),cat)%rvalue <= upper) then histcnt=histcnt+table%icount(table%idx(i)) n=n+1 i=i+1 else cum=cum+histcnt if (n == 1) then midval=table%categories(table%idx(i-1),cat)%rvalue else midval=upper-0.5*histwidth end if if (oldcum <= stats(2) .and. cum >= stats(2)) then ch='+' else if (oldcum <= stats(3) .and. cum >= stats(1)) then ch='|' else ch=' ' end if write(outstr, fdec, advance='no') midval write(outstr,'(i8,1x,a1,1x,50a:)') & histcnt, ch, ('*', j=1, min(50, histcnt/histscale)) ncat=ncat+1 xvals(ncat)=midval yvals(ncat)=dble(histcnt) upper=upper+histwidth histcnt=0 n=0 oldcum=cum end if end do if (n == 1) then midval=table%categories(table%idx(i-1),cat)%rvalue else midval=upper-0.5*histwidth end if write(outstr, fdec, advance='no') midval write(outstr,'(i8,1x,a1,1x,50a:)') & histcnt, ch, ('*', j=1, min(50, histcnt/histscale)) ncat=ncat+1 xvals(ncat)=midval yvals(ncat)=dble(histcnt) ! Produce a postscript histogram plot for binned data if (outfil /= ' ') then open(GSTRM, file=outfil, iostat=ioerr) if (ioerr /= 0) return call xy_grapheps(GSTRM, ncat, xvals, yvals, locnam, & 'Frequency', ' ', 'bargraph', 1.2d0, 4) close(GSTRM, status='keep') end if end subroutine dohist ! ! Summarize test statistics for UCSC browser ! subroutine sumucsc(chr) use outstream use locus_data character (len=*), intent (in) :: chr integer, parameter :: MISS=-9999 integer :: i, idx, nvar, pos ! functions integer :: tobp write(outstr,'(2a/2a)') & 'track type=wiggle_0 name="pvalues" description="-log10 P-value"', & ' visibility=full gridDefault=on', & 'variableStep chrom=chr', trim(adjustl(chr)) do i=1, nloci if (map(i) /= MISS .and. group(i) == chr .and. locstat(i) /= MISS) then pos=tobp(map(i)) write(outstr, '(i0,1x,f9.4)') pos, -log10(max(1.0d-50,locstat(i))) end if end do end subroutine sumucsc ! ! Summarize test statistics ! subroutine tabstat(plevel) use interrupt use outstream use statfuns use locus_data integer, intent(in) :: plevel integer, parameter :: MISS=-9999, NSHOWTOP=4 double precision, parameter :: pi=3.1415926535897932d0 integer :: i, idx, nvar, pos, cumsum, grandcumsum, texponent, typ logical :: useful double precision :: cauchy, chisq, cpval, den, lam, maxstat, pval, trget character(len=7) :: cbin integer, dimension(NSHOWTOP) :: toploci ! functions character (len=6) :: pstring if (nloci == 0) return write(outstr,'(/3a//a/a)') & 'Test: "', trim(whichstat), '".', & 'Bin Count Percent CumPct ', & '------- ------- ------- -------' nvar=nloci lam=1.0d0 useful=.false. do i=1, nvar if (locstat(i) /= MISS) then useful=.true. exit end if end do if (.not.useful) return call rankstat(nvar) den=1.0d2/dble(nvar) maxstat=locstat(wloc(nvar)) typ=2 pos=0 cumsum=0 grandcumsum=0 cauchy=0.0d0 chisq=0.0d0 trget=0.0d0 do i=1, nvar pos=pos+1 idx=wloc(pos) if (locstat(idx) > trget) exit if (locstat(idx) /= MISS) cumsum=cumsum+1 end do if (locstat(idx) < 1.0d0) typ=1 if (typ == 2 .or. cumsum > 0) then grandcumsum=grandcumsum+cumsum write(outstr,'(i7,a1,i7,a1,2(2x,f5.1))') & 0, tabsep, cumsum, tabsep, den*dble(cumsum), & den*dble(grandcumsum) end if if (typ == 2) then trget=1.0d0 cumsum=0 do while (pos <= nvar) idx=wloc(pos) if (locstat(idx) > trget) then grandcumsum=grandcumsum+cumsum write(outstr,'(i7,a1,i7,a1,2(2x,f5.1))') & int(trget), tabsep, cumsum, tabsep, den*dble(cumsum), & den*dble(grandcumsum) trget=trget+1.0d0 cumsum=0 if (irupt /= 0) exit end if if (locstat(idx) <= trget) then pos=pos+1 cumsum=cumsum+1 end if end do write(outstr,'(i7,a1,i7,a1,2x,f5.1)') & int(trget), tabsep, cumsum, tabsep, den*dble(cumsum) else lam=2.198285d0*chisqd(locstat(wloc(int(nvar/2))), 1) texponent=nint(log10(locstat(idx))) trget=10.0d0**texponent cumsum=0 do while (pos <= nvar) idx=wloc(pos) cauchy=cauchy+tan(pi*(0.5d0-locstat(idx))) chisq=chisq+log(locstat(idx)) if (locstat(idx) > trget) then if (cumsum > 0 .or. trget > 1e-8) then grandcumsum=grandcumsum+cumsum write(cbin,'(i7)') texponent cbin='10^' // trim(adjustl(cbin)) write(outstr,'(a7,a1,i7,2(a1,1x,f5.1),a1,5(1x,a):)') & cbin, tabsep, cumsum, tabsep, den*dble(cumsum), & tabsep, den*dble(grandcumsum), tabsep, & (trim(loc(toploci(i))), i=1,min(cumsum, NSHOWTOP)) end if texponent=texponent+1 trget=10.0d0**texponent cumsum=0 if (irupt /= 0) exit end if if (locstat(idx) <= trget) then pos=pos+1 cumsum=cumsum+1 if (cumsum < 6) toploci(cumsum)=idx end if end do chisq=-chisq-chisq pval=chip(chisq, 2*nvar) cauchy=cauchy/dfloat(nvar) cpval=0.5d0-atan(cauchy)/pi write(cbin,'(i7)') texponent cbin='10^' // trim(adjustl(cbin)) grandcumsum=grandcumsum+cumsum write(outstr,'(a7,a1,i7,2(a1,1x,f5.1),a1,5(1x,a):)') & cbin, tabsep, cumsum, tabsep, den*dble(cumsum), & tabsep, den*dble(grandcumsum), tabsep, & (trim(loc(toploci(i))), i=1,min(cumsum, NSHOWTOP)) write(outstr,'(/a,f6.2,2(/2a)/)') & 'Lambda = ', lam, & 'Fisher P = ', pstring(pval), & 'Cauchy P = ', pstring(cpval) end if end subroutine tabstat ! ! Histogram of test statistics ! subroutine histstat(plevel) use locus_data use contingency_table integer, parameter :: MAXROW=20, MISS=-9999 integer, intent(in) :: plevel integer :: fin, i, idx, nvar, sta, typ logical :: abbreviate character(len=10) :: cval type (table_data) :: table call setup_table(1, 100, table) do i=1, nloci if (locstat(i) /= MISS) then call insert_table(1, locstat(i), table, 1) end if end do call sort_table(table) if (locstat_typ /= 1 .or. plevel > 0) then typ=11 if (locstat_typ /= 2) typ=9 wt=100.0d0/dble(max(1, table%ntot)) write(outstr,'(/3a,i0,a//a/a)') & 'Test: "', trim(whichstat), '" (takes ', table%ncells, & ' distinct values).', & 'Category Count Percent', & '---------- ------- -------' sta=1 fin=MAXROW-5 if (table%ncells < MAXROW .or. plevel > 1) fin=table%ncells do do i=sta, fin idx=table%idx(i) call wrtrait(table%categories(idx,1)%rvalue, cval, typ, whichstat, 9, 4) write(outstr,'(a10,i8,3x,f5.1)') cval, table%icount(idx), & wt*dble(table%icount(idx)) end do if (fin == table%ncells) exit write(outstr,'(2x,a)') '...' sta=max(fin+1, table%ncells-3) fin=table%ncells end do end if if (locstat_typ == 1) then write(outstr,'(/3a,i0,a/)') & 'Test: "', trim(whichstat), '" (takes ', table%ncells,' distinct values).' call dohist(trim(whichstat), min(table%ncells, 10), 1, table, 9, 4, ' ') call symtest(table, 0) end if end subroutine histstat ! ! Show ranked test statistics ! LFDR after Bickel 2021 ! subroutine sumstat(numval, plevel) use interrupt use outstream use genetic_maps use locus_data integer, intent(in) :: numval integer, intent(in) :: plevel integer, parameter :: MISS=-9999 double precision, parameter :: e_val = 2.7182818284590451d0 integer :: high, i, idx, nvar character (len=10) :: cpos character (len=6) :: pstring character (len=7) :: mapfmt double precision :: bfactor, fdr, fdrprop, lfdr if (nloci == 0) return mapfmt=mapformat(mapunits, '10') write(outstr,'(/3a)') 'Test: "', trim(whichstat), '".' call rankstat(nvar) write(outstr,'(/a,i0)') 'Total number of tests = ', nvar if (locstat_typ == 0) then high=nvar if (plevel < 1) high=min(numval, nvar) write(outstr, '(/a/a)') & 'Locus Chr Position P-value -log10(P) FDR LFDR', & '------------------ --- ---------- ------- ---------- -------------' do i=1, high idx=wloc(i) if (map(idx) == MISS) then write(cpos, '(i10)') idx cpos='(' // trim(adjustl(cpos)) // ')' call juststr('r',cpos,10) else write(cpos, mapfmt) map(idx)/mapconstant end if bfactor=-e_val*locstat(idx)*log(locstat(idx)) fdrprop=dble(i)/dble(nvar) fdr=locstat(idx)*(1.0d0-fdrprop)/fdrprop/(1.0d0-locstat(idx)) lfdr=1.0d0/(1.0d0+(1.0d0-fdrprop)/fdrprop/bfactor) if (fdr > 1.0d0) fdr=1.0d0 write(outstr, '(a18,a1,a2,a1,a10,a1,1x,a,a1,1x,f10.3,3(a1,1x,a))') & loc(idx), tabsep, group(idx), tabsep, cpos, tabsep, & pstring(locstat(idx)), tabsep, & min(1000.0d0,-log10(locstat(idx))), tabsep, & pstring(fdr), tabsep, pstring(lfdr), tabsep, trim(locnotes(idx)) if (irupt /= 0) exit end do else high=1 if (plevel < 1) high=max(1, nvar-numval+1) write(outstr, '(/a/a)') & 'Locus Chr Position Statistic', & '------------------ --- ---------- -----------' do i=nvar, high, -1 idx=wloc(i) if (map(idx) == MISS) then write(cpos, '(i10)') idx cpos='(' // trim(adjustl(cpos)) // ')' call juststr('r',cpos,10) else write(cpos, mapfmt) map(idx)/mapconstant end if write(outstr, '(a18,a1,a3,a1,a10,a1,g12.4,a1,a)') & loc(idx), tabsep, group(idx), tabsep, cpos, tabsep, & locstat(idx), tabsep, trim(locnotes(idx)) if (irupt /= 0) exit end do end if end subroutine sumstat ! ! Rank the test statistics (nvar=no. nonmissing values) ! subroutine rankstat(nvar) use locus_data use sorts integer, intent(out) :: nvar interface subroutine ascend(n, ia) integer, intent(in) :: n integer, dimension(:), intent(inout) :: ia end subroutine end interface nvar=nloci if (nvar == 0) return call ascend(nvar, wloc) call srank(nvar, locstat, wloc) end subroutine rankstat ! ! Combine P-values from a region ! subroutine combine_stats(pval, plevel) use interrupt use outstream use locus_data use genetic_maps use statfuns double precision, intent(out) :: pval integer, intent(in) :: plevel integer, parameter :: MISS=-9999 double precision, parameter :: pi=3.1415926535897932d0 logical :: zerop integer :: df, i, idx, sta, fin double precision :: cauchy, chisq, cpval character (len=10) :: cpos character (len=7) :: mapfmt ! functions logical :: isint character (len=6) :: pstring if (nloci == 0) return pval=1.0d0 if (nloci == 0) return zerop=.false. df=0 cauchy=0.0d0 chisq=0.0d0 sta=MISS fin=MISS do i=1, nord if (locstat(locord(i)) /= MISS) then sta=i exit end if end do if (sta /= MISS) then do i=nord, 1, -1 if (locstat(locord(i)) /= MISS) then fin=i exit end if end do end if if (fin == MISS) return if (plevel > 0) then write(outstr, '(/a/a)') & 'Locus Chr Position Statistic', & '------------------ --- ---------- -----------' mapfmt=mapformat(mapunits, '10') end if do i=sta, fin idx=locord(i) if (locstat(idx) /= MISS) then df=df+1 if (locstat(idx) <= 0.0d0) then zerop=.true. else cauchy=cauchy+tan(pi*(0.5d0-locstat(idx))) chisq=chisq+log(locstat(idx)) end if if (plevel > 0) then if (map(idx) == MISS) then write(cpos, '(i10)') idx cpos='(' // trim(adjustl(cpos)) // ')' call juststr('r',cpos,10) else write(cpos, mapfmt) map(idx)/mapconstant end if write(outstr, '(a18,a1,a3,a1,a10,a1,g12.4,a1,a)') & loc(idx), tabsep, group(idx), tabsep, cpos, tabsep, & locstat(idx), tabsep, trim(locnotes(idx)) end if if (irupt /= 0) exit end if end do if (zerop) then cpval=0.0d0 pval=0.0d0 else chisq=-chisq-chisq pval=chip(chisq, 2*df) cauchy=cauchy/dfloat(df) cpval=0.5d0-atan(cauchy)/pi end if write(outstr,'(/3a,1x,i0,1x,a,1x,a)') & trim(loc(locord(sta))), ' -- ', trim(loc(locord(fin))), & df, pstring(pval), pstring(cpval) end subroutine combine_stats ! ! Extract statistics from locus annotation ! pick nth column or name=value pairs in text ! subroutine get_stats(statnam) use scanner use outstream use locus_types use locus_data character (len=*), intent(in) :: statnam integer, parameter :: MISS=-9999 integer :: i, n, pos character (len=20) :: cval ! functions integer :: ival logical :: isint, isreal double precision :: fval n=0 if (isint(statnam)) then call setup_stat('Val' // trim(statnam), typ=1) pos=ival(statnam) do i=1, nloci if (isactive(loctyp(i))) then call getword(locnotes(i), pos, cval) if (isreal(cval)) then locstat(i)=fval(cval) n=n+1 else locstat(i)=MISS end if end if end do else call setup_stat(statnam, typ=1) do i=1, nloci if (isactive(loctyp(i))) then call getpairval(statnam, locnotes(i), opsimple, cval) locstat(i)=fval(cval) if (locstat(i) /= MISS) n=n+1 end if end do end if write(outstr,'(a,i0,3a)') & 'Extracted ', n, ' values from "', statnam, '" in locus annotations.' end subroutine get_stats ! ! Dump all P-values to a file ! subroutine dumpstats(strm) use outstream use locus_data use locus_types use genetic_maps use automatic_data integer, intent(in) :: strm integer, parameter :: MISS=-9999 character (len=2), parameter :: misval='NA' integer :: i, ios character (len=3) :: chr character (len=12) :: cpos character (len=7) :: mapfmt mapfmt=mapformat(mapunits, '12') write(strm,'(a20,a1,a3,a1,a12,a1,a)') & 'Locus', tabsep, 'Chr', tabsep, 'Position', tabsep, 'Stat' do i=ENVNUM+1, nloci if (isactive(loctyp(i))) then chr=misval cpos=misval if (group(i) /= ' ') then chr=group(i) end if if (map(i) /= MISS) then write(cpos, mapfmt) map(i)/mapconstant end if if (locstat(i) /= MISS) then write(strm, '(6a, g14.8)') loc(i), tabsep, chr, tabsep, cpos, tabsep, locstat(i) end if end if end do end subroutine dumpstats ! ! Dump stats for DISTmix ! subroutine todistmix(strm, selchr, dataset, allele_buffer) use outstream use locus_data use locus_types use genetic_maps use alleles_class use ped_class use statfuns implicit none integer, intent(in) :: strm character (len=*) :: selchr type (ped_data) :: dataset type (allele_data) :: allele_buffer integer, parameter :: MISS=-9999 character (len=2), parameter :: misval='NA' integer :: i, ios character (len=3) :: allel, allel2 character (len=12) :: cpos character (len=7) :: mapfmt mapfmt=mapformat(mapunits, '12') write(strm, '(a)') 'rs chr ps a1 a2 z af1' do i=1, nloci if (isactive(loctyp(i)) .and. group(i) == selchr .and. & map(i) /= MISS .and. locstat(i) /= MISS) then call freq(locpos(i), loctyp(i), 0, dataset, allele_buffer) if (allele_buffer%numal == 2) then write(cpos, mapfmt) map(i)/mapconstant call wrall(allele_buffer%allele_names(1), allel) call wrall(allele_buffer%allele_names(2), allel2) write(strm, '(6(a,1x),g14.8,1x,f6.4)') & loc(i), selchr, cpos, allel, allel2, ppnd(1.0d0-locstat(i)), & allele_buffer%allele_freqs(1) end if end if end do end subroutine todistmix ! ! Produce a plot of P-values ! subroutine asciiplot(plevel) use outstream use contingency_table use locus_types use locus_data use recast_data integer, intent(in) :: plevel integer, parameter :: MAXLEV=50, MISS=-9999 integer, dimension(6), parameter :: nbins = (/ 20, 10, 7, 5, 4, 5 /) integer, dimension(MAXLEV) :: bestloc character (len=20), dimension(MAXLEV) :: logp character (len=2) :: chr character (len=10) :: mappos integer, dimension(MAXLEV) :: chrom_start, chrom_end double precision, dimension(MAXLEV) :: minp, minpos, maxpos type (table_data) :: chrtable type (table_cell), dimension(1) :: val integer :: best, i, ibin, idx, ios, j, nb, nchrom, nobs, pcat, typ double precision :: pval, binsiz, thischr ! functions character (len=6) :: pstring bestloc=0 chrom_start=0 chrom_end=0 logp=' ' minp=0.0d0 minpos=1.0d20 maxpos=0.0d0 nobs=0 nchrom=0 call setup_table(1, 20, chrtable) do i=1, nloci if (isactive(loctyp(i)) .and. ismarker(loctyp(i))) then call encchr(group(i), pval) call set_table_cell(val(1), rvalue=pval) call insert_table_cells(1, val, chrtable, 1, slot=idx) if (locstat(i) /= MISS) then nobs=nobs+1 if (map(i) /= MISS) then minpos(idx)=min(minpos(idx), map(i)) maxpos(idx)=max(maxpos(idx), map(i)) if (chrom_start(idx) == 0) chrom_start(idx)=i chrom_end(idx)=i end if pval=-log10(locstat(i)) if (idx > MAXLEV) idx=MAXLEV if (minp(idx) < pval) then bestloc(idx)=i minp(idx)=pval end if pcat=min(20,int(pval)+1) logp(idx)(pcat:pcat)='*' end if end if end do call sort_table(chrtable) write(outstr,'(/3a/)') 'Binned Manhattan Plot "', trim(whichstat), '"' nchrom=chrtable%ncells if (nchrom > 5 .and. plevel < 1) then do j=1, nchrom idx=chrtable%idx(j) thischr=chrtable%categories(idx,1)%rvalue call decchr(thischr, chr) best=bestloc(idx) write(outstr,'(a2,2a)', advance='no') chr, '|', trim(logp(idx)) if (best > 0) then write(outstr,'(2x,a,1x,3a)') & trim(loc(best)), '(P=', trim(pstring(locstat(best))),')' else write(outstr,*) end if end do else if (nchrom > 0) then do j=1, nchrom idx=chrtable%idx(j) thischr=chrtable%categories(idx,1)%rvalue call decchr(thischr, chr) bestloc=0 logp=' ' minp=0.0d0 nb=min(nbins(min(nchrom,6)), chrom_end(idx)-chrom_start(idx)+1) binsiz=(maxpos(idx)-minpos(idx))/dfloat(nb) if (binsiz == 0.0d0) then nb=1 binsiz=1.0d0 end if do i=chrom_start(idx), chrom_end(idx) if (isactive(loctyp(i)) .and. ismarker(loctyp(i))) then call encchr(group(i), pval) if (pval == thischr .and. locstat(i) /= MISS) then pval=-log10(locstat(i)) pcat=min(20,int(pval)+1) ibin=1 if (map(i) /= MISS) then ibin=int((map(i)-minpos(idx))/binsiz)+1 end if if (minp(ibin) < pval) then bestloc(ibin)=i minp(ibin)=pval end if logp(ibin)(pcat:pcat)='*' end if end if end do pval=minpos(idx) if (pval == 1.0d20) pval = 0.0d0 do ibin=1, nb best=bestloc(ibin) write(mappos,'(f8.3)') pval mappos=trim(chr) // ':' // trim(adjustl(mappos)) write(outstr,'(3a)', advance='no') mappos, '|', trim(logp(ibin)) if (best > 0) then write(outstr,'(2x,a,1x,3a)') & trim(loc(best)), '(P=', trim(pstring(locstat(best))),')' else write(outstr,*) end if pval=pval+binsiz end do end do end if end subroutine asciiplot ! ! Produce a plot of P-values ! subroutine sumplot(fil) use outstream use timelib use locus_data use grapheps implicit none character (len=*), intent(in) :: fil integer, parameter :: MISS=-9999 integer :: i, ios, nobs, typ character (len=10) :: style character (len=20) :: xlab, ylab character (len=80) :: title double precision :: thisx double precision, dimension(:), allocatable :: xvals, yvals if (nloci == 0) return style='mountain' title='Summary of test results (' // current_time() // ')' ylab='-log10(P)' open(GSTRM, file=trim(fil), iostat=ios) if (ios /= 0) then write(outstr, '(a)') 'ERROR: Unable to open "', trim(fil), '".' return end if nobs=0 typ=2 do i=1, nloci if (map(i) /= MISS) typ=1 if (locstat(i) /= MISS) nobs=nobs+1 end do allocate(xvals(nobs), yvals(nobs)) nobs=0 thisx=0.0d0 if (typ == 1) then xlab='Map Position' do i=1, nloci if (locstat(i) /= MISS) then nobs=nobs+1 if (map(i) /= MISS) thisx=map(i) xvals(nobs)=thisx yvals(nobs)=-log10(max(1.0d-20,locstat(i))) end if end do else xlab='Locus position' do i=1, nloci if (locstat(i) /= MISS) then nobs=nobs+1 xvals(nobs)=dble(nobs) yvals(nobs)=-log10(max(1.0d-20,locstat(i))) end if end do end if call xy_grapheps(GSTRM, nobs, xvals, yvals, xlab, ylab, title, style, 1.8d0, 3) close(GSTRM, status='keep') end subroutine sumplot ! ! Produce a Q-Q (quantile-quantile) plot of P-values ! subroutine qqplot(fil) use outstream use timelib use locus_data use grapheps implicit none character (len=*), intent(in) :: fil integer, parameter :: MISS=-9999 integer :: i, idx, ios, nvar, typ character (len=10) :: style character (len=20) :: xlab, ylab character (len=80) :: title double precision :: den double precision, dimension(:), allocatable :: xvals, yvals if (nloci == 0) return style=' ' title='Quantile-Quantile plot of test results (' // current_time() // ')' xlab='Expected' ylab='Observed -log10(P)' nvar=nloci call rankstat(nvar) open(GSTRM, file=trim(fil), iostat=ios) if (ios /= 0) then write(outstr, '(a)') 'ERROR: Unable to open "', trim(fil), '".' return end if allocate(xvals(nvar), yvals(nvar)) den=log10(dble(nvar)) do i=1, nvar if (locstat(i) /= MISS) then idx=wloc(i) yvals(i)=-log10(max(1.0d-20,locstat(idx))) xvals(i)=den-log10(dble(i)) end if end do call xy_grapheps(GSTRM, nvar, xvals, yvals, xlab, ylab, title, style, 1.4d0, 10) close(GSTRM, status='keep') end subroutine qqplot ! ! Select loci (wloc) based on test on value of locstat ! subroutine selstat(message, thresh, gt, plevel) use locus_data character (len=*), intent(in) :: message double precision, intent(in) :: thresh integer, intent(in) :: gt integer, intent(in) :: plevel integer :: i double precision :: isaff do i=1, nloci wloc(i)=0 if (isaff(locstat(i), thresh, gt) == 2.0d0) then wloc(i)=1 if (plevel > 0) then write(outstr,'(5a,g12.4)') & 'Selected "', trim(loc(i)), '". ', trim(message), ' = ', locstat(i) end if end if end do end subroutine selstat ! ! Produce a MCMC trace ! subroutine traceplot(fil, nobs, nmult, yvals) use outstream use timelib use grapheps implicit none character (len=*), intent(in) :: fil integer, intent(in) :: nobs, nmult double precision, dimension(:), intent(inout) :: yvals integer, parameter :: MISS=-9999 integer :: i, ios, typ character (len=10) :: style character (len=20) :: xlab, ylab character (len=80) :: title double precision, dimension(nobs) :: xvals style='mountain' title='Sib-pair MCMC Trace (' // current_time() // ')' xlab='Iteration' ylab='-LogLik' open(GSTRM, file=trim(fil), iostat=ios) if (ios /= 0) then write(outstr, '(a)') 'ERROR: Unable to open "', trim(fil), '".' return end if do i=1, nobs xvals(i)=dble(i*nmult) end do call xy_grapheps(GSTRM, nobs, xvals, yvals, xlab, ylab, title, style, 1.8d0, 1) close(GSTRM, status='keep') end subroutine traceplot ! ! Filliben correlation here testing for normality ! ! m(i) = 1 - m(n) for i = 1 ! m(i) = (i - 0.3175)/(n + 0.365) for i = 2, 3, ..., n-1 ! m(i) = 0.5**(1/n) for i = n ! subroutine filliben(table, plevel) use outstream use contingency_table use statfuns use statresults type (table_data) :: table integer, intent(in) :: plevel ! local variables integer :: i, n double precision, dimension(3) :: cov(3) double precision, dimension(2) :: mean(2), x(2) double precision :: den, dn, p ! functions ! ppnd, zp if (table%ntot == 0) return mean(1)=0.0d0 mean(2)=0.0d0 cov(1)=0.0d0 cov(2)=0.0d0 cov(3)=0.0d0 n=table%icount(table%idx(1)) dn=dble(table%ntot) x(1)=ppnd(1.0d0-0.5d0**(1.0d0/dn)) x(2)=table%categories(1,1)%rvalue call dssp(2, n, table%icount(table%idx(1)), x, mean, cov) den=1.0d0/(0.365d0+dn) do i=2, table%ncells-1 n=n+table%icount(table%idx(i)) x(1)=ppnd(den*(dble(i) - 0.3175d0)) x(2)=table%categories(table%idx(i),1)%rvalue call dssp(2, n, table%icount(table%idx(i)), x, mean, cov) end do n=n+table%icount(table%idx(table%ncells)) x(1)=ppnd(0.5d0**(1.0d0/dn)) x(2)=table%categories(table%idx(table%ncells),1)%rvalue call dssp(2, n, table%icount(table%idx(table%ncells)), x, mean, cov) ! Filliben r statval(1)=cov(2)/sqrt(cov(1))/sqrt(cov(3)) p=log(1.0d0-statval(1))+1.99196d0+1.0402d0*(log(dn)-log(log(dn))) p=zp(p/(0.31239d0+0.788392d0/log(dn))) pval=p ! Poissonness test statval(2)=sqrt(0.5d0*dble(n-1))*(cov(1)/mean(1)-1.0d0) ! ! Approximate P-value modelled on that for Royston 1993 for W' ! if (plevel > -1) then write(outstr,'(/a,f13.4,a,f5.3,a)') & 'Filliben correlation = ', statval(1), ' (P=',p,')' p=zp(statval(2)) write(outstr,'(/a,g13.4,a,f5.3,a)') & 'Poissonness test Z = ', statval(2), ' (P=', p, ')' end if end subroutine filliben ! ! David & Johnson's Jr test for symmetry of a distribution ! Resek Busi Stat 1975; 546-551 ! Doksum Biometrika 1977; 64: 473-487 ! ! Standard error of Jr based on simulations under Gaussian true distribution ! subroutine symtest(table, plevel) use outstream use contingency_table use statfuns use statresults type (table_data) :: table integer, intent(in) :: plevel ! local variables integer, parameter :: MISS=-9999 integer :: i, n, ns1, ns2, pos(6,2) double precision :: dn, iqr, j02, x(6,2), qq(5), q(5) ! functions ! zp if (table%ntot == 0) return q(1)=0.02d0 q(2)=0.25d0 q(3)=0.5d0 q(4)=0.75d0 q(5)=0.98d0 dn=dble(table%ntot-1) do i=1, 5 x(i,1)=MISS x(i,2)=MISS qq(i)=q(i)*dn+1.0d0 pos(i,1)=nint(qq(i)-0.5d0) pos(i,2)=nint(qq(i)+0.5d0) end do pos(6,1:2)=table%ntot x(6,1:2)=0.0d0 n=0 ns1=1 ns2=1 tabloop: do i=1, table%ncells n=n+table%icount(table%idx(i)) 100 continue if (n >= pos(ns1,1) .and. x(ns1,1) == MISS) then x(ns1,1)=table%categories(table%idx(i),1)%rvalue ns1=ns1+1 goto 100 end if if (n >= pos(ns2,2) .and. x(ns2,2) == MISS) then x(ns2,2)=table%categories(table%idx(i),1)%rvalue ns2=ns2+1 ! break if all quantiles found if (ns2 > 5) exit tabloop goto 100 end if end do tabloop if (plevel > 1) then write(outstr,*) do i=1, 5 write(outstr,'(f5.3,3(1x,g13.4))') q(i), qq(i), x(i,1), x(i,2) end do write(outstr,*) end if do i=1, 5 x(i,1)=x(i,1)+(x(i,2)-x(i,1))*(qq(i)-dble(pos(i,1))) end do iqr=x(4,1)-x(2,1) j02=0.0d0 if (iqr > 0.0d0) then j02=(0.5d0*(x(1,1)+x(5,1))-x(3,1))/iqr end if statval(3)=j02 if (plevel > -2) then write(outstr,'(a,3(f13.4,a)/a,f13.4,a,f5.3,a)') & 'Median (IQR) = ',x(3,1), ' (', x(2,1), ' -- ', x(4,1), ')', & 'Symmetry test J(.02) = ', j02, ' (P=', zp(0.735D0*sqrt(dn)*abs(j02)), ')' end if end subroutine symtest ! ! Tail estimation procedure of Davis and Resnick (1984; Ann Stat 12:1467-87) ! Pareto tail estimate from order statistics per extreme value theory. ! xvals(1:(m+2)) contains the ordered m highest out of n values ! where xvals(1) is work space, xvals(2) = b = the n-m'th order statistic, ! a is the tail index, here estimated using Hill's (1975) estimator. ! xpos is the rank of xnew in the distribution, so that if b <= 0, then ! returns xpos/n ! function evdtailp(xpos, n, mm, xvals, xnew) double precision :: evdtailp integer, intent(in) :: xpos, n, mm double precision, intent(in) :: xvals(mm) double precision, intent(in) :: xnew integer :: i, m double precision :: a, b m=mm-2 evdtailp=dble(xpos)/dble(n) if (m >= n .or. xnew <= xvals(mm)) return b = xvals(2) if (b <= 0.0d0) return a = 0.0d0 do i=mm, 3, -1 a=a+log(xvals(i)) end do a=a/dble(m)-log(b) evdtailp=dble(m)/dble(n) * (xnew/b)**(-1.0d0/a) end function evdtailp ! ! calculate McNemar statistic ! function clcmcn(b,c) double precision clcmcn integer, intent(in out) :: b integer, intent(in out) :: c clcmcn=0.0d0 if ((b+c) > 0) then clcmcn=dble((b-c)*(b-c))/dble(b+c) end if end function clcmcn ! ! normal approx binomial deviate ! function binz(x, n, e) double precision :: binz integer, intent(in) :: x integer, intent(in) :: n double precision, intent(in) :: e binz=0.0d0 if (e /= 0.0d0 .and. e /= 1.0d0 .and. n > 0) then binz=(dble(x)-dble(n)*e)/ sqrt(e*(1.0d0-e)*dble(max(1,n-1))) end if end function binz ! ! Freeman-Tukey deviates ! function ftdev(o,e) double precision :: ftdev double precision, intent(in) :: o double precision, intent(in) :: e ftdev=sqrt(o)+sqrt(o+1.0d0)-sqrt(4.0d0*e+1.0d0) end function ftdev ! ! find index of coefficient for pair i,j in a lower triangular matrix ! stored as a 1-D array ! function clcpos(i,j) integer :: clcpos integer, intent(in) :: i integer, intent(in) :: j if (i > j) then clcpos=i*(i-1)/2+j else clcpos=j*(j-1)/2+i end if end function clcpos ! ! find index of coefficient for pair i,j in a lower triangular matrix ! stored as a big 1-D array ! function big_clcpos(i,j) integer(kind=8) :: big_clcpos integer, intent(in) :: i integer, intent(in) :: j if (i > j) then big_clcpos=int(i, kind=8)*(int(i, kind=8)-1)/2+int(j, kind=8) else big_clcpos=int(j, kind=8)*(int(j, kind=8)-1)/2+int(i, kind=8) end if end function big_clcpos ! ! Copy integer array A to integer array B ! subroutine copy(n, ia, ib) integer, intent(in) :: n integer, dimension(:), intent(in) :: ia integer, dimension(:), intent(out) :: ib do i=1, n ib(i)=ia(i) end do end subroutine copy ! ! Load a lower triangular matrix ! subroutine filltri(n, nn, a, dval, oval) integer, intent(in) :: n integer, intent(in) :: nn double precision, intent(out) :: a(nn) double precision, intent(in) :: dval double precision, intent(in) :: oval integer :: i,j do i=1, nn a(i)=oval end do if (dval /= oval) then j=0 do i=1, n j=j+i a(j)=dval end do end if end subroutine filltri ! ! zero-trapped log ! function ln(x) double precision :: ln double precision, intent(in) :: x if (x <= 0.0d0) then ln=0.0d0 else ln=log(x) end if end function ln ! ! logit of p ! function logit(p) double precision :: logit double precision, intent(in) :: p if (p <= 0.00000001d0) then logit=-18.42068073d0 else if (p > 0.99999999d0) then logit=+18.42068073d0 else logit=log(p)-log(1-p) end if end function logit ! ! Reverse logit ! function alogit(x) double precision :: alogit double precision, intent(in) :: x alogit=exp(x)/(1+exp(x)) end function alogit ! ! Inverse hyperbolic tan ! function inht(x) double precision :: inht double precision, intent(in) :: x inht=0.5d0*log((1.0d0+x)/(1.0d0-x)) end function inht ! ! Standard error for Fisher-Z transformed correlation coefficient ! function fishzse(n) double precision :: fishzse integer, intent(in) :: n fishzse=sqrt(1.0d0/dble(n-1)+2.0d0/dble((n-1)**2)) end function fishzse ! ! 95%CI via Fisher-Z transform for correlation coefficient ! subroutine fishzci(r, n, rlo, rhi) double precision, intent(in) :: r integer, intent(in) :: n double precision, intent(inout) :: rlo, rhi double precision :: hz, zr ! functions double precision :: inht, fishzse zr=inht(r) hz=1.96d0*fishzse(n) rlo=tanh(zr-hz) rhi=tanh(zr+hz) end subroutine fishzci ! ! Hyperbolic secant ! function sech(x) double precision :: sech double precision, intent(in) :: x sech = 2.0d0/(exp(x)+exp(-x)) end function sech ! ! Test equality of two correlation coefficients via LRTS ! (Brandner 1933; Stuart & Ord Volume 2, Exercise 26.21) ! Direction of test is retained ! function cortest(r1, r2, n1, n2) double precision :: cortest double precision, intent(in) :: r1, r2 integer, intent(in) :: n1, n2 double precision :: d, p1, p2, res ! functions double precision :: inht, sech p1=dble(n1)/dble(n1+n2) p2=dble(n2)/dble(n1+n2) d=inht(r1)-inht(r2) res=dble(n2)*log(sech(p1*d)) + dble(n1)*log(sech(p2*d)) cortest=sign(1.0d0,d)*sqrt(abs(res+res)) end function cortest ! ! ibd correlation to recombination fraction ! function rtheta(x) double precision :: rtheta double precision, intent(in out) :: x rtheta=0.5d0*(1.0d0-sqrt(max(0.0d0,x))) end function rtheta ! ! Confidence intervals around a proportion: approach of Wilson (Agresti ! & Coull) -- wrapper ! subroutine wrpropci(num, den, width) use outstream integer, intent(in) :: num integer, intent(in) :: den double precision, intent(in) :: width double precision :: phat, ll, ul, w call propci(num, den, width, phat, ll, ul) write(outstr,'(a,g14.4,1x,a,1x,i2,a,g14.4,a,g14.4)') & 'Prop=',phat, 'Agresti-Coull', int(width), '%CI=', ll, ' -- ', ul end subroutine wrpropci ! ! Actual Wilson algorithm ! subroutine propci(num, den, inwidth, phat, ll, ul) use statfuns integer, intent(in) :: num integer, intent(in) :: den double precision, intent(in) :: inwidth double precision, intent(out) :: phat, ll, ul double precision :: alpha, rtot, t1, t2, t3, width, z, z2 ! functions ! ppnd if (den == 0) then phat=0.0d0 ll=0.0d0 ul=0.0d0 end if width=inwidth if (width <= 0.0d0 .or. width >= 100.0d0) width=95.0d0 alpha=(1.0d0-0.01d0*width) z=ppnd(0.5d0*alpha) z2=z*z rtot=1.0d0/dble(den) phat=dble(num)*rtot t1=rtot*0.5d0*z2 t2=z * sqrt((phat * (1.0d0 - phat) + 0.25d0*rtot*z2)*rtot) t3=1.0d0+rtot*z2 ll=(phat+t1 + t2)/t3 ul=(phat+t1 - t2)/t3 if (num == 1) ll= -log(1.0d0-alpha)*rtot if ((den-num) == 1) ul= 1 + log(1 - alpha)*rtot end subroutine propci ! ! accumulate mean and sum-of-squares following AS41 ! subroutine moment(n, x, mean, ss) integer, intent(in) :: n double precision, intent(in) :: x double precision, intent(inout) :: mean double precision, intent(inout) :: ss ! local variables double precision :: dev dev=x-mean mean=mean+dev/dble(n) ss=ss+dev*dev*dble(n-1)/dble(n) end subroutine moment ! ! accumulate means and SSCP following AS41 ! subroutine dssp(nvar, nobs, iwt, x, mean, cov) integer, intent(in) :: nvar integer, intent(in) :: nobs integer, intent(in) :: iwt double precision, dimension(nvar), intent(inout) :: x double precision, dimension(nvar), intent(inout) :: mean double precision, dimension(nvar*(nvar+1)/2), intent(inout) :: cov ! local variables integer :: i,j,k double precision :: b, c b=dble(iwt)/dble(nobs) c=dble(iwt)-b k=0 do i=1, nvar x(i)=x(i)-mean(i) mean(i)=mean(i)+b*x(i) do j=1, i k=k+1 cov(k)=cov(k)+c*x(i)*x(j) end do end do end subroutine dssp ! ! Standardize covariance matrix (variances left on diagonal) ! subroutine covcor(nvar, nobs, cov) integer, intent(in) :: nvar integer, intent(in) :: nobs double precision, dimension(nvar*(nvar+1)/2), intent(inout) :: cov integer :: i, ii, j double precision :: den den=1.0d0/dble(max(1,nobs-1)) ii=0 do i=1, nvar ii=ii+i do j=1,i-1 cov(ii-i+j)=cov(ii-i+j)/sqrt(cov(ii))/sqrt(cov(j*(j+1)/2)) end do end do ii=0 do i=1, nvar ii=ii+i cov(ii)=den*cov(ii) end do end subroutine covcor ! ! Thin a covariance matrix ! subroutine thincov(nfull, nreduced, active, cov) integer, intent(in) :: nfull integer, intent(in) :: nreduced logical, dimension(:), intent(in) :: active double precision, dimension(:) :: cov integer :: i, j, k, pos integer, parameter :: MISS=-9999 ! write(*,*) 'nfull= ', nfull, ' nred=', nreduced ! write(*,*) 'size(active)=', size(active) ! write(*,*) 'size(cov)=', size(cov) if (nreduced == nfull) return pos=0 do i=1, nfull if (.not.active(i)) then do j=1, i-1 cov(pos+j)=MISS end do k=pos do j=i, nfull cov(k+i)=MISS k=k+j end do end if pos=pos+i end do pos=1 do i=1, nfull*(nfull+1)/2 if (cov(i) /= MISS) then cov(pos)=cov(i) pos=pos+1 end if end do end subroutine thincov ! ! Predicting values for subset (indexed by yindicator) ! given covariance matrix and values for complementary subset. ! X values are stored counting backwards in xval(nfull-ny+1:nfull) ! (the observed values for the predicted group are stored xval(1:ny) ! On output, yp contains ny (sum(active)) predicted values. ! subroutine predmat(nfull, yindicator, cov, xval, yp) integer, intent(in) :: nfull logical, dimension(:), intent(in) :: yindicator double precision, dimension(:), intent(in) :: cov double precision, dimension(:), intent(in) :: xval double precision, dimension(:), intent(out) :: yp integer, parameter :: MISS=-9999 integer :: i, iout, j, k, pos integer, dimension(nfull) :: ungeno double precision :: res ! pointer to phenotype value of untyped individuals pos=nfull+1 do i=1, nfull if (.not.yindicator(i)) then pos=pos-1 ungeno(i)=pos end if end do iout=0 pos=0 do i=1, nfull if (yindicator(i)) then res=0.0d0 do j=1, i-1 if (.not.yindicator(j)) then res=res+cov(pos+j)*xval(ungeno(j)) end if end do k=pos+i do j=i+1, nfull if (.not.yindicator(j)) then res=res+cov(k+i)*xval(ungeno(j)) end if k=k+j end do iout=iout+1 yp(iout)=res end if pos=pos+i end do end subroutine predmat ! ! Use AS164 to evaluate quadratic y' S~ y where S not necessarily full rank ! subroutine iquadmult(n, y, s, res) use AS164 integer, intent(in) :: n double precision, dimension(n), intent(in) :: y double precision, dimension(n*(n+1)/2), intent(in) :: s double precision, intent(out) :: res integer :: i, ifail, j, nter, ncov, pos double precision, dimension(n) :: b double precision, dimension(n+1) :: x double precision, dimension((n+1)*(n+2)/2) :: r res=0.0d0 nter=n+1 ncov=nter*(nter+1)/2 call inicov(nter, ncov, r) pos=0 do i=1, n do j=1, i-1 x(j)=s(pos+j) end do k=pos do j=i, n x(j)=s(k+i) k=k+j end do x(nter)=y(i) call givenc(r, ncov, nter, x, 1.0d0, ifail) pos=pos+i end do call alias(r, ncov, nter, 1.0d-15, x, ifail) call bsub(r, ncov, nter, b, n, ifail) do i=1, n res=res+b(i)*y(i) end do end subroutine iquadmult ! ! Use AS164 to fit a log-linear model ! subroutine loglin(ncells, totpars, npars, counts, model, offset, b, cov, lrts) use outstream use interrupt use AS164 integer, intent(in) :: ncells integer, intent(in) :: totpars integer, intent(in) :: npars double precision, dimension(:), intent(inout) :: counts double precision, dimension(:), intent(inout) :: model double precision, dimension(:), intent(inout) :: offset double precision, dimension(:) :: b double precision, dimension(:) :: cov double precision :: lrts double precision, parameter :: delta=1.0d-5 double precision, parameter :: eps=1.0d-6 ! local variables integer :: ifail, it, ncov, nter, pos double precision :: oldx2 ! etas (linear predictors) and weights double precision, dimension(ncells) :: eta, wt ! work arrays for AS164 double precision, dimension(:), allocatable :: x double precision, dimension(:), allocatable :: r ifail=0 nter=npars+1 ncov=nter*(nter+1)/2 allocate(x(nter), r(ncov)) nobs=0 ! ! ncell etas (linear predictors) and weights ! do i=1, ncells eta(i)=log(counts(i)+0.5d0)-offset(i) wt(i)=1.0d0/(counts(i)+0.5d0) nobs=nobs+int(counts(i)) end do it=0 lrts=-1.0D0 do while (irupt == 0) it=it+1 oldx2=lrts call inicov(nter, ncov, r) do i=1, ncells pos=(i-1)*totpars do j=1, npars pos=pos+1 x(j)=dble(model(pos)) end do x(nter)=eta(i) call givenc(r, ncov, nter, x, wt(i), ifail) end do call alias(r, ncov, nter, 1.0d-15, x, ifail) call bsub(r, ncov, nter, b, npars, ifail) lrts=0.0d0 do i=1, ncells pred=0.0d0 pos=(i-1)*totpars do j=1,npars pos=pos+1 pred=pred+b(j)*model(pos) end do pred=exp(pred+offset(i)) obs=counts(i) eta(i)=log(pred)-offset(i)+(obs-pred)/pred if (obs > eps .and. pred > eps) lrts=lrts+obs*log(obs/pred) wt(i)=1.0d0/pred end do if (it > 50 .or. abs(lrts-oldx2) < delta) exit end do lrts=lrts+lrts call alias(r, ncov, nter, 1.0d-15, x, ifail) call bsub(r, ncov, nter, b, npars, ifail) call var(r, ncov, cov, ncov, nter, nobs, 2, ifail) if (ifail /= 0) then write(outstr,'(a)') & 'NOTE : Identifiability problem in variance-covariance matrix for betas.' end if end subroutine loglin ! ! Use AS164 and EM algorithm to fit a log-linear model to incomplete ! tables ! subroutine emllm(ncells, nfull, totpars, npars, counts, scatter, model, & ex, oldex, full, offset, b, cov, lrts, plevel) use interrupt use outstream integer, intent(in) :: ncells integer, intent(in) :: nfull integer, intent(in) :: totpars integer, intent(in) :: npars ! counts = observed contingency table (length ncells) double precision, dimension(:), intent(inout) :: counts ! scatter = scatter matrix connecting observed and full contingency table integer, dimension(:), intent(inout) :: scatter ! model = design matrix (length nfull x totpars) double precision, dimension(:), intent(inout) :: model ! ex = expected values for contingency table iteration i double precision, dimension(:), intent(inout) :: ex ! oldex = expected values for contingency table iteration i-1 double precision, dimension(:), intent(inout) :: oldex ! full = expected values for full (unobserved) contingency table (length nfull) double precision, dimension(:), intent(inout) :: full ! offset = offset for full (length nfull) double precision, dimension(:), intent(inout) :: offset ! loglinear model parameters double precision, dimension(:), intent(inout) :: b double precision, dimension(:), intent(inout) :: cov double precision, intent(out) :: lrts integer, intent(in) :: plevel ! local variables double precision, parameter :: eps=1.0d-8 integer :: i, it, j, pos logical fin interface subroutine loglin(ncells, totpars, npars, counts, model, offset, b, cov, lrts) integer, intent(in) :: ncells integer, intent(in) :: totpars integer, intent(in) :: npars double precision, dimension(:), intent(inout) :: counts double precision, dimension(:), intent(inout) :: model double precision, dimension(:), intent(inout) :: offset double precision, dimension(:) :: b double precision, dimension(:) :: cov double precision :: lrts end subroutine loglin end interface it=0 do i=1, nfull full(i)=1.0d0 end do do i=1, ncells oldex(i)=-1e6 end do ! ! EM loop ! do while (irupt == 0) it=it+1 do j=1, ncells ex(j)=0.0d0 end do do i=1, nfull ex(scatter(i))=ex(scatter(i))+full(i) end do ! check convergence ! breaking if all differences <= EPS fin=.true. do j=1, ncells if (abs(dble(ex(j))-dble(oldex(j))) > eps .and. it < 200) then fin=.false. exit end if end do if (fin) exit ! else maximize likelihood do j=1, ncells oldex(j)=ex(j) end do do i=1, nfull full(i)=dble(full(i))* dble(counts(scatter(i)))/dble(ex(scatter(i))) end do call loglin(nfull, totpars, npars, full, model, offset, b, cov, lrts) ! calculate expected values do i=1, nfull full(i)=0.0d0 pos=(i-1)*totpars do j=1, npars pos=pos+1 full(i)=full(i)+b(j)*model(pos) end do full(i)=exp(full(i)+offset(i)) end do end do ! calculate LRTS for observed table lrts=0.0d0 do i=1, ncells if (counts(i) > eps .and. ex(i) > eps) then lrts=lrts+counts(i)*log(counts(i)/ex(i)) end if end do lrts=lrts+lrts ! print details if (plevel > 2) then write(outstr,'(/a,i3,a/a)') 'After ', it, ' EM iterations', & ' Obs Scatter Exp Offset Design matrix' pos=0 do i=1, ncells write(outstr,'(f6.0,i6,1x,f6.1,2x,f6.3,1x,(20f3.0):)') & counts(i), scatter(i), full(i), offset(i), model(pos+1:pos+totpars) pos=pos+totpars end do do i=ncells+1, nfull write(outstr,'(6x,i6,1x,f6.1,2x,f6.3,1x,(20f3.0):)') & scatter(i),full(i),offset(i), model(pos+1:pos+totpars) pos=pos+totpars end do end if end subroutine emllm ! ! Appropriate design matrix for factor ! subroutine gl(nr, nc, design, sta, levels, reps, droplev) use outstream integer, intent(in) :: nr ! rows of design matrix integer, intent(in) :: nc ! cols of design matrix double precision, dimension(:), intent(inout) :: design integer, intent(in) :: sta ! first col integer, intent(in) :: levels ! number of cols integer, intent(in) :: reps ! repeats per level logical, intent(in) :: droplev ! drop first column ! local variables integer :: i, ilev, ilevels, nlev, tot i=sta ilevels=levels if (droplev) then ilevels=ilevels-1 i=i+reps*nc end if if (ilevels > (nc-sta+1)) then write(outstr,'(a)') 'ERROR: too many levels of factor!' write(outstr,*) ' nr=', nr,' nc=', nc,' sta=', sta, & ' levels=', levels,' reps=', reps return end if nlev=0 ilev=1 tot=nr*nc do while (i <= tot) design(i)=design(i)+1.0d0 nlev=nlev+1 i=i+nc if (nlev >= reps) then nlev=0 ilev=ilev+1 if (ilev > ilevels) then ilev=1 i=i-ilevels if (droplev) i=i+reps*nc end if i=i+1 end if end do end subroutine gl ! ! AS162 - Conditional logistic regression. Converted to Fortran 95 ! subroutine logccs(nstrata, nobs, nv, nv1, ivar, nca, nct, z, & b, cov, chi2, st, ifault, plevel) use combinatorics ! #if SUN use, intrinsic :: ieee_arithmetic use, intrinsic :: ieee_exceptions #endif implicit none integer, intent(in) :: nstrata, nobs, nv, nv1 integer, dimension(nv), intent(in) :: ivar integer, dimension(nstrata), intent(in) :: nca, nct double precision, dimension(nobs, nv), intent(in) :: z double precision, dimension(nv) :: b double precision, dimension(nv1) :: cov ! LRTS and score test double precision, intent(out) :: chi2, st integer, intent(out) :: ifault integer, intent(in) :: plevel ! Work arrays integer, dimension(nobs+2) :: iw integer, dimension(nstrata) :: is double precision, dimension(nv) :: dl, w, ww double precision, dimension(nv1) :: covi integer :: i, i1, i2, im, im1i, ips, ips1i, its, iz, j, j1, ji, jj, k, kk, l, m, n, maxit, nmax2 logical :: ifg, id double precision :: bk, den, logdet, x, xx, sx, wk, zc, rlik, rliks, rlikp, eps data maxit /100/, eps /1.0d-9/ ! ! initial settings ! nmax2=nobs+2 rlikp=1.0d0 ifault=0 do i=1, nv b(i)=0.0d0 end do is(1)=0 do j=2,nstrata j1=j-1 is(j)=is(j1)+nca(j1)+nct(j1) end do ! ! start of main loop ! its=0 main: do its=its+1 if (its > maxit) then ifault=1 exit end if rlik=0.0d0 k=0 do j=1, nv dl(j)=0.0d0 do jj=1, j k=k+1 covi(k)=0.0d0 end do end do ! ! loops thru strata ! sloop: do i=1, nstrata if (nca(i)*nct(i) == 0) cycle sloop ifg=.false. sx=0.0d0 k=0 do j=1, nv w(j)=0.0d0 ww(j)=0.0d0 do jj=1, j k=k+1 cov(k)=0.0d0 end do end do m=nca(i) n=m+nct(i) xx=1.0d0 x=0.0d0 iw(1)=n+1 iw(n+2)=-2 kk=nct(i)+1 do j=2, kk iw(j)=0 end do do j=1, m jj=kk+j iw(jj)=j end do ! ! numerator of terms of likelihood ! do k=1, nv l=ivar(k) bk=b(k) wk=0.0d0 do j=1, m ji=is(i)+j wk=wk+z(ji,l) x=x+bk*z(ji,l) end do w(k)=wk end do id=.false. ! ! enumerate all combinations to calc denominator ! of likelihood. Start of loop. ! comb: do xx=exp(x) sx=sx+xx if (.not.ifg) then rlik=rlik+log(sx) do k=1, nv dl(k)=dl(k)+w(k) end do ifg=.true. end if l=0 do k=1, nv ww(k)=ww(k)+xx*w(k) do kk=1, k l=l+1 cov(l)=cov(l)+xx*w(k)*w(kk) end do end do call twidl(ips,im,iz,id,iw,nmax2) if (id) exit ! ! twidl only alters one element at a time so contribution of ! succeeding combinations evaluated easily ! ips1i=is(i)+n-ips+1 im1i=is(i)+n-im+1 do k=1, nv l=ivar(k) zc=z(ips1i,l)-z(im1i,l) w(k)=w(k)+zc x=x+b(k)*zc end do end do comb rlik=rlik-log(sx) l=0 do j=1, nv dl(j)=dl(j)-ww(j)/sx do k=1, j l=l+1 ! write(*,*) 'COVI: ', j, k, covi(l), (sx*cov(l)-ww(j)*ww(k))/sx**2, cov(l), ww(j), ww(k), sx ! write(*,*) ' : ', sx*cov(l), ww(j)*ww(k), sx**2, (sx*cov(l)-ww(j)*ww(k)), (sx*cov(l)-ww(j)*ww(k))/(sx**2) den=sx*sx covi(l)=covi(l)+(sx*cov(l)-ww(j)*ww(k))/den #if SUN if (ieee_is_nan(covi(l))) then #else if (isnan(covi(l))) then #endif ifault=3 b=0.0d0 cov=0.0d0 chi2=0.0d0 if (plevel > 1) then write(*,'(a,i0,a)') & 'NOTE: Error evaluating likelihood at iteration ', its, '.' end if return end if ! write(*,*) 'COVI= ', covi(l) end do end do end do sloop ! if (its == 1) rliks=rlik call syminv(covi, nv, cov, logdet, ifault) if (ifault /= 0) then if (plevel > 1) then write(*,'(a,i0,a,i0,a)') & 'NOTE: Problem inverting covariance matrix. DGEFA info=', & ifault, ' at iteration ', its, '.' end if call geninv(covi, nv, cov, logdet, i, ifault) end if ! ! Calc new parameter estimates ! do i=1, nv w(i)=0.0d0 i2=i*(i-1)/2 do j=1, i k=i2+j w(i)=w(i)+dl(j)*cov(k) end do i1=i+1 if (i1 > nv) cycle do k=i1, nv j=k*(k-1)/2+i w(i)=w(i)+dl(k)*cov(j) end do end do do i=1, nv b(i)=b(i)+w(i) end do ! ! Calculate score test ! if (its == 1) then st=0.0d0 do i=1, nv st=st+w(i)*dl(i) end do end if ! ! check for convergence ! rlik=rlik-rliks if (abs(rlikp-rlik) <= eps) exit main rlikp=rlik if (plevel > 1) then write(*,'(a,i3,a,f14.6)') & ' Iteration ',its,' LLik=',rliks+rlik end if end do main chi2=rlik+rlik end subroutine logccs ! ! Binary trait prevalences and recurrence risks. ! subroutine segrat(locnam, trait, dataset) use outstream use ped_class implicit none character (len=*), intent(in) :: locnam integer, intent(in) :: trait type (ped_data) :: dataset ! integer, parameter :: KNOWN=0, MISS=-9999 integer :: i, j, pedoffset, ped, pos, sta, currf, currm integer, dimension(6) :: aff, den double precision, dimension(6) :: segr integer, dimension(3) :: mat integer :: matyp, naff, nmiss, nmissf, nsib integer :: sscon, ssdis, hscon, hsdis, gpcon, gpdis, pocon, podis integer :: mzcon, mzdis double precision :: ssrec, hsrec, mzrec, porec, gprec, marrec double precision :: prev, sstet, hstet, mztet, potet, gptet, martet double precision :: sstet_ll, hstet_ll, mztet_ll, potet_ll, gptet_ll, martet_ll double precision :: sstet_ul, hstet_ul, mztet_ul, potet_ul, gptet_ul, martet_ul logical :: ismzpair, last, sibshp gpcon=0 gpdis=0 gprec=0.0d0 gptet=0.0d0 hscon=0 hsdis=0 hsrec=0.0d0 hstet=0.0d0 marrec=0.0d0 martet=0.0d0 mzcon=0 mzdis=0 mzrec=0.0d0 mztet=0.0d0 naff=0 nmiss=0 nmissf=0 nsib=0 pocon=0 podis=0 porec=0.0d0 potet=0.0d0 sscon=0 ssdis=0 ssrec=0.0d0 sstet=0.0d0 mat(1)=0 mat(2)=0 mat(3)=0 do i=1, 6 aff(i)=0 den(i)=0 segr(i)=0.0d0 end do do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) if (dataset%plocus(i,trait) /= 1 .and. dataset%plocus(i,trait) /= 2) then nmiss=nmiss+1 if (i <= pedoffset+dataset%nfound(ped)) nmissf=nmissf+1 else den(4)=den(4)+1 if (dataset%plocus(i,trait) == 2) aff(4)=aff(4)+1 if (i <= pedoffset+dataset%nfound(ped)) then den(5)=den(5)+1 if (dataset%plocus(i,trait) == 2) aff(5)=aff(5)+1 else den(6)=den(6)+1 if (dataset%plocus(i,trait) == 2) aff(6)=aff(6)+1 end if do j=max(pedoffset+dataset%nfound(ped)+1, i+1), dataset%num(ped) if (dataset%plocus(j,trait) == 1 .or. dataset%plocus(j,trait) == 2) then if ((dataset%fa(j) == i .or. dataset%mo(j) == i) .or. & (i > pedoffset+dataset%nfound(ped) .and. & (dataset%fa(i) == j .or. dataset%mo(i) == j))) then if (dataset%plocus(i,trait) == 2 .and. & dataset%plocus(j,trait) == 2) then pocon=pocon+1 else if (dataset%plocus(i,trait) /= dataset%plocus(j,trait)) then podis=podis+1 end if else if ((dataset%fa(j) > pedoffset+dataset%nfound(ped) .and. & (dataset%fa(dataset%fa(j)) == i .or. & dataset%mo(dataset%fa(j)) == i)) .or. & (dataset%mo(j) > pedoffset+dataset%nfound(ped) .and. & (dataset%fa(dataset%mo(j)) == i .or. & dataset%mo(dataset%mo(j)) == i))) then if (dataset%plocus(i,trait) == 2 .and. & dataset%plocus(j,trait) == 2) then gpcon=gpcon+1 else if (dataset%plocus(i,trait) /= dataset%plocus(j,trait)) then gpdis=gpdis+1 end if else if (i > pedoffset+dataset%nfound(ped)) then if (dataset%fa(i) == dataset%fa(j) .and. & dataset%mo(i) == dataset%mo(j)) then if (dataset%plocus(i,trait) == 2 .and. & dataset%plocus(j,trait) == 2) then if (ismzpair(i, j, dataset)) then mzcon=mzcon+1 else sscon=sscon+1 end if else if (dataset%plocus(i,trait) /= dataset%plocus(j,trait)) then if (ismzpair(i, j, dataset)) then mzdis=mzdis+1 else ssdis=ssdis+1 end if end if else if (dataset%fa(i) == dataset%fa(j) .or. & dataset%mo(i) == dataset%mo(j)) then if (dataset%plocus(i,trait) == 2 .and. & dataset%plocus(j,trait) == 2) then hscon=hscon+1 else if (dataset%plocus(i,trait) /= dataset%plocus(j,trait)) then hsdis=hsdis+1 end if else if ((dataset%fa(i) > pedoffset+dataset%nfound(ped) .and. & (dataset%fa(dataset%fa(i)) == j .or. & dataset%mo(dataset%fa(i)) == j)) .or. & (dataset%mo(i) > pedoffset+dataset%nfound(ped) .and. & (dataset%fa(dataset%mo(i)) == j .or. & dataset%mo(dataset%mo(i)) == j))) then if (dataset%plocus(i,trait) == 2 .and. & dataset%plocus(j,trait) == 2) then gpcon=gpcon+1 else if (dataset%plocus(i,trait) /= dataset%plocus(j,trait)) then gpdis=gpdis+1 end if end if end if end if end do end if end do ! ! If any nonfounders, do segregation ratios ! if (pedoffset+dataset%nfound(ped) < dataset%num(ped)) then pos=pedoffset+dataset%nfound(ped)+1 sta=pos currf=dataset%fa(sta) currm=dataset%mo(sta) last=.false. sibshp=.false. ! through sibship by sibship do if (pos > dataset%num(ped)) then last=.true. sibshp=.true. else if (currf /= dataset%fa(pos) .or. currm /= dataset%mo(pos)) then sibshp=.true. end if if (sibshp .and. dataset%plocus(currf,trait) /= MISS .and. & dataset%plocus(currm,trait) /= MISS) then matyp=1 if (dataset%plocus(currf,trait) == 2) matyp=matyp+1 if (dataset%plocus(currm,trait) == 2) matyp=matyp+1 mat(matyp)=mat(matyp)+1 do i=sta,pos-1 if (dataset%plocus(i,trait) /= MISS) then nsib=nsib+1 den(matyp)=den(matyp)+1 end if if (dataset%plocus(i,trait) == 2) then aff(matyp)=aff(matyp)+1 naff=naff+1 end if end do end if ! exit if last sibship if (last) exit ! else move to next sibship if appropriate and iter if (sibshp) then sibshp=.false. sta=pos currf=dataset%fa(sta) currm=dataset%mo(sta) end if pos=pos+1 end do end if ! ! end of segregation ratio loop end if end do ! last pedigree -- write output write(outstr,'(/a/a,a10,a/a/)') & '------------------------------------------------', & 'Segregation ratios for trait "',locnam,'"', & '------------------------------------------------' do i=1,6 if (den(i) > 0) segr(i)=dble(aff(i))/dble(den(i)) end do prev=segr(4) write(outstr,'(a/a)') & 'Total sample All Fndrs Nonfndrs', & '--------------------------------------------------------' write(outstr,'(3x,a8,3(1x,i6,a1,i7)/3x,a8,3(10x,f5.3)/3x,a8,3i15)') & 'Aff/Tot ', aff(4),'/',den(4), aff(5),'/',den(5), aff(6),'/',den(6), & 'Prop Aff',segr(4), segr(5), segr(6), & 'Missing ',nmiss, nmissf, nmiss-nmissf write(outstr,'(/a/a)') & 'Mating Type UxU UxA AxA', & '--------------------------------------------------------' write(outstr,'(3x,a8,3i15/3x,a8,3(1x,i6,a1,i7)/3x,a8,3(10x,f5.3))') & 'Matings ', mat(1), mat(2), mat(3), & 'Aff/Tot ', aff(1),'/',den(1), aff(2),'/',den(2), aff(3),'/',den(3), & 'Prop Aff',segr(1), segr(2), segr(3) write(outstr,'(/a/a)') & 'Relative pair RecRisk Aff-Aff Aff-UnA Tetrachoric r naive 95%CI ', & '------------------------------------------------ ------------- ---------------' if ((pocon+podis) > 0) then porec=dble(2*pocon)/dble(2*pocon+podis) call tetcor_tab(pocon, podis, prev, potet, potet_ll, potet_ul) end if if ((mzcon+mzdis) > 0) then mzrec=dble(2*mzcon)/dble(2*mzcon+mzdis) call tetcor_tab(mzcon, mzdis, prev, mztet, mztet_ll, mztet_ul) end if if ((sscon+ssdis) > 0) then ssrec=dble(2*sscon)/dble(2*sscon+ssdis) call tetcor_tab(sscon, ssdis, prev, sstet, sstet_ll, sstet_ul) end if if ((hscon+hsdis) > 0) then hsrec=dble(2*hscon)/dble(2*hscon+hsdis) call tetcor_tab(hscon, hsdis, prev, hstet, hstet_ll, hstet_ul) end if if ((gpcon+gpdis) > 0) then gprec=dble(2*gpcon)/dble(2*gpcon+gpdis) call tetcor_tab(gpcon, gpdis, prev, gptet, gptet_ll, gptet_ul) end if if ((mat(2)+mat(3)) > 0) then marrec=dble(2*mat(3))/dble(2*mat(3)+mat(2)) call tetcor_tab(mat(3), mat(2), prev, martet, martet_ll, martet_ul) end if write(outstr,'((3x,a,7x,f5.3,6x,i6,6x,i7,7x,f6.3,2x,f6.3,a,f6.3))') & 'Marital ',marrec, mat(3), mat(2), martet, martet_ll, ' -- ', martet_ul, & 'Gparent ', gprec, gpcon, gpdis, gptet, gptet_ll, ' -- ', gptet_ul, & 'Halfsib ', hsrec, hscon, hsdis, hstet, hstet_ll, ' -- ', hstet_ul, & 'Par-Off ', porec, pocon, podis, potet, potet_ll, ' -- ', potet_ul, & 'Fullsib ', ssrec, sscon, ssdis, sstet, sstet_ll, ' -- ', sstet_ul, & 'MZ twin ', mzrec, mzcon, mzdis, mztet, mztet_ll, ' -- ', mztet_ul end subroutine segrat ! ! Familial association for categorical or ordinal trait ! subroutine catseg(typ, trait, dataset, jdraw, iter, plevel) use outstream use interrupt use locus_data use ped_class use relpair_classes use contingency_table use rngs use categorical_data implicit none integer, intent(in) :: typ integer, intent(in) :: trait type (ped_data) :: dataset integer, intent(in) :: jdraw integer, intent(in) :: iter integer, intent(in) :: plevel ! integer, parameter :: KNOWN=0, MISS=-9999 integer, dimension(NCLASS) :: jnpairs, npairs double precision, dimension(NCLASS) :: kappa, jkappa, jcov, jsecov integer :: astat, i, j, js, k, n, pedoffset, ped, pos, sta, & tpos, currf, currm integer, dimension(3) :: mat integer :: econ, ncon, nmiss, nobserved double precision, dimension(1) :: val character (len=7) :: cpairs ! trait tabulation integer :: traitlevels type (table_data) :: traittable integer, dimension(:,:,:), allocatable :: crosstables, jcrosstables integer, dimension(:), allocatable :: rowtot, coltot character (len=14) :: cval ! jackknife logical :: dojack integer :: drawsize, ndraws integer, dimension(dataset%nobs) :: obs_indx integer, parameter :: MAXDRAWSIZE = 100 integer, dimension(MAXDRAWSIZE) :: chosen double precision :: weight ! functions logical :: ismzpair npairs=0 kappa=0.0d0 jnpairs=0 jkappa=0.0d0 jcov=0.0d0 jsecov=0.0d0 nobserved=0 tpos=locpos(trait) call setup_table(1, 30, traittable) dataset%untyped=.false. do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) if (dataset%plocus(i,tpos) /= MISS) then nobserved=nobserved+1 obs_indx(nobserved)=i val(1)=dataset%plocus(i,tpos) call insert_table(1, val, traittable, 1) else nmiss=nmiss+1 dataset%untyped(i)=.true. end if end do end if end do traitlevels=traittable%ncells ! ! allocate work arrays ! allocate(crosstables(NCLASS,traitlevels,traitlevels), & jcrosstables(NCLASS,traitlevels,traitlevels), stat=astat) if (astat /= 0) then write(outstr,'(a/7x,a,i0,a)') & 'ERROR: Unable to allocate memory to analyze familial correlations', & 'for a categorical variable with ', traitlevels, ' levels.' return end if call famcatass(typ, tpos, traitlevels, traittable, dataset, & npairs, crosstables, kappa) ! Jackknife dojack=jack_useful(npairs, iter, plevel) if (dojack) then if (jdraw == MISS) then drawsize=min(10, nobserved/10) else drawsize=jdraw end if if (drawsize < 1) drawsize=1 if (drawsize > MAXDRAWSIZE) drawsize=MAXDRAWSIZE ndraws=0 do js=1, iter ndraws=ndraws+1 if (plevel > 2) then write(outstr,'(a,i0)') 'Jackknife draw ', js end if do j=1, drawsize chosen(j)=irandom(1,nobserved) dataset%untyped(obs_indx(chosen(j)))=.true. end do call famcatass(typ, tpos, traitlevels, traittable, dataset, & jnpairs, jcrosstables, jkappa) do j=1, drawsize dataset%untyped(obs_indx(chosen(j)))=.false. end do do k=1, NCLASS call moment(js, jkappa(k), jcov(k), jsecov(k)) end do if (irupt /= 0) exit end do weight=(dble(nobserved)-dble(drawsize))/dble(drawsize)/dble(ndraws) do k=1, NCLASS jsecov(k)=sqrt(weight*jsecov(k)) end do end if ! write output if (plevel < 2) then write(outstr,'(/a/3a/a/)') & '--------------------------------------------------------', & 'Summary statistics for trait "',trim(loc(trait)),'"', & '--------------------------------------------------------' else write(outstr,'(/a/3a/a/)') & '-----------------------------------------------------------', & 'Relative pair crosstabulations for trait "',trim(loc(trait)),'"', & '-----------------------------------------------------------' end if ! Overall tabulation weight=1.0d0/dble(nobserved) write(outstr,'(a)',advance='no') repeat(' ',14) do i=1, traitlevels pos=traittable%idx(i) call wrtrait(traittable%categories(pos,1)%rvalue, cval, & loctyp(trait), get_notes(loc(trait), locnotes(trait)), 9, 4) write(outstr,'(a)',advance='no') adjustr(cval) end do write(outstr,'(/a14)', advance='no') 'Count' do i=1, traitlevels write(outstr,'(i14)', advance='no') traittable%icount(traittable%idx(i)) end do write(outstr,'(/a14)', advance='no') 'Proportion' do i=1, traitlevels write(outstr,'(8x,f6.4)', advance='no') weight*dble(traittable%icount(traittable%idx(i))) end do write(outstr,*) write(outstr,*) ! kappa or polychoric correlation if (plevel < 2) then if (typ == 1) then write(outstr,'(a/a/a)') & '--- Familial kappa correlations (pairwise) ----', & 'Rel 1 Rel 2 Kappa N Pairs Jack K JSE', & '-----------------------------------------------' else write(outstr,'(a/a/a)') & '- Familial polychoric correlations (pairwise) -', & 'Rel 1 Rel 2 r N Pairs Jack r JSE', & '-----------------------------------------------' end if do k=1, NCLASS if (npairs(k) > 0) then call wrint(npairs(k), cpairs) write(outstr,'(a,1x,f7.4,2x,a7,1x,f7.4,1x,f7.4)') & relclass(k), kappa(k), cpairs, jkappa(k), jsecov(k) end if end do write(outstr,'(26x,a/26x,i0)') '------', sum(npairs) if (.not.dojack) then write(outstr,'(/a,2(/7x,a))') & 'NOTE: Jackknife SEs not calculated since large number of pairs.', & 'Set plevel to 1 or higher to force calculation,', & 'and consider decreasing iterations.' else write(outstr,'(2(/a,i0))') & 'Jackknife random subsample = delete-', drawsize, & 'Number of samples = ', ndraws end if else do k=1, NCLASS if (npairs(k) > 0) then if (typ == 1) then write(outstr,'(2a,i0,2(a,f5.3),a)') & relclass(k), ' (', npairs(k), ' pairs) Cohen''s Kappa=', & kappa(k), ' (JSE=', jsecov(k), ')' else write(outstr,'(2a,i0,2(a,f5.3),a)') & relclass(k), ' (', npairs(k), ' pairs) polychoric r =', & kappa(k), ' (JSE=', jsecov(k), ')' end if write(outstr,'(a)',advance='no') repeat(' ',14) do i=1, traitlevels pos=traittable%idx(i) call wrtrait(traittable%categories(pos,1)%rvalue, cval, & loctyp(trait), get_notes(loc(trait), locnotes(trait)), 9, 4) write(outstr,'(a)',advance='no') adjustr(cval) end do write(outstr,*) do i=1, traitlevels pos=traittable%idx(i) call wrtrait(traittable%categories(pos,1)%rvalue, cval, & loctyp(trait), get_notes(loc(trait), locnotes(trait)), 9, 4) write(outstr,'(a)',advance='no') cval if (exchangeable(k)) then write(outstr,'(10f14.1:)') 0.5d0*dble(crosstables(k, i, 1:traitlevels)) else write(outstr,'(10i14:)') crosstables(k, i, 1:traitlevels) end if end do write(outstr,*) end if end do end if if (typ == 2) then call wlscor(kappa, npairs, jsecov) end if end subroutine catseg ! ! Pairwise familial Cohen Kappa (typ=1) or polychoric correlation (typ=2) ! subroutine famcatass(typ, trait, traitlevels, traittable, dataset, & npairs, crosstables, corstat) use ped_class use contingency_table implicit none integer, parameter :: KNOWN=0, MISS=-9999 integer, parameter :: NCLASS=19 integer, parameter :: REL_MAR=1, REL_GRAND=2, REL_HALF=3, & REL_PO=4, REL_FS=5, REL_MZ=6, REL_FASO=7, & REL_FADA=8, REL_MOSO=9, REL_MODA=10, & REL_BROBRO=11, REL_SISSIS=12, REL_BROSIS=13, & REL_MZM=14, REL_MZF=15, REL_COZ=16, REL_DCOZ=17, & REL_AVUNC=18, REL_ALL=19 integer, intent(in) :: typ integer, intent(in) :: trait integer, intent(in) :: traitlevels type (table_data), intent(in) :: traittable type (ped_data) :: dataset integer, dimension(NCLASS), intent(out) :: npairs integer, dimension(NCLASS,traitlevels, traitlevels), intent(out) :: crosstables double precision, dimension(NCLASS), intent(out) :: corstat(NCLASS) ! integer, dimension(traitlevels) :: rowtot, coltot integer, dimension(2) :: tabshape integer :: i, j, k, n, pedoffset, ped, pos, sta, currf, currm, nships, nsibs integer :: econ, ncon, x1, x2 logical :: last, sibshp character (len=12) :: midpar double precision :: dtot, t1, t2 ! nuclear family IDs integer, dimension(dataset%maxact) :: nucfam integer :: avunc, ego, f1, f2, m1, m2, nfam, parsibs ! functions logical :: ismzpair interface subroutine polycor(nr, nc, tab, polyr, assocX2, modelX2) use outstream use statfuns use brent_mft integer, intent(in) :: nr, nc integer, dimension(nr,nc), intent(in) :: tab double precision, intent(out) :: polyr double precision, intent(out) :: assocX2, modelX2 end subroutine polycor end interface crosstables=0 corstat=0.0d0 npairs=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) if (.not.dataset%untyped(i)) then x1=findlev(dataset%plocus(i,trait), traittable) do j=max(pedoffset+dataset%nfound(ped)+1,i+1), dataset%num(ped) if (.not.dataset%untyped(j)) then x2=findlev(dataset%plocus(j,trait), traittable) crosstables(REL_ALL, x1, x2) = crosstables(REL_ALL, x1, x2)+1 crosstables(REL_ALL, x2, x1) = crosstables(REL_ALL, x2, x1)+1 end if end do do j=max(pedoffset+dataset%nfound(ped)+1,i+1), dataset%num(ped) if (.not.dataset%untyped(j)) then x2=findlev(dataset%plocus(j,trait), traittable) if (dataset%fa(j) == i .or. dataset%mo(j) == i) then crosstables(REL_PO, x1, x2) = crosstables(REL_PO, x1, x2)+1 if (dataset%sex(i) == 1 .and. dataset%sex(j) == 1) then crosstables(REL_FASO, x1, x2) = crosstables(REL_FASO, x1, x2)+1 else if (dataset%sex(i) == 1 .and. dataset%sex(j) == 2) then crosstables(REL_FADA, x1, x2) = crosstables(REL_FADA, x1, x2)+1 else if (dataset%sex(i) == 2 .and. dataset%sex(j) == 1) then crosstables(REL_MOSO, x1, x2) = crosstables(REL_MOSO, x1, x2)+1 else if (dataset%sex(i) == 2 .and. dataset%sex(j) == 2) then crosstables(REL_MODA, x1, x2) = crosstables(REL_MODA, x1, x2)+1 end if else if ((dataset%fa(j) > pedoffset+dataset%nfound(ped) .and. & (dataset%fa(dataset%fa(j)) == i .or. & dataset%mo(dataset%fa(j)) == i)) .or. & (dataset%mo(j) > pedoffset+dataset%nfound(ped) .and. & (dataset%fa(dataset%mo(j)) == i .or. & dataset%mo(dataset%mo(j)) == i))) then crosstables(REL_GRAND, x1, x2) = crosstables(REL_GRAND, x1, x2)+1 else if (i > pedoffset+dataset%nfound(ped)) then if (dataset%fa(i) == j .or. dataset%mo(i) == j) then crosstables(REL_PO, x1, x2) = crosstables(REL_PO, x1, x2)+1 if (dataset%sex(i) == 1 .and. dataset%sex(j) == 1) then crosstables(REL_FASO, x1, x2) = crosstables(REL_FASO, x1, x2)+1 else if (dataset%sex(i) == 2 .and. dataset%sex(j) == 1) then crosstables(REL_FADA, x1, x2) = crosstables(REL_FADA, x1, x2)+1 else if (dataset%sex(i) == 1 .and. dataset%sex(j) == 2) then crosstables(REL_MOSO, x1, x2) = crosstables(REL_MOSO, x1, x2)+1 else if (dataset%sex(i) == 2 .and. dataset%sex(j) == 2) then crosstables(REL_MODA, x1, x2) = crosstables(REL_MODA, x1, x2)+1 end if else if (dataset%fa(i) == dataset%fa(j) .and. & dataset%mo(i) == dataset%mo(j)) then if (ismzpair(i, j, dataset)) then crosstables(REL_MZ, x1, x2) = crosstables(REL_MZ, x1, x2)+1 crosstables(REL_MZ, x2, x1) = crosstables(REL_MZ, x2, x1)+1 if (dataset%sex(i) == 1) then crosstables(REL_MZM, x1, x2) = crosstables(REL_MZM, x1, x2)+1 crosstables(REL_MZM, x2, x1) = crosstables(REL_MZM, x2, x1)+1 else if (dataset%sex(i) == 2) then crosstables(REL_MZF, x1, x2) = crosstables(REL_MZF, x1, x2)+1 crosstables(REL_MZF, x2, x1) = crosstables(REL_MZF, x2, x1)+1 end if else crosstables(REL_FS, x1, x2) = crosstables(REL_FS, x1, x2)+1 crosstables(REL_FS, x2, x1) = crosstables(REL_FS, x2, x1)+1 if (dataset%sex(i) == 1 .and. dataset%sex(j) == 1) then crosstables(REL_BROBRO, x1, x2) = crosstables(REL_BROBRO, x1, x2)+1 crosstables(REL_BROBRO, x2, x1) = crosstables(REL_BROBRO, x2, x1)+1 else if (dataset%sex(i) == 2 .and. dataset%sex(j) == 2) then crosstables(REL_SISSIS, x1, x2) = crosstables(REL_SISSIS, x1, x2)+1 crosstables(REL_SISSIS, x2, x1) = crosstables(REL_SISSIS, x2, x1)+1 else if ((dataset%sex(i)+dataset%sex(j)) == 3) then crosstables(REL_BROSIS, x1, x2) = crosstables(REL_BROSIS, x1, x2)+1 end if end if else if (dataset%fa(i) == dataset%fa(j) .or. & dataset%mo(i) == dataset%mo(j)) then crosstables(REL_HALF, x1, x2) = crosstables(REL_HALF, x1, x2)+1 crosstables(REL_HALF, x2, x1) = crosstables(REL_HALF, x2, x1)+1 else if ((dataset%fa(i) > pedoffset+dataset%nfound(ped) .and. & (dataset%fa(dataset%fa(i)) == j .or. & dataset%mo(dataset%fa(i)) == j)) .or. & (dataset%mo(i) > pedoffset+dataset%nfound(ped) .and. & (dataset%fa(dataset%mo(i)) == j .or. & dataset%mo(dataset%mo(i)) == j))) then crosstables(REL_GRAND, x2, x1) = crosstables(REL_GRAND, x2, x1)+1 end if end if end if end do end if end do pos=pedoffset+dataset%nfound(ped)+1 if (pos <= dataset%num(ped)) then nfam=0 nucfam=0 sta=pos currf=dataset%fa(sta) currm=dataset%mo(sta) last=.false. sibshp=.false. ! through sibship by sibship do if (pos > dataset%num(ped)) then last=.true. if (dataset%num(ped)-pedoffset > dataset%nfound(ped)) sibshp=.true. else if (currf /= dataset%fa(pos) .or. currm /= dataset%mo(pos)) then sibshp=.true. end if if (sibshp) then ! marital correlation if (.not.dataset%untyped(currf) .and. .not.dataset%untyped(currm)) then x1=findlev(dataset%plocus(currf,trait), traittable) x2=findlev(dataset%plocus(currm,trait), traittable) crosstables(REL_MAR, x1, x2) = crosstables(REL_MAR, x1, x2)+1 end if nfam=nfam+1 do i=sta, pos-1 nucfam(i-pedoffset)=nfam end do end if ! exit if last sibship if (last) exit ! else move to next sibship if appropriate and iter if (sibshp) then sibshp=.false. sta=pos currf=dataset%fa(sta) currm=dataset%mo(sta) end if pos=pos+1 end do ! ! full cousins and avuncular ! do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped)-1 if (.not.dataset%untyped(i)) then ego=nucfam(i-pedoffset) f1=nucfam(dataset%fa(i)-pedoffset) m1=nucfam(dataset%mo(i)-pedoffset) x1=findlev(dataset%plocus(i,trait), traittable) do j=i+1, dataset%num(ped) if (.not.dataset%untyped(j) .and. & nucfam(i-pedoffset) /= nucfam(j-pedoffset)) then parsibs=0 avunc=0 f2=nucfam(dataset%fa(j)-pedoffset) m2=nucfam(dataset%mo(j)-pedoffset) if (f2 /= 0) then if (f1 == f2) then if (dataset%fa(i) /= dataset%fa(j)) parsibs=parsibs+1 end if if (m1 == f2) parsibs=parsibs+1 if (ego == f2 .and. i /= dataset%fa(j)) avunc=avunc+1 end if if (m2 /= 0) then if (f1 == m2) parsibs=parsibs+1 if (m1 == m2) then if (dataset%mo(i) /= dataset%mo(j)) parsibs=parsibs+1 end if if (ego == m2 .and. i /= dataset%mo(j)) avunc=avunc+1 end if if (parsibs == 1) then x2=findlev(dataset%plocus(j,trait), traittable) crosstables(REL_COZ, x1, x2) = crosstables(REL_COZ, x1, x2)+1 crosstables(REL_COZ, x2, x1) = crosstables(REL_COZ, x2, x1)+1 else if (parsibs == 2) then x2=findlev(dataset%plocus(j,trait), traittable) crosstables(REL_DCOZ, x1, x2) = crosstables(REL_DCOZ, x1, x2)+1 crosstables(REL_DCOZ, x2, x1) = crosstables(REL_DCOZ, x2, x1)+1 else if (avunc > 0) then x2=findlev(dataset%plocus(j,trait), traittable) crosstables(REL_AVUNC, x2, x1) = crosstables(REL_AVUNC, x2, x1)+1 end if end if end do end if end do end if end if end do if (typ == 2) then tabshape(1)=traitlevels tabshape(2)=traitlevels do k=1, NCLASS npairs(k)=sum(crosstables(k,:,:)) call polycor(traitlevels, traitlevels, & crosstables(k,:,:), corstat(k), t1, t2) ! reshape(crosstables(k,:,:), tabshape), corstat(k), t1) end do else do k=1, NCLASS n=0 ncon=0 econ=0 rowtot=0 coltot=0 do i=1, traitlevels do j=1, traitlevels n=n+crosstables(k,i,j) rowtot(i)=rowtot(i)+crosstables(k,i,j) coltot(j)=coltot(j)+crosstables(k,i,j) end do ncon=ncon+crosstables(k,i,i) end do do i=1, traitlevels econ=econ+coltot(i)*rowtot(i) end do if (n > 0) then dtot=1.0d0/dble(n) t1=dble(ncon)*dtot t2=dble(econ)*dtot*dtot corstat(k)=(t1-t2)/(1.0d0-t2) end if npairs(k)=n end do end if end subroutine famcatass ! ! Classical twin analysis: binary trait prevalences and recurrence risks ! subroutine twincon(locnam, trait, mztwin, gt, thresh, dataset, plevel) use outstream use ped_class use statfuns implicit none character(len=20), intent(in) :: locnam integer, intent(in) :: trait integer, intent(in) :: mztwin integer, intent(in) :: gt double precision, intent(in) :: thresh type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel ! integer, parameter :: KNOWN=0, MISS=-9999 integer, parameter :: nclass=7 integer :: i, j, pedoffset, ped, pos, sta, currf, currm integer :: idx, npairs, pairstat, x1, x2, zyg logical :: samefa, samemo, hasdz integer, dimension(nclass,3) :: concord integer, dimension(4) :: dzxcon double precision :: asyp, con, hicon, locon, lrts, prev, width character (len=3) :: histo character (len=14), dimension(12) :: zygclass = & (/ 'MZ twins ', 'DZ twins ', 'Sibs (non-MZ) ', & 'MZ Female ', 'MZ Male ', & 'DZ Female ', 'DZ Male ', 'DZ Female-Male', 'Sibs (nontwin)', & 'Sisters ', 'Brothers ', 'Sister-Brother' /) character (len=1), dimension(2) :: yn = (/'n','y'/) ! functions double precision :: isaff character (len=6) :: pstring interface subroutine concest(group, concord, npairs, prev, con, locon, hicon) integer, intent(in) :: group integer, dimension(:,:), intent(in) :: concord integer, intent(out) :: npairs double precision, intent(out) :: con, hicon, locon, prev end subroutine concest end interface do i=1, nclass do j=1, 3 concord(i,j)=0 end do end do dzxcon=0 hasdz=.not.(gt==16 .and. thresh==0.0d0) write(outstr,'(/a/3a/a)') & '------------------------------------------------------------', & 'Classical twin analysis of "', trim(locnam), '"', & '------------------------------------------------------------' if (plevel > 1) then write(outstr,'(a)') & 'Pedigree Person1 Person2 Zyg Traits' end if do ped=1, dataset%nped if (dataset%actset(ped) > 0) then ! only iterate nonfounders do i=dataset%num(ped-1)+dataset%nfound(ped)+1, dataset%num(ped)-1 do j=i+1, dataset%num(ped) samefa=(dataset%fa(i) == dataset%fa(j)) samemo=(dataset%mo(i) == dataset%mo(j)) if (.not.samefa .or. .not.samemo) exit ! ! Share parents and zygosity indicator -- MZ (zyg=1) or DZ (zyg=2) twins ! zyg=2 if (dataset%plocus(i,mztwin) /= MISS .and. & dataset%plocus(i,mztwin)==dataset%plocus(j,mztwin)) then if (int(isaff(dataset%plocus(i,mztwin),thresh,gt)) == 2 .and. & int(isaff(dataset%plocus(j,mztwin),thresh,gt)) == 2) then zyg=1 end if else if (hasdz) then zyg=0 end if if (dataset%plocus(i,trait) /= MISS .and. dataset%plocus(j,trait) /= MISS) then x1=int(dataset%plocus(i,trait)) x2=int(dataset%plocus(j,trait)) pairstat=int(x1)+int(x2)-1 if (zyg==1) then concord(1, pairstat)=concord(1, pairstat)+1 if (dataset%sex(i)==1 .and. dataset%sex(i)==1) then concord(4, pairstat)=concord(4, pairstat)+1 else if (dataset%sex(i)==2 .and. dataset%sex(i)==2) then concord(3, pairstat)=concord(3, pairstat)+1 end if if (plevel > 1) then write(outstr,'(a11,2(1x,a),3x,a,2x,2(1x,a1))') & dataset%pedigree(ped)(1:11), dataset%id(i), dataset%id(j), & 'MZ ', yn(x1), yn(x2) end if else if (zyg==2) then concord(2, pairstat)=concord(2, pairstat)+1 if (dataset%sex(i)==1 .and. dataset%sex(j)==1) then concord(6, pairstat)=concord(6, pairstat)+1 else if (dataset%sex(i)==2 .and. dataset%sex(j)==2) then concord(5, pairstat)=concord(5, pairstat)+1 else if (dataset%sex(i)==1 .and. dataset%sex(j)==2) then idx=2*x2+x1-2 dzxcon(idx)=dzxcon(idx)+1 else if (dataset%sex(i)==2 .and. dataset%sex(j)==1) then idx=2*x1+x2-2 dzxcon(idx)=dzxcon(idx)+1 end if if (plevel > 1) then write(outstr,'(a11,2(1x,a),3x,a,2x,2(1x,a1))') & dataset%pedigree(ped)(1:11), dataset%id(i), dataset%id(j), & 'DZ ', yn(x1), yn(x2) end if else concord(7, pairstat)=concord(7, pairstat)+1 if (plevel > 1) then write(outstr,'(a11,2(1x,a),3x,a,1x,2(1x,a1))') & dataset%pedigree(ped)(1:11), dataset%id(i), dataset%id(j), & 'Sib', yn(x1), yn(x2) end if end if end if end do end do end if end do ! ! Table of correlations ! write(outstr,'(/a/a)') & 'Zygosity Group N Pairs Prevalence Con Dis Recurrence Risk (95%CI)', & '-------------- ------- ------------ ---------- ------------------------' call concest(1, concord, npairs, prev, con, locon, hicon) write(outstr,'(a,i8,f13.4, 1x,i5,1x,i5,3x,f5.3,1x,a,f5.3,a,f5.3,a)') & zygclass(1), npairs, prev, concord(1,3), concord(1,2), & con, '(', locon, ' -- ', hicon, ')' zyg=3 if (hasdz) zyg=zyg-1 call concest(2, concord, npairs, prev, con, locon, hicon) write(outstr,'(a,i8,f13.4, 1x,i5,1x,i5,3x,f5.3,1x,a,f5.3,a,f5.3,a)') & zygclass(zyg), npairs, prev , concord(2,3), concord(2,2), & con, '(', locon, ' -- ', hicon, ')' call concest(7, concord, npairs, prev, con, locon, hicon) if (npairs>0) then write(outstr,'(a,i8,f13.4, 1x,i5,1x,i5,3x,f5.3,1x,a,f5.3,a,f5.3,a)') & zygclass(9), npairs, prev , concord(7,3), concord(7,2), & con, '(', locon, ' -- ', hicon, ')' end if zyg=10 if (hasdz) zyg=6 call concest(3, concord, npairs, prev, con, locon, hicon) write(outstr,'(/a,i8,f13.4, 1x,i5,1x,i5,3x,f5.3,1x,a,f5.3,a,f5.3,a)') & zygclass(4), npairs, prev , concord(3,3), concord(3,2), & con, '(', locon, ' -- ', hicon, ')' call concest(4, concord, npairs, prev, con, locon, hicon) write(outstr,'(a,i8,f13.4, 1x,i5,1x,i5,3x,f5.3,1x,a,f5.3,a,f5.3,a)') & zygclass(5), npairs, prev , concord(4,3), concord(4,2), & con, '(', locon, ' -- ', hicon, ')' call concest(5, concord, npairs, prev, con, locon, hicon) write(outstr,'(a,i8,f13.4, 1x,i5,1x,i5,3x,f5.3,1x,a,f5.3,a,f5.3,a)') & zygclass(zyg), npairs, prev , concord(5,3), concord(5,2), & con, '(', locon, ' -- ', hicon, ')' call concest(6, concord, npairs, prev, con, locon, hicon) write(outstr,'(a,i8,f13.4, 1x,i5,1x,i5,3x,f5.3,1x,a,f5.3,a,f5.3,a)') & zygclass(zyg+1), npairs, prev , concord(6,3), concord(6,2), & con, '(', locon, ' -- ', hicon, ')' npairs=dzxcon(1)+dzxcon(2)+dzxcon(3)+dzxcon(4) prev=dble(dzxcon(4)+dzxcon(3))/dble(max(npairs,1)) call propci(dzxcon(4), dzxcon(3)+dzxcon(4), & 95.0d0, con, locon, hicon) write(outstr,'(a,i8,f13.4,1x,i5,1x,i5,3x,f5.3,1x,a,f5.3,a,f5.3,a)') & zygclass(zyg+2), npairs, prev , dzxcon(4), dzxcon(3), & con, '(', locon, ' -- ', hicon, ')' prev=dble(dzxcon(4)+dzxcon(2))/dble(max(npairs,1)) call propci(dzxcon(4), dzxcon(2)+dzxcon(4), & 95.0d0, con, locon, hicon) write(outstr,'(22x,f13.4,1x,i5,1x,i5,3x,f5.3,1x,a,f5.3,a,f5.3,a)') & prev, dzxcon(4), dzxcon(2), con, '(', locon, ' -- ', hicon, ')' ! ! Table of LRTS tests of homogeneity of concordances ! write(outstr,'(/a/a)') & 'Hypothesis LRTS P-value', & '----------------- ----------- -------' call conchi(concord(3,3), concord(3,2), concord(4,3), concord(4,2), lrts) asyp=chip(lrts,1) call phist(asyp, asyp, histo) write(outstr,'(a,f12.2,4x,a,1x,a)') & 'Pc(MZF) = Pc(MZM)', lrts, pstring(asyp), histo call conchi(concord(5,3), concord(5,2), concord(6,3), concord(6,2), lrts) asyp=chip(lrts,1) call phist(asyp, asyp, histo) write(outstr,'(a,f12.2,4x,a,1x,a)') & 'Pc(DZF) = Pc(DZM)', lrts, pstring(asyp), histo if (hasdz .and. (concord(7,3)+concord(7,2))>0) then call conchi(concord(2,3), concord(2,2), concord(7,3), concord(7,2), lrts) asyp=chip(lrts,1) call phist(asyp, asyp, histo) write(outstr,'(a,f12.2,4x,a,1x,a)') & 'Pc(DZ) = Pc(Sib) ', lrts, pstring(asyp), histo end if call conchi(concord(1,3), concord(1,2), concord(2,3), concord(2,2), lrts) asyp=chip(lrts,1) call phist(asyp, asyp, histo) write(outstr,'(a,f12.2,4x,a,1x,a)') & 'Pc(MZ) = Pc(DZ) ', lrts, pstring(asyp), histo end subroutine twincon ! ! Summary statistics for recurrence risk calculation ! subroutine concest(group, concord, npairs, prev, con, locon, hicon) integer, intent(in) :: group integer, dimension(:,:), intent(in) :: concord integer, intent(out) :: npairs double precision, intent(out) :: con, hicon, locon, prev integer :: ncases double precision :: phat npairs=concord(group,1)+concord(group,2)+concord(group,3) ncases=2*concord(group,3)+concord(group,2) prev=0.0d0 con=0.0d0 locon=0.0d0 hicon=0.0d0 if (npairs>0) then prev=dble(ncases)/dble(npairs+npairs) if (ncases>0) then con=dble(2*concord(group,3))/dble(ncases) call propci(concord(group,3), concord(group,3)+concord(group,2), & 95.0d0, phat, locon, hicon) locon=(locon+locon)/(1.0d0+locon) hicon=(hicon+hicon)/(1.0d0+hicon) end if end if end subroutine concest ! ! LRTS for equality of 2x2 ! subroutine conchi(a, b, c, d, lrts) integer, intent(in) :: a, b, c, d double precision, intent(out) :: lrts integer, dimension(4) :: tble double precision, dimension(4) :: e double precision :: den tble(1)=a tble(2)=b tble(3)=c tble(4)=d den=1.0d0/dble(a+b+c+d) e(1)=den*dble((a+b)*(a+c)) e(2)=den*dble((a+b)*(b+d)) e(3)=den*dble((a+c)*(c+d)) e(4)=den*dble((b+d)*(c+d)) call upchi(4, tble, e, lrts) end subroutine conchi ! ! Test for extrabinomial variation ! subroutine tarone(trait, dataset, plevel) use outstream use ped_class use statfuns implicit none integer, intent(in) :: trait type (ped_data) :: dataset integer, intent(in) :: plevel ! integer, parameter :: MISS=-9999 integer, dimension(dataset%nact, 2) :: afftab integer :: aff, n, i, iped, nmiss, ped, pedoffset, totaff, totnum double precision :: aff2, dev, dn, k, phat, pval, siz2, sum1, sum2 double precision :: chit, chiv, icr, msa, msw ! functions character (len=6) :: pstring if (plevel >= 0) then write(outstr,'(/a/a)') & 'Pedigree Affected (Prop) Total Missing', & '---------- ---------------- -------- -------' end if iped=0 totaff=0 totnum=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) aff=0 n=0 nmiss=0 do i=pedoffset+1, dataset%num(ped) if (dataset%plocus(i,trait) /= MISS) then n=n+1 end if if (dataset%plocus(i,trait) == 2.0d0) then aff=aff+1 end if end do if (plevel >= 0) then write(outstr,'(a10,1x,i6,a,f6.4,a,2i9)') & dataset%pedigree(ped), aff, ' (', dble(aff)/dble(max(1,n)), ') ', & n, dataset%num(ped)-pedoffset-n end if if (n > 0) then iped=iped+1 afftab(iped,1)=aff afftab(iped,2)=n totaff=totaff+aff totnum=totnum+n end if end if end do phat=dble(totaff)/dble(totnum) write(outstr,'(/a,i0/a,i0/a,i0)') & ' Number of pedigrees = ', iped, & ' Number of affecteds = ', totaff, & ' Number observed = ', totnum write(outstr,'(a,f6.4)') & ' Proportion affected = ', phat if (phat > 0.0d0 .and. phat < 1.0d0) then aff2=0.0d0 sum1=0.0d0 sum2=0.0d0 siz2=0.0d0 do ped=1, iped dn=dble(afftab(ped,2)) dev=dble(afftab(ped,1))-dn*phat dev=dev*dev/phat/(1.0d0-phat) sum1=sum1+dev sum2=sum2+dn*(dn-1.0d0) chiv=chiv+dev/dn aff2=aff2+dble(afftab(ped,1)**2)/dn siz2=siz2+dn*dn end do dn=dble(totnum) sum1=sum1-dn chit=sum1*sum1/2/sum2 msa=(aff2-dble(totaff*totaff)/dn)/dble(max(1,iped-1)) msw=(dble(totaff)-aff2)/dble(totnum-iped) k=(dn-siz2/dn)/dble(max(1,iped-1)) icr=(msa-msw)/(msa+(k-1.0d0)*msw) pval=1.0d0 if (iped > 1) pval=chip(chiv, iped-1) write(outstr,'(a,f12.2,a,i4,3a)') & ' Variance Chi-square =', chiv, ' (df=', iped-1, & ', P=', trim(pstring(pval)), ')' pval=chip(chit,1) write(outstr,'(a,f12.2,3a/a,7x,f7.4)') & ' Tarone Score Test =', chit, ' (P=', trim(pstring(pval)), ')' , & 'Intraclass correlation =', icr end if end subroutine tarone ! ! Segregation ratios using Davie 1976 ! subroutine davie(loc1, trait, loc2, proband, dataset, plevel) use outstream use ped_class implicit none character (len=*), intent(in) :: loc1 integer, intent(in) :: trait character (len=*), intent(in) :: loc2 integer, intent(in) :: proband type (ped_data) :: dataset integer, intent(in) :: plevel integer, parameter :: nclass=4, MISS=-9999 integer :: currf, currm, i, matyp, npro, num, pedoffset, ped, pos, sta integer, dimension(nclass) :: j, mat, q, r, t double precision, dimension(nclass) :: phat, se double precision :: den logical :: last, sibshp write(outstr,'(/a/3a/a)') & '---------------------------------------------------', & 'Corrected segregation ratios for trait "', trim(loc1), '"', & '---------------------------------------------------' if (trait == proband) then write(outstr,'(a)') 'NOTE: Assuming complete ascertainment.' else write(outstr,'(3a)') 'NOTE: Proband defined by "', trim(loc2), '".' end if if (plevel > 1) then write(outstr,'(/a,15x,a)') 'Pedigree Parents', 'Faff Maff Npro Naff Tot' end if do i=1, nclass j(i)=0 mat(i)=0 phat(i)=0.0d0 r(i)=0 q(i)=0 t(i)=0 end do do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset if (dataset%nfound(ped) == num) cycle pos=pedoffset+dataset%nfound(ped)+1 sta=pos currf=dataset%fa(sta) currm=dataset%mo(sta) last=.false. sibshp=.false. ! through sibship by sibship do if (pos > dataset%num(ped)) then last=.true. sibshp=.true. else if (currf /= dataset%fa(pos) .or. currm /= dataset%mo(pos)) then sibshp=.true. end if if (sibshp) then npro=0 do i=sta, pos-1 if (dataset%plocus(i,proband) == 2.0d0 .and. & dataset%plocus(i,trait) == 2.0d0) then npro=npro+1 end if end do call davstat(4, pos, sta, npro, trait, dataset, mat, j, q, t, r) if (dataset%plocus(currf,trait) /= MISS .and. & dataset%plocus(currm,trait) /= MISS) then matyp=1 if (dataset%plocus(currf,trait) == 2.0d0) matyp=matyp+1 if (dataset%plocus(currm,trait) == 2.0d0) matyp=matyp+1 call davstat(matyp, pos, sta, npro, trait, dataset, mat, j, q, t, r) end if if (plevel > 1) then call davwri(ped, currf, currm, pos, sta, npro, trait, dataset) end if end if ! exit if last sibship if (last) exit ! else move to next sibship if appropriate and iter if (sibshp) then sibshp=.false. sta=pos currf=dataset%fa(sta) currm=dataset%mo(sta) end if pos=pos+1 end do ! last pedigree -- write output end if end do do i=1, nclass den=dble(t(i)-j(i)) if (den > 0.0d0) then phat(i)=dble(r(i)-j(i))/den se(i)=dble((r(i)-j(i))*(t(i)-r(i)))/den**3.0d0 + & dble(2*q(i)*(t(i)-r(i))**2)/den**4.0d0 se(i)=sqrt(se(i)) else phat(i)=0.0d0 se(i)=0.0d0 end if end do write(outstr,'(/a/a)') & 'Mating Type UxU UxA AxA All', & '-------------------------------------------------------' write(outstr,'(3x,a8,4i11/3x,a8,4(1x,i4,a1,i5),2(/3x,a8,4(6x,f5.3)))') & 'Matings ', mat(1), mat(2), mat(3), mat(4), & 'Aff/Tot ', r(1),'/',t(1), r(2),'/',t(2), r(3),'/',t(3), r(4),'/',t(4), & 'Risk ', phat(1), phat(2), phat(3), phat(4), & 'Std Err ', se(1),se(2),se(3), se(4) end subroutine davie ! ! Accumulate counts needed for Davie formula in current family ! subroutine davstat(typ, pos, sta, npro, trait, dataset, class, j, q, t, r) use ped_class implicit none integer, parameter :: nclass=4, MISS=-9999 integer, intent(in) :: typ integer, intent(in) :: pos integer, intent(in) :: sta integer, intent(in) :: npro integer, intent(in) :: trait type (ped_data) :: dataset integer, intent(inout) :: class(nclass) integer, intent(inout) :: j(nclass) integer, intent(inout) :: q(nclass) integer, intent(inout) :: t(nclass) integer, intent(inout) :: r(nclass) integer :: i class(typ)=class(typ)+1 if (npro == 1) then j(typ)=j(typ)+1 end if if (npro == 2) then q(typ)=q(typ)+1 end if do i=sta, pos-1 if (dataset%plocus(i,trait) /= MISS) then t(typ)=t(typ)+1 end if if (dataset%plocus(i,trait) == 2.0d0) then r(typ)=r(typ)+1 end if end do end subroutine davstat ! ! print prop affected per sibship ! subroutine davwri(ped, currf, currm, pos, sta, npro, trait, dataset) use outstream use ped_class implicit none integer, intent(in) :: ped integer, intent(in) :: currf, currm integer, intent(in) :: pos integer, intent(in) :: sta integer, intent(in) :: npro integer, intent(in) :: trait type (ped_data) :: dataset integer, parameter :: MISS=-9999 integer :: i, na, nt character (len=1) :: af, am na=0 nt=0 call wraff(dataset%plocus(currf,trait), af, 1) call wraff(dataset%plocus(currm,trait), am, 1) do i=sta, pos-1 if (dataset%plocus(i,trait) /= MISS) then nt=nt+1 if (dataset%plocus(i,trait) == 2.0d0) na=na+1 end if end do write(outstr,'(3(a,1x),2(3x,a1,1x),3i5)') & dataset%pedigree(ped), dataset%id(currf), dataset%id(currm), & af, am, npro, na, nt end subroutine davwri ! ! Simple segregation tabulations for a codominant marker ! Phase the genotypes if requested ! ! So either ! Father Mother Child ! ng ng na*na ! ! or ! mating Child ! ng*(ng+1)/2 ng ! subroutine marseg(gene, locnam, typ, dataset, allele_buffer, plevel) use outstream use interrupt use alleles_class use ped_class implicit none integer, intent(in) :: gene character (len=*), intent(in) :: locnam integer, intent(in) :: typ ! 1=phased 2=unphased type (ped_data) :: dataset type (allele_data), intent(inout) :: allele_buffer integer, intent(in) :: plevel ! local variables integer, parameter :: KNOWN=0, MISS=-9999 ! tabulation of matings integer, dimension(:,:), allocatable :: tble ! local variables integer :: inconsist, noffgen, nmatgen, ped, pedoffset, i, j, k integer :: c1, c2, g1, g2, g3, g4, gen2, nobs, posoff, posmat integer :: tr1, tr2, nt1, nt2 character (len=3) :: allel, errmsg character (len=7) :: gtpfa, gtpmo, gtp ! functions integer :: clcpos, getnam write(outstr,'(/a/3a/a/)') & '------------------------------------------------', & 'Segregation data for marker "', trim(locnam), '"', & '------------------------------------------------' if (typ==1) then write(outstr,'(a/)') 'NOTE: Phased genotypes inferred for offspring' end if if (plevel > 1) then write(outstr,'(a)') 'Pedigree ID Offspring Paternal Maternal' end if ! table of genotype counts versus parental genotypes (phased or unphased) if (typ==1) then noffgen=allele_buffer%numal*allele_buffer%numal nmatgen=allele_buffer%numgtp*allele_buffer%numgtp else noffgen=allele_buffer%numgtp nmatgen=noffgen*(noffgen+1)/2 end if allocate(tble(nmatgen, noffgen)) inconsist=0 nobs=0 tble = 0 gen2=gene+1 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) dataset%untyped(i)=.not.observed(i, gene, dataset) end do do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped) if (.not.dataset%untyped(i) .and. & .not.dataset%untyped(dataset%fa(i)) .and. & .not.dataset%untyped(dataset%mo(i))) then nobs=nobs+1 ! mating call get_namedgeno(dataset%fa(i), gene, gen2, dataset, & allele_buffer, g1, g2) call get_namedgeno(dataset%mo(i), gene, gen2, dataset, & allele_buffer, g3, g4) call get_namedgeno(i, gene, gen2, dataset, allele_buffer, c1, c2) if (allele_buffer%xlinkd) g1=1 ! genotype (or allele if parent of origin TDT) if (typ == 1) then posmat=allele_buffer%numgtp*(clcpos(g1,g2)-1)+clcpos(g3,g4) call trans(g1, g2, g3, g4, c1, c2, & tr1, tr2, nt1, nt2, 0) else j=clcpos(g1, g2) k=clcpos(g3, g4) call order(j, k) posmat=allele_buffer%numgtp*(j-1)+k tr1=c1 tr2=c2 end if if (tr1 /= MISS) then posoff=allele_buffer%numal*(tr1-1)+tr2 tble(posmat,posoff)=tble(posmat,posoff)+1 else inconsist=inconsist+1 end if if (plevel > 1) then call wrgtp(g1, g2, gtpfa, '/', '', 1) call wrgtp(g3, g4, gtpmo, '/', '', 1) if (tr1 /= MISS) then call wrgtp(allele_buffer%allele_names(tr1), & allele_buffer%allele_names(tr2), gtp, '/', '', 1) errmsg=' ' else call wrgtp(allele_buffer%allele_names(c1), & allele_buffer%allele_names(c2), gtp, '/', '', 1) errmsg='ERR' end if write(outstr,'(a10,a10,3(1x,a8),1x,a)') & dataset%pedigree(ped), dataset%id(i), gtp, gtpfa, gtpmo, errmsg end if end if end do end if end do if (plevel > 1) then write(outstr,*) end if if (typ==1) then write(outstr, '(a)', advance='no') ' Pat Mat ' do c1=1, allele_buffer%numal do c2=1, allele_buffer%numal call wrgtp(allele_buffer%allele_names(c1), & allele_buffer%allele_names(c2), gtp, '/', '', 1) write(outstr, '(1x,a)', advance='no') gtp end do end do write(outstr,'(/a)', advance='no') '------- ------- ' do i=1, allele_buffer%numal*allele_buffer%numal write(outstr, '(1x,a)', advance='no') '-------' end do write(outstr,*) posmat=0 do g1=1, allele_buffer%numal if (irupt == 0) then do g2=1, g1 call wrgtp(allele_buffer%allele_names(g2), & allele_buffer%allele_names(g1), gtpfa, '/', '', 1) do g3=1, allele_buffer%numal do g4=1, g3 posmat=posmat+1 call wrgtp(allele_buffer%allele_names(g4), & allele_buffer%allele_names(g3), gtpmo, '/', '', 1) write(outstr,'(a7,1x,a7,(50i8):)') gtpfa, gtpmo, tble(posmat,1:noffgen) end do end do end do end if end do end if if (inconsist > 0) then write(outstr,'(/a,i0,a)') & 'NOTE: Encountered ', inconsist, ' Mendelian inconsistencies.' end if deallocate(tble) end subroutine marseg ! ! Simple family based imputation of age/yob/etc ! ego ~ midparent + sibs + spouses + offspring ! subroutine famimp(locnam, trait, dataset, plevel) use outstream use ped_class use AS164 implicit none character (len=*), intent(in) :: locnam integer, intent(in) :: trait type (ped_data) :: dataset integer, intent(in) :: plevel ! integer, parameter :: MISS=-9999 integer, dimension(4) :: nrel double precision, dimension(dataset%nobs, 4) :: impreg ! regressions double precision :: boff(3), bsib(3), bspouse(3), roff(10), rsib(10), rspouse(10), x(5) double precision :: muy, resid, pred, sx, vay integer :: currspouse, i, idx, ifail, j, k, pedoffset, ped, pos, sta integer :: nobs, nimp, noff, nsib, nspouse character (len=1) :: ch if (plevel>1) then write(outstr,*) 'ped id sex ego parent sib spouse offspring n1 n2 n3 n4' end if nimp=0 nobs=0 noff=0 nsib=0 nspouse=0 call inicov(4, 10, roff) call inicov(4, 10, rsib) call inicov(4, 10, rspouse) muy=0.0d0 vay=0.0d0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) nrel(1:4)=0 impreg(i,1:4)=0.0d0 if (dataset%fa(i)/=MISS) then idx=dataset%fa(i) if (dataset%plocus(idx,trait)/=MISS) then nrel(1)=nrel(1)+1 impreg(i,1)=impreg(i,1)+dataset%plocus(idx,trait) end if idx=dataset%mo(i) if (dataset%plocus(idx,trait)/=MISS) then nrel(1)=nrel(1)+1 impreg(i,1)=impreg(i,1)+dataset%plocus(idx, trait) end if do j=pedoffset+1, dataset%num(ped) if ((dataset%fa(j)==dataset%fa(i) .or. & dataset%mo(j)==dataset%mo(i)) .and. & dataset%plocus(j, trait) /= MISS) then nrel(2)=nrel(2)+1 impreg(i,2)=impreg(i,2)+dataset%plocus(j, trait) end if end do end if currspouse=MISS do j=pedoffset+1, dataset%num(ped) if (dataset%fa(j)==i .or. dataset%mo(j)==i) then if (dataset%fa(j)==i .and. dataset%plocus(dataset%mo(j),trait)/=MISS .and. & dataset%mo(j)/=currspouse) then currspouse=dataset%mo(j) nrel(3)=nrel(3)+1 impreg(i,3)=impreg(i,3)+dataset%plocus(dataset%mo(j), trait) else if (dataset%mo(j)==i .and. dataset%plocus(dataset%fa(j),trait)/=MISS .and. & dataset%fa(j)/=currspouse) then currspouse=dataset%fa(j) nrel(3)=nrel(3)+1 impreg(i,3)=impreg(i,3)+dataset%plocus(dataset%fa(j), trait) end if if (dataset%plocus(j, trait)/=MISS) then nrel(4)=nrel(4)+1 impreg(i,4)=impreg(i,4)+dataset%plocus(j, trait) end if end if end do do k=1, 4 if (nrel(k)==0) then impreg(i,k)=MISS else impreg(i,k)=impreg(i,k)/dble(nrel(k)) end if end do if (plevel>1) then write(outstr,*) trim(dataset%pedigree(ped)), ' ', trim(dataset%id(i)), & dataset%sex(i), dataset%plocus(i, trait), impreg(i, 1:4), nrel(1:4) end if if (dataset%plocus(i, trait) /= MISS) then nobs=nobs+1 call moment(nobs, dataset%plocus(i,trait), muy, vay) sx=0.5d0 if (dataset%sex(i)/=MISS) sx=dataset%sex(i)-1.0d0 if (impreg(i,3) /= MISS) then nspouse=nspouse+1 x(1)=1.0d0 x(2)=sx x(3)=impreg(i,3) x(4)=dataset%plocus(i, trait) call givenc(rspouse, 10, 4, x, 1.0d0, ifail) end if if (impreg(i,2) /= MISS) then nsib=nsib+1 x(1)=1.0d0 x(2)=sx x(3)=impreg(i,2) x(4)=dataset%plocus(i, trait) call givenc(rsib, 10, 4, x, 1.0d0, ifail) end if if (impreg(i,4) /= MISS) then noff=noff+1 x(1)=1.0d0 x(2)=sx x(3)=impreg(i,4) x(4)=dataset%plocus(i, trait) call givenc(roff, 10, 4, x, 1.0d0, ifail) end if end if end do end if end do call alias(roff, 10, 4, 1.0d-15, x, ifail) call bsub(roff, 10, 4, boff, 3, ifail) call alias(rsib, 10, 4, 1.0d-15, x, ifail) call bsub(rsib, 10, 4, bsib, 3, ifail) call alias(rspouse, 10, 4, 1.0d-15, x, ifail) call bsub(rspouse, 10, 4, bspouse, 3, ifail) vay=sqrt(vay/dble(max(1,nobs-1))) write(outstr,'(/a,3(/a,i8,3(1x,f12.4))/)') & 'Relation N Intercept Sex Beta', & 'Offspr ', noff, boff(1), boff(2), boff(3), & 'Siblings', nsib, bsib(1), bsib(2), bsib(3), & 'Spouses ', nspouse, bspouse(1), bspouse(2), bspouse(3) ! ! Outliers ! if (plevel >= 0) then write(outstr, '(/a//a/a)') 'Outliers (>3 SDs)', & 'Regression ID Observed Expected StdRes Relatives-Mean', & '---------- ---------------------- -------------- -------------- ------- --------------' do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) if (dataset%plocus(i, trait) /= MISS) then sx=0.5d0 if (dataset%sex(i)/=MISS) sx=dataset%sex(i)-1.0d0 if (impreg(i,2) /= MISS) then pred=bsib(1)+bsib(2)*sx+bsib(3)*impreg(i,2) resid=(dataset%plocus(i, trait)-pred)/vay if (abs(resid)>3) then write(outstr,'(a10,1x,a22,2(1x,f14.6),1x,f7.2,1x,f14.6)') & 'Sibling', trim(dataset%pedigree(ped)) // '-' // trim(dataset%id(i)), & dataset%plocus(i,trait), pred, resid, impreg(i,2) end if end if if (impreg(i,3) /= MISS) then pred=bspouse(1)+bspouse(2)*sx+bspouse(3)*impreg(i,3) resid=(dataset%plocus(i, trait)-pred)/vay if (abs(resid)>3) then write(outstr,'(a10,1x,a22,2(1x,f14.6),1x,f7.2,1x,f14.6)') & 'Spouse', trim(dataset%pedigree(ped)) // '-' // trim(dataset%id(i)), & dataset%plocus(i,trait), pred, resid, impreg(i,3) end if end if if (impreg(i,4) /= MISS) then pred=boff(1)+boff(2)*sx+boff(3)*impreg(i,4) resid=(dataset%plocus(i, trait)-pred)/vay if (abs(resid)>3) then write(outstr,'(a10,1x,a22,2(1x,f14.6),1x,f7.2,1x,f14.6)') & 'Offspring', trim(dataset%pedigree(ped)) // '-' // trim(dataset%id(i)), & dataset%plocus(i,trait), pred, resid, impreg(i,4) end if end if end if end do end if end do write(outstr,*) end if ! ! Imputation ! do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) if (dataset%plocus(i, trait) == MISS) then sx=0.5d0 if (dataset%sex(i)/=MISS) sx=dataset%sex(i)-1.0d0 if (impreg(i,4) /= MISS) then nimp=nimp+1 dataset%plocus(i, trait)=boff(1)+boff(2)*sx+boff(3)*impreg(i,4) if (plevel>0) then call wrsex(dataset%sex(i), ch) write(outstr,*) & 'Imputed ', trim(dataset%pedigree(ped)), '-', trim(dataset%id(i)), & ' (', ch, ') to be ', dataset%plocus(i, trait), ' (Kids x=', impreg(i,4), ')' end if else if (impreg(i,3) /= MISS) then nimp=nimp+1 dataset%plocus(i, trait)=bspouse(1)+bspouse(2)*sx+bspouse(3)*impreg(i,3) if (plevel>0) then call wrsex(dataset%sex(i), ch) write(outstr,*) & 'Imputed ', trim(dataset%pedigree(ped)), '-', trim(dataset%id(i)), & ' (', ch, ') to be ', dataset%plocus(i, trait), ' (Spouse x=', impreg(i,3), ')' end if else if (impreg(i,2) /= MISS) then nimp=nimp+1 dataset%plocus(i, trait)=bsib(1)+bsib(2)*sx+bsib(3)*impreg(i,2) if (plevel>0) then call wrsex(dataset%sex(i), ch) write(outstr,*) & 'Imputed ', trim(dataset%pedigree(ped)), '-', trim(dataset%id(i)), & ' (', ch, ') to be ', dataset%plocus(i, trait), ' (Sibs x=', impreg(i,2), ')' end if end if end if end do end if end do write(outstr,'(a,i6,a)') 'Imputed ', nimp, ' missing values.' end subroutine famimp ! ! Quantitative trait relatives means and covariances ! subroutine famcor(locnam, trait, dataset, jdraw, iter, plevel) use outstream use interrupt use ped_class use relpair_classes use rngs implicit none character (len=*), intent(in) :: locnam integer, intent(in) :: trait type (ped_data) :: dataset ! Jackknife draw size integer, intent(in) :: jdraw integer, intent(in) :: iter integer, intent(in) :: plevel ! integer, parameter :: KNOWN=0, MISS=-9999 integer :: i, j, js, pedoffset, ped, pos, sta, currf, currm, nships, nsibs character (len=7) :: cpairs double precision :: x1, x2 integer, dimension(NCLASS) :: npairs, jnpairs double precision, dimension(NCLASS) :: cov, jcov, scov, jsecov double precision, dimension(NCLASS, 2) :: mu, cvar, jmu, jcvar, & smu, scvar, jsemu, jsecvar ! logical :: dojack integer :: drawsize, ndraws, nobserved, totpairs integer, dimension(dataset%nobs) :: obs_indx integer, parameter :: MAXDRAWSIZE = 100 integer, dimension(MAXDRAWSIZE) :: chosen double precision :: weight jmu=0.0d0 jcov=0.0d0 jcvar=0.0d0 jsemu=0.0d0 jsecov=0.0d0 jsecvar=0.0d0 write(outstr,'(/a/3a/a/)') & '------------------------------------------------', & 'Summary statistics for trait "', trim(locnam), '"', & '------------------------------------------------' call fammeans(trait, dataset, nobserved, obs_indx, plevel) call famcovar(trait, dataset, npairs, mu, cvar, cov) ! ! Jackknife ! dojack=jack_useful(npairs, iter, plevel) if (dojack) then if (jdraw == MISS) then drawsize=min(10, nobserved/10) else drawsize=jdraw end if if (drawsize < 1) drawsize=1 if (drawsize > MAXDRAWSIZE) drawsize=MAXDRAWSIZE ndraws=0 do js=1, iter ndraws=ndraws+1 if (plevel > 2) then write(outstr,'(a,i0)') 'Jackknife draw ', js end if do j=1, drawsize chosen(j)=irandom(1,nobserved) dataset%untyped(obs_indx(chosen(j)))=.true. end do call famcovar(trait, dataset, jnpairs, smu, scvar, scov) do j=1, drawsize dataset%untyped(obs_indx(chosen(j)))=.false. end do do i=1, NCLASS call moment(js, scov(i), jcov(i), jsecov(i)) do j=1, 2 call moment(js, smu(i,j), jmu(i,j), jsemu(i,j)) call moment(js, scvar(i,j), jcvar(i,j), jsecvar(i,j)) end do end do if (irupt /= 0) exit end do weight=(dble(nobserved)-dble(drawsize))/dble(drawsize)/dble(ndraws) do i=1, NCLASS jsecov(i)=sqrt(weight*jsecov(i)) do j=1, 2 jsemu(i,j)=sqrt(weight*jsemu(i,j)) jsecvar(i,j)=sqrt(weight*jsecvar(i,j)) end do end do end if ! ! Write relative correlations ! write(outstr,'(a/2a/2a)') & '-------------- Familial correlations (pairwise) --------------', & 'Rel 1 Rel 2 Std Dev 1 Std Dev 2 Correlation N Pairs', & ' Jack Cor JSE', & '--------------------------------------------------------------', & ' --------------' call wrint(npairs(REL_MAR), cpairs) write(outstr,'(a,3(1x,f12.4),2x,a7,1x,f7.4,1x,f7.4)') & relclass(REL_MAR), & cvar(REL_MAR,1), cvar(REL_MAR,2), & cov(REL_MAR), cpairs, & jcov(REL_MAR), jsecov(REL_MAR) call wrint(npairs(REL_GRAND), cpairs) write(outstr,'(a,3(4x,f9.4),2x,a7,1x,f7.4,1x,f7.4)') & relclass(REL_GRAND), & cvar(REL_GRAND,1), cvar(REL_GRAND,2), & cov(REL_GRAND), cpairs, & jcov(REL_GRAND), jsecov(REL_GRAND) call wrint(npairs(REL_HALF)/2, cpairs) write(outstr,'(a,4x,f9.4,17x,f9.4,2x,a7,1x,f7.4,1x,f7.4)') & relclass(REL_HALF), & cvar(REL_HALF,1), & cov(REL_HALF), cpairs, & jcov(REL_HALF), jsecov(REL_HALF) if (npairs(REL_AVUNC) > 0) then call wrint(npairs(REL_AVUNC), cpairs) write(outstr,'(a,3(1x,f12.4),2x,a7,1x,f7.4,1x,f7.4)') & relclass(REL_AVUNC), & cvar(REL_AVUNC,1), cvar(REL_AVUNC,2), & cov(REL_AVUNC), cpairs, & jcov(REL_AVUNC), jsecov(REL_AVUNC) end if if (npairs(REL_COZ) > 0) then call wrint(npairs(REL_COZ)/2, cpairs) write(outstr,'(a,4x,f9.4,17x,f9.4,2x,a7,1x,f7.4,1x,f7.4)') & relclass(REL_COZ), & cvar(REL_COZ,1), & cov(REL_COZ), cpairs, & jcov(REL_COZ), jsecov(REL_COZ) end if if (npairs(REL_DCOZ) > 0) then call wrint(npairs(REL_DCOZ)/2, cpairs) write(outstr,'(a,4x,f9.4,17x,f9.4,2x,a7,1x,f7.4,1x,f7.4)') & relclass(REL_DCOZ), & cvar(REL_DCOZ,1), & cov(REL_DCOZ), cpairs, & jcov(REL_DCOZ), jsecov(REL_DCOZ) end if call wrint(npairs(REL_PO), cpairs) write(outstr,'(a,3(4x,f9.4),2x,a7,1x,f7.4,1x,f7.4)') & relclass(REL_PO), & cvar(REL_PO,1), cvar(REL_PO,2), & cov(REL_PO), cpairs, & jcov(REL_PO), jsecov(REL_PO) call wrint(npairs(REL_FS)/2, cpairs) write(outstr,'(a,4x,f9.4,17x,f9.4,2x,a7,1x,f7.4,1x,f7.4)') & relclass(REL_FS), & cvar(REL_FS,1), & cov(REL_FS), cpairs, & jcov(REL_FS), jsecov(REL_FS) if (npairs(REL_MZ) > 0) then call wrint(npairs(REL_MZ)/2, cpairs) write(outstr,'(a,4x,f9.4,17x,f9.4,2x,a7,1x,f7.4,1x,f7.4)') & relclass(REL_MZ), & cvar(REL_MZ,1), & cov(REL_MZ), cpairs, & jcov(REL_MZ), jsecov(REL_MZ) end if if (npairs(REL_ALL) > 0) then call wrint(npairs(REL_ALL)/2, cpairs) write(outstr,'(a,4x,f9.4,17x,f9.4,2x,a7,1x,f7.4,1x,f7.4)') & relclass(REL_ALL), & cvar(REL_ALL,1), & cov(REL_ALL), cpairs, & jcov(REL_ALL), jsecov(REL_ALL) end if if (npairs(REL_PO) > 0) then write(outstr,'(4(/a,3(4x,f9.4),2x,i7,1x,f7.4,1x,f7.4))') & relclass(7), cvar(7,1),cvar(7,2),cov(7), & npairs(7), jcov(7), jsecov(7), & relclass(8), cvar(8,1),cvar(8,2),cov(8), & npairs(8), jcov(8), jsecov(8), & relclass(9), cvar(9,1),cvar(9,2),cov(9), & npairs(9), jcov(9), jsecov(9), & relclass(10), cvar(10,1),cvar(10,2),cov(10), & npairs(10), jcov(10), jsecov(10) end if if (npairs(REL_FS) > 0) then write(outstr,'(2(/a,4x,f9.4,17x,f9.4,2x,i7,1x,f7.4,1x,f7.4))') & relclass(11) , cvar(11,1), cov(11), & npairs(11)/2, jcov(11), jsecov(11), & relclass(12) , cvar(12,1), cov(12), & npairs(12)/2, jcov(12), jsecov(12) write(outstr,'(a,3(4x,f9.4),2x,i7,1x,f7.4,1x,f7.4)') & relclass(13) , cvar(13,1),cvar(13,2), & cov(13),npairs(13), jcov(13), jsecov(13) end if if (npairs(REL_MZ) > 0) then write(outstr,'(2(/a,4x,f9.4,17x,f9.4,2x,i7,1x,f7.4,1x,f7.4))') & relclass(14) , cvar(14,1), cov(14), & npairs(14)/2, jcov(14), jsecov(14), & relclass(15) , cvar(15,1), cov(15), & npairs(15)/2, jcov(15), jsecov(15) end if if (.not.dojack) then write(outstr,'(/a,2(/7x,a))') & 'NOTE: Jackknife SEs not calculated since total pairs > 100000.', & 'Set plevel to 1 or higher to force calculation,', & 'and consider decreasing iterations.' else write(outstr,'(2(/a,i0))') & 'Jackknife random subsample = delete-', drawsize, & 'Number of samples = ', ndraws end if ! ! Estimate heritability call wlscor(cov, npairs, jsecov) ! Fain sibship variance test call sibvar(trait, dataset, plevel) end subroutine famcor ! ! Simple descriptive statistics for a quantitative trait ! sets up dataset%untyped ! subroutine fammeans(trait, dataset, nobserved, obs_indx, plevel) use outstream use ped_class implicit none integer, intent(in) :: trait type (ped_data) :: dataset integer, intent(out) :: nobserved integer, dimension(dataset%nobs), intent(out) :: obs_indx integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS=-9999 integer :: nmiss, nmissf, nships integer, dimension(3) :: tnum double precision, dimension(3) :: mean, tvar, maxv, minv integer :: i, ped, pedoffset double precision :: x1 nmiss=0 nmissf=0 nobserved=0 nships=0 do i=1, 3 maxv(i)=-1.0d20 minv(i)=+1.0d20 mean(i)=0.0d0 tvar(i)=0.0d0 tnum(i)=0 end do do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) dataset%untyped(i)=(dataset%plocus(i, trait) == MISS) if (dataset%untyped(i)) then nmiss=nmiss+1 if (i <= pedoffset+dataset%nfound(ped)) nmissf=nmissf+1 else nobserved=nobserved+1 obs_indx(nobserved)=i x1=dataset%plocus(i, trait) if (x1 > maxv(1)) then maxv(1)=x1 end if if (x1 < minv(1)) then minv(1)=x1 end if tnum(1)=tnum(1)+1 call moment(tnum(1), x1, mean(1), tvar(1)) if (i <= pedoffset+dataset%nfound(ped)) then if (x1 > maxv(2)) then maxv(2)=x1 end if if (x1 < minv(2)) then minv(2)=x1 end if tnum(2)=tnum(2)+1 call moment(tnum(2), x1, mean(2), tvar(2)) else if (x1 > maxv(3)) then maxv(3)=x1 end if if (x1 < minv(3)) then minv(3)=x1 end if tnum(3)=tnum(3)+1 call moment(tnum(3), x1, mean(3), tvar(3)) end if end if end do end if end do if (tnum(1) > 0) then tvar(1)=tvar(1)/dble(max(1,tnum(1)-1)) tvar(2)=tvar(2)/dble(max(1,tnum(2)-1)) tvar(3)=tvar(3)/dble(max(1,tnum(3)-1)) if (tnum(2) == 0) then maxv(2)=0.0d0 minv(2)=0.0d0 else if (tnum(3) == 0) then maxv(3)=0.0d0 minv(3)=0.0d0 end if if (plevel > 1 .and. nships > 0) then write(outstr,*) end if write(outstr,'(a/a)') & 'Descriptive Stats All Founders Nonfounders', & '-----------------------------------------------------------' write(outstr,'(5(a,3x,3(1x,g14.6)/),2(a,2x,3(2x,i9,4x)/))') & 'Means ', mean(1), mean(2), mean(3), & 'Variances ', tvar(1), tvar(2), tvar(3), & 'Stand Devs ', sqrt(tvar(1)), sqrt(tvar(2)), sqrt(tvar(3)), & 'Maxima ', maxv(1), maxv(2), maxv(3), & 'Minima ', minv(1), minv(2), minv(3), & 'No. obs ', tnum(1), tnum(2), tnum(3), & 'No. missing', nmiss, nmissf, nmiss-nmissf else write(outstr,'(a/)') 'NOTE: no nonmissing observations' end if end subroutine fammeans ! ! Pairwise familial correlations ! subroutine famcovar(trait, dataset, npairs, mu, cvar, cov) use interrupt use ped_class implicit none integer, parameter :: KNOWN=0, MISS=-9999 integer, parameter :: NCLASS=19 integer, parameter :: REL_MAR=1, REL_GRAND=2, REL_HALF=3, & REL_PO=4, REL_FS=5, REL_MZ=6, REL_FASO=7, & REL_FADA=8, REL_MOSO=9, REL_MODA=10, & REL_BROBRO=11, REL_SISSIS=12, REL_BROSIS=13, & REL_MZM=14, REL_MZF=15, REL_COZ=16, REL_DCOZ=17, & REL_AVUNC=18, REL_ALL=19 integer, intent(in) :: trait type (ped_data) :: dataset integer, dimension(NCLASS) :: npairs double precision, dimension(NCLASS) :: cov double precision, dimension(NCLASS,2) :: mu, cvar ! integer :: i, j, pedoffset, ped, pos, sta, currf, currm, nships, nsibs double precision :: x1, x2 logical :: last, sibshp character (len=12) :: midpar ! nuclear family IDs integer, dimension(dataset%maxact) :: nucfam integer :: avunc, ego, f1, f2, m1, m2, nfam, parsibs ! functions logical :: ismzpair mu=0.0d0 cov=0.0d0 cvar=0.0d0 npairs=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) if (.not.dataset%untyped(i)) then x1=dataset%plocus(i, trait) do j=i+1, dataset%num(ped) if (.not.dataset%untyped(j)) then x2=dataset%plocus(j, trait) call corr(REL_ALL,x1,x2,NCLASS,npairs,mu,cvar,cov) call corr(REL_ALL,x2,x1,NCLASS,npairs,mu,cvar,cov) end if end do do j=max(pedoffset+dataset%nfound(ped)+1,i+1), dataset%num(ped) if (.not.dataset%untyped(j)) then x2=dataset%plocus(j, trait) if (dataset%fa(j) == i .or. dataset%mo(j) == i) then call corr(REL_PO,x1,x2,NCLASS,npairs,mu,cvar,cov) if (dataset%sex(i) == 1 .and. dataset%sex(j) == 1) then call corr(REL_FASO,x1,x2,NCLASS,npairs,mu,cvar,cov) else if (dataset%sex(i) == 1 .and. dataset%sex(j) == 2) then call corr(REL_FADA,x1,x2,NCLASS,npairs,mu,cvar,cov) else if (dataset%sex(i) == 2 .and. dataset%sex(j) == 1) then call corr(REL_MOSO,x1,x2,NCLASS,npairs,mu,cvar,cov) else if (dataset%sex(i) == 2 .and. dataset%sex(j) == 2) then call corr(REL_MODA,x1,x2,NCLASS,npairs,mu,cvar,cov) end if else if ((dataset%fa(j) > pedoffset+dataset%nfound(ped) .and. & (dataset%fa(dataset%fa(j)) == i .or. & dataset%mo(dataset%fa(j)) == i)) .or. & (dataset%mo(j) > pedoffset+dataset%nfound(ped) .and. & (dataset%fa(dataset%mo(j)) == i .or. & dataset%mo(dataset%mo(j)) == i))) then call corr(REL_GRAND,x1,x2,NCLASS,npairs,mu,cvar,cov) else if (i > pedoffset+dataset%nfound(ped)) then if (dataset%fa(i) == j .or. dataset%mo(i) == j) then call corr(REL_PO,x2,x1,NCLASS,npairs,mu,cvar,cov) if (dataset%sex(i) == 1 .and. dataset%sex(j) == 1) then call corr(REL_FASO,x2,x1,NCLASS,npairs,mu,cvar,cov) else if (dataset%sex(i) == 2 .and. dataset%sex(j) == 1) then call corr(REL_FADA,x2,x1,NCLASS,npairs,mu,cvar,cov) else if (dataset%sex(i) == 1 .and. dataset%sex(j) == 2) then call corr(REL_MOSO,x2,x1,NCLASS,npairs,mu,cvar,cov) else if (dataset%sex(i) == 2 .and. dataset%sex(j) == 2) then call corr(REL_MODA,x2,x1,NCLASS,npairs,mu,cvar,cov) end if else if (dataset%fa(i) == dataset%fa(j) .and. & dataset%mo(i) == dataset%mo(j)) then if (ismzpair(i, j, dataset)) then call corr(REL_MZ,x1,x2,NCLASS,npairs,mu,cvar,cov) call corr(REL_MZ,x2,x1,NCLASS,npairs,mu,cvar,cov) if (dataset%sex(i) == 1) then call corr(REL_MZM,x1,x2,NCLASS,npairs,mu,cvar,cov) call corr(REL_MZM,x2,x1,NCLASS,npairs,mu,cvar,cov) else if (dataset%sex(i) == 2) then call corr(REL_MZF,x1,x2,NCLASS,npairs,mu,cvar,cov) call corr(REL_MZF,x2,x1,NCLASS,npairs,mu,cvar,cov) end if else call corr(REL_FS,x1,x2,NCLASS,npairs,mu,cvar,cov) call corr(REL_FS,x2,x1,NCLASS,npairs,mu,cvar,cov) if (dataset%sex(i) == 1 .and. dataset%sex(j) == 1) then call corr(REL_BROBRO,x1,x2,NCLASS,npairs,mu,cvar,cov) call corr(REL_BROBRO,x2,x1,NCLASS,npairs,mu,cvar,cov) else if (dataset%sex(i) == 2 .and. dataset%sex(j) == 2) then call corr(REL_SISSIS,x1,x2,NCLASS,npairs,mu,cvar,cov) call corr(REL_SISSIS,x2,x1,NCLASS,npairs,mu,cvar,cov) else if ((dataset%sex(i)+dataset%sex(j)) == 3) then call corr(REL_BROSIS,x1,x2,NCLASS,npairs,mu,cvar,cov) end if end if else if (dataset%fa(i) == dataset%fa(j) .or. & dataset%mo(i) == dataset%mo(j)) then call corr(REL_HALF,x1,x2,NCLASS,npairs,mu,cvar,cov) call corr(REL_HALF,x2,x1,NCLASS,npairs,mu,cvar,cov) else if ((dataset%fa(i) > pedoffset+dataset%nfound(ped) .and. & (dataset%fa(dataset%fa(i)) == j .or. & dataset%mo(dataset%fa(i)) == j)) .or. & (dataset%mo(i) > pedoffset+dataset%nfound(ped) .and. & (dataset%fa(dataset%mo(i)) == j .or. & dataset%mo(dataset%mo(i)) == j))) then call corr(REL_GRAND,x2,x1,NCLASS,npairs,mu,cvar,cov) end if end if end if end do end if if (irupt /= 0) exit end do pos=pedoffset+dataset%nfound(ped)+1 if (pos <= dataset%num(ped)) then nfam=0 nucfam=0 sta=pos currf=dataset%fa(sta) currm=dataset%mo(sta) last=.false. sibshp=.false. ! through sibship by sibship do if (pos > dataset%num(ped)) then last=.true. if (dataset%num(ped)-pedoffset > dataset%nfound(ped)) sibshp=.true. else if (currf /= dataset%fa(pos) .or. currm /= dataset%mo(pos)) then sibshp=.true. end if if (sibshp) then ! marital correlation if (.not.dataset%untyped(currf) .and. .not.dataset%untyped(currm)) then x1=dataset%plocus(currf,trait) x2=dataset%plocus(currm,trait) call corr(REL_MAR, x1, x2, NCLASS, npairs, mu, cvar, cov) end if nfam=nfam+1 do i=sta, pos-1 nucfam(i-pedoffset)=nfam end do end if ! exit if last sibship if (last) exit ! else move to next sibship if appropriate and iter if (sibshp) then sibshp=.false. sta=pos currf=dataset%fa(sta) currm=dataset%mo(sta) end if pos=pos+1 end do ! ! full cousins and avuncular ! do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped)-1 if (.not.dataset%untyped(i)) then ego=nucfam(i-pedoffset) f1=nucfam(dataset%fa(i)-pedoffset) m1=nucfam(dataset%mo(i)-pedoffset) x1=dataset%plocus(i,trait) do j=i+1, dataset%num(ped) if (.not.dataset%untyped(j) .and. & nucfam(i-pedoffset) /= nucfam(j-pedoffset)) then parsibs=0 avunc=0 f2=nucfam(dataset%fa(j)-pedoffset) m2=nucfam(dataset%mo(j)-pedoffset) if (f2 /= 0) then if (f1 == f2) then if (dataset%fa(i) /= dataset%fa(j)) parsibs=parsibs+1 end if if (m1 == f2) parsibs=parsibs+1 if (ego == f2 .and. i /= dataset%fa(j)) avunc=avunc+1 end if if (m2 /= 0) then if (f1 == m2) parsibs=parsibs+1 if (m1 == m2) then if (dataset%mo(i) /= dataset%mo(j)) parsibs=parsibs+1 end if if (ego == m2 .and. i /= dataset%mo(j)) avunc=avunc+1 end if if (parsibs == 1) then x2=dataset%plocus(j,trait) call corr(REL_COZ,x1,x2,NCLASS,npairs,mu,cvar,cov) call corr(REL_COZ,x2,x1,NCLASS,npairs,mu,cvar,cov) else if (parsibs == 2) then x2=dataset%plocus(j,trait) call corr(REL_DCOZ,x1,x2,NCLASS,npairs,mu,cvar,cov) call corr(REL_DCOZ,x2,x1,NCLASS,npairs,mu,cvar,cov) else if (avunc > 0) then x2=dataset%plocus(j,trait) call corr(REL_AVUNC,x1,x2,NCLASS,npairs,mu,cvar,cov) end if end if end do if (irupt /= 0) exit end if end do end if end if end do ! convert to correlations call corrstd(nclass, npairs, cvar, cov) end subroutine famcovar ! ! Sibship variance tests ! subroutine sibvar(trait, dataset, plevel) use outstream use ped_class use statfuns use AS164 implicit none integer, intent(in) :: trait type (ped_data) :: dataset integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS=-9999 integer :: i, ifail, j, pedoffset, ped, pos, sta, currf, currm, nfam, nships, nsibs double precision :: x1, x2 ! sibship variance test regression results double precision :: x(3),r(6),cov(6),b(2) double precision :: alpha, beta, sea, seb, ssm, ssw, tvalb ! nuclear family IDs integer, dimension(dataset%maxact) :: nucfam logical :: last, sibshp character (len=12) :: midpar ! functions ! probst character (len=6) :: pstring nships=0 do i=1, 6 r(i)=0.0d0 end do j=0 do i=1, 3 j=j+i r(j)=-1.0d0 end do if (plevel > 1) then write(outstr,'(a/a)') & 'Pedigree Father Mother Midparent Sibship Mean log(Sibs Var)', & '---------- -------- -------- ------------ ------------ ------------' end if do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) nfam=0 nucfam=0 pos=pedoffset+dataset%nfound(ped)+1 sta=pos currf=dataset%fa(sta) currm=dataset%mo(sta) last=.false. sibshp=.false. ! through sibship by sibship do if (pos > dataset%num(ped)) then last=.true. if (dataset%num(ped)-pedoffset > dataset%nfound(ped)) sibshp=.true. else if (currf /= dataset%fa(pos) .or. currm /= dataset%mo(pos)) then sibshp=.true. end if if (sibshp) then ! marital correlation if (dataset%plocus(currf,trait) /= MISS .and. & dataset%plocus(currm,trait) /= MISS) then x1=dataset%plocus(currf,trait) x2=dataset%plocus(currm,trait) write(midpar,'(f12.4)') 0.5d0*(x1+x2) else midpar=' x ' end if ! within-sibship means and variances nfam=nfam+1 nsibs=0 ssm=0.0d0 ssw=0.0d0 do i=sta, pos-1 if (dataset%plocus(i,trait) /= MISS .and. dataset%imztwin(i) == MISS) then x1=dataset%plocus(i,trait) nsibs=nsibs+1 call moment(nsibs, x1, ssm, ssw) end if nucfam(i-pedoffset)=nfam end do if (nsibs > 1 .and. ssw > 0.0d0) then nships=nships+1 x(1)=1.0d0 x(2)=ssm x(3)=log(ssw/dble(max(1,nsibs-1))) if (plevel > 1) then write(outstr,'(a10,1x,a10,1x,a10,1x,a12,2(1x,f12.4))') & dataset%pedigree(ped), dataset%id(currf), dataset%id(currm), & midpar, x(2), x(3) end if call givenc(r, 6, 3, x, 1.0d0, ifail) end if end if ! exit if last sibship if (last) exit ! else move to next sibship if appropriate and iter if (sibshp) then sibshp=.false. sta=pos currf=dataset%fa(sta) currm=dataset%mo(sta) end if pos=pos+1 end do end if end do write(outstr,'(a/a)') 'Fain sibship variance test', '--------------------------' if (nships > 2) then call alias(r, 6, 3, 1.0d-15, x, ifail) call bsub(r, 6, 3, b, 2, ifail) call var(r, 6, cov, 6, 3, nships, 1, ifail) alpha=b(1) sea=sqrt(cov(1)) beta=b(2) seb=sqrt(cov(3)) tvalb=abs(beta/seb) write(outstr,'(a,i0,2(/a,g10.4,a,g10.4,a)/a,g10.4,a,i0,3a)') & 'No. sibships = ',nships, 'Intercept = ',alpha,' (ase=',sea,')', & 'Slope = ',beta, ' (ase=',seb,')', & 't value = ',tvalb,' (df=',nships-2,', P=', & trim(pstring(1.0D0-probst(tvalb,nships-2,ifail))), ')' else write(outstr,'(/a/)') 'NOTE: Insufficient number of sibships for Fain test.' end if end subroutine sibvar ! ! Calculate twinning rate ! subroutine twinrate(mztwin, gt, thresh, dataset, plevel) use outstream use ped_class use statfuns implicit none integer, intent(in) :: mztwin integer, intent(in) :: gt double precision, intent(in) :: thresh type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel ! local integer, parameter :: KNOWN=0, MISS=-9999 integer :: i, j, k, ped, thisfa, thismo, thiszyg integer :: dzbirth, mzbirth, nbirth logical :: hasdz, samefa, samemo, samezyg double precision :: dn ! functions double precision :: isaff hasdz=.not.(gt==16 .and. thresh==0.0d0) dzbirth=0 mzbirth=0 nbirth=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then ! only iterate nonfounders k=dataset%num(ped-1)+dataset%nfound(ped)+1 thisfa=MISS thismo=MISS thiszyg=0 do i=k, dataset%num(ped) samefa=(dataset%fa(i) == thisfa) samemo=(dataset%mo(i) == thismo) samezyg=(thiszyg > 0 .and. dataset%plocus(i,mztwin) == thiszyg) if (.not.(samefa .and. samemo .and. samezyg)) then nbirth=nbirth+1 if (int(isaff(dataset%plocus(i,mztwin),thresh,gt)) == 2) then mzbirth=mzbirth+1 else if (hasdz .and. dataset%plocus(i,mztwin) > 0) then dzbirth=dzbirth+1 end if end if thisfa=dataset%fa(i) thismo=dataset%mo(i) thiszyg=dataset%plocus(i,mztwin) end do end if end do ! write(*,*) 'N=', nbirth if (nbirth > 0) then dn=1.0d0/dfloat(nbirth) write(outstr, '(/a/a,3(/a,i7,1x,f7.5)/a,i7)') & 'Zygosity Births Rate', & '---------- ------- --------', & 'MZ ', mzbirth, dfloat(mzbirth)*dn, & 'DZ ', dzbirth, dfloat(dzbirth)*dn, & 'All Twin ', mzbirth+dzbirth, dfloat(mzbirth+dzbirth)*dn, & 'Singletons ', nbirth-mzbirth-dzbirth else write(outstr,'(a)') 'No offspring.' end if end subroutine twinrate ! ! Classical twin analysis contrasting monozygotic twins v. other siblings. ! subroutine twincor(locnam, trait, mztwin, gt, thresh, dataset, plevel) use outstream use ped_class use statfuns implicit none character(len=20), intent(in) :: locnam integer, intent(in) :: trait integer, intent(in) :: mztwin integer, intent(in) :: gt double precision, intent(in) :: thresh type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel ! local integer, parameter :: KNOWN=0, MISS=-9999 ! MZ, DZ, MZF, MZM, DZF, DZM, DZFM, Sib integer, parameter :: nclass=8 integer, dimension(nclass) :: npairs double precision :: cov(nclass), mu(nclass,2), cvar(nclass,2) logical :: samefa, samemo, hasdz integer :: i, j, k, ped, zyg double precision :: asyp, rlo, rhi, x1, x2, z character (len=3) :: histo character (len=14), dimension(12) :: zygclass = & (/ 'MZ twins ', 'DZ twins ', 'Sibs (non-MZ) ', & 'MZ Female ', 'MZ Male ', & 'DZ Female ', 'DZ Male ', 'DZ Female-Male', 'Sibs (nontwin)', & 'Sisters ', 'Brothers ', 'Sister-Brother' /) ! functions ! zp character (len=6) :: pstring double precision :: isaff, inht, cortest do i=1, nclass mu(i,1)=0.0d0 mu(i,2)=0.0d0 npairs(i)=0 cvar(i,1)=0.0d0 cvar(i,2)=0.0d0 cov(i)=0.0d0 end do hasdz=.not.(gt==16 .and. thresh==0.0d0) write(outstr,'(/a/3a/a)') & '------------------------------------------------------------', & 'Classical twin analysis of "', trim(locnam), '"', & '------------------------------------------------------------' if (plevel > 1) then write(outstr,'(a)') 'Pedigree Person1 Person2 Zyg Trait1 Trait2' end if do ped=1, dataset%nped if (dataset%actset(ped) > 0) then ! only iterate nonfounders do i=dataset%num(ped-1)+dataset%nfound(ped)+1, dataset%num(ped)-1 do j=i+1, dataset%num(ped) samefa=(dataset%fa(i) == dataset%fa(j)) samemo=(dataset%mo(i) == dataset%mo(j)) if (.not.samefa .or. .not.samemo) exit ! ! Share parents and zygosity indicator -- MZ (zyg=1) or DZ (zyg=2) twins ! zyg=2 if (dataset%plocus(i,mztwin) /= MISS .and. & dataset%plocus(i,mztwin)==dataset%plocus(j,mztwin)) then if (int(isaff(dataset%plocus(i,mztwin),thresh,gt)) == 2 .and. & int(isaff(dataset%plocus(j,mztwin),thresh,gt)) == 2) then zyg=1 end if else if (hasdz) then zyg=0 end if if (dataset%plocus(i,trait) /= MISS .and. dataset%plocus(j,trait) /= MISS) then x1=dataset%plocus(i,trait) x2=dataset%plocus(j,trait) if (zyg==1) then call corr(1, x1, x2, nclass, npairs, mu, cvar, cov) call corr(1, x2, x1, nclass, npairs, mu, cvar, cov) if (dataset%sex(i)==1 .and. dataset%sex(i)==1) then call corr(4, x1, x2, nclass, npairs, mu, cvar, cov) call corr(4, x2, x1, nclass, npairs, mu, cvar, cov) else if (dataset%sex(i)==2 .and. dataset%sex(i)==2) then call corr(3, x1, x2, nclass, npairs, mu, cvar, cov) call corr(3, x2, x1, nclass, npairs, mu, cvar, cov) end if if (plevel > 1) then write(outstr,'(a11,2(1x,a),3x,a,2x,2(1x,f9.4))') & dataset%pedigree(ped)(1:11), dataset%id(i), dataset%id(j), & 'MZ ', x1, x2 end if else if (zyg==2) then call corr(2, x1, x2, nclass, npairs, mu, cvar, cov) call corr(2, x2, x1, nclass, npairs, mu, cvar, cov) if (dataset%sex(i)==1 .and. dataset%sex(j)==1) then call corr(6, x1, x2, nclass, npairs, mu, cvar, cov) call corr(6, x2, x1, nclass, npairs, mu, cvar, cov) else if (dataset%sex(i)==2 .and. dataset%sex(j)==2) then call corr(5, x1, x2, nclass, npairs, mu, cvar, cov) call corr(5, x2, x1, nclass, npairs, mu, cvar, cov) else if (dataset%sex(i)==1 .and. dataset%sex(j)==2) then call corr(7, x2, x1, nclass, npairs, mu, cvar, cov) else if (dataset%sex(i)==2 .and. dataset%sex(j)==1) then call corr(7, x1, x2, nclass, npairs, mu, cvar, cov) end if if (plevel > 1) then write(outstr,'(a11,2(1x,a),3x,a,2x,2(1x,f9.4))') & dataset%pedigree(ped)(1:11), dataset%id(i), dataset%id(j), & 'DZ ', x1, x2 end if else call corr(8, x1, x2, nclass, npairs, mu, cvar, cov) call corr(8, x2, x1, nclass, npairs, mu, cvar, cov) if (plevel > 1) then write(outstr,'(a11,2(1x,a),3x,a,1x,2(1x,f9.4))') & dataset%pedigree(ped)(1:11), dataset%id(i), dataset%id(j), & 'Sib', x1, x2 end if end if end if end do end do end if end do call corrstd(nclass, npairs, cvar, cov) ! now correct n for double entered data do i=1, 6 npairs(i)=npairs(i)/2 end do npairs(8)=npairs(8)/2 ! ! Table of correlations ! write(outstr,'(/a/a)') & 'Zygosity Group N Pairs Mean Std Dev Correlation (95%CI)', & '-------------- ------- ------------ --------- -------------------------' call fishzci(cov(1), npairs(1), rlo, rhi) write(outstr,'(a,i8,f13.4, 1x,f10.4,f9.3,a,f6.3,a,f6.3,a)') & zygclass(1), npairs(1), mu(1,1), cvar(1,1), cov(1), ' (', rlo, ' -- ', rhi, ')' zyg=3 if (hasdz) zyg=zyg-1 call fishzci(cov(2), npairs(2), rlo, rhi) write(outstr,'(a,i8,f13.4, 1x,f10.4,f9.3,a,f6.3,a,f6.3,a)') & zygclass(zyg), npairs(2), mu(2,1), cvar(2,1), cov(2), ' (', rlo, ' -- ', rhi, ')' if (npairs(8)>0) then call fishzci(cov(8), npairs(8), rlo, rhi) write(outstr,'(a,i8,f13.4, 1x,f10.4,f9.3,a,f6.3,a,f6.3,a)') & zygclass(9), npairs(8), mu(8,1), cvar(8,1), cov(8), ' (', rlo, ' -- ', rhi, ')' end if zyg=10 if (hasdz) zyg=6 call fishzci(cov(3), npairs(3), rlo, rhi) write(outstr,'(/a,i8,f13.4, 1x,f10.4,f9.3,a,f6.3,a,f6.3,a)') & zygclass(4), npairs(3), mu(3,1), cvar(3,1), cov(3), ' (', rlo, ' -- ', rhi, ')' call fishzci(cov(4), npairs(4), rlo, rhi) write(outstr,'(a,i8,f13.4, 1x,f10.4,f9.3,a,f6.3,a,f6.3,a)') & zygclass(5), npairs(4), mu(4,1), cvar(4,1), cov(4), ' (', rlo, ' -- ', rhi, ')' call fishzci(cov(5), npairs(5), rlo, rhi) write(outstr,'(a,i8,f13.4, 1x,f10.4,f9.3,a,f6.3,a,f6.3,a)') & zygclass(zyg), npairs(5), mu(5,1), cvar(5,1), cov(5), ' (', rlo, ' -- ', rhi, ')' call fishzci(cov(6), npairs(6), rlo, rhi) write(outstr,'(a,i8,f13.4, 1x,f10.4,f9.3,a,f6.3,a,f6.3,a)') & zygclass(zyg+1), npairs(6), mu(6,1), cvar(6,1), cov(6), ' (', rlo, ' -- ', rhi, ')' call fishzci(cov(7), npairs(7), rlo, rhi) write(outstr,'(a,i8,f13.4,a1,1x,f9.4,a1,f8.3,a,f6.3,a,f6.3,a/22x,f13.4,1x,f10.4/)') & zygclass(zyg+2), npairs(7), mu(7,1), ',', cvar(7,1), ',', cov(7), ' (', rlo, ' -- ', rhi, ')', & mu(7,2), cvar(7,2) ! ! Table of Z tests of homogeneity of correlations ! write(outstr,'(/a/a)') & 'Hypothesis Z-statistic P-value', & '--------------- ----------- -------' z=abs(cortest(cov(3), cov(4), npairs(3), npairs(4))) asyp=2.0d0*zp(abs(z)) call phist(asyp, asyp, histo) write(outstr,'(a,3x,f9.2,4x,a,1x,a)') & 'r(MZF) = r(MZM)', z, pstring(asyp), histo z=abs(cortest(cov(5), cov(6), npairs(5), npairs(6))) asyp=2.0d0*zp(abs(z)) call phist(asyp, asyp, histo) write(outstr,'(a,3x,f9.2,4x,a,1x,a)') & 'r(DZF) = r(DZM)', z, pstring(asyp), histo if (hasdz .and. npairs(8)>0) then z=abs(cortest(cov(2), cov(8), npairs(2), npairs(8))) asyp=2.0d0*zp(abs(z)) call phist(asyp, asyp, histo) write(outstr,'(a,3x,f9.2,4x,a,1x,a)') & 'r(DZ) = r(Sib) ', z, pstring(asyp), histo end if z=cortest(cov(1), cov(2), npairs(1), npairs(2)) asyp=zp(z) call phist(asyp, asyp, histo) write(outstr,'(a,3x,f9.2,4x,a,1x,a)') & 'r(MZ) = r(DZ) ', z, pstring(asyp), histo write(outstr,'(/a/)') 'Falconer style estimates of heritability' if (cov(1) > 2.0d0*cov(2)) then write(outstr,'(a,f5.3/a,f5.3)') & 'Heritability h2= ', 4.0d0*cov(2)-cov(1), & 'Dominance d2= ', 2.0d0*(cov(1)-cov(2)-cov(2)) else write(outstr,'(a,f5.3/a,f5.3)') & 'Heritability h2= ', 2.0d0*(cov(1)-cov(2)), & 'Domesticity c2= ', cov(2)+cov(2)-cov(1) end if end subroutine twincor ! ! update means and sums of squares and products ! ! 1=Marital 2=Grandparent-Grandchild 3=Half-sib ! 4=Parent-Offspring 5=Full-sib 6=MZ-Twin ! 7=father-son 8=father-daugher 9=mother-son 10=mother-daughter ! 11=brother 12=sister 13=brother-sister ! 14=MZ-Males 15=MZ-Females ! subroutine corr(typ, x1, x2, nclass, npairs, mean, var, cov) integer, intent(in) :: typ double precision, intent(in) :: x1 double precision, intent(in) :: x2 integer, intent(in) :: nclass integer, intent(inout) :: npairs(nclass) double precision, intent(inout) :: mean(nclass,2) double precision, intent(inout) :: var(nclass,2) double precision, intent(inout) :: cov(nclass) double precision :: d1, d2, de, wt npairs(typ)=npairs(typ)+1 de=dble(npairs(typ)) wt=(de-1.0d0)/de d1=x1-mean(typ,1) d2=x2-mean(typ,2) mean(typ,1)=mean(typ,1)+d1/de mean(typ,2)=mean(typ,2)+d2/de var(typ,1)=var(typ,1)+ d1*d1*wt var(typ,2)=var(typ,2)+ d2*d2*wt cov(typ)=cov(typ)+ d1*d2*wt end subroutine corr ! ! cor to cov for classes ! subroutine corrstd(nclass, npairs, var, cov) integer, intent(in) :: nclass integer, intent(in) :: npairs(nclass) double precision, intent(inout) :: var(nclass,2) double precision, intent(inout) :: cov(nclass) integer :: i do i=1, nclass var(i,1)=sqrt(var(i,1)/dble(max(1,npairs(i)-1))) var(i,2)=sqrt(var(i,2)/dble(max(1,npairs(i)-1))) if (var(i,1) > 0.0d0 .and. var(i,2) > 0.0d0) then cov(i)=cov(i)/dble(max(1,npairs(i)-1))/var(i,1) /var(i,2) else cov(i)=0.0d0 end if end do end subroutine corrstd ! ! distance correlation (bivariate) ! can be two sets of loci, where division is last position of first set ! subroutine dodist(division, nterms, terms, nloci, loc, loctyp, locpos, dataset, plevel) use outstream use read_data use covariate_data use statfuns use distance_cor implicit none integer, intent(in) :: division integer, intent(in) :: nterms integer, dimension(:), intent(inout) :: terms integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data) :: dataset integer, intent(in) :: plevel integer :: i, j, k, n, ped integer, dimension(2) :: traitpair double precision :: dcor, dcov, dvar1, dvar2, pval double precision, dimension(:,:), allocatable :: xval, yval ! functions character (len=6) :: pstring if (plevel > 0) then write(outstr,'(a/a)') 'Distance Correlation', '--------------------' if (division > 0) then write(outstr,'(a/a)', advance='no') 'Set1 with Set2', 'X: ' do j=1, division write(outstr,'(1x,a)', advance='no') trim(loc(terms(j))) end do write(outstr,'(/a)', advance='no') 'Y: ' do k=division+1, nterms write(outstr,'(1x,a)', advance='no') trim(loc(terms(k))) end do write(outstr,*) else write(outstr,'(a)') 'All univariate pairings.' end if end if write(outstr,'(/a/a)') & 'Trait1 Trait2 N dCov dVarX dVarY dCor P-value', & '---------- ---------- ------ ---------- ---------- ---------- ------- -------' ! all pairs if (division == 0) then allocate(xval(dataset%nobs,1), yval(dataset%nobs,1)) traitpair=0 do j=1, nterms-1 traitpair(1)=terms(j) do k=j+1, nterms traitpair(2)=terms(k) n=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (complete(.false., i, 2, traitpair, locpos, loctyp, dataset)) then n=n+1 call readdatum(i, locpos(terms(j)), loctyp(terms(j)), & nloci, loctyp, locpos, dataset, xval(n,1)) call readdatum(i, locpos(terms(k)), loctyp(terms(k)), & nloci, loctyp, locpos, dataset, yval(n,1)) end if end do end if end do call distcor(n, xval, yval, dcov, dvar1, dvar2, dcor) pval=chip(abs(dcor*dble(n)), 1) write(outstr,'(a10,1x,a10,1x,i6,1x,3(1x,g10.4),1x,f7.4,2x,a)') & loc(terms(j)), loc(terms(k)), n, dcov, dvar1, dvar2, dcor, pstring(pval) end do end do ! or two sets else allocate(xval(dataset%nobs,division), yval(dataset%nobs,nterms-division)) n=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (complete(.false., i, nterms, terms, locpos, loctyp, dataset)) then n=n+1 do j=1, division call readdatum(i, locpos(terms(j)), loctyp(terms(j)), & nloci, loctyp, locpos, dataset, xval(n,j)) end do do k=division+1, nterms call readdatum(i, locpos(terms(k)), loctyp(terms(k)), & nloci, loctyp, locpos, dataset, yval(n,k-division)) end do end if end do end if end do call distcor(n, xval, yval, dcov, dvar1, dvar2, dcor) pval=chip(abs(dcor*dble(n)), 1) j=1 k=division+1 write(outstr,'(a10,1x,a10,1x,i6,1x,3(1x,g10.4),1x,f7.4,2x,a)') & loc(terms(j)), loc(terms(k)), n, dcov, dvar1, dvar2, dcor, pstring(pval) do j=j+1 k=k+1 if (j > division .and. k > nterms) exit if (j <= division .and. k <= nterms) then write(outstr,'(a10,1x,a10)') loc(terms(j)), loc(terms(k)) else if (j <= division) then write(outstr,'(a10)') loc(terms(j)) else write(outstr,'(11x,a10)') loc(terms(k)) end if end do end if end subroutine dodist ! ! Means and covariances for multiple trait ! typ=1 means and correlations ! 2 means and covariances ! 3 plus PCA ! subroutine docov(typ, nterms, terms, nloci, loc, loctyp, locpos, dataset) use outstream use string_utilities use read_data use covariate_data implicit none integer, intent(in) :: typ integer, intent(in) :: nterms integer, dimension(:), intent(inout) :: terms integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data) :: dataset ! integer, parameter :: KNOWN=0, MISS=-9999 character (len=11), dimension(2) :: lab = (/ 'Covariances', 'Correlation' /) ! array of means and covariances double precision, dimension(nterms) :: mean, x double precision, dimension(:), allocatable :: cov double precision, dimension(:,:), allocatable :: loadings ! local variables integer :: g1, g2, i, ifail, ii, j, namwid, nobs, ncov, ntot, ped character(len=40) :: str character(len=6) :: fstr double precision :: den if (nterms <= 0) then write(outstr,'(a)') 'ERROR: No active traits.' return end if ncov=nterms*(nterms+1)/2 if (typ == 1) then allocate(cov(ncov)) else allocate(cov(ncov), loadings(nterms, nterms)) end if nobs=0 ntot=0 ifail=0 do i=1, nterms mean(i)=0.0d0 end do do i=1, ncov cov(i)=0.0d0 end do nobs=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (complete(.false., i, nterms, terms, locpos, loctyp, dataset)) then nobs=nobs+1 do j=1, nterms if (ismarker(loctyp(terms(j)))) then call get_geno(i, locpos(terms(j)), locpos(terms(j))+1, dataset, g1, g2) x(j)=0.5d0*dble(g1+g2) else if (loctyp(terms(j)) == LOC_AFF) then x(j)=dataset%plocus(i,locpos(terms(j)))-1.0d0 else if (isspecial(loctyp(terms(j)))) then call autovar(i, locpos(terms(j)), nloci, loctyp, locpos, dataset, x(j)) else x(j)=dataset%plocus(i,locpos(terms(j))) end if end do call dssp(nterms, nobs, 1, x, mean, cov) end if end do ntot=ntot+dataset%num(ped)-dataset%num(ped-1) end if end do namwid=max(10,widest(loc(terms))) str='Variable' call wrform('a', namwid, 0, fstr) write(outstr,'(/3a/2a)') & str(1:namwid), ' Mean Stand Dev ', lab(1+mod(typ,2)), & repeat('-', namwid), ' ------------ ------------ ---------------------' if (typ /= 2) then call covcor(nterms, nobs, cov) ii=0 do i=1,nterms ii=ii+i write(outstr, fstr, advance='no') loc(terms(i)) write(outstr,'(1x,f12.4,1x,f12.4,15(1x,f4.2))') & mean(i),sqrt(cov(ii)), (cov(ii-i+j),j=1,i-1), 1.0D0 cov(ii)=1.0d0 end do else cov=cov/dble(max(1,nobs-1)) ii=0 do i=1,nterms ii=ii+i write(outstr, fstr, advance='no') loc(terms(i)) write(outstr,'(1x,f12.4,1x,f12.4,15(1x,g12.4))') & mean(i),sqrt(cov(ii)), (cov(ii-i+j),j=1,i) end do end if write(outstr,'(2(/a,i7),a,f5.1,a)') & 'Number of variables =',nterms, & 'No. usable observations =',nobs, ' ( ', & float(100*nobs)/float(ntot),'%)' if (typ == 3) then write(outstr,'(/a)') 'Variances for the principal components' call eigen(1, nterms, cov, loadings) write(outstr,'(9x,6(1x,g10.4,:))') (cov(j), j=nterms,1,-1) den=0.0d0 do i=1, nterms den=den+cov(i) end do do i=1, nterms cov(i)=cov(i)/den end do write(outstr,'(a)') 'Proportion of total variance due to each component' write(outstr,'(9x,6(2x,f5.3,4x,:))') (cov(j), j=nterms,1,-1) write(outstr,'(a)') 'Loadings of each variable on components' do i=1, nterms write(outstr,'(a10,6(f7.4,4x,:))') & loc(terms(i)), (loadings(i,j), j=nterms,1,-1) end do end if end subroutine docov ! ! Fit mixture of distributions to quantitative trait ! subroutine domix(locnam, trait, nmix, typ, histcat, outfil, dataset, & logl, df, nwid, ndec, plevel) use outstream use ped_class use contingency_table implicit none character (len=*), intent(in) :: locnam integer, intent(in) :: trait integer, intent(in) :: nmix integer, intent(in) :: typ, histcat character (len=*), intent(in) :: outfil type (ped_data) :: dataset double precision :: logl integer :: df integer, intent(in) :: plevel integer, intent(in) :: nwid, ndec ! integer, parameter :: MISS=-9999 ! Quantitative trait values type (table_data) :: table ! Parameter estimates double precision :: alpha(nmix), mean(nmix), sd(nmix) ! Likelihood contributions double precision, dimension(:,:), allocatable :: prob double precision, dimension(:), allocatable :: den ! local variables integer :: i, ifail, j, ped, pedoffset ! call setup_table(1, 100, table) ! write(outstr,'(/a/3a/a)') & '------------------------------------------------', & 'Mixture distributions for trait "', trim(locnam), '"', & '------------------------------------------------' ! Tabulate sorted values and frequencies do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (dataset%plocus(i,trait) /= MISS) then call insert_table(1, dataset%plocus(i, trait), table, 1) end if end do end if end do call sort_table(table) ! ! Produce a histogram with HISTCAT intervals ! call dohist(locnam, min(table%ncells, histcat), 1, table, nwid, ndec, outfil) if (plevel > -1) then call filliben(table, plevel) call symtest(table, plevel) end if allocate(prob(table%ncells, nmix)) allocate(den(table%ncells)) call fitmix(nmix, typ, table, prob, den, alpha, mean, sd, logl, df, plevel) end subroutine domix ! ! Fit mixture of distributions to univariate tabulated data ! subroutine fitmix(nmix, typ, table, prob, den, alpha, mean, sd, logl, df, plevel) use outstream use contingency_table implicit none integer, intent(in) :: nmix integer, intent(in) :: typ ! Quantitative trait values type (table_data), intent(in) :: table ! Likelihood contributions double precision, dimension(table%ncells,nmix) :: prob double precision, dimension(table%ncells) :: den double precision, dimension(table%ncells) :: val ! Parameter estimates double precision :: alpha(nmix), mean(nmix), sd(nmix) double precision :: logl integer :: df integer, intent(in) :: plevel ! integer, parameter :: MISS=-9999 ! local variables integer :: i, ifail, j, ped, pos, pedoffset double precision :: inita, initsd character (len=10), dimension(5) :: dist=(/ & ' Normal ','Norm: 1 SD','Exponentl ','Poisson ','Binomial '/) ! ! starting values for mixture ! ifail=0 inita=1.0d0/dble(nmix) initsd=sqrt(table%categories(table%idx(max(1,3*table%ncells/4)),1)%rvalue - & table%categories(table%idx(max(1,table%ncells/4)),1)%rvalue) if (initsd <= 0.0d0) initsd=0.01d0 do i=1, nmix alpha(i)=inita pos=i*table%ncells/(nmix+1) if (pos < 1) pos=1 mean(i)=table%categories(pos,1)%rvalue sd(i)=initsd if (typ == 4) sd(i)=sqrt(mean(i)) end do ! call table_r_array(table, val) call mixture(typ, nmix, table%ncells, val, table%icount, & alpha, mean, sd, prob, den, table%ntot, logl, ifail, plevel) df=nmix if (typ==1) df=df+nmix if (typ==2) df=df+1 logl=-logl-logl ! if (plevel > 1) then write(outstr,'(/a/a)') & ' Rank Trait value Obs Posterior probabilities ', & ' -------------------------------------------------------' do j=1, table%ncells write(outstr,'(1x,i4,2x,f12.4,i8,5(2x,f5.3):)') & j, val(j), table%icount(j), (alpha(i)*prob(j,i)/den(j), i=1, nmix) end do end if if (ifail /= 0) then write(outstr,'(/a,i0,a,i0,a/)') & 'ERROR: Problem encountered in estimating ', nmix, & ' mixtures model IFAIL=', ifail,'.' end if if (plevel > -1) then write(outstr,'(/2a,3(/a,i8),/a,f13.4)') & 'Distribution type = ', dist(typ), & 'No. of distributions = ', nmix, & 'No. of observations = ', table%ntot, & 'No. of unique values = ', table%ncells, & '-2*Loglikelihood = ', logl write(outstr,'(2(/a))') & ' Dist Mean Standard Dev Proportion', & ' ---------------------------------------------' do i=1, nmix write(outstr,'(1x,i4,1x,f14.4,2x,f12.4,2x,f6.4)') i, mean(i), sd(i), alpha(i) end do end if end subroutine fitmix ! ! Fit mixture of distributions ! Algorithm AS 203 (Appl Stat 1984; 33:327-332) ! subroutine mixture(a, k, m, x, n, alpha, mean, sd, f, g, nobs, logl, ifail, plevel) use outstream use statfuns ! ! a=distribution type Nor(k sd) Nor(1 sd) Exp Poi Bin ! k=number of mixture distributions 1..MAXMIX ! m=number of classes 1..MAXSIZ ! integer, intent(in) :: a, k, m ! ! Data: value and number of observations for that value ! double precision, intent(in) :: x(m) integer, intent(in) :: n(m) ! ! Parameter estimates ! double precision, intent(inout) :: alpha(k) double precision, intent(inout) :: mean(k) double precision, intent(inout) :: sd(k) ! ! Likelihood contributions ! double precision, intent(out) :: f(m,k) double precision, intent(out) :: g(m) integer, intent(in) :: nobs double precision, intent(out) :: logl integer, intent(out) :: ifail integer, intent(in) :: plevel ! Local variables integer, parameter :: MAXEMITER = 2000 double precision, parameter :: tol=1.0D-6, one=1.0d0 logical :: test integer :: counter double precision :: oldlogl, part, poolv, poolsd, sumalpha ! Updated estimates double precision :: nalpha(k), nmean(k), nsd(k), & dt(k), nt(k), vt(k) ifail=0 oldlogl=0.0 counter=0 test=.false. ! ! While construct ! do while (.not.test) if (plevel > 2) then write(outstr,'(/a,i5,a,f13.4,a,i2/)') & 'Iter:', counter, ' LL:', oldlogl, ' Ifail:', ifail do j=1,k write(outstr,'(1x,i4,1x,f12.4,2x,f12.4,2x,f6.4)') j, mean(j), sd(j), alpha(j) end do end if counter=counter+1 if (counter > MAXEMITER) then ifail=1 exit end if do j=1, k if ((alpha(j) > 1) .or. (alpha(j) <= 0)) then ifail=2 return end if if (a < 3) then if ((mean(j) >= x(m)) .or. (mean(j) <= x(1))) then ifail=3 return end if if (sd(j) <= 0) then ifail=4 return end if else if ((mean(j) > x(m)) .or. (mean(j) < x(1))) then ifail=3 return end if end if end do do i=1, k-1 do j=i+1, k if (mean(i) == mean(j)) then if (a < 3) then if (sd(i) == sd(j)) then ifail=9 return end if else ifail=8 return end if end if end do end do ! ! actual start of EM algorithm a=1-2 Gauss 3 Exp 4 Poisson 5 Binomial ! logl=0.0d0 do i=1, m g(i)=0.0d0 do j=1, k if (a < 3) then f(i,j)=exp(-0.5*((x(i)-mean(j))/sd(j))**2)/sd(j) else if (a == 3) then f(i,j)=exp(-x(i)/mean(j))/mean(j) else if (a == 4) then f(i,j)=exp(dpois(x(i), mean(j))) else if (i == 1) then f(i,j) = (one - mean(j) / x(m))**x(m) * & (mean(j) / (x(m) - mean(j)))**x(i) else f(i,j) = f(i-1,j) * (mean(j) / (x(m) - mean(j))) end if end if g(i)=g(i)+alpha(j)*f(i,j) end do if (g(i) > 1.0D-25) then logl=logl+n(i)*log(g(i)) end if end do ! ! calcs probability densities of the subpopulations which form the ! the mixture, and the loglikelihood function ! test=.true. sumalpha=0.0d0 ! poolv=0.0d0 do j=1, k nt(j)=0.0d0 dt(j)=0.0d0 vt(j)=0.0d0 do i=1, m if (g(i) > 1.0D-25) then part=f(i,j)*n(i)/g(i) else part=0.0D0 end if dt(j)=dt(j)+part nt(j)=nt(j)+part*x(i) if (a < 3) then vt(j)=vt(j)+part*(x(i)-mean(j))**2 poolv=poolv+alpha(j)*part*(x(i)-mean(j))**2 end if end do ! ! calc denominators and numerators of new estimates ! nmean(j)=nt(j)/dt(j) if (j /= k) then nalpha(j)=alpha(j)*dt(j)/dble(nobs) sumalpha=sumalpha+nalpha(j) else nalpha(k)=one-sumalpha end if if (a < 3) then nsd(j)=sqrt(vt(j)/dt(j)) end if ! if (abs(oldlogl-logl) > tol) then test= .false. end if ! oldlogl=logl alpha(j)=nalpha(j) mean(j)=nmean(j) if (a < 3) then sd(j)=nsd(j) end if end do if (a == 2) then poolsd=sqrt(poolv/dble(nobs)) do j=1, k sd(j)=poolsd end do end if end do ! ! variances for other distributions ! if (a == 3) then do j=1, k sd(j)=mean(j) end do else if (a == 4) then do j=1, k sd(j)=sqrt(mean(j)) end do else if (a == 5) then do j=1, k sd(j)=sqrt(mean(j)*(one-mean(j))/x(m)) end do end if end subroutine mixture ! ! linear regression analysis of quantitative trait ! typ ! -2 SNP regression ! -1 run silently ! 0 regression summary table ! 1 calculate residuals ! 2 imputation ! 3 predicted value ! subroutine regress(typ, nterms, terms, nloci, loc, loctyp, locpos, & gene, genemod, allele_buffer, dataset, & mlik, mpar, pval, plevel) use outstream use AS164 use AS164_class use alleles_class use ped_class use locus_types use covariate_data use read_data use statfuns implicit none integer, intent(in) :: typ ! position of y and x variables integer, intent(in) :: nterms integer, dimension(:), intent(inout) :: terms integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp integer, intent(in) :: gene integer, intent(in) :: genemod ! alleles for first marker (will generate numal-1 dummy variables) type (allele_data), intent(inout) :: allele_buffer type (ped_data) :: dataset double precision, intent(out) :: mlik integer, intent(out) :: mpar double precision, intent(out) :: pval integer, intent(in) :: plevel ! local variables double precision, parameter :: delta=1.0d-5 double precision, parameter :: eps=1.0d-6 integer, parameter :: KNOWN=0, MISS=-9999 ! regression work arrays (b and cov are in AS164_class) double precision, dimension(nterms) :: mean double precision, dimension(:), allocatable :: x type (table_cell), dimension(1) :: values ! levels of covariates type (variable_data) :: covariates ! ! local variables integer :: a1, a2, genelevels, i, icat, ifail, ii, ityp, j, k, ncat, & nchange, ncov, nfix, nobs, nter, ntot, ped, pos, ycol, ypos, vpos logical :: comp, fussy double precision :: afreq, asyp ! regression results integer :: idf, mdf double precision :: aic, mss, pred, rsq, rss, tval character (len=3) :: allel, all2, histo character (len=20) :: label ! functions ! zp integer :: clcpos, getnam character (len=6) :: pstring double precision :: ln pval=1.0d0 ypos=terms(nterms) if (typ >= 0) then write(outstr,'(/a/3a/a)') & '------------------------------------------------', & 'Linear regression analysis of trait "', trim(loc(ypos)),'"', & '------------------------------------------------' end if mlik=0.0d0 mpar=0 call varlevels(COMPLETE_OBS, gene, allele_buffer%numal, nterms, terms, & loc, loctyp, locpos, dataset, covariates, plevel) nfix=covariates%totvars+1 genelevels=0 if (gene > 0) then if (genemod == 1) then genelevels=allele_buffer%numal-1 else genelevels=allele_buffer%numgtp-1 end if nfix=nfix-1+genelevels end if icat=0 do j=1, nterms pos=terms(j) if (pos == gene) then if (genelevels < 1) then write(outstr,'(3a,i0,a)') & 'NOTE: ', trim(loc(pos)), ' has only ', genelevels+1, ' levels.' end if else if (loctyp(pos) == LOC_CAT) then icat=icat+1 ncat=covariates%martable(icat)%ncells if (ncat < 2) then write(outstr,'(3a,i0,a)') & 'NOTE: ', trim(loc(pos)), ' has only ', ncat, ' levels.' end if end if end do nobs=0 ntot=0 ifail=0 nter=nfix+1 ncov=nter*(nter+1)/2 ! ! allocate work arrays ! allocate(x(nter)) if (allocated(b)) then deallocate(b) deallocate(cov) end if if (allocated(r)) then deallocate(r) end if allocate(b(nter)) allocate(cov(ncov)) allocate(r(ncov)) call inicov(nter, ncov, r) do j=1, nterms mean(j)=0.0d0 end do nobs=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i= dataset%num(ped-1)+1, dataset%num(ped) if (complete(.false., i, nterms, terms, locpos, loctyp, dataset)) then nobs=nobs+1 icat=0 vpos=1 x(vpos)=1.0d0 do j=1, nterms pos=terms(j) if (pos == gene) then do k=1, genelevels x(vpos+k)=0.0d0 end do call get_geno(i, locpos(gene), locpos(gene)+1, dataset, a1, a2) a1=getnam(a1, allele_buffer)-1 a2=getnam(a2, allele_buffer)-1 if (genemod == 1) then if (a1 > 0) x(vpos+a1)=x(vpos+a1) + 1 if (a2 > 0) x(vpos+a2)=x(vpos+a2) + 1 else k=clcpos(a1+1, a2+1)-1 if (k > 0) x(vpos+k)=x(vpos+k)+1 end if vpos=vpos+genelevels else if (ismarker(loctyp(pos))) then call get_geno(i, locpos(pos), locpos(pos)+1, dataset, a1, a2) vpos=vpos+1 x(vpos)=0.5d0*dble(a1+a2) mean(j)=mean(j)+x(vpos) else if (loctyp(pos) == LOC_AFF) then vpos=vpos+1 x(vpos)=dataset%plocus(i,locpos(pos))-1.0d0 mean(j)=mean(j)+x(vpos) else if (loctyp(pos) == LOC_CAT) then icat=icat+1 ncat=covariates%martable(icat)%ncells-1 do k=1, ncat x(vpos+k)=0.0d0 end do call set_table_cell(values(1), rvalue=dataset%plocus(i,locpos(pos))) ii=search_table(1, values, covariates%martable(icat), 0)-1 if (ii > 0) x(vpos+ii)=x(vpos+ii) + 1 vpos=vpos+ncat else if (loctyp(pos) == LOC_SPECIAL) then vpos=vpos+1 call autovar(i, locpos(pos), nloci, loctyp, locpos, dataset, x(vpos)) mean(j)=mean(j)+x(vpos) else vpos=vpos+1 x(vpos)=dataset%plocus(i,locpos(pos)) mean(j)=mean(j)+x(vpos) end if end do call givenc(r, ncov, nter, x, 1.0d0, ifail) end if end do ntot=ntot+dataset%num(ped)-dataset%num(ped-1) end if end do do j=1, nterms mean(j)=mean(j)/dble(nobs) end do call alias(r, ncov, nter, 1.0d-15, x, ifail) call bsub(r, ncov, nter, b, nter-1, ifail) call var(r, ncov, cov, ncov, nter, nobs, 1, ifail) if (typ >= 0) then write(outstr,'(/a/a)') & ' Variable Beta Stand Error t-Value', & ' ---------------------------------------------------------' end if i=1 ii=1 mdf=0 mss=0.0d0 tval=abs(b(i))/sqrt(cov(ii)) asyp=zp(tval) call phist(asyp, 1.0d0, histo) if (typ >= 0) then write(outstr,'(2x,a9,6x,f12.4,3x,f12.4,3x,f12.4,1x,a3)') & 'Intercept', b(i), sqrt(cov(ii)), tval, histo end if call sscomp(r, ncov, nter, nobs, 1, rss, idf, ifail) icat=0 do j=1, nterms-1 pos=terms(j) ncat=1 if (pos == gene) then ncat=genelevels a1=1 a2=1 else if (loctyp(pos) == LOC_CAT) then icat=icat+1 ncat=covariates%martable(icat)%ncells-1 end if do k=1, ncat label=loc(pos) if (pos == gene) then if (genemod == 1) then call wrall(allele_buffer%allele_names(k), all2) call wrall(allele_buffer%allele_names(k+1), allel) afreq=allele_buffer%allele_freqs(k+1) label=label(1:min(10,len_trim(label))) // '*' // trim(adjustl(allel)) else a2=a2+1 if (a2 > allele_buffer%numal) then a1=a1+1 a2=a1 end if call wrall(allele_buffer%allele_names(a1), allel) call wrall(allele_buffer%allele_names(a2), all2) label=label(1:min(8,len_trim(label))) // '*' // & trim(adjustl(allel)) // '/' // trim(adjustl(all2)) end if else if (ncat > 1) then write(allel, '(i3)') k+1 label=label(1:min(10,len_trim(label))) // '*' // trim(adjustl(allel)) end if i=i+1 ii=ii+i if (typ >= 0) then tval=abs(b(i))/sqrt(cov(ii)) call phist(zp(tval), 1.0d0, histo) write(outstr,'(2x,a14,1x,f12.4,3x,f12.4,3x,f12.4,1x,a3)') & label,b(i),sqrt(cov(ii)), tval, histo else if (typ == -2 .and. pos == gene) then tval=0.0d0 if (abs(cov(ii)) /= 0) tval=abs(b(i))/sqrt(cov(ii)) pval=zp(tval) if (plevel > -1) then write(outstr,'(a20,a1,a6,a1,f4.2,a1,i6,a1,g10.4,a1,g10.4,a1,g10.4,4a)') & loc(pos), tabsep, trim(adjustl(allel)) // tabsep // & trim(adjustl(all2)), tabsep, afreq, tabsep, nobs, tabsep, & b(i), tabsep, sqrt(cov(ii)), tabsep, tval, tabsep, & pstring(pval), tabsep, 'SNP' end if end if call sscomp(r, ncov, nter, nobs, i, rss, idf, ifail) mdf=mdf+idf mss=mss+rss end do end do call sscomp(r, ncov, nter, nobs, 0, rss, idf, ifail) mlik=dble(nobs) * (ln(mss+rss)-ln(rss)) mpar=idf if (typ >= 0) then rsq=1.0d0-rss/(rss+mss) mss=mss/dble(mdf) rss=rss/dble(idf) aic=log(rss)+2.0d0*dble(mdf)/dble(nobs) write(outstr,'(/a,i7,a,f5.1,a,2(/a,g12.4,a,i0,a),2(/a,g12.4))') & 'No. usable observations =', nobs, & ' ( ',float(100*nobs)/float(ntot), '%)', & 'Model Mean Square =', mss, ' (df=',mdf,')', & 'Mean Square Error =', rss, ' (df=',idf,')', & 'Multiple R**2 =', rsq, 'Akaike Inf. Criterion =', aic end if ! ! Write out residuals or predicted values if requested ! if (typ < 1) return ityp=typ nchange=0 fussy=(typ > 10) if (fussy) ityp=typ-10 ycol=locpos(ypos) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) comp=.true. icat=0 vpos=1 pred=b(vpos) do j=1, nterms-1 pos=terms(j) if (pos == gene) then call get_geno(i, locpos(gene), locpos(gene)+1, dataset, a1, a2) a1=getnam(a1, allele_buffer)-1 a2=getnam(a2, allele_buffer)-1 if (a1 > 0) pred=pred+b(vpos+a1) if (a2 > 0) pred=pred+b(vpos+a2) vpos=vpos+allele_buffer%numal-1 else if (ismarker(loctyp(pos))) then vpos=vpos+1 if (.not.observed(i, locpos(pos), dataset)) then comp=.false. pred=pred+b(vpos)*mean(j) else call get_geno(i, locpos(pos), locpos(pos)+1, dataset, a1, a2) pred=pred+b(vpos)*0.5d0*dble(a1+a2) end if else if (dataset%plocus(i,locpos(pos)) == MISS) then vpos=vpos+1 comp=.false. pred=pred + b(vpos)*mean(j) else if (loctyp(pos) == LOC_AFF) then vpos=vpos+1 pred=pred + b(vpos)*(dataset%plocus(i,locpos(pos))-1.0d0) else if (loctyp(pos) == LOC_CAT) then icat=icat+1 ncat=covariates%martable(icat)%ncells-1 do k=1, ncat x(vpos+k)=0.0d0 end do ii=search_table(1, values, covariates%martable(icat), plevel-2) if (ii > 1) pred=pred+b(vpos+ii) vpos=vpos+ncat else vpos=vpos+1 pred=pred+ b(vpos)*dataset%plocus(i,locpos(pos)) end if end do if (.not.fussy .or. (fussy .and. comp)) then if (ityp == 1 .and. dataset%plocus(i,ycol) /= MISS) then nchange=nchange+1 dataset%plocus(i,ycol)=dataset%plocus(i,ycol)-pred else if (ityp == 3 .or. & (ityp == 2 .and. dataset%plocus(i,ycol) == MISS)) then nchange=nchange+1 dataset%plocus(i,ycol)=pred end if else if (ityp == 1) then dataset%plocus(i,ycol)=MISS end if end do end if end do if (ityp == 1) then write(outstr,'(/a,i6,3a)') & 'Wrote ', nchange, ' residuals to ', trim(loc(ypos)), '.' else write(outstr,'(/a,i6,3a)') & 'Wrote ', nchange, ' predicted values to ', trim(loc(ypos)), '.' end if end subroutine regress ! ! Binomial (ilink=2), Poisson (ilink=3), ! Weibull (ilink=4), Exponential (ilink=5), EVD (ilink=6) regression analysis ! subroutine binreg(ilink, nterms, terms, nloci, loc, loctyp, locpos, & offset, censor, gene, genemod, allele_buffer, & mcp, useimp, fixshape, iter, mincnt, & dataset, wshap, mlik, mpar, statval, pval, plevel) use interrupt use outstream use glm_types use AS164 use AS164_class use alleles_class use ped_class use locus_types use covariate_data use rngs use statfuns implicit none integer, intent(in) :: ilink ! position of y and x variables integer, intent(in) :: nterms integer, dimension(:), intent(inout) :: terms integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp integer, intent(in) :: offset integer, intent(in) :: censor integer, intent(in) :: gene integer, intent(in) :: genemod ! alleles for first marker (will generate numal-1 dummy variables) type (allele_data), intent(inout) :: allele_buffer logical, intent(in) :: mcp ! MC P-value for first marker logical, intent(in) :: useimp ! Use imputed genotypes for association logical, intent(in) :: fixshape ! Shape parameter fixed integer, intent(in) :: iter, mincnt type (ped_data) :: dataset double precision, intent(inout) :: wshap ! model likelihood and degrees of freedom double precision, intent(out) :: mlik integer, intent(out) :: mpar double precision, dimension(3), intent(out) :: statval double precision, intent(out) :: pval integer, intent(in) :: plevel ! local variables double precision, parameter :: delta=1.0d-5 double precision, parameter :: eps=1.0d-6 integer, parameter :: KNOWN=0, MISS=-9999 ! regression work arrays b and cov are in AS164_class double precision, dimension(:,:), allocatable :: x double precision, dimension(:), allocatable :: offval, v, y double precision, dimension(1) :: values ! levels of covariates type (variable_data) :: covariates ! for marker association test integer, dimension(:,:), allocatable :: set integer :: itused, tailp double precision :: mchisq, mbeta, vchisq, vbeta ! ! nfix=number of fixed effects (including dummy variables) ! nter=nfix+1 (the trait) ! integer :: a1, a2, betapos, genelevels, gpos, ifail, i, icat, ii, it, j, k, & ncat, ncov, nfix, nobs, nter, ntot, & ped, pedoffset, pos, nvar, vpos, ypos double precision :: adjust ! regression results integer :: bsign, naff double precision :: base, oldshap, scaleval, shap, simlik, tval, halfwidth character (len=3) :: allel, all2, histo character (len=9) :: cval1, cval2 character (len=20) :: label ! functions ! zp integer :: clcpos, getnam character (len=6) :: pstring double precision :: ln interface subroutine simped(ped, dataset, allele_buffer, set) use alleles_class use ped_class integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data), intent(in) :: allele_buffer integer, dimension(:,:), intent(out) :: set end subroutine simped subroutine xsimped(ped, dataset, allele_buffer, set) use alleles_class use ped_class integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data), intent(in) :: allele_buffer integer, dimension(:,:), intent(out) :: set end subroutine xsimped end interface betapos=0 genelevels=0 it=0 mpar=0 mlik=0.0D0 mchisq=0.0d0 mbeta=0.0d0 pval=1.0d0 statval=0.0d0 vchisq=0.0d0 vbeta=0.0d0 oldshap=wshap shap=wshap bsign=1 if (ilink >= GLM_WEIB .or. ilink <= GLM_EVD) bsign=-1 nvar=nterms ypos=terms(nterms) if (plevel >= 0) then write(outstr,'(/a/4a/a)') & '------------------------------------------------', & densid(ilink), ' regression analysis of trait "', trim(loc(ypos)),'"', & '------------------------------------------------' end if call varlevels(COMPLETE_OBS, gene, allele_buffer%numal, nterms, terms, & loc, loctyp, locpos, dataset, covariates, plevel) nfix=covariates%totvars+1 if (gene > 0) then if (genemod == 1) then genelevels=allele_buffer%numal-1 else genelevels=allele_buffer%numgtp-1 end if nfix=nfix+genelevels-1 end if if (offset /= MISS) then if (plevel >= 0) then write(outstr,'(3a)') 'Model offset: ', trim(loc(offset)), '.' end if nvar=nvar+1 terms(nvar)=offset end if if (censor /= MISS) then if (plevel >= 0) then write(outstr,'(3a)') & 'Censoring variable: ', trim(loc(censor)), '.' end if nvar=nvar+1 terms(nvar)=censor end if if (plevel > 0) then write(outstr, '(/4x,a/2x,a)') 'Variable Levels', repeat('-', 20) icat=0 do j=1, nterms-1 pos=terms(j) if (loctyp(pos) == LOC_CAT) then icat=icat+1 write(outstr,'(2x,a14,i4)') loc(pos), covariates%martable(icat)%ncells else if (loctyp(pos) == LOC_AFF) then write(outstr,'(2x,a14,i4)') loc(pos), 2 else if (pos == gene) then write(outstr,'(2x,a14,i4)') loc(pos), genelevels+1 else write(outstr,'(2x,a14,i4)') loc(pos), 1 end if end do end if naff=0 nobs=0 ntot=0 ifail=0 nter=nfix+1 ncov=nter*(nter+1)/2 ! ! allocate work arrays ! do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (complete(useimp, i, nvar, terms, locpos, loctyp, dataset)) then nobs=nobs+1 end if end do end if end do allocate(y(nobs)) allocate(v(nobs)) allocate(offval(nobs)) allocate(x(nobs, nter)) if (allocated(b)) then deallocate(b) deallocate(cov) end if if (allocated(r)) then deallocate(r) end if allocate(b(nter)) allocate(r(ncov)) allocate(cov(ncov)) cov=0.0d0 ! ! copy phenotype data to work array, incl dummy coding for first marker ! adjust=0.0d0 if (loctyp(ypos) == LOC_AFF) adjust=1.0d0 nobs=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) ntot=ntot+1 dataset%untyped(i)=.true. if (complete(useimp, i, nvar, terms, locpos, loctyp, dataset)) then nobs=nobs+1 dataset%untyped(i)=.false. call fixeff(i, nobs, 1, gene, genemod, allele_buffer, useimp, & nterms, terms, & nloci, loctyp, locpos, covariates, dataset, x, 1) if (ilink == GLM_BINOM .or. ilink == GLM_POISS) then y(nobs)=dataset%plocus(i,locpos(ypos))-adjust offval(nobs)=0.0d0 if (offset /= MISS) then offval(nobs)=dataset%plocus(i,locpos(offset)) end if else y(nobs)=1.0d0 if (censor /= MISS) then y(nobs)=dataset%plocus(i, locpos(censor))-1.0d0 end if if (ilink == GLM_EVD) then offval(nobs)=dataset%plocus(i,locpos(ypos)) else offval(nobs)=ln(dataset%plocus(i,locpos(ypos))) end if end if if (ilink /= GLM_POISS .and. y(nobs) == 1.0d0) naff=naff+1 if (ilink == GLM_BINOM) then x(nobs, nter)=0.25d0*(y(nobs)-0.5d0-offval(nobs))-0.6931472d0 v=4.0d0 else x(nobs, nter)=ln(y(nobs)+offval(nobs)) v(nobs)=1.0d0/max(0.5d0, y(nobs)) end if end if end do end if end do ! Once round for binomial, poisson, exponential if (nobs > 0 .and. (ilink > GLM_BINOM .or. (naff /= 0 .and. naff /= nobs))) then if ((ilink /= GLM_WEIB .and. ilink /= GLM_EVD) .or. fixshape) then call fitbin(ilink, nobs, nter, ncov, & it, mlik, r, b, y, v, offval, x, shap, ifail, plevel) ! else iterate for Weibull shape parameter else do oldshap=shap call fitbin(ilink, nobs, nter, ncov, & ii, mlik, r, b, y, v, offval, x, shap, ifail, plevel) it=it+ii if (ifail == 0) then call weishape(nobs, naff, nter, b, y, offval, x, oldshap, shap) end if if (plevel > 1) then write(outstr,'(a, f6.3)') 'Weibull shape parameter=', shap end if if (abs(oldshap-shap) <= delta .or. ifail /= 0) exit end do end if mpar=nfix call var(r, ncov, cov, ncov, nter, nobs, 2, ifail) if (plevel >= 0) then write(outstr,'(/a/a)') & ' Variable Beta Stand Error t-Value', & ' ---------------------------------------------------------' end if i=1 ii=1 tval=0.0d0 if (cov(ii) > 0.0d0) tval=abs(b(i))/sqrt(cov(ii)) if (plevel >= 0) then call phist(zp(tval),1.0d0,histo) write(outstr,'(2x,a9,6x,f12.4,3x,f12.4,3x,f12.4,1x,a3)') & 'Intercept', bsign*b(i),sqrt(cov(ii)), tval, histo end if icat=0 do j=1, nterms-1 pos=terms(j) ncat=1 if (pos == gene) then ncat=genelevels a1=1 a2=1 else if (loctyp(pos) == LOC_CAT) then icat=icat+1 ncat=covariates%martable(icat)%ncells-1 end if do k=1, ncat i=i+1 ii=ii+i if (pos == gene .and. cov(ii) > 0.0d0) then betapos=i statval(1)=b(i) statval(2)=cov(ii) pval=zp(abs(b(i))/sqrt(cov(ii))) pval=pval+pval end if if (plevel >= 0) then label=loc(pos) if (pos == gene) then if (genemod == 1) then call wrall(allele_buffer%allele_names(k+1), allel) label=label(1:min(10,len_trim(label))) // '*' // trim(adjustl(allel)) else a2=a2+1 if (a2 > allele_buffer%numal) then a1=a1+1 a2=a1 end if call wrall(allele_buffer%allele_names(a1), allel) call wrall(allele_buffer%allele_names(a2), all2) label=label(1:min(8,len_trim(label))) // '*' // & trim(adjustl(allel)) // '/' // trim(adjustl(all2)) end if else if (ncat > 1) then write(allel, '(i3)') k+1 label=label(1:min(10,len_trim(label))) // '*' // trim(adjustl(allel)) end if tval=0.0d0 if (cov(ii) > 0.0d0) tval=abs(b(i))/sqrt(cov(ii)) call phist(zp(tval), 1.0d0, histo) write(outstr,'(2x,a14,1x,f12.4,3x,f12.4,3x,f12.4,1x,a3)') & label, bsign*b(i), sqrt(cov(ii)), tval, histo end if end do end do if (plevel >= 0) then write(outstr,'(/a,i7,a,f5.1,a)') 'No. usable observations =', nobs, & ' (',float(100*nobs)/float(ntot),'%)' if (ilink == GLM_BINOM) then write(outstr,'(a,i7/)') 'Number of affecteds =', naff else if (ilink == GLM_WEIB .or. ilink == GLM_EXPON .or. ilink == GLM_EVD) then write(outstr,'(a,i7,a,f5.1,a/)') 'No. of uncensored times =', naff, & ' (',float(100*naff)/float(nobs),'%)' end if if (ilink == GLM_WEIB .or. ilink == GLM_EVD) then write(outstr,'(a, f12.4)') 'Weibull shape parameter =', shap end if ! Base model deviance (intercept only) call glmscale(ilink, nobs, nter, b, y, offval, x, shap, scaleval) if (ilink == GLM_BINOM) then base=dble(naff)/dble(nobs) base=dble(naff)*log(base)+ dble(nobs-naff)*log(1.0d0-base) base=-base-base write(outstr,'(a,f12.4/a,i7/a,f12.4,a,i4,a,2(/a,f12.4))') & 'Null deviance =', base, 'Number of iterations =', it, & 'Model LR Chi-square =', base-mlik,' (df=',mpar-1,')', & 'Akaike Inf. Criterion =', dble(2*mpar)+mlik, & 'Estimated dispersion =', scaleval else write(outstr,'(a,i7/a,f12.4,a,i6,a,2(/a,f12.4))') & 'Number of iterations =', it, & 'Model LR Chi-square =', mlik,' (df=',nobs-mpar,')', & 'Akaike Inf. Criterion =', dble(2*mpar)+mlik, & 'Estimated dispersion =', scaleval end if end if ! ! Gene drop if appropriate ! if (mcp .and. iter > 0 .and. gene /= MISS) then allocate(set(dataset%maxsiz,2)) gpos=1 vpos=1 do j=1, nterms pos=terms(j) if (pos == gene) then gpos=vpos vpos=vpos+allele_buffer%numal-1 else vpos=vpos+1 end if end do ! ! Sequential Monte-Carlo P-value after Besag & Clifford Biometrika 1991 ! P= tailp/it if tailp=mincnt or (tailp+1)/(it+1) if tailp<mincnt && it=iter ! if (plevel > 1) then write(outstr,'(/a,i8,a,f12.4)') 'Original data', 0, ': lik=', mlik end if if (plevel > 2) then nobs=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1)+1 do i=pedoffset+1, dataset%num(ped) if (.not.dataset%untyped(i)) then nobs=nobs+1 call get_geno(i, locpos(gene), locpos(gene)+1, dataset, a1, a2) write(outstr,*) dataset%pedigree(ped), dataset%id(i), y(nobs), & a1, '/', a2, x(nobs, 1:nter), offval(nobs) end if end do end if end do end if it=0 itused=0 tailp=0 irupt=0 do while (it < iter .and. tailp < mincnt .and. irupt == 0) it=it+1 nobs=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) if (allele_buffer%xlinkd) then call xsimped(ped, dataset, allele_buffer, set) else call simped(ped, dataset, allele_buffer, set) end if do i=pedoffset+1, dataset%num(ped) if (.not.dataset%untyped(i)) then nobs=nobs+1 do k=1, genelevels x(nobs,gpos+k)=0.0 end do a1=set(i-pedoffset,1)-1 a2=set(i-pedoffset,2)-1 if (genemod == 1) then if (a1 > 0) x(nobs,gpos+a1)=x(nobs,gpos+a1) + 1 if (a2 > 0) x(nobs,gpos+a2)=x(nobs,gpos+a2) + 1 else k=clcpos(a1+1, a2+1)-1 if (k > 0) x(nobs,gpos+k)=x(nobs,gpos+k) + 1.0d0 end if if (ilink == GLM_BINOM) then x(nobs, nter)=0.25d0*(y(nobs)-0.5d0-offval(nobs))-0.6931472d0 v=4.0d0 else x(nobs, nter)=ln(y(nobs)+offval(nobs)) v(nobs)=1.0d0/max(0.5d0, y(nobs)) end if if (plevel > 2) then write(outstr,*) dataset%pedigree(ped), dataset%id(i), y(nobs), & set(i-pedoffset,1), '/', set(i-pedoffset,2), & x(nobs, 1:nter), offval(nobs) end if end if end do end if end do ! Once round for binomial, poisson, exponential if (ilink /= GLM_WEIB) then call fitbin(ilink, nobs, nter, ncov, & ii, simlik, r, b, y, v, offval, x, shap, ifail, plevel) ! else iterate for Weibull shape parameter else do oldshap=shap call fitbin(ilink, nobs, nter, ncov, & ii, simlik, r, b, y, v, offval, x, shap, ifail, plevel) if (ifail == 0) then call weishape(nobs, naff, nter, b, y, offval, x, oldshap, shap) end if if (plevel > 1) then write(outstr,'(a, f6.3)') 'Weibull shape parameter=', shap end if if (abs(oldshap-shap) <= delta .or. ifail/=0) exit end do end if if (ifail==0) then itused=itused+1 call moment(itused, b(betapos), mbeta, vbeta) call moment(itused, simlik, mchisq, vchisq) if (simlik < mlik .or. (simlik == mlik .and. random() > 0.5)) then tailp=tailp+1 end if if (plevel > 1) then write(outstr,'(a,i8,2(a,f12.4)/)') & 'Pseudosample ', it, ': lik=', simlik, ' beta=', b(betapos) end if else if (plevel > 0) then write(outstr,'(a, i8)') 'Due to IRLS failure, discarded Pseudosample ', it end if end do if (tailp < mincnt) then tailp=tailp+1 itused=itused+1 end if vchisq=vchisq/dble(max(1,itused-1)) pval=dble(tailp)/dble(itused) statval(3)=vbeta/dble(max(1,itused-1)) halfwidth=1.96d0*sqrt(statval(3)) if (plevel >= 0) then write(outstr,'(/3a)') & 'Gene-dropping association test for "', trim(loc(gene)), '"' if (allele_buffer%numal == 2) then if (statval(1) > 0.0d0) then call wrall(allele_buffer%allele_names(2), allel) else call wrall(allele_buffer%allele_names(1), allel) end if call juststr('l',allel,3) write(outstr,'(3a,f10.2,a,f10.2,a)') & 'Mean (SD) sim Beta(',allel ,') =', mbeta , ' (', sqrt(statval(3)), ')' write(cval1, '(f9.2)') exp(abs(statval(1))-halfwidth) write(cval2, '(f9.2)') exp(abs(statval(1))+halfwidth) write(outstr,'(3a,f10.2,5a)') & 'Exp(Beta) for allele ', allel, '=', exp(abs(statval(1))), ' (', & trim(adjustl(cval1)), ' -- ', trim(adjustl(cval2)), ')' end if write(outstr,'(a,i5,a,i6,3a/a,f12.4,a,f12.4,a)') & 'Equalled or exceeded by =', tailp, '/', itused, & ' simulated values (', trim(pstring(pval)), ')', & 'Mean (Var) sim deviance =', mchisq, ' (', vchisq, ')' end if deallocate(set) end if if (statval(3) == 0.0d0 .or. itused < 20) then statval(3)=statval(2) end if else if (nobs == 0) then write(outstr,'(/a)') 'No usable observations.' else if (naff == nobs) then write(outstr,'(/a)') 'Only affecteds with complete information.' else if (naff == 0) then write(outstr,'(/a)') 'Only unaffecteds with complete information.' end if end if if (wshap == MISS) wshap=shap end subroutine binreg ! ! Perform binomial (ilink=2) or poisson (ilink=3) regression IRLS, ! subroutine fitbin(ilink, nobs, nter, ncov, & it, x2, r, b, y, v, offval, x, shap, ierr, plevel) use outstream use glm_types integer, intent(in) :: ilink integer, intent(in) :: nobs integer, intent(in) :: nter integer, intent(in) :: ncov integer, intent(out) :: it double precision, intent(out) :: x2 double precision, intent(inout) :: r(ncov) double precision, intent(inout) :: b(nter) double precision, intent(inout) :: y(nobs) double precision, intent(inout) :: v(nobs) double precision, intent(inout) :: offval(nobs) double precision, intent(inout) :: x(nobs, nter) double precision, intent(in) :: shap integer, intent(out) :: ierr integer, intent(in) :: plevel ! local variables integer :: itmax, j double precision :: delta, oldx2 ierr=0 it=0 itmax=200 delta=1.0D-5 if (ilink == GLM_POISS) delta=5.0d-5 x2=-1.0D99 oldx2=-2.0D99 do while (it <= itmax .and. abs(x2-oldx2) >= delta .and. ierr == 0) it=it+1 oldx2=x2 call binirls(ilink, nobs, nter, ncov, x2, & r, b, y, v, offval, x, shap, ierr, plevel) if (plevel > 1) then write(outstr,'(i4,a,f16.4,6(1x,f9.4):)') & it, ': ',x2, (b(j), j=1, min(6, nter-1)) end if end do if (it > itmax) then write(outstr,'(/a,i3,a/)') 'NOTE: Exceeded max (',itmax,') iterations.' end if if (ierr /= 0) then write(outstr,'(/a/)') 'ERROR: IRLS failed (perhaps due to separation).' end if end subroutine fitbin ! ! One iteration of IRLS for binomial or poisson regression ! subroutine binirls(ilink, nobs, nter, nel, x2, & r, b, y, v, offval, x, shap, ierr, plevel) use outstream use glm_types use AS164 integer, intent(in) :: ilink integer, intent(in) :: nobs integer, intent(in) :: nter integer, intent(in) :: nel double precision, intent(out) :: x2 double precision, intent(inout) :: r(nel) double precision, intent(inout) :: b(nter) double precision, intent(inout) :: y(nobs) double precision, intent(inout) :: v(nobs) double precision, intent(in) :: offval(nobs) double precision, intent(inout) :: x(nobs, nter) double precision, intent(in) :: shap integer, intent(inout) :: ierr integer, intent(in) :: plevel double precision, parameter :: eps=1.0d-6 integer :: i, j, ifault double precision :: work(nter) double precision :: pred, z ! functions double precision :: alogit, logit call inicov(nter, nel, r) do i=1, nobs work(1:nter) = x(i, 1:nter) call givenc(r, nel, nter, work, v(i), ifault) end do call alias(r, nel, nter, 1.0d-15, work, ifault) if (ifault < 0 .and. plevel > 1) then write(outstr,*) 'NOTE: Parameter ',-ifault,' is aliased.' end if call bsub(r, nel, nter, b, nter, ierr) if (ierr /= 0 .and. plevel > 1) then write(outstr,*) 'IRLS Back subst IFAULT=', ierr end if x2=0.0d0 do i=1, nobs pred=0.0d0 do j=1, nter-1 pred=pred+b(j)*x(i, j) end do ! offset pred=pred+shap*offval(i) if (ilink == GLM_BINOM) then pred=alogit(pred) v(i)=1.0d0/pred/(1.0d0-pred) z=y(i)-pred x(i,nter)= logit(pred)-offval(i)+z*v(i) if (pred > eps .and. (1.0d0-pred) > eps) then if (y(i) == 1.0d0) then x2=x2-log(pred) else x2=x2-log(1.0d0-pred) end if end if else pred=exp(pred) v(i)=1.0d0/pred z=y(i)-pred x(i,nter)=log(pred)-shap*offval(i)+z*v(i) if (y(i) > eps .and. pred > eps) then x2=x2+y(i)*log(y(i)/pred) end if end if end do x2=x2+x2 end subroutine binirls ! ! Scale parameter for GLM ! subroutine glmscale(ilink, nobs, nter, b, y, offval, x, shap, scaleval) use glm_types integer, intent(in) :: ilink integer, intent(in) :: nobs integer, intent(in) :: nter double precision, intent(in) :: b(nter) double precision, intent(in) :: y(nobs) double precision, intent(in) :: offval(nobs) double precision, intent(in) :: x(nobs, nter) double precision, intent(in) :: shap double precision, intent(out) :: scaleval double precision, parameter :: eps=1.0d-6 integer :: i, j double precision :: dev, pred ! functions double precision :: alogit, logit scaleval=0.0d0 do i=1, nobs pred=0.0d0 do j=1, nter-1 pred=pred+b(j)*x(i, j) end do pred=pred+shap*offval(i) if (ilink == GLM_BINOM) then pred=alogit(pred) else pred=exp(pred) end if if (pred > eps) then dev=y(i)-pred scaleval=scaleval+dev*dev/pred end if end do scaleval=scaleval/dble(nobs-nter+1) end subroutine glmscale ! ! Estimate shape for Weibull distribution ! Use relaxation methods and hard limit on step size ! subroutine weishape(nobs, naff, nter, b, y, offval, x, alpha, alpha2) integer, intent(in) :: nobs integer, intent(in) :: naff integer, intent(in) :: nter double precision, intent(in) :: b(nter) double precision, intent(in) :: y(nobs) double precision, intent(in) :: offval(nobs) double precision, intent(inout) :: x(nobs, nter) double precision, intent(in) :: alpha double precision, intent(out) :: alpha2 ! regression work arrays etc integer :: i, j double precision :: ln, pred alpha2=0.0D0 do i=1, nobs pred=0.0d0 do j=1, nter-1 pred=pred+b(j)*x(i, j) end do pred=pred+alpha*offval(i) alpha2=alpha2+(exp(pred)-y(i))*offval(i)/dble(naff) end do if (alpha2<=0.0d0) then alpha2=alpha+1.0d0 else alpha2=0.5D0*(alpha+1.0D0/alpha2) end if if (alpha2-alpha > 2.0d0) alpha2=alpha+2.0d0 if (alpha2-alpha < -2.0d0) alpha2=alpha-2.0d0 do i=1, nobs x(i,nter)=ln(y(i)+offval(i)) end do end subroutine weishape ! ! Simulation P for RxC contingency table read from stdin ! subroutine rcp(typ, nr, nc, narg, args, iter) use outstream integer, intent(in) :: typ integer, intent(in) :: nr, nc integer, intent(in) :: narg character (len=*), dimension(narg) :: args integer, intent(in) :: iter ! local variables integer, dimension(nr*nc) :: tble double precision, dimension(nr*nc) :: e integer, dimension(2) :: rcshape integer :: df, i, j, idx, n, ncells logical :: badval double precision :: asyp, lrts, polyr ! functions double precision :: fval idx=0 ncells=nr*nc if (narg == (ncells+3)) then j=3 do i=1, ncells j=j+1 tble(i)=int(fval(args(j))) end do else if (narg > 3) then write(outstr,'(a,i0,a,i0,a/7x,a)') & 'ERROR: expected ',ncells,' counts rather than ', narg, '!', & 'Enter manually:' end if do i=1, nr write(*,'(a,i3,a,$)') 'row ',i,': ' read(*,*,err=100) (tble(j), j=idx+1, idx+nc) idx=idx+nc end do end if write(outstr,'(3x, 100(1x,i6,8x):)') (j, j=1,nc) write(outstr,*) badval=.false. idx=0 do i=1, nr n=sum(tble((idx+1):(idx+nc))) write(outstr,'(i3, 100(1x,i6,1x,a,f5.3,a):)') & i, (tble(j), '(', dfloat(tble(j))/dfloat(max(n,1)), ')', j=idx+1, idx+nc) idx=idx+nc end do write(outstr,*) if (minval(tble) >= 0) then if (typ == 2) then call poltest(nr, nc, tble) else call rctest(nr, nc, tble, e, iter) end if else write(outstr,'(a)') 'ERROR: Negative count!' end if return ! input error 100 write(outstr,'(a,i0,a)') 'ERROR: expected ',ncells,' counts!' end subroutine rcp ! ! Polychoric r and LRTS for RxC contingency table ! subroutine poltest(nr, nc, tble) use outstream use statfuns integer, intent(in) :: nr integer, intent(in) :: nc integer, dimension(nr*nc), intent(inout) :: tble integer, dimension(2) :: rcshape double precision, dimension(nr*nc) :: jr integer :: df, n double precision :: assocX2, asyp, dev, jse, mjr, modelX2, pcor, polyr ! functions character (len=6) :: pstring interface subroutine polycor(nr, nc, tab, polyr, assocX2, modelX2) use outstream use statfuns use brent_mft integer, intent(in) :: nr, nc integer, dimension(nr,nc), intent(in) :: tab double precision, intent(out) :: polyr double precision, intent(out) :: assocX2, modelX2 end subroutine polycor end interface rcshape(1)=nc rcshape(2)=nr call polycor(nr, nc, transpose(reshape(tble, rcshape)), polyr, assocX2, modelX2) ! Jackknife n=sum(tble) jr=polyr jse=0.0d0 do i=1, nr*nc if (tble(i) > 0) then tble(i)=tble(i)-1 call polycor(nr, nc, transpose(reshape(tble, rcshape)), jr(i), asyp, dev) tble(i)=tble(i)+1 jr(i)=dble(n)*polyr-dble(n-1)*jr(i) mjr=mjr+dble(tble(i))*jr(i) end if end do mjr=mjr/dble(n) do i=1, nr*nc dev=jr(i)-mjr jse=jse+dble(tble(i))*dev*dev end do jse=sqrt(jse/dble(max(1,n*(n-1)))) asyp=chip(assocX2,1) write(outstr,'(/a,f7.4/2(a,f7.4),a/a,g12.4,3a)') & 'Polychoric r = ', polyr, & 'Jackknife r = ', mjr, ' (SE=', jse, ')', & ' Assoc X2 = ', assocX2, ' (P=', pstring(asyp), ')' df=(nc-1)*(nr-1)-1 if (df > 0) then asyp=chip(modelX2, df) write(outstr,'(a,g12.4/a,i0/2a)') & 'Model fit X2 = ', modelX2, & ' df = ', df, & ' P-value = ', pstring(asyp) end if end subroutine poltest ! ! LRTS and Permutation P for RxC contingency table ! subroutine rctest(nr, nc, tble, e, iter) use outstream use statfuns integer, intent(in) :: nr integer, intent(in) :: nc integer, dimension(nr*nc), intent(inout) :: tble double precision, dimension(nr*nc), intent(inout) :: e integer, intent(in) :: iter ! local variables integer, dimension(nr) :: rows integer, dimension(nc) :: cols integer :: df, econ, ncon, ncells, tot double precision :: cov, dtot, mc, mh, mr, obschi, sc, sr, t1, t2 integer i, idx, j double precision :: pval ! functions ! chip character (len=6) :: pstring if (nr < 2 .or. nc < 2) return ncells=nr*nc cov=0.0d0 mc=0.0d0 mr=0.0d0 sc=0.0d0 sr=0.0d0 do i=1, nr rows(i)=0 end do do j=1, nc cols(j)=0 end do econ=0 ncon=0 tot=0 idx=0 do i=1, nr do j=1, nc idx=idx+1 tot=tot+tble(idx) rows(i)=rows(i)+tble(idx) cols(j)=cols(j)+tble(idx) mr=mr+dble(i-1)*tble(idx) mc=mc+dble(j-1)*tble(idx) end do end do dtot=1.0d0/dble(tot) mc=mc*dtot mr=mr*dtot idx=0 do i=1, nr do j=1, nc idx=idx+1 e(idx)=dble(rows(i))*dble(cols(j))*dtot cov=cov+tble(idx)*(dble(i-1)-mr)*(dble(j-1)-mc) sr=sr+tble(idx)*(dble(i-1)-mr)*(dble(i-1)-mr); sc=sc+tble(idx)*(dble(j-1)-mc)*(dble(j-1)-mc); end do end do call upchi(ncells, tble, e, obschi) ! if square table, calculate agreement and kappa if (nr == nc) then idx=1 do i=1, nr ncon=ncon+tble(idx) econ=econ+cols(i)*rows(i) idx=idx+nr+1 end do end if mh=dble(tot-1)*cov*cov/sr/sc df=(nr-1)*(nc-1) pval=chip(obschi,df) write(outstr,'(/a,i0/a,f7.1/a,i0)') & ' No. complete observations = ',tot, & ' LR contingency chi-square = ',obschi, & ' Degrees of freedom = ',df if (pval >= 0.0001d0) then write(outstr,'(a,f6.4)') & ' Asymptotic P-value = ', pval else write(outstr,'(a,g9.4)') & ' Asymptotic P-value = ', pval end if if (iter > 0) then call simchi(nr, rows, nc, cols, tble, e, obschi, tot, iter, pval) if (pval >= 0.0001d0) then write(outstr,'(14x,a,f6.4,a,i0,a)') 'Empiric P-value = ', pval, & ' (',10*tot*iter,' MCMC iterations)' else write(outstr,'(14x,a,g9.4,a,i0,a)') 'Empiric P-value = ', pval, & ' (',10*tot*iter,' MCMC iterations)' end if end if write(outstr,'(a,f7.2,2x,3a)') & ' Trend chi-square = ', mh, & ' (P=', trim(pstring(chip(mh,1))), ')' ! If square table, print agreement and kappa if (nr == nc) then t1=dble(ncon)*dtot t2=dble(econ)*dtot*dtot write(outstr,'(20x,a,3x,f5.3,1x,a,i0,a,i0,a)') 'Agreement =', & t1,' (', ncon, '/', tot, ')' write(outstr,'(16x,a,2x,f7.4)') 'Cohen''s Kappa =', (t1-t2)/(1.0d0-t2) end if end subroutine rctest ! ! MCMC a RxC contingency table retaining given margins ! subroutine simchi(nr, rows, nc, cols, tble, e, obschi, tot, iter, pval) use interrupt use rngs integer, intent(in) :: nr integer, dimension(nr), intent(inout) :: rows integer, intent(in) :: nc integer, dimension(nc), intent(inout) :: cols integer, dimension(nr*nc), intent(inout) :: tble double precision, dimension(nr*nc), intent(in out) :: e double precision, intent(in) :: obschi integer, intent(in) :: tot integer, intent(in) :: iter double precision, intent(out) :: pval integer :: c1, c2, eligc, eligr, i, incr, ip, it, ncells, r1, r2, isub(4) double precision :: chisq, qa pval=1.0d0 if (iter <= 0) return call mkchoose(nr, rows, eligr) call mkchoose(nc, cols, eligc) if (eligr < 2 .or. eligc < 2) return ncells=nr*nc ip=0 chisq=obschi do it=1, 10*iter if (irupt == 0) then ! dememorise by sampling each tot'th value do i=1, tot call choose(2, eligr, rows) call choose(2, eligc, cols) r1=rows(1) r2=rows(2) c1=cols(1) c2=cols(2) call order(r1,r2) call order(c1,c2) isub(1)=nc*(r1-1)+c1 isub(2)=nc*(r1-1)+c2 isub(3)=nc*(r2-1)+c1 isub(4)=nc*(r2-1)+c2 incr=2*irandom(1,2)-3 qa=0.0d0 if (incr == -1 .and. tble(isub(1)) > 0 .and. tble(isub(4)) > 0) then qa=min(1.0d0,dble(tble(isub(1))*tble(isub(4)))/ & dble((tble(isub(2))+1)*(tble(isub(3))+1))) else if (incr == 1 .and. tble(isub(2)) > 0 .and. & tble(isub(3)) > 0) then qa=min(1.0d0,dble(tble(isub(2))*tble(isub(3)))/ & dble((tble(isub(1))+1)*(tble(isub(4))+1))) end if ! If accepted, update table if (qa > random()) then tble(isub(1))=tble(isub(1))+incr tble(isub(2))=tble(isub(2))-incr tble(isub(3))=tble(isub(3))-incr tble(isub(4))=tble(isub(4))+incr end if end do call upchi(ncells, tble, e, chisq) if (chisq >= obschi) ip=ip+1 end if end do pval=dble(ip)/dble(it) end subroutine simchi ! ! LRTS for contingency table in MCMC ! subroutine upchi(ncells, tble, e, lrts) integer, intent(in) :: ncells integer, dimension(ncells), intent(in) :: tble double precision, dimension(ncells), intent(in) :: e double precision, intent(out) :: lrts double precision, parameter :: tol=1.0d-6 integer :: i, icount lrts=0.0d0 do i=1,ncells if (tble(i) > 0 .and. e(i) > tol) then icount=tble(i) lrts=lrts+dble(icount)*log(dble(icount)/e(i)) end if end do lrts=lrts+lrts end subroutine upchi ! ! Contingency table LRTS ! subroutine rclrts(nr, nc, tble, e, lrts, df) use outstream integer, intent(in) :: nr integer, intent(in) :: nc integer, dimension(nr*nc), intent(inout) :: tble double precision, dimension(nr*nc), intent(inout) :: e double precision, intent(out) :: lrts integer, intent(out) :: df ! local variables integer, dimension(nr) :: rows integer, dimension(nc) :: cols integer i, idx, j, ncells, tot double precision :: dtot lrts=0.0d0 df=(nr-1)*(nc-1) if (df < 1) return ncells=nr*nc do i=1, nr rows(i)=0 end do do j=1, nc cols(j)=0 end do tot=0 idx=0 do i=1, nr do j=1, nc idx=idx+1 tot=tot+tble(idx) rows(i)=rows(i)+tble(idx) cols(j)=cols(j)+tble(idx) end do end do dtot=1.0d0/dble(tot) idx=0 do i=1, nr do j=1, nc idx=idx+1 e(idx)=dble(rows(i))*dble(cols(j))*dtot end do end do call upchi(ncells, tble, e, lrts) end subroutine rclrts ! ! Load an array with indices of eligible choices (eg nonmissing alleles) ! subroutine mkchoose(ni, eligible , nelig) integer, intent(in) :: ni integer, intent(inout) :: eligible(ni) integer, intent(out) :: nelig integer :: i nelig=0 do i=1, ni if (eligible(i) > 0) then nelig=nelig+1 eligible(nelig)=i end if end do end subroutine mkchoose ! ! Shuffle array of indices so can randomly select combination from ! as first r elements ! subroutine choose(nch, ni, idx) use rngs integer, intent(in) :: nch integer, intent(in out) :: ni integer, intent(in out) :: idx(ni) integer :: i, pos, tmp do i=1, nch pos=irandom(1, ni) tmp=idx(pos) idx(pos)=idx(i) idx(i)=tmp end do end subroutine choose ! ! Make every individual and pedigree ID a unique number ! subroutine uniqid(typ, dataset, plevel) use outstream use ped_class implicit none integer, intent(inout) :: typ type (ped_data) :: dataset integer, intent(in) :: plevel ! integer, parameter :: MISS=-9999 integer :: famcnt, i, idbase, idno, nfam, ped, pedoffset, tot character (len=ped_width) :: oldpednam ! if (plevel > 0) then write(outstr,'(/a)') 'Original_ID New_ID' end if famcnt=int(10.0**int(max(3.0,1.0+log10(float(dataset%maxsiz))))) idbase=0 nfam=0 tot=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then oldpednam=dataset%pedigree(ped) pedoffset=dataset%num(ped-1) nfam=nfam+1 if (typ == 1) then idbase=idbase+famcnt idno=idbase else idno=tot end if write(dataset%pedigree(ped), '(i10)') nfam dataset%pedigree(ped)=adjustl(dataset%pedigree(ped)) do i=pedoffset+1, dataset%num(ped) idno=idno+1 if (plevel > 0) then write(outstr,'(a,1x,a,1x,2i10)') & trim(oldpednam), trim(dataset%id(i)), nfam, idno end if write(dataset%id(i), '(i10)') idno dataset%id(i)=adjustl(dataset%id(i)) end do tot=tot+dataset%num(ped)-pedoffset end if end do write(outstr,'(/a,i0,a)') 'Renamed ', nfam, ' pedigrees.' end subroutine uniqid ! ! Prune pedigree to ancestors shared by affecteds ! subroutine prunep(wrk, wrk2, locnam, trait, gt, thresh, dataset, plevel) use outstream use ped_class use comp_ops implicit none integer, intent(in) :: wrk integer, intent(in) :: wrk2 character (len=*), intent(in) :: locnam integer, intent(in) :: trait integer, intent(in) :: gt double precision, intent(in) :: thresh type (ped_data) :: dataset integer, intent(in) :: plevel ! local variables integer, parameter :: KNOWN=0, MISS=-9999 ! workfiles for family pointers etc integer, dimension(dataset%maxsiz,2) :: set integer, dimension(dataset%maxsiz) :: key, ord ! offset for pedigree position in dataset: original and after pruning integer :: pedoffset, newoffset ! updated overall pedigree information integer :: new_nped ! old overall pedigree information integer :: actset, nfound, num integer, dimension(NDATACLASS) :: numloc integer :: i, fap, mop, no, nf, naff, ped, pos, totno, totnum ! functions double precision :: dataset_uses, isaff numloc=dataset%numloc totno=0 totnum=0 new_nped=0 write(outstr,'(/a/3a/a)') & '--------------------------------------------------', & ' Pruning pedigrees of probands with trait "',trim(locnam),'"', & '--------------------------------------------------' if (gt > KNOWN) call defpro(gt, thresh, .true.) if (plevel > 1) then write(outstr,'(a/a/)') & ' Number of Pedigree Size', & 'Pedigree Index Cases Original New' end if open(wrk, status='scratch', form='unformatted') open(wrk2, status='scratch', form='unformatted') pedoffset=0 newoffset=0 do ped=1, dataset%nped actset=dataset%actset(ped) num=dataset%num(ped)-dataset%num(ped-1) nfound=dataset%nfound(ped) pedoffset=dataset%num(ped-1) if (actset <= 0) then call wrkout(wrk, wrk2, ped, dataset, new_nped, newoffset) else totnum=totnum+num naff=0 do i=pedoffset+1, dataset%num(ped) if (int(isaff(dataset%plocus(i,trait), thresh, gt)) == 2) then set(i-pedoffset,1)=1 set(i-pedoffset,2)=1 naff=naff+1 else set(i-pedoffset,1)=0 set(i-pedoffset,2)=0 end if ord(i-pedoffset)=0 end do ! Skip if nobody affected if (naff > 0) then ! ! Accumulate counts of descendents who are affected ! do i=dataset%num(ped), pedoffset+nfound+1, -1 set(dataset%fa(i)-pedoffset,1)=set(dataset%fa(i)-pedoffset,1)+set(i-pedoffset,1) set(dataset%mo(i)-pedoffset,1)=set(dataset%mo(i)-pedoffset,1)+set(i-pedoffset,1) end do ! Find MRCAs do i=pedoffset+nfound+1, dataset%num(ped) if (set(i-pedoffset,1) /= 0) then if (set(dataset%fa(i)-pedoffset,1) > set(i-pedoffset,1)) then set(dataset%fa(i)-pedoffset,2)=1 end if if (set(dataset%mo(i)-pedoffset,1) > set(i-pedoffset,1)) then set(dataset%mo(i)-pedoffset,2)=1 end if end if end do ! Add connectors and other parents, if needed do i=pedoffset+nfound+1, dataset%num(ped) if (set(i-pedoffset,1) /= 0) then if (set(dataset%fa(i)-pedoffset,2) /= 0) set(i-pedoffset,2)=1 if (set(dataset%mo(i)-pedoffset,2) /= 0) set(i-pedoffset,2)=1 end if if (set(i-pedoffset,2) /= 0) then if (set(dataset%fa(i)-pedoffset,2) /= 0) set(dataset%mo(i)-pedoffset,2)=1 if (set(dataset%mo(i)-pedoffset,2) /= 0) set(dataset%fa(i)-pedoffset,2)=1 end if end do ! New founders nf=0 do i=1, nfound if (set(i,2) /= 0) then nf=nf+1 ord(i)=nf end if end do do i=nfound+1, num if (set(i,2) /= 0 .and. & set(dataset%fa(pedoffset+i)-pedoffset,2) == 0 .and. & set(dataset%mo(pedoffset+i)-pedoffset,2) == 0) then nf=nf+1 ord(i)=nf dataset%imztwin(pedoffset+i)=MISS dataset%fa(pedoffset+i)=MISS dataset%mo(pedoffset+i)=MISS end if end do ! New nonfounders no=nf do i=nfound+1, num if (set(i,2) /= 0 .and. ord(i) == 0) then no=no+1 ord(i)=no if (dataset%imztwin(pedoffset+i) /= MISS) then dataset%imztwin(pedoffset+i)=newoffset + & ord(dataset%imztwin(pedoffset+i)-pedoffset) end if dataset%fa(pedoffset+i)=newoffset+ord(dataset%fa(pedoffset+i)-pedoffset) dataset%mo(pedoffset+i)=newoffset+ord(dataset%mo(pedoffset+i)-pedoffset) end if end do totno=totno+no ! write new pedigree if (plevel > 1) then write(outstr,'(a10,1x,i5,2(8x,i5))') dataset%pedigree(ped), naff, num, no end if do i=1,num if (ord(i) /= 0) then key(ord(i))=i end if end do new_nped=new_nped+1 write(wrk) dataset%pedigree(ped), actset, newoffset+no, nf do i=1, no pos=pedoffset+key(i) write(wrk2) dataset%id(pos), dataset%imztwin(pos), & dataset%fa(pos), dataset%mo(pos), & dataset%sex(pos), & dataset%glocus(pos,1:numloc(GCLASS)), & dataset%plocus(pos,1:numloc(PCLASS)) if (dataset%hassnps /= 0) then call matrix_write_row(pos, dataset%slocus, wrk2) end if end do newoffset=newoffset+no end if end if end do ! ! Read pedigrees back in ! call pedin(wrk, wrk2, new_nped, newoffset, numloc, numloc, dataset) close(wrk, status='delete') close(wrk2, status='delete') end subroutine prunep ! ! Write relatives of index ! subroutine relations(tped, tid, dataset, trait, typ, plevel) use outstream use alleles_class use locus_data use ped_class use string_utilities implicit none character (len=ped_width), intent(in) :: tped character (len=id_width), intent(in) :: tid type (ped_data) :: dataset integer, intent(in) :: plevel integer, intent(in) :: trait, typ ! integer, parameter :: MISS=-9999 integer, dimension(dataset%maxsiz) :: key ! for kinships: ! allele frequencies for each marker listed in mark integer :: nmark type (allele_array) :: alleles ! coefficients to estimate kinship coefficients from IBS double precision, dimension(:,:), allocatable :: ibscoef ! numerator relationship matrix double precision :: k0, k1, k2 double precision, dimension(:), allocatable :: kin integer :: cfa, cmo, eop, i, idx, ii, ndesc, nmat, nmh, noff, nph, nsibs integer :: num, ped, pedoffset, useful ! functions ! logical strfind interface subroutine load_allele_array(nloci, loctyp, locpos, dataset, nmark, alleles) use alleles_class use ped_class use locus_types integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data), intent(in) :: dataset integer, intent(out) :: nmark type (allele_array) :: alleles end subroutine load_allele_array subroutine ibskin_one(peri, perj, locpos, alleles, dataset, useful, ibscoef) use outstream use alleles_class use ped_class use locus_types integer, intent(in) :: peri, perj integer, dimension(:), intent(in) :: locpos type (allele_array) :: alleles type (ped_data), intent(in) :: dataset integer, intent(out) :: useful double precision, dimension(alleles%nmark,3), intent(out) :: ibscoef end subroutine ibskin_one subroutine prrel(iclass, ped, kin, dataset, key, eop, trait, typ) use ped_class implicit none integer, intent(in) :: iclass integer, intent(in) :: ped double precision, dimension(:), intent(in) :: kin type (ped_data) :: dataset integer, dimension(:), intent(in) :: key integer, intent(in) :: eop integer, intent(in) :: trait, typ end subroutine end interface ! eop=len_trim(tped) do ped=1, dataset%nped if (dataset%actset(ped) > 0 .and. strfind(tped, dataset%pedigree(ped), 1)) then do idx=dataset%num(ped-1)+1, dataset%num(ped) if (strfind(tid, dataset%id(idx), 1)) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset ! empirical kinships if (typ == 1000) then call load_allele_array(nloci, loctyp, locpos, dataset, nmark, alleles) allocate(ibscoef(nmark,3)) allocate(kin(num)) kin=MISS ii=0 do i=pedoffset+1, dataset%num(ped) ii=ii+1 call ibskin_one(idx, i, locpos, alleles, dataset, useful, ibscoef) if (useful > 0) then call emibskin(alleles%nmark, useful, ibscoef, k0, k1, k2, plevel) kin(ii)=k2+0.5d0*k1 end if end do deallocate(ibscoef) end if ndesc=0 nmh=0 noff=0 nph=0 nsibs=0 cfa=dataset%fa(idx) cmo=dataset%mo(idx) do i=1, num key(i)=0 end do key(idx-pedoffset)=1 if (idx > pedoffset+dataset%nfound(ped)) then ii=dataset%nfound(ped) do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped) ii=ii+1 if (i == idx) then continue else if (dataset%fa(i) == cfa .and. dataset%mo(i) == cmo) then nsibs=nsibs+1 key(ii)=-1 else if (dataset%fa(i) == cfa) then nph=nph+1 key(ii)=-2 else if (dataset%mo(i) == cmo) then nmh=nmh+1 key(ii)=-3 end if end do end if ii=dataset%nfound(ped) do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped) ii=ii+1 if (key(dataset%fa(i)-pedoffset) > 0 .or. key(dataset%mo(i)-pedoffset) > 0) then key(ii)=min(3,max(key(dataset%fa(i)-pedoffset), key(dataset%mo(i)-pedoffset))+1) ndesc=ndesc+1 if (dataset%fa(i) == idx .or. dataset%mo(i) == idx) then noff=noff+1 end if end if end do write(outstr,'(a//a,11x,3a)', advance='no') & 'Class N IDs', & 'Index', trim(dataset%pedigree(ped)),'-', trim(dataset%id(idx)) call appval(idx, trait, typ, kin(idx-pedoffset), dataset) write(outstr,*) if (cfa /= MISS) then write(outstr,'(a,9x,3a)', advance='no') 'Parents', & trim(dataset%pedigree(ped)), '-', trim(dataset%id(cfa)) call appval(cfa, trait, typ, kin(cfa-pedoffset), dataset) write(outstr,'(1x,3a)', advance='no') & trim(dataset%pedigree(ped)), '-', trim(dataset%id(cmo)) call appval(cmo, trait, typ, kin(cmo-pedoffset), dataset) write(outstr,*) end if write(outstr,'(a,4x,i3,$)') 'Siblings', nsibs call prrel(-1, ped, kin, dataset, key, eop, trait, typ) if (nph > 0) then write(outstr,'(a,i3,$)') 'Pat halfsibs', nph call prrel(-2, ped, kin, dataset, key, eop, trait, typ) end if if (nmh > 0) then write(outstr,'(a,i3,$)') 'Mat halfsibs', nph call prrel(-3, ped, kin, dataset, key, eop, trait, typ) end if write(outstr,'(a,3x,i3,$)') 'Offspring', noff call prrel(2, ped, kin, dataset, key, eop, trait, typ) write(outstr,'(a,i3,$)') 'Descendants ', ndesc call prrel(3, ped, kin, dataset, key, eop, trait, typ) ! Mates do i=1, num key(i)=0 end do key(idx-pedoffset)=1 do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped) if (key(dataset%fa(i)-pedoffset) == 1) then key(dataset%mo(i)-pedoffset)=2 else if (key(dataset%mo(i)-pedoffset) == 1) then key(dataset%fa(i)-pedoffset)=2 end if end do nmat=0 do i=1, num if (key(i) == 2) then nmat=nmat+1 end if end do write(outstr,'(a,3x,i3,$)') 'Mates ', nmat call prrel(2, ped, kin, dataset, key, eop, trait, typ) if ((plevel == 0 .and. num < 12) .or. plevel > 0) then call pairlink(ped, idx, dataset, plevel) end if end if end do end if end do end subroutine relations ! ! print list of relatives ! subroutine prrel(iclass, ped, kin, dataset, key, eop, trait, typ) use outstream use ped_class implicit none integer, intent(in) :: iclass integer, intent(in) :: ped type (ped_data) :: dataset double precision, dimension(:), intent(in) :: kin integer, dimension(:), intent(in) :: key integer, intent(in) :: eop integer, intent(in) :: trait, typ ! integer, parameter :: fc=17 integer, parameter :: lc=72 integer :: i, ii, pos ! function ! ii=0 pos=fc do i=dataset%num(ped-1)+1, dataset%num(ped) ii=ii+1 if (key(ii) == iclass) then pos=pos+eop+len_trim(dataset%id(i))+2 if (pos > lc) then pos=fc+eop+len_trim(dataset%id(i))+2 write(outstr,'(/14x,a1)', advance='no') ' ' end if write(outstr,'(1x,3a)', advance='no') & trim(dataset%pedigree(ped)), '-', trim(dataset%id(i)) call appval(i, trait, typ, kin(ii), dataset) end if end do write(outstr,*) end subroutine prrel ! ! append locus value if asked ! subroutine appval(idx, trait, typ, kin, dataset) use outstream use ped_class use locus_types implicit none integer, intent(in) :: idx, trait, typ double precision, intent(in) :: kin type (ped_data) :: dataset integer, parameter :: KNOWN=0, MISS=-9999 integer :: g1, g2 character (len=1) :: ch character (len=11) :: gtp if (typ == 1000) then if (kin == MISS) then write(outstr,'(a)', advance='no') ' (x)' else write(outstr,'(a,f4.2,a)', advance='no') ' (', kin ,')' end if else if (trait /= MISS) then if (typ == LOC_AFF) then ch='x' if (dataset%plocus(idx,trait) /= MISS) then call wraff(dataset%plocus(idx,trait), ch, 2) end if write(outstr,'(3a)', advance='no') ' (', ch ,')' else if (same_loctyp(typ, LOC_CAT) .or. & same_loctyp(typ, LOC_QUA)) then if (dataset%plocus(idx,trait) == MISS) then write(outstr,'(a)', advance='no') ' (x)' else write(gtp, '(g11.4)') dataset%plocus(idx,trait) write(outstr,'(3a)', advance='no') ' (', trim(adjustl(gtp)) ,')' end if else if (isactdip(typ)) then call get_geno(idx, trait, trait+1, dataset, g1, g2) if (g1 > KNOWN) then call wrgtp(g1, g2, gtp, '/', '', 1) else gtp='x/x' end if write(outstr,'(3a)', advance='no') ' (', trim(adjustl(gtp)) ,')' else if (same_loctyp(typ, LOC_HAP)) then call get_geno(idx, trait, trait+1, dataset, g1, g2) if (g1 > KNOWN) then call wrall(g1, gtp) else gtp='x/x' end if write(outstr,'(3a)', advance='no') ' (', trim(adjustl(gtp)) ,')' end if end if end subroutine appval ! ! Show relationship to ego: Djikstra's shortest path algorithm ! subroutine pairlink(ped, idx, dataset, plevel) use interrupt use outstream use ped_class implicit none integer, intent(in) :: ped, idx type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel ! local variables integer, parameter :: MISS=-9999 ! list of paths and length integer, dimension(:), allocatable :: dist logical, dimension(:), allocatable :: done integer, dimension(:,:), allocatable :: path integer :: num, pedoffset integer :: astat, cfa, cmo, curr, d, eon, i, ii, it, j, jj, n, p1, pos, shortest character (len=id_width) :: chid ! functions integer :: conlen pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset p1=idx-pedoffset allocate(dist(num), done(num), path(num, num), stat=astat) if (astat /= 0) then write(outstr,'(a)') & 'ERROR: Was not able to allocate memory for Djikstra shortest path algorithm.' return end if ! path=idx ii=pedoffset do i=1, num ii=ii+1 dist(i)=conlen(idx, ii, ped, dataset) done(i)=.false. path(i,1)=ii if (dist(i) == 1) then path(i,1)=ii end if end do done(p1)=.true. do it=1, num-2 shortest=dataset%maxact+2 do i=1, num if (.not.done(i)) then if (dist(i) < shortest) then shortest=dist(i) curr=i end if end if end do done(curr)=.true. ii=pedoffset do i=1, num ii=ii+1 d=conlen(pedoffset+curr, ii, ped, dataset) if ((dist(curr)+d) < dist(i)) then if (dist(i) < dataset%maxact) then jj=dist(curr) do j=1, dist(i) jj=jj+1 path(i,jj)=path(i,j) end do path(i,jj)=path(i,j) else jj=dist(curr)+1 path(i,jj)=path(i,1) end if do j=1, dist(curr) path(i,j)=path(curr,j) end do dist(i)=dist(curr)+d end if end do if (irupt /= 0) goto 999 end do write(outstr,*) n=1 do i=1, num if (dist(i) <= dataset%maxact .and. i /= p1) then n=n+1 call wrid('l',dataset%id(idx), chid, dataset%sex(idx)) write(outstr,'(a)',advance='no') trim(chid) d=idx do j=1, dist(i) curr=path(i,j) call wrid('l',dataset%id(curr), chid, dataset%sex(curr)) if (dataset%fa(d) == curr .or. dataset%mo(d) == curr) then write(outstr,'(2a)',advance='no') '<-', trim(chid) else write(outstr,'(2a)',advance='no') '->', trim(chid) end if d=curr end do write(outstr,*) if (irupt /= 0) goto 999 end if end do if (n < num) then write(outstr,'(/4a/)') & trim(dataset%pedigree(ped)),'--',trim(dataset%id(idx)), ' is unconnected to:' pos=0 do i=1, num if (dist(i) > dataset%maxact) then eon=len_trim(dataset%id(path(i,1))) pos=pos+eon+1 write(outstr,'(1x,a)', advance='no') trim(dataset%id(path(i,1))) pos=pos+1 call newlin(1,78,pos,eon+2) end if end do write(outstr,*) end if 999 continue deallocate(dist, done, path) end subroutine pairlink ! ! Are i and j a parent-offspring pair? ! function conlen(i, j, ped, dataset) use ped_class integer :: conlen integer, intent(in) :: i, j, ped type (ped_data), intent(in) :: dataset conlen=dataset%maxact+1 if (dataset%fa(i) == j) then conlen=1 else if (dataset%mo(i) == j) then conlen=1 else if (dataset%fa(j) == i) then conlen=1 else if (dataset%mo(j) == i) then conlen=1 end if end function conlen ! ! Find loops ! ! Marriage node representation ! Traverses depth-first with backtracking ! Trades time for space ;) ! ! Data structure: ! nodal backlink typelink ! ! nodal is the list of vertices 1..maxact are individuals with edge to mating ! maxact+1... are matings with edges to parents ! backlink contains the "thread" or point stack, and also the mark (negative) ! typelink shows direction of edge ! subroutine findloop(trait, dataset, plevel) use outstream use ped_class implicit none integer, intent(in) :: trait type (ped_data) :: dataset integer, intent(in) :: plevel integer, parameter :: MISS=-9999 integer, dimension(2*dataset%maxact,3) :: nodal integer, dimension(2*dataset%maxact) :: backlink, typelink integer :: nfound, num, ped, pedoffset integer :: cfa, cmo, cmat, dir, eos, i, idx, ii, it, nvisited, pos logical :: more character (len=2), dimension(3), parameter :: link = (/ '- ','->','<-' /) write(outstr,'(a/a)') & 'Pedigree Cycles', & '-------------------- ----------------------------------------' do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset nfound=dataset%nfound(ped) ii=pedoffset do i=1, nfound ii=ii+1 nodal(i,1)=ii nodal(i,2)=0 nodal(i,3)=0 backlink(i)=0 typelink(i)=0 end do cfa=MISS cmo=MISS cmat=dataset%maxact do i=nfound+1, num ii=ii+1 if (cfa /= dataset%fa(ii) .or. cmo /= dataset%mo(ii)) then cmat=cmat+1 cfa=dataset%fa(ii) cmo=dataset%mo(ii) nodal(cmat,1)=cmat-dataset%maxact nodal(cmat,2)=cfa-pedoffset nodal(cmat,3)=cmo-pedoffset backlink(cmat)=0 typelink(cmat)=0 end if nodal(i,1)=ii nodal(i,2)=cmat nodal(i,3)=0 backlink(i)=0 typelink(i)=0 end do nvisited=0 more=.true. idx=num it=0 scanner: do while (more) it=it+1 more=.false. ! looking upwards from a mating if (idx > dataset%maxact) then if (backlink(nodal(idx,2)) == 0) then nvisited=nvisited+1 backlink(nodal(idx,2))=idx typelink(nodal(idx,2))=1 idx=nodal(idx,2) more=.true. cycle scanner else if (backlink(nodal(idx,3)) == 0) then nvisited=nvisited+1 backlink(nodal(idx,3))=idx typelink(nodal(idx,3))=1 idx=nodal(idx,3) more=.true. cycle scanner end if ! looking upwards from a nonfounder else if (idx > nfound) then i=nodal(idx,2) if (backlink(i) == 0) then backlink(i)=idx typelink(i)=2 idx=i more=.true. cycle scanner else if (abs(backlink(i)) /= idx .and. abs(backlink(idx)) /= i) then backlink(i)=idx typelink(i)=2 more=.false. cycle scanner end if end if ! looking downwards from a mating if (idx > dataset%maxact) then do i=nfound+1, num if (nodal(i,2) == idx) then if (backlink(i) == 0) then nvisited=nvisited+1 backlink(i)=idx typelink(i)=3 idx=i more=.true. cycle scanner else if (abs(backlink(idx)) /= i .and. abs(backlink(i)) /= idx) then backlink(i)=idx typelink(i)=3 more=.false. cycle scanner end if end if end do ! looking downwards from an individual else do i=dataset%maxact+1, cmat if (nodal(i,2) == idx .or. nodal(i,3) == idx) then if (backlink(i) == 0) then nvisited=nvisited+1 backlink(i)=idx typelink(i)=1 idx=i more=.true. cycle scanner else if (abs(backlink(idx)) /= i .and. abs(backlink(i)) /= idx) then backlink(i)=idx typelink(i)=1 more=.false. cycle scanner end if end if end do end if ! Unable to progress, so backtrack if (backlink(idx) > 0) then i=backlink(idx) backlink(idx)=-backlink(idx) idx=i more=.true. end if end do scanner ! ! Write a cycle if found ! i=backlink(idx) if (i > 0) then if (trait /= MISS) then do ii=pedoffset+1, dataset%num(ped) dataset%plocus(ii, trait)=MISS end do end if write(outstr,'(a20,1x)', advance='no') dataset%pedigree(ped) pos=22 if (idx > dataset%maxact) then cfa=nodal(nodal(idx,2),1) cmo=nodal(nodal(idx,3),1) eos=len_trim(dataset%id(cfa))+len_trim(dataset%id(cmo))+5 pos=pos+eos call newlin(22, 78, pos, 21+eos) write(outstr,'(5a)', advance='no') & '{', trim(dataset%id(cfa)),' x ', trim(dataset%id(cmo)),'}' else ii=nodal(idx,1) eos=len_trim(dataset%id(ii)) pos=pos+eos call newlin(22, 78, pos, 21+eos) write(outstr,'(a)', advance='no') trim(dataset%id(ii)) if (trait /= MISS) then dataset%plocus(ii, trait)=2.0d0 end if end if dir=typelink(idx) do while (i>0) if (i > dataset%maxact) then cfa=nodal(nodal(i,2),1) cmo=nodal(nodal(i,3),1) eos=len_trim(dataset%id(cfa))+len_trim(dataset%id(cmo))+5 pos=pos+eos call newlin(22, 78, pos, 21+eos) write(outstr,'(6a)', advance='no') & trim(link(dir)), & '{', trim(dataset%id(cfa)),' x ', & trim(dataset%id(cmo)),'}' else ii=nodal(i,1) eos=len_trim(dataset%id(ii))+1 pos=pos+eos call newlin(22, 78, pos, 21+eos) write(outstr,'(2a)', advance='no') & trim(link(dir)), trim(dataset%id(ii)) if (trait /= MISS) then dataset%plocus(ii, trait)=2.0d0 end if end if if (i == idx) exit dir=typelink(i) i=backlink(i) end do write(outstr,*) if (plevel > 1) then write(outstr,'(a,i0,a,i0)') 'Visited ', nvisited,'/',num end if else if (plevel > 0) then write(outstr,'(a20,1x,a)') dataset%pedigree(ped), 'Nil ' end if end if end do end subroutine findloop ! ! extract unrelated (typ=1) or all (typ=2) individuals with information ! for a criterion trait ! As of 20151205, does not generate new pedigree IDs unless asked ! subroutine wricas(typ, newped, wrk, wrk2, trait, dataset) use outstream use ped_class implicit none integer, intent(in) :: typ integer, intent(in) :: newped integer, intent(in) :: wrk, wrk2 integer, intent(in) :: trait type (ped_data) :: dataset ! integer, parameter :: MISS=-9999 integer, dimension(dataset%maxsiz) :: aff integer :: actset, eop, i, ii, nf, nmarloc, nuse, tuse integer, dimension(NDATACLASS) :: numloc integer :: fap, mop, newoffset, nped, num, ped, pedoffset character (len=ped_width) :: fam ! newoffset=0 numloc=dataset%numloc nped=0 tuse=0 open(wrk, status='scratch', form='unformatted') open(wrk2, status='scratch', form='unformatted') do ped=1, dataset%nped actset=dataset%actset(ped) num=dataset%num(ped)-dataset%num(ped-1) pedoffset=dataset%num(ped-1) if (actset <= 0) then call wrkout(wrk, wrk2, ped, dataset, nped, newoffset) else ii=pedoffset nf=dataset%nfound(ped) if (typ == 2) nf=num do i=1, nf ii=ii+1 if (dataset%plocus(ii,trait) /= MISS) then aff(i)=2 else aff(i)=1 end if end do if (typ == 1) then do i=nf+1, num ii=ii+1 if (aff(dataset%fa(ii)-pedoffset) == 1 .and. & aff(dataset%mo(ii)-pedoffset) == 1) then if (dataset%plocus(ii,trait) /= MISS) then aff(i)=2 aff(dataset%fa(ii)-pedoffset)=3 aff(dataset%mo(ii)-pedoffset)=3 else aff(i)=1 end if else aff(i)=3 end if end do end if ! nuse=0 fam=dataset%pedigree(ped) eop=len_trim(fam) ii=pedoffset do i=1, num ii=ii+1 if (aff(i) == 2) then nped=nped+1 nuse=nuse+1 newoffset=newoffset+1 if (newped == 2) call makeind(1, nuse, eop, 10, fam) write(wrk) fam, actset, newoffset, 1 write(wrk2) dataset%id(ii), MISS, MISS, MISS, dataset%sex(ii), & dataset%glocus(ii,1:numloc(GCLASS)), & dataset%plocus(ii,1:numloc(PCLASS)) if (dataset%hassnps /= 0) then call matrix_write_row(ii, dataset%slocus, wrk2) end if end if end do tuse=tuse+nuse end if end do ! ! Read pedigrees back in ! call pedin(wrk, wrk2, nped, newoffset, numloc, numloc, dataset) close(wrk, status='delete') close(wrk2, status='delete') write(outstr,'(a,i6,a)') 'Extracted ',tuse,' cases.' end subroutine wricas ! ! convert into nuclear families, duplicating individuals as needed ! subroutine nuclear(wrk, wrk2, typ, maxsibs, dataset) use outstream use ped_class implicit none integer, intent(in) :: wrk, wrk2 integer, intent(in) :: typ integer, intent(inout) :: maxsibs type (ped_data) :: dataset ! integer :: currf, currm, fap, mop, nuc, pos, sta, totnuc integer, dimension(NDATACLASS) :: numloc integer :: actset, newoffset, num, nped, nships, ped, pedoffset ! functions integer :: countships ! maxsibs=maxsibs-1 newoffset=0 numloc=dataset%numloc nped=0 totnuc=0 open(wrk, status='scratch', form='unformatted') open(wrk2, status='scratch', form='unformatted') do ped=1, dataset%nped num=dataset%num(ped)-dataset%num(ped-1) pedoffset=dataset%num(ped-1) nships=countships(ped, dataset) if (dataset%actset(ped) <= 0 .or. nships <= 1) then if (dataset%actset(ped) > 0) totnuc=totnuc+nships call wrkout(wrk, wrk2, ped, dataset, nped, newoffset) else nuc=0 pos=pedoffset+dataset%nfound(ped)+1 sta=pos currf=dataset%fa(sta) currm=dataset%mo(sta) do while (pos <= dataset%num(ped)) if (dataset%fa(pos) /= currf .or. dataset%mo(pos) /= currm) then nuc=nuc+1 call onefam(wrk, wrk2, typ, maxsibs, ped, dataset, & nuc, newoffset, currf, currm, sta, pos-1) sta=pos currf=dataset%fa(sta) currm=dataset%mo(sta) end if pos=pos+1 end do ! last sibship nuc=nuc+1 call onefam(wrk, wrk2, typ, maxsibs, ped, dataset, & nuc, newoffset, currf, currm, sta, dataset%num(ped)) totnuc=totnuc+nuc nped=nped+nuc end if end do ! ! Read pedigrees back in ! call pedin(wrk, wrk2, nped, newoffset, numloc, numloc, dataset) close(wrk, status='delete') close(wrk2, status='delete') write(outstr,'(a,i6,a)') 'Extracted ', totnuc, ' nuclear families.' end subroutine nuclear ! ! Write out current nuclear family -- with or without grandparents ! subroutine onefam(wrk, wrk2, typ, maxsibs, ped, dataset, & nuc, newoffset, currf, currm, sta, fin) use ped_class implicit none integer, intent(in) :: wrk, wrk2 integer, intent(in) :: typ integer, intent(in) :: maxsibs integer, intent(in) :: ped type (ped_data) :: dataset integer, intent(in) :: nuc integer, intent(inout) :: newoffset integer, intent(in) :: currf integer, intent(in) :: currm integer, intent(in) :: sta integer, intent(in) :: fin ! integer, parameter :: MISS=-9999 character (len=ped_width) :: fam integer :: gp1, gp2, gp3, gp4, i, imztwin, j, nfou, ngp, nsibs, p1, p2 integer :: nfound, pedoffset ! pedoffset=dataset%num(ped-1) nfound=pedoffset+dataset%nfound(ped) fam=dataset%pedigree(ped) call makeind(1, nuc, len_trim(fam), ped_width, fam) nsibs=min(fin-sta, maxsibs)+1 ngp=0 nfou=2 gp1=MISS gp2=MISS gp3=MISS gp4=MISS p1=newoffset+1 p2=newoffset+2 if (typ == 2) then if (currf > nfound) then ngp=ngp+2 nfou=nfou+1 p1=p1+2 p2=p2+2 gp1=newoffset+1 gp2=newoffset+2 end if if (currm > nfound) then ngp=ngp+2 nfou=nfou+1 p1=p1+2 p2=p2+2 gp3=max(gp2,newoffset)+1 gp4=gp3+1 end if end if write(wrk) fam, dataset%actset(ped), newoffset+nsibs+ngp+2, nfou ! Grandparents if (typ == 2) then if (currf > nfound) then write(wrk2) dataset%id(dataset%fa(currf)), MISS, MISS, MISS, 1, & dataset%glocus(dataset%fa(currf),1:dataset%numloc(GCLASS)), & dataset%plocus(dataset%fa(currf),1:dataset%numloc(PCLASS)) if (dataset%hassnps /= 0) then call matrix_write_row(dataset%fa(currf), dataset%slocus, wrk2) end if write(wrk2) dataset%id(dataset%mo(currf)), MISS, MISS, MISS, 2, & dataset%glocus(dataset%mo(currf),1:dataset%numloc(GCLASS)), & dataset%plocus(dataset%mo(currf),1:dataset%numloc(PCLASS)) if (dataset%hassnps /= 0) then call matrix_write_row(dataset%mo(currf), dataset%slocus, wrk2) end if end if if (currm > nfound) then write(wrk2) dataset%id(dataset%fa(currm)), MISS, MISS, MISS, 1, & dataset%glocus(dataset%fa(currm),1:dataset%numloc(GCLASS)), & dataset%plocus(dataset%fa(currm),1:dataset%numloc(PCLASS)) if (dataset%hassnps /= 0) then call matrix_write_row(dataset%fa(currm), dataset%slocus, wrk2) end if write(wrk2) dataset%id(dataset%mo(currm)), MISS, MISS, MISS, 2, & dataset%glocus(dataset%mo(currm),1:dataset%numloc(GCLASS)), & dataset%plocus(dataset%mo(currm),1:dataset%numloc(PCLASS)) if (dataset%hassnps /= 0) then call matrix_write_row(dataset%mo(currm), dataset%slocus, wrk2) end if end if end if ! Parents (reorder if one parent a nonfounder) if (gp3==MISS .and. gp1/=MISS) then i=p1 p1=p2 p2=i write(wrk2) dataset%id(currm), MISS, gp3, gp4, 2, & dataset%glocus(currm,1:dataset%numloc(GCLASS)), & dataset%plocus(currm,1:dataset%numloc(PCLASS)) if (dataset%hassnps /= 0) then call matrix_write_row(currm, dataset%slocus, wrk2) end if write(wrk2) dataset%id(currf), MISS, gp1, gp2, 1, & dataset%glocus(currf,1:dataset%numloc(GCLASS)), & dataset%plocus(currf,1:dataset%numloc(PCLASS)) if (dataset%hassnps /= 0) then call matrix_write_row(currf, dataset%slocus, wrk2) end if else write(wrk2) dataset%id(currf), MISS, gp1, gp2, 1, & dataset%glocus(currf,1:dataset%numloc(GCLASS)), & dataset%plocus(currf,1:dataset%numloc(PCLASS)) if (dataset%hassnps /= 0) then call matrix_write_row(currf, dataset%slocus, wrk2) end if write(wrk2) dataset%id(currm), MISS, gp3, gp4, 2, & dataset%glocus(currm,1:dataset%numloc(GCLASS)), & dataset%plocus(currm,1:dataset%numloc(PCLASS)) if (dataset%hassnps /= 0) then call matrix_write_row(currm, dataset%slocus, wrk2) end if end if ! Children j=p2 do i=sta, sta+nsibs-1 j=j+1 imztwin=MISS if (dataset%imztwin(i) /= MISS) imztwin=i+j-dataset%imztwin(i) write(wrk2) dataset%id(i), imztwin, p1, p2, dataset%sex(i), & dataset%glocus(i,1:dataset%numloc(GCLASS)), & dataset%plocus(i,1:dataset%numloc(PCLASS)) if (dataset%hassnps /= 0) then call matrix_write_row(i, dataset%slocus, wrk2) end if end do newoffset=newoffset+nsibs+ngp+2 end subroutine onefam ! ! chop into disjoint subpedigrees ! note that the pointers in set(,2) do not follow the sort order of ! the pedigree, as connect() moves both up and down the generations ! subroutine disjoin(wrk, wrk2, dataset, plevel) use outstream use ped_class implicit none integer, intent(in) :: wrk, wrk2 type (ped_data) :: dataset integer, intent(in) :: plevel ! workfiles for family pointers etc integer, parameter :: MISS=-9999 integer, dimension(dataset%maxsiz,2) :: set integer, dimension(dataset%maxsiz) :: fa, mo, imztwin, ord integer :: newoffset, num, nped, oldped, ped, pedoffset, nsplit integer :: curped, eop, i, ios, imzt, maxgrp, nf, nsub, no integer, dimension(NDATACLASS) :: numloc character (len=ped_width) :: fam ! functions interface subroutine connect(num, fa, mo, set, nsub, maxgrp) integer, intent(in) :: num integer, dimension(:), intent(in) :: fa integer, dimension(:), intent(in) :: mo integer, dimension(:,:), intent(out) :: set integer, intent(out) :: nsub integer, intent(out) :: maxgrp end subroutine connect end interface ! newoffset=0 numloc=dataset%numloc nped=0 oldped=0 nsplit=0 open(wrk, status='scratch', form='unformatted') open(wrk2, status='scratch', form='unformatted') do ped=1, dataset%nped if (dataset%actset(ped) <= 0) then call wrkout(wrk, wrk2, ped, dataset, nped, newoffset) else oldped=oldped+1 pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset call workpointers(ped, dataset, fa, mo, imztwin) call connect(num, fa, mo, set, nsub, maxgrp) if (plevel > 0) then write(outstr,'(3a,i4,a)') & 'Pedigree ', dataset%pedigree(ped), & ' written out as ', nsub,' pedigrees.' end if nsplit=nsplit+nsub if (nsub == 1) then call wrkout(wrk, wrk2, ped, dataset, nped, newoffset) else eop=len_trim(dataset%pedigree(ped)) do curped=1, nsub nf=0 no=0 do i=1, dataset%nfound(ped) if (set(i,1) == curped) then no=no+1 nf=nf+1 ord(i)=no end if end do do i=dataset%nfound(ped)+1, num if (set(i,1) == curped) then no=no+1 ord(i)=no end if end do fam=dataset%pedigree(ped) call makeind(1, curped, eop, 10, fam) if (plevel > 1) then write(outstr,'(2a)') 'Created pedigree ', fam end if write(wrk) fam, dataset%actset(ped), newoffset+no, nf do i=1, dataset%nfound(ped) if (set(i,1) == curped) then write(wrk2) dataset%id(pedoffset+i), MISS, MISS, MISS, & dataset%sex(pedoffset+i), & dataset%glocus(pedoffset+i,1:numloc(GCLASS)), & dataset%plocus(pedoffset+i,1:numloc(PCLASS)) if (dataset%hassnps /= 0) then call matrix_write_row(i, dataset%slocus, wrk2) end if end if end do do i=dataset%nfound(ped)+1, num if (set(i,1) == curped) then imzt=MISS if (dataset%imztwin(pedoffset+i) /= MISS) then imzt=newoffset+ord(dataset%imztwin(pedoffset+i)-pedoffset) end if write(wrk2) dataset%id(pedoffset+i), imzt, & newoffset+ord(fa(i)), newoffset+ord(mo(i)), & dataset%sex(pedoffset+i), & dataset%glocus(pedoffset+i,1:numloc(GCLASS)), & dataset%plocus(pedoffset+i,1:numloc(PCLASS)) if (dataset%hassnps /= 0) then call matrix_write_row(pedoffset+i, dataset%slocus, wrk2) end if end if end do newoffset=newoffset+no end do nped=nped+nsub end if end if end do ! ! Read pedigrees back in ! call pedin(wrk, wrk2, nped, newoffset, numloc, numloc, dataset) close(wrk, status='delete') close(wrk2, status='delete') write(outstr,'(a,i6,a,i6,a)') & 'Extracted ', nsplit, ' component pedigrees from ', oldped, ' pedigrees.' ! end subroutine disjoin ! ! join families together by duplicated individuals ! (assuming unique individual IDs) ! had to exempt automatic variables from test of phenotype discordance 20180828 ! subroutine joinped(wrk, wrk2, typ, farg, larg, words, & nloci, loc, locpos, loctyp, locnotes, locstat, & dataset, chek, droperr, plevel) use automatic_data use outstream use ped_class use locus_types use sorts use string_utilities implicit none integer, intent(in) :: wrk, wrk2 integer, intent(in) :: typ integer, intent(in) :: farg, larg character (len=*), dimension(:), intent(inout) :: words integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp character (len=*), dimension(:), intent(in) :: locnotes double precision, dimension(:), intent(inout) :: locstat type (ped_data), intent(inout) :: dataset logical, intent(in) :: chek integer, intent(in) :: droperr integer, intent(in) :: plevel ! integer, parameter :: KNOWN=0, MISS=-9999 type (ped_data) :: buffer integer, dimension(dataset%nped) :: mergelist logical, dimension(dataset%nped) :: tomerge integer, dimension(:), allocatable :: key, ord character (len=id_width), dimension(:), allocatable :: sortid integer :: astat, fin, g1, g2, g3, g4, i, idx, inconsist, j, k, ki, & ndiscard, nerr, nmerge, pos, sta integer, dimension(NDATACLASS) :: numloc integer :: bufoffset, newoffset, newsiz, num, nfound, nped, ped, pedoffset logical :: elig, incon, ltyp character (len=id_width) :: cid character (len=1) :: ch ! functions ! logical strfind interface subroutine check(checkall, nloci, loc, loctyp, locpos, locnotes, locstat, & dataset, droperr, ndiscard, inconsist, plevel) use ped_class use locstring_widths logical, intent(in) :: checkall integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=annotation_width), dimension(:), intent(in) :: locnotes double precision, dimension(:), intent(inout) :: locstat type (ped_data) :: dataset integer, intent(in) :: droperr integer, intent(inout) :: ndiscard integer, intent(inout) :: inconsist integer, intent(in) :: plevel end subroutine check end interface ! tomerge(1:dataset%nped)=.false. ltyp=(typ == 2) nmerge=0 newsiz=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then elig=ltyp family: do i=farg, larg if (strfind(words(i)(1:ped_width), dataset%pedigree(ped), 1)) then elig=.not.elig exit family end if end do family if (elig) then tomerge(ped)=.true. nmerge=nmerge+1 mergelist(nmerge)=ped newsiz=newsiz+dataset%num(ped)-dataset%num(ped-1) end if end if end do if (nmerge<2) then write(outstr,'(a,i1,a)') 'There were ', nmerge, ' active pedigrees matching the merge list.' return else write(outstr,'(a)', advance='no') 'Merging pedigrees: ' do j=1, nmerge write(outstr,'(1x,a)', advance='no') trim(dataset%pedigree(mergelist(j))) end do write(outstr,*) end if numloc=dataset%numloc allocate(ord(newsiz), key(newsiz), sortid(newsiz)) call setup_peds(1, newsiz, numloc, numloc, buffer, astat, plevel) buffer%pedigree(1)=dataset%pedigree(mergelist(1)) bufoffset=0 newsiz=0 do j=1, nmerge ped=mergelist(j) pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset do i=pedoffset+1, dataset%num(ped) newsiz=newsiz+1 key(newsiz)=newsiz buffer%untyped(newsiz)=.false. sortid(newsiz)=dataset%id(i) buffer%iped(newsiz)=dataset%iped(i) buffer%id(newsiz)=dataset%id(i) if (dataset%imztwin(i)==MISS) then buffer%imztwin(newsiz)=MISS else buffer%imztwin(newsiz)=dataset%imztwin(i)-pedoffset+bufoffset end if if (dataset%fa(i)==MISS) then buffer%fa(newsiz)=MISS buffer%mo(newsiz)=MISS else buffer%fa(newsiz)=dataset%fa(i)-pedoffset+bufoffset buffer%mo(newsiz)=dataset%mo(i)-pedoffset+bufoffset end if buffer%sex(newsiz)=dataset%sex(i) buffer%glocus(newsiz,1:numloc(GCLASS))=dataset%glocus(i,1:numloc(GCLASS)) buffer%plocus(newsiz,1:numloc(PCLASS))=dataset%plocus(i,1:numloc(PCLASS)) if (buffer%hassnps /= 0) then call matrix_copy_row(i, dataset%slocus, newsiz, buffer%slocus, astat) end if end do bufoffset=bufoffset+num end do ! will need to retest for Mendelians and reimpute unobserved genotypes do j=1, nloci if (ismarker(loctyp(j))) then do i=1, newsiz if (.not.observed(i, locpos(j), buffer)) then call set_geno(i, locpos(j), locpos(j)+1, dataset, MISS, MISS) end if end do end if end do ! ! pool data from duplicated records and test for inconsistencies ! pointers to duplicates should point to initial record for that ID ! call csort(newsiz, sortid, key) if (plevel > 0) then write(outstr,'(/a)') 'Common IDs on which to merge:' cid=sortid(1) sta=1 fin=1 do i=2, newsiz if (sortid(i)==cid) then fin=i else if (fin>sta) then do j=sta, fin idx=key(j) write(outstr,'(3x,a,1x,a)', advance='no') & trim(dataset%pedigree(buffer%iped(idx))), trim(buffer%id(idx)) if (buffer%fa(idx)==MISS) then write(outstr,'(1x,a)', advance='no') 'x x' else write(outstr,'(1x,a,1x,a)', advance='no') & trim(buffer%id(buffer%fa(idx))), trim(buffer%id(buffer%mo(idx))) end if call wrsex(buffer%sex(idx), ch) write(outstr,*) ch, buffer%plocus(idx, 1:4) , '...' end do end if cid=sortid(i) sta=i fin=i end if end do write(outstr,*) end if incon=.false. idx=key(1) cid=sortid(1) do i=2, newsiz if (sortid(i)==cid) then ki=key(i) buffer%untyped(ki)=.true. buffer%id(ki)=trim(buffer%id(ki)) // '[D]' if (buffer%fa(idx)==MISS .and. buffer%fa(ki)/=MISS) then buffer%fa(idx)=buffer%fa(ki) buffer%mo(idx)=buffer%mo(ki) else if (buffer%fa(idx)/=MISS .and. buffer%fa(ki)/=MISS) then if (buffer%id(buffer%fa(idx)) /= buffer%id(buffer%fa(ki)) .or. & buffer%id(buffer%mo(idx)) /= buffer%id(buffer%mo(ki))) then incon=.true. write(outstr,'(3a)') 'ERROR: Unable to merge pedigrees because parents of ', & trim(sortid(i)), ' are inconsistent.' write(outstr,'(7x,a,3(1x,a)/7x,a,3(1x,a))') & trim(dataset%pedigree(buffer%iped(idx))), trim(buffer%id(idx)), & trim(buffer%id(buffer%fa(idx))), trim(buffer%id(buffer%mo(idx))), & trim(dataset%pedigree(buffer%iped(ki))), trim(buffer%id(ki)), & trim(buffer%id(buffer%fa(ki))), trim(buffer%id(buffer%mo(ki))) end if end if if (buffer%sex(idx)==MISS .and. buffer%sex(ki)/=MISS) then buffer%sex(idx)=buffer%sex(ki) else if (buffer%sex(idx) /= buffer%sex(ki) .and. & buffer%sex(idx)/=MISS .and. buffer%sex(ki)/=MISS) then incon=.true. write(outstr,'(3a)') 'ERROR: Unable to merge pedigrees because sexes for ', & trim(sortid(i)), ' are inconsistent.' end if do j=ENVNUM+1, nloci if (ismarker(loctyp(j))) then if (.not.missing(ki, locpos(j), buffer)) then call get_geno(ki, locpos(j), locpos(j)+1, buffer, g1, g2) call get_geno(idx, locpos(j), locpos(j)+1, buffer, g3, g4) if (missing(idx, locpos(j), buffer)) then call set_geno(idx, locpos(j), locpos(j)+1, dataset, g1, g2) else if (g1 /= g3 .or. g2 /= g4) then incon=.true. write(outstr,'(5a)') 'ERROR: Unable to merge pedigrees because data for ', & trim(sortid(i)), ' at "', trim(loc(j)), '" are inconsistent.' end if end if else if (buffer%plocus(idx,locpos(j)) == MISS .and. & buffer%plocus(ki,locpos(j)) /= MISS) then buffer%plocus(idx,locpos(j))=buffer%plocus(ki,locpos(j)) else if (buffer%plocus(idx,locpos(j)) /= & buffer%plocus(ki,locpos(j)) .and. & buffer%plocus(ki,locpos(j)) /= MISS) then incon=.true. write(outstr,'(5a)') 'ERROR: Unable to merge pedigrees because data for ', & trim(sortid(i)), ' at "', trim(loc(j)), '" are inconsistent.' if (plevel > -1) then write(outstr,'(7x,f12.6,a,f12.6)') & buffer%plocus(idx,locpos(j)), ' versus ', buffer%plocus(ki,locpos(j)) end if end if end if end do do k=1, newsiz if (buffer%fa(k)==ki) buffer%fa(k)=idx if (buffer%mo(k)==ki) buffer%mo(k)=idx end do else idx=key(i) cid=sortid(i) end if end do deallocate(ord, key, sortid) if (incon) then write(outstr,'(a)') 'Pedigree file not changed.' return end if ! pull down and remove duplicates, repointing if needed i=1 nfound=0 do while (i < buffer%nobs) if (buffer%untyped(i)) then do j=i+1, buffer%nobs buffer%untyped(j-1)=buffer%untyped(j) buffer%id(j-1)=buffer%id(j) buffer%imztwin(j-1)=buffer%imztwin(j) buffer%fa(j-1)=buffer%fa(j) buffer%mo(j-1)=buffer%mo(j) buffer%sex(j-1)=buffer%sex(j) buffer%glocus(j-1,1:numloc(GCLASS))=buffer%glocus(j,1:numloc(GCLASS)) buffer%plocus(j-1,1:numloc(PCLASS))=buffer%plocus(j,1:numloc(PCLASS)) if (buffer%hassnps /= 0) then call matrix_copy_row(j, buffer%slocus, j-1, buffer%slocus, astat) end if end do buffer%nobs=buffer%nobs-1 do k=1, buffer%nobs if (buffer%imztwin(k)>i) buffer%imztwin(k)=buffer%imztwin(k)-1 if (buffer%fa(k)>i) buffer%fa(k)=buffer%fa(k)-1 if (buffer%mo(k)>i) buffer%mo(k)=buffer%mo(k)-1 end do else if (buffer%fa(i)==MISS) nfound=nfound+1 i=i+1 end if end do ! do last obs if (buffer%fa(i)==MISS) nfound=nfound+1 if (buffer%untyped(i)) then buffer%nobs=buffer%nobs-1 end if buffer%num(1)=buffer%nobs buffer%nfound(1)=nfound buffer%actset(1)=1 buffer%maxsiz=buffer%nobs ! get pedigree order call pedsort(1, buffer, nerr, plevel) if (nerr>0) then write(outstr,'(a)') 'Pedigree file not changed.' return end if ! see if uncovered Mendelians inconsist=0 ndiscard=0 if (chek) then call check(.true., nloci, loc, loctyp, locpos, locnotes, locstat, & buffer, droperr, ndiscard, inconsist, -1) end if if (inconsist > 0) then write(outstr,'(a)') 'Pedigree file not changed.' return end if ! write first the new merged pedigree followed by the other pedigrees open(wrk, status='scratch', form='unformatted') open(wrk2, status='scratch', form='unformatted') nped=0 newoffset=0 call wrkout(wrk, wrk2, 1, buffer, nped, newoffset) do ped=1, dataset%nped if (.not.tomerge(ped)) then call wrkout(wrk, wrk2, ped, dataset, nped, newoffset) end if end do call pedin(wrk, wrk2, nped, newoffset, numloc, numloc, dataset) close(wrk, status='delete') close(wrk2, status='delete') write(outstr,'(a,i6,a)') 'Merged ', nmerge, ' pedigrees into one.' end subroutine joinped ! ! Sort a pedigree in a dataset ! subroutine pedsort(ped, dataset, nerr, plevel) use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(inout) :: dataset integer, intent(out) :: nerr integer, intent(in) :: plevel ! local variables integer, parameter :: MISS=-9999 type (ped_data) :: buffer integer :: astat, higen, i, idx, ii, j, num, pedoffset integer, dimension(dataset%maxsiz) :: fa, key, mo, ord, pid character (len=id_width), dimension(dataset%maxsiz) :: id interface subroutine ascend(n, ia) integer, intent(in) :: n integer, dimension(:), intent(inout) :: ia end subroutine subroutine famsort(pedigree,num, nfound, nid, id, pid, fa, mo, & key1, ord, higen, nerr, plevel) use idstring_widths character (len=ped_width), intent(in out) :: pedigree integer, intent(in) :: num integer, intent(in) :: nfound integer, intent(in out) :: nid character (len=id_width), dimension(:), intent(inout) :: id integer, dimension(:), intent(inout) :: pid integer, dimension(:), intent(inout) :: fa integer, dimension(:), intent(inout) :: mo integer, dimension(:), intent(inout) :: key1 integer, dimension(:), intent(inout) :: ord integer, intent(inout) :: higen integer, intent(inout) :: nerr integer, intent(in) :: plevel end subroutine famsort end interface ! pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset if (num <= 1) then return end if call setup_peds(1, num, dataset%numloc, dataset%numloc, buffer, astat, plevel) buffer%nped=1 buffer%maxsiz=num buffer%maxact=num buffer%nobs=num buffer%numloc=dataset%numloc buffer%num(1)=num buffer%nfound(1)=dataset%nfound(ped) buffer%actset(1)=dataset%actset(ped) ii=pedoffset do i=1, num ii=ii+1 buffer%iped(i)=dataset%iped(ii) buffer%id(i)=dataset%id(ii) if (dataset%imztwin(ii) == MISS) then buffer%imztwin(i)=MISS else buffer%imztwin(i)=dataset%imztwin(ii)-pedoffset end if if (dataset%fa(ii)==MISS) then buffer%fa(i)=MISS buffer%mo(i)=MISS fa(i)=MISS mo(i)=MISS else buffer%fa(i)=dataset%fa(ii)-pedoffset buffer%mo(i)=dataset%mo(ii)-pedoffset fa(i)=buffer%fa(i) mo(i)=buffer%mo(i) end if buffer%sex(i)=dataset%sex(ii) if (buffer%hassnps /= 0) then call matrix_copy_row(ii, dataset%slocus, i, buffer%slocus, astat) end if buffer%glocus(i,1:buffer%numloc(GCLASS))=dataset%glocus(ii,1:buffer%numloc(GCLASS)) buffer%plocus(i,1:buffer%numloc(PCLASS))=dataset%plocus(ii,1:buffer%numloc(PCLASS)) end do nerr=0 id(1:num)=dataset%id(pedoffset+1:dataset%num(ped)) call ascend(num, pid) call famsort(dataset%pedigree(ped), num, dataset%nfound(ped), & num, id, pid, fa, mo, key, ord, higen, nerr, plevel) if (nerr==0) then do i=1, num key(ord(i))=i end do ii=pedoffset do i=1, num idx=ord(i) ii=ii+1 dataset%iped(ii)=buffer%iped(idx) dataset%id(ii)=buffer%id(idx) if (buffer%imztwin(idx)==MISS) then dataset%imztwin(ii)=MISS else dataset%imztwin(ii)=key(buffer%imztwin(idx))+pedoffset end if if (buffer%fa(idx)==MISS) then dataset%fa(ii)=MISS dataset%mo(ii)=MISS else dataset%fa(ii)=key(buffer%fa(idx))+pedoffset dataset%mo(ii)=key(buffer%mo(idx))+pedoffset end if dataset%sex(ii)=buffer%sex(idx) if (buffer%hassnps /= 0) then call matrix_copy_row(idx, buffer%slocus, ii, dataset%slocus, astat) end if dataset%glocus(ii,1:buffer%numloc(GCLASS))=buffer%glocus(idx,1:buffer%numloc(GCLASS)) dataset%plocus(ii,1:buffer%numloc(PCLASS))=buffer%plocus(idx,1:buffer%numloc(PCLASS)) end do end if call cleanup_peds(buffer) end subroutine pedsort ! ! Additive allelic model for association with a quantitative trait ! subroutine doanova(trait, locnam, gene, genetyp, iter, mincnt, norder, & assfnd, conibd, dataset, freqfnd, use_fixfreq, & fixfreq_buffer, allele_buffer2, pval, plevel, typ) use interrupt use outstream use alleles_class use ped_class use rngs use sorts use statfuns use AS164 implicit none integer, intent(in) :: trait character (len=*), intent(in) :: locnam integer, intent(in) :: gene, genetyp integer, intent(in) :: iter integer, intent(in) :: mincnt, norder logical, intent(in) :: assfnd integer, intent(in) :: conibd type (ped_data) :: dataset integer, intent(in) :: freqfnd logical, intent(in) :: use_fixfreq type (allele_data), intent(in) :: fixfreq_buffer type (allele_data), intent(inout) :: allele_buffer2 double precision, intent(out) :: pval integer, intent(in) :: plevel integer, intent(in) :: typ ! local variables integer, parameter :: KNOWN=0, MISS=-9999 type (allele_data) :: allele_buffer ! regression work arrays integer, dimension(dataset%maxsiz, 2) :: set double precision, dimension(:), allocatable :: b, x double precision, dimension(:), allocatable :: cov, r integer, dimension(:), allocatable :: counts logical, dimension(dataset%nobs) :: untyped integer :: g1, g2, gen2, geno, i, idf, ifail, ii, it, j, mdf, n, & ncats, ncov, nobs, nter, tailp, nuntyp, pedoffset, ped, pos, tot character (len=3) :: allel, ana, histo character (len=7) :: gtp double precision :: asyp, bss, orss, lrts, mss, mu, rss, vg, vss ! ! used to extrapolate extreme tail empirical P values using ! David & Resnick ! integer :: ntopvals double precision, dimension(norder+2) :: topvals ! functions integer :: clcpos, getnam character (len=6) :: pstring double precision :: evdtailp, ln interface subroutine freq(gene, loctyp, fndr, dataset, allele_buffer) use ped_class use alleles_class integer, intent(in) :: gene integer, intent(in) :: loctyp integer, intent(in) :: fndr type (ped_data), intent(in) :: dataset type (allele_data), intent(inout) :: allele_buffer end subroutine freq subroutine simped(ped, dataset, allele_buffer, set) use alleles_class use ped_class integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data), intent(in) :: allele_buffer integer, dimension(:,:), intent(out) :: set end subroutine simped subroutine xsimped(ped, dataset, allele_buffer, set) use alleles_class use ped_class integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data), intent(in) :: allele_buffer integer, dimension(:,:), intent(out) :: set end subroutine xsimped subroutine cisimped(ped, gene, allele_buffer, allele_buffer2, dataset, set) use alleles_class use ped_class implicit none integer, intent(in) :: ped ! pedigree to simulate integer, intent(in) :: gene ! position of marker conditioned on type (allele_data), intent(in) :: allele_buffer ! marker to be simulated type (allele_data), intent(in) :: allele_buffer2 ! marker to condition ibd on type (ped_data) :: dataset ! all the observed data integer, dimension(:,:), intent(out) :: set ! the new simulated marker end subroutine cisimped end interface call setup_freq(10, allele_buffer) if (.not.use_fixfreq) then call freq(gene, genetyp, freqfnd, dataset, allele_buffer) else call copyfreq(fixfreq_buffer, allele_buffer) end if it=0 nobs=0 ncats=allele_buffer%numal ana='HWE' if (typ == 2) then ncats=allele_buffer%numal*(allele_buffer%numal+1)/2 ana='Gtp' end if nter=ncats+1 ncov=nter*(nter+1)/2 gen2=gene+1 ! ! allocate work arrays ! allocate(counts(ncats)) allocate(x(nter)) allocate(b(nter)) allocate(cov(ncov), r(ncov)) call inicov(nter, ncov, r) bss=0.0d0 mu=0.0d0 vg=0.0d0 ntopvals = norder+2 topvals=0.0d0 nuntyp=0 counts=0 untyped=.false. do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) n=dataset%num(ped) if (assfnd) then n=pedoffset+dataset%nfound(ped) end if if (typ == 1) then do i=pedoffset+1, n if (.not.observed(i, gene, dataset)) then untyped(i)=.true. if (dataset%plocus(i,trait) /= MISS) nuntyp=nuntyp+1 else if (dataset%plocus(i,trait) /= MISS) then call get_namedgeno(i, gene, gen2, dataset, allele_buffer, g1, g2) nobs=nobs+1 do j=1, ncats x(j)=0.0d0 end do x(nter)=dataset%plocus(i,trait) x(g1)=x(g1)+1 x(g2)=x(g2)+1 counts(g1)=counts(g1)+1 counts(g2)=counts(g2)+1 call moment(nobs, x(nter), mu, bss) call givenc(r, ncov, nter, x, 1.0d0, ifail) end if end do else if (typ == 2) then do i=pedoffset+1, n if (.not.observed(i, gene, dataset)) then untyped(i)=.true. if (dataset%plocus(i,trait) /= MISS) nuntyp=nuntyp+1 else if (dataset%plocus(i,trait) /= MISS) then call get_namedgeno(i, gene, gen2, dataset, allele_buffer, g1, g2) geno=clcpos(g1, g2) nobs=nobs+1 do j=1, ncats x(j)=0.0d0 end do x(nter)=dataset%plocus(i,trait) x(geno)=x(geno)+1 counts(geno)=counts(geno)+1 call moment(nobs, x(nter), mu, bss) call givenc(r, ncov, nter, x, 1.0d0, ifail) end if end do end if end if end do call alias(r, ncov, nter, 1.0d-15, x, ifail) call bsub(r, ncov, nter, b, ncats, ifail) call var(r, ncov, cov, ncov, nter, nobs, 1, ifail) mdf=0 mss=0.0d0 do i=1, ncats call sscomp(r, ncov, nter, nobs, i, rss, idf, ifail) mdf=mdf+idf mss=mss+rss end do call sscomp(r, ncov, nter, nobs, 0, orss, idf, ifail) lrts=dble(nobs) * (ln(bss)-ln(orss)) if (bss == 0.0d0) lrts=0.0d0 asyp=chip(lrts, max(1, mdf-1)) mss=mss/dble(max(1, mdf)) orss=orss/dble(max(1, idf)) if (plevel > 0) then write(outstr,'(/a,a10,a)') & ' ------ QTL Association with "', locnam, '" -----' if (typ == 2) then write(outstr,'(a)') ' Genotype Gtypic Mean Stand Error Count' else write(outstr,'(a)') ' Allele Allelic Mean Stand Error Count' end if write(outstr,'(a)') ' ----------------------------------------------' ii=0 tot=nobs if (typ == 1) then tot=nobs+nobs do i=1,ncats ii=ii+i call wrall(allele_buffer%allele_names(i), allel) write(outstr,'(5x,a3,5x,f12.4,3x,f12.4,1x,i7)') & allel, b(i), sqrt(cov(ii)), counts(i) end do else i=0 do g1=1, allele_buffer%numal do g2=1,g1 i=i+1 ii=ii+i call wrgtp(allele_buffer%allele_names(g2), & allele_buffer%allele_names(g1), gtp, '/', '', 1) write(outstr,'(1x,a7,5x,f12.4,3x,f12.4,1x,i7)') & gtp, b(i), sqrt(cov(ii)), counts(i) vg=vg+dble(counts(i))*(b(i)-mu)**2 end do end do vg=vg/dble(tot) end if write(outstr,'(a/a,f12.4,3x,f12.4,1x,i7)') & ' ----------------------------------------------', & ' Total ',mu, sqrt(bss/dble(max(1,nobs-1))), tot write(outstr,'(2(/a,i7),2(/a,f12.4,a,i4,a))') & ' No. trait(+) marker(-) =', nuntyp, & ' No. trait(+) marker(+) =', nobs, & ' Model Mean Square =', mss, ' (df=',mdf,')', & ' Mean Square Error =', orss, ' (df=',idf,')' if (typ == 2) then write(outstr,'(a,f12.4)') & ' Genetic Variance =', vg end if write(outstr,'(a,f12.4,/a,g12.4)') ' Likelihood ratio test =', lrts, & ' Nominal P-value =', asyp end if if (iter > 0 .and. nobs > 1 .and. ncats > 1) then ! ! Sequential Monte-Carlo P-value after Besag & Clifford Biometrika 1991 ! P= tailp/it if tailp=mincnt or (tailp+1)/(it+1) if tailp<mincnt && it=iter mss=0.0D0 vss=0.0D0 tailp=0 do while (it < iter .and. tailp < mincnt .and. irupt==0) it=it+1 call inicov(nter, ncov, r) if (conibd /= MISS) then call newstart(conibd, allele_buffer2, dataset, plevel) end if do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) if (conibd /= MISS) then call cisimped(ped, conibd, allele_buffer, allele_buffer2, dataset, set) else if (allele_buffer%xlinkd) then call xsimped(ped, dataset, allele_buffer, set) else call simped(ped, dataset, allele_buffer, set) end if end if n=dataset%num(ped) if (assfnd) then n=pedoffset+dataset%nfound(ped) end if if (typ == 1) then do i=pedoffset+1, n if (.not.untyped(i) .and. dataset%plocus(i,trait) /= MISS) then do j=1, ncats x(j)=0.0d0 end do g1=set(i-pedoffset,1) g2=set(i-pedoffset,2) x(nter)=dataset%plocus(i,trait) x(g1)=x(g1)+1 x(g2)=x(g2)+1 call givenc(r, ncov, nter, x, 1.0d0, ifail) end if end do else if (typ == 2) then do i=pedoffset+1, n if (.not.untyped(i) .and. dataset%plocus(i,trait) /= MISS) then geno=clcpos(set(i-pedoffset,1),set(i-pedoffset,2)) do j=1, ncats x(j)=0.0d0 end do x(nter)=dataset%plocus(i,trait) x(geno)=x(geno)+1 call givenc(r, ncov, nter, x, 1.0d0, ifail) end if end do end if end if end do call alias(r, ncov, nter, 1.0d-15, x, ifail) call sscomp(r, ncov, nter, nobs, 0, rss, idf, ifail) rss=rss/dble(max(1,idf)) topvals(1)=1.0d0/rss call dsort(ntopvals,topvals) call moment(it, rss, mss, vss) if (rss < orss .or. (rss == orss .and. random() > 0.5d0)) then tailp=tailp+1 end if if (plevel > 1) then write(outstr,'(/a,i8,a,f12.4)') 'Pseudosample ',it,': MSE=',rss end if end do if (tailp < mincnt) then tailp=tailp+1 it=it+1 end if vss=vss/dble(max(1, it-1)) pval=evdtailp(tailp, it, ntopvals, topvals, 1.0d0/orss) else mss=0.0d0 vss=0.0d0 topvals=1.0d0 tailp=0 pval=1.0d0 end if if (plevel > 0) then write(outstr,'(a,i0,a,i0,3a/a,f12.4,a,f12.4,a)') & ' Equalled or exceeded by =', tailp, '/', it, & ' simulated values (', trim(pstring(pval)), ')', & ' Mean (SD) simulated MSE =', mss, ' (', sqrt(vss), ')' if (plevel > 1) then write(outstr,'(/a/5(1x,f12.4):)') ' Smallest simulated RSS:', & 1.0d0/topvals(2:ntopvals) end if else if (plevel > -2) then call phist(asyp, pval, histo) write(outstr,'(a20,2(a1,i6),a1,f10.1,2(a1,a),a1,i8,a1,2a,a1,a)') & locnam, tabsep, nobs, tabsep, mdf, tabsep, lrts, tabsep, & pstring(asyp), tabsep, pstring(pval), tabsep, it, tabsep, & 'ANOVA-',ana, tabsep, histo end if if (iter == 0) pval=asyp end subroutine doanova ! ! Quantitative trait TDT following Gauderman 2003 25(4): 327-338 ! ! E(Y_i) = a_MTi + beta Z(G_i) ! subroutine qtdt(trait, locnam, gene, genetyp, freqfnd, iter, mincnt, use2, typ, & dataset, pval, plevel) use outstream use pairlist_class use alleles_class use ped_class use recast_data use rngs use statfuns use AS164 implicit none integer, intent(in) :: trait character (len=*), intent(in) :: locnam integer, intent(in) :: gene, genetyp integer, intent(in) :: freqfnd integer, intent(in) :: iter ! number of MC iterations integer, intent(in) :: mincnt ! minimum numerator for sequential MC P-value integer, intent(in) :: use2 ! number of trios per family to use (2=all, 3=first) integer, intent(in) :: typ ! 1=maternal 2=paternal 3=biparental TDT type (ped_data) :: dataset double precision, intent(out) :: pval integer, intent(in) :: plevel ! local variables integer, parameter :: KNOWN=0, MISS=-9999, NOT_FOUND=0 double precision, parameter :: EPS = 1.0d-4 type (allele_data) :: allele_buffer ! marker locus mating types type (pairlist_data) :: cntmat ! regression work arrays integer, dimension(dataset%nobs) :: mattyp integer, dimension(dataset%nobs, 2) :: set logical, dimension(dataset%nobs) :: untyped double precision, dimension(:), allocatable :: b, x, x2 double precision, dimension(:), allocatable :: cov, r, r2 integer, dimension(:), allocatable :: counts ! local variables integer :: nf, ped, pedoffset, i, ii, j integer :: allelic_df, contrib, gen2, g1, g2, gtp1, gtp2, idf, ifail, it, mating, & mdf, ncats, ncov, nobs, nter, tailp, rdf, nuntyp integer :: tr1, tr2, nt1, nt2 character (len=3) :: allel, histo character (len=7) :: gtp double precision :: asyp, allelic_mss, bss, ftest, oftest, mss, mu, orss, rss, vss ! functions integer :: getnam logical :: tdtuse character (len=6) :: pstring double precision :: ln interface subroutine freq(gene, loctyp, fndr, dataset, allele_buffer) use ped_class use alleles_class integer, intent(in) :: gene integer, intent(in) :: loctyp integer, intent(in) :: fndr type (ped_data), intent(in) :: dataset type (allele_data), intent(inout) :: allele_buffer end subroutine freq subroutine csimped(ped, dataset, untyped, set, xlinkd) use ped_class integer, intent(in) :: ped type (ped_data) :: dataset logical, dimension(:), intent(in) :: untyped integer, dimension(:,:), intent(inout) :: set logical, intent(in) :: xlinkd end subroutine end interface call setup_freq(10, allele_buffer) call freq(gene, genetyp, freqfnd, dataset, allele_buffer) it=0 nobs=0 gen2=gene+1 ! ! Copy marker genotypes to set, and count the mating types for the marker ! call setup_pairs(100, cntmat) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) nf=dataset%num(ped-1)+dataset%nfound(ped) do i=pedoffset+1, nf mattyp(i)=MISS untyped(i)=.false. if (.not.observed(i, gene, dataset)) then untyped(i)=.true. set(i,1)=MISS set(i,2)=MISS else call get_namedgeno(i, gene, gen2, dataset, allele_buffer, & set(i,1), set(i,2)) end if end do do i=nf+1, dataset%num(ped) mattyp(i)=MISS untyped(i)=.false. if (.not.observed(i, gene, dataset)) then untyped(i)=.true. set(i,1)=MISS set(i,2)=MISS else call get_namedgeno(i, gene, gen2, dataset, allele_buffer, & set(i,1), set(i,2)) if (dataset%plocus(i, trait) /= MISS .and. & .not.untyped(dataset%fa(i)) .and. & .not.untyped(dataset%mo(i))) then gtp1=iencgtp(set(dataset%fa(i),1), set(dataset%fa(i),2)) gtp2=iencgtp(set(dataset%mo(i),1), set(dataset%mo(i),2)) if (typ == 3) then call order(gtp1, gtp2) call insert_pair(gtp1, gtp2, cntmat) else if (typ == 2) then call insert_pair(gtp1, gtp1, cntmat) else if (typ == 1) then call insert_pair(gtp2, gtp2, cntmat) end if end if end if end do end if end do ncats=allele_buffer%numal+cntmat%npairs nter=ncats+1 ncov=nter*(nter+1)/2 ! ! allocate work arrays ! allocate(counts(ncats)) allocate(x(nter), x2(nter)) allocate(b(nter)) allocate(cov(ncov), r(ncov), r2(ncov)) call inicov(nter, ncov, r) call inicov(nter, ncov, r2) bss=0.0d0 mu=0.0d0 nuntyp=0 do i=1, ncats counts(i)=0 end do if (plevel > 1) then write(outstr,'(a8,6x,a2,12x,a5,5x,a8,2x,a)', advance='no') & 'Pedigree', 'ID', 'Trait', 'Genotype', 'Mating Pat Mat' do i=1, allele_buffer%numal write(outstr,'(1x,a,i0)', advance='no') 'a', i end do write(outstr,*) end if do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) ! ! Only phenotyped persons with genotyped parents used ! contrib is probandi from this pedigree -- may choose first or all ! contrib=0 do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped) if (dataset%plocus(i,trait) /= MISS .and. & .not.untyped(i) .and. & .not.untyped(dataset%fa(i)) .and. & .not.untyped(dataset%mo(i)) .and. & (use2==2 .or. contrib==0)) then nobs=nobs+1 contrib=contrib+1 do j=1, ncats x(j)=0.0d0 x2(j)=0.0d0 end do x(nter)=dataset%plocus(i,trait) x2(nter)=dataset%plocus(i,trait) ! mating gtp1=iencgtp(set(dataset%fa(i),1), set(dataset%fa(i),2)) gtp2=iencgtp(set(dataset%mo(i),1), set(dataset%mo(i),2)) if (typ == 3) then call order(gtp1, gtp2) mattyp(i)=find_pair(gtp1, gtp2, cntmat) else if (typ == 2) then mattyp(i)=find_pair(gtp1, gtp1, cntmat) else if (typ == 1) then mattyp(i)=find_pair(gtp2, gtp2, cntmat) end if if (mattyp(i) /= NOT_FOUND) then x(mattyp(i))=1.0d0 x2(allele_buffer%numal+mattyp(i))=1.0d0 counts(allele_buffer%numal+mattyp(i))=counts(allele_buffer%numal+mattyp(i))+1 else write(outstr,*) 'ERROR: mating type not found!!!' end if ! genotype (or allele if parent of origin TDT) if (typ /= 3) then if (.not.allele_buffer%xlinkd) then call trans(set(dataset%fa(i),1), set(dataset%fa(i),2), & set(dataset%mo(i),1), set(dataset%mo(i),2), & set(i,1), set(i,2), tr1, tr2, nt1, nt2, typ) else if (dataset%sex(i) == 1) then call xtrans(set(dataset%mo(i),1), set(dataset%mo(i),2), & set(i,1), set(i,2), tr1, tr2, nt1, nt2) end if else tr1=set(i,1) tr2=set(i,2) end if if (tr1 /= MISS) then x(tr1+cntmat%npairs)=x(tr1+cntmat%npairs)+1 x2(tr1)=x2(tr1)+1 counts(tr1)=counts(tr1)+1 end if if (tr2 /= MISS) then x(tr2+cntmat%npairs)=x(tr2+cntmat%npairs)+1 x2(tr2)=x2(tr2)+1 counts(tr2)=counts(tr2)+1 end if if (plevel > 1) then call wrgtp(set(i,1), set(i,2), gtp, '/', '', 1) write(outstr,'(a14,a14,f9.4,1x,a7,4x,i2)', advance='no') & dataset%pedigree(ped), dataset%id(i), & dataset%plocus(i,trait), gtp, mattyp(i) call wrgtp(set(dataset%fa(i),1), set(dataset%fa(i),2), gtp, '/', '', 1) write(outstr,'(1x,a7)', advance='no') gtp call wrgtp(set(dataset%mo(i),1), set(dataset%mo(i),2), gtp, '/', '', 1) write(outstr,'(1x,a7)', advance='no') gtp write(outstr,*) ' ', int(x2(1:allele_buffer%numal)) end if call moment(nobs, x(nter), mu, bss) call givenc(r, ncov, nter, x, 1.0d0, ifail) call givenc(r2, ncov, nter, x2, 1.0d0, ifail) end if end do end if end do if (nobs == 0) then if (plevel > 0) then write(outstr,'(/a,a10,a/2(/a,i7))') & ' ------------ QTDT for "',locnam,'"-------------', & ' No. trait(+) marker(-) =',nuntyp, & ' No. trait(+) marker(+) =',nobs else write(outstr,'(a20,2(1x,i6),1x,f10.1,2(1x,f6.4),1x,i6,1x,a)') & locnam, nobs, 0, 0.0D0, 1.0D0, 1.0D0, 0, 'QTDT .' end if return end if call alias(r, ncov, nter, 1.0d-15, x, ifail) call alias(r2, ncov, nter, 1.0d-15, x, ifail) call bsub(r2, ncov, nter, b, ncats, ifail) call var(r2, ncov, cov, ncov, nter, nobs, 1, ifail) allelic_df=0 mss=0.0d0 allelic_mss=0.0d0 call sscomp(r, ncov, nter, nobs, 0, orss, rdf, ifail) do i=1, cntmat%npairs call sscomp(r, ncov, nter, nobs, i, rss, idf, ifail) mss=mss+rss end do allelic_mss=mss do i=cntmat%npairs+1, ncats call sscomp(r, ncov, nter, nobs, i, rss, idf, ifail) allelic_df=allelic_df+idf mss=mss+rss end do allelic_mss=mss-allelic_mss rdf=max(1, rdf) allelic_df=max(1, allelic_df) oftest=allelic_mss/orss*dble(rdf)/dble(allelic_df) asyp=fp(oftest, allelic_df, rdf) orss=orss/dble(max(1,rdf)) if (plevel > 0) then write(outstr,'(/a,a10,a/a/a)') & ' ------------ QTDT for "',locnam,'"-------------', & ' Allele Allelic Mean Stand Error Count', & ' -----------------------------------------------' ii=0 do i=1, allele_buffer%numal ii=ii+i call wrall(allele_buffer%allele_names(i), allel) write(outstr,'(5x,a3,5x,f12.4,3x,f12.4,1x,i7)') & allel, b(i), sqrt(cov(ii)), counts(i) end do write(outstr,'(a/a,f12.4,3x,f12.4,1x,i7)') & ' ----------------------------------------------', & ' Total ',mu, sqrt(bss/dble(max(1,nobs-1))), 2*nobs write(outstr,'(3(/a,i7),3(/a,f12.4,a,i4,a))') & ' No. trait(+) marker(-) =', nuntyp, & ' No. trait(+) marker(+) =', nobs, & ' No. marker mating types =', cntmat%npairs, & ' Allelic Mean Square =', allelic_mss, ' (df=', allelic_df, ')', & ' Residual Standard Error =', sqrt(orss), ' (df=', rdf, ')' write(outstr,'(a,f12.4,/a,f12.4)') & ' F-Statistic =', oftest, & ' Nominal P-value =', asyp end if if (iter > 0) then ! ! Sequential Monte-Carlo P-value after Besag & Clifford Biometrika 1991 ! P= tailp/it if tailp=mincnt or (tailp+1)/(it+1) if tailp<mincnt && it=iter mss=0.0D0 vss=0.0D0 it=0 tailp=0 do while (it < iter .and. tailp < mincnt) it=it+1 call inicov(nter, ncov, r) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then call csimped(ped, dataset, untyped, set, allele_buffer%xlinkd) do i=dataset%num(ped-1)+1, dataset%num(ped) if (mattyp(i) /= MISS) then do j=1, ncats x(j)=0.0d0 end do x(nter)=dataset%plocus(i, trait) x(mattyp(i))=1.0d0 if (typ /= 3) then if (.not.allele_buffer%xlinkd) then call trans(set(dataset%fa(i),1), set(dataset%fa(i),1), & set(dataset%mo(i),1), set(dataset%mo(i),2), & set(i,1), set(i,2), tr1, tr2, nt1, nt2, typ) else if (dataset%sex(i) == 1) then call xtrans(set(dataset%mo(i),1), set(dataset%mo(i),2), & set(i,1), set(i,2), tr1, tr2, nt1, nt2) end if else tr1=set(i,1) tr2=set(i,2) end if if (tr1 /= MISS) x(tr1+cntmat%npairs)=x(tr1+cntmat%npairs)+1 if (tr2 /= MISS) x(tr2+cntmat%npairs)=x(tr2+cntmat%npairs)+1 call givenc(r, ncov, nter, x, 1.0d0, ifail) end if end do end if end do call alias(r, ncov, nter, 1.0d-15, x, ifail) mss=0.0d0 do i=1, cntmat%npairs call sscomp(r, ncov, nter, nobs, i, rss, idf, ifail) mss=mss+rss end do mdf=0 allelic_mss=mss do i=cntmat%npairs+1, ncats call sscomp(r, ncov, nter, nobs, i, rss, idf, ifail) mdf=mdf+idf mss=mss+rss end do allelic_mss=mss-allelic_mss call sscomp(r, ncov, nter, nobs, 0, rss, rdf, ifail) ftest=allelic_mss/rss*dble(max(1,rdf))/dble(max(1,mdf)) rss=rss/dble(max(1,idf)) if (abs(ftest-oftest) < EPS) then if (random() > 0.5d0) tailp=tailp+1 else if (ftest > oftest) then tailp=tailp+1 end if if (plevel > 1) then write(outstr,'(a,i8,a,f12.4)') & 'Pseudosample ',it,': F=', ftest end if end do if (tailp < mincnt) then tailp=tailp+1 it=it+1 end if pval=dble(tailp)/dble(it) else tailp=0 pval=1.0d0 end if if (plevel > 0) then write(outstr,'(a,i0,a,i0,3a)') & ' Equalled or exceeded by =', tailp, '/', it, & ' simulated values (', trim(pstring(pval)), ')' else if (plevel > -2) then call phist(asyp, pval, histo) write(outstr,'(a20,2(a1,i6),a1,f10.1,2(a1,a),a1,i8,2(a1,a))') & locnam, tabsep, nobs, tabsep, allelic_df, tabsep, oftest, tabsep, & pstring(asyp), tabsep, pstring(pval), tabsep, it, tabsep, & 'QTDT', tabsep, histo end if if (iter == 0) pval=asyp call clean_pairs(cntmat) end subroutine qtdt ! ! Additive allelic model for association with a quantitative trait ! Conditional on parental genotypes ! subroutine cpganova(trait, locnam, gene, genetyp, iter, mincnt, & freqfnd, dataset, plevel) use outstream use alleles_class use ped_class use rngs use statfuns use AS164 implicit none integer, intent(in) :: trait character (len=*), intent(in) :: locnam integer, intent(in) :: gene, genetyp integer, intent(in) :: iter integer, intent(in) :: mincnt integer, intent(in) :: freqfnd type (ped_data) :: dataset integer, intent(in) :: plevel ! local variables integer, parameter :: KNOWN=0, MISS=-9999 double precision, parameter :: EPS=1.0d-7 type (allele_data) :: allele_buffer ! regression work arrays logical, dimension(dataset%nobs) :: contrib integer, dimension(dataset%nobs, 2) :: set logical, dimension(dataset%nobs) :: untyped double precision, dimension(:), allocatable :: b, x double precision, dimension(:), allocatable :: cov, r integer, dimension(:), allocatable :: counts ! local variables integer :: g1, g2, gen2, i, idf, ifail, ii, it, j, mdf, & ncats, ncov, nobs, nter, pedoffset, ped, tailp, nuntyp character (len=3) :: allel, histo double precision :: asyp, bss, lrts, mss, mu, pval, orss, rss, vss ! functions integer :: getnam character (len=6) :: pstring double precision :: ln interface subroutine csimped(ped, dataset, untyped, set, xlinkd) use ped_class integer, intent(in) :: ped type (ped_data) :: dataset logical, dimension(:), intent(in) :: untyped integer, dimension(:,:), intent(inout) :: set logical, intent(in) :: xlinkd end subroutine end interface call setup_freq(10, allele_buffer) call freq(gene, genetyp, freqfnd, dataset, allele_buffer) it=0 nobs=0 ncats=allele_buffer%numal nter=ncats+1 ncov=nter*(nter+1)/2 gen2=gene+1 ! ! allocate work arrays ! allocate(counts(ncats)) allocate(x(nter)) allocate(b(nter)) allocate(cov(ncov), r(ncov)) call inicov(nter, ncov, r) bss=0.0d0 mu=0.0d0 nuntyp=0 do i=1, ncats counts(i)=0 end do do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) ! load set() with genotypes do i=pedoffset+1, dataset%num(ped) contrib(i)=.false. untyped(i)=.false. if (.not.observed(i, gene, dataset)) then untyped(i)=.true. set(i,1)=MISS set(i,2)=MISS else call get_namedgeno(i, gene, gen2, dataset, allele_buffer, & set(i,1), set(i,2)) end if end do ! ! Only phenotyped persons with genotyped parents used-> value() set to trait do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped) if (dataset%plocus(i,trait) /= MISS .and. & .not.untyped(i) .and. & .not.untyped(dataset%fa(i)) .and. & .not.untyped(dataset%mo(i))) then contrib(i)=.true. nobs=nobs+1 do j=1, allele_buffer%numal x(j)=0.0d0 end do x(nter)=dataset%plocus(i,trait) x(set(i,1))=x(set(i,1))+1 x(set(i,2))=x(set(i,2))+1 counts(set(i,1))=counts(set(i,1))+1 counts(set(i,2))=counts(set(i,2))+1 call moment(nobs, x(nter), mu, bss) call givenc(r, ncov, nter, x, 1.0d0, ifail) end if end do end if end do if (nobs == 0) then if (plevel > 0) then write(outstr,'(/a,a10,a/a/a/2(/a,i7))') & ' ------ QTL Association with "',locnam,'"-------', & ' ------ Conditioned on Parental Genotype -------', & ' -----------------------------------------------', & ' No. trait(+) marker(-) =',nuntyp, & ' No. trait(+) marker(+) =',nobs else if (plevel > -2) then write(outstr,'(a20,2(1x,i6),1x,f10.1,2(1x,f6.4),1x,i8,1x,a)') & locnam, nobs, 0, 0.0D0, 1.0D0, 1.0D0, 0, 'ANOVA-CPG .' end if return end if call alias(r, ncov, nter, 1.0d-15, x, ifail) call bsub(r, ncov, nter, b, ncats, ifail) call var(r, ncov, cov, ncov, nter, nobs, 1, ifail) mdf=0 mss=0.0d0 do i=1, ncats call sscomp(r, ncov, nter, nobs, i, rss, idf, ifail) mdf=mdf+idf mss=mss+rss end do call sscomp(r, ncov, nter, nobs, 0, orss, idf, ifail) lrts=dble(nobs) * (ln(bss)-ln(orss)) asyp=chip(lrts,max(1,mdf-1)) mss=mss/dble(max(1,mdf)) orss=orss/dble(max(1,idf)) if (plevel > 0) then write(outstr,'(/a,a10,a/a/a/a)') & ' ------ QTL Association with "',locnam,'"-------', & ' ------ Conditioned on Parental Genotype -------', & ' Allele Allelic Mean Stand Error Count', & ' -----------------------------------------------' ii=0 DO i=1, ncats ii=ii+i call wrall(allele_buffer%allele_names(i), allel) write(outstr,'(5x,a3,5x,f12.4,3x,f12.4,1x,i7)') & allel, b(i), sqrt(cov(ii)), counts(i) end do write(outstr,'(a/a,f12.4,3x,f12.4,1x,i7)') & ' ----------------------------------------------', & ' Total ',mu, sqrt(bss/dble(max(1,nobs-1))), 2*nobs write(outstr,'(2(/a,i7),2(/a,f12.4,a,i4,a))') & ' No. trait(+) marker(-) =', nuntyp, & ' No. trait(+) marker(+) =', nobs, & ' Model Mean Square =', mss, ' (df=', mdf, ')', & ' Mean Square Error =', orss, ' (df=', idf, ')' write(outstr,'(a,f12.4,/a,f12.4)') & ' Likelihood ratio test =',lrts, & ' Nominal P-value =',asyp end if if (iter > 0 .and. nobs > 1 .and. ncats > 1) then ! ! Sequential Monte-Carlo P-value after Besag & Clifford Biometrika 1991 ! P= tailp/it if tailp=mincnt or (tailp+1)/(it+1) if tailp<mincnt && it=iter mss=0.0D0 vss=0.0D0 it=0 tailp=0 do while (it < iter .and. tailp < mincnt) it=it+1 call inicov(nter, ncov, r) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then call csimped(ped, dataset, untyped, set, allele_buffer%xlinkd) do i=dataset%num(ped-1)+1, dataset%num(ped) if (contrib(i)) then do j=1, ncats x(j)=0.0d0 end do x(nter)=dataset%plocus(i, trait) x(set(i,1))=x(set(i,1))+1 x(set(i,2))=x(set(i,2))+1 call givenc(r, ncov, nter, x, 1.0d0, ifail) end if end do end if end do call alias(r, ncov, nter, 1.0d-15, x, ifail) call sscomp(r, ncov, nter, nobs, 0, rss, idf, ifail) rss=rss/dble(max(1,idf)) call moment(it, rss, mss, vss) if (abs(rss-orss) < EPS) then if (random() > 0.5d0) tailp=tailp+1 else if (rss < orss) then tailp=tailp+1 end if if (plevel > 1) then write(outstr,'(/a,i8,a,f12.4)') 'Pseudosample ',it,': MSE=',rss end if end do if (tailp < mincnt) then tailp=tailp+1 it=it+1 end if vss=vss/dble(max(1, it-1)) pval=dble(tailp)/dble(it) else tailp=0 pval=1.0d0 end if if (plevel > 0) then write(outstr,'(a,i0,a,i0,3a/a,f12.4,a,f12.4,a)') & ' Equalled or exceeded by =', tailp, '/', it, & ' simulated values (', trim(pstring(pval)), ')', & ' Mean (SD) simulated MSE =', mss, ' (', sqrt(vss), ')' else if (plevel > -2) then call phist(asyp, pval, histo) write(outstr,'(a20,2(a1,i6),a1,f10.1,2(a1,a),a1,i8,2(a1,a))') & locnam, tabsep, nobs, tabsep, mdf, tabsep, lrts, tabsep, & pstring(asyp), tabsep, pstring(pval), tabsep, it, tabsep, & 'ANOVA-CPG', tabsep, histo end if end subroutine cpganova ! ! MC approach to association to haploid markers ! ! Enumerate haplotypes for haploid SNPs ! subroutine haploid_count(nloc, loclist, loc, locpos, loctyp, dataset, & haplotable) use contingency_table use ped_class use locus_types implicit none integer, intent(in) :: nloc ! number of markers integer, intent(in) :: loclist(nloc) ! haplotype list character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp type (ped_data) :: dataset type (table_data) :: haplotable integer :: g1, g2, i, j, lpos double precision, dimension(nloc) :: val ! data for one individual ! person: do i=1, dataset%nobs if (dataset%actset(dataset%iped(i)) > 0) then dataset%untyped(i)=.true. do j=1, nloc lpos=locpos(loclist(j)) if (.not.observed(i, lpos, dataset)) then cycle person else call get_geno(i, lpos, lpos, dataset, g1, g2) val(j)=dble(g1) end if end do dataset%untyped(i)=.false. call insert_table(nloc, val, haplotable, 1) end if end do person end subroutine haploid_count ! ! encode observed haplotypes ! subroutine set_hval(nloc, loclist, loc, locpos, loctyp, & haplotable, hval, dataset, plevel) use contingency_table use ped_class use locus_types implicit none integer, intent(in) :: nloc ! number of markers integer, intent(in) :: loclist(nloc) ! haplotype list character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp type (table_data) :: haplotable type (ped_data) :: dataset integer, dimension(dataset%nobs) :: hval integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS=-9999 integer :: g1, g2, i, j, lpos, ped, pedoffset type (table_cell), dimension(nloc) :: val ! data for one individual do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) if (.not.dataset%untyped(i)) then do j=1, nloc lpos=locpos(loclist(j)) call get_geno(i, lpos, lpos, dataset, g1, g2) call set_table_cell(val(j), rvalue=dble(g1)) end do hval(i)=search_table(nloc, val, haplotable, plevel-2) else hval(i)=MISS end if end do end if end do end subroutine set_hval ! ! fill in missing haplotypes and check for mutation/error ! subroutine fillin_yha(haplotable, hval, dataset, plevel) use outstream use contingency_table use ped_class implicit none type (table_data) :: haplotable type (ped_data) :: dataset integer, dimension(dataset%nobs) :: hval integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS=-9999 integer :: i, incon, j, ped, pedoffset logical :: fin incon=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) fin=.false. do while (.not.fin) fin=.true. do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped) if (dataset%sex(i) == 1) then if (hval(dataset%fa(i)) /= MISS .and. hval(i) == MISS) then call incr_table(hval(dataset%fa(i)), haplotable, 1) hval(i)=hval(dataset%fa(i)) fin=.false. else if (hval(dataset%fa(i)) == MISS .and. hval(i) /= MISS) then call incr_table(hval(i), haplotable, 1) hval(dataset%fa(i))=hval(i) fin=.false. end if end if end do end do do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped) if (hval(dataset%fa(i)) /= MISS .and. & hval(dataset%fa(i)) /= hval(i) .and. & dataset%sex(i) == 1) then incon=incon+1 if (plevel > 0) then write(outstr, '(4a)') 'Father-son inconsistency due to ', & trim(dataset%pedigree(ped)), '--', trim(dataset%id(i)) end if end if end do end if end do end subroutine fillin_yha ! ! Mitochondrial ! subroutine fillin_mit(haplotable, hval, dataset, plevel) use outstream use contingency_table use ped_class implicit none type (table_data) :: haplotable type (ped_data) :: dataset integer, dimension(dataset%nobs) :: hval integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS=-9999 integer :: i, incon, j, ped, pedoffset logical :: fin incon=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) fin=.false. do while (.not.fin) fin=.true. do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped) if (hval(dataset%mo(i)) /= MISS .and. hval(i) == MISS) then call incr_table(hval(dataset%mo(i)), haplotable, 1) hval(i)=hval(dataset%mo(i)) fin=.false. else if (hval(dataset%mo(i)) == MISS .and. hval(i) /= MISS) then call incr_table(hval(i), haplotable, 1) hval(dataset%mo(i))=hval(i) fin=.false. end if end do end do do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped) if (hval(dataset%mo(i)) /= MISS .and. hval(dataset%mo(i)) /= hval(i)) then incon=incon+1 if (plevel > 0) then write(outstr, '(4a)') 'Mother-offspring inconsistency due to ', & trim(dataset%pedigree(ped)), '--', trim(dataset%id(i)) end if end if end do end if end do end subroutine fillin_mit ! ! Count of haplotypes from haploid markers ! subroutine haploid_freq(nloc, loclist, loc, locpos, loctyp, & dataset, plevel, typ) use interrupt use outstream use sorts use contingency_table use ped_class use locus_types implicit none integer, intent(in) :: nloc ! number of markers integer, intent(in) :: loclist(nloc) ! haplotype list character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp type (ped_data) :: dataset integer, intent(in) :: plevel integer, intent(in) :: typ integer, parameter :: KNOWN=0, MISS=-9999 double precision, dimension(nloc) :: val ! data for one individual ! ! Mitochondrial or Y marker tabulation ! type (table_data) :: haplotable, traittable ! called haplotypes integer, dimension(dataset%nobs) :: hval integer :: nhap integer, dimension(:), allocatable :: counts, idx double precision, dimension(:), allocatable :: prop integer :: g1, g2, gen2, geno, i, ii, inherit, j, k, lpos, lpos2, n, & nloc2, nf, nobs, pedoffset, ped, pos, tot logical :: fin, makehap character (len=3) :: allel ! functions interface subroutine haploid_count(nloc, loclist, loc, locpos, loctyp, dataset, & haplotable) use contingency_table use ped_class use locus_types implicit none integer, intent(in) :: nloc ! number of markers integer, intent(in) :: loclist(nloc) ! haplotype list character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp type (ped_data) :: dataset type (table_data) :: haplotable end subroutine haploid_count subroutine set_hval(nloc, loclist, loc, locpos, loctyp, & haplotable, hval, dataset, plevel) use contingency_table use ped_class use locus_types implicit none integer, intent(in) :: nloc ! number of markers integer, intent(in) :: loclist(nloc) ! haplotype list character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp type (table_data) :: haplotable type (ped_data) :: dataset integer, dimension(dataset%nobs) :: hval integer, intent(in) :: plevel end subroutine set_hval subroutine fillin_mit(haplotable, hval, dataset, plevel) use outstream use contingency_table use ped_class implicit none type (table_data) :: haplotable type (ped_data) :: dataset integer, dimension(dataset%nobs) :: hval integer, intent(in) :: plevel end subroutine fillin_mit subroutine fillin_yha(haplotable, hval, dataset, plevel) use outstream use contingency_table use ped_class implicit none type (table_data) :: haplotable type (ped_data) :: dataset integer, dimension(dataset%nobs) :: hval integer, intent(in) :: plevel end subroutine fillin_yha subroutine ascend(n, ia) integer, intent(in) :: n integer, dimension(:), intent(inout) :: ia end subroutine end interface makehap=(typ > 2) inherit=2-mod(typ,2) nloc2=nloc if (makehap) nloc2=nloc2-1 if (inherit == 1) then allel='Y' else allel='Mit' end if write(outstr,'(/3a)', advance='no') trim(allel), '-Markers: ', trim(loc(loclist(1))) do j=2, nloc2 write(outstr,'(2a)', advance='no') '-', trim(loc(loclist(j))) end do write(outstr,*) if (makehap) then write(outstr,'(3a)') 'Writing haplotypes to locus "', trim(loc(loclist(nloc))),'".' end if call setup_table(nloc2, 100, haplotable) ! ! enumerate the observed haplotypes call haploid_count(nloc2, loclist, loc, locpos, loctyp, dataset, & haplotable) nhap=haplotable%ncells ! ! fill in missing haplotypes and check for mutation/error ! call set_hval(nloc2, loclist, loc, locpos, loctyp, & haplotable, hval, dataset, plevel) if (inherit == 1) then call fillin_yha(haplotable, hval, dataset, plevel) else call fillin_mit(haplotable, hval, dataset, plevel) end if ! ! allocate work arrays ! allocate(idx(nhap), counts(nhap)) call ascend(nhap,idx) ! nf=0 nobs=0 counts=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then nf=nf+dataset%nfound(ped) pedoffset=dataset%num(ped-1) do i=pedoffset+1, pedoffset+dataset%nfound(ped) if (.not.dataset%untyped(i)) then nobs=nobs+1 counts(hval(i))=counts(hval(i))+1 end if end do end if end do call isort(1, nhap, counts, idx, 2) write(outstr,'(/a/a)') & ' Hap Count (Founder Prop) Haplotype', & '----- -------------------- -----------------------' do ii=nhap, 1, -1 i=idx(ii) pos=haplotable%idx(i) write(outstr,'(i4,1x,i10,1x,a1,f5.4,a1)', advance='no') & nhap+1-ii, haplotable%icount(pos), '(', dble(counts(ii))/dble(max(1,nobs)), ')' call wrall(int(haplotable%categories(pos,1)%rvalue), allel) write(outstr,'(5x,a)', advance='no') trim(adjustl(allel)) do j=2, nloc2 call wrall(int(haplotable%categories(pos,j)%rvalue), allel) write(outstr,'(2a)', advance='no') '-', trim(adjustl(allel)) end do write(outstr,*) end do write(outstr,'(a//a,i10/a,i10,a,i0,a)') & '----- -------------------- -----------------------', & ' Number of observed haplotypes = ', haplotable%ntot, & ' Number of founder haplotypes = ', nobs, ' (out of possible ', nf ,')' if (makehap) then lpos=locpos(loclist(nloc)) lpos2=lpos+1 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) if (hval(i) /= MISS) then g1=nhap+1-idx(hval(i)) call set_geno(i, lpos, lpos2, dataset, g1, g1) if (plevel > 1) then write(outstr,'(5a,i0)') 'Setting ', & trim(dataset%pedigree(ped)), '--', trim(dataset%id(i)), ' to ', g1 end if else call set_geno(i, lpos, lpos2, dataset, MISS, MISS) end if end do end if end do end if end subroutine haploid_freq ! ! MC approach to association to haploid markers ! subroutine haploid_aov(trait, nloc, loclist, loc, locpos, loctyp, & iter, mincnt, dataset, pval, plevel, typ) use interrupt use outstream use contingency_table use ped_class use locus_types use rngs use statfuns use AS164 implicit none integer, intent(in) :: trait integer, intent(in) :: nloc ! number of markers integer, intent(in) :: loclist(nloc) ! haplotype list character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp integer, intent(in) :: iter integer, intent(in) :: mincnt type (ped_data) :: dataset double precision, intent(out) :: pval integer, intent(in) :: plevel integer, intent(in) :: typ integer, parameter :: KNOWN=0, MISS=-9999 double precision, dimension(nloc) :: val ! data for one individual ! ! Mitochondrial or Y marker tabulation ! type (table_data) :: haplotable ! called haplotypes integer, dimension(dataset%nobs) :: hval integer :: nhap integer, dimension(:), allocatable :: counts double precision, dimension(:), allocatable :: cumhaps ! regression work arrays double precision, dimension(:), allocatable :: b, x double precision, dimension(:), allocatable :: cov, r integer :: g1, g2, gen2, geno, i, idf, ifail, ii, incon, it, j, lpos, mdf, n, & nmiss, ncov, nobs, nter, tailp, nuntyp, pedoffset, ped, pos, tot, tpos logical :: fin character (len=3) :: allel, histo character (len=64) :: haplo double precision :: asyp, bss, den, orss, lrts, mss, mu, rss, vg, vss ! functions ! chip character (len=6) :: pstring double precision :: ln interface subroutine haploid_count(nloc, loclist, loc, locpos, loctyp, dataset, & haplotable) use contingency_table use ped_class use locus_types implicit none integer, intent(in) :: nloc ! number of markers integer, intent(in) :: loclist(nloc) ! haplotype list character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp type (ped_data) :: dataset type (table_data) :: haplotable end subroutine haploid_count subroutine set_hval(nloc, loclist, loc, locpos, loctyp, & haplotable, hval, dataset, plevel) use contingency_table use ped_class use locus_types implicit none integer, intent(in) :: nloc ! number of markers integer, intent(in) :: loclist(nloc) ! haplotype list character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp type (table_data) :: haplotable type (ped_data) :: dataset integer, dimension(dataset%nobs) :: hval integer, intent(in) :: plevel end subroutine set_hval subroutine fillin_mit(haplotable, hval, dataset, plevel) use outstream use contingency_table use ped_class implicit none type (table_data) :: haplotable type (ped_data) :: dataset integer, dimension(dataset%nobs) :: hval integer, intent(in) :: plevel end subroutine fillin_mit subroutine fillin_yha(haplotable, hval, dataset, plevel) use outstream use contingency_table use ped_class implicit none type (table_data) :: haplotable type (ped_data) :: dataset integer, dimension(dataset%nobs) :: hval integer, intent(in) :: plevel end subroutine fillin_yha end interface if (typ == 1) then allel='Y' else allel='Mit' end if if (plevel > 0) then write(outstr,'(/3a)', advance='no') trim(allel), '-Markers: ', trim(loc(loclist(1))) do j=2, nloc write(outstr,'(2a)', advance='no') '-', trim(loc(loclist(j))) end do write(outstr,*) end if pval=1.0d0 tpos=locpos(trait) call setup_table(nloc, 100, haplotable) ! ! enumerate the observed haplotypes call haploid_count(nloc, loclist, loc, locpos, loctyp, dataset, & haplotable) nhap=haplotable%ncells if (nhap == 1) then if (plevel > 0) then write(outstr,'(/a)') ' Monomorphic' else histo=' ' allel='yha' if (typ == 2) allel='mit' write(outstr,'(a20,2(1x,i6),1x,f10.1,2(1x,f6.4),1x,i6,1x,2a,1x,a)') & loc(loclist(1)), nobs, 0, 0.0d0, 1.0d0, pval, 0, 'ANOVA-',allel, histo end if return end if ! ! fill in missing haplotypes and check for mutation/error ! call set_hval(nloc, loclist, loc, locpos, loctyp, & haplotable, hval, dataset, plevel) if (typ == 1) then call fillin_yha(haplotable, hval, dataset, plevel) else call fillin_mit(haplotable, hval, dataset, plevel) end if ! ! allocate work arrays ! nter=nhap+1 ncov=nter*(nter+1)/2 allocate(x(nter)) allocate(b(nter)) allocate(cov(ncov), r(ncov)) call inicov(nter, ncov, r) allocate(counts(nhap)) ! ! Do ANOVA ! nobs=0 nuntyp=0 do i=1, nhap counts(i)=0 end do bss=0.0d0 mu=0.0d0 vg=0.0d0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) if (dataset%plocus(i,tpos) /= MISS) then if (hval(i) /= MISS) then nobs=nobs+1 counts(hval(i))=counts(hval(i))+1 do j=1, nhap x(j)=0.0d0 end do x(nter)=dataset%plocus(i,tpos) x(hval(i))=x(hval(i))+1 call moment(nobs, x(nter), mu, bss) call givenc(r, ncov, nter, x, 1.0d0, ifail) else nuntyp=nuntyp+1 end if end if end do end if end do call alias(r, ncov, nter, 1.0d-15, x, ifail) call bsub(r, ncov, nter, b, nhap, ifail) call var(r, ncov, cov, ncov, nter, nobs, 1, ifail) mdf=0 mss=0.0d0 do i=1, nhap call sscomp(r, ncov, nter, nobs, i, rss, idf, ifail) mdf=mdf+idf mss=mss+rss end do call sscomp(r, ncov, nter, nobs, 0, orss, idf, ifail) lrts=0.0d0 if (bss > 0.0d0 ) lrts=dble(nobs) * (ln(bss)-ln(orss)) asyp=chip(lrts, max(1, mdf-1)) mss=mss/dble(max(1, mdf)) orss=orss/dble(max(1, idf)) if (plevel > 0) then write(outstr,'(/a/a)') & ' Haplotype Mean Stand Error Count', & '------------------------------------------------------------' ii=0 do i=1, nhap pos=haplotable%idx(i) call wrall(int(haplotable%categories(pos,1)%rvalue), allel) haplo=trim(adjustl(allel)) do j=2, nloc call wrall(int(haplotable%categories(pos,j)%rvalue), allel) haplo=trim(haplo) // '-' // trim(adjustl(allel)) end do write(outstr,'(1x,a24,f12.4,3x,f12.4,1x,i7)') & haplo, b(i), sqrt(cov(ii)), counts(i) end do write(outstr,'(a/a,19x,f12.4,3x,f12.4,1x,i7)') & '------------------------------------------------------------', & ' Total',mu, sqrt(bss/dble(max(1,nobs-1))), nobs write(outstr,'(2(/a,i7),2(/a,f12.4,a,i4,a))') & ' No. trait(+) marker(-) =', nuntyp, & ' No. trait(+) marker(+) =', nobs, & ' Model Mean Square =', mss, ' (df=',mdf,')', & ' Mean Square Error =', orss, ' (df=',idf,')' write(outstr,'(a,f12.4,/a,f12.4)') & ' Likelihood ratio test =', lrts, & ' Nominal P-value =', asyp end if it=0 if (iter > 0 .and. nobs > 1) then ! ! Sequential Monte-Carlo P-value after Besag & Clifford Biometrika 1991 ! allocate(cumhaps(nhap)) den=1.0d0/dble(haplotable%ntot) tot=haplotable%icount(haplotable%idx(1)) cumhaps(1)=den*dble(tot) cumhaps(nhap)=1.0d0 do i=2, nhap-1 tot=tot+haplotable%icount(haplotable%idx(i)) cumhaps(i)=den*dble(tot) end do mss=0.0D0 vss=0.0D0 tailp=0 do while (it < iter .and. tailp < mincnt .and. irupt==0) it=it+1 call inicov(nter, ncov, r) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) call simhaploid(typ, ped, dataset, nhap, cumhaps, hval) do i=pedoffset+1, dataset%num(ped) if (hval(i) /= MISS .and. dataset%plocus(i,tpos) /= MISS) then do j=1, haplotable%ncells x(j)=0.0d0 end do x(nter)=dataset%plocus(i,tpos) x(hval(i))=x(hval(i))+1 call givenc(r, ncov, nter, x, 1.0d0, ifail) end if end do end if end do call alias(r, ncov, nter, 1.0d-15, x, ifail) call sscomp(r, ncov, nter, nobs, 0, rss, idf, ifail) rss=rss/dble(max(1,idf)) call moment(it, rss, mss, vss) if (rss < orss .or. (rss == orss .and. random() > 0.5d0)) then tailp=tailp+1 end if if (plevel > 1) then write(outstr,'(/a,i8,a,f12.4)') 'Pseudosample ',it,': MSE=',rss end if end do if (tailp < mincnt) then tailp=tailp+1 it=it+1 end if vss=vss/dble(max(1, it-1)) pval=dble(tailp)/dble(it) else tailp=0 pval=1.0d0 end if if (plevel > 0) then write(outstr,'(a,i0,a,i0,3a/a,f12.4,a,f12.4,a)') & ' Equalled or exceeded by =', tailp, '/', it, & ' simulated values (', trim(pstring(pval)), ')', & ' Mean (SD) simulated MSE =', mss, ' (', sqrt(vss), ')' else call phist(asyp, pval, histo) allel='yha' if (typ == 2) allel='mit' write(outstr,'(a20,2(1x,i6),1x,f10.1,2(1x,a),1x,i6,1x,2a,1x,a)') & loc(loclist(1)), nobs, mdf, lrts, pstring(asyp), pstring(pval), & it, 'ANOVA-',allel, histo end if if (iter == 0) pval=asyp end subroutine haploid_aov ! ! Count of marker alleles/genotypes in cases and controls -- haploid marker(s) ! subroutine haploid_ass(trait, nloc, loclist, loc, locpos, loctyp, locnotes, & assoc_stat, iter, mincnt, dataset, pval, plevel, typ) use interrupt use outstream use contingency_table use ped_class use locus_types use rngs use statfuns use categorical_data implicit none ! external :: assoc_stat integer, intent(in) :: trait integer, intent(in) :: nloc ! number of markers integer, intent(in) :: loclist(nloc) ! haplotype list character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp character (len=40), dimension(:), intent(in) :: locnotes integer, intent(in) :: iter integer, intent(in) :: mincnt type (ped_data) :: dataset double precision, intent(out) :: pval integer, intent(in) :: plevel integer, intent(in) :: typ integer, parameter :: KNOWN=0, MISS=-9999 double precision, dimension(nloc) :: val ! data for one individual ! ! Mitochondrial or Y marker tabulation ! type (table_data) :: haplotable, traittable ! called haplotypes and phenotypes integer, dimension(dataset%nobs) :: aff, hval integer :: nhap, traitlevels double precision, dimension(:), allocatable :: cumhaps ! flat table nhap x traitlevels (+2) integer, dimension(:,:), allocatable :: cntall integer, dimension(:), allocatable :: nca ! per-group diversities double precision, dimension(:), allocatable :: diversities integer :: g1, g2, gen2, geno, i, idf, ifail, ii, incon, it, j, k, lpos, n, & nmiss, ncov, nobs, tailp, nuntyp, pedoffset, ped, pos, tot, tpos logical :: fin character (len=3) :: allel, histo character (len=12) :: cval character (len=64) :: haplo integer :: df ! Within-group and total population diversity double precision :: gst, hs, ht, p, pt double precision :: asyp, chisq, den, ochisq, mchisq, vchisq ! functions ! chip character (len=6) :: pstring double precision :: ln interface subroutine haploid_count(nloc, loclist, loc, locpos, loctyp, dataset, & haplotable) use contingency_table use ped_class use locus_types implicit none integer, intent(in) :: nloc ! number of markers integer, intent(in) :: loclist(nloc) ! haplotype list character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp type (ped_data) :: dataset type (table_data) :: haplotable end subroutine haploid_count subroutine set_hval(nloc, loclist, loc, locpos, loctyp, & haplotable, hval, dataset, plevel) use contingency_table use ped_class use locus_types implicit none integer, intent(in) :: nloc ! number of markers integer, intent(in) :: loclist(nloc) ! haplotype list character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp type (table_data) :: haplotable type (ped_data) :: dataset integer, dimension(dataset%nobs) :: hval integer, intent(in) :: plevel end subroutine set_hval subroutine fillin_mit(haplotable, hval, dataset, plevel) use outstream use contingency_table use ped_class implicit none type (table_data) :: haplotable type (ped_data) :: dataset integer, dimension(dataset%nobs) :: hval integer, intent(in) :: plevel end subroutine fillin_mit subroutine fillin_yha(haplotable, hval, dataset, plevel) use outstream use contingency_table use ped_class implicit none type (table_data) :: haplotable type (ped_data) :: dataset integer, dimension(dataset%nobs) :: hval integer, intent(in) :: plevel end subroutine fillin_yha end interface interface function assoc_stat(sta, fin, nlev, nca, cntall) double precision assoc_stat integer, intent(in) :: sta, fin, nlev integer, dimension(:), intent(in) :: nca integer, dimension(:,:), intent(in) :: cntall end function assoc_stat end interface if (typ == 1) then allel='Y' else allel='Mit' end if if (plevel > 0) then write(outstr,'(/3a)', advance='no') trim(allel), '-Markers: ', trim(loc(loclist(1))) do j=2, nloc write(outstr,'(2a)', advance='no') '-', trim(loc(loclist(j))) end do write(outstr,*) end if gst=0.0d0 hs=0.0d0 ht=0.0d0 pval=1.0d0 call setup_table(nloc, 100, haplotable) ! ! enumerate the observed haplotypes call haploid_count(nloc, loclist, loc, locpos, loctyp, dataset, & haplotable) nhap=haplotable%ncells if (nhap == 1) then if (plevel > 0) then write(outstr,'(/a)') ' Monomorphic' else histo=' ' allel='yha' if (typ == 2) allel='mit' write(outstr,'(a20,2(1x,i6),1x,f10.1,2(1x,f6.4),1x,i8,1x,2a,1x,a)') & loc(loclist(1)), nobs, 0, 0.0d0, 1.0d0, pval, 0, 'Ass-',allel, histo end if return end if ! ! fill in missing haplotypes and check for mutation/error ! call set_hval(nloc, loclist, loc, locpos, loctyp, & haplotable, hval, dataset, plevel) if (typ == 1) then call fillin_yha(haplotable, hval, dataset, plevel) else call fillin_mit(haplotable, hval, dataset, plevel) end if ! ! Enumerate trait levels ! tpos=locpos(trait) nuntyp=0 call setup_table(1, 30, traittable) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) n=dataset%num(ped) ! if (assfnd) then ! n=pedoffset+dataset%nfound(ped) ! end if do i=pedoffset+1, n if (dataset%plocus(i,tpos) /= MISS .and. .not.dataset%untyped(i)) then val(1)=dataset%plocus(i,tpos) call insert_table(1, val, traittable, 1) else nuntyp=nuntyp+1 dataset%untyped(i)=.true. end if end do end if end do traitlevels=traittable%ncells ! ! allocate work arrays ! allocate(cntall(nhap, traitlevels+2)) allocate(nca(traitlevels)) allocate(diversities(traitlevels)) ! df=0 nobs=0 aff=MISS cntall=0 nca=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) if (.not.dataset%untyped(i)) then nobs=nobs+1 aff(i)=findlev(dataset%plocus(i,tpos), traittable) cntall(hval(i), aff(i))=cntall(hval(i), aff(i))+1 end if end do end if end do do j=1, nhap do k=1, traitlevels nca(k)=nca(k)+cntall(j,k) cntall(j,traitlevels+1)=cntall(j,traitlevels+1)+cntall(j,k) end do if (cntall(j,traitlevels+1) > 0) df=df+1 cntall(j,traitlevels+2)=j end do df=(df-1)*(traitlevels-1) ochisq=assoc_stat(1, nhap, traitlevels, nca, cntall) asyp=chip(ochisq,df) ! Gst calculation diversities=1.0d0 do k=1, traitlevels den=dble(max(1,nca(k))) do j=1, nhap p=dble(cntall(j,k))/den pt=dble(cntall(j,traitlevels+1))/dble(nobs) diversities(k)=diversities(k)-p*p ht=ht+(p-pt)**2 end do diversities(k)=dble(max(1,nca(k)))/dble(max(1,nca(k)-1)) * & diversities(k) hs=hs+diversities(k) end do ht=1.0d0+ht/(dble(max(1,nobs*(nobs-1)))) do j=1, nhap pt=dble(cntall(j,traitlevels+1))/dble(nobs) ht=ht-pt*pt end do hs=hs/dble(traitlevels) gst=1.0d0-hs/ht if (plevel > 0) then write(outstr,'(/a)', advance='no') & ' Haplotype ' do k=1, traitlevels pos=traittable%idx(k) call wrtrait(traittable%categories(pos,1)%rvalue, cval, & loctyp(trait), get_notes(loc(trait), locnotes(trait)), 9, 4) write(outstr,'(2x,a)',advance='no') cval end do write(outstr,'(4x,a/2a)') & 'Total', & '-----------------------------------------------------', & repeat('-', max(0,traitlevels-1)*14) ii=0 do i=1, nhap pos=haplotable%idx(i) ii=ii+i call wrall(int(haplotable%categories(pos,1)%rvalue), allel) haplo=trim(adjustl(allel)) do j=2, nloc call wrall(int(haplotable%categories(pos,j)%rvalue), allel) haplo=trim(haplo) // '-' // trim(adjustl(allel)) end do write(outstr,'(1x,a24)', advance='no') haplo do k=1, traitlevels write(outstr,'(2x,i5,1x,a1,f4.3,a1)', advance='no') & cntall(i,k), '(', dble(cntall(i,k))/dble(max(1,nca(k))), ')' end do write(outstr,'(1x,i13)') cntall(i,traitlevels+1) end do write(outstr,'(2a)') & '-----------------------------------------------------', & repeat('-', max(0,traitlevels-1)*14) write(outstr,'(a,14x)', advance='no') 'Allelic diversity' do k=1, traitlevels write(outstr,'(1x,f6.4,7x)',advance='no') diversities(k) end do write(outstr,'(2x,f6.4)') ht write(outstr,'(2a)') & '-----------------------------------------------------', & repeat('-', max(0,traitlevels-1)*14) write(outstr,'(/a,i6)') & ' No. trait(+) marker(-) =', nuntyp write(outstr,'(a,i6)') & ' No. trait(+) marker(+) =', nobs write(outstr,'(a,3x,f6.4)') & ' Gst =', gst write(outstr,'(a,f6.1/a,i4/a,3x,a)') & ' Contingency chi-square =', ochisq, & ' Nominal degrees of freedom =', df, & ' Nominal P-value =', pstring(asyp) end if ! ! if founders only, or no cases or no controls or iter=0, then ! Monte-Carlo procedure superfluous ! it=0 mchisq=0.0d0 vchisq=0.0d0 tailp=0 if (iter == 0 .or. nhap < 2) then pval=1.0d0 else ! ! Sequential Monte-Carlo P-value after Besag & Clifford Biometrika 1991 ! P= tailp/it if tailp=mincnt or (tailp+1)/(it+1) if tailp<mincnt && it=iter ! allocate(cumhaps(nhap)) den=1.0d0/dble(haplotable%ntot) tot=haplotable%icount(haplotable%idx(1)) cumhaps(1)=den*dble(tot) cumhaps(nhap)=1.0d0 do i=2, nhap-1 tot=tot+haplotable%icount(haplotable%idx(i)) cumhaps(i)=den*dble(tot) end do do while (it < iter .and. tailp < mincnt .and. irupt == 0) it=it+1 do j=1, nhap do k=1, traitlevels+1 cntall(j,k)=0 end do end do do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) call simhaploid(typ, ped, dataset, nhap, cumhaps, hval) do i=pedoffset+1, dataset%num(ped) if (aff(i) /= MISS) then cntall(hval(i), aff(i))=cntall(hval(i), aff(i))+1 end if end do end if end do tot=0 do i=1, nhap do j=1, traitlevels cntall(i,traitlevels+1)=cntall(i,traitlevels+1)+cntall(i,j) tot=tot+cntall(i,j) end do end do chisq=assoc_stat(1, nhap, traitlevels, nca, cntall) call moment(it, chisq, mchisq, vchisq) if (chisq > ochisq .or. (chisq == ochisq .and. random() > 0.5)) then tailp=tailp+1 end if if (plevel > 1) then write(outstr,'(/a,i8,a,f6.1)') 'Pseudosample ',it,': Chisq=',chisq do i=1, nhap write(outstr,'(i8,10(2x,i5):)') & cntall(i,traitlevels+2), cntall(i,1:(traitlevels+1)) end do end if end do if (tailp < mincnt) then tailp=tailp+1 it=it+1 end if vchisq=vchisq/dble(max(1,it-1)) pval=dble(tailp)/dble(it) end if if (plevel > 0) then write(outstr, '(a,i0,a,i0,3a/a,f6.1,a,f6.1,a)') & ' Equalled or exceeded by =',tailp,'/',it, & ' simulated values (', trim(pstring(pval)), ')', & ' Mean (Var) simulated chi-sqs =',mchisq, ' (', vchisq, ')' else if (plevel > -2) then call phist(asyp, pval, histo) allel='yha' if (typ == 2) allel='mit' write(outstr,'(a20,2(a1,i6),a1,f10.1,2(a1,a),a1,i8,a1,2a,a1,a)') & loc(loclist(1)), tabsep, nobs, tabsep, nhap, tabsep, ochisq, tabsep, & pstring(asyp), tabsep, pstring(pval), tabsep, it, tabsep, & 'AssX2-', allel, tabsep, histo end if if (iter == 0) pval=asyp end subroutine haploid_ass ! ! Count of marker alleles/genotypes in cases and controls -- codominant system ! subroutine doassoc(trait, loc, loctyp, locnote, locnam, gene, genetyp, & assoc_stat, iter, mincnt, norder, assfnd, gt, thresh, & conibd, dataset, freqfnd, use_fixfreq, fixfreq_buffer, & allele_buffer2, prevalence, pval, sumstat, plevel, typ) use interrupt use outstream use popgen_vcdata use alleles_class use contingency_table use ped_class use locus_types use comp_ops use rngs use sorts use statfuns use categorical_data implicit none ! integer, intent(in) :: trait character (len=*), intent(in) :: loc integer, intent(in) :: loctyp character (len=*), intent(in) :: locnote character (len=*), intent(in) :: locnam integer, intent(in) :: gene, genetyp integer, intent(in) :: iter integer, intent(in) :: mincnt, norder logical, intent(in) :: assfnd integer, intent(in) :: gt double precision, intent(in) :: thresh integer, intent(in) :: conibd type (ped_data) :: dataset integer, intent(in) :: freqfnd logical, intent(in) :: use_fixfreq type (allele_data), intent(in) :: fixfreq_buffer type (allele_data), intent(in) :: allele_buffer2 double precision, intent(in) :: prevalence double precision, intent(out) :: pval integer, intent(in) :: sumstat integer, intent(in) :: plevel integer, intent(in) :: typ ! local variables integer, parameter :: KNOWN=0, MISS=-9999 type (allele_data) :: allele_buffer ! ! array for allele counts in cases and controls ! integer, dimension(dataset%nobs) :: aff integer, dimension(dataset%maxsiz,2) :: set integer, dimension(:,:), allocatable :: cntall integer, dimension(:), allocatable :: nca, nmalca ! ! Marginal trait tabulation ! type (table_data) :: traittable double precision, dimension(1) :: val logical :: allelic, multcat ! F statistics integer, dimension(:), allocatable :: eh, nhom double precision, dimension(:), allocatable :: d double precision :: h0, h01, hs, hs1, ht, ht1, fis, fit, fst ! other local variables integer :: df, g1, g2, gen2, geno, i, iaff, ii, it, j, k, kk, & malcats, n, ncats, ntot, nmal, nuntyp, & pedoffset, ped, pos, sexlim, tailp, traitlevels character (len=3) :: allel, ana, histo character (len=7) :: gtp character (len=12) :: cval ! used to calculate penetrances, attributable risk, risk allele, and rec risks integer :: goodall, testall double precision :: attrisk, casden, casfrq, conden, confrq, gfrq, & h2, popcas, popcon, prrr, va, vd, vt double precision, dimension(:), allocatable :: alpha, popfreq, pen double precision :: asyp, chisq, mchisq, ochisq, pexp, vchisq, zstat double precision :: odds0, odds1 ! ! used to extrapolate extreme tail empirical P values using ! David & Resnick ! integer :: ntopvals double precision, dimension(norder+2) :: topvals ! functions ! chip integer :: clcpos, getnam character (len=6) :: pstring double precision :: binz, evdtailp, isaff, tetcor interface function assoc_stat(sta, fin, nlev, nca, cntall) double precision assoc_stat integer, intent(in) :: sta, fin, nlev integer, dimension(:), intent(in) :: nca integer, dimension(:,:), intent(in) :: cntall end function assoc_stat subroutine freq(gene, loctyp, fndr, dataset, allele_buffer) use ped_class use alleles_class integer, intent(in) :: gene integer, intent(in) :: loctyp integer, intent(in) :: fndr type (ped_data), intent(in) :: dataset type (allele_data), intent(inout) :: allele_buffer end subroutine freq subroutine simped(ped, dataset, allele_buffer, set) use alleles_class use ped_class integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data), intent(in) :: allele_buffer integer, dimension(:,:), intent(out) :: set end subroutine simped subroutine xsimped(ped, dataset, allele_buffer, set) use alleles_class use ped_class integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data), intent(in) :: allele_buffer integer, dimension(:,:), intent(out) :: set end subroutine xsimped subroutine cisimped(ped, gene, allele_buffer, allele_buffer2, dataset, set) use alleles_class use ped_class implicit none integer, intent(in) :: ped ! pedigree to simulate integer, intent(in) :: gene ! position of marker conditioned on type (allele_data), intent(in) :: allele_buffer ! marker to be simulated type (allele_data), intent(in) :: allele_buffer2 ! marker to condition ibd on type (ped_data) :: dataset ! all the observed data integer, dimension(:,:), intent(out) :: set ! the new simulated marker end subroutine cisimped end interface pval=1.0d0 call setup_freq(10, allele_buffer) if (.not.use_fixfreq) then call freq(gene, genetyp, freqfnd, dataset, allele_buffer) else call copyfreq(fixfreq_buffer, allele_buffer) end if if (allele_buffer%numal == 0) then if (plevel > 0) then write(outstr,'(2a)') 'No complete observations for ', trim(locnam) end if if (sumstat > 0) pval=0.0d0 return end if allelic=.true. multcat=.false. traitlevels=2 malcats=0 sexlim=0 ncats=allele_buffer%numal goodall=1 testall=1 attrisk=0.0d0 casfrq=0.0d0 confrq=0.0d0 prrr=1.0d0 ntopvals = norder+2 topvals=0.0d0 va=0.0d0 vt=0.0d0 ana='HWE' if (typ == 2) then allelic=.false. ncats=ncats*(ncats+1)/2 ana='Gtp' if (allele_buffer%xlinkd) then malcats=allele_buffer%numal end if if (prevalence /= MISS) then allocate(alpha(allele_buffer%numal), popfreq(allele_buffer%numal), pen(ncats)) alpha=0.0d0 attrisk=1.0d0 popfreq=0.0d0 pen=0.0d0 end if end if if ((loctyp == LOC_CAT .or. loctyp == LOC_QUA) .and. gt < COMP_LT) then multcat=.true. call setup_table(1, 30, traittable) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) n=dataset%num(ped) if (assfnd) then n=pedoffset+dataset%nfound(ped) end if do i=pedoffset+1, n if (dataset%plocus(i,trait) /= MISS .and. observed(i, gene, dataset)) then val(1)=dataset%plocus(i,trait) call insert_table(1, val, traittable, 1) end if end do end if end do traitlevels=traittable%ncells end if allocate(nca(traitlevels), nmalca(traitlevels)) allocate(d(traitlevels), eh(traitlevels), nhom(traitlevels)) allocate(cntall(malcats+ncats, traitlevels+2)) df=-1 gen2=gene+1 nhom=0 ntot=0 nmal=0 nuntyp=0 do j=1, malcats+ncats do k=1, traitlevels+1 cntall(j,k)=0 end do end do if (allelic) then do j=1, ncats cntall(j, traitlevels+2)=allele_buffer%allele_names(j) end do else do j=1, ncats cntall(j, traitlevels+2)=j end do if (allele_buffer%xlinkd) then do j=1, malcats cntall(ncats+j, traitlevels+2)=allele_buffer%allele_names(j) end do end if end if fis=0.0d0 fit=0.0d0 fst=0.0d0 h0=0.0d0 hs=0.0d0 ht=0.0d0 mchisq=0.0D0 vchisq=0.0D0 ! ! two passes - one to count eligible phenotypes do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) n=dataset%num(ped) do i=pedoffset+1, n aff(i)=MISS end do if (assfnd) then n=pedoffset+dataset%nfound(ped) end if do i=pedoffset+1, n if (.not.observed(i, gene, dataset)) then if (dataset%plocus(i,trait) /= MISS) nuntyp=nuntyp+1 else if (dataset%plocus(i,trait) /= MISS) then if (multcat) then iaff=findlev(dataset%plocus(i,trait), traittable) else iaff=int(isaff(dataset%plocus(i,trait), thresh, gt)) end if if (iaff < 1 .or. iaff > traitlevels) cycle aff(i)=iaff ntot=ntot+1 end if end do end if end do if (ntot == 0) then if (plevel > 0) then write(outstr,'(2a)') 'No complete observations for ', trim(locnam) end if if (sumstat > 0) pval=0.0d0 return end if ! ! Now genotypes ! do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) n=dataset%num(ped) if (assfnd) then n=pedoffset+dataset%nfound(ped) end if do i=pedoffset+1, n if (aff(i) /= MISS) then iaff=aff(i) call get_namedgeno(i, gene, gen2, dataset, allele_buffer, g1, g2) if (allelic) then cntall(g1,iaff)=cntall(g1,iaff)+1 cntall(g2,iaff)=cntall(g2,iaff)+1 if (g1 == g2) nhom(iaff)=nhom(iaff)+1 else if (allele_buffer%xlinkd .and. dataset%sex(i)==1) then nmal=nmal+1 cntall(ncats+g1,iaff)=cntall(ncats+g1,iaff)+1 else geno=clcpos(g1,g2) cntall(geno,iaff)=cntall(geno,iaff)+1 end if end if end if end do end if end do d=0.0d0 nca=0 nmalca=0 do j=1, ncats do k=1, traitlevels nca(k)=nca(k)+cntall(j,k) cntall(j,traitlevels+1)=cntall(j,traitlevels+1)+cntall(j,k) end do if (cntall(j,traitlevels+1) > 0) df=df+1 end do df=df*(traitlevels-1) if (typ==2 .and. allele_buffer%xlinkd) then do j=1, malcats do k=1, traitlevels nmalca(k)=nmalca(k)+cntall(ncats+j,k) cntall(ncats+j,traitlevels+1)=cntall(ncats+j,traitlevels+1)+cntall(ncats+j,k) end do end do do k=1, traitlevels if (nmalca(k)>0 .and. nca(k)==0) then sexlim=1 else if (nmalca(k)==0 .and. nca(k)>0) then sexlim=2 end if end do end if ! F statistics calculated if allelic test if (allelic .and. ncats > 1 .and. traitlevels > 1 .and. & .not.allele_buffer%xlinkd) then eh=0 do j=1, ncats do k=1, traitlevels eh(k)=eh(k)+cntall(j,k)*cntall(j,k) end do end do do k=1, traitlevels d(k)=max(1.0d0, dble(nca(k)/2)) h01=1.0d0-dble(nhom(k))/d(k) h0=h0+h01 hs1=0.25d0*dble(eh(k))/d(k)/d(k) hs1=1.0d0-hs1-h01/(d(k)+d(k)) hs1=hs1 * d(k) / max(1.0d0, d(k)-1.0d0) hs=hs+hs1 end do do i=1, traitlevels-1 do j=i+1, traitlevels ht1=1.0d0 do k=1, ncats ht1=ht1-0.25d0*dble(cntall(k,i)*cntall(k,j))/d(i)/d(j) end do ht=ht+ht1+ht1 end do end do h0=h0/dble(traitlevels) hs=hs/dble(traitlevels) ht=ht/dble(max(1,traitlevels*(traitlevels-1))) gen_h0=gen_h0+h0 gen_hs=gen_hs+hs gen_ht=gen_ht+ht if (hs /= 0.0d0) fis=(hs-h0)/hs if (ht /= 0.0d0) fit=(ht-h0)/ht if (ht /= 0.0d0) fst=(ht-hs)/ht gen_nloci=gen_nloci+1 end if ! Calculate association statistic if ((nca(1)+nmalca(1)) > 0) then pexp=dble(nca(1))/dble(nca(1)+nca(2)) if (typ==2 .and. allele_buffer%xlinkd .and. sexlim==1) then pexp=dble(nmalca(1))/dble(nmalca(1)+nmalca(2)) end if ochisq=assoc_stat(1, ncats, traitlevels, nca, cntall) asyp=chip(ochisq,df) else pexp=0.0D0 ochisq=0.0D0 asyp=1.0D0 end if ! ! summary case-control frequencies for SNPs ! if ((typ == 12 .or. typ == 13 .or. typ == 14) .and. .not.multcat) then if (typ == 13) then ! tabulate minor allele (in controls) do i=2, ncats if (cntall(i,1) < cntall(testall,1)) testall=i end do else if (typ == 14) then ! tabulate risk allele do i=2, ncats if (cntall(i,2)*cntall(testall,1) > cntall(testall,2)*cntall(i,1)) testall=i end do end if call wrall(cntall(testall,traitlevels+2), allel) casden=max(1.0d0, dble(nca(2))) conden=max(1.0d0, dble(nca(1))) casfrq=dble(cntall(testall,2))/casden confrq=dble(cntall(testall,1))/conden testall=cntall(testall,4) end if if (plevel > 0) then write(outstr,'(/4a)') & ' ---- Association Analysis for "', trim(locnam), '" ', & repeat('-', max(1, 15+max(0,traitlevels-2)*14-len_trim(locnam))) if (typ == 2) then write(outstr,'(a)',advance='no') ' Genotype' else write(outstr,'(a)',advance='no') ' Allele' end if if (multcat) then do k=1, traitlevels pos=traittable%idx(k) call wrtrait(traittable%categories(pos,1)%rvalue, cval, & loctyp, get_notes(loc, locnote), 9, 4) write(outstr,'(2x,a)',advance='no') cval end do write(outstr,'(a/2a)') & ' Total', & ' ------------------------------------------------', & repeat('-', max(0,traitlevels-2)*14) else write(outstr,'(a)', advance='no') ' Affected Unaffected Total Dev' if (prevalence == MISS .or. typ /= 2) then write(outstr,*) ' OR' i=57 else write(outstr,'(3x,a)') 'Penetrance AR' i=67 end if write(outstr,'(2x,a)') repeat('-',i) end if casden=max(1.0d0, dble(nca(2))) conden=max(1.0d0, dble(nca(1))) if (allelic) then if (multcat) then do i=1, ncats call wrall(cntall(i,traitlevels+2), allel) write(outstr,'(3x,a3,a)', advance='no') allel, ' ' do k=1, traitlevels casden=max(1.0d0, dble(nca(k))) write(outstr,'(2x,i5,1x,a1,f4.3,a1)', advance='no') & cntall(i,k), '(', dble(cntall(i,k))/casden, ')' end do write(outstr,'(i8)') cntall(i,traitlevels+1) end do else odds0=(dble(cntall(allele_buffer%topall,2))+0.5d0) / & (dble(cntall(allele_buffer%topall,1))+0.5d0) do i=1, ncats odds1=(dble(cntall(i,2))+0.5d0) / & (dble(cntall(i,1))+0.5d0) call wrall(cntall(i,traitlevels+2), allel) write(outstr,'(3x,a3,2x,2(2x,i5,1x,a1,f4.3,a1),i8,1x,f6.1,1x,f7.2)') & allel, cntall(i,2), '(', dble(cntall(i,2))/casden, ')', & cntall(i,1), '(', dble(cntall(i,1))/conden, ')', & cntall(i,3), & binz(cntall(i,2), cntall(i,3), pexp), odds1/odds0 end do end if else if (allele_buffer%xlinkd) then write(outstr, '(2x,a)') 'Females' end if i=1 if (multcat) then do g1=1, allele_buffer%numal do g2=1, g1 call wrgtp(allele_buffer%allele_names(g2), & allele_buffer%allele_names(g1), gtp, '/', '', 1) write(outstr,'(1x,a7)', advance='no') gtp do j=1, traitlevels casden=max(1.0d0, dble(nca(j))) write(outstr,'(2x,i5,1x,a1,f4.3,a1)', advance='no') & cntall(i,j), '(', float(cntall(i,j))/casden, ')' end do write(outstr,'(i8)') cntall(i,traitlevels+1) i=i+1 end do end do else do g1=1, allele_buffer%numal do g2=1, g1 call wrgtp(allele_buffer%allele_names(g2), & allele_buffer%allele_names(g1), gtp, '/', '', 1) write(outstr,'(1x,a7,2(2x,i5,1x,a1,f4.3,a1),i8,1x,f6.1)', & advance='no') & gtp, cntall(i,2), '(', float(cntall(i,2))/casden, ')', & cntall(i,1), '(', float(cntall(i,1))/conden, ')', & cntall(i,3), & binz(cntall(i,2), cntall(i,3), pexp) ! ! If prespecified prevalence, calculate sampling corrected allele frequencies and ! penetrances if (prevalence == MISS) then write(outstr,*) else popcas=prevalence*float(cntall(i,2))/casden popcon=(1.0d0-prevalence)*float(cntall(i,1))/conden gfrq=popcas+popcon popfreq(g1)=popfreq(g1)+0.5d0*gfrq popfreq(g2)=popfreq(g2)+0.5d0*gfrq if (gfrq > 0.0d0) then pen(i)=popcas/gfrq write(outstr,'(5x,f6.4,1x,f6.4)') & pen(i), (prevalence-pen(i))/prevalence if (g1 == g2 .and. pen(i) < attrisk) then goodall=g1 attrisk=pen(i) end if pen(i)=pen(i)-prevalence else write(outstr,'(6x,a)') '-' end if end if i=i+1 end do end do ! ! If prespecified prevalence, calculate allelic deviations and variances if (prevalence /= MISS) then i=1 do g1=1, allele_buffer%numal do g2=1, g1 gfrq=popfreq(g1)*popfreq(g2) if (g1 /= g2) gfrq=gfrq+gfrq vt=vt+gfrq*pen(i)*pen(i) alpha(g1)=alpha(g1)+popfreq(g2)*pen(i) if (g1 /= g2) then alpha(g2)=alpha(g2)+popfreq(g1)*pen(i) end if i=i+1 end do end do do g1=1, allele_buffer%numal va=va+popfreq(g1)*alpha(g1)*alpha(g1) end do va=va+va vd=vt-va end if end if if (allele_buffer%xlinkd) then zstat=0.0d0 casden=max(1.0d0, dble(nmalca(2))) conden=max(1.0d0, dble(nmalca(1))) write(outstr, '(2x,a)') 'Males' do j=1, malcats if (sexlim==0 .or. sexlim==1) then zstat=binz(cntall(i,2), cntall(i,3), pexp) end if call wrall(cntall(i,traitlevels+2), allel) if (multcat) then write(outstr,'(3x,a3,a)', advance='no') allel, ' ' do k=1, traitlevels casden=max(1.0d0, dble(nmalca(k))) write(outstr,'(2x,i5,1x,a1,f4.3,a1)', advance='no') & cntall(i,k), '(', dble(cntall(i,k))/casden, ')' end do write(outstr,'(i8)') cntall(i,traitlevels+1) else write(outstr,'(3x,a3,2x,2(2x,i5,1x,a1,f4.3,a1),i8,1x,f6.1)') & allel, cntall(i,2), '(', dble(cntall(i,2))/casden, ')', & cntall(i,1), '(', dble(cntall(i,1))/conden, ')', & cntall(i,3), zstat end if i=i+1 end do end if end if write(outstr,'(2x,a)') repeat('-', 49+max(0,traitlevels-2)*14) ! subtotals if (multcat) then write(outstr,'(a8)', advance='no') 'Total' do k=1, traitlevels write(outstr,'(2x,i5,7x)', advance='no') & (3-mod(typ,10))*traittable%icount(traittable%idx(k)) end do write(outstr,'(i8)') (3-mod(typ,10))*ntot else write(outstr,'(a8,2(2x,i5,7x),i8)') & 'Total', nca(2)+nmalca(2), nca(1)+nmalca(1), ntot end if ! optional table of allelic deviances if (plevel > 1 .and. prevalence /= MISS .and. typ == 2) then write(outstr,'(/a/a)') 'Allele Pop Freq Alpha', & '------ ---------- --------' do g1=1, allele_buffer%numal call wrall(allele_buffer%allele_names(g1), allel) write(outstr,'(a6,2(4x,f6.4))') allel, popfreq(g1), alpha(g1) end do end if ! if (sexlim==1) then write(outstr,'(/a/7x,a)') & 'NOTE: There are no female cases in this X-linked', & 'genotypic association analysis.' else if (sexlim==2) then write(outstr,'(/a/7x,a)') & 'NOTE: There are no male cases in this X-linked', & 'genotypic association analysis.' end if write(outstr,'(/a,i6)') & ' No. trait(+) marker(-) =', nuntyp write(outstr,'(a,i6)') & ' No. trait(+) marker(+) =', ntot if (typ == 11 .and. .not.allele_buffer%xlinkd) then write(outstr,'(/a,3(3x,f6.4)/a,3(3x,f6.4))') & ' Ho, Hs, Ht =',h0, hs, ht, & ' Fis, Fit, Fst =',fis, fit, fst end if if (typ == 2 .and. prevalence /= MISS) then attrisk=(prevalence-attrisk)/prevalence if (allele_buffer%numal == 2) then call wrall(allele_buffer%allele_names(3-goodall), allel) cval=adjustl(allel) else if (allele_buffer%numal > 2) then call wrall(allele_buffer%allele_names(goodall), allel) cval='non-' // adjustl(allel) end if prrr=1.0d0 + (va+vd)/prevalence/prevalence h2=tetcor(prevalence, prrr) prrr=1.0d0 + (0.5d0*va+0.25d0*vd)/prevalence/prevalence write(outstr,'(/a,3x,f6.4/a,2(3x,f6.4),2(/a,f9.4)/a,3x,f6.4,3a)') & ' Assumed trait prevalence =', prevalence, & ' Genetic variances VA, VD =', va, vd, & ' Sib recurrence risk ratio =', prrr, & ' MFT Heritability =', h2, & ' Attributable risk =', attrisk,' (', trim(cval), ')' end if write(outstr,'(/a,f7.2/a,i4/a,3x,a)') & ' Contingency chi-square =', ochisq, & ' Nominal degrees of freedom =', df, & ' Nominal P-value =', pstring(asyp) end if ! ! if founders only, or no cases or no controls or iter=0, then ! Monte-Carlo procedure superfluous ! it=0 tailp=0 if (assfnd .or. nca(1) == 0 .or. nca(2) == 0 .or. traitlevels < 2 .or. iter == 0) then pval=1.0d0 if (sumstat > 0) pval=0.0d0 else ! ! Sequential Monte-Carlo P-value after Besag & Clifford Biometrika 1991 ! P= tailp/it if tailp=mincnt or (tailp+1)/(it+1) if tailp<mincnt && it=iter ! if (plevel == 1 .and. iter > 1000) then write(outstr,'(a)', advance='no') ' ' end if do while (it < iter .and. tailp < mincnt .and. irupt == 0) it=it+1 do j=1, ncats do k=1, traitlevels+1 cntall(j,k)=0 end do end do if (conibd /= MISS) then call newstart(conibd, allele_buffer2, dataset, plevel) end if do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) if (conibd /= MISS) then call cisimped(ped, conibd, allele_buffer, allele_buffer2, dataset, set) else if (allele_buffer%xlinkd) then call xsimped(ped, dataset, allele_buffer, set) else call simped(ped, dataset, allele_buffer, set) end if end if if (allelic) then i=0 do ii=pedoffset+1, dataset%num(ped) i=i+1 if (aff(ii) /= MISS) then cntall(set(i,1), aff(ii))=cntall(set(i,1), aff(ii))+1 cntall(set(i,2), aff(ii))=cntall(set(i,2), aff(ii))+1 end if end do else i=0 do ii=pedoffset+1, dataset%num(ped) i=i+1 if (aff(ii) /= MISS) then if (allele_buffer%xlinkd .and. dataset%sex(ii)==1) then cntall(ncats+set(i,1),aff(ii))=cntall(ncats+set(i,1),aff(ii))+1 else geno=clcpos(set(i,1), set(i,2)) cntall(geno,aff(ii))=cntall(geno,aff(ii))+1 end if end if end do end if end if end do do i=1, ncats cntall(i,traitlevels+1)=0 do j=1, traitlevels cntall(i,traitlevels+1)=cntall(i,traitlevels+1)+cntall(i,j) end do end do chisq=assoc_stat(1, ncats, traitlevels, nca, cntall) topvals(1)=chisq call dsort(ntopvals,topvals) call moment(it, chisq, mchisq, vchisq) if (chisq > ochisq .or. (chisq == ochisq .and. random() > 0.5)) then tailp=tailp+1 end if if (plevel > 1) then write(outstr,'(/a,i8,a,f6.1,1x,i0)') & 'Pseudosample ',it,': Chisq=',chisq, tailp if (multcat) then do i=1, ncats write(outstr,'(i8,10(2x,i5):)') & cntall(i,traitlevels+2), cntall(i,1:(traitlevels+1)) end do else do i=1, ncats write(outstr,'(i8,2(2x,i5,1x,a1,f3.2,a1),i8)') & cntall(i,4), cntall(i,2), '(', float(cntall(i,2))/float(nca(2)), ')', & cntall(i,1), '(', float(cntall(i,1))/float(nca(1)), ')', & cntall(i,3) end do end if else if (plevel == 1) then if (iter > 1000) then if (mod(10*it, iter) == 0) then write(outstr,'(a,i0,a1,i0)', advance='no') '...', tailp, '/', it end if end if end if end do if (tailp < mincnt) then tailp=tailp+1 it=it+1 end if vchisq=vchisq/dble(max(1,it-1)) pval=evdtailp(tailp, it, ntopvals, topvals, ochisq) end if if (plevel == 1 .and. iter > 1000) then write(outstr, *) end if if (plevel > 0) then write(outstr, '(a,i0,a,i0,3a/a,f6.1,a,f6.1,a)') & ' Equalled or exceeded by = ',tailp,'/',it, & ' simulated values (', trim(pstring(pval)), ')', & ' Mean (Var) simulated chi-sqs =',mchisq, ' (', vchisq, ')' if (plevel > 1) then write(outstr,'(/a/11(1x,f6.1):)') ' Top simulated chi-sqs:', & topvals(2:ntopvals) end if else if (plevel > -2) then call phist(asyp, pval, histo) if (typ == 11) then write(outstr,'(a20,2(a1,i6),a1,i5,3(a1,f6.4),2(a1,a),a1,i6,2(a1,a))') & locnam, tabsep, ntot, tabsep, ncats, tabsep, traitlevels, tabsep, & fis, tabsep, fit, tabsep, fst, tabsep, pstring(asyp), tabsep, & pstring(pval), tabsep, it, tabsep, 'Fstat', tabsep, histo else if ((typ == 12 .or. typ == 13 .or. typ == 14) .and. .not.multcat) then call wrall(testall, allel) write(outstr,'(a20,a1,i6,a1,a6,2(a1,a6),a1,f10.1,2(a1,a),a1,i6,a1,2a,a1,a)') & locnam, tabsep, ntot, tabsep, allel, & tabsep, pstring(casfrq), tabsep, pstring(confrq), & tabsep, ochisq, tabsep, pstring(asyp), & tabsep, pstring(pval), tabsep, it, tabsep, & 'AssX2-', ana, tabsep, histo else write(outstr,'(a20,2(a1,i6),a1,f10.1,2(a1,a),a1,i8,a1,2a,a1,a)') & locnam, tabsep, ntot, tabsep, ncats, tabsep, ochisq, tabsep, & pstring(asyp), tabsep, pstring(pval), tabsep, it, tabsep, & 'AssX2-', ana, tabsep, histo end if end if if (sumstat == 1) then pval=fst else if (iter == 0) then pval=asyp end if end subroutine doassoc ! ! Chi-square measures of association in flat contingency tables ! ! Pearson chi-sq for slice of RxC table ! (uses cntall(,1:traitlevels+1), nca(1:traitlevels)) ! function pearson(sta, fin, nlev, nca, cntall) double precision pearson integer, intent(in) :: sta, fin, nlev integer, dimension(:), intent(in) :: nca integer, dimension(:,:), intent(in) :: cntall integer :: i, tot double precision :: dev, nexp, denom, numer tot=0 denom=1.0d0 pearson=0.0d0 do i=sta, fin tot=tot+cntall(i,nlev+1) end do if (tot > 0) denom=1.0d0/dble(tot) do i=sta, fin if (cntall(i,nlev+1) > 0) then numer=dble(cntall(i, nlev+1)) do j=1, nlev nexp=dble(nca(j))*numer*denom dev=dble(cntall(i,j))-nexp if (nexp > 0.0d0) pearson=pearson+dev*dev/nexp end do end if end do return end function pearson ! ! Gibbs chi-sq for slice of RxC table ! (uses cntall(,1:traitlevels+1), nca(1:traitlevels)) ! function gibbs(sta, fin, nlev, nca, cntall) double precision :: gibbs integer, intent(in) :: sta, fin, nlev integer, dimension(:), intent(in) :: nca integer, dimension(:,:), intent(in) :: cntall double precision, parameter :: eps=1.0D-5 integer :: i, tot double precision :: expn, obsn, denom, numer tot=0 denom=1.0d0 gibbs=0.0d0 do i=sta, fin tot=tot+cntall(i,nlev+1) end do if (tot > 0) denom=1.0d0/dble(tot) do i=sta, fin if (cntall(i,nlev+1) > 0) then numer=dble(cntall(i, nlev+1)) do j=1, nlev expn=dble(nca(j))*numer*denom obsn=dble(cntall(i,j)) if (expn > eps .and. obsn > eps) gibbs=gibbs+obsn*log(obsn/expn) end do end if end do gibbs=gibbs+gibbs return end function gibbs ! ! Pearson chi-sq for 2xK table (uses only cntall(,1-3)) ! function twobyk(sta, fin, cntall, pexp) double precision twobyk integer, intent(in) :: sta, fin integer, dimension(:,:), intent(in) :: cntall double precision, intent(in) :: pexp integer :: i double precision :: num1, num2, den1, den2 twobyk=0.0d0 if (pexp == 0.0d0 .or. pexp == 1.0d0) return do i= sta, fin if (cntall(i,3) > 0) then den2=pexp*dble(cntall(i,3)) den1=dble(cntall(i,3))-den2 num2=dble(cntall(i,2))-den2 num1=dble(cntall(i,1))-den1 twobyk=twobyk+(num1*num1)/den1+(num2*num2)/den2 end if end do return end function twobyk ! ! perform sibship association permutation test ! ! Combines TDT with SDT: appropriate permutation set for each sibship ! ! If both parents genotyped, then each child can be drawn from 13,14,23,24 ! If one or no parents genotyped, but may be reconstructed, then draw ! from mixture of obligate genotypes (those usable to reconstruct the missing ! parents) and 13,14,23,24. ! If cannot unequivocally reconstruct parental genotypes ! draw only from obligate (observed) genotypes among children ! subroutine rctdt(trait, locnam, gene, genetyp, iter, mincnt, gt, thresh, & fbatimp, freqfnd, dataset, plevel) use outstream use alleles_class use ped_class use rngs use statfuns implicit none integer, intent(in) :: trait character (len=*), intent(in) :: locnam integer, intent(in) :: gene, genetyp integer, intent(in) :: iter integer, intent(in) :: mincnt integer, intent(in) :: gt double precision, intent(in) :: thresh logical, intent(in) :: fbatimp type (ped_data) :: dataset integer, intent(in) :: freqfnd integer, intent(in) :: plevel ! local variables integer, parameter :: KNOWN=0, MISS=-9999 double precision, parameter :: eps=1.0D-6 type (allele_data) :: allele_buffer ! ! work arrays for simulation ! ! aff(:) = affection status of child ! set(:,1:2) = genotypes of child ! sibships(:,1) = first useful child of nth sibship ! sibships(:,2) = last useful child of nth sibship ! sibships(:,3:4) = paternal genotype ! sibships(:,5:6) = maternal genotype ! sibships(:,7) = resimulation (=1) or permutation only (=2) ! integer, dimension(dataset%nobs) :: aff integer, dimension(dataset%nobs, 2) :: set integer, dimension(dataset%nobs, 7) :: sibships ! array for allele counts and scores in cases integer, dimension(:,:), allocatable :: cntall double precision, dimension(:), allocatable :: x, mtrans double precision, dimension(:), allocatable :: vtrans ! local variables integer :: pedoffset, ped ! ! nfam=number of useful sibships ! nca, nco = number of affected and unaffected offspring ! integer :: contrib, df, famtyp, gen2, i, it, j, k, naff, nuntyp, pos, tailp, kk integer :: currf, currm, fin, g1, g2, mg1, mg2, pg1, pg2, nca, nco, nfam, & parall, ptyped, partyp(4,3), firstsib, lastsib character (len=3) :: allel, histo character (len=7) :: gtp1, gtp2 real :: casden, conden double precision :: asyp, bestz, chisq, obs, mchisq, ochisq, pval, vchisq ! functions ! chip integer :: getnam integer :: rctuse character (len=6) :: pstring double precision :: isaff interface subroutine freq(gene, loctyp, fndr, dataset, allele_buffer) use ped_class use alleles_class integer, intent(in) :: gene integer, intent(in) :: loctyp integer, intent(in) :: fndr type (ped_data), intent(in) :: dataset type (allele_data), intent(inout) :: allele_buffer end subroutine freq subroutine parimp(pg1, pg2, mg1, mg2, sta, fin, set, parall) integer, intent(inout) :: pg1, pg2, mg1, mg2 integer, intent(in) :: sta, fin integer, dimension(:,:), intent(in) :: set integer, intent(out) :: parall end subroutine subroutine rctsim(nfam, sibships, aff, set, numal, trans) integer, intent(in) :: nfam integer, dimension(:,:), intent(in) :: sibships integer, dimension(:), intent(in) :: aff integer, dimension(:,:), intent(inout) :: set integer, intent(in) :: numal double precision, intent(out) :: trans(numal) end subroutine end interface if (iter == 0) return call setup_freq(10, allele_buffer) call freq(gene, genetyp, freqfnd, dataset, allele_buffer) allocate(cntall(allele_buffer%numgtp,4)) allocate(x(allele_buffer%numal), mtrans(allele_buffer%numal)) allocate(vtrans(allele_buffer%numgtp)) df=-1 gen2=gene+1 nca=0 nco=0 nfam=0 nuntyp=0 parall=0 do i=1, 4 partyp(i,1)=0 partyp(i,2)=0 partyp(i,3)=0 end do do j=1, allele_buffer%numal mtrans(j)=0.0d0 do k=1, 3 cntall(j,k)=0 end do end do do j=1, allele_buffer%numgtp vtrans(j)=0.0d0 end do mchisq=0.0d0 vchisq=0.0d0 if (plevel > 1) then write(outstr,'(/a/a)') & '--------- Sibships used for RC-TDT --------------------', & 'Pedigree Father Mother Aff Tot' end if ! ! iterate over active pedigrees ! do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) fin=dataset%num(ped) do i=pedoffset+1, fin aff(i)=int(isaff(dataset%plocus(i,trait),thresh,gt)) if (observed(i, gene, dataset)) then call get_namedgeno(i, gene, gen2, dataset, allele_buffer, & set(i,1), set(i,2)) else set(i,1)=MISS set(i,2)=MISS end if end do ! ! iterate over sibships ! currf=dataset%fa(fin) currm=dataset%mo(fin) do k=dataset%num(ped)-1, pedoffset+dataset%nfound(ped), -1 if (dataset%fa(k) /= currf .or. dataset%mo(k) /= currm) then firstsib=0 lastsib=0 contrib=0 naff=0 do i=k+1, fin if (set(i,1) > KNOWN) then contrib=contrib+1 lastsib=i if (firstsib==0) firstsib=i if (aff(i) /= MISS) then naff=naff+aff(i)-1 else nuntyp=nuntyp+1 end if end if end do ! ! skip if no usable individuals in this sibship ! if (contrib > 0) then pg1=set(currf,1) pg2=set(currf,2) mg1=set(currm,1) mg2=set(currm,2) ptyped=1 if (pg1 > KNOWN) then ptyped=ptyped+1 end if if (mg1 > KNOWN) then ptyped=ptyped+2 end if partyp(ptyped,1)=partyp(ptyped,1)+1 call parimp(pg1, pg2, mg1, mg2, firstsib, lastsib, set, parall) ! keeping inferred parental genotypes for use in their own sibship test if (fbatimp) then if (pg1 /= MISS .and. pg2 /= MISS .and. set(currf,1) < KNOWN) then set(currf,1)=abs(pg1) set(currf,2)=abs(pg2) end if if (mg1 /= MISS .and. mg2 /= MISS .and. set(currm,1) < KNOWN) then set(currm,1)=abs(mg1) set(currm,2)=abs(mg2) end if end if ! ! Skip if family uninformative: need at least one heterozygote parent ! and if parental genotypes imputed, either affected and ! unaffected offspring to permute, or more than two affected ! famtyp=rctuse(pg1, pg2, mg1, mg2, ptyped, parall, contrib, naff) if (famtyp > 0) then partyp(ptyped,2)=partyp(ptyped,2)+1 partyp(ptyped,3)=partyp(ptyped,3)+naff if (plevel > 1) then call wrgtp(pg1, pg2, gtp1, '/', '', 1) call wrgtp(mg1, mg2, gtp2, '/', '', 1) write(outstr,'(a,2(1x,a14),2(1x,i3),1x)', advance='no') & dataset%pedigree(ped)(1:14), & adjustl(trim(dataset%id(currf)) // ' (' // trim(adjustl(gtp1)) // ')'), & adjustl(trim(dataset%id(currm)) // ' (' // trim(adjustl(gtp2)) // ')'), naff, contrib do i=firstsib, lastsib if (aff(i) == 2 .and. set(i,1) > KNOWN) then call wrgtp(set(i,1), set(i,2), gtp1, '', '/', 1) write(outstr,'(1x,a)', advance='no') trim(adjustl(gtp1)) end if end do write(outstr,*) ' [', parall, ']' end if nfam=nfam+1 sibships(nfam,1)=firstsib sibships(nfam,2)=lastsib sibships(nfam,3)=pg1 sibships(nfam,4)=pg2 sibships(nfam,5)=mg1 sibships(nfam,6)=mg2 sibships(nfam,7)=famtyp do i=firstsib, lastsib if (aff(i) /= MISS .and. set(i,1) > KNOWN) then cntall(set(i,1),aff(i))=cntall(set(i,1),aff(i))+1 cntall(set(i,2),aff(i))=cntall(set(i,2),aff(i))+1 end if end do end if end if ! Now update to next sibship fin=k currf=dataset%fa(fin) currm=dataset%mo(fin) end if end do end if end do do j=1, allele_buffer%numal nco=nco+cntall(j,1) nca=nca+cntall(j,2) cntall(j,3)=cntall(j,1)+cntall(j,2) if (cntall(j,3) > 0) df=df+1 end do ! ! MC estimation of mean and variance ! it=0 tailp=0 if (iter == 0 .or. nca == 0 .or. nfam < 1) then asyp=1.0d0 pval=1.0d0 else do it=1, iter call rctsim(nfam, sibships, aff, set, allele_buffer%numal, x) call dssp(allele_buffer%numal, it, 1, x, mtrans, vtrans) end do do j=1, allele_buffer%numgtp vtrans(j)=vtrans(j)/dble(max(1,it-1)) end do ! ! Sequential P-value simulation ! ochisq=0.0D0 pos=0 do j=1, allele_buffer%numal obs=dble(cntall(j,2)) if (mtrans(j) > eps .and. obs > eps) then ochisq=ochisq+obs*log(obs/mtrans(j)) end if end do it=0 do while (it < iter .and. tailp < mincnt) it=it+1 call rctsim(nfam, sibships, aff, set, allele_buffer%numal, x) chisq=0.0d0 do j=1, allele_buffer%numal if (mtrans(j) > eps .and. x(j) > eps) then chisq=chisq+x(j)*log(x(j)/mtrans(j)) end if end do call moment(it, chisq, mchisq, vchisq) if (chisq > ochisq .or. (chisq == ochisq .and. random() > 0.5)) then tailp=tailp+1 end if if (plevel > 2) then write(outstr,'(/a,i8,a,f6.1,100i4:)') 'Pseudosample ',it,': RC-TDT=', chisq, int(x) end if end do if (tailp < mincnt) then tailp=tailp+1 it=it+1 end if pval=dble(tailp)/dble(it) end if vchisq=vchisq/dble(max(1,it-1)) bestz=0.0d0 pos=0 do j=1, allele_buffer%numal pos=pos+j if (vtrans(pos) > eps) then x(j)=(dble(cntall(j,2))-mtrans(j))/sqrt(vtrans(pos)) else x(j)=0.0d0 end if if ((x(j)*x(j)) > abs(bestz)) bestz=x(j)*x(j) end do if (plevel > 0 .and. nca == 0) then write(outstr,'(/a,a10,a,3(/a,i6))') & ' -------- Combined transmission test for "', trim(locnam), '" --------', & ' marker(-) =', nuntyp, & ' No. trait(+) marker(+) =', (nca+nco)/2, & ' No. useful sibships =', nfam else if (plevel > 0) then write(outstr,'(/a,a10,a/a/a)') & ' ------------ Combined transmission test for "',trim(locnam),'" --------------', & ' Allele Affected Unaffected Total E(Aff) V(Aff) Z P', & ' -----------------------------------------------------------------------' casden=max(1.0,float(nca)) conden=max(1.0,float(nco)) pos=0 do j=1, allele_buffer%numal pos=pos+j call wrall(allele_buffer%allele_names(j), allel) write(outstr,'(3x,a3,2x,2(2x,i5,1x,a1,f3.2,a1),i7,3(1x,f7.2),1x,a)') & allel,cntall(j,2), '(', float(cntall(j,2))/casden, ')', & cntall(j,1), '(', float(cntall(j,1))/conden, ')', cntall(j,3), & mtrans(j), vtrans(pos), x(j), pstring(chip(x(j)*x(j),1)) end do write(outstr,'(a/a8,2(2x,i5,6x),i7)') & ' -----------------------------------------------------------------------', & 'Total', nca, nco, nca+nco write(outstr,'(3(/a,i6))') & ' marker(-) =', nuntyp, & ' No. trait(+) marker(+) =', (nca+nco)/2, & ' No. useful sibships =', nfam write(outstr,'(a,f6.1/a,i4)') & ' Global association statistic =', ochisq, & ' Degrees of freedom =', max(0, df) write(outstr,'(a,1x,i0,a,i0,3a/a,f6.1,a,f6.1,a)') & ' Equalled or exceeded by =', tailp, '/', it, & ' simulated values (', trim(pstring(pval)), ')', & ' Mean (Var) simulated chi-sqs =', mchisq, ' (', vchisq, ')' if (plevel > 1) then write(outstr,'(/a/a)') ' Allele Tr E(Tr) Cov(Tr)', & ' ------- ------ ------- --------------------------------------' pos=0 do j=1, allele_buffer%numal call wrall(allele_buffer%allele_names(j), allel) write(outstr,'(3x,a3,2x,i7,10(1x,f7.2):)') & allel,cntall(j,2),mtrans(j),(vtrans(k),k=pos+1,pos+j) pos=pos+j end do write(outstr,'(/a/a,4(/a,3(2x,i7)))') & ' Parents genotyped No. Fams Useable Aff Off', & ' ------------------ -------- ------- -------', & ' None ', partyp(1,1), partyp(1,2), partyp(1,3), & ' Father only ', partyp(2,1), partyp(2,2), partyp(2,3), & ' Mother only ', partyp(3,1), partyp(3,2), partyp(3,3), & ' Both parents ', partyp(4,1), partyp(4,2), partyp(4,3) end if else if (nca > 0 .and. allele_buffer%numal > 1) then asyp=chip(bestz,1) asyp=min(1.0d0,(allele_buffer%numal-1)*asyp) call phist(asyp,pval,histo) write(outstr,'(a20,2(a1,i6),a1,f10.1,2(a1,a),a1,i8,2(a1,a))') & locnam, tabsep, nca/2, tabsep, allele_buffer%numal, tabsep, & bestz, tabsep, pstring(asyp), tabsep, pstring(pval), tabsep, & it, tabsep, 'RC-TDT ', tabsep, histo end if end subroutine rctdt ! ! Make list of possible parental genotypes for this sibship ! subroutine parimp(pg1, pg2, mg1, mg2, sta, fin, set, parall) integer, intent(inout) :: pg1, pg2, mg1, mg2 integer, intent(in) :: sta, fin integer, dimension(:,:), intent(in) :: set integer, intent(out) :: parall integer, parameter :: KNOWN=0, MISS=-9999 integer :: g(4,2), het, i, ng, p11, p12, p21, p22, tmp logical :: d1, d2, d3, d4 ! Both parents genotyped if (pg1 > KNOWN .and. mg1 > KNOWN) then parall=4 return end if ! ! initialize g() with a heterozygote genotype if possible het=sta do i=sta, fin if (set(i,1) > KNOWN .and. (set(i,1) /= set(i,2))) then het=i exit end if end do g(1,1)=set(het,1) g(1,2)=set(het,2) ! ! Categorise sibs genotype ! in terms of which allele is shared with starting genotype do i=2, 4 g(i,1)=MISS g(i,2)=MISS end do do i=sta, fin if (set(i,1) > KNOWN) then d1=(set(i,1) == g(1,1)) d4=(set(i,2) == g(1,2)) if (.not.(d1 .and. d4)) then d2=(set(i,1) == g(1,2)) d3=(set(i,2) == g(1,1)) if (d1) then g(2,1)=set(i,1) g(2,2)=set(i,2) else if (d3) then g(2,1)=set(i,2) g(2,2)=set(i,1) else if (d2) then g(3,1)=set(i,1) g(3,2)=set(i,2) else if (d4) then g(3,1)=set(i,2) g(3,2)=set(i,1) else g(4,1)=set(i,1) g(4,2)=set(i,2) end if end if end if end do ! ! Fix order of 4th genotype so consistent with others ! if ((g(2,2) /= MISS .and. g(4,2) /= g(2,2)) .or. & (g(3,1) /= MISS .and. g(4,1) /= g(3,1))) then tmp=g(4,2) g(4,2)=g(4,1) g(4,1)=tmp end if ! ! Test for 1/2 x x/x -> 1/2 ! ng=0 do i=1, 4 if (g(i,1) /= MISS) ng=ng+1 end do if (ng == 1) then if ((mg1 > KNOWN .and. g(1,1) == mg1 .and. g(1,2) == mg2) .or. & (pg1 > KNOWN .and. g(1,1) == pg1 .and. g(1,2) == pg2)) then parall=2 return end if end if ! ! Produce parental phenosets and compare to any known genotypes ! p11=g(1,1) p21=g(1,2) p12=MISS p22=MISS if (g(2,2) /= MISS) p22=g(2,2) if (g(4,2) /= MISS) p22=g(4,2) if (g(3,2) /= MISS) p12=g(3,2) if (g(4,1) /= MISS) p12=g(4,1) call order(p11,p12) call order(p21,p22) if ((mg1 > KNOWN .and. ((mg1 == p11 .and. mg2 == p12) .or. & (p21 /= MISS .and. (mg1 /= p21 .or. mg2 /= p22)) .or. & (p21 == MISS .and. mg1 /= p22 .and. mg2 /= p22))) .or. & (pg1 > KNOWN .and. ((pg1 == p21 .and. pg2 == p22) .or. & (p11 /= MISS .and. (pg1 /= p11 .or. pg2 /= p12)) .or. & (p11 == MISS .and. pg1 /= p12 .and. pg2 /= p12)))) then call swap(p11,p21) call swap(p12,p22) end if ! Return observed and imputed genotypes if (mg1 <= KNOWN) then if (p21 /= MISS) mg1= -p21 if (p22 /= MISS) mg2= -p22 end if if (pg1 <= KNOWN) then if (p11 /= MISS) pg1= -p11 if (p12 /= MISS) pg2= -p12 end if parall=0 if (pg1 /= MISS) parall=parall+1 if (pg2 /= MISS) parall=parall+1 if (mg1 /= MISS) parall=parall+1 if (mg2 /= MISS) parall=parall+1 end subroutine parimp ! ! Simulate the null distribution of sibship genotypes ! Parental alleles imputed via the children must be transmitted ! at least once to that sibship ! Furthermore, if two imputed alleles are the same in the two parents, ! then these must be transmitted together to at least one child ! And (Jun 2008), if only A/A and A/B segregating in sibship, ! need to also condition on total number of each type of ! genotype in sibship for -/- x -/- and A/B x -/- matings ! (sticking point is A/B x A/B possibility) ! subroutine rctperm(ifam, sibships, set) use rngs integer, intent(in) :: ifam integer, dimension(:,:), intent(in) :: sibships integer, dimension(:,:), intent(inout) :: set integer, parameter :: KNOWN=0, MISS=-9999 integer :: mg1, mg2, pg1, pg2 integer :: iall(2,2), gen(2,2), hom0, homimp, i, imp0, imputd, & j, p1(2), p2(2), swap, tmp, tr1, tr2 ! functions integer :: ranall ! ! If {A/B, -/-} x -/- -> {A/A, A/B} skip straight to permutation ! if (sibships(ifam,7) == 1) then pg1=sibships(ifam,3) pg2=sibships(ifam,4) mg1=sibships(ifam,5) mg2=sibships(ifam,6) do i=1, 2 do j=1, 2 iall(i,j)=0 gen(i,j)=0 end do end do if (pg1 < KNOWN .and. pg1 /= MISS) iall(1,1)=1 if (pg2 < KNOWN .and. pg2 /= MISS) iall(1,2)=1 if (mg1 < KNOWN .and. mg1 /= MISS) iall(2,1)=1 if (mg2 < KNOWN .and. mg2 /= MISS) iall(2,2)=1 imp0=iall(1,1)+iall(1,2)+iall(2,1)+iall(2,2) if ((iall(1,1)+iall(2,1)) == 2 .and. pg1 == mg1) gen(1,1)=1 if ((iall(1,1)+iall(2,2)) == 2 .and. pg1 == mg2) gen(1,2)=1 if ((iall(1,2)+iall(2,1)) == 2 .and. pg2 == mg1) gen(2,1)=1 if ((iall(1,2)+iall(2,2)) == 2 .and. pg2 == mg2) gen(2,2)=1 hom0=gen(1,1)+gen(1,2)+gen(2,1)+gen(2,2) ! ! rejection sampling ! do homimp=hom0 imputd=imp0 p1(1)=pg1 p1(2)=pg2 p2(1)=mg1 p2(2)=mg2 iall(1,1)=gen(1,1) iall(1,2)=gen(1,2) iall(2,1)=gen(2,1) iall(2,2)=gen(2,2) do i=sibships(ifam,1), sibships(ifam,2) if (set(i,1) > KNOWN) then tr1=ranall(p1) tr2=ranall(p2) if (iall(tr1,tr2) == 1) then homimp=homimp-1 iall(tr1,tr2)=0 end if call conoff(tr1,p1,imputd,set(i,1)) call conoff(tr2,p2,imputd,set(i,2)) end if end do if (imputd == 0 .and. homimp == 0) exit end do end if ! ! If matches conditions, permute genotypes within sibship ! do i=sibships(ifam,1), sibships(ifam,2) if (set(i,1) > KNOWN) then do swap=irandom(sibships(ifam,1), sibships(ifam,2)) if (set(swap,1) > KNOWN) exit end do tmp=set(swap,1) set(swap,1)=set(i,1) set(i,1)=tmp tmp=set(swap,2) set(swap,2)=set(i,2) set(i,2)=tmp end if end do do i=sibships(ifam,1), sibships(ifam,2) call order(set(i,1), set(i,2)) end do end subroutine rctperm ! ! Randomly transmit nonmissing alleles ! function ranall(par) use rngs integer ranall integer, intent(in) :: par(2) integer, parameter :: MISS=-9999 if (par(1) /= MISS .and. par(2) /= MISS) then ranall=irandom(1, 2) else if (par(2) == MISS) then ranall=1 else ranall=2 end if end function ranall ! ! Conditional parent-offspring transmission ! Flag whether an imputed parental allele is transmitted ! subroutine conoff(tr, par, imputd, off) integer, intent(inout) :: tr integer, intent(inout) :: par(2) integer, intent(inout) :: imputd integer, intent(out) :: off integer, parameter :: KNOWN=0 if (par(tr) < KNOWN) then imputd=imputd-1 par(tr)= -par(tr) end if off=par(tr) end subroutine conoff ! ! One simulation of entire set of informative nuclear families ! subroutine rctsim(nfam, sibships, aff, set, numal, trans) integer, intent(in) :: nfam integer, dimension(:,:), intent(in) :: sibships integer, dimension(:), intent(in) :: aff integer, dimension(:,:), intent(inout) :: set integer, intent(in) :: numal double precision, intent(out) :: trans(numal) integer, parameter :: KNOWN=0 integer :: i,j interface subroutine rctperm(ifam, sibships, set) integer, intent(in) :: ifam integer, dimension(:,:), intent(in) :: sibships integer, dimension(:,:), intent(inout) :: set end subroutine end interface do j=1, numal trans(j)=0.0d0 end do do j=1, nfam call rctperm(j, sibships, set) do i=sibships(j,1), sibships(j,2) if (aff(i) == 2 .and. set(i,1) > KNOWN) then trans(set(i,1))=trans(set(i,1))+1.0d0 trans(set(i,2))=trans(set(i,2))+1.0d0 end if end do end do end subroutine rctsim ! ! test if useful for RC-TDT/FBAT ! function rctuse(pg1, pg2, mg1, mg2, ptyped, parall, contrib, naff) integer :: rctuse integer, intent(in out) :: pg1 integer, intent(in out) :: pg2 integer, intent(in out) :: mg1 integer, intent(in out) :: mg2 integer, intent(in out) :: ptyped integer, intent(in) :: parall integer, intent(in out) :: contrib integer, intent(in out) :: naff integer, parameter :: MISS=-9999 logical :: h1, h2 ! ! At least 1 affected if (naff == 0) then rctuse=0 return end if h1=(pg1 /= MISS .and. abs(pg1) /= abs(pg2)) h2=(mg1 /= MISS .and. abs(mg1) /= abs(mg2)) rctuse=1 ! Both parents homozygous or insufficient parental genotypes if (.not.(h1.or.h2) .or. parall <= 2) then rctuse=0 return ! Both parents typed else if (ptyped == 4) then return ! Affected and unaffected children and identifiable parental alleles else if (parall > 2 .and. contrib > naff) then if (parall == 3) rctuse=2 return ! More than 2 affected children and... else if (contrib > 2) then ! 4 parental alleles if (parall == 4) then return ! or 3 parental alleles 12 x 3- or 1- x 23 else if (h1 .and. abs(pg1) /= abs(mg2) .and. & abs(pg2) /= abs(mg2)) then return else if (h2 .and. abs(mg1) /= abs(pg2) .and. & abs(mg2) /= abs(pg2)) then return end if end if rctuse=0 end function rctuse ! ! Tabulate sibship affection by genotype for fast test of total ! association ! subroutine sibass(trait, locnam, gene, allele_buffer, dataset, iter, & typ, pval, plevel) use outstream use alleles_class use ped_class use statfuns implicit none integer, intent(in) :: trait character (len=*), intent(in) :: locnam integer, intent(in) :: gene type (allele_data), intent(inout) :: allele_buffer type (ped_data) :: dataset integer, intent(in) :: typ integer, intent(in) :: iter double precision, intent(out) :: pval integer, intent(in) :: plevel ! local variables integer, parameter :: KNOWN=0, MISS=-9999 ! table of genotypes by sibship type integer, dimension(3*allele_buffer%numgtp) :: mztble integer, dimension(3*allele_buffer%numgtp*allele_buffer%numgtp) :: tble double precision, dimension(3*allele_buffer%numgtp*allele_buffer%numgtp) :: e integer :: aff1, aff2, contrib, g1, g2, g3, g4, gen2, & geno1, geno2, i, idx, j, k, nc, nsibs, nmz, nr, totcol, totrow integer :: currf, currm, fin, ped, pedoffset double precision :: lrts, lrts1, lrts2 integer :: df, df1, df2 logical :: first character (len=3) :: histo character (len=7) :: gtp1, gtp2 ! functions ! chip integer :: clcpos character (len=6) :: pstring contrib=0 first=(typ == 2) nmz=0 nsibs=0 mztble=0 tble=0 totcol=3 totrow=allele_buffer%numgtp*allele_buffer%numgtp gen2=gene+1 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) fin=dataset%num(ped) currf=dataset%fa(fin) currm=dataset%mo(fin) do k=dataset%num(ped)-1, pedoffset+dataset%nfound(ped), -1 if (dataset%fa(k) /= currf .or. dataset%mo(k) /= currm) then sibship: do i=k+1, fin if (observed(i, gene, dataset) .and. & dataset%plocus(i, trait) /= MISS) then aff1=int(dataset%plocus(i, trait)) call get_namedgeno(i, gene, gen2, dataset, allele_buffer, g1, g2) geno1=clcpos(g1, g2) do j=i+1, fin if (observed(j, gene, dataset) .and. & dataset%plocus(j, trait) /= MISS) then contrib=contrib+1 aff2=int(dataset%plocus(j, trait)) nc=aff1+aff2-1 if (dataset%imztwin(j) == MISS) then nsibs=nsibs+1 call get_namedgeno(j, gene, gen2, dataset, allele_buffer, & g3, g4) geno2=clcpos(g3, g4) if (aff2 > aff1) then nr=geno2+allele_buffer%numgtp*(geno1-1) else nr=geno1+allele_buffer%numgtp*(geno2-1) end if idx=totcol*(nr-1)+nc tble(idx)=tble(idx)+1 else nmz=nmz+1 idx=totcol*(geno1-1)+nc mztble(idx)=mztble(idx)+1 end if if (first) exit sibship end if end do end if end do sibship fin=k currf=dataset%fa(fin) currm=dataset%mo(fin) end if end do end if end do ! df1=0 df2=0 lrts1=0.0d0 lrts2=0.0d0 if (nsibs > 0) then call rclrts(totrow, totcol, tble, e, lrts1, df1) if (plevel > 0) then write(outstr,'(/a,i0/)') 'Number of sibling pairs: ', nsibs write(outstr,'(a)') locnam write(outstr,'(a)') 'Geno1 Geno2 ++ +- --' nr=0 do g1=1, allele_buffer%numal do g2=1, g1 i=clcpos(g1, g2) call wrgtp(allele_buffer%allele_names(g2), & allele_buffer%allele_names(g1), gtp1, '/', '', 1) do g3=1, allele_buffer%numal do g4=1, g3 j=clcpos(g3, g4) call wrgtp(allele_buffer%allele_names(g4), & allele_buffer%allele_names(g3), gtp2, '/', '', 1) nr=nr+1 idx=totcol*(nr-1) write(outstr,'(a7,1x,a7,1x,3i5)') & gtp1, gtp2, tble(idx+1), tble(idx+2), tble(idx+3) end do end do end do end do call rctest(totrow, totcol, tble, e, iter) end if else if (plevel > 0) then write(outstr,'(a)') 'No useful sibships' end if if (nmz > 0) then call rclrts(allele_buffer%numgtp, totcol, mztble, e, lrts2, df2) if (plevel > 0) then write(outstr,'(/a,i0/)') 'Number of MZ pairs: ', nmz write(outstr,'(a)') 'Genotype ++ +- --' do g1=1, allele_buffer%numal do g2=1, g1 idx=totcol*(clcpos(g1, g2)-1) call wrgtp(allele_buffer%allele_names(g2), & allele_buffer%allele_names(g1), gtp1, '/', '', 1) write(outstr,'(a7,1x,3i5)') & gtp1, mztble(idx+1), mztble(idx+2), mztble(idx+3) end do end do call rctest(allele_buffer%numgtp, totcol, mztble, e, iter) end if end if lrts=lrts1+lrts2 df=df1+df2 pval=chip(lrts, df) if (plevel > 0) then write(outstr,'(/a,g7.2/a,i0)') & ' LR contingency chi-square = ',lrts, & ' Degrees of freedom = ',df if (pval >= 0.0001d0) then write(outstr,'(a,f6.4)') & ' Combined asymptotic P-value = ', pval else write(outstr,'(a,g9.4)') & ' Combined asymptotic P-value = ', pval end if else if (plevel > -2) then call phist(pval, pval, histo) write(outstr,'(a14,2(a1,i6),a1,f10.1,a1,a,a1,a,a1,a)') & locnam, tabsep, nsibs+nmz, tabsep, df, tabsep, lrts, tabsep, & pstring(pval), tabsep, 'SibX2', tabsep, histo end if end subroutine sibass ! ! Random effects stratified proportional odds model of Whitehead and Whitehead ! subroutine whitehead(trait, gt, thresh, locnam, gene, loctyp, & allele_buffer, stratloc, stratvar, strattyp, & stratlabels, weight, dataset, pval, ptype, plevel) use outstream use alleles_class use locus_types use ped_class use contingency_table use statfuns use categorical_data implicit none integer, intent(in) :: trait integer, intent(in) :: gt double precision, intent(in) :: thresh character (len=*), intent(in) :: locnam integer, intent(in) :: gene integer, intent(in) :: loctyp type (allele_data), intent(in) :: allele_buffer character (len=*), intent(in) :: stratloc integer, intent(in) :: stratvar integer, intent(in) :: strattyp character (len=*), intent(in) :: stratlabels integer, intent(in) :: weight type (ped_data) :: dataset double precision, intent(out) :: pval integer, intent(in) :: ptype integer, intent(in) :: plevel ! local variables integer, parameter :: KNOWN=0, MISS=-9999 ! table of predictor and strata type (table_data) :: predictor, strata ! table of strata by genotypes by trait integer, dimension(:,:,:), allocatable :: counts ! statistics for each stratum double precision, dimension(:), allocatable :: het, theta, w, z integer :: g1, g2, gen2, gtp, i, iaff, is, j, k, nlevels, nobs, nstrata, pos, typ, iwt integer :: ped, pedoffset double precision :: bigw, bigz double precision :: lc, le, ll, nc, ne, tble, totc, tote, uc, ue, ul double precision :: q, u, mu, var, amu, avar, adju, adjpval, hetp, tausq double precision :: adjwt, adjsw, ase, dev, num, sumwt, w2 double precision :: p1, p2 double precision, dimension(1) :: val integer :: df character (len=3) :: histo character (len=9) :: cval1, cval2 ! functions character (len=6) :: pstring double precision :: isaff if (same_loctyp(loctyp, LOC_CODOM)) then if (allele_buffer%numal /= 2) return end if typ=1 if (istrait(loctyp)) typ=2 gen2=gene+1 nobs=0 iwt=1 adju=0.0d0 pval=1.0d0 call setup_table(1, 2, predictor) call setup_table(1, 30, strata) if (typ == 1) then do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) dataset%untyped(i)=.true. if (dataset%plocus(i,trait) /= MISS .and. & dataset%plocus(i,stratvar) /= MISS .and. & observed(i, gene, dataset)) then val(1)=dataset%plocus(i,stratvar) if (weight /= MISS) iwt=dataset%plocus(i, weight) call insert_table(1, val, strata, iwt) dataset%untyped(i)=.false. end if end do end if end do else do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) dataset%untyped(i)=.true. if (dataset%plocus(i,trait) /= MISS .and. & dataset%plocus(i,gene) /= MISS .and. & dataset%plocus(i,stratvar) /= MISS) then val(1)=dataset%plocus(i,stratvar) if (weight /= MISS) iwt=dataset%plocus(i, weight) call insert_table(1, val, strata, iwt) val(1)=dataset%plocus(i,gene) call insert_table(1, val, predictor, iwt) dataset%untyped(i)=.false. end if end do end if end do end if nobs=strata%ntot nstrata=strata%ncells if (typ == 1) then nlevels=3 else nlevels=predictor%ncells end if if (plevel > 0) then write(outstr,'(/3a,i0,a/)') & 'Results for: ', trim(locnam), ' (nlevels=', nlevels,')' end if if (nobs == 0 .or. nlevels < 2) then if (plevel > 0) then write(outstr,'(a)') 'No useful observations.' else if (plevel > -2) then write(outstr,'(a14,2(a1,i6),a1,f10.1,a1,a,a1,a,a1,a)') & locnam, tabsep, nobs, tabsep, nstrata, tabsep, adju, tabsep, & pstring(pval), tabsep, 'WhiX2', tabsep, ' ' end if return end if allocate(counts(nstrata, nlevels, 2)) allocate(het(nstrata), theta(nstrata), w(nstrata), z(nstrata)) counts=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) if (.not.dataset%untyped(i)) then is=findlev(dataset%plocus(i,stratvar), strata) iaff=int(isaff(dataset%plocus(i,trait), thresh, gt)) if (typ == 1) then call get_namedgeno(i, gene, gen2, dataset, allele_buffer, g1, g2) gtp=g1+g2-1 else gtp=nlevels-findlev(dataset%plocus(i,gene), predictor) + 1 end if if (weight /= MISS) iwt=dataset%plocus(i, weight) counts(is,gtp,iaff)=counts(is,gtp,iaff)+iwt end if end do end if end do ! do i=1, nstrata totc=0.0d0 tote=0.0d0 do j=1, nlevels tote=tote+dble(counts(i,j,1)) totc=totc+dble(counts(i,j,2)) end do tble=totc+tote lc=0.0d0 le=0.0d0 uc=totc ue=tote bigz=0.0d0 bigw=0.0d0 do j=1, nlevels ne=dble(counts(i,j,1)) nc=dble(counts(i,j,2)) ue=ue-ne uc=uc-nc bigz=bigz+ne*(lc-uc) bigw=bigw+ne*(totc-nc)+nc*ne*(tble-nc-ne)+2.0d0*ne*lc*uc+2.0d0*nc*le*ue le=le+ne lc=lc+nc end do z(i)=bigz/(tble+1.0d0) w(i)=bigw/(tble+1.0d0)/(tble+2.0d0)+z(i)*z(i)/(tble+2.0d0) theta(i)=0.0d0 if (w(i) > 0.0d0) theta(i)=z(i)/w(i) end do num=0.0d0 w2=0.0d0 sumwt=0.0d0 do i=1, nstrata num=num+theta(i)*w(i) sumwt=sumwt+w(i) w2=w2+w(i)*w(i) end do q=0.0d0 u=0.0d0 amu=0.0d0 avar=0.0d0 mu=0.0d0 tausq=0.0d0 if (sumwt > 0.0d0) then u=num*num/sumwt mu=num/sumwt var=1/sumwt end if do i=1, nstrata dev=theta(i)-mu het(i)=w(i)*dev*dev q=q+het(i) end do if (sumwt > 0.0d0) then tausq=(q-dble(max(1,nstrata-1)))/(sumwt-w2/sumwt) if (tausq < 0.0d0) tausq=0.0d0 end if df=0 adjsw=0.0d0 adju=0.0d0 num=0.0d0 do i=1, nstrata adjwt=0.0d0 if (w(i) > 0.0d0) then df=df+1 adjwt=1.0d0/(1.0d0/w(i)+tausq) end if num=num+theta(i)*adjwt adjsw=adjsw+adjwt end do if (adjsw > 0.0d0) adju=num*num/adjsw if (tausq > 0.0d0) then amu=num/adjsw avar=1.0d0/adjsw else amu=mu avar=1.0d0/sumwt+tausq*w2/sumwt/sumwt end if pval=chip(u,1) adjpval=pval if (adju > 0.0d0) adjpval=chip(adju, 1) hetp=chip(q, df) if (plevel > 0) then write(outstr,'(a)', advance='no') 'Stratum N theta ASE Het' if (typ == 1) then write(outstr,'(a)') ' Case Control' else write(outstr,*) end if write(outstr,'(a)') '--------- ------ ------- ------- -------' do i=1, nstrata pos=strata%idx(i) call wrtrait(strata%categories(pos,1)%rvalue, cval1, strattyp, & get_notes(stratloc, stratlabels), 9, 4) ase=0.0d0 if (w(i) > 0.0d0) ase=1.0d0/sqrt(w(i)) if (typ == 1) then nc=dble(counts(i,1,2)+counts(i,2,2)+counts(i,3,2)) ne=dble(counts(i,1,1)+counts(i,2,1)+counts(i,3,1)) p2=0.5d0*dble(2*counts(i,1,2)+counts(i,2,2))/nc p1=0.5d0*dble(2*counts(i,1,1)+counts(i,2,1))/ne write(outstr,'(a,i8,3(1x,f7.2),2(1x,a6))') & cval1, strata%icount(pos), theta(i), ase, het(i), & pstring(p2), pstring(p1) else write(outstr,'(a,i8,3(1x,f7.2))') & cval1, strata%icount(pos), theta(i), ase, het(i) end if end do write(outstr,'(/a,i0/a,i0/a,f7.2/a,i0/a,f6.4)') & ' Number of observations = ', nobs, & ' Number of strata = ', nstrata, & ' Homogeneity chi-square = ', q, & ' Degrees of freedom = ', df, & ' Asymptotic P-value = ', hetp write(outstr,'(3(/a,f7.2)/a,i0)') & ' FE model Assoc chi-square = ', u, & ' Random effects Variance = ', tausq, & ' RE model Assoc chi-square = ', adju, & ' Degrees of freedom = ', 1 if (pval >= 0.0001d0) then write(outstr,'(a,f6.4)') & ' FE Asymptotic P-value = ', pval else write(outstr,'(a,g9.4)') & ' FE Asymptotic P-value = ', pval end if if (adjpval >= 0.0001d0) then write(outstr,'(a,f6.4)') & ' RE Asymptotic P-value = ', adjpval else write(outstr,'(a,g9.4)') & ' RE Asymptotic P-value = ', adjpval end if write(cval1, '(f9.2)') exp(amu-1.96*sqrt(avar)) write(cval2, '(f9.2)') exp(amu+1.96*sqrt(avar)) write(outstr,'(a,f8.2,5a)') & ' RE Pooled Odds Ratio =', exp(amu), & ' (', trim(adjustl(cval1)), ' -- ', trim(adjustl(cval2)), ')' else if (plevel > -2) then if (ptype == 1) then call phist(pval, pval, histo) write(outstr,'(a20,2(a1,i6),a1,f10.1,a1,a,a1,a,a1,a)') & locnam, tabsep, nobs, tabsep, nstrata, tabsep, u, tabsep, & pstring(pval), tabsep, 'WhiX2', tabsep, histo else call phist(hetp, hetp, histo) write(outstr,'(a20,2(a1,i6),a1,f10.1,a1,a,a1,a,a1,a)') & locnam, tabsep, nobs, tabsep, nstrata, tabsep, q, tabsep, & pstring(hetp), tabsep, 'HetX2', tabsep, histo end if end if if (ptype == 2) pval = hetp end subroutine whitehead ! ! Read summary allele counts from a VCF file and do case-population comparison ! subroutine vcfcascon(trait, gt, thresh, assfnd, vcf_ac, vcf_an, & vcf_het, vcf_hom, port, dataset, plevel) use interrupt use comp_ops use iobuff use vcftools use locus_types use locus_data use locus_list use idstring_widths use locus_data use ped_class use alleles_class use nucleotides use contingency_table use sorts use fileio use scanner use statfuns implicit none integer, intent(in) :: trait integer, intent(in) :: gt double precision, intent(in) :: thresh logical, intent(in) :: assfnd character (len=*), intent(in) :: vcf_ac, vcf_an, vcf_het, vcf_hom type (ioport) :: port ! Hash table for IDs type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel integer, parameter :: MISS = -9999, WORDLEN=80 ! file i/o port ! ID strings and data strings integer :: narg integer, dimension(:), allocatable :: idx, vcfcol ! buffer for entire line of data character (len=20000) :: buffer character (len=WORDLEN) :: curloc, slin character (len=WORDLEN), dimension(8) :: words ! and for split ID if of form ped_id character (len=WORDLEN), dimension(2) :: idstrings ! allow matching by map position type (hash_table) :: maphash character (len=13), dimension(nloci) :: map_str character (len=13) :: pos_str ! current phenotype integer, dimension(dataset%nobs) :: aff ! Marginal trait tabulation type (table_data) :: traittable double precision, dimension(1) :: val logical :: allelic, multcat ! alleles for current locus ! and alleles in current dataset at this locus type (allele_data) :: allele_buffer, vcf_alleles ! allele counts integer :: numal, traitlevels integer, dimension(:,:), allocatable :: counts, gcounts double precision, dimension(:), allocatable :: afreq double precision, dimension(:), allocatable :: e integer, dimension(:), allocatable :: byrow double precision :: asyp, hwep, lrts integer :: df ! integer :: aref, astat, badmatch, conpos, g, g1, g2, gene, gen2, & i, iaff, ii, ioerr, j, jj, longall, n, ncol, nhet, & nlines, nmar, ped, pos, totmark, tpos integer :: nf, nobs, nped, num, pedoffset integer :: allele_map(20) logical :: fnd double precision :: dn character (len=1) :: allsep character (len=3) :: allel, allel2 character (len=WORDLEN) :: cval ! where to write discordant SNPs integer :: disrep ! functions integer :: aval, ival integer :: getnam double precision :: fval, isaff character (len=8) :: wrpercent character (len=6) :: pstring n=0 nhet=-1 ncol=9 ! header call readline(port, buffer, ios=ioerr) if (ioerr /= 0) then write(outstr,'(a)') 'ERROR: Could not read VCF file header!' return end if narg=4 call args(buffer, narg, words, ' ', SEP_WH_RES) if (words(1) /= '##fileformat') then write(outstr,'(a/8x,a)') & 'NOTE: Expected metainformation headed by "##fileformat=..." in:', & '"', buffer(1:60), '..."' words(3)='Nonstandard' end if write(outstr,'(3a)') 'VCF file name = "', trim(port%filnam), '"' write(outstr,'(3a/)') 'File format = "', trim(words(3)), '"' call metavcf_vars(port, buffer, trim(vcf_ac) // ',' // trim(vcf_an), ioerr, plevel) if (ioerr /= 0) then write(outstr,'(/5a)') & 'ERROR: Expected metainformation for "', & trim(vcf_ac), '" and "', trim(vcf_an), '".' return end if tpos=locpos(trait) traitlevels=2 aff=MISS dataset%untyped=.true. if ((loctyp(tpos) == LOC_CAT .or. loctyp(tpos) == LOC_QUA) .and. gt < COMP_LT) then multcat=.true. call setup_table(1, 30, traittable) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) n=dataset%num(ped) if (assfnd) then n=pedoffset+dataset%nfound(ped) end if do i=pedoffset+1, n if (dataset%plocus(i,tpos) /= MISS) then dataset%untyped(i)=.false. val(1)=dataset%plocus(i,tpos) call insert_table(1, val, traittable, 1) end if end do end if end do traitlevels=traittable%ncells do i=1, dataset%nobs if (.not.dataset%untyped(i)) then aff(i)=findlev(dataset%plocus(i,tpos), traittable) end if end do else do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) n=dataset%num(ped) if (assfnd) then n=pedoffset+dataset%nfound(ped) end if do i=pedoffset+1, n if (dataset%plocus(i,tpos) /= MISS) then dataset%untyped(i)=.false. aff(i)=int(isaff(dataset%plocus(i,tpos), thresh, gt)) end if end do end if end do end if if (traitlevels == 0) return conpos=traitlevels+1 allocate(counts(conpos,64)) allocate(gcounts(conpos,64)) allocate(afreq(conpos)) allocate(e(conpos*64)) allocate(byrow(conpos*64)) if (.not.lochash%current) then call make_lochash(nloci, loc, lochash) end if call make_maphash(nloci, loctyp, group, map, map_str, maphash) call cntmark(nloci, loctyp, totmark, 3) badmatch=0 nmar=0 nlines=0 call setup_freq(64, vcf_alleles) if (plevel == 0) then write(outstr,'(/a/a)') & 'Marker Typed Allele Case Contrl Pop Chi-square Asy P', & '-------------------- ------ -------- ------ ------ ------ ---------- ------' end if ! ! Read each locus from VCF file in turn ! if (plevel == 0) then call newlun(disrep) open(disrep, status='scratch', form='formatted') end if do call readline(port, buffer, ios=ioerr) if (ioerr /= 0) exit nlines=nlines+1 narg=8 call args(buffer, narg, words, ' ', SEP_WHITE) call getword(buffer, 3, curloc) if (words(1)(1:3) == 'chr') words(1)=words(1)(4:len_trim(words(1))) if (curloc == '.') then curloc='chr' // trim(words(1)) // ':' // trim(words(2)) end if call find_hashtab(trim(curloc(1:loc_width)), loc, lochash, pos) if (pos == 0) then pos_str=trim(words(1)) // ':' // adjustl(words(2)) call find_hashtab(trim(pos_str), map_str, maphash, pos) end if ! if eligible if (pos > 0) then if (.not.isactive(loctyp(pos))) pos=0 end if if (pos > 0) then nmar=nmar+1 gene=locpos(pos) gen2=gene+1 byrow=0 counts=0 gcounts=0 longall=0 narg=ncol ! read in alleles as specified by VCF file for this locus call load_vcf_refall(2, vcf_ac, vcf_an, vcf_het, vcf_hom, buffer, vcf_alleles) ! test if reference allele from VCF is compatible with current dataset - aref=-1 if (vcf_alleles%totall > 0) then allele_map=-1 call freq(gene, loctyp(pos), 0, dataset, allele_buffer) ! flip strand if necessary after comparing to current dataset call refstrand(2, loc(pos), gene, dataset, allele_buffer, & vcf_alleles, astat, plevel-2) do j=1, allele_buffer%numal if (vcf_alleles%allele_names(vcf_alleles%topall) == & allele_buffer%allele_names(j)) then aref=j end if do jj=1, vcf_alleles%numal if (vcf_alleles%allele_names(jj) == & allele_buffer%allele_names(j)) then allele_map(j)=jj end if end do end do ! alleles must be compatible do j=1, allele_buffer%numal if (allele_map(j) < 0) aref=-1 end do end if if (plevel > 2) then write(outstr,'(/a)') 'Current dataset:' call wrfreq(outstr, loc(pos), group(pos), map(pos), & locnotes(pos), allele_buffer, 1) write(outstr,'(/a)') 'Reference population:' call wrfreq(outstr, curloc, group(pos), map(pos), & words(8), vcf_alleles, 1) end if ! if inconsistent alleles, skip comparison ! otherwise test difference population frequencies versus ! matching dataset allele frequencies if (aref > 0) then n=int(vcf_alleles%allele_freqs(vcf_alleles%topall) * & dble(vcf_alleles%totall)) if (n > 0) counts(conpos,1)=n n=vcf_alleles%totall-n if (n > 0) counts(conpos,2)=n ! ! n12=nhet n11=(AC-n12)/2 ! if (vcf_alleles%untyped > -1) then gcounts(conpos,2)=vcf_alleles%untyped gcounts(conpos,1)=(counts(conpos,1)-vcf_alleles%untyped)/2 gcounts(conpos,3)=(counts(conpos,2)-vcf_alleles%untyped)/2 end if numal=2 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) if (.not.dataset%untyped(i)) then if (observed(i, gene, dataset)) then iaff=aff(i) call get_namedgeno(i, gene, gen2, dataset, allele_buffer, g1, g2) g=3 if (g1 == aref) then g=g-1 counts(iaff,1)=counts(iaff,1)+1 else counts(iaff,2)=counts(iaff,2)+1 end if if (g2 == aref) then g=g-1 counts(iaff,1)=counts(iaff,1)+1 else counts(iaff,2)=counts(iaff,2)+1 end if gcounts(iaff,g)=gcounts(iaff,g)+1 end if end if end do end if end do ii=0 do j=1, conpos byrow((ii+1):(ii+numal))=counts(j,1:numal) afreq(j)=dble(counts(j,2))/dble(max(1,sum(counts(j,1:numal)))) ii=ii+numal end do call rclrts(conpos, numal, byrow, e, lrts, df) asyp=chip(lrts, df) locstat(pos)=asyp call wrall(allele_buffer%allele_names(aref), allel) allel=adjustl(allel) allel2='Other' if (allele_buffer%numal == 2) then call wrall(allele_buffer%allele_names(3-aref), allel2) allel2=adjustl(allel2) end if if (plevel == 0) then write(outstr,'(a20,i7,1x,a8,3(1x,f6.4),1x,f10.1,1x,a)') & loc(pos), sum(counts)/2, trim(allel2) // ' (' // trim(allel) // ')', & afreq(2), afreq(1), afreq(3), lrts, pstring(asyp) else if (plevel > 0) then write(outstr,'(/5a)') & '---- Association Analysis for "', trim(loc(trait)), '" v "', trim(loc(pos)), '" ----' write(outstr, '(4x,a7,1x,a7,2(4x,a),3(1x,a7),2x,a)') & allel, allel2, 'AF1', 'AF2', & trim(allel) // '/' // trim(allel), & trim(allel) // '/' // trim(allel2), & trim(allel2) // '/' // trim(allel2), 'HWE-P' call hwe2(gcounts(2,1), gcounts(2,2), gcounts(2,3), dn, hwep) write(outstr, '(a,2(1x,i7),2(1x,a),3(1x,i7),2x,a)') & 'Aff', counts(2,1:2), pstring(1.0d0-afreq(2)), pstring(afreq(2)), & gcounts(2,1:3), pstring(hwep) call hwe2(gcounts(1,1), gcounts(1,2), gcounts(1,3), dn, hwep) write(outstr, '(a,2(1x,i7),2(1x,a),3(1x,i7),2x,a)') & 'UnA', counts(1,1:2), pstring(1.0d0-afreq(1)), pstring(afreq(1)), & gcounts(1,1:3), pstring(hwep) write(outstr, '(a,2(1x,i7),2(1x,a))', advance='no') & 'Pop', counts(3,1:2), pstring(1.0d0-afreq(3)), pstring(afreq(3)) if (vcf_alleles%untyped /= -1) then call hwe2(gcounts(3,1), gcounts(3,2), gcounts(3,3), dn, hwep) write(outstr, '(3(1x,i7),2x,a)') & gcounts(3,1:3), pstring(hwep) else write(outstr, '(3(7x,a1))') repeat('-',3) end if write(outstr, '(a,1x,f10.1,1x,3a)') & 'LRTS=', lrts, '(P=', trim(pstring(asyp)), ')' end if else badmatch=badmatch+1 if (plevel == 0 .or. plevel == 1) then write(disrep,'(a20,1x,a)', advance='no') loc(pos),'Curr:' call wrfreq(disrep, loc(pos), group(pos), map(pos), & locnotes(pos), allele_buffer, 22) write(disrep,'(a)', advance='no') '; VCF:' call wrfreq(disrep, curloc, group(pos), map(pos), & words(8), vcf_alleles, 22) write(disrep,'(4a)') ' - ', trim(words(4)), '/', trim(words(5)) else if (plevel > 1) then write(outstr,'(/3a/a)', advance='no') & 'Incompatible alleles at "', trim(loc(pos)), '":', 'This dataset:' call wrfreq(outstr, loc(pos), group(pos), map(pos), & locnotes(pos), allele_buffer, 15) write(outstr,'(a)', advance='no') ' VCF file:' call wrfreq(outstr, curloc, group(pos), map(pos), & words(8), vcf_alleles, 15) end if end if end if if (nmar == totmark) exit if (irupt /= 0) exit end do if (plevel > 0) then write(outstr, '(/a,i0,a,i0)') & 'Number of loci matched with VCF file = ', nmar, '/', totmark end if if (badmatch > 0 .and. plevel > -1) then write(outstr, '(/a,i0)') & 'Number of SNPs with discordant alleles = ', badmatch if (plevel == 0 .or. plevel == 1) then rewind(disrep) write(outstr,*) do i=1, badmatch read(disrep, '(a)') buffer write(outstr,'(a)') trim(buffer) end do close(disrep) end if end if end subroutine vcfcascon ! ! Recode rare allele carriers for currently active markers to a marker ! subroutine rarecarrier(mark, thresh, dataset, plevel) use interrupt use comp_ops use iobuff use locus_types use locus_data use locus_list use idstring_widths use locus_data use ped_class use alleles_class use nucleotides use sorts use fileio use scanner implicit none integer, intent(in) :: mark double precision, intent(in) :: thresh type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel integer, parameter :: MISS = -9999, WORDLEN=80 ! current phenotype ! alleles for current locus ! and alleles in current dataset at this locus type (allele_data) :: allele_buffer ! integer :: aref, astat, g1, g2, gene, gen2, i, iaff, ii, & ioerr, j, n, ncol, nmar, og1, og2, ped, pos, totmark integer, dimension(3) :: tcount integer, dimension(dataset%nobs) :: carrier, ntyped integer :: nf, nobs, nped, num, pedoffset double precision :: maxthresh ! functions integer :: aval, ival integer :: getnam double precision :: fval, isaff maxthresh = 1.0d0 - thresh nmar=0 tcount=0 carrier=0 ntyped=0 ! ! Each active locus in turn ! do j=1, nloci if (isactdip(loctyp(j)) .and. irupt == 0 .and. j /= mark) then call freq(locpos(j), loctyp(j), 0, dataset, allele_buffer) if (allele_buffer%allele_freqs(allele_buffer%topall) .gt. maxthresh) then nmar=nmar+1 gene=locpos(j) gen2=gene+1 aref=allele_buffer%allele_names(allele_buffer%topall) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) if (observed(i, gene, dataset)) then ntyped(i)=ntyped(i)+1 call get_geno(i, gene, gen2, dataset, g1, g2) if (g1 /= aref) carrier(i)=carrier(i)+1 if (g2 /= aref) carrier(i)=carrier(i)+1 end if end do end if end do end if end if end do ! set indicator variable og1=locpos(mark) og2=og1+1 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (ntyped(i) > 0) then g1=1 g2=1 if (carrier(i) > 0) g2=g2+1 if (carrier(i) > 1) g1=g1+1 tcount(g1+g2-1)=tcount(g1+g2-1)+1 else g1=MISS g2=MISS end if call set_geno(i, og1, og2, dataset, g1, g2) end do end if end do write(outstr,'(/a,i0/)') 'Number of eligible loci = ', nmar write(outstr,'(a,i0)') 'Number wild type = ', tcount(1) write(outstr,'(a,i0)') 'Number heterozygotes = ', tcount(2) write(outstr,'(a,i0)') 'Number putative homoz = ', tcount(3) end subroutine rarecarrier ! ! Enumerate rare alleles in cases and controls for currently active markers ! subroutine rarecascon(trait, thresh, dataset, plevel) use interrupt use iobuff use locus_types use locus_data use locus_list use idstring_widths use locus_data use ped_class use alleles_class use nucleotides use contingency_table use sorts use fileio use scanner use statfuns implicit none integer, intent(in) :: trait double precision, intent(in) :: thresh type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel integer, parameter :: MISS = -9999, WORDLEN=80 ! current phenotype and genotype integer, dimension(dataset%nobs) :: aff, ntyped, rarealls ! tabulation for each locus type (table_data) :: carrier_table type (table_cell), dimension(5) :: val ! counts for one locus ! alleles for current locus ! and alleles in current dataset at this locus type (allele_data) :: allele_buffer ! allele counts integer :: numal, traitlevels integer, dimension(0:2,2) :: counts, curr_counts integer, dimension(12) :: cctab double precision, dimension(8) :: ec ! integer :: aref, astat, g1, g2, gene, gen2, i, iaff, ii, & ioerr, j, n, n1, n2, ncol, nmar, ped, pos, totmark, tpos double precision :: prop logical :: carrier integer :: nf, nobs, nped, num, pedoffset double precision :: maxthresh character (len=1) :: allsep character (len=3) :: allel, allel2 character (len=7) :: gtp character (len=7), dimension(0:2) :: casecon = & (/ 'Unknown', 'Control', 'Case ' /) ! functions integer :: aval, ival integer :: getnam double precision :: fval, isaff character (len=8) :: wrpercent character (len=6) :: pstring maxthresh = 1.0d0 - thresh call setup_table(5, 50, carrier_table) tpos=locpos(trait) aff=0 ntyped=0 rarealls=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) n=dataset%num(ped) do i=pedoffset+1, n if (dataset%plocus(i,tpos) /= MISS) then aff(i)=int(dataset%plocus(i,tpos)) end if end do end if end do nmar=0 counts=0 cctab=0 rarealls=0 ! ! Each active locus in turn ! if (plevel > -1) then write(outstr,'(/a,15x,2a,15x,6a)') & 'Locus' , tabsep, 'Individual', tabsep, & 'Case ', tabsep, 'Genotype', tabsep, 'Notes' end if do j=1, nloci if (isactdip(loctyp(j)) .and. irupt == 0) then call freq(locpos(j), loctyp(j), 0, dataset, allele_buffer) if (allele_buffer%allele_freqs(allele_buffer%topall) .gt. maxthresh) then curr_counts=0 nmar=nmar+1 gene=locpos(j) gen2=gene+1 aref=allele_buffer%allele_names(allele_buffer%topall) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) if (observed(i, gene, dataset)) then ntyped(i)=ntyped(i)+1 iaff=aff(i) call get_geno(i, gene, gen2, dataset, g1, g2) carrier=.false. if (g1 /= aref) carrier=.true. if (g2 /= aref) carrier=.true. if (carrier) then rarealls(i)=rarealls(i)+1 counts(iaff,1)=counts(iaff,1)+1 curr_counts(iaff,1)=curr_counts(iaff,1)+1 if (plevel > -1) then call wrgtp(g1, g2, gtp, '/', '', 1) write(outstr,'(a,a1,a25,a1,a8,a1,a,a1,a)') & loc(j), tabsep, trim(dataset%pedigree(ped)) // '--' // & trim(dataset%id(i)), tabsep, casecon(iaff), tabsep, gtp, & tabsep, trim(locnotes(j)) end if else counts(iaff,2)=counts(iaff,2)+1 curr_counts(iaff,2)=curr_counts(iaff,2)+1 end if end if end do end if end do ! Tabulation of counts for each rare locus call set_table_cell(val(1), ivalue=j) call set_table_cell(val(2), ivalue=curr_counts(1,1)) call set_table_cell(val(3), ivalue=curr_counts(1,2)) call set_table_cell(val(4), ivalue=curr_counts(2,1)) call set_table_cell(val(5), ivalue=curr_counts(2,2)) call insert_table_cells(5, val, carrier_table, 1) end if end if end do do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (ntyped(i) > 0) then pos=4*aff(i)+min(rarealls(i),3)+1 cctab(pos)=cctab(pos)+1 end if end do end if end do ! ! print carrier table for each locus ! write(outstr,'(/a20,2(a,a19),2a)') & 'Locus' // repeat(' ',14), tabsep, 'Case carriers', tabsep, & 'Control carriers', tabsep, 'Notes' write(outstr,'(7a)') & repeat('-',20), tabsep, repeat('-',19), tabsep, repeat('-',19), tabsep, repeat('-', 8) do j=1, carrier_table%ncells call get_table_cell(carrier_table%categories(j,1), ivalue=ii) call get_table_cell(carrier_table%categories(j,2), ivalue=curr_counts(1,1)) call get_table_cell(carrier_table%categories(j,3), ivalue=curr_counts(1,2)) call get_table_cell(carrier_table%categories(j,4), ivalue=curr_counts(2,1)) call get_table_cell(carrier_table%categories(j,5), ivalue=curr_counts(2,2)) n1=curr_counts(1,1)+curr_counts(1,2) n2=curr_counts(2,1)+curr_counts(2,2) write(outstr,'(a20, 2(a,i6,1x,i6,1x,f6.1,a),2a)') & loc(ii), tabsep, & curr_counts(2,1), n2, dfloat(100*curr_counts(2,1))/dfloat(max(1,n2)), '%', & tabsep, & curr_counts(1,1), n1, dfloat(100*curr_counts(1,1))/dfloat(max(1,n1)), '%', & tabsep, trim(locnotes(ii)) end do ! burden test write(outstr,'(/a,i0//9x,a,2(/a8,4a7,1x,a))') & 'Number of eligible loci = ', nmar, & 'Rare variants carried by indivdual', & 'Case', '0', '1', '2', '3+', 'Percentage(Any)', & '-------', '------', '------', '------', '------', '----------' do iaff=2, 0, -1 pos=4*iaff+1 n=sum(cctab(pos:(pos+3))) prop=0.0d0 if (n > 0) prop=100.0d0-dfloat(100*cctab(pos))/dfloat(n) write(outstr,'(a8,4(1x,i6),3x,f5.1,a)') & casecon(iaff), cctab(pos:(pos+3)), prop, '%' end do call rctest(2, 4, cctab(5:12), ec, 100) write(outstr,'(/a/a)') & 'Summed rare allele counts:', & 'Case Rare (Prop) Total' do iaff=2, 1, -1 n=counts(iaff,1)+counts(iaff,2) write(outstr,'(a,1x,i8,1x,a,f8.6,a,1x,i10)') & casecon(iaff), counts(iaff,1), & '(', dble(counts(iaff,1))/dble(max(1,n)), ')', n end do end subroutine rarecascon ! ! SKAT test ! subroutine doskat(trait, typ, dataset, pval, plevel) use interrupt use iobuff use genetic_maps use locus_types use locus_data use locus_list use idstring_widths use locus_data use ped_class use alleles_class use nucleotides use contingency_table use sorts use fileio use scanner use statfuns implicit none integer, intent(in) :: trait integer, intent(in) :: typ ! weighting type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel double precision, intent(out) :: pval integer, parameter :: MAXMAR = 1000, MISS = -9999, WORDLEN=80 ! current phenotype and genotype double precision, dimension(dataset%nobs,1) :: yval integer, dimension(dataset%nobs) :: idx, ntyped integer, dimension(MAXMAR) :: markid integer, dimension(MAXMAR) :: snp_topall double precision, dimension(MAXMAR) :: alfreq ! alleles for current locus type (allele_data) :: allele_buffer ! ! genotypes (naff * nmar) ! double precision, dimension(:,:), allocatable :: gmat ! ! kernel and null P matrix ! double precision, dimension(:,:), allocatable :: kmat, pmat double precision, dimension(:,:), allocatable :: gpgmat double precision, dimension(:), allocatable :: eigenvals, weights ! integer :: aref, astat, g, g1, g2, gene, gen2, i, ii, & ioerr, j, jj, naff, n, nmar, nmiss, ntot, ped, pos, tpos integer :: nf, nobs, nped, num, pedoffset character (len=1) :: allsep character (len=3) :: allel, allel2 character (len=7) :: gtp double precision :: adjust, mgscore, onen, pp, ymean, ss double precision, dimension(1,1) :: skatstat ! functions integer :: aval, ival integer :: getnam double precision :: fval, isaff character (len=14) :: gstring character (len=6) :: pstring nmar=0 do j=1, nloci if (isactdip(loctyp(j)) .and. irupt == 0) then call freq(locpos(j), loctyp(j), 0, dataset, allele_buffer) if (allele_buffer%numal > 1) then nmar=nmar+1 markid(nmar)=j alfreq(nmar)=1.0d0-allele_buffer%allele_freqs(allele_buffer%topall) snp_topall(nmar)=allele_buffer%allele_names(allele_buffer%topall) end if end if if (nmar == MAXMAR) exit end do if (nmar == MAXMAR) then write(outstr,'(a,i0,a)') & 'NOTE: Analysis restricted to maximum ', MAXMAR, ' markers.' end if if (nmar == 0) then write(outstr,'(a)') & 'NOTE: No eligible markers.' return end if tpos=locpos(trait) adjust=0.0d0 if (loctyp(trait) == LOC_AFF) adjust=1.0d0 yval=0.0d0 ymean=0.0d0 ss=0.0d0 ntot=0 idx=0 ntyped=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) if (dataset%plocus(i,tpos) /= MISS) then n=0 do jj=1, nmar j=markid(jj) if (observed(i, locpos(j), dataset)) then n=n+1 end if end do if (n > 0) then ntot=ntot+1 idx(ntot)=i yval(ntot,1)=dataset%plocus(i,tpos)-adjust call moment(ntot, yval(ntot,1), ymean, ss) ntyped(ntot)=n end if end if end do end if end do pp=ss/dble(max(ntot,1)) onen=1.0d0-1.0d0/dble(ntot) yval=yval-ymean allocate(gmat(ntot, nmar)) allocate(kmat(ntot, ntot), pmat(ntot, ntot), stat=i) if (i /= 0) then write(outstr,'(a,f5.1,a/7x,a,i0,a,i0)') & 'ERROR: Was not able to allocate ', 1.6e-8*dble(ntot)*dble(ntot), & 'G memory for SKAT kernel.', 'n=', ntot, ' m=', nmar return end if allocate(gpgmat(nmar, nmar)) allocate(eigenvals(nmar), weights(nmar)) weights=1.0d0 if (typ > 1) then ss=0.0d0 if (typ == 2) then do jj=1, nmar weights(jj)=sqrt(1.0d0/alfreq(jj)/(1.0d0-alfreq(jj))) ss=ss+weights(jj) end do else if (typ == 3) then do jj=1, nmar weights(jj)=dbeta(alfreq(jj), 1.0d0, 25.0d0) ss=ss+weights(jj) end do end if do jj=1, nmar weights(jj)=dble(nmar)*weights(jj)/ss end do end if ! ! Each active locus in turn ! if (plevel > 0) then write(outstr,'(/a)') & 'Marker Chr Position MAF Weight Typed' end if nmiss=0 do jj=1, nmar j=markid(jj) gene=locpos(j) gen2=gene+1 mgscore=2*weights(jj)*alfreq(jj) n=0 do ii=1, ntot i=idx(ii) if (missing(i, gene, dataset)) then nmiss=nmiss+1 gmat(ii,jj)=mgscore else n=n+1 call get_geno(i, gene, gen2, dataset, g1, g2) g=2 if (g1 == snp_topall(jj)) g=g-1 if (g2 == snp_topall(jj)) g=g-1 gmat(ii,jj)=weights(jj)*dble(g) end if end do if (plevel > 0) then write(outstr,'(a,1x,a,1x,a,1x,f6.4,1x,g12.4,1x,i0)') & loc(j), group(j), mapstring(map(j)), alfreq(jj), weights(jj), n end if end do kmat=matmul(gmat, transpose(gmat)) skatstat=matmul(transpose(yval(1:ntot,:)), matmul(kmat, yval(1:ntot,:))) write(outstr, '(/a,i0/a,i0,5a/a,i0,a,f5.3,a/5a)') & 'Number of useful individuals = ', ntot, & 'Number of active markers = ', nmar, & ' (', trim(loc(markid(1))), ' -- ', trim(loc(markid(nmar))), ')', & 'Number of missing genotypes = ', nmiss, ' (', dble(nmiss)/dble(nmar*ntot), ')', & 'Trait mean = ', & trim(gstring(ymean)), ' (SD=', trim(gstring(sqrt(pp))), ')' write(outstr, '(2a)') & 'Skat test statistic = ', trim(gstring(skatstat(1,1))) pmat=-pp/dfloat(ntot) do ii=1, ntot pmat(ii,ii)=pp*onen end do gpgmat=matmul(matmul(transpose(gmat), pmat), gmat) call eigens(nmar, gpgmat, eigenvals) ! call dsort(nmar, eigenvals) do n=nmar, 1, -1 if (eigenvals(n) < 1.0d0) exit end do if (n == nmar) then write(outstr, '(/a,i0,a,g14.4/)') & 'NOTE: Largest (of', nmar,') eigenvalues is ', maxval(eigenvals) end if if (plevel > 0) then write(outstr, '(/a,i0,a/)') & 'NOTE: Using ', nmar-n+1 ,' largest eigenvalues for P-value calculation.' end if call pchisqsum(skatstat(1,1), eigenvals(n:nmar), pval) write(outstr, '(a,a)') & 'Skat test P-value = ', pstring(pval) if (plevel > 0) then n=12 write(outstr, '(/a)', advance='no') 'Eigenvalues:' do i=nmar, max(1, nmar-20), -1 n=n+8 if (n > 72) then n=20 write(outstr, '(/12x)', advance='no') end if write(outstr, '(1x,f7.2)', advance='no') eigenvals(i) end do end if if (plevel > 1) then write(outstr, '(/a/a/)') 'Individual Phenotype Typed Markers', & '-------------------- --------- -------------' do ii=1, ntot write(outstr, '(a20,1x,f9.4,1x,i0,1x,f5.3)') & dataset%id(idx(ii)), yval(ii,1), ntyped(ii), dble(ntyped(ii))/dble(nmar) end do end if end subroutine doskat ! ! Simulate (gene-dropping) genotypes at a single autosomal locus ! in a pedigree of arbitrary complexity ! subroutine simped(ped, dataset, allele_buffer, set) use alleles_class use ped_class integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data), intent(in) :: allele_buffer integer, dimension(:,:), intent(out) :: set ! integer, parameter :: MISS=-9999 integer :: i, ii, num, pedoffset logical :: fin interface subroutine found(cumfrq, allele) double precision, dimension(:), intent(in) :: cumfrq integer, intent(out) :: allele end subroutine subroutine genoff(idx, fa, mo, set) integer, intent(in) :: idx integer, intent(in) :: fa integer, intent(in) :: mo integer, dimension(:,:), intent(in out) :: set end subroutine subroutine gencopy(idx, origin, set) integer, intent(in) :: idx integer, intent(in) :: origin integer, dimension(:,:), intent(inout) :: set end subroutine gencopy end interface pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset do i=1, dataset%nfound(ped) call found(allele_buffer%cum_freqs, set(i,1)) call found(allele_buffer%cum_freqs, set(i,2)) call order(set(i,1), set(i,2)) end do do i=dataset%nfound(ped)+1, num set(i,1)=MISS set(i,2)=MISS end do do fin=.true. ii=pedoffset+dataset%nfound(ped) do i=dataset%nfound(ped)+1, num ii=ii+1 if (set(i,1) == MISS) then if (set(dataset%fa(ii)-pedoffset,1) /= MISS .and. & set(dataset%mo(ii)-pedoffset,1) /= MISS) then if (dataset%imztwin(ii) /= MISS) then call gencopy(i, dataset%imztwin(ii)-pedoffset, set) else call genoff(i, dataset%fa(ii)-pedoffset, & dataset%mo(ii)-pedoffset, set) end if else fin=.false. end if end if end do if (fin) exit end do end subroutine simped ! ! Simulate (gene-dropping) genotypes at a single X-linked locus ! in a pedigree of arbitrary complexity ! subroutine xsimped(ped, dataset, allele_buffer, set) use alleles_class use ped_class use rngs integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data), intent(in) :: allele_buffer integer, dimension(:,:), intent(out) :: set ! integer, parameter :: MISS=-9999 integer :: i, num, pedoffset logical :: fin ! functions interface subroutine found(cumfrq, allele) double precision, dimension(:), intent(in) :: cumfrq integer, intent(out) :: allele end subroutine subroutine genoff(idx, fa, mo, set) integer, intent(in) :: idx integer, intent(in) :: fa integer, intent(in) :: mo integer, dimension(:,:), intent(in out) :: set end subroutine subroutine gencopy(idx, origin, set) integer, intent(in) :: idx integer, intent(in) :: origin integer, dimension(:,:), intent(inout) :: set end subroutine gencopy end interface pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset do i=1, dataset%nfound(ped) call found(allele_buffer%cum_freqs, set(i,1)) if (dataset%sex(pedoffset+i) == 1) then set(i,2)=set(i,1) else call found(allele_buffer%cum_freqs, set(i,2)) call order(set(i,1),set(i,2)) end if end do do i=dataset%nfound(ped)+1, num set(i,1)=MISS set(i,2)=MISS end do do fin=.true. do i=dataset%nfound(ped)+1, num if (set(i,1) == MISS) then if (set(dataset%fa(pedoffset+i)-pedoffset,1) /= MISS .and. & set(dataset%mo(pedoffset+i)-pedoffset,1) /= MISS) then if (dataset%imztwin(pedoffset+i) /= MISS) then call gencopy(i, dataset%imztwin(pedoffset+i)-pedoffset, set) else if (dataset%sex(pedoffset+i) == 1) then if (random() > 0.5) then set(i,1)=set(dataset%mo(pedoffset+i)-pedoffset, 1) else set(i,1)=set(dataset%mo(pedoffset+i)-pedoffset, 2) end if set(i,2)=set(i,1) else call genoff(i, dataset%fa(pedoffset+i)-pedoffset, & dataset%mo(pedoffset+i)-pedoffset, set) end if else fin=.false. end if end if end do if (fin) exit end do end subroutine xsimped ! ! Simulate (gene-dropping) genotypes at a single codominant locus ! Conditioning on typed ``founder'' genotypes (true founders/marry-ins ! plus individuals without typed parents) heading informative ! chains of descent ! subroutine csimped(ped, dataset, untyped, set, xlinkd) use ped_class integer, intent(in) :: ped type (ped_data) :: dataset logical, dimension(:), intent(in) :: untyped integer, dimension(:,:), intent(inout) :: set logical, intent(in) :: xlinkd ! integer, parameter :: MISS=-9999 integer :: first, i, last logical :: fin interface subroutine genoff(idx, fa, mo, set) integer, intent(in) :: idx integer, intent(in) :: fa integer, intent(in) :: mo integer, dimension(:,:), intent(in out) :: set end subroutine genoff subroutine mumson(idx, mo, set) integer, intent(in) :: idx integer, intent(in) :: mo integer, dimension(:,:), intent(inout) :: set end subroutine mumson subroutine gencopy(idx, origin, set) integer, intent(in) :: idx integer, intent(in) :: origin integer, dimension(:,:), intent(inout) :: set end subroutine gencopy end interface first=dataset%num(ped-1)+dataset%nfound(ped)+1 last=dataset%num(ped) do i=first, last if (.not.untyped(dataset%fa(i)) .and. & .not.untyped(dataset%mo(i))) then set(i,1)=MISS set(i,2)=MISS end if end do ! ! Main loop -- only update individuals with two typed parents ! iter=0 do iter=iter+1 fin=.true. do i=first, last if (set(i,1) == MISS .and. .not.untyped(dataset%fa(i)) .and. & .not.untyped(dataset%mo(i))) then if (set(dataset%fa(i),1) /= MISS .and. set(dataset%mo(i),1) /= MISS) then if (dataset%imztwin(i) /= MISS) then call gencopy(i, dataset%imztwin(i), set) else if (xlinkd .and. dataset%sex(i) == 1) then call mumson(i, dataset%mo(i), set) else call genoff(i, dataset%fa(i), dataset%mo(i), set) end if else fin=.false. end if end if end do if (fin) exit end do end subroutine csimped ! ! transmit genes from parents to child ! subroutine genoff(idx, fa, mo, set) use rngs integer, intent(in) :: idx integer, intent(in) :: fa integer, intent(in) :: mo integer, dimension(:,:), intent(in out) :: set integer :: a1,a2 if (random() > 0.5) then a1=set(fa,1) else a1=set(fa,2) end if if (random() > 0.5) then a2=set(mo,1) else a2=set(mo,2) end if if (a1 > a2) then set(idx,1)=a2 set(idx,2)=a1 else set(idx,1)=a1 set(idx,2)=a2 end if end subroutine genoff ! ! Transmit single X-linked allele from mother to son ! subroutine mumson(idx, mo, set) use rngs integer, intent(in) :: idx integer, intent(in) :: mo integer, dimension(:,:), intent(inout) :: set if (random() > 0.5) then set(idx,1)=set(mo,1) else set(idx,1)=set(mo,2) end if set(idx,2)=set(idx,1) end subroutine mumson ! ! Copy genotype from MZ cotwin to ego ! subroutine gencopy(idx, origin, set) integer, intent(in) :: idx integer, intent(in) :: origin integer, dimension(:,:), intent(inout) :: set set(idx,1:2)=set(origin,1:2) end subroutine gencopy ! ! Simulate Y or mitochondrial haplotypes ! subroutine simhaploid(typ, ped, dataset, nhaps, cumhaps, hval) use ped_class integer, intent(in) :: typ, ped type (ped_data) :: dataset integer, intent(in) :: nhaps double precision, dimension(nhaps), intent(in) :: cumhaps integer, dimension(dataset%nobs), intent(inout) :: hval integer, parameter :: MISS=-9999 integer :: i, pedoffset interface subroutine found(cumfrq, allele) double precision, dimension(:), intent(in) :: cumfrq integer, intent(out) :: allele end subroutine end interface pedoffset=dataset%num(ped-1) do i=pedoffset+1, pedoffset+dataset%nfound(ped) if (hval(i) /= MISS) then call found(cumhaps, hval(i)) end if end do do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped) if (hval(dataset%mo(i)) /= MISS .and. hval(i) /= MISS) then hval(i)=hval(dataset%mo(i)) end if end do end subroutine simhaploid ! ! Simulate pedigree conditional on all founders (all must be typed) and ! typed nonfounders ! subroutine fsimped(it, pedigree, num, nfound, id, fa, mo, imztwin, set, sibd, & untyped, key, plevel) use outstream use ped_class use rngs integer, intent(in) :: it character (len=ped_width), intent(in out) :: pedigree integer, intent(in) :: num, nfound character (len=id_width), dimension(:), intent(in out) :: id integer, dimension(:), intent(in out) :: fa, mo, imztwin integer, dimension(:,:), intent(inout) :: set integer, dimension(:,:), intent(out) :: sibd logical, dimension(:), intent(in out) :: untyped integer, dimension(:), intent(out) :: key integer, intent(in) :: plevel ! local variables integer, parameter :: MISS=-9999 integer :: found, i, failid, maxtry, nonf, pos, restart integer, dimension(num-nfound) :: ord logical :: fin interface subroutine simibd(typ, pedigree, num, nfound, fa, mo, imztwin, set, sibd) use ped_class integer, intent(in) :: typ character (len=ped_width), intent(in) :: pedigree integer, intent(in) :: num, nfound integer, dimension(:), intent(in) :: fa, mo, imztwin integer, dimension(:,:), intent(in) :: set integer, dimension(:,:), intent(out) :: sibd end subroutine subroutine genof4(idx, fa, mo, imztwin, set, sibd, untyped, key, failid) integer, intent(in) :: idx, fa, mo, imztwin integer, dimension(:,:), intent(in) :: set integer, dimension(:,:), intent(in out) :: sibd logical, dimension(:), intent(in out) :: untyped integer, dimension(:), intent(inout) :: key integer, intent(out) :: failid end subroutine subroutine fill2(num, set, sibd, untyped, key) integer, intent(in) :: num integer, dimension(:,:), intent(out) :: set integer, dimension(:,:), intent(in out) :: sibd logical, dimension(:), intent(in out) :: untyped integer, dimension(:), intent(in out) :: key end subroutine end interface maxtry=2000 found=0 do i=1, nfound found=found+1 sibd(i,1)=found key(found)=set(i,1) found=found+1 sibd(i,2)=found key(found)=set(i,2) end do nonf=num-nfound do i=1, nonf ord(i)=nfound+i end do ! ! start of loop -- terminated by either a successful simulation ! of ibd & genotypes of nonfounders, or bailout due <maxtry> iterations ! without success ! restart=0 999 continue found=0 do i=1, nfound if (untyped(i)) then key(found+1)=-set(i,1) key(found+2)=-set(i,2) end if found=found+2 end do do i=nfound+1, num sibd(i,1)=MISS sibd(i,2)=MISS end do do fin=.true. call permut(nonf, ord) do pos=1, nonf i=ord(pos) if (sibd(i,1) == MISS) then if (sibd(fa(i),1) /= MISS .and. sibd(mo(i),1) /= MISS) then call genof4(i, fa(i), mo(i), imztwin(i), set, sibd, untyped, key, failid) if (failid /= MISS) then if (restart < maxtry) then restart=restart+1 go to 999 else if (plevel > 0) then write(outstr,'(/a,i4,a/7x,a,a8,2a/)') & 'NOTE: In iteration ', it, & ' of the Metropolis algorithm,', & 'simulation of ibd had to restart due to individual ', & trim(id(failid)), ' in pedigree ', pedigree if (plevel > 1) then do j=1, nfound write(outstr,'(a10,a,2(1x,i3),a,2(1x,i3),a,l1)') & id(j), ' x x', set(j,1), set(j,2), & ' {', sibd(j,1),sibd(j,2), '} ', untyped(j) end do do j=nfound+1, num write(outstr,'(3a10,2(1x,i3),a,2(1x,i3),a,l1)') & id(j), id(fa(j)), id(mo(j)), set(j,1), set(j,2), & ' {', sibd(j,1), sibd(j,2), '} ', untyped(j) end do end if end if call simibd(2, pedigree, num, nfound, fa, mo, imztwin, set, sibd) return end if end if else fin=.false. end if end if end do if (fin) exit end do call fill2(num, set, sibd, untyped, key) end subroutine fsimped ! ! Drop ibd-alleles conditional on observed markers ! and randomly where marker genotype not observed -- restart ! if later generates inconsistency ! This version assumes all founders are typed ! subroutine genof4(idx, fa, mo, imztwin, set, sibd, untyped, key, failid) use rngs integer, intent(in) :: idx, fa, mo, imztwin integer, dimension(:,:), intent(in) :: set integer, dimension(:,:), intent(in out) :: sibd logical, dimension(:), intent(in out) :: untyped integer, dimension(:), intent(inout) :: key integer, intent(out) :: failid integer, parameter :: KNOWN=0, MISS=-9999 integer :: a1,a2,first,maxtrials, second, tr1,tr2,trials ! sample without replacement from {{1,2},{1,2}} integer :: choice, i, seed, sspace(4) failid=MISS if (imztwin /= MISS) then sibd(idx,1:2)=sibd(imztwin,1:2) return end if maxtrials=4 trials=0 do i=1, maxtrials sspace(i)=i end do 1 continue trials=trials+1 choice=irandom(trials, maxtrials) seed=sspace(choice) sspace(choice)=sspace(trials) tr2=iand(seed,2)/2+1 tr1=iand(seed,1)+1 a1=sibd(fa,tr1) a2=sibd(mo,tr2) ! write(*,*) 'In GENOF4():' ! write(*,*) 'Alleles: ',key(1),key(2),key(3),key(4),key(5),key(6) ! write(*,*) 'Person #',idx,set(idx,1),'/',set(idx,2), ! & ' Untyped: ',untyped(idx) ! write(*,*) 'Father #',fa, set(fa,1),'/',set(fa,2), ! & ' Untyped: ',untyped(fa) ! write(*,*) 'Mother #',mo, set(mo,1),'/',set(mo,2), ! & ' Untyped: ',untyped(mo) ! write(*,*) 'Transmitting: ',a1,' [',key(a1),' ], ', ! & a2,' [',key(a2),' ]' ! if (untyped(idx)) then sibd(idx,1)=a1 sibd(idx,2)=a2 else if (key(a1) < KNOWN .and. key(a2) < KNOWN) then first=irandom(1,2) second=3-first sibd(idx,first)=a1 sibd(idx,second)=a2 key(a1)=set(idx,first) key(a2)=set(idx,second) else if (key(a1) < KNOWN .and. set(idx,1) == key(a2)) then sibd(idx,1)=a2 sibd(idx,2)=a1 key(a1)=set(idx,2) else if (key(a1) < KNOWN .and. set(idx,2) == key(a2)) then sibd(idx,1)=a1 sibd(idx,2)=a2 key(a1)=set(idx,1) else if (key(a2) < KNOWN .and. set(idx,2) == key(a1)) then sibd(idx,1)=a2 sibd(idx,2)=a1 key(a2)=set(idx,1) else if (key(a2) < KNOWN .and. set(idx,1) == key(a1)) then sibd(idx,1)=a1 sibd(idx,2)=a2 key(a2)=set(idx,2) else if (set(idx,1) == key(a1) .and. set(idx,2) == key(a2)) then sibd(idx,1)=a1 sibd(idx,2)=a2 else if (set(idx,1) == key(a2) .and. set(idx,2) == key(a1)) then sibd(idx,1)=a2 sibd(idx,2)=a1 else if (trials < maxtrials) then go to 1 else failid=idx end if end subroutine genof4 ! ! infer missing genotypes based on sibd values after run of fsimped ! assume all founders are typed ! subroutine fill2(num, set, sibd, untyped, key) integer, intent(in) :: num integer, dimension(:,:), intent(out) :: set integer, dimension(:,:), intent(in out) :: sibd logical, dimension(:), intent(in out) :: untyped integer, dimension(:), intent(in out) :: key ! local variables integer :: g1,g2,i,tmp do i=1, num if (untyped(i)) then g1=abs(key(sibd(i,1))) g2=abs(key(sibd(i,2))) if (g1 > g2) then tmp=g1 g1=g2 g2=tmp tmp=sibd(i,1) sibd(i,1)=sibd(i,2) sibd(i,2)=tmp end if set(i,1)=g1 set(i,2)=g2 end if end do end subroutine fill2 ! ! Simulate a single marker consistent with ibd sharing at a target marker locus ! If there are missing genotypes, call should be preceded by call to newstart() ! subroutine cisimped(ped, gene, allele_buffer, allele_buffer2, dataset, set) use alleles_class use ped_class implicit none integer, intent(in) :: ped ! pedigree to simulate integer, intent(in) :: gene ! position of marker conditioned on type (allele_data), intent(in) :: allele_buffer ! marker to be simulated type (allele_data), intent(in) :: allele_buffer2 ! marker to condition ibd on type (ped_data) :: dataset ! all the observed data integer, dimension(:,:), intent(out) :: set ! the new simulated marker integer, parameter :: KNOWN=0, MISS=-9999 integer, dimension(dataset%maxsiz, 2) :: sibd ! ibd indicator integer, dimension(2*dataset%maxsiz) :: key ! the simulated founder alleles integer :: a1, a2, gen2, i, ii, mark2, num, nuntyp, pedoffset ! functions integer :: getnam interface subroutine found(cumfrq, allele) double precision, dimension(:), intent(in) :: cumfrq integer, intent(out) :: allele end subroutine found subroutine pedibd(typ, ped, dataset, set, sibd) use ped_class implicit none integer, intent(in) :: typ integer, intent(in) :: ped type (ped_data), intent(in) :: dataset integer, dimension(:,:), intent(in) :: set integer, dimension(:,:), intent(in out) :: sibd end subroutine pedibd end interface ! gen2=gene+1 pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset ! Conditional on ibd at gene call loadset(gene, ped, allele_buffer2, dataset, set, nuntyp) call pedibd(2, ped, dataset, set, sibd) ! simulate based on given allele frequencies, ibd and missingness do i=1, 2*dataset%nfound(ped) call found(allele_buffer%cum_freqs, key(i)) end do do i=1, num a1=key(sibd(i,1)) a2=key(sibd(i,2)) call order(a1, a2) set(i,1)=a1 set(i,2)=a2 end do end subroutine cisimped ! ! Sample with or without replacement from the trait values within an entire pedigree ! subroutine sample(trait, ped, dataset, typ) use ped_class use rngs implicit none integer, intent(in) :: trait integer, intent(in) :: ped type (ped_data) :: dataset integer, intent(in) :: typ ! integer, parameter :: MISS=-9999 integer :: i, j, pedoffset integer :: nchoice integer, dimension(:), allocatable :: choice double precision, dimension(:), allocatable :: chooseset ! functions interface subroutine ascend(n, ia) integer, intent(in) :: n integer, dimension(:), intent(inout) :: ia end subroutine end interface nchoice=0 pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) if (dataset%plocus(i, trait) /= MISS) then nchoice=nchoice+1 end if end do if (nchoice > 0) then allocate(chooseset(nchoice)) nchoice=0 do i=pedoffset+1, dataset%num(ped) if (dataset%plocus(i, trait) /= MISS) then nchoice=nchoice+1 chooseset(nchoice)=dataset%plocus(i,trait) end if end do if (typ==1) then do i=pedoffset+1, dataset%num(ped) dataset%plocus(i,trait)=chooseset(irandom(1,nchoice)) end do else if (typ==2) then j=0 allocate(choice(nchoice)) call ascend(nchoice, choice) call permut(nchoice, choice) do i=pedoffset+1, dataset%num(ped) if (dataset%plocus(i,trait) /= MISS) then j=j+1 dataset%plocus(i,trait)=chooseset(choice(j)) end if end do end if end if end subroutine sample ! ! Modified random walk simulation (one iteration) of pedigree missing ! genotypes (Metropolis-Hastings algorithm) -- proposal uses founder ! allele mutations propagated throughout then pedigree conditional ! on (identity by) descent, swapping ibd origins for heterozygotes, ! alternated with a randomization of descent conditional on marker ! genotype. This procedure has the advantage of being quick, ! but the proposal probabilities are not always symmetric, so they ! are combined with additional local proposals ! ! It is alternated with a locally updating Gibbs sampler. This jointly ! simulates Untyped x Untyped founder matings genotypes conditional on ! offspring and other spouses; other genotypes individual-by-individual, ! conditional on parental, spouse and child genotypes. ! ! set and sibd (set2 and sibd2) are genotypes for current pedigree only ! only fa and mo need to be redirected ! ! subroutine drop(it, ped, dataset, cntmat, numal, gfrq, & set, sibd, set2, key, iprop, plevel) use outstream use pairlist_class use ped_class use rngs implicit none integer, intent(in) :: it integer, intent(in) :: ped type (ped_data) :: dataset ! number of untyped matings -- used to decide number and type of mutations type (pairlist_data), intent(inout) :: cntmat integer, intent(in) :: numal double precision, dimension(numal*(numal+1)/2) :: gfrq integer, dimension(:,:), intent(inout), target :: set, sibd ! proposal and work array integer, dimension(:,:), intent(inout) :: set2 integer, dimension(:), intent(inout) :: key integer, intent(out) :: iprop integer, intent(in) :: plevel ! ! local variables ! copy of current pedigree integer :: nfound, num, pedoffset character (len=id_width), dimension(dataset%maxsiz) :: id integer, dimension(dataset%maxsiz) :: fa, mo, imztwin logical, dimension(dataset%maxsiz) :: untyped ! integer :: gibbsit, gprop, i, j, mat, par1, par2 logical :: xmale double precision :: lr, qa ! functions integer :: parcon interface subroutine fsimped(it, pedigree, num, nfound, id, fa, mo, imztwin, set, sibd, & untyped, key, plevel) use ped_class integer, intent(in) :: it character (len=ped_width), intent(in out) :: pedigree integer, intent(in) :: num, nfound character (len=id_width), dimension(:), intent(in out) :: id integer, dimension(:), intent(in out) :: fa, mo, imztwin integer, dimension(:,:), intent(inout) :: set integer, dimension(:,:), intent(out) :: sibd logical, dimension(:), intent(in out) :: untyped integer, dimension(:), intent(out) :: key integer, intent(in) :: plevel end subroutine fsimped subroutine simibd(typ, pedigree, num, nfound, fa, mo, imztwin, set, sibd) use idstring_widths integer, intent(in) :: typ character (len=ped_width), intent(in) :: pedigree integer, intent(in) :: num, nfound integer, dimension(:), intent(in) :: fa, mo, imztwin integer, dimension(:,:), intent(in) :: set integer, dimension(:,:), intent(out) :: sibd end subroutine simibd subroutine mutate(numal, num, nfound, set, sibd, set2, untyped) integer, intent(in) :: numal integer, intent(in) :: num integer, intent(in) :: nfound integer, dimension(:,:), intent(in) :: set integer, dimension(:,:), intent(in out) :: sibd integer, dimension(:,:), intent(inout) :: set2 logical, dimension(:), intent(inout) :: untyped end subroutine mutate subroutine switch(num,nfound,id,fa,mo,set,sibd,set2,untyped) use idstring_widths integer, intent(in) :: num integer, intent(in) :: nfound character (len=id_width), dimension(:), intent(in out) :: id integer, dimension(:), intent(in) :: fa, mo integer, dimension(:,:), intent(in) :: set integer, dimension(:,:), intent(in out) :: sibd integer, dimension(:,:), intent(out) :: set2 logical, dimension(:), intent(in) :: untyped end subroutine switch subroutine simnuc(par1, par2, num, nfound, fa, mo, numal, gfrq, set) implicit none integer, intent(in) :: par1, par2 integer, intent(in) :: num, nfound integer, dimension(:), intent(in) :: fa, mo integer, intent(in) :: numal double precision, dimension(:), intent(in) :: gfrq integer, dimension(:,:), intent(inout) :: set end subroutine simnuc subroutine simpar(par1, par2, numal, num, nfound, fa, mo, set) integer, intent(in) :: par1, par2 integer, intent(in) :: numal integer, intent(in) :: num integer, intent(in) :: nfound integer, dimension(:), intent(in) :: fa, mo integer, dimension(:,:), intent(inout) :: set end subroutine simpar end interface ! ! local copy of pedigree -- pointers to structure components not allowed ! pedoffset=dataset%num(ped-1) nfound=dataset%nfound(ped) num=dataset%num(ped)-pedoffset do i=1, num id(i)=dataset%id(pedoffset+i) untyped(i)=dataset%untyped(pedoffset+i) end do call workpointers(ped, dataset, fa, mo, imztwin) ! gibbsit=5 xmale=.false. iprop=irandom(1,60) if (iprop > 4) iprop=4 ! Metropolis multisite proposals if (iprop <= 3) then ! Do ibd dropping if (iprop == 1) then do i=1, num set2(i,1)=set(i,1) set2(i,2)=set(i,2) end do call fsimped(it, dataset%pedigree(ped), num, nfound, id, & fa, mo, imztwin, set2, sibd, untyped, key, plevel) ! Or mutate founder allele(s) else if (iprop == 2) then call simibd(2, dataset%pedigree(ped), num, nfound, fa, mo, imztwin, set, sibd) call mutate(numal, num, nfound, set, sibd, set2, untyped) ! Or switch parents of origin else call simibd(2, dataset%pedigree(ped), num, nfound, fa, mo, imztwin, set, sibd) call switch(num, nfound, id, fa, mo, set, sibd, set2, untyped) end if ! Further shuffle genotypes -- here untyped founder matings do mat=1, cntmat%npairs par1=cntmat%pairs(mat,1)-pedoffset par2=cntmat%pairs(mat,2)-pedoffset call simpar(par1, par2, numal, num, nfound, fa, mo, set) end do ! ! now check if the proposal is an acceptable one ! if (plevel > 2) then do i=1, num write(outstr,*) it, ' ', id(i), set(i,1), set(i,2), ' -> ', & set2(i,1), set2(i,2), ' {', sibd(i,1), sibd(i,2),' }' end do end if lr=1.0d0 do i=1, nfound if (untyped(i)) then lr=lr*gfrq(set2(i,2)*(set2(i,2)-1)/2+set2(i,1))/ & gfrq(set(i,2)*(set(i,2)-1)/2+set(i,1)) end if end do do i=nfound+1, num par2=parcon(set2(i,1), set2(i,2), & set2(fa(i),1), set2(fa(i),2), & set2(mo(i),1), set2(mo(i),2), xmale) par1=parcon(set(i,1), set(i,2), & set(fa(i),1), set(fa(i),2), & set(mo(i),1), set(mo(i),2), xmale) if (par1 /= par2) then lr=lr*dble(par2)/dble(par1) end if end do qa=min(1.0d0,lr) ! ! If accepted, update genotypes ! if (qa > random()) then if (plevel > 2) then write(outstr,'(a,i1,a,f12.4)') 'Proposal type ',iprop,' accepted ',lr end if do i=1, num if (untyped(i)) then set(i,1)=set2(i,1) set(i,2)=set2(i,2) end if end do else if (plevel > 2) then write(outstr,'(a,i1,a,f12.4)') 'Proposal type ',iprop,' rejected ',lr end if iprop=-iprop end if end if ! ! now local updating via Gibbs sampler ! gprop=0 do mat=1, cntmat%npairs gprop=gprop+1 key(gprop)=dataset%maxsiz+mat end do do i=1, num if (untyped(i)) then gprop=gprop+1 key(gprop)=i end if end do call permut(gprop, key) do j=1, gibbsit do i=1, gprop if (key(i) > dataset%maxsiz) then ! Untyped x untyped founder mating update mat=key(i)-dataset%maxsiz par1=cntmat%pairs(mat,1)-pedoffset par2=cntmat%pairs(mat,2)-pedoffset call simnuc(par1, par2, num, nfound, fa, mo, numal, gfrq, set) else ! individual update call simnuc(key(i), key(i), num, nfound, fa, mo, numal, gfrq, set) end if end do end do call simibd(2, dataset%pedigree(ped), num, nfound, fa, mo, imztwin, set, sibd) if (plevel > 1) then write(outstr,'(a,i6)') 'Simulated missing genotypes for iteration ',it do i=1, num if (untyped(i)) then write(outstr,'(i5,1x,a,2(1x,i3))') & it, trim(dataset%pedigree(ped)) // '--' // trim(id(i)), set(i,1), set(i,2) end if end do end if end subroutine drop ! ! Gibbs sampler for codominant marker locus ! Simulate parental genotypes for untyped x untyped ! mating conditional on offspring genotypes ! or for untyped nonfounders conditional on offspring, spouses ! and parents. Family may be contained within larger pedigree, and ! multiple spouses are possible ! subroutine simnuc(par1, par2, num, nfound, fa, mo, numal, gfrq, set) use rngs implicit none integer, intent(in) :: par1, par2 integer, intent(in) :: num, nfound integer, dimension(:), intent(in) :: fa, mo integer, intent(in) :: numal double precision, dimension(:), intent(in) :: gfrq integer, dimension(:,:), intent(inout) :: set ! local variables integer, parameter :: MISS=-9999 integer :: fin, i, sta double precision :: targt ! functions interface subroutine nuclik(par1, par2, sta, fin, fa, mo, numal, gfrq, set, targt) integer, intent(in) :: par1 integer, intent(in) :: par2 integer, intent(in) :: sta integer, intent(in) :: fin integer, dimension(:), intent(in) :: fa, mo integer, intent(in) :: numal double precision, intent(in) :: gfrq(numal*(numal+1)/2) integer, dimension(:,:), intent(inout) :: set double precision, intent(inout) :: targt end subroutine subroutine foulik(idx, fa, mo, sta, fin, numal, gfrq, set, targt) integer, intent(in) :: idx integer, dimension(:), intent(in) :: fa, mo integer, intent(in) :: sta, fin integer, intent(in) :: numal double precision, dimension(numal*(numal+1)/2), intent(in) :: gfrq integer, dimension(:,:), intent(inout) :: set double precision, intent(inout) :: targt end subroutine subroutine onelik(idx, fa, mo, sta, fin, set, targt) integer, intent(in) :: idx integer, dimension(:), intent(in) :: fa, mo integer, intent(in) :: sta, fin integer, dimension(:,:), intent(inout) :: set double precision, intent(inout) :: targt end subroutine end interface sta=MISS fin=MISS do i=nfound+1, num if (par1 == fa(i) .or. par2 == mo(i)) then if (sta == MISS) then sta=i fin=i else if (i > fin) then fin=i end if end if end do if (par1 /= par2) then targt=1.0d0 call nuclik(par1, par2, sta, fin, fa, mo, numal, gfrq, set, targt) targt=dble(random())*targt call nuclik(par1, par2, sta, fin, fa, mo, numal, gfrq, set, targt) else if (par1 <= nfound) then targt=1.0d0 call foulik(par1, fa, mo, sta, fin, numal, gfrq, set, targt) targt=dble(random())*targt call foulik(par1, fa, mo, sta, fin, numal, gfrq, set, targt) else targt=1.0d0 call onelik(par1, fa, mo, sta, fin, set, targt) targt=dble(random())*targt call onelik(par1, fa, mo, sta, fin, set, targt) end if end subroutine simnuc ! ! Nuclik is run twice, once to calculate the total likelihood <totlik> of the ! legal genotypes (with target=1), the second time to select a ! parental genotypes with target ~ U(0,totlik). ! subroutine nuclik(par1, par2, sta, fin, fa, mo, numal, gfrq, set, targt) integer, intent(in) :: par1 integer, intent(in) :: par2 integer, intent(in) :: sta integer, intent(in) :: fin integer, dimension(:), intent(in) :: fa, mo integer, intent(in) :: numal double precision, intent(in) :: gfrq(numal*(numal+1)/2) integer, dimension(:,:), intent(inout) :: set double precision, intent(inout) :: targt integer :: g1, g2, mg1, mg2, pg1, pg2 ! genotype frequencies structure ! local variables integer :: con, i logical :: fullcon, xmale double precision :: lik, totlik ! functions integer :: parcon xmale=.false. totlik=0.0d0 g1=0 do mg2=1, numal do mg1=1, mg2 g1=g1+1 lik=gfrq(g1) g2=0 do pg2=1, numal do pg1=1, pg2 g2=g2+1 lik=gfrq(g1)*gfrq(g2) set(par1,1)=pg1 set(par1,2)=pg2 set(par2,1)=mg1 set(par2,2)=mg2 fullcon=.true. do i=sta, fin con=parcon(set(i,1), set(i,2), set(fa(i),1), set(fa(i),2), & set(mo(i),1), set(mo(i),2), xmale) if ((par1 == fa(i) .or. par2 == mo(i)) .and. con == 0) then fullcon=.false. exit end if lik=lik*0.25d0*dble(con) end do ! ! else (if consistent) add to legal genotypes if (fullcon) then totlik=totlik+lik ! ! check to see if have selected current parental genotypes ! if (totlik >= targt) return end if end do end do end do end do targt=totlik end subroutine nuclik ! ! Founder codominant locus conditional likelihood ! foulik is run twice, once to calculate the total likelihood <totlik> of the ! legal genotypes (with target=1), the second time to select a genotype, ! with target ~ U(0,totlik). ! subroutine foulik(idx, fa, mo, sta, fin, numal, gfrq, set, targt) integer, intent(in) :: idx integer, dimension(:), intent(in) :: fa, mo integer, intent(in) :: sta, fin integer, intent(in) :: numal double precision, dimension(numal*(numal+1)/2), intent(in) :: gfrq integer, dimension(:,:), intent(inout) :: set double precision, intent(inout) :: targt ! local variables integer, parameter :: MISS=-9999 integer :: con, g1, g2, ng, i logical :: fullcon, xmale double precision :: lik, totlik ! functions integer :: parcon xmale=.false. fullcon=.false. totlik=0.0d0 ng=0 do g1=1, numal do g2=1, g1 ng=ng+1 lik=gfrq(ng) set(idx,1)=g2 set(idx,2)=g1 if (sta /= MISS) then fullcon=.true. do i=sta, fin con=parcon(set(i,1),set(i,2),set(fa(i),1),set(fa(i),2), & set(mo(i),1),set(mo(i),2),xmale) if ((idx == fa(i) .or. idx == mo(i)) .and. con == 0) then fullcon=.false. exit end if lik=lik*0.25d0*dble(con) end do end if ! exit if target reached if (fullcon) then totlik=totlik+lik if (totlik >= targt) return end if end do end do targt=totlik end subroutine foulik ! ! nonfounder codominant locus conditional likelihood ! onelik is run twice, once to calculate the total likelihood <totlik> of the ! legal genotypes (with target=1), the second time to select a genotype, ! with target ~ U(0,totlik). ! subroutine onelik(idx, fa, mo, sta, fin, set, targt) integer, intent(in) :: idx integer, dimension(:), intent(in) :: fa, mo integer, intent(in) :: sta, fin integer, dimension(:,:), intent(inout) :: set double precision, intent(inout) :: targt ! local variables integer, parameter :: MISS=-9999 integer :: con, g1, g2, i, i1, i2 logical :: fullcon, xmale double precision :: lik, totlik ! functions integer :: parcon xmale=.false. totlik=0.0d0 do i1=1, 2 do i2=1, 2 fullcon=.true. lik=0.25d0 g1=set(fa(idx),i1) g2=set(mo(idx),i2) call order(g1,g2) set(idx,1)=g1 set(idx,2)=g2 if (sta /= MISS) then do i=sta, fin con=parcon(set(i,1),set(i,2),set(fa(i),1),set(fa(i),2), & set(mo(i),1),set(mo(i),2),xmale) if ((idx == fa(i) .or. idx == mo(i)) .and. con == 0) then fullcon=.false. exit end if lik=lik*0.25d0*dble(con) end do end if ! exit if target reached if (fullcon) then totlik=totlik+lik if (totlik >= targt) return end if end do end do targt=totlik end subroutine onelik ! ! Propose parental genotypes for untyped x untyped ! mating conditional on offspring genotypes ! Family may be contained within larger pedigree, and ! multiple spouses are possible ! subroutine simpar(par1, par2, numal, num, nfound, fa, mo, set) use rngs integer, intent(in) :: par1, par2 integer, intent(in) :: numal integer, intent(in) :: num integer, intent(in) :: nfound integer, dimension(:), intent(in) :: fa, mo integer, dimension(:,:), intent(inout) :: set ! local variables integer, parameter :: MISS=-9999 integer :: fin, i, sta integer :: targt, totp ! functions interface subroutine inuclik(par1, par2, sta, fin, numal, fa, mo, set, targt, totp) integer, intent(in) :: par1, par2 integer, intent(in) :: sta, fin integer, intent(in) :: numal integer, dimension(:), intent(in) :: fa, mo integer, dimension(:,:), intent(inout) :: set integer, intent(in out) :: targt integer, intent(out) :: totp end subroutine end interface sta=MISS fin=MISS do i=nfound+1, num if (par1 == fa(i) .or. par2 == mo(i)) then if (sta == MISS) then sta=i fin=i else if (i > fin) then fin=i end if end if end do targt=numal*numal*(numal+1)*(numal+1)/4 call inuclik(par1, par2, sta, fin, numal, fa, mo, set, targt, totp) targt=irandom(1,totp) call inuclik(par1, par2, sta, fin, numal, fa, mo, set, targt, totp) end subroutine simpar ! ! inuclik is an integer version of nuclik ! inuclik is run twice, once to calculate the total number <totp> of the ! legal genotypes (with target=MAXG*MAXG), the second time to select a ! parental genotype. ! subroutine inuclik(par1, par2, sta, fin, numal, fa, mo, set, targt, totp) integer, intent(in) :: par1, par2 integer, intent(in) :: sta, fin integer, intent(in) :: numal integer, dimension(:), intent(in) :: fa, mo integer, dimension(:,:), intent(inout) :: set integer, intent(in out) :: targt integer, intent(out) :: totp ! local variables integer :: mg1, mg2, pg1, pg2 integer :: con, i logical :: fullcon, xmale ! functions integer :: parcon xmale=.false. totp=0 do mg2=1,numal do mg1=1,mg2 do pg2=1,numal do pg1=1,pg2 set(par1,1)=pg1 set(par1,2)=pg2 set(par2,1)=mg1 set(par2,2)=mg2 fullcon=.true. do i=sta,fin con=parcon(set(i,1),set(i,2),set(fa(i),1),set(fa(i),2), & set(mo(i),1),set(mo(i),2),xmale) if ((par1 == fa(i) .or. par2 == mo(i)) .and. con == 0) then fullcon=.false. exit end if end do ! else (if consistent) add to legal genotypes if (fullcon) then totp=totp+1 ! check to see if have selected current parental genotypes if (totp == targt) return end if end do end do end do end do end subroutine inuclik ! ! Mutate 1-4 allele in untyped founders. Can never fail, due "backmutation". ! ! (1) mutate an allele never transmitted to a typed individual ! (2) swap parent of origin if have no offspring sharing ibd-allele ! subroutine mutate(numal, num, nfound, set, sibd, set2, untyped) use rngs integer, intent(in) :: numal integer, intent(in) :: num, nfound integer, dimension(:,:), intent(in) :: set integer, dimension(:,:), intent(inout) :: sibd integer, dimension(:,:), intent(inout) :: set2 logical, dimension(:), intent(inout) :: untyped ! mut designates ibd-allele, prop the corresponding marker allele integer :: nmut integer :: mut(4), prop(4) integer :: g1,g2,i,j ! functions interface subroutine update(idx, all1, all2, set) integer, intent(in) :: idx integer, intent(in) :: all1 integer, intent(in) :: all2 integer, dimension(:,:), intent(inout) :: set end subroutine end interface 1 continue nmut=irandom(1,4) do j=1, nmut mut(j)=irandom(1,2*nfound) prop(j)=irandom(1,numal) end do do i=1, num g1=set(i,1) g2=set(i,2) do j=1, nmut if (sibd(i,1) == mut(j)) g1=prop(j) if (sibd(i,2) == mut(j)) g2=prop(j) end do call order(g1,g2) ! midloop break if (.not.untyped(i) .and. (set(i,1) /= g1 .or. set(i,2) /= g2)) then go to 1 end if call update(i, g1, g2, set2) end do end subroutine mutate ! ! Do a switch of grandparent of origin of alleles = switch lineage ! subroutine switch(num, nfound, id, fa, mo, set, sibd, set2, untyped) use idstring_widths use rngs integer, intent(in) :: num integer, intent(in) :: nfound character (len=id_width), dimension(:), intent(in out) :: id integer, dimension(:), intent(in) :: fa, mo integer, dimension(:,:), intent(in) :: set integer, dimension(:,:), intent(inout) :: sibd integer, dimension(:,:), intent(out) :: set2 logical, dimension(:), intent(in) :: untyped integer, parameter :: KNOWN=0, MISS=-9999 integer :: g(2), i, idx, ntrials, par logical :: fin, xmale ! functions integer :: parcon interface subroutine cpibd(i, j, sibd, sibd2, imiss) integer, intent(in) :: i, j integer, dimension(:,:), intent(in) :: sibd integer, dimension(:,:), intent(inout) :: sibd2 integer, intent(in) :: imiss end subroutine end interface xmale=.false. ntrials=0 1 continue ntrials=ntrials+1 ! ! give up if <num> unsuccessful trials if (ntrials > num) then do i=1, num set2(i,1)=set(i,1) set2(i,2)=set(i,2) end do return end if ! ! provide a heterozygote candidate with both parents untyped idx=irandom(nfound+1,num) if (set(idx,1) == set(idx,2) .or. & .not.untyped(fa(idx)) .or. .not.untyped(mo(idx))) then go to 1 end if do i=1, num set2(i,1)=MISS set2(i,2)=MISS end do g(2)=set(idx,1) g(1)=set(idx,2) set2(idx,1)=1 set2(idx,2)=2 ! ! each iteration moves as far up the pedigree as possible 15 continue fin=.true. do i=nfound+1, num if (set2(i,1) /= MISS) then par=fa(i) if (set2(par,1) == MISS .and. untyped(par)) then call cpibd(par,i,sibd,set2,KNOWN) fin=.false. end if par=mo(i) if (set2(par,1) == MISS .and. untyped(par)) then call cpibd(par,i,sibd,set2,KNOWN) fin=.false. end if end if end do if (.not.fin) go to 15 ! ! See if reached one (loop) or two untyped founders, so swap feasible par=0 do i=1,nfound if (set2(i,1) > KNOWN .or. set2(i,2) > KNOWN) then par=par+1 end if end do ! write(*,*) 'idx=',id(idx), ' par=', par ! do 999 i=1,num ! write(*,*) id(i), ' ', set(i,1), set(i,2), ' -> ', ! & set2(i,1), set2(i,2), ' {',sibd(i,1),sibd(i,2),'}' ! 999 continue if (par == 0) then go to 1 end if ! ! swap appropriate alleles of simulated genotype ! do i=1, nfound if (set2(i,1) > KNOWN) set2(i,1)=g(set2(i,1)) if (set2(i,2) > KNOWN) set2(i,2)=g(set2(i,2)) if (set2(i,1) <= KNOWN) set2(i,1)=set(i,1) if (set2(i,2) <= KNOWN) set2(i,2)=set(i,2) call order(set2(i,1), set2(i,2)) end do do i= nfound+1, num if (set2(i,1) > KNOWN) set2(i,1)=g(set2(i,1)) if (set2(i,2) > KNOWN) set2(i,2)=g(set2(i,2)) if (set2(i,1) <= KNOWN) set2(i,1)=set(i,1) if (set2(i,2) <= KNOWN) set2(i,2)=set(i,2) call order(set2(i,1), set2(i,2)) if (parcon(set2(i,1), set2(i,2), & set2(fa(i),1), set2(fa(i),2), & set2(mo(i),1), set2(mo(i),2), xmale) == 0) then go to 1 end if end do end subroutine switch ! ! Copy ibd for a pair of relatives. ! Person j has a typing-genotype at sibd2, person i does not. ! The typing-allele corresponding to that shared at sibd() ! is "transmitted" to person i from person j. ! subroutine cpibd(i, j, sibd, sibd2, imiss) integer, intent(in) :: i, j integer, dimension(:,:), intent(in) :: sibd integer, dimension(:,:), intent(inout) :: sibd2 integer, intent(in) :: imiss integer, parameter :: MISS=-9999 if (sibd(i,1) == sibd(j,1)) then sibd2(i,1)=sibd2(j,1) end if if (sibd(i,1) == sibd(j,2)) then sibd2(i,1)=sibd2(j,2) end if if (sibd(i,2) == sibd(j,1)) then sibd2(i,2)=sibd2(j,1) end if if (sibd(i,2) == sibd(j,2)) then sibd2(i,2)=sibd2(j,2) end if if (sibd2(i,1) == MISS) sibd2(i,1)=imiss end subroutine cpibd ! ! update new genotype ! subroutine update(idx, all1, all2, set) integer, intent(in) :: idx integer, intent(in) :: all1 integer, intent(in) :: all2 integer, dimension(:,:), intent(inout) :: set if (all1 > all2) then set(idx,2)=all1 set(idx,1)=all2 else set(idx,1)=all1 set(idx,2)=all2 end if end subroutine update ! ! Given genotypes at a single locus in a pedigree of arbitrary complexity, ! generate ibd by gene dropping a perfectly informative marker a la ! John Blangero. ! Type=1 unconditional, =2, conditional on observed markers ! subroutine simibd(typ, pedigree, num, nfound, fa, mo, imztwin, set, sibd) use outstream use interrupt use idstring_widths integer, intent(in) :: typ character (len=ped_width), intent(in) :: pedigree integer, intent(in) :: num, nfound integer, dimension(:), intent(in) :: fa, mo, imztwin integer, dimension(:,:), intent(in) :: set integer, dimension(:,:), intent(out) :: sibd integer, parameter :: MISS=-9999 integer :: i, ifault, found, maxtrials, trials logical :: fin interface subroutine genoff(idx, fa, mo, set) integer, intent(in) :: idx integer, intent(in) :: fa integer, intent(in) :: mo integer, dimension(:,:), intent(in out) :: set end subroutine subroutine gencopy(idx, origin, set) integer, intent(in) :: idx integer, intent(in) :: origin integer, dimension(:,:), intent(inout) :: set end subroutine gencopy subroutine genof2(pedigree, idx, fa, mo, imztwin, set, sibd, ifault) use idstring_widths character (len=ped_width), intent(in) :: pedigree integer, intent(in) :: idx integer, intent(in) :: fa, mo, imztwin integer, dimension(:,:), intent(in) :: set integer, dimension(:,:), intent(inout) :: sibd integer, intent(out) :: ifault end subroutine end interface maxtrials=10 trials=0 1 continue trials = trials + 1 found=0 do i=1, nfound found=found+1 sibd(i,1)=found found=found+1 sibd(i,2)=found end do do i=nfound+1, num sibd(i,1)=MISS sibd(i,2)=MISS end do if (typ == 1) then do fin=.true. do i=nfound+1, num if (sibd(i,1) == MISS) then if (sibd(fa(i),1) /= MISS .and. sibd(mo(i),1) /= MISS) then if (imztwin(i) /= MISS) then call gencopy(i, imztwin(i), sibd) else call genoff(i, fa(i), mo(i), sibd) end if else fin=.false. end if end if end do if (fin) exit end do else if (typ == 2) then do fin=.true. do i=nfound+1, num if (sibd(i,1) == MISS) then if (sibd(fa(i),1) /= MISS .and. sibd(mo(i),1) /= MISS) then call genof2(pedigree, i, fa(i), mo(i), imztwin(i), set, sibd, ifault) if (ifault /= 0) then if (trials < maxtrials) then goto 1 else write(outstr,'(a,i0,a)') & 'Failed in simibd after ', trials, ' restarts!' end if end if else fin=.false. end if end if end do if (fin .or. irupt > 0) exit end do end if end subroutine simibd ! ! transmit ibd-marker from parents to child, ! test if consistent with observed marker ! In this version 12/99, the sibd pairs are ordered by the collating ! order of the marker alleles they represent and ! not the collating order of the sibd allele. ! subroutine genof2(pedigree, idx, fa, mo, imztwin, set, sibd, ifault) use outstream use idstring_widths use rngs character (len=ped_width), intent(in) :: pedigree integer, intent(in) :: idx integer, intent(in) :: fa, mo, imztwin integer, dimension(:,:), intent(in) :: set integer, dimension(:,:), intent(inout) :: sibd integer, intent(out) :: ifault integer, parameter :: MISS=-9999 integer :: c1, c2, maxtrials, par1, par2, tr1, tr2, trials ! sample without replacement from {{1,2},{1,2}} integer :: choice, i, seed, sspace(4) ifault=0 if (imztwin /= MISS) then sibd(idx,1:2)=sibd(imztwin,1:2) return end if maxtrials=4 trials=0 do i=1, maxtrials sspace(i)=i end do c1=set(idx,1) c2=set(idx,2) 1 continue trials=trials+1 choice=irandom(trials, maxtrials) seed=sspace(choice) sspace(choice)=sspace(trials) tr2=iand(seed,2)/2+1 tr1=iand(seed,1)+1 par1=set(fa,tr1) par2=set(mo,tr2) ! write(outstr,*) 'prop: ',trials,' choice:',choice, ! 2 ' sspace: ',(sspace(i),i=1,4), ! 3 ' seed: ',seed,'-> ',tr1,tr2 if (c1 == par1 .and. c2 == par2) then sibd(idx,1)=sibd(fa,tr1) sibd(idx,2)=sibd(mo,tr2) else if (c1 == par2.and.c2 == par1) then sibd(idx,1)=sibd(mo,tr2) sibd(idx,2)=sibd(fa,tr1) else if (trials < maxtrials) then go to 1 else write(outstr,'(a/7x,a/a/)') & 'ERROR: Probable mendelian inconsistency encountered', & 'performing ibd simulation. Stopping prematurely.' write(outstr,'(3a,i0,3(a,i0,a,i0))') & 'In pedigree ', trim(pedigree),', index individual #', idx, & ' has genotype: ',c1, '/', c2,' Parental genotypes: ', & set(fa,1), '/', set(fa,2),' & ',set(mo,1) ,'/', set(mo,2) ifault=1 end if end subroutine genof2 ! ! Monte-Carlo approach to estimating one-locus homozygosity by descent ! subroutine wrhbd(gene, trait, iter, burnin, allele_buffer, dataset, plevel) use outstream use interrupt use pairlist_class use alleles_class use ped_class implicit none integer, intent(in) :: gene integer, intent(inout) :: trait integer, intent(in) :: iter, burnin type (allele_data), intent(inout) :: allele_buffer type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel ! local variables integer, parameter :: KNOWN=0, MISS=-9999 integer, dimension(dataset%maxsiz,2) :: set integer, dimension(dataset%maxsiz,2) :: sibd integer, dimension(dataset%maxsiz) :: hbd ! proposal and work array: pedigree sized integer, dimension(dataset%maxsiz,2) :: set2 integer, dimension(2*dataset%maxsiz) :: key ! untyped matings type (pairlist_data) cntmat double precision, dimension(allele_buffer%numgtp) :: gfrq ! NRM to give F double precision, dimension(dataset%maxsiz*(dataset%maxsiz+1)/2) :: kin ! local variables integer :: g1, g2, gen2, i, ii, j, iprop, it, nfam, nuntyp, ntyped integer :: num, ped, pedoffset, pedtyp logical :: alltyp character (len=7) :: gtp double precision :: den ! functions integer :: getnam interface subroutine update(idx, all1, all2, set) integer, intent(in) :: idx integer, intent(in) :: all1 integer, intent(in) :: all2 integer, dimension(:,:), intent(inout) :: set end subroutine update subroutine kinship(ped, dataset, kin) use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(in) :: dataset double precision, dimension(:), intent(inout) :: kin end subroutine kinship subroutine tabmat(ped, dataset, cntmat) use pairlist_class use ped_class integer, intent(in) :: ped type (ped_data), intent(in) :: dataset type (pairlist_data), intent(inout) :: cntmat end subroutine tabmat subroutine drop(it, ped, dataset, cntmat, numal, gfrq, & set, sibd, set2, key, iprop, plevel) use pairlist_class use ped_class implicit none integer, intent(in) :: it integer, intent(in) :: ped type (ped_data) :: dataset ! number of untyped matings -- used to decide number and type of mutations type (pairlist_data), intent(inout) :: cntmat integer, intent(in) :: numal double precision, dimension(numal*(numal+1)/2) :: gfrq integer, dimension(:,:), intent(inout), target :: set, sibd ! proposal and work array integer, dimension(:,:), intent(inout) :: set2 integer, dimension(:), intent(inout) :: key integer, intent(out) :: iprop integer, intent(in) :: plevel end subroutine drop subroutine pedibd(typ, ped, dataset, set, sibd) use ped_class implicit none integer, intent(in) :: typ integer, intent(in) :: ped type (ped_data), intent(in) :: dataset integer, dimension(:,:), intent(in) :: set integer, dimension(:,:), intent(in out) :: sibd end subroutine pedibd end interface ! den=1.0d0/dble(iter) gen2=gene+1 nfam=0 if (trait == MISS .or. plevel > 1) then write(outstr,'(a)') 'Pedigree ID HBD F Gtp' end if ! ! iterate over active pedigrees ! do ped=1, dataset%nped pedtyp=0 if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset do i=1, num hbd(i)=0 end do alltyp=.true. pedtyp=0 do i=pedoffset+1, dataset%num(ped) call get_geno(i, gene, gen2, dataset, g1, g2) if (.not.observed(i, gene, dataset)) then if (i <= pedoffset+dataset%nfound(ped)) then alltyp=.false. nuntyp=nuntyp+1 end if dataset%untyped(i)=.true. if (g1 == 0 .or. g1 == MISS) then g1=MISS g2=MISS else g1=getnam(g1, allele_buffer) g2=getnam(g2, allele_buffer) end if else pedtyp=pedtyp+1 dataset%untyped(i)=.false. g1=getnam(g1, allele_buffer) g2=getnam(g2, allele_buffer) end if call update(i-pedoffset, g1, g2, set) end do if (pedtyp>0) then nfam=nfam+1 ntyped=ntyped+pedtyp call kinship(ped, dataset, kin) ! completely typed if (alltyp) then do it=1, iter call pedibd(2, ped, dataset, set, sibd) do i=1, num if (sibd(i,1) == sibd(i,2)) then hbd(i)=hbd(i)+1 end if end do end do else ! some untyped markers: ! produce genotype frequencies for Metropolis criterion ! enumerate untyped founder matings call genot(allele_buffer, gfrq) call tabmat(ped, dataset, cntmat) ! ! Metropolis simulation of genotypes ! if (plevel > 2) then write(outstr,'(/2a,4(/a,i4))') & 'Metropolis simulation of pedigree ', dataset%pedigree(ped), & 'Untyped Individuals: ', num-pedtyp, & 'Possible genotypes : ', allele_buffer%numgtp, & 'UnT x UnT matings : ', cntmat%npairs, & 'Burn-in (iters) : ', burnin end if do it=1, burnin call drop(it, ped, dataset, cntmat, allele_buffer%numal, gfrq, & set, sibd, set2, key, iprop, 0) end do do it=1, iter call drop(it, ped, dataset, cntmat, allele_buffer%numal, gfrq, & set, sibd, set2, key, iprop, plevel) call pedibd(2, ped, dataset, set, sibd) do i=1, num if (sibd(i,1) == sibd(i,2)) then hbd(i)=hbd(i)+1 end if end do end do ! record new starting genotypes ii=pedoffset do i=1, num ii=ii+1 if (dataset%untyped(ii)) then g1=-allele_buffer%allele_names(set(i,1)) g2=-allele_buffer%allele_names(set(i,2)) call set_geno(ii, gene, gen2, dataset, g1, g2) end if end do end if ! no typed individuals else do it=1, iter call pedibd(1, ped, dataset, set, sibd) do i=1, num if (sibd(i,1) == sibd(i,2)) then hbd(i)=hbd(i)+1 end if end do end do end if ! output to screen if (trait == MISS .or. plevel > 1) then ii=0 j=0 do i=pedoffset+1, dataset%num(ped) j=j+1 ii=ii+j if (dataset%untyped(i)) then call wrgtp(MISS, MISS, gtp, '/', '', 1) else call get_geno(i, gene, gen2, dataset, g1, g2) call wrgtp(g1, g2, gtp, '/', '', 1) end if write(outstr,'(a10,1x,a10,2(1x,f6.4),1x,a7)') & dataset%pedigree(ped), dataset%id(i), & den*dble(hbd(i-pedoffset)), kin(ii)-1.0d0, gtp end do end if ! output to variable if (trait /= MISS) then do i=pedoffset+1, dataset%num(ped) dataset%plocus(i,trait)=den*dble(hbd(i-pedoffset)) end do end if else if (trait /= MISS) then do i=pedoffset+1, dataset%num(ped) dataset%plocus(i,trait)=MISS end do end if end do call clean_pairs(cntmat) end subroutine wrhbd ! ! MCMC for genotype probability estimates and allele doses ! subroutine mcgpe(gene, trait, iter, burnin, allele_buffer, dataset, plevel) use outstream use interrupt use pairlist_class use alleles_class use ped_class implicit none integer, intent(in) :: gene, trait integer, intent(in) :: iter, burnin type (allele_data), intent(inout) :: allele_buffer type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel ! local variables integer, parameter :: KNOWN=0, MISS=-9999 ! Genotype counts: pedigree sized double precision, dimension(dataset%maxsiz, allele_buffer%numgtp) :: gcount ! proposal and work array: pedigree sized integer, dimension(dataset%maxsiz,2) :: set integer, dimension(dataset%maxsiz,2) :: sibd integer, dimension(dataset%maxsiz,2) :: set2 integer, dimension(2*dataset%maxsiz) :: key ! untyped matings type (pairlist_data) cntmat double precision, dimension(allele_buffer%numgtp) :: gfrq ! local variables integer :: g, g1, g2, gen2, i, it, j, nfam, nuntyp, ntyped integer :: num, ped, pedoffset, pedtyp logical :: alltyp character (len=7) :: gtp double precision :: dose, one, wei ! Metropolis summary integer :: iprop, proprate(4), proptyp(4) ! functions integer :: clcpos, getnam interface subroutine update(idx, all1, all2, set) integer, intent(in) :: idx integer, intent(in) :: all1 integer, intent(in) :: all2 integer, dimension(:,:), intent(inout) :: set end subroutine update subroutine tabmat(ped, dataset, cntmat) use pairlist_class use ped_class integer, intent(in) :: ped type (ped_data), intent(in) :: dataset type (pairlist_data), intent(inout) :: cntmat end subroutine tabmat subroutine drop(it, ped, dataset, cntmat, numal, gfrq, & set, sibd, set2, key, iprop, plevel) use pairlist_class use ped_class implicit none integer, intent(in) :: it integer, intent(in) :: ped type (ped_data) :: dataset ! number of untyped matings -- used to decide number and type of mutations type (pairlist_data), intent(inout) :: cntmat integer, intent(in) :: numal double precision, dimension(numal*(numal+1)/2) :: gfrq integer, dimension(:,:), intent(inout), target :: set, sibd ! proposal and work array integer, dimension(:,:), intent(inout) :: set2 integer, dimension(:), intent(inout) :: key integer, intent(out) :: iprop integer, intent(in) :: plevel end subroutine drop subroutine pedibd(typ, ped, dataset, set, sibd) use ped_class implicit none integer, intent(in) :: typ integer, intent(in) :: ped type (ped_data), intent(in) :: dataset integer, dimension(:,:), intent(in) :: set integer, dimension(:,:), intent(in out) :: sibd end subroutine pedibd end interface ! if (trait == MISS .or. plevel > 0) then write(outstr,'(/a/a)') & 'Individual Gtp Genotype Probabilities', & '------------------------- ------- ---------------------------' end if one=1.0d0 do i=1, 4 proprate(i)=0 proptyp(i)=0 end do gen2=gene+1 call genot(allele_buffer, gfrq) nfam=0 ntyped=0 nuntyp=0 ! ! iterate over active pedigrees ! do ped=1, dataset%nped pedtyp=0 if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset gcount(1:num, 1:allele_buffer%numgtp)=0.0d0 alltyp=.true. pedtyp=0 do i=pedoffset+1, dataset%num(ped) call get_geno(i, gene, gen2, dataset, g1, g2) if (.not.observed(i, gene, dataset)) then alltyp=.false. nuntyp=nuntyp+1 dataset%untyped(i)=.true. if (g1 == 0 .or. g1 == MISS) then g1=MISS g2=MISS else g1=getnam(g1, allele_buffer) g2=getnam(g2, allele_buffer) end if else pedtyp=pedtyp+1 dataset%untyped(i)=.false. g1=getnam(g1, allele_buffer) g2=getnam(g2, allele_buffer) if (g1 == MISS .or. g2 == MISS) then write(outstr,'(/a)') 'ERROR: Unknown allele. Aborting!' return end if end if call update(i-pedoffset, g1, g2, set) end do nfam=nfam+1 ntyped=ntyped+pedtyp ! all genotypes KNOWN if (alltyp) then do i=1, num g=clcpos(set(i,1),set(i,2)) gcount(i,g)=gcount(i,g)+one end do ! no genotypes known else if (pedtyp == 0) then do i=1, num gcount(i,1:allele_buffer%numgtp)=gfrq end do ! else Metropolis simulation of genotypes else call tabmat(ped, dataset, cntmat) if (plevel > 2) then write(outstr,'(/2a,4(/a,i4))') & 'Metropolis simulation of pedigree ', dataset%pedigree(ped), & 'Untyped Individuals: ', num-pedtyp, & 'Possible genotypes : ', allele_buffer%numgtp, & 'UnT x UnT matings : ', cntmat%npairs, & 'Burn-in (iters) : ', burnin end if do it=1, burnin call drop(it, ped, dataset, cntmat, allele_buffer%numal, gfrq, & set, sibd, set2, key, iprop, 0) end do wei=1.0d0/dble(iter) do it=1, iter call drop(it, ped, dataset, cntmat, allele_buffer%numal, gfrq, & set, sibd, set2, key, iprop, plevel) call cntprop(iprop, proprate, proptyp) do i=1, num g=clcpos(set(i,1),set(i,2)) gcount(i,g)=gcount(i,g)+wei end do end do ! record new starting genotypes j=pedoffset do i=1, num j=j+1 if (dataset%untyped(j)) then g1=-allele_buffer%allele_names(set(i,1)) g2=-allele_buffer%allele_names(set(i,2)) call set_geno(j, gene, gen2, dataset, g1, g2) end if end do end if ! output if (trait /= MISS) then do i=1, num g=1 dose=2*gcount(i,g) do j=1, allele_buffer%numal-1 g=g+j dose=dose+gcount(i,g) end do dataset%plocus(pedoffset+i,trait)=dose if (plevel > 0) then call prgtp(pedoffset+i, gene, dataset, gtp) write(outstr, '(a25,1x,a7,1x,f6.4)') & trim(dataset%pedigree(ped)) // '--' // trim(dataset%id(pedoffset+i)), & gtp, dose end if end do else if (plevel > 0) then do i=1, num call prgtp(pedoffset+i, gene, dataset, gtp) write(outstr, '(a25,1x,a7,(15(1x,f6.4)):)') & trim(dataset%pedigree(ped)) // '--' // trim(dataset%id(pedoffset+i)), & gtp, gcount(i,1:allele_buffer%numgtp) end do else if (plevel == 0) then do i=1, num if (.not.observed(pedoffset+i, gene, dataset)) then call prgtp(pedoffset+i, gene, dataset, gtp) write(outstr, '(a25,1x,a7,(15(1x,f6.4)):)') & trim(dataset%pedigree(ped)) // '--' // trim(dataset%id(pedoffset+i)), & gtp, gcount(i,1:allele_buffer%numgtp) end if end do end if end if if (irupt /= 0) exit end do write(outstr,'(2(/a,i7))') & 'Number of observed genotypes =', ntyped, & 'No. of unobserved ungenotypes =', nuntyp call wrprop(0, proprate, proptyp) end subroutine mcgpe ! ! MCEM for pedigree allele frequencies ! subroutine mcfreq(gene, iter, emiter, dataset, allele_buffer, plevel) use outstream use interrupt use pairlist_class use alleles_class use ped_class implicit none integer, intent(in) :: gene integer, intent(in) :: iter, emiter type (ped_data), intent(inout) :: dataset type (allele_data), intent(inout) :: allele_buffer integer, intent(in) :: plevel ! local variables integer, parameter :: KNOWN=0, MISS=-9999 double precision, dimension(allele_buffer%numal) :: alfrq2 double precision, dimension(allele_buffer%numgtp) :: gfrq logical, dimension(dataset%nped) :: alltyp, zerotyp integer, dimension(dataset%nobs,2), target :: set integer, dimension(dataset%nobs,2), target :: sibd ! proposal and work array: pedigree sized integer :: psta, pfin integer, dimension(:,:), pointer :: pset, psibd integer, dimension(dataset%maxsiz,2) :: set2 integer, dimension(2*dataset%maxsiz) :: key ! untyped matings type (pairlist_data) cntmat ! local variables integer :: emit, g1, g2, gen2, i, iprop, it, j, maxem, nfam, & ntyped, nuntyp, ped, pedoffset, pedtyp, tfound integer :: proprate(4), proptyp(4) logical :: nostart double precision :: accel, delta, den, one, minfreq, topfreq, wei ! functions integer :: getnam interface subroutine update(idx, all1, all2, set) integer, intent(in) :: idx integer, intent(in) :: all1 integer, intent(in) :: all2 integer, dimension(:,:), intent(inout) :: set end subroutine update subroutine tabmat(ped, dataset, cntmat) use pairlist_class use ped_class integer, intent(in) :: ped type (ped_data), intent(in) :: dataset type (pairlist_data), intent(inout) :: cntmat end subroutine tabmat subroutine drop(it, ped, dataset, cntmat, numal, gfrq, & set, sibd, set2, key, iprop, plevel) use pairlist_class use ped_class implicit none integer, intent(in) :: it integer, intent(in) :: ped type (ped_data) :: dataset ! number of untyped matings -- used to decide number and type of mutations type (pairlist_data), intent(inout) :: cntmat integer, intent(in) :: numal double precision, dimension(numal*(numal+1)/2) :: gfrq integer, dimension(:,:), intent(inout), target :: set, sibd ! proposal and work array integer, dimension(:,:), intent(inout) :: set2 integer, dimension(:), intent(inout) :: key integer, intent(out) :: iprop integer, intent(in) :: plevel end subroutine drop end interface if (allele_buffer%numal == 0) then return end if gen2=gene+1 nfam=0 ntyped=0 nuntyp=0 tfound=0 one=1.0d0 wei=1.0d0/dble(iter) ! ! iterate over active pedigrees ! do ped=1, dataset%nped nostart=.false. pedtyp=0 if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) alltyp(ped)=.true. pedtyp=0 do i=pedoffset+1, dataset%num(ped) call get_geno(i, gene, gen2, dataset, g1, g2) if (.not.observed(i, gene, dataset)) then if (i <= pedoffset+dataset%nfound(ped)) then alltyp=.false. nuntyp=nuntyp+1 end if dataset%untyped(i)=.true. if (g1 == 0 .or. g1 == MISS) then nostart=.true. g1=MISS g2=MISS else g1=getnam(g1, allele_buffer) g2=getnam(g2, allele_buffer) end if else pedtyp=pedtyp+1 dataset%untyped(i)=.false. g1=getnam(g1, allele_buffer) g2=getnam(g2, allele_buffer) end if call update(i,g1,g2,set) end do if (pedtyp>0 .and..not.nostart) then nfam=nfam+1 tfound=tfound+dataset%nfound(ped) ntyped=ntyped+pedtyp end if end if zerotyp(ped)=(pedtyp==0 .or. nostart) end do if (nfam==0) then write(outstr,'(a)') 'NOTE: No pedigrees usable for MCEM!' return end if maxem=emiter if (nuntyp == 0) maxem=1 den=1.0d0/dble(2*tfound) ! ! EM iterations ! do i=1, allele_buffer%numal allele_buffer%allele_freqs(i)=1.0d0/dble(allele_buffer%numal) end do emit=0 do while (emit < maxem .and. irupt == 0) emit=emit+1 do i=1, allele_buffer%numal alfrq2(i)=0.0d0 end do do i=1, 4 proprate(i)=0 proptyp(i)=0 end do call genot(allele_buffer, gfrq) do ped=1, dataset%nped if (.not.zerotyp(ped)) then pedoffset=dataset%num(ped-1) if (.not.alltyp(ped)) then call tabmat(ped, dataset, cntmat) psta=pedoffset+1 pfin=dataset%num(ped) pset => set(psta:pfin, 1:2) psibd => sibd(psta:pfin, 1:2) if (plevel > 1) then write(outstr,'(/2a)') 'Metropolis simulation of pedigree ', dataset%pedigree(ped) end if do it=1, iter call drop(it, ped, dataset, cntmat, allele_buffer%numal, gfrq, & pset, psibd, set2, key, iprop, plevel) call cntprop(iprop, proprate, proptyp) do i=pedoffset+1, pedoffset+dataset%nfound(ped) alfrq2(set(i,1))=alfrq2(set(i,1))+wei alfrq2(set(i,2))=alfrq2(set(i,2))+wei end do end do else do i=pedoffset+1, pedoffset+dataset%nfound(ped) alfrq2(set(i,1))=alfrq2(set(i,1))+one alfrq2(set(i,2))=alfrq2(set(i,2))+one end do end if end if end do accel=1.0d0 if (emit <= (maxem/2)) then accel=dble(emit+1)/dble(emit) end if do i=1, allele_buffer%numal delta=allele_buffer%allele_freqs(i)-den*alfrq2(i) allele_buffer%allele_freqs(i)=allele_buffer%allele_freqs(i)-accel*delta if (allele_buffer%allele_freqs(i) < 0.0d0) allele_buffer%allele_freqs(i)=0.01d0 if (allele_buffer%allele_freqs(i) > 1.0d0) allele_buffer%allele_freqs(i)=0.99d0 end do if (plevel > 0) then call wrprop(emit, proprate, proptyp) write(outstr,'(i4,1x,12(1x,f5.3):)') & emit, allele_buffer%allele_freqs(1:allele_buffer%numal) end if end do if (plevel > 0) write(outstr,*) topfreq=0.0d0 minfreq=1.0d0 do i=1, allele_buffer%numal if (allele_buffer%allele_freqs(i) > topfreq) then topfreq=allele_buffer%allele_freqs(i) allele_buffer%topall=i end if if (allele_buffer%allele_freqs(i) < minfreq) then minfreq=allele_buffer%allele_freqs(i) allele_buffer%minall=i end if end do allele_buffer%cum_freqs(1)=allele_buffer%allele_freqs(1) allele_buffer%cum_freqs(allele_buffer%numal)=1.0d0 do i=2, allele_buffer%numal-1 allele_buffer%cum_freqs(i)= allele_buffer%cum_freqs(i-1) + & allele_buffer%allele_freqs(i) end do allele_buffer%typed=tfound-nuntyp allele_buffer%totall=2*tfound end subroutine mcfreq ! ! Call drop to shuffle the unobserved genotypes ! subroutine newstart(gene, allele_buffer, dataset, plevel) use outstream use interrupt use pairlist_class use alleles_class use ped_class implicit none integer, intent(in) :: gene type (allele_data), intent(in) :: allele_buffer type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel ! local variables integer, parameter :: KNOWN=0, MISS=-9999 ! proposal and work array: pedigree sized integer, dimension(dataset%maxsiz,2) :: set integer, dimension(dataset%maxsiz,2) :: sibd integer, dimension(dataset%maxsiz,2) :: set2 integer, dimension(2*dataset%maxsiz) :: key ! untyped matings type (pairlist_data) cntmat double precision, dimension(allele_buffer%numgtp) :: gfrq ! local variables integer :: g1, g2, gen2, i, idx, ii, it, iter, j, & maxiter, nfam, nuntyp, ntyped integer :: num, ped, pedoffset, pedtyp logical :: alltyp, hasmiss double precision :: den, zibd ! Metropolis summary integer :: iprop ! functions integer :: getnam interface subroutine update(idx, all1, all2, set) integer, intent(in) :: idx integer, intent(in) :: all1 integer, intent(in) :: all2 integer, dimension(:,:), intent(inout) :: set end subroutine update subroutine tabmat(ped, dataset, cntmat) use pairlist_class use ped_class integer, intent(in) :: ped type (ped_data), intent(in) :: dataset type (pairlist_data), intent(inout) :: cntmat end subroutine tabmat subroutine drop(it, ped, dataset, cntmat, numal, gfrq, & set, sibd, set2, key, iprop, plevel) use pairlist_class use ped_class implicit none integer, intent(in) :: it integer, intent(in) :: ped type (ped_data) :: dataset ! number of untyped matings -- used to decide number and type of mutations type (pairlist_data), intent(inout) :: cntmat integer, intent(in) :: numal double precision, dimension(numal*(numal+1)/2) :: gfrq integer, dimension(:,:), intent(inout), target :: set, sibd ! proposal and work array integer, dimension(:,:), intent(inout) :: set2 integer, dimension(:), intent(inout) :: key integer, intent(out) :: iprop integer, intent(in) :: plevel end subroutine drop subroutine pedibd(typ, ped, dataset, set, sibd) use ped_class implicit none integer, intent(in) :: typ integer, intent(in) :: ped type (ped_data), intent(in) :: dataset integer, dimension(:,:), intent(in) :: set integer, dimension(:,:), intent(in out) :: sibd end subroutine pedibd end interface ! maxiter=10 gen2=gene+1 call genot(allele_buffer, gfrq) ! ! iterate over active pedigrees ! do ped=1, dataset%nped pedtyp=0 if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset alltyp=.true. hasmiss=.false. pedtyp=0 ii=pedoffset do i=1, num ii=ii+1 call get_geno(ii, gene, gen2, dataset, g1, g2) if (.not.observed(ii, gene, dataset)) then if (i <= dataset%nfound(ped)) then alltyp=.false. nuntyp=nuntyp+1 end if dataset%untyped(ii)=.true. if (g1 == 0 .or. g1 == MISS) then hasmiss=.true. g1=MISS g2=MISS else g1=getnam(g1, allele_buffer) g2=getnam(g2, allele_buffer) end if else pedtyp=pedtyp+1 dataset%untyped(ii)=.false. g1=getnam(g1, allele_buffer) g2=getnam(g2, allele_buffer) end if call update(i, g1, g2, set) end do if (.not.alltyp) then nfam=nfam+1 ntyped=ntyped+pedtyp ! need legal starting genotypes for all pedigree members if (hasmiss) then write(outstr,'(a)') & 'ERROR: Some starting values for genotype imputation missing.' return end if ! enumerate untyped founder matings call tabmat(ped, dataset, cntmat) iter=min(maxiter, num-pedtyp) ! Metropolis simulation of genotypes if (plevel > 2) then write(outstr,'(/2a,4(/a,i4))') & 'Metropolis resimulation of pedigree ', dataset%pedigree(ped), & 'Untyped Individuals: ', num-pedtyp, & 'Possible genotypes : ', allele_buffer%numgtp, & 'UnT x UnT matings : ', cntmat%npairs, & 'Iterations : ', iter end if do it=1, iter call drop(it, ped, dataset, cntmat, allele_buffer%numal, gfrq, & set, sibd, set2, key, iprop, plevel) end do end if ! output updated missing genotypes ii=pedoffset do i=1, num ii=ii+1 if (dataset%untyped(ii)) then g1=-allele_buffer%allele_names(set(i,1)) g2=-allele_buffer%allele_names(set(i,2)) call set_geno(ii, gene, gen2, dataset, g1, g2) end if end do end if end do end subroutine newstart ! ! Increment counts of MCMC proposal type ! subroutine cntprop(iprop, proprate, proptyp) integer, intent(in out) :: iprop integer, intent(inout) :: proprate(4) integer, intent(inout) :: proptyp(4) proptyp(abs(iprop))=proptyp(abs(iprop))+1 if (iprop > 0) then proprate(iprop)=proprate(iprop)+1 end if end subroutine cntprop ! ! Summary of MCMC proposals from drop() ! subroutine wrprop(ilabel, proprate, proptyp) use outstream integer, intent(in) :: ilabel integer, intent(in) :: proprate(4) integer, intent(in) :: proptyp(4) character (len=3) :: proplab(4) = (/'ibd','mut','swi','loc'/) if (ilabel > 0) then write(outstr,'(a,i4,$)') 'DROP ', ilabel else write(outstr,'(/a,$)') 'MCMC proposals:' end if write(outstr,'(4(1x, a3, i7, 1x, f5.3))') & (proplab(i), proptyp(i), & dble(proprate(i))/dble(max(1,proptyp(i))), i=1,4) end subroutine wrprop ! ! count the untyped founder x founder matings for use by Metropolis algs ! subroutine tabmat(ped, dataset, cntmat) use pairlist_class use ped_class integer, intent(in) :: ped type (ped_data), intent(in) :: dataset type (pairlist_data), intent(inout) :: cntmat ! local variables integer :: i, nf nf=dataset%num(ped-1)+dataset%nfound(ped) call setup_pairs(100, cntmat) do i=nf+1, dataset%num(ped) if (dataset%untyped(dataset%fa(i)) .and. dataset%untyped(dataset%mo(i)) .and. & dataset%fa(i) <= nf .and. dataset%mo(i) <= nf) then call append_pair(dataset%fa(i), dataset%mo(i), cntmat) end if end do end subroutine tabmat ! ! Approach of Schaid and Sommer (1993), amplified by Knapp et al (1995) ! ! MM x MM MM x MN MM x NN MN x MN MN x NN NN x NN ! MM MM MN MN MM MN NN MN NN NN ! n1 n2 n3 n4 n5 n6 n7 n8 n9 n10 ! ! a=4*n1 + 3*n2 + 3*n3 + 2*n4 + 2*n5 + 2*n6 + 2*n7 + n8 + n9 ! b=n2 + n3 + 2*n4 + 2*n5 + 2*n6 + 2*n7 + 3*n8 + 3*n9 + 4*n10 ! c=n1 + n2 + n5 ! d=n3 + n4 + n6 + n8 ! ! providing n-c-d!=0 and a-2c-d!=0 then ! ! p=(a-2*c-d)/2n ! r1= (1-p)*d/(2*p*(n-c-d)) ! r2= (1-p)^2 c/(p^2*(n-c-d)) ! ! Here, actually done as the log-linear model, as the closed form ! standard error formulae are ugly ! subroutine nucseg(trait, locnam, gene, genetyp, freqfnd, & spec_candal, dataset, pval, plevel) use outstream use alleles_class use ped_class use statfuns implicit none integer, intent(in) :: trait character (len=*), intent(in) :: locnam integer, intent(in) :: gene, genetyp, freqfnd integer, intent(in) :: spec_candal type (ped_data) :: dataset double precision, intent(out) :: pval integer, intent(in) :: plevel ! local variables integer, parameter :: KNOWN=0 ! two alleles integer :: candal, other type (allele_data) :: allele_buffer ! loglinear model matrices integer, dimension(16) :: icounts double precision :: counts(16), cpgmod(40), hwemod(64), offset(16) double precision, dimension(16) :: b, x double precision, dimension(136) :: cov, r integer :: gen2, i, naff, nch, nfa, nmo, offs, ped, pos integer :: g1, g2, fg1, fg2, mg1, mg2 character (len=3) :: allnam, histo character (len=7) :: gtp0, gtp1, gtp2 logical :: last double precision :: lik0, lik1, p, p0, q, q0, r0, r1, r2, & e1, e2, e3, e4, e5, e6, se1, se2 ! functions ! chip character (len=6) :: pstring interface subroutine freq(gene, loctyp, fndr, dataset, allele_buffer) use ped_class use alleles_class integer, intent(in) :: gene integer, intent(in) :: loctyp integer, intent(in) :: fndr type (ped_data), intent(in) :: dataset type (allele_data), intent(inout) :: allele_buffer end subroutine freq subroutine loglin(ncells, totpars, npars, counts, model, offset, b, cov, lrts) integer, intent(in) :: ncells integer, intent(in) :: totpars integer, intent(in) :: npars double precision, dimension(:), intent(inout) :: counts double precision, dimension(:), intent(inout) :: model double precision, dimension(:), intent(inout) :: offset double precision, dimension(:) :: b double precision, dimension(:) :: cov double precision :: lrts end subroutine loglin end interface data hwemod / 1, 4, 0, 1, 1, 3, 0, 1, 1, 3, 0, 1, & 1, 3, 1, 0, 1, 3, 1, 0, 1, 2, 1, 0, & 1, 2, 1, 0, 1, 2, 0, 1, 1, 2, 1, 0, & 1, 2, 1, 0, 1, 2, 0, 0, 1, 1, 1, 0, & 1, 1, 1, 0, 1, 1, 0, 0, 1, 1, 0, 0, & 1, 0, 0, 0 / data cpgmod / 1, 0, 0, 0, 1, 1, 0, 0, 1, 0, & 0, 1, 0, 0, 1, 0, 1, 0, 1, 0, & 0, 1, 0, 1, 0, 0, 1, 0, 0, 0, & 0, 0, 1, 1, 0, 0, 0, 1, 0, 0 / gen2=gene+1 call setup_freq(10, allele_buffer) call freq(gene, genetyp, freqfnd, dataset, allele_buffer) if (spec_candal > KNOWN) then candal=spec_candal else candal=allele_buffer%allele_names(allele_buffer%topall) end if call wrall(candal, allnam) other=0 if (allele_buffer%numal == 2) then other=allele_buffer%allele_names(1) if (allele_buffer%allele_names(1) == candal) then other=allele_buffer%allele_names(2) end if end if naff=0 do i=1, 10 icounts(i)=0 end do do i=1, 16 offset(i)=0.0d0 end do if (plevel > 1) then write(outstr,'(/a)') 'Pedigree ID Child Father Mother' end if do ped=1, dataset%nped if (dataset%actset(ped) > 0) then offs=dataset%num(ped-1) do i=offs+dataset%nfound(ped)+1, dataset%num(ped) if (dataset%plocus(i,trait) == 2.0d0 .and. & observed(i, gene, dataset) .and. & observed(dataset%fa(i), gene, dataset) .and. & observed(dataset%mo(i), gene, dataset)) then naff=naff+1 nfa=0 nmo=0 nch=0 call get_geno(i, gene, gen2, dataset, g1, g2) call get_geno(dataset%fa(i), gene, gen2, dataset, fg1, fg2) call get_geno(dataset%mo(i), gene, gen2, dataset, mg1, mg2) if (g1 == candal) nch=nch+1 if (g2 == candal) nch=nch+1 if (fg1 == candal) nfa=nfa+1 if (fg2 == candal) nfa=nfa+1 if (mg1 == candal) nmo=nmo+1 if (mg2 == candal) nmo=nmo+1 if (nmo == 1 .and. nfa == 1) then pos=7-nch else if ((nfa+nmo) > 1) then pos=7-nfa-nmo-nch else pos=10-nfa-nmo-nch end if icounts(pos)=icounts(pos)+1 if (plevel > 1) then write(outstr,'(a10,1x,a10,3(1x,i3,1x,i3))') & dataset%pedigree(ped), dataset%id(i), & g1, g2, fg1, fg2, mg1, mg2 end if end if end do end if end do counts(1)=dble(icounts(1)) counts(2)=0.5*dble(icounts(2)) counts(3)=counts(2) counts(4)=0.5*dble(icounts(3)) counts(5)=counts(4) counts(6)=0.5*dble(icounts(4)) counts(7)=counts(6) counts(8)=dble(icounts(5)) counts(9)=0.5*dble(icounts(6)) counts(10)=counts(9) counts(11)=dble(icounts(7)) counts(12)=0.5*dble(icounts(8)) counts(13)=counts(12) counts(14)=0.5*dble(icounts(9)) counts(15)=counts(14) counts(16)=dble(icounts(10)) call loglin(16,4,2,counts,hwemod,offset,b,cov,lik0) p0=exp(b(2)) p0=p0/(1.0d0+p0) q0=1.0d0-p0 call loglin(16,4,4,counts,hwemod,offset,b,cov,lik1) p=exp(b(2)) p=p/(1.0d0+p) q=1.0d0-p r1=b(3) r2=b(4) r0=p*p*exp(r2)+2*p*q*exp(r1)+q*q se1=1.96d0*sqrt(cov(6)) se2=1.96d0*sqrt(cov(10)) lik1=lik0-lik1 e1=p0*p0*p0*p0*dble(naff) e2=4*p0*q0*p0*p0*dble(naff) e3=2*p0*p0*q0*q0*dble(naff) e4=4*p0*q0*p0*q0*dble(naff) e5=4*p0*q0*q0*q0*dble(naff) e6=q*q*q*q*dble(naff) call wrgtp(candal,candal,gtp2,'/', '', 1) call wrgtp(candal,other,gtp1,'/', '', 1) call wrgtp(other,other,gtp0,'/', '', 1) if (plevel > 0) then write(outstr,'(/a,a10,a/6x,a,9x,a,3(1x,a)/a)') & '---- TDT for "',locnam,'" ----------------------------------', & 'Mating','Total Expected', gtp2, gtp1, gtp0, & '------------------------------------------------------------' write(outstr, '(3a,i9,f9.1,(1x,i5,2x),2a8)') & gtp2, ' x ', gtp2, icounts(1), e1, icounts(1), 'x ','x ' write(outstr, '(3a,i9,f9.1,2(1x,i5,2x),a8)') & gtp2, ' x ', gtp1, icounts(2)+icounts(3), e2, icounts(2), icounts(3), 'x ' write(outstr, '(3a,i9,f9.1,a8,(1x,i5,2x),a8)') & gtp2, ' x ', gtp0, icounts(4), e3, 'x ', icounts(4), 'x ' write(outstr, '(3a,i9,f9.1,3(1x,i5,2x))') & gtp1, ' x ', gtp1, icounts(5)+icounts(6)+icounts(7), e4, icounts(5), icounts(6), icounts(7) write(outstr, '(3a,i9,f9.1,a8,2(1x,i5,2x))') & gtp1, ' x ', gtp0, icounts(8)+icounts(9), e5, 'x ', icounts(8), icounts(9) write(outstr, '(3a,i9,f9.1,2a8,1x,i5)') & gtp0, ' x ', gtp0, icounts(10), e6, 'x ','x ', icounts(10) write(outstr,'(a//3a,f5.3/a,i5)') & '------------------------------------------------------------', & 'Freq of ', allnam, ' allele = ', p, 'N affected children = ', naff write(outstr,'(/a,f8.2,3a,2(/3(a,f8.2),a)/a,f8.2)') & 'HWE Chi-square (2 df)= ', lik1, & ' (P=', trim(pstring(chip(lik1,2))), ')', & 'Genotypic RR1 (f1) = ', exp(r1), ' (95%CI=', & exp(r1-se1), ' to ', exp(r1+se1),')', & 'Genotypic RR2 (f2) = ', exp(r2), ' (95%CI=', & exp(r2-se2), ' to ', exp(r2+se2),')', & 'Attributable risk = ', 1.0d0-1.0d0/r0 end if ! ! ML CPG test ! counts(1)=dble(icounts(2)) counts(2)=dble(icounts(3)) counts(3)=dble(icounts(5)) counts(4)=0.5*dble(icounts(6)) counts(5)=counts(4) counts(6)=dble(icounts(7)) counts(7)=dble(icounts(8)) counts(8)=dble(icounts(9)) call loglin(8,5,3,counts,cpgmod,offset,b,cov,lik0) call loglin(8,5,5,counts,cpgmod,offset,b,cov,lik1) r1=b(4) r2=b(5) r0=p*p*exp(r2)+2*p*q*exp(r1)+q*q se1=1.96d0*sqrt(cov(10)) se2=1.96d0*sqrt(cov(15)) lik1=lik0-lik1 pval=chip(lik1,2) if (plevel > 0) then write(outstr,'(/a,f8.2,3a,2(/3(a,f8.2),a)/a,f8.2)') & 'CPG Chi-sq (2 df) = ', lik1, & ' (P=', trim(pstring(pval)),')', & 'Genotypic RR1 (f1) = ',exp(r1),' (95%CI=', & exp(r1-se1),' to ',exp(r1+se1),')', & 'Genotypic RR2 (f2) = ',exp(r2),' (95%CI=', & exp(r2-se1),' to ',exp(r2+se1),')', & 'Attributable risk = ',(p*p*(exp(r2)-1.0d0)+ 2*p*q*(exp(r1)-1.0d0))/r0 else if (plevel == 0 .or. plevel == -1) then call phist(pval,pval,histo) write(outstr,'(a14,a1,i6,a1,a6,a1,f10.1,3(a1,a))') & locnam, tabsep, naff, tabsep, allnam, tabsep, lik1, & tabsep, pstring(pval), tabsep, 'Sch', tabsep, histo end if end subroutine nucseg ! ! marker homozygosity in all subjects or just probands -- codominant system ! subroutine dohomoz(trait, locnam, gene, genetyp, freqfnd, iter, mincnt, norder, & gt, thresh, dataset, pval, plevel) use outstream use popgen_vcdata use alleles_class use ped_class use rngs use sorts use statfuns implicit none integer, intent(in) :: trait character (len=*), intent(in) :: locnam integer, intent(in) :: gene, genetyp integer, intent(in) :: freqfnd integer, intent(in) :: iter integer, intent(in) :: mincnt, norder integer, intent(in) :: gt double precision, intent(in) :: thresh type (ped_data) :: dataset double precision, intent(out) :: pval integer, intent(in) :: plevel ! local variables integer, parameter :: KNOWN=0, MISS=-9999 ! ! array for allele counts in cases and controls ! integer, dimension(dataset%nobs) :: aff integer, dimension(dataset%maxsiz,2) :: set ! type (allele_data) :: allele_buffer ! homozygosity analysis -- limited to cases integer :: ehomoz, homoz, nca integer :: g1, g2, gen2, i, it, n, ped, pedoffset, tailp character (len=3) :: histo double precision :: asyp, chisq, den, ef, expp, fcoeff, obs, ochisq, zstat ! extreme tail empirical P values integer :: ntopvals double precision, dimension(norder+2) :: topvals ! functions character (len=6) :: corstring, pstring double precision :: binz, evdtailp, isaff interface subroutine freq(gene, loctyp, fndr, dataset, allele_buffer) use ped_class use alleles_class integer, intent(in) :: gene integer, intent(in) :: loctyp integer, intent(in) :: fndr type (ped_data), intent(in) :: dataset type (allele_data), intent(inout) :: allele_buffer end subroutine freq subroutine simped(ped, dataset, allele_buffer, set) use alleles_class use ped_class integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data), intent(in) :: allele_buffer integer, dimension(:,:), intent(out) :: set end subroutine simped subroutine xsimped(ped, dataset, allele_buffer, set) use alleles_class use ped_class integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data), intent(in) :: allele_buffer integer, dimension(:,:), intent(out) :: set end subroutine xsimped end interface call setup_freq(10, allele_buffer) call freq(gene, genetyp, freqfnd, dataset, allele_buffer) asyp=1.0d0 expp=0.0D0 ntopvals = norder+2 topvals=0.0d0 gen2=gene+1 homoz=0 it=0 nca=0 do i=1, allele_buffer%numal expp=expp+ allele_buffer%allele_freqs(i)*allele_buffer%allele_freqs(i) end do do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) n=dataset%num(ped) if (trait == MISS) then do i=pedoffset+1, n aff(i)=2 if (allele_buffer%xlinkd .and. dataset%sex(i) /= 2) aff(i)=MISS end do else do i=pedoffset+1, n aff(i)=int(isaff(dataset%plocus(i,trait),thresh,gt)) if (allele_buffer%xlinkd .and. dataset%sex(i) /= 2) aff(i)=miss end do end if do i=pedoffset+1, n dataset%untyped(i)=.false. if (.not.observed(i, gene, dataset)) then dataset%untyped(i)=.true. else if (aff(i) == 2) then nca=nca+1 call get_geno(i, gene, gen2, dataset, g1, g2) if (g1 == g2) homoz=homoz+1 end if end do end if end do if (nca > 0) then den=1.0d0/dble(nca) obs=den*dble(homoz) if (expp < 1.0d0) then fcoeff=(obs-expp)/(1.0d0-expp) else fcoeff=1.0d0 end if gen_nloci=gen_nloci+1 gen_h0=gen_h0+1.0d0-obs gen_hs=gen_hs+1.0d0-expp zstat=binz(homoz, nca, expp) ochisq=zstat*zstat asyp=chip(ochisq, 1) else obs=0.0d0 fcoeff=0.0d0 end if ! ! if iter=0 or nca=0, Monte-Carlo procedure superfluous ! if (iter > 0 .and. nca > 0 .and. allele_buffer%numal > 1) then ! ! Sequential Monte-Carlo P-value after Besag & Clifford Biometrika 1991 ! P= tailp/it if tailp=mincnt or (tailp+1)/(it+1) if tailp<mincnt && it=iter ! it=0 tailp=0 do while (it < iter .and. tailp < mincnt) it=it+1 ehomoz=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) if (allele_buffer%xlinkd) then call xsimped(ped, dataset, allele_buffer, set) else call simped(ped, dataset, allele_buffer, set) end if do i=pedoffset+1, dataset%num(ped) if (.not.dataset%untyped(i) .and. aff(i) == 2 .and. & set(i-pedoffset,1)==set(i-pedoffset,2)) then ehomoz=ehomoz+1 end if end do end if end do chisq=binz(ehomoz, nca, expp) chisq=chisq*chisq ef=abs((den*dble(ehomoz)-expp)/(1.0d0-expp)) if (chisq > ochisq .or. (chisq == ochisq .and. random() > 0.5)) then tailp=tailp+1 end if topvals(1)=chisq call dsort(ntopvals,topvals) if (plevel > 1) then write(outstr,'(/a,i8,a,i5)') 'Pseudosample ',it,': No. homoz=',ehomoz end if end do if (tailp < mincnt) then tailp=tailp+1 it=it+1 end if pval=evdtailp(tailp, it, ntopvals, topvals, ochisq) else pval=1.0d0 end if if (plevel > 1) then write(outstr,'(/a/11(1x,f6.1):)') ' Top simulated chi-sqs:', & topvals(2:ntopvals) write(outstr,'(/a/a)') & 'Marker N Obs Exp Fis Z Asy P Emp P Iters', & '-------------------- ------ ------ ------ ------ ------ ------ ------ --------' end if if (plevel > -2) then call phist(pval,pval,histo) write(outstr,'(a20,a1,i6,2(a1,f6.4),a1,a6,a1,f6.1,2(a1,a),a1,i8,2(a1,a))') & locnam, tabsep, nca, tabsep, obs, tabsep, expp, tabsep, & corstring(fcoeff), tabsep, zstat, tabsep, & pstring(asyp), tabsep, pstring(pval), tabsep, it, tabsep, & 'HOM', tabsep, histo end if if (iter == 0) pval=asyp end subroutine dohomoz ! ! perform Haseman-Elston sib-pair regression: univariate ! using squared difference or centred cross-product ! and ibds estimated from the entire sibship ! if missing parental genotypes ! ! typ ! 1 Original Haseman-Elston ! 2 Haseman-Elston II ! 3 Sham and Purcell ! 4 Visscher and Hopper ! subroutine sibpair(tranam, trait, locnam, gene, mappos, typ, & sibm, sibr, sibv, mcp, iter, mincnt, weight, & dataset, allele_buffer, pval, plevel) use outstream use alleles_class use ped_class use rngs use statfuns use AS164 implicit none character(len=*), intent(in) :: tranam integer, intent(in) :: trait character (len=*), intent(in) :: locnam integer, intent(in) :: gene double precision, intent(in) :: mappos integer, intent(in) :: typ double precision, intent(in) :: sibm, sibr, sibv logical, intent(in) :: mcp integer, intent(in) :: iter integer, intent(in) :: mincnt integer, intent(in) :: weight type (ped_data) :: dataset type (allele_data), intent(inout) :: allele_buffer double precision, intent(out) :: pval integer, intent(in) :: plevel ! ! work arrays ! ! listofpairs: list of fullsib and halfsib pairs ! col 1 pairtype (1=f, 2=h) ! col 2 first sib of sibship or first sib of halfsib pair ! col 3 last sib of sibship or second sib of halfsib pair ! ibd: ibds for current sibship ! integer, parameter :: KNOWN=0, MISS=-9999 integer, dimension(:,:), allocatable :: listofpairs double precision, dimension(:), allocatable :: ibd integer, dimension(dataset%nobs,2), target :: set ! pedigree sized set for nucibd integer :: psta, pfin integer, dimension(:,:), pointer :: pset ! integer :: bigship, contrib, df, famdf, fsdf, g1, g2, gen2, hsibs, & i, ii, it, j, k, nuntyp, ped, pedoffset, pos, sibs, ship integer :: commp, currf, currm, fin, nfam, npairs, nped, sta, tailp logical :: last, mhs, phs character (len=3) :: histo character (len=10) :: cmap double precision :: ibd_hs ! regression results integer :: afail, bfail, vfail double precision :: x(4), r(10), b(3), cov(10) double precision :: asyp, beta, denf1, denf2, denh1, denh2, kf, kh, & mub, mux, muy, muy2, oalpha, obeta, rf, rh, & rf0, rh0, sdb, sea, seb, tvalb, vay, wt, y1, y2, ycf, ych ! Score test of Szatkiewicz et al double precision :: aconst, aden, anum, ascore, aterm ! required by Visscher & Hopper double regression double precision :: rs(10), vd, vs, wt_vh, ys ! required by Szatkiewicz and Feingold Robust Discordant Pairs Test double precision :: pivar, rdp, rdpnum, rdpden ! functions ! probst, zp integer :: getnam character (len=6) :: pstring double precision :: hibd, regwt interface subroutine nucibd(gene, setoffset, fa, mo, sta, fin, set, untyped, allele_buffer, ibd) use alleles_class integer, intent(in) :: gene integer, intent(in) :: setoffset integer, intent(in) :: fa, mo integer, intent(in) :: sta, fin integer, dimension(:,:), intent(in) :: set logical, dimension(:), intent(in) :: untyped type (allele_data), intent(in) :: allele_buffer double precision, dimension(:), intent(inout) :: ibd end subroutine nucibd subroutine simped(ped, dataset, allele_buffer, set) use alleles_class use ped_class integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data), intent(in) :: allele_buffer integer, dimension(:,:), intent(out) :: set end subroutine simped end interface pval=1.0d0 tvalb=0.0d0 gen2=gene+1 cmap=' ' nfam=0 hsibs=0 sibs=0 if (plevel > 0) then write(outstr,'(/a/5a/a/)') & '-----------------------------------------------', & ' H-E analysis for "',trim(tranam),'" v. "',trim(locnam),'"', & '-----------------------------------------------' end if ! ! Obtain trait mean, sib and half-sib trait correlations ! Note that sibcor zeroes the correlations ! Use the number of pairs as an upper bound for allocating storage ! if (sibr /= MISS) then call sibcor(trait, 1, dataset, muy, vay, rf, rh, npairs, bigship, plevel) rf=sibr rh=0.5d0*rf if (sibm /= MISS) muy=sibm if (sibv /= MISS) vay=sibv else call sibcor(trait, typ, dataset, muy, vay, rf, rh, npairs, bigship, plevel) end if if (npairs == 0 .or. allele_buffer%numal < 2) then if (plevel > 0) then write(outstr,'(/a,i5,a,i5,a/a,i5)') & 'No. full-sib pairs = ',sibs, ' (in ', nfam, ' sibships)', & 'No. half-sib pairs = ',hsibs if (npairs==0) then write(outstr,'(a)') 'No usable pairs for sib-pair linkage analysis.' else write(outstr,'(3a)') 'Marker "', trim(locnam), '" is uninformative.' end if else if (mappos /= MISS) then write(cmap,'(f10.3)') mappos end if write(outstr,'(a14,2(1x,i6),1x,a10,2(1x,a6),1x,a6,2(1x,a))') & locnam, sibs, hsibs, '-', '-', '-', '-', 'H-E . ', cmap end if return end if muy2=muy+muy rf0=max(0.0d0,rf) rh0=max(0.0d0,rh) denf1=1.0d0/(1.0d0+rf0)**2 denf2=1.0d0/(1.0d0-rf0)**2 denh1=1.0d0/(1.0d0+rh0)**2 denh2=1.0d0/(1.0d0-rh0)**2 ycf=4.0d0*rf0/(1.0d0-rf0*rf0) ych=4.0d0*rh0/(1.0d0-rh0*rh0) kf=4.0d0*(1.0d0+rf0*rf0)/(1.0d0-rf0*rf0)**2 kh=4.0d0*(1.0d0+rh0*rh0)/(1.0d0-rh0*rh0)**2 ! RDP test rdp=0.0d0 rdpnum=0.0d0 rdpden=0.0d0 pivar=0.0d0 ! Score test ascore=0.0d0 anum=0.0d0 aden=0.0d0 aconst=4.0d0*rf0*denf2 ! ! list of fullsib and halfsib pairs and ibds ! allocate(listofpairs(npairs,3)) allocate(ibd(bigship*(bigship+1)/2)) ship=0 ! ! move through sib pairs ! df=0 fsdf=0 nped=0 mux=0.0d0 call inicov(4, 10, r) call inicov(4, 10, rs) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then nped=nped+1 pedoffset=dataset%num(ped-1) i=0 ! record if typed in untyped() do ii=pedoffset+1, dataset%num(ped) i=i+1 if (observed(ii, gene, dataset)) then dataset%untyped(ii)=.false. call get_namedgeno(ii, gene, gen2, dataset, allele_buffer, & set(i,1), set(i,2)) else dataset%untyped(ii)=.true. set(i,1)=MISS set(i,2)=MISS end if end do ! ! Full sibs ! famdf=0 fin=dataset%num(ped) currf=dataset%fa(fin) currm=dataset%mo(fin) do k=dataset%num(ped)-1, pedoffset+dataset%nfound(ped), -1 if (dataset%fa(k) /= currf .or. dataset%mo(k) /= currm) then nfam=nfam+1 contrib=0 do i=k+1, fin if (dataset%plocus(i,trait) /= MISS .and. .not.dataset%untyped(i)) then contrib=contrib+1 end if end do ! Skip if no usable full sib pairs in this sibship if (contrib > 1) then df=df+contrib-1 fsdf=fsdf+contrib-1 famdf=famdf+contrib-1 ship=ship+1 listofpairs(ship,1)=1 listofpairs(ship,2)=k+1 listofpairs(ship,3)=fin call nucibd(gene, pedoffset, currf, currm, k+1, fin, & set, dataset%untyped, allele_buffer, ibd) pos=0 do i=k+1, fin y1=dataset%plocus(i,trait) do j=k+1, i-1 y2=dataset%plocus(j,trait) pos=pos+1 if (y1 /= MISS .and. y2 /= MISS .and. & .not.dataset%untyped(i) .and. .not.dataset%untyped(j)) then sibs=sibs+1 wt=regwt(weight, i, j, dataset) x(1)=1.0d0 x(2)=0.0d0 x(3)=ibd(pos) aterm=(denf1*(y1+y2-muy2)**2 - denf2*(y1-y2)**2)/vay if (typ == 3) then x(3)=kf*(x(3)-0.5d0) x(4)=ycf+aterm else if (typ == 2) then x(4)=(y1-muy)*(y2-muy) else x(4)=(y1-y2)**2 end if anum=anum+aterm*(ibd(pos)-0.5d0) aden=aden+aterm*aterm rdpnum=rdpnum+(y1-y2)**2 * (0.5d0-ibd(pos)) rdpden=rdpden+(y1-y2)**4 pivar=pivar + ibd(pos)*(1.0d0-ibd(pos)) mux=mux+ibd(pos) if (plevel > 1) then write(outstr,*) trim(dataset%pedigree(ped)), ' ', & trim(dataset%id(i)), ' ', trim(dataset%id(j)), & y1, y2, ibd(pos), x(2) end if call givenc(r, 10, 4, x, wt, afail) if (typ == 4) then x(1)=1.0d0 x(2)=0.0d0 x(3)=ibd(pos) x(4)=(y1+y2-muy2)**2 call givenc(rs, 10, 4, x, wt, afail) end if end if end do ! and now skip the self-correlation (that VC approach does use) pos=pos+1 end do end if ! ! half-sibs related to current sibship -- only scan sibships not yet visited ! stored in different style to full sibs ! skip if no usable individuals in this sibship ! if (contrib>0) then do i=pedoffset+dataset%nfound(ped)+1, k phs=(dataset%fa(i) == currf) mhs=(dataset%mo(i) == currm) if ((phs .or. mhs) .and. & dataset%plocus(i,trait) /= MISS .and. .not.dataset%untyped(i)) then df=df+1 y1=dataset%plocus(i,trait) do j=k+1, fin if (dataset%plocus(j,trait) /= MISS .and. .not.dataset%untyped(j)) then y2=dataset%plocus(j,trait) hsibs=hsibs+1 ship=ship+1 listofpairs(ship,1)=2 listofpairs(ship,2)=i listofpairs(ship,3)=j wt=regwt(weight, i, j, dataset) x(1)=1.0d0 x(2)=1.0d0 if (typ == 3) then x(4)=ych+(denh1*(y1+y2-muy2)**2 - denh2*(y1-y2)**2)/vay else if (typ == 2) then x(4)=(y1-muy)*(y2-muy) else x(4)=(y1-y2)**2 end if if (phs) then x(3)=hibd(set(i-pedoffset,1), set(i-pedoffset,2), & set(j-pedoffset,1), set(j-pedoffset,2), & set(dataset%mo(i)-pedoffset,1), set(dataset%mo(i)-pedoffset,2), & set(dataset%fa(i)-pedoffset,1), set(dataset%fa(i)-pedoffset,2), & set(dataset%mo(j)-pedoffset,1), set(dataset%mo(j)-pedoffset,2)) if (typ == 4) then ibd_hs=x(3) ys=(y1+y2-muy2)**2 end if else x(3)=hibd(set(i-pedoffset,1), set(i-pedoffset,2), & set(j-pedoffset,1), set(j-pedoffset,2), & set(dataset%fa(i)-pedoffset,1), set(dataset%fa(i)-pedoffset,2), & set(dataset%mo(i)-pedoffset,1), set(dataset%mo(i)-pedoffset,2), & set(dataset%fa(j)-pedoffset,1), set(dataset%fa(j)-pedoffset,2)) if (typ == 4) then ibd_hs=x(3) ys=(y1+y2-muy2)**2 end if end if if (plevel > 1) then write(outstr,*) trim(dataset%pedigree(ped)), ' ', & trim(dataset%id(i)), ' ', trim(dataset%id(j)), y1, y2, x(3), x(2) end if if (typ == 3) x(3)=kh*(x(3)-0.25d0) call givenc(r, 10, 4, x, wt, afail) if (typ == 4) then x(1)=1.0d0 x(2)=1.0d0 x(3)=ibd_hs x(4)=ys call givenc(rs, 10, 4, x, wt, afail) end if end if end do end if end do end if ! Now update to next sibship fin=k currf=dataset%fa(fin) currm=dataset%mo(fin) end if end do end if end do ! ! fitting intercept=0 ! if (typ == 3) then x(1)=1.0d0 x(2)=0.0d0 x(3)=0.0d0 x(4)=0.0d0 call givenc(r, 10, 4, x, 0.0d0, afail) end if if (df > 0) then mux=mux/dble(sibs) call alias(r, 10, 4, 1.0d-15, x, afail) call bsub(r, 10, 4, b, 3, bfail) call var(r, 10, cov, 10, 4, sibs+hsibs, 1, vfail) oalpha=b(1) sea=sqrt(cov(1)) obeta=b(3) seb=sqrt(cov(6)) if (typ == 4) then vd=1.0d0/cov(6) call alias(rs, 10, 4, 1.0d-15, x, afail) call bsub(rs, 10, 4, b, 3, bfail) call var(rs, 10, cov, 10, 4, sibs+hsibs, 1, vfail) vs=1.0d0/cov(6) wt_vh=vd/(vd+vs) obeta=0.5d0*((1.0d0-wt_vh)*b(3)-wt_vh*obeta) seb=0.5d0*sqrt(wt_vh)*seb end if if (seb > 0.0d0) tvalb=obeta/seb if (afail > 0 .or. bfail > 0 .or. vfail > 0) then write(outstr,'(/a,3(/7x,a,i3))') & 'ERROR: Problem in regression (AS164) subroutines.', & 'Aliasing Ifail=',afail, 'Backsub Ifail=',bfail, & 'Variance Ifail=',vfail end if df=df-2 if (typ == 3) df=df+1 if (typ > 1) then asyp=1.0d0-probst(tvalb,df,afail) else asyp=probst(tvalb,df,afail) end if if (fsdf > 0) then ascore=anum/sqrt(aden*(0.25d0-pivar/dble(sibs))) rdp=rdpnum/sqrt(rdpden*(0.25d0-pivar/dble(sibs))) end if else mux=0.0d0 oalpha=0.0d0 sea=0.0d0 obeta=0.0d0 seb=0.0d0 tvalb=0.0d0 df=0 asyp=1.0d0 end if ! ! MC P-value estimation ! it=0 tailp=0 mub=0.0D0 sdb=0.0D0 if (.not.mcp .or. iter == 0 .or. df < 1) then pval=1.0d0 else ! ! Now can simulate genotypes and do sequential P-value simulation ! do while (it < iter .and. tailp < mincnt) it=it+1 call inicov(4, 10, r) call inicov(4, 10, rs) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then psta=dataset%num(ped-1)+1 pfin=dataset%num(ped) pset => set(psta:pfin, 1:2) call simped(ped, dataset, allele_buffer, pset) do i=psta, pfin if (dataset%untyped(i)) then set(i,1)=MISS set(i,2)=MISS end if end do end if end do ! read list of sibships do k=1, ship if (listofpairs(k,1)==1) then sta=listofpairs(k,2) fin=listofpairs(k,3) call nucibd(gene, 0, dataset%fa(sta), dataset%mo(sta), & sta, fin, set, dataset%untyped, allele_buffer, ibd) pos=0 do i=sta, fin do j=sta, i-1 pos=pos+1 if (dataset%plocus(j, trait) /= MISS .and. & .not.dataset%untyped(j) .and. & dataset%plocus(i, trait) /= MISS .and. & .not.dataset%untyped(i)) then y1=dataset%plocus(i, trait) y2=dataset%plocus(j, trait) wt=regwt(weight, i, j, dataset) x(1)=1.0d0 x(2)=0.0d0 x(3)=ibd(pos) if (typ == 3) then x(3)=kf*(x(3)-0.5d0) x(4)=ycf+aterm else if (typ == 2) then x(4)=(y1-muy)*(y2-muy) else x(4)=(y1-y2)**2 end if call givenc(r, 10, 4, x, wt, afail) if (typ == 4) then x(1)=1.0d0 x(2)=0.0d0 x(3)=ibd(pos) x(4)=(y1+y2-muy2)**2 call givenc(rs, 10, 4, x, wt, afail) end if end if end do pos=pos+1 end do else i=listofpairs(k, 2) j=listofpairs(k, 3) if (dataset%fa(i)==dataset%fa(j)) then commp=dataset%fa(i) currf=dataset%mo(i) currm=dataset%mo(j) else commp=dataset%mo(i) currf=dataset%fa(i) currm=dataset%fa(j) end if y1=dataset%plocus(i, trait) y2=dataset%plocus(j, trait) wt=regwt(weight, i, j, dataset) x(1)=1.0d0 x(2)=1.0d0 x(3)=hibd(set(i-pedoffset,1), set(i-pedoffset,2), & set(j-pedoffset,1), set(j-pedoffset,2), & set(currf-pedoffset,1), set(currf-pedoffset,2), & set(commp-pedoffset,1), set(commp-pedoffset,2), & set(currm-pedoffset,1), set(currm-pedoffset,2)) if (typ == 3) then x(3)=kh*(x(3)-0.25d0) x(4)=ych+(denh1*(y1+y2-muy2)**2 - denh2*(y1-y2)**2)/vay else if (typ == 2) then x(4)=(y1-muy)*(y2-muy) else x(4)=(y1-y2)**2 ibd_hs=x(3) ys=(y1+y2-muy2)**2 end if call givenc(r, 10, 4, x, wt, afail) if (typ == 4) then x(1)=1.0d0 x(2)=1.0d0 x(3)=ibd_hs x(4)=ys call givenc(rs, 10, 4, x, wt, afail) end if end if end do ! no intercept model if (typ == 3) then x(1)=1.0d0 x(2)=0.0d0 x(3)=0.0d0 x(4)=0.0d0 call givenc(r, 10, 4, x, 0.0d0, afail) end if call alias(r, 10, 4, 1.0d-15, x, afail) call bsub(r, 10, 4, b, 3, bfail) beta=b(3) if (typ == 4) then call alias(rs, 10, 4, 1.0d-15, x, afail) call bsub(rs, 10, 4, b, 3, bfail) beta=0.5d0*((1.0d0-wt_vh)*b(3)-wt_vh*beta) end if call moment(it, beta, mub, sdb) if ((typ == 1 .and. beta < obeta) .or. (typ > 1 .and. beta > obeta) .or. & (beta == obeta .and. random() > 0.5d0)) then tailp=tailp+1 end if if (plevel > 1) then write(outstr,'(a,i8,a,g12.4,a,2i3)') & 'Pseudosample ',it,': Beta=', beta, ' Ifail=',afail, bfail end if end do if (tailp < mincnt) then tailp=tailp+1 it=it+1 end if sdb=sqrt(sdb/dble(max(1,it-1))) pval=dble(tailp)/dble(it) end if if (plevel > 0) then write(outstr,'(/a,i5,a,i5,a/a,i5/a,f5.3)') & 'No. full-sib pairs = ',sibs, ' (in ', nfam, ' sibships)', & 'No. half-sib pairs = ',hsibs, & 'Mean full-sib ibd = ', mux write(outstr,'(a,g10.4,a,g10.4,a/a,g10.4,a,g10.4,a)') & 'Intercept (f-s) = ',oalpha,' (ase=', sea,')', & 'Slope = ',obeta, ' (ase=', seb,')' write(outstr,'(a,g10.4,a,i4,3a)') & 't value = ',tvalb,' (df=',df, ', P=', trim(pstring(asyp)) ,')' write(outstr,'(/a,i0,a,i0,3a/a,g12.4,a,g12.4,a)') & 'Equalled or exceeded by =',tailp,'/',it, ' simulated values (', & trim(pstring(pval)), ')', & 'Mean (SD) simulated Beta=',mub,' (',sdb,')' ! Score and RDP test write(outstr,'(/a,g10.4,3a)') & 'Score test (f-s) = ',ascore,' (P=', trim(pstring(zp(ascore))) ,')' write(outstr,'(a,g10.4,3a)') & 'Robust Disc Pair t = ',rdp,' (P=', trim(pstring(zp(rdp))),')' else call phist(asyp,pval,histo) if (mappos /= MISS) then write(cmap,'(g10.3)') mappos end if write(outstr,'(a20,2(1x,i6),1x,g10.1,2(1x,a),1x,i6,2(1x,a),1x,a10)') & locnam, sibs, hsibs, tvalb, pstring(asyp), pstring(pval), it, 'H-E',histo, cmap end if if (.not.mcp .or. iter == 0) pval=asyp deallocate(ibd) deallocate(listofpairs) end subroutine sibpair ! ! Estimate sibling and half-sib intraclass correlations ! subroutine sibcor(trait, typ, dataset, muy, vay, rf, rh, npairs, bigship, plevel) use outstream use ped_class implicit none integer, intent(in) :: trait integer, intent(in) :: typ type (ped_data) :: dataset double precision, intent(inout) :: muy, vay, rf, rh integer, intent(inout) :: bigship integer, intent(inout) :: npairs integer, intent(in) :: plevel ! local variables integer, parameter :: MISS=-9999 integer :: hsibs, i, j, k, n, nsibs, ped, pedoffset, sibs integer :: currf, currm, fin double precision :: y1, y2 logical :: last, mhs, phs bigship=0 hsibs=0 n=0 npairs=0 sibs=0 ! ! Mean and variance of trait in nonfounders ! muy=0.0d0 vay=0.0d0 rf=0.0d0 rh=0.0d0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+dataset%nfound(ped)+1, dataset%num(ped) if (dataset%plocus(i,trait) /= MISS) then n=n+1 call moment(n, dataset%plocus(i,trait), muy, vay) end if end do end if end do vay=vay/dble(max(1,n-1)) ! ! then through by sibships and half-sibships ! do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) fin=dataset%num(ped) currf=dataset%fa(fin) currm=dataset%mo(fin) do k=dataset%num(ped)-1, pedoffset+dataset%nfound(ped), -1 if (dataset%fa(k) /= currf .or. dataset%mo(k) /= currm) then bigship=max(bigship, fin-k) do i=k+1, fin-1 if (dataset%plocus(i,trait) /= MISS) then y1=dataset%plocus(i,trait) do j=i+1, fin if (dataset%plocus(j,trait) /= MISS) then sibs=sibs+1 y2=dataset%plocus(j,trait) rf=rf+(y1-muy)*(y2-muy) end if end do end if end do ! half-sibs related to current sibship do i=pedoffset+dataset%nfound(ped)+1, k phs=(dataset%fa(i) == currf) mhs=(dataset%mo(i) == currm) if ((phs .or. mhs) .and. dataset%plocus(i,trait) /= MISS) then y1=dataset%plocus(i,trait) do j=k+1, fin if (dataset%plocus(j,trait) /= MISS) then hsibs=hsibs+1 y2=dataset%plocus(j,trait) rh=rh+(y1-muy)*(y2-muy) end if end do end if end do ! Now update to next sibship fin=k currf=dataset%fa(fin) currm=dataset%mo(fin) end if end do end if end do rf=rf/dble(max(1,sibs-1))/vay rh=rh/dble(max(1,hsibs-1))/vay if (plevel > 0) then write(outstr,'(a,f10.4,a,f10.4,a)') & 'Trait mean (nonfo) = ', muy, ' (SD=', sqrt(vay),')' if (typ > 1) then write(outstr,'(a,f5.3,a,i5,a/a,f5.3,a,i5,a)') & 'Sibling r = ',rf,' (',sibs,' pairs)', & 'Half-sib r = ',rh,' (',hsibs,' pairs)' if (rh <= 0.0d0) then write(outstr,'(a,f5.3)') 'Working half-sib r = ', 0.5D0*rf end if end if end if if (rh <= 0.0d0) rh=0.5d0*rf npairs=sibs+hsibs end subroutine sibcor ! ! Routines to calculate ibd sharing using full sibship information ! where parent(s) untyped. ! ! ibd(1..nsib*(nsib+1)/2) ! prall(5) probs for 1..4 observed alleles plus all others ! ! 1. enumerate alleles segregating among children ! 2. generate short list of genotypes for parents ! 3. sum up ibd sharing for each pair of sibs for each genotype freq ! subroutine nucibd(gene, setoffset, fa, mo, sta, fin, set, untyped, allele_buffer, ibd) use outstream use alleles_class integer, intent(in) :: gene integer, intent(in) :: setoffset integer, intent(in) :: fa, mo integer, intent(in) :: sta, fin integer, dimension(:,:), intent(in) :: set logical, dimension(:), intent(in) :: untyped type (allele_data), intent(in) :: allele_buffer double precision, dimension(:), intent(inout) :: ibd integer, parameter :: KNOWN=0, MISS=-9999 ! count of segregating alleles, and frequency integer :: nall, allele(5) double precision :: prall(5) ! other local variables integer :: g1, g2, g3, g4 integer :: gen2, i, j, nind, npairs, mg1, mg2, pg1, pg2, pos integer :: i1, i2, t1, t2 ! offset parental and child addresses integer :: cfa, cfin, cmo, csta logical :: con, xmale double precision :: lik, totp ! functions integer :: parcon double precision :: shibd interface function whall(iall,nall,allele) integer whall integer, intent(in) :: iall integer, intent(in) :: nall integer, intent(in) :: allele(:) end function whall end interface xmale=.false. cfa=fa-setoffset cmo=mo-setoffset csta=sta-setoffset cfin=fin-setoffset gen2=gene+1 pos=0 ptyped=0 if (.not.untyped(fa)) then ptyped=ptyped+1 pg1=set(cfa,1) pg2=set(cfa,2) end if if (.not.untyped(mo)) then ptyped=ptyped+2 mg1=set(cmo,1) mg2=set(cmo,2) end if if (ptyped == 3) then do i=csta, cfin do j=csta, i-1 pos=pos+1 ibd(pos)=shibd(set(i,1),set(i,2),set(j,1),set(j,2), pg1, pg2, mg1, mg2) end do pos=pos+1 ibd(pos)=1.0d0 end do return end if ! ! else sum over all possible parental genotypes ! nall=0 if (ptyped == 1) then call addall(pg1, nall, 5, allele) call addall(pg2, nall, 5, allele) else if (ptyped == 2) then call addall(mg1, nall, 5, allele) call addall(mg2, nall, 5, allele) end if do i=csta, cfin if (.not.untyped(setoffset+i)) then call addall(set(i,1), nall, 5, allele) call addall(set(i,2), nall, 5, allele) end if end do nind=fin-sta+1 npairs=nind*(nind+1)/2 ! first check if (nall > 4) then write(outstr,'(a)') 'ERROR: Mendelian inconsistency detected.' call filltri(nind, npairs, ibd, 1.0d0,0.5d0) return end if ! else continue call filltri(nind, npairs, ibd, 1.0d0, 0.0d0) nall=nall+1 allele(nall)=0 prall(nall)=1.0d0 do i=1,nall-1 prall(i)=allele_buffer%allele_freqs(allele(i)) prall(nall)=prall(nall)-prall(i) end do ! ! While loop to list all possible genotypes ! initialize genotype indices ! if (ptyped == 1) then t1=1 i1=1 g1=whall(pg1, nall, allele) g2=whall(pg2, nall, allele) else t1=nall*(nall+1)/2 i1=0 g1=1 g2=0 end if if (ptyped == 2) then t2=1 i2=1 g3=whall(mg1, nall, allele) g4=whall(mg2, nall, allele) else t2=nall*(nall+1)/2 i2=t2 g3=1 g4=0 end if ! ! simulated nested do-loops ! check if inner loop completed once ! totp=0.0d0 do if (i2 == t2) then call couple(i1,t1,nall,g1,g2) pg1=allele(g1) pg2=allele(g2) if (t2 > 1) i2=0 end if call couple(i2,t2,nall,g3,g4) mg1=allele(g3) mg2=allele(g4) ! inconsistent constellations lik=0 con=.true. do i=csta, cfin if (.not.untyped(setoffset+i) .and. & parcon(set(i,1), set(i,2), pg1, pg2, mg1, mg2, xmale) == 0) then con=.false. exit end if end do ! ! if consistent calculate likelihood ! ! L = Pr(G) = Pr(Children & Parents) = Pr(P) Pr(C|P) ! = Prod{ Pr(P_j) } Prod { Pr(C_i | Father_i Mother_i } ! if (con) then lik=prall(g1)*prall(g2)*prall(g3)*prall(g4) if (g1 /= g2) lik=lik+lik if (g3 /= g4) lik=lik+lik do i=csta, cfin if (.not.untyped(setoffset+i)) then lik=lik*0.25d0* dble(parcon(set(i,1),set(i,2),pg1,pg2,mg1,mg2,xmale)) end if end do totp=totp+lik pos=0 do i=csta, cfin do j=csta, i-1 pos=pos+1 ibd(pos)=ibd(pos)+ lik*shibd(set(i,1), set(i,2), set(j,1), set(j,2), & pg1, pg2, mg1, mg2) end do pos=pos+1 end do end if if (i1 == t1 .and. i2 == t2) exit end do ! end of until loop ! abort if error else rescale likelihood if (totp == 0.0d0) then write(outstr,'(a)') 'ERROR: Mendelian inconsistency detected.' call filltri(nind, npairs, ibd, 1.0d0, 0.5d0) else totp=1.0d0/totp pos=0 do i=1, nind do j=1, i-1 pos=pos+1 ibd(pos)=min(1.0d0,totp*ibd(pos)) end do pos=pos+1 end do end if end subroutine nucibd ! ! Calculate ibd sharing for full sibs when parental genotypes known ! function shibd(c11, c12, c21, c22, p11, p12, p21, p22) double precision :: shibd integer, intent(in) :: c11, c12, c21, c22 integer, intent(in) :: p11, p12, p21, p22 ! integer, parameter :: KNOWN=0, MISS=-9999 logical :: h1, h2 integer :: nallele, nmiss, cnallele integer :: shared ! overall expectation shibd=0.5d0 ! deal with simplest cases call countall(c11,c12,c21,c22,cnallele,nmiss) if (cnallele == 4 .or.(c11 /= c21 .and. c11 /= c22 .and. & c12 /= c21 .and. c12 /= c22)) then shibd=0.0d0 return end if call countall(p11,p12,p21,p22,nallele,nmiss) h1=.false. h2=.false. if (p11 /= p12) h1=.true. if (p21 /= p22) h2=.true. shared=MISS if (nallele == 3 .and. h1 .and. h2) then shared=p11 if (p11 /= p21 .and. p11 /= p22) shared=p12 end if if (nallele == 4 .or. (nallele == 3 .and. h1.and.h2)) then if (c11 == c21 .and. c12 == c22 ) then shibd=1.0d0 else if (c11 /= c12 .and. c21 /= c22 .and. & (((c11 == c21.or.c11 == c22) .and. c11 == shared ) .or. & ((c12 == c21.or.c12 == c22) .and. c12 == shared ))) then shibd=0.0d0 end if else if (nallele == 3) then shibd=0.25d0 if (c11 == c21 .and. c12 == c22 ) shibd=0.75d0 else if (h1 .and. h2) then if (c11 == c21 .and. c12 == c22) then shibd=1.0d0 if (c11 /= c22) shibd=0.5d0 end if else if (h1 .or. h2) then shibd=0.25d0 if (c11 == c21 .and. c12 == c22) shibd=0.75d0 end if end if end function shibd ! ! Calculate regression weight ! function regwt(weight, i, j, dataset) use ped_class double precision :: regwt integer, intent(in) :: weight integer, intent(in) :: i integer, intent(in) :: j type (ped_data) :: dataset integer, parameter :: MISS=-9999 regwt=1.0d0 if (weight /= MISS) then if (dataset%plocus(i,weight) /= MISS .and. & dataset%plocus(j,weight) /= MISS) then regwt=0.5d0*(dataset%plocus(i,weight)+dataset%plocus(j,weight)) end if end if end function regwt ! ! estimate ibd score for a pair of half-sibs -- parents known ! tabulations of number of genes expected shared ibd ! function hibd(c11, c12, c21, c22, p11, p12, pc1, pc2, p21, p22) double precision hibd integer, intent(in) :: c11 integer, intent(in) :: c12 integer, intent(in) :: c21 integer, intent(in) :: c22 integer, intent(in) :: p11 integer, intent(in) :: p12 integer, intent(in) :: pc1 integer, intent(in) :: pc2 integer, intent(in) :: p21 integer, intent(in) :: p22 integer, parameter :: KNOWN=0 integer :: d, n integer :: ip(6), ic(4) ! IBS=0 added 20051224! if (c11 /= c21 .and. c11 /= c22 .and. c12 /= c21 .and. c12 /= c22) then hibd=0.0d0 return end if hibd=0.25d0 ! if homozygote common parent, no linkage information if (pc1 > KNOWN .and. pc1 == pc2) return d=0 n=0 ic(1)=c11 ic(2)=c12 ic(3)=c21 ic(4)=c22 ip(1)=p11 ip(2)=p12 ip(3)=pc1 ip(4)=pc2 ip(5)=p21 ip(6)=p22 do i1=1,2 do i2=3,4 if ((ic(1) == ip(i1) .and. ic(2) == ip(i2)) .or. & (ic(2) == ip(i1) .and. ic(1) == ip(i2))) then do i3=3,4 do i4=5,6 if ((ic(3) == ip(i3) .and. ic(4) == ip(i4)) .or. & (ic(4) == ip(i3) .and. ic(3) == ip(i4))) then n=n+1 if (i2 == i3) d=d+1 end if end do end do end if end do end do if (n > 0) then hibd=0.5d0*dble(d)/dble(n) end if end function hibd ! ! perform Elston & Keats sib pair linkage analysis ! between two codominant markers ! ! recombination fraction c= 0.5 (1-sqrt(r)) ! where r is the correlation between mean ibd at marker1 and mean ibd at ! marker2 for all sib pairings ! subroutine twopoi(mark1, loc1, mark2, loc2, & allele_buffer1, allele_buffer2, dataset, plevel) use outstream use alleles_class use ped_class implicit none character(len=20), intent(in) :: loc1, loc2 integer, intent(in) :: mark1, mark2 type (ped_data) :: dataset type (allele_data), intent(inout) :: allele_buffer1, allele_buffer2 integer, intent(in) :: plevel ! ! work arrays ! ibd: ibds for current sibship ! integer, parameter :: KNOWN=0, MISS=-9999 double precision, dimension(:), allocatable :: ibd1, ibd2 logical, dimension(dataset%maxsiz) :: untyped, untyp2 integer, dimension(dataset%maxsiz, 2) :: set, set2 ! local variables integer :: bigship, contrib, currf, currm, fin, i, ii, j, k, nfam, & ped, pedoffset, pos, mark12, mark22, sibs double precision :: cov(3), mean(2), r, rhi, rlo, y(2) logical :: last ! functions integer :: getnam double precision :: fishzse, inht, rtheta interface subroutine nucibd(gene, setoffset, fa, mo, sta, fin, set, untyped, allele_buffer, ibd) use alleles_class integer, intent(in) :: gene integer, intent(in) :: setoffset integer, intent(in) :: fa, mo integer, intent(in) :: sta, fin integer, dimension(:,:), intent(in) :: set logical, dimension(:), intent(in) :: untyped type (allele_data), intent(in) :: allele_buffer double precision, dimension(:), intent(inout) :: ibd end subroutine nucibd end interface nfam=0 sibs=0 mark12=mark1+1 mark22=mark2+1 mean(1)=0.0d0 mean(2)=0.0d0 cov(1)=0.0d0 cov(2)=0.0d0 cov(3)=0.0d0 call shipsiz(dataset, bigship) allocate(ibd1(bigship*(bigship+1)/2)) allocate(ibd2(bigship*(bigship+1)/2)) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) i=0 do ii=pedoffset+1, dataset%num(ped) i=i+1 if (observed(ii, mark1, dataset)) then untyped(i)=.false. call get_namedgeno(ii, mark1, mark12, dataset, allele_buffer1, & set(i,1), set(i,2)) else untyped(i)=.true. set(i,1)=MISS set(i,2)=MISS end if if (observed(ii, mark2, dataset)) then untyp2(i)=.false. call get_namedgeno(ii, mark2, mark22, dataset, allele_buffer2, & set2(i,1), set2(i,2)) else untyp2(i)=.true. set2(i,1)=MISS set2(i,2)=MISS end if end do fin=dataset%num(ped) currf=dataset%fa(fin) currm=dataset%mo(fin) do k=dataset%num(ped)-1, pedoffset+dataset%nfound(ped), -1 if (dataset%fa(k) /= currf .or. dataset%mo(k) /= currm) then contrib=0 do i=k+1, fin if (.not.untyped(i-pedoffset) .and. .not.untyp2(i-pedoffset)) then contrib=contrib+1 end if end do ! Skip if no usable individuals in this sibship if (contrib > 0) then nfam=nfam+1 call nucibd(mark1, 0, currf-pedoffset, currm-pedoffset, & k+1-pedoffset, fin-pedoffset, & set, untyped, allele_buffer1, ibd1) call nucibd(mark2, 0, currf-pedoffset, currm-pedoffset, & k+1-pedoffset, fin-pedoffset, & set2, untyp2, allele_buffer2, ibd2) pos=0 do i=k+1, fin do j=k+1, i-1 pos=pos+1 if (.not.untyped(i-pedoffset) .and. .not.untyped(j-pedoffset) .and. & .not.untyp2(i-pedoffset) .and. .not.untyp2(j-pedoffset)) then y(1)=ibd1(pos) y(2)=ibd2(pos) sibs=sibs+1 if (plevel > 1) then write(outstr,'(i5,3(1x,a),2(1x,f6.4))') & sibs, dataset%pedigree(ped), dataset%id(i), dataset%id(j), y(1), y(2) end if call dssp(2, sibs, 1, y, mean, cov) end if end do pos=pos+1 end do end if ! Now update to next sibship fin=k currf=dataset%fa(fin) currm=dataset%mo(fin) end if end do end if end do r=cov(2)/sqrt(cov(1))/sqrt(cov(3)) call fishzci(r, sibs, rlo, rhi) write(outstr,'(a14,1x,a14,2(1x,i8),2(3x,f5.3),1x,f5.3,a,f5.3)') & loc1, loc2, nfam, sibs, r, rtheta(r), rtheta(rhi), '--', rtheta(rlo) end subroutine twopoi ! ! Count alleles in pair of relatives or spouses ! subroutine countall(p1, p2, p3, p4, nallele, nmiss) integer, intent(in) :: p1 integer, intent(in) :: p2 integer, intent(in) :: p3 integer, intent(in) :: p4 integer, intent(out) :: nallele integer, intent(out) :: nmiss integer, parameter :: MISS=-9999 nallele=0 nmiss=0 if (p1 == MISS) then nmiss=1 else nallele=1 end if if (p2 == MISS) then nmiss=nmiss+1 else if (p1 /= p2) then nallele=nallele+1 end if if (p3 == MISS) then nmiss=nmiss+1 else if ((p1 /= p3).and.(p2 /= p3)) then nallele=nallele+1 end if if (p4 == MISS) then nmiss=nmiss+1 else if ((p1 /= p4).and.(p2 /= p4).and.(p3 /= p4)) then nallele=nallele+1 end if end subroutine countall ! ! Do ibs sharing ASP analysis as per Lange 1986 and Bishop 1990 ! subroutine doasp(trait, locnam, gene, gt, thresh, & allele_buffer, dataset, pval, plevel) use outstream use alleles_class use ped_class use statfuns implicit none integer, intent(in) :: trait character (len=*), intent(in) :: locnam integer, intent(in) :: gene integer, intent(inout) :: gt double precision, intent(in) :: thresh type (allele_data), intent(inout) :: allele_buffer type (ped_data) :: dataset double precision, intent(out) :: pval integer, intent(inout) :: plevel ! integer, parameter :: KNOWN=0, MISS=-9999 double precision, dimension(:), allocatable :: ibd integer, dimension(dataset%maxsiz, 2) :: set logical, dimension(dataset%maxsiz) :: untyped ! calculate expected ibs statistics for marker double precision :: p, p2, p4, pp, pq, pq2, q, f(3), h(3) ! 2 df chi-square integer :: tabf(3), tabh(3) double precision :: chif, chih, ef, eh, ex, muf, muh, mux, obs ! integer :: contrib, currf, currm, fin, gen2, i, ii, ibs, j, k, nfs, nhs, pos integer :: bigship, hsibs, nfam, sibs integer :: ped, pedoffset character (len=3) :: histo double precision :: ibsp, zibd logical :: last ! functions ! chip integer :: getnam character (len=6) :: pstring double precision :: isaff interface subroutine nucibd(gene, setoffset, fa, mo, sta, fin, set, untyped, allele_buffer, ibd) use alleles_class integer, intent(in) :: gene integer, intent(in) :: setoffset integer, intent(in) :: fa, mo integer, intent(in) :: sta, fin integer, dimension(:,:), intent(in) :: set logical, dimension(:), intent(in) :: untyped type (allele_data), intent(in) :: allele_buffer double precision, dimension(:), intent(inout) :: ibd end subroutine nucibd end interface ! muf=0.0D0 muh=0.0D0 mux=0.0D0 do i=1, 3 tabf(i)=0 tabh(i)=0 end do gen2=gene+1 ! Calculate expected values for ibs statistic p2=0.0D0 p4=0.0D0 pp=0.0D0 pq2=0.0D0 do i=1, allele_buffer%numal p=allele_buffer%allele_freqs(i) q=1.0D0-p p=p*p q=q*q p2=p2+p pq2=pq2+p*q p4=p4+p*p do j=i+1, allele_buffer%numal p=allele_buffer%allele_freqs(i) q=allele_buffer%allele_freqs(j) pq=1.0d0-p-q pp=pp+p*q*pq*pq end do end do f(3)=0.25d0*(1.0d0+2.0d0*p2*(1.0d0+p2)-p4) f(1)=0.25d0*(pq2+pp+pp) f(2)=1.0d0-f(3)-f(1) ef=f(3)+0.5d0*f(2) h(3)=0.5d0*(p2*(1.0d0+p2+p2)-p4) h(1)=2.0d0*f(1) h(2)=1.0d0-h(3)-h(1) eh=h(3)+0.5d0*h(2) call shipsiz(dataset, bigship) allocate(ibd(bigship*(bigship+1)/2)) ! do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) i=0 do ii=pedoffset+1, dataset%num(ped) i=i+1 if (observed(ii, gene, dataset)) then dataset%untyped(ii)=.false. call get_namedgeno(ii, gene, gen2, dataset, allele_buffer, & set(i,1), set(i,2)) else dataset%untyped(ii)=.true. set(i,1)=MISS set(i,2)=MISS end if end do ! only iterate nonfounders -- sibship by sibship fin=dataset%num(ped) currf=dataset%fa(fin) currm=dataset%mo(fin) do k=dataset%num(ped)-1, pedoffset+dataset%nfound(ped), -1 if (dataset%fa(k) /= currf .or. dataset%mo(k) /= currm) then nfam=nfam+1 contrib=0 do i=k+1, fin if (dataset%plocus(i,trait) /= MISS .and. .not.dataset%untyped(i)) then contrib=contrib+1 end if end do ! ! Skip if no usable individuals in this sibship ! if (contrib > 0) then call nucibd(gene, pedoffset, currf, currm, k+1, fin, & set, dataset%untyped, allele_buffer, ibd) pos=0 do i=k+1, fin do j=k+1, i-1 pos=pos+1 if (isaff(dataset%plocus(i,trait), thresh, gt) == 2.0 .and. & isaff(dataset%plocus(j,trait), thresh, gt) == 2.0 .and. & .not.dataset%untyped(i) .and. .not.dataset%untyped(j)) then sibs=sibs+1 call sshare(set(i-pedoffset,1), set(i-pedoffset,2), & set(j-pedoffset,1), set(j-pedoffset,2), zibd) ibs=int(2.0d0*zibd)+1 mux=mux+ibd(pos) tabf(ibs)=tabf(ibs)+1 end if end do pos=pos+1 end do ! ! half-sibs related to current sibship -- only scan sibships not yet visited ! stored in different style to full sibs ! do i=pedoffset+dataset%nfound(ped)+1, k if (dataset%fa(i) == currf .or. dataset%mo(i) == currm .and. & isaff(dataset%plocus(i,trait),thresh,gt) == 2.0 .and. & .not.dataset%untyped(i)) then contrib=contrib+1 do j=k+1, fin if (isaff(dataset%plocus(j,trait),thresh,gt) == 2.0 .and. & .not.dataset%untyped(j)) then hsibs=hsibs+1 call sshare(set(i-pedoffset,1), set(i-pedoffset,2), & set(j-pedoffset,1), set(j-pedoffset,2), zibd) ibs=int(2.0D0*zibd)+1 tabh(ibs)=tabh(ibs)+1 end if end do end if end do end if ! Now update to next sibship fin=k currf=dataset%fa(fin) currm=dataset%mo(fin) end if end do end if end do ! nfs=tabf(3)+tabf(2)+tabf(1) nhs=tabh(3)+tabh(2)+tabh(1) if (nfs > 0) muf=0.5D0*dble(2*tabf(3)+tabf(2))/dble(nfs) if (nhs > 0) muh=0.5D0*dble(2*tabh(3)+tabh(2))/dble(nhs) if (plevel > 0) then write(outstr,'(3a/)') & '----------- ASP analysis for "', trim(locnam), '" --------------' write(outstr,'(2(12x,a/),2(a,i6,2x,3i6,6x,f6.4,3x,f6.4/))') & 'No. of IBS Sharing Mean IBS sharing', & 'Pairs 2/2 1/2 0/2 Obs Exp', & 'Full-sibs', nfs, tabf(3), tabf(2), tabf(1), muf, ef, & 'Half-sibs', nhs, tabh(3), tabh(2), tabh(1), muh, eh write(outstr,'(2(12x,a/),2(a,8x,3f6.3/))') & 'Expectd IBS Sharing', ' 2/2 1/2 0/2 ', & 'Full-sibs', f(3), f(2), f(1), & 'Half-sibs', h(3), h(2), h(1) end if if (nfs > 0) then chif=0.0D0 do i=1, 3 ex=dble(nfs)*f(i) obs=dble(tabf(i)) if (obs > 0.001D0 .and. ex > 0.001D0) then chif=chif+obs*log(obs/ex) end if end do chif=chif+chif ibsp=chip(chif,2) pval=binp(2.0D0*mux,dble(2*nfs)-2.0D0*mux) if (plevel > 0) then write(outstr,'(a,f6.1,3a/a,f6.4,3a)') & 'Full-Sib Chi-square (2 df) =', chif, & ' (P=', trim(pstring(ibsp)), ')', & 'Mean full-sib IBD sharing =', mux/dble(nfs), & ' (P=', trim(pstring(pval)), ')' if (muf < ef) then write(outstr,'(/a/)') 'NOTE: Full-sib IBS sharing less than expected.' end if else call phist(ibsp, pval, histo) write(outstr,'(a14,1x,i6,4(1x,f6.4),3(1x,a))') & locnam, nfs, muf, ef, ibsp, mux/dble(nfs), pstring(pval), 'ASP', histo end if end if if (nhs > 0) then chih=0.0D0 do i=1,3 ex=dble(nhs)*h(i) obs=dble(tabh(i)) if (obs > 0.001D0 .and. ex > 0.001D0) then chih=chih+obs*log(obs/ex) end if end do chih=chih+chih ibsp=chip(chih,2) if (plevel > 0) then write(outstr,'(a,f6.1,3a)') & 'Half-Sib Chi-square (2 df) =',chih,' (P=', trim(pstring(ibsp)), ')' if (muh < eh) then write(outstr,'(/a/)') 'NOTE: Half-sib IBS sharing less than expected.' end if end if end if end subroutine doasp ! ! Return IBS sharing for relative pair ! subroutine sshare(g1, g2, g3, g4, zibs) integer, intent(in) :: g1, g2, g3, g4 double precision, intent(out) :: zibs if ((g1 == g3 .and. g2 == g4).or.(g1 == g4 .and. g2 == g3)) then zibs=1.0d0 else if (g1 == g3 .or. g1 == g4 .or. g2 == g3 .or. g2 == g4) then zibs=0.5d0 else zibs=0.0d0 end if end subroutine sshare ! ! Penrose sib pair linkage analysis ! subroutine dopenrose(loc1, trait, typ1, loc2, gene, typ2, dataset, iter, plevel) use outstream use locus_types use ped_class implicit none integer, intent(in) :: trait, gene character (len=*), intent(in) :: loc1, loc2 integer, intent(in) :: typ1, typ2 type (ped_data) :: dataset integer, intent(in) :: iter integer, intent(inout) :: plevel integer, parameter :: KNOWN=0, MISS=-9999 ! integer :: contrib, currf, currm, fin, g1, g2, g3, g4, i, j, k, ped, pedoffset integer :: con, idx, np, necon, nfam, sibs, sim1, sim2 integer, dimension(4) :: contab double precision :: expcon, zval double precision, dimension(2) :: val double precision, dimension(4) :: ex ! functions double precision :: encgtp con=0 contab=0 nfam=0 sibs=0 if (plevel>0) then write(outstr,'(a/a)') 'ID1 ID2 Con (Loc1, Loc2)', & '---------- ---------- ----------------' end if ! ! only iterate nonfounders -- sibship by sibship do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) fin=dataset%num(ped) currf=dataset%fa(fin) currm=dataset%mo(fin) do k=dataset%num(ped)-1, pedoffset+dataset%nfound(ped), -1 if (dataset%fa(k) /= currf .or. dataset%mo(k) /= currm) then contrib=0 do i=k+1, fin dataset%untyped(i)=.true. np=0 if (isactdip(typ1)) then if (observed(i, trait, dataset)) np=np+1 else if (istrait(typ1)) then if (dataset%plocus(i,trait) /= MISS) np=np+1 end if if (isactdip(typ2)) then if (observed(i, gene, dataset)) np=np+1 else if (istrait(typ2)) then if (dataset%plocus(i,gene) /= MISS) np=np+1 end if if (np == 2) then contrib=contrib+1 dataset%untyped(i)=.not.dataset%untyped(i) end if end do ! ! Skip if no usable individuals in this sibship ! if (contrib > 1) then nfam=nfam+1 do i=k+1, fin if (.not.dataset%untyped(i)) then do j=k+1, i-1 if (.not.dataset%untyped(j)) then sibs=sibs+1 sim1=0 sim2=0 if (isactdip(typ1)) then call get_geno(i, trait, trait+1, dataset, g1, g2) call get_geno(j, trait, trait+1, dataset, g3, g4) if (g1 == g3 .and. g2 == g4) then sim1=sim1+1 end if else if (dataset%plocus(i,trait) == dataset%plocus(j,trait)) then sim1=sim1+1 end if if (isactdip(typ2)) then call get_geno(i, gene, gene+1, dataset, g1, g2) call get_geno(j, gene, gene+1, dataset, g3, g4) if (g1 == g3 .and. g2 == g4) then sim2=sim2+1 end if else if (dataset%plocus(i,gene) == dataset%plocus(j,gene)) then sim2=sim2+1 end if idx=sim1+2*sim2+1 contab(idx)=contab(idx)+1 if ((sim1+sim2)==2) con=con+1 if (plevel>0) then write(outstr,'(a,1x,a,6x,i1,1x,i1)') & dataset%id(i), dataset%id(j), sim1, sim2 end if end if end do end if end do end if ! Now update to next sibship fin=k currf=dataset%fa(fin) currm=dataset%mo(fin) end if end do end if end do ! if (plevel>0) write(outstr,*) write(outstr,'(21x,a)') loc2 write(outstr,'(a,1x,a)') loc1, 'Concordant Discordant' write(outstr,'(2(a,i10,2x,i10/))') & 'Concordant ', contab(4), contab(2), & 'Discordant ', contab(3), contab(1) write(outstr,'(a,i5/a,i5)') & 'No. of sib pairs = ', sibs, & 'No. of sibships = ', nfam if (sibs > 0) then call rctest(2, 2, contab, ex, iter) end if end subroutine dopenrose ! ! Find biggest active sibship ! subroutine shipsiz(dataset, bigship) use ped_class implicit none type (ped_data) :: dataset integer, intent(out) :: bigship ! local variables integer, parameter :: MISS=-9999 integer :: k, ped, pedoffset, sibs integer :: currf, currm, fin bigship=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) fin=dataset%num(ped) currf=dataset%fa(fin) currm=dataset%mo(fin) do k=dataset%num(ped)-1, pedoffset+dataset%nfound(ped), -1 if (dataset%fa(k) /= currf .or. dataset%mo(k) /= currm) then bigship=max(bigship, fin-k) fin=k currf=dataset%fa(fin) currm=dataset%mo(fin) end if end do end if end do end subroutine shipsiz ! ! Perform Monte-Carlo based APM analysis ! subroutine doapm(trait, locnam, gene, typ, iter, burnin, gt, thresh, & dataset, allele_buffer, pvalout, plevel) use outstream use alleles_class use ped_class use pairlist_class use rngs use statfuns implicit none integer, intent(in out) :: trait character (len=20), intent(in out) :: locnam integer, intent(in) :: gene integer, intent(in) :: typ integer, intent(in) :: iter integer, intent(in) :: burnin integer, intent(in out) :: gt double precision, intent(in) :: thresh type (ped_data) :: dataset type (allele_data), intent(inout) :: allele_buffer double precision, intent(out) :: pvalout integer, intent(in out) :: plevel ! local variables integer, parameter :: KNOWN=0, MISS=-9999 double precision, dimension(allele_buffer%numgtp) :: gfrq integer, dimension(dataset%maxsiz,2) :: set integer, dimension(dataset%maxsiz,2) :: sibd ! proposal and work array integer, dimension(dataset%maxsiz,2) :: set2 integer, dimension(2*dataset%maxsiz) :: key ! untyped matings type (pairlist_data) cntmat ! list of affected individuals ! storage is affected ID in aff(1...aff), unaffected ID in aff(unaff...nobs) integer :: naff, unaff, aff(dataset%maxsiz) ! other local variables logical :: alltyp, fin, last integer :: num, ped, pedoffset integer :: gen2, g1, g2, i, idx, ii, iprop, it, j, k, nskipped, & nt, ntyped, ut character (len=3) :: histo double precision :: den ! families containing AA, AU, UU, AA+AU, GPM/WH pairs logical :: pair(5) ! number of families containing AA, AU, UU, or any AA, AU, UU pairs integer :: nfam(5) ! ibd [,1] or ibs [,1-3] based statistics double precision :: wt, z(5,3), oz(5,3), t(5,3), sz(5,3), v(5,3) double precision :: n(5,3), d(5,3), logp(5), pval(5,3), zsum(5,3) ! functions ! chip, ppnd, zp integer :: getnam character (len=6) :: pstring double precision :: isaff double precision :: makewt interface subroutine update(idx, all1, all2, set) integer, intent(in) :: idx integer, intent(in) :: all1 integer, intent(in) :: all2 integer, dimension(:,:), intent(inout) :: set end subroutine update subroutine tabmat(ped, dataset, cntmat) use pairlist_class use ped_class integer, intent(in) :: ped type (ped_data), intent(in) :: dataset type (pairlist_data), intent(inout) :: cntmat end subroutine tabmat subroutine drop(it, ped, dataset, cntmat, numal, gfrq, & set, sibd, set2, key, iprop, plevel) use pairlist_class use ped_class implicit none integer, intent(in) :: it integer, intent(in) :: ped type (ped_data) :: dataset ! number of untyped matings -- used to decide number and type of mutations type (pairlist_data), intent(inout) :: cntmat integer, intent(in) :: numal double precision, dimension(numal*(numal+1)/2) :: gfrq integer, dimension(:,:), intent(inout), target :: set, sibd ! proposal and work array integer, dimension(:,:), intent(inout) :: set2 integer, dimension(:), intent(inout) :: key integer, intent(out) :: iprop integer, intent(in) :: plevel end subroutine drop subroutine simped(ped, dataset, allele_buffer, set) use alleles_class use ped_class integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data), intent(in) :: allele_buffer integer, dimension(:,:), intent(out) :: set end subroutine simped subroutine clcibs(naff, unaff, aff, allele_buffer, set, z) use alleles_class implicit none integer, intent(in) :: naff integer, intent(in) :: unaff integer, dimension(:), intent(in) :: aff type (allele_data), intent(inout) :: allele_buffer integer, dimension(:,:), intent(in) :: set double precision, dimension(5,3), intent(out) :: z end subroutine clcibs function simil(nfound, naff, aff, sibd, key) double precision :: simil integer, intent(in) :: nfound integer, intent(in) :: naff integer, dimension(:), intent(in out) :: aff integer, dimension(:,:), intent(in out) :: sibd integer, dimension(:), intent(out) :: key end function simil subroutine pedibd(typ, ped, dataset, set, sibd) use ped_class implicit none integer, intent(in) :: typ integer, intent(in) :: ped type (ped_data), intent(in) :: dataset integer, dimension(:,:), intent(in) :: set integer, dimension(:,:), intent(in out) :: sibd end subroutine pedibd subroutine clcibd(naff, unaff, aff, sibd, zibd) integer, intent(in) :: naff, unaff integer, dimension(:), intent(in) :: aff integer, dimension(:,:), intent(in) :: sibd double precision, dimension(5,3), intent(out) :: zibd end subroutine clcibd end interface if (allele_buffer%numal < 2) then return end if den=dble(iter) gen2=gene+1 nskipped=0 nt=0 ut=0 do j=1, 5 nfam(j)=0 end do do j=1, 5 logp(j)=0.0d0 do k=1, 3 zsum(j,k)=0.0d0 n(j,k)=0.0d0 d(j,k)=0.0d0 end do end do if (plevel > 0) then write(outstr,'(/3a/)') & '----------- APM analysis for "', trim(locnam),'" --------------' end if ! ! transfer genotype to set() and record if typed in untyped() ! record affection status in set2(,2) ! do ped=1, dataset%nped ntyped=0 if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset alltyp=.true. ii=pedoffset do i=1, num ii=ii+1 call get_geno(ii, gene, gen2, dataset, g1, g2) if (.not.observed(ii, gene, dataset)) then alltyp=.false. dataset%untyped(ii)=.true. if (g1 == 0 .or. g1 == MISS) then if (typ == 1) then g1=0 g2=0 else write(outstr,'(a/7x,a)') & 'ERROR: Starting genotypes were not generated.', & 'Imputation must be set to higher than -1.' return end if else g1=getnam(g1, allele_buffer) g2=getnam(g2, allele_buffer) end if else ntyped=ntyped+1 dataset%untyped(ii)=.false. g1=getnam(g1, allele_buffer) g2=getnam(g2, allele_buffer) end if call update(i,g1,g2,set) set2(i,2)=int(isaff(dataset%plocus(ii,trait),thresh,gt)) set2(i,1)=0 end do ! ! store number of offspring in set2(,1) ! do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped) set2(dataset%fa(i)-pedoffset,1)=set2(dataset%fa(i)-pedoffset,1)+1 set2(dataset%mo(i)-pedoffset,1)=set2(dataset%mo(i)-pedoffset,1)+1 end do ! ! trim uninformative persons ie untyped individuals with no offspring ! by setting their affection status to missing -- update their parents ! offspring number (so that end with number of informative offspring) ! do fin=.true. do i=dataset%nfound(ped)+1, num if (set2(i,1) == 0 .and. dataset%untyped(pedoffset+i)) then fin=.false. set2(i,1)=MISS set2(i,2)=MISS idx=dataset%fa(pedoffset+i)-pedoffset set2(idx,1)=set2(idx,1)-1 idx=dataset%mo(pedoffset+i)-pedoffset set2(idx,1)=set2(idx,1)-1 end if end do if (fin) exit end do do i=1, dataset%nfound(ped) if (set2(i,1) == 0 .and. dataset%untyped(pedoffset+i)) then set2(i,1)=MISS set2(i,2)=MISS end if end do ! transfer affection status to list naff=0 unaff=dataset%maxsiz+1 do i=1, num if (.not.dataset%untyped(pedoffset+i) .or. typ == 2) then if (set2(i,2) == 2) then naff=naff+1 aff(naff)=i else if (set2(i,2) == 1) then unaff=unaff-1 aff(unaff)=i end if end if end do unaff=dataset%maxsiz+1-unaff ! check if family appropriate for different (or any) statistics if (ntyped==0 .or. (naff+unaff) < 2 .or. num <= 3) then nskipped=nskipped+1 if (plevel > 1) then write(outstr,'(a,a10//a,/)') & 'Pedigree ', dataset%pedigree(ped), & ' Insufficient individuals typed.' end if cycle end if nfam(4)=nfam(4)+1 pair(1)=.false. pair(2)=.false. pair(3)=.false. pair(4)=.true. pair(5)=.false. if (naff > 1) then nfam(1)=nfam(1)+1 pair(1)=.true. pair(5)=.true. end if if (naff > 0 .and. unaff > 0) then nfam(2)=nfam(2)+1 pair(2)=.true. if (typ == 1) pair(5)=.true. end if if (unaff > 1) then nfam(3)=nfam(3)+1 pair(3)=.true. end if nt=nt+naff ut=ut+unaff ! if ibs based statistic if (typ == 1) then call clcibs(naff, unaff, aff, allele_buffer, set, oz) do j=1, 5 do k=1, 3 pval(j,k)=0.0d0 sz(j,k)=0.0d0 v(j,k)=0.0d0 end do end do ! generate ibs distribution under null do i=1, iter call simped(ped, dataset, allele_buffer, set) call clcibs(naff, unaff, aff, allele_buffer, set, z) ! only update statistic if appropriate family do j=1, 5 if (pair(j)) then do k=1, 3 if (j /= 2) then if (z(j,k) > oz(j,k) .or. (z(j,k) == oz(j,k) .and. & random() > 0.5)) pval(j,k)=pval(j,k)+1.0d0 else if (z(j,k) < oz(j,k) .or. (z(j,k) == oz(j,k) .and. & random() > 0.5)) pval(j,k)=pval(j,k)+1.0d0 end if call moment(i,z(j,k),sz(j,k),v(j,k)) end do end if end do end do do j=1, 5 if (pair(j)) then do k=1, 3 if (pval(j,k) == 0.0d0) then pval(j,k)=0.5d0/den else if (pval(j,k) == den) then pval(j,k)=1.0d0-0.5d0/den else pval(j,k)=pval(j,k)/den end if zsum(j,k)=zsum(j,k)+ppnd(1.0d0-pval(j,k)) v(j,k)=v(j,k)/dble(max(1,iter-1)) if (v(j,k) > 0) then wt=makewt(j,naff,unaff,v(j,k)) t(j,k)=(oz(j,k)-sz(j,k))/sqrt(v(j,k)) n(j,k)=n(j,k)+wt*(oz(j,k)-sz(j,k)) d(j,k)=d(j,k)+wt*wt*v(j,k) else t(j,k)=0.0d0 end if end do else t(j,1)=0.0d0 t(j,2)=0.0d0 t(j,3)=0.0d0 end if end do if (plevel > 1) then write(outstr,'(a,a10,a/a,3(/a,4(1x,f10.3),1x,a))') & 'Pedigree ', dataset%pedigree(ped), & ' E(Z) Var(Z) Z T MC-P', 'Aff-Aff', & 'f(p) = 1 ',sz(1,1), v(1,1), oz(1,1), t(1,1), pstring(pval(1,1)), & 'f(p) = 1/sqrt(p)',sz(1,2), v(1,2), oz(1,2), t(1,2), pstring(pval(1,2)), & 'f(p) = 1/p ',sz(1,3), v(1,3), oz(1,3), t(1,3), pstring(pval(1,3)) write(outstr,'(a,3(/a,4(1x,f10.3),1x,f6.4))') 'Aff-UnA', & 'f(p) = 1 ',sz(2,1), v(2,1), oz(2,1), t(2,1), pstring(pval(2,1)), & 'f(p) = 1/sqrt(p)',sz(2,2), v(2,2), oz(2,2), t(2,2), pstring(pval(2,2)), & 'f(p) = 1/p ',sz(2,3), v(2,3), oz(2,3), t(2,3), pstring(pval(2,3)) write(outstr,'(a,3(/a,4(1x,f10.3),1x,f6.4))') 'Aff-Aff v. Aff-UnA', & 'f(p) = 1 ',sz(5,1), v(5,1), oz(5,1), t(5,1), pstring(pval(5,1)), & 'f(p) = 1/sqrt(p)',sz(5,2), v(5,2), oz(5,2), t(5,2), pstring(pval(5,2)), & 'f(p) = 1/p ',sz(5,3), v(5,3), oz(5,3), t(5,3), pstring(pval(5,3)) write(outstr,'(a,3(/a,4(1x,f10.3),1x,f6.4))') 'GPM', & 'f(p) = 1 ',sz(4,1), v(4,1), oz(4,1), t(4,1), pstring(pval(4,1)), & 'f(p) = 1/sqrt(p)',sz(4,2), v(4,2), oz(4,2), t(4,2), pstring(pval(4,2)), & 'f(p) = 1/p ',sz(4,3), v(4,3), oz(4,3), t(4,3), pstring(pval(4,3)) write(outstr,'(/a,10(1x,a)/(10x,10(1x,a)):)') & 'Affecteds:', (trim(dataset%id(pedoffset+aff(i))), i=1, naff) write(outstr,'(a,10(1x,a)/(10x,10(1x,a)):)') & 'Unaffectd:', (trim(dataset%id(pedoffset+aff(i))), & i=dataset%maxsiz+1-unaff,dataset%maxsiz) write(outstr,'(/i5,a,i5,a/)') naff, ' affecteds and ', unaff, ' unaffecteds used' end if ! else ibd based statistic calculated else if (typ == 2) then sz(1,1)=0.0d0 sz(2,1)=0.0d0 sz(3,1)=0.0d0 sz(4,1)=0.0d0 sz(5,1)=0.0d0 if (alltyp) then do i=1, iter call pedibd(2, ped, dataset, set, sibd) call clcibd(naff, unaff, aff, sibd, z) sz(1,1)=sz(1,1)+z(1,1) sz(2,1)=sz(2,1)+z(2,1) sz(3,1)=sz(3,1)+z(3,1) sz(4,1)=sz(4,1)+z(4,1) sz(5,1)=sz(5,1)+simil(dataset%nfound(ped), naff, aff, sibd, key) end do else ! some untyped markers: ! produce genotype frequencies for Metropolis criterion ! enumerate untyped founder matings call genot(allele_buffer, gfrq) call tabmat(ped, dataset, cntmat) ! ! Metropolis simulation of genotypes ! if (plevel > 2) then write(outstr,'(/2a,4(/a,i4))') & 'Metropolis simulation of pedigree ', dataset%pedigree(ped), & 'Untyped Individuals: ', dataset%num(ped)-ntyped, & 'Possible genotypes : ', allele_buffer%numgtp, & 'UnT x UnT matings : ', cntmat%npairs, & 'Burn-in (iters) : ',burnin end if do it=1, burnin call drop(it, ped, dataset, cntmat, allele_buffer%numal, gfrq, & set, sibd, set2, key, iprop, 0) end do do it=1, iter call drop(it, ped, dataset, cntmat, allele_buffer%numal, gfrq, & set, sibd, set2, key, iprop, plevel-1) call clcibd(naff, unaff, aff, sibd, z) sz(1,1)=sz(1,1)+z(1,1) sz(2,1)=sz(2,1)+z(2,1) sz(3,1)=sz(3,1)+z(3,1) sz(4,1)=sz(4,1)+z(4,1) sz(5,1)=sz(5,1)+simil(dataset%nfound(ped), naff, aff, sibd, key) end do ! record new starting genotypes j=pedoffset do i=1, num j=j+1 if (dataset%untyped(j)) then g1=-allele_buffer%allele_names(set(i,1)) g2=-allele_buffer%allele_names(set(i,2)) call set_geno(j, gene, gen2, dataset, g1, g2) end if end do end if ! ! now take mean statistics over different ibd realizations ! oz(1,1)=sz(1,1)/den oz(2,1)=sz(2,1)/den oz(3,1)=sz(3,1)/den oz(4,1)=sz(4,1)/den oz(5,1)=sz(5,1)/den ! ! generate ibd distribution under null, ! as of 20030615 conditional on marker informativeness ! do j=1, 5 pval(j,1)=0.0d0 sz(j,1)=0.0d0 v(j,1)=0.0d0 end do do i=1, iter call simped(ped, dataset, allele_buffer, set) call pedibd(2, ped, dataset, set, sibd) call clcibd(naff, unaff, aff, sibd, z) z(5,1)=simil(dataset%nfound(ped), naff, aff, sibd, key) do j=1, 5 if (pair(j)) then if (j /= 2) then if (z(j,1) > oz(j,1) .or. & (z(j,1) == oz(j,1) .and. random() > 0.5)) pval(j,1)=pval(j,1)+1.0d0 else if (z(j,1) < oz(j,1) .or. & (z(j,1) == oz(j,1) .and. random() > 0.5)) pval(j,1)=pval(j,1)+1.0d0 end if call moment(i,z(j,1),sz(j,1),v(j,1)) end if end do end do do j=1, 5 if (pair(j)) then if (pval(j,1) == 0.0d0) then pval(j,1)=0.5d0/den else if (pval(j,1) == den) then pval(j,1)=1.0d0-0.5d0/den else pval(j,1)=pval(j,1)/den end if logp(j)=logp(j)+log(pval(j,1)) zsum(j,1)=zsum(j,1)+ppnd(1.0d0-pval(j,1)) v(j,1)=v(j,1)/dble(max(1,iter-1)) if (v(j,1) > 0.0d0) then t(j,1)=(oz(j,1)-sz(j,1))/sqrt(v(j,1)) wt=makewt(j,naff,unaff,v(j,1)) n(j,1)=n(j,1)+wt*(oz(j,1)-sz(j,1)) d(j,1)=d(j,1)+wt*wt*v(j,1) else t(j,1)=0.0d0 end if else t(j,1)=0.0d0 end if end do if (plevel > 1) then write(outstr,'(a,a10,a,4(/a,4(1x,f10.3),1x,a))') & 'Pedigree ', dataset%pedigree(ped), & ' E(Z) Var(Z) Z T MC-P', & 'ibd-based Af-Af ', sz(1,1), v(1,1), oz(1,1), t(1,1), & pstring(pval(1,1)), & 'ibd-based Af-Un ', sz(2,1), v(2,1), oz(2,1), t(2,1), & pstring(pval(2,1)), & 'ibd-based GPM ', sz(4,1), v(4,1), oz(4,1), t(4,1), & pstring(pval(4,1)), & 'Whit-Halp Score ', sz(5,1), v(5,1), oz(5,1), t(5,1), & pstring(pval(5,1)) write(outstr,'(/a,10(1x,a)/(10x,10(1x,a)):)') & 'Affecteds:', (trim(dataset%id(pedoffset+aff(i))), i=1, naff) write(outstr,'(a,10(1x,a)/(10x,10(1x,a)):)') & 'Unaffectd:', (trim(dataset%id(pedoffset+aff(i))), & i=dataset%maxsiz+1-unaff,dataset%maxsiz) write(outstr,'(/i5,a,i5,a/)') & naff, ' affecteds and ', unaff, ' unaffecteds used' end if end if end if end do ! end of main loop if (typ == 1) then nfam(5)=nfam(4) do j=1, 5 do k=1, 3 if (nfam(j) > 0) then zsum(j,k)=zp(zsum(j,k)/sqrt(dble(nfam(j)))) end if if (d(j,k) > 0.0d0) then t(j,k)=n(j,k)/sqrt(d(j,k)) else t(j,k)=0.0d0 end if end do end do if (plevel > 0) then write(outstr,'(/a)') 'Overall statistics T NFam Asy-P InvZ-P' write(outstr,'(a,3(/a,1x,f10.3,1x,i5,2(1x,f6.4)))') 'Aff-Aff', & 'f(p) = 1 ', t(1,1), nfam(1), zp(t(1,1)), zsum(1,1), & 'f(p) = 1/sqrt(p)', t(1,2), nfam(1), zp(t(1,2)), zsum(1,2), & 'f(p) = 1/p ', t(1,3), nfam(1), zp(t(1,3)), zsum(1,3) write(outstr,'(a,3(/a,1x,f10.3,1x,i5,2(1x,f6.4)))') 'Aff-UnA', & 'f(p) = 1 ', t(2,1), nfam(2), zp(-t(2,1)), zsum(2,1), & 'f(p) = 1/sqrt(p)', t(2,2), nfam(2), zp(-t(2,2)), zsum(2,2), & 'f(p) = 1/p ', t(2,3), nfam(2), zp(-t(2,3)), zsum(2,3) write(outstr,'(a,3(/a,1x,f10.3,1x,i5,2(1x,f6.4)))') 'Aff-Aff v. Aff-UnA', & 'f(p) = 1 ', t(5,1), nfam(4), zp(t(5,1)), zsum(5,1), & 'f(p) = 1/sqrt(p)', t(5,2), nfam(4), zp(t(5,2)), zsum(5,2), & 'f(p) = 1/p ', t(5,3), nfam(4), zp(t(5,3)), zsum(5,3) write(outstr,'(a,3(/a,1x,f10.3,1x,i5,2(1x,f6.4)))') 'GPM', & 'f(p) = 1 ', t(4,1), nfam(4), zp(t(4,1)), zsum(4,1), & 'f(p) = 1/sqrt(p)', t(4,2), nfam(4), zp(t(4,2)), zsum(4,2), & 'f(p) = 1/p ', t(4,3), nfam(4), zp(t(4,3)), zsum(4,3) write(outstr,'(/a,i0,a,i0,a)', advance='no') & 'Total of ',nt,' affecteds and ',ut,' unaffecteds used' if (nskipped > 0) then write(outstr,'(a,i0,a)', advance='no') & ' (Skipping ', nskipped, ' uninformative pedigrees)' end if write(outstr,'(a)') '.' else call phist(zp(t(1,2)), zsum(1,2), histo) write(outstr,'(a20,2(1x,i6),1x,f10.1,2(1x,a),1x,i6,2(1x,a))') & locnam, nfam(1), nt, t(1,2), pstring(zp(t(1,2))), pstring(zsum(1,2)), & iter, 'APM-IBS', histo call phist(zp(t(4,2)), zsum(4,2), histo) write(outstr,'(a20,2(1x,i6),1x,f10.1,2(1x,a),1x,i6,2(1x,a))') & locnam, nfam(4), nt, t(4,2), pstring(zp(t(4,2))), pstring(zsum(4,2)), & iter, 'GPM-IBS', histo end if pvalout=zp(t(4,2)) else if (typ == 2) then if (nfam(1) > 0) then nfam(5)=nfam(1) zsum(1,1)=zp(zsum(1,1)/sqrt(dble(nfam(1)))) zsum(5,1)=zp(zsum(5,1)/sqrt(dble(nfam(1)))) end if if (nfam(2) > 0) zsum(2,1)=zp(zsum(2,1)/sqrt(dble(nfam(2)))) if (nfam(4) > 0) zsum(4,1)=zp(zsum(4,1)/sqrt(dble(nfam(4)))) do j=1, 5 logp(j)=chip(-2*logp(j), 2*nfam(j)) if (d(j,1) > 0.0d0) then t(j,1)=n(j,1)/sqrt(d(j,1)) else t(j,1)=0.0d0 end if end do if (plevel > 0) then write(outstr,'(/a)') & 'Overall statistics T NFam Asy-P Fish-P InvZ-P' write(outstr,'(4(/a,1x,f10.3,1x,i5,3(1x,a)))') & 'ibd-based Af-Af ', t(1,1), nfam(1), pstring(zp(t(1,1))), & pstring(logp(1)), pstring(zsum(1,1)), & 'ibd-based Af-Un ', t(2,1), nfam(2), pstring(zp(-t(2,1))), & pstring(logp(2)), pstring(zsum(2,1)), & 'ibd-based GPM ', t(4,1), nfam(4), pstring(zp(t(4,1))), & pstring(logp(4)), pstring(zsum(4,1)), & 'Whit-Halp Score ', t(5,1), nfam(5), pstring(zp(t(5,1))), & pstring(logp(5)), pstring(zsum(5,1)) write(outstr,'(/a,i0,a,i0,a)', advance='no') & 'Total of ', nt, ' affecteds and ', ut, ' unaffecteds used' if (nskipped > 0) then write(outstr,'(a,i0,a)', advance='no') & ' (Skipping ', nskipped, ' uninformative pedigrees)' end if write(outstr,'(a)') '.' else call phist(zp(t(1,1)), logp(1), histo) write(outstr,'(a20,2(1x,i6),1x,f10.1,2(1x,a),1x,i6,2(1x,a))') & locnam, nfam(1), nt, t(1,1), pstring(zp(t(1,1))), pstring(logp(1)), & iter, 'APM-IBD', histo call phist(zp(t(4,1)), logp(4), histo) write(outstr,'(a20,2(1x,i6),1x,f10.1,2(1x,a),1x,i6,2(1x,a))') & locnam, nfam(4), nt, t(4,1), pstring(zp(t(4,1))), pstring(logp(4)), & iter, 'GPM-IBD', histo end if pvalout=zp(t(4,1)) end if call clean_pairs(cntmat) end subroutine doapm ! ! Copy genotypes from pedigree to set ! subroutine loadset(gene, ped, allele_buffer, dataset, set, nuntyp) use alleles_class use ped_class implicit none integer, intent(in) :: gene integer, intent(in) :: ped type (allele_data) :: allele_buffer type (ped_data) :: dataset integer, dimension(dataset%maxsiz,2), intent(out) :: set integer, intent(out) :: nuntyp integer, parameter :: KNOWN=0, MISS=-9999 integer :: g1, g2, gen2, i, pedoffset ! functions integer getnam interface subroutine update(idx, all1, all2, set) integer, intent(in) :: idx integer, intent(in) :: all1 integer, intent(in) :: all2 integer, dimension(:,:), intent(inout) :: set end subroutine update end interface gen2=gene+1 nuntyp=0 pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) call get_geno(i, gene, gen2, dataset, g1, g2) if (.not.observed(i, gene, dataset)) then nuntyp=nuntyp+1 dataset%untyped(i)=.true. if (g1 == 0 .or. g1 == MISS) then g1=MISS g2=MISS else g1=getnam(g1, allele_buffer) g2=getnam(g2, allele_buffer) end if else dataset%untyped(i)=.false. g1=getnam(g1, allele_buffer) g2=getnam(g2, allele_buffer) end if call update(i-pedoffset, g1, g2, set) end do end subroutine loadset ! ! Pedigree structure type call to simibd ! subroutine pedibd(typ, ped, dataset, set, sibd) use ped_class implicit none integer, intent(in) :: typ integer, intent(in) :: ped type (ped_data), intent(in) :: dataset integer, dimension(:,:), intent(in) :: set integer, dimension(:,:), intent(in out) :: sibd integer, parameter :: MISS=-9999 integer :: i, num, pedoffset integer, dimension(dataset%maxsiz) :: fa, mo, imztwin interface subroutine simibd(typ, pedigree, num, nfound, fa, mo, imztwin, set, sibd) use idstring_widths integer, intent(in) :: typ character (len=ped_width), intent(in) :: pedigree integer, intent(in) :: num, nfound integer, dimension(:), intent(in) :: fa, mo, imztwin integer, dimension(:,:), intent(in) :: set integer, dimension(:,:), intent(out) :: sibd end subroutine simibd end interface pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset call workpointers(ped, dataset, fa, mo, imztwin) call simibd(typ, dataset%pedigree(ped), num, dataset%nfound(ped), & fa, mo, imztwin, set, sibd) end subroutine pedibd ! ! Calculate some plausible weights to allow combination of APM statistics ! from different pedigrees ! type=1 pair=AA, 2 AU, 3 UU, 4 GPM, 5 W-H ! function makewt(typ, naff, unaff, var) double precision makewt integer, intent(in) :: typ integer, intent(in) :: naff integer, intent(in) :: unaff double precision, intent(inout) :: var makewt=0.0d0 if ((typ == 1 .or. typ == 5) .and. naff > 1) then makewt=sqrt(dble(naff-1))/sqrt(var) else if (typ == 3 .and. unaff > 1) then makewt=sqrt(dble(unaff-1))/sqrt(var) else if (typ == 2 .and.(naff+unaff) > 1) then makewt=sqrt(dble(naff+unaff-1))/sqrt(var) else if (typ == 4 .and.(naff+unaff) > 1) then makewt=dble(naff+unaff-1) makewt=sqrt(0.5d0*makewt*(makewt-1.0d0))/sqrt(var) end if end function makewt ! ! Calculate ibs statistic ! subroutine clcibs(naff, unaff, aff, allele_buffer, set, z) use alleles_class implicit none integer, intent(in) :: naff integer, intent(in) :: unaff integer, dimension(:), intent(in) :: aff type (allele_data), intent(inout) :: allele_buffer integer, dimension(:,:), intent(in) :: set double precision, dimension(5,3), intent(out) :: z integer :: i, j, g1, g2, g3, g4, maxsiz, p1, p2 double precision :: d1, d2, pr1, pr2 ! functions double precision :: delta maxsiz=size(aff) do i=1, 5 do j=1, 3 z(i,j)=0.0d0 end do end do ! AA statistic if (naff > 1) then do i=1, naff-1 p1=aff(i) g1=set(p1,1) g2=set(p1,2) pr1=1.0d0/allele_buffer%allele_freqs(g1) pr2=1.0d0/allele_buffer%allele_freqs(g2) do j=i+1,naff p2=aff(j) ! --- the most recent versions of APM exclude parent-offspring pairs ! --- as a method to increase power to detect linkage over association ! if (fa(p1).ne.p2 .and. mo(p1).ne.p2 .and. ! & fa(p2).ne.p1.and.mo(p2).ne.p1) then g3=set(p2,1) g4=set(p2,2) d1=delta(g1,g3)+delta(g1,g4) d2=delta(g2,g3)+delta(g2,g4) z(1,1)=z(1,1)+d1+d2 z(1,2)=z(1,2)+d1*sqrt(pr1)+d2*sqrt(pr2) z(1,3)=z(1,3)+d1*pr1+d2*pr2 end do end do end if ! AU statistic if (naff > 0 .and. unaff > 0) then do i=1,naff p1=aff(i) g1=set(p1,1) g2=set(p1,2) pr1=1.0d0/allele_buffer%allele_freqs(g1) pr2=1.0d0/allele_buffer%allele_freqs(g2) do j=maxsiz+1-unaff,maxsiz p2=aff(j) g3=set(p2,1) g4=set(p2,2) d1=delta(g1,g3)+delta(g1,g4) d2=delta(g2,g3)+delta(g2,g4) z(2,1)=z(2,1)+d1+d2 z(2,2)=z(2,2)+d1*sqrt(pr1)+d2*sqrt(pr2) z(2,3)=z(2,3)+d1*pr1+d2*pr2 end do end do end if ! UU statistic if (unaff > 1) then do i=maxsiz+1-unaff,maxsiz-1 p1=aff(i) g1=set(p1,1) g2=set(p1,2) pr1=1.0d0/allele_buffer%allele_freqs(g1) pr2=1.0d0/allele_buffer%allele_freqs(g2) do j=i+1,maxsiz p2=aff(j) g3=set(p2,1) g4=set(p2,2) d1=delta(g1,g3)+delta(g1,g4) d2=delta(g2,g3)+delta(g2,g4) z(3,1)=z(3,1)+d1+d2 z(3,2)=z(3,2)+d1*sqrt(pr1)+d2*sqrt(pr2) z(3,3)=z(3,3)+d1*pr1+d2*pr2 end do end do end if ! Rescale appropriately do i=1,3 do j=1,3 z(i,j)=0.25d0*z(i,j) end do end do ! Combined statistic if (naff > 1) then z(4,1)=z(4,1)+z(1,1)/naff/(naff-1) z(4,2)=z(4,2)+z(1,2)/naff/(naff-1) z(4,3)=z(4,3)+z(1,3)/naff/(naff-1) end if if (naff > 1 .and. unaff > 1) then z(5,1)=2.0d0*z(4,1)-z(2,1)/naff/unaff z(5,2)=2.0d0*z(4,2)-z(2,2)/naff/unaff z(5,3)=2.0d0*z(4,3)-z(2,3)/naff/unaff z(4,1)=z(4,1)-z(2,1)/naff/unaff z(4,2)=z(4,2)-z(2,2)/naff/unaff z(4,3)=z(4,3)-z(2,3)/naff/unaff end if if (unaff > 1) then z(4,1)=z(4,1)+z(3,1)/unaff/(unaff-1) z(4,2)=z(4,2)+z(3,2)/unaff/(unaff-1) z(4,3)=z(4,3)+z(3,3)/unaff/(unaff-1) end if end subroutine clcibs ! ! measure of IBS sharing ! function delta(g1,g2) double precision :: delta integer, intent(in) :: g1, g2 delta=1.0d0 if (g1 /= g2) delta=0.0d0 end function delta ! ! calculate ibd sharing statistic based on simulated ibd ! subroutine clcibd(naff, unaff, aff, sibd, zibd) integer, intent(in) :: naff, unaff integer, dimension(:), intent(in) :: aff integer, dimension(:,:), intent(in) :: sibd double precision, dimension(5,3), intent(out) :: zibd integer :: i, j, g1, g2, g3, g4, maxsiz, p1, p2 double precision :: ibd maxsiz=size(aff) zibd(1,1)=0.0d0 zibd(2,1)=0.0d0 zibd(3,1)=0.0d0 zibd(4,1)=0.0d0 zibd(5,1)=0.0d0 ! AA statistic if (naff > 1) then do i=1, naff-1 p1=aff(i) g1=sibd(p1,1) g2=sibd(p1,2) do j=i+1, naff p2=aff(j) g3=sibd(p2,1) g4=sibd(p2,2) call share(g1,g2,g3,g4,ibd) zibd(1,1)=zibd(1,1)+ibd end do end do end if ! AU statistic if (naff > 0 .and. unaff > 0) then do i=1, naff p1=aff(i) g1=sibd(p1,1) g2=sibd(p1,2) do j=maxsiz+1-unaff, maxsiz p2=aff(j) g3=sibd(p2,1) g4=sibd(p2,2) call share(g1, g2, g3, g4, ibd) zibd(2,1)=zibd(2,1)+ibd end do end do end if ! UU statistic if (unaff > 1) then do i=maxsiz+1-unaff, maxsiz-1 p1=aff(i) g1=sibd(p1,1) g2=sibd(p1,2) do j=i+1, maxsiz p2=aff(j) g3=sibd(p2,1) g4=sibd(p2,2) call share(g1, g2, g3, g4, ibd) zibd(3,1)=zibd(3,1)+ibd end do end do end if ! Combined statistic if (naff > 1) zibd(4,1)=zibd(4,1)+zibd(1,1)/naff/(naff-1) if (naff > 1 .and. unaff > 1) zibd(4,1)=zibd(4,1)-zibd(2,1)/naff/unaff if (unaff > 1) zibd(4,1)=zibd(4,1)+zibd(3,1)/unaff/(unaff-1) end subroutine clcibd ! ! Return IBD sharing for relative pair based on ibd-alleles ! subroutine share(g1, g2, g3, g4, zibd) integer, intent(in) :: g1, g2, g3, g4 double precision, intent(out) :: zibd if ((g1 == g3 .and. g2 == g4).or.(g1 == g4 .and. g2 == g3)) then zibd=1.0d0 else if (g1 == g3 .or. g1 == g4 .or. g2 == g3 .or. g2 == g4) then zibd=0.5d0 else zibd=0.0d0 end if if (g1==g2 .or. g3==g4) then zibd=2*zibd end if end subroutine share ! ! Whittemore's & Halpern's (Biometrics 1994; 50:118-127) measure ! of ibd sharing for multiple relatives ! ! for a set of N individuals, enumerate 2**N vectors containing ! one ibd-allele from each person. For each such set u_i, calculate ! a measure of overall similarity as the number of [additional] "nontrivial" ! permutations of that set that leave u unchanged. For example, if ! 3 individuals are {1/2} {1/3} {1/2}, there are 8 u's, which give a total ! abc Legal permutations (excl obs) of 10 possible permutations, with ! 111 5 acb, bac, bca, cab, cba a mean of 10/8. If a 4th relative ! 112 1 bac was ibd-genotype {4/5}, the mean ! 131 1 cba would be 10/16. The mean score (S) ! 132 0 is used to derive a standardized ! 211 1 acb score [S-E(S)]/SD(S), as in the APM ! 212 1 cba method, although direct enumeration ! 231 0 is of course feasible for small N. ! 232 1 cba ! ! Randomized version ! function simil(nfound, naff, aff, sibd, key) use rngs use statfuns double precision :: simil integer, intent(in) :: nfound integer, intent(in) :: naff integer, dimension(:), intent(in out) :: aff integer, dimension(:,:), intent(in out) :: sibd integer, dimension(:), intent(out) :: key integer :: i, idx, j, k, tperm double precision :: perm, dsum dsum=0.0D0 ! ! enumerate all permutations if number of probands (n) < 10 ! otherwise sample 1024 random permutations from 2^n ! if (naff < 10) then tperm=2**naff do i=1, tperm do j=1, 2*nfound key(j)=0 end do k=1 do j=1, naff idx=1 if (k == iand(i,k)) idx=2 k=2*k key(sibd(aff(j),idx))=key(sibd(aff(j),idx))+1 end do perm=1.0d0 do j=1, 2*nfound if (key(j) > 1) then perm=perm*fact(key(j)) end if end do perm=max(perm-1.0d0,0.0d0) dsum=dsum+perm end do else tperm=1024 do i=1, tperm do j=1, 2*nfound key(j)=0 end do do j=1, naff idx=irandom(1,2) key(sibd(aff(j),idx))=key(sibd(aff(j),idx))+1 end do perm=1.0d0 do j=1, 2*nfound if (key(j) > 1) then perm=perm*fact(key(j)) end if end do perm=max(perm-1.0d0,0.0d0) dsum=dsum+perm end do end if simil=dsum/dble(tperm) end function simil ! ! Conditional logistic regression version of 20151026 ! Stratum variable is either pedigree, sibship or (new) ! stratifying variable (which may cross pedigrees) ! subroutine clreg(typ, styp, nterms, terms, nloci, loc, loctyp, locpos, & gene, genemod, allele_buffer, useimp, & dataset, mlik, mpar, statval, pval, plevel) use interrupt use outstream use AS164_class use alleles_class use covariate_data use statfuns implicit none ! output type (SDT or full CLR) integer, intent(in) :: typ ! stratifying variable -1=pedigree -2=sibship >0 =stratum indicator integer, intent(in) :: styp ! position of y and x variables integer, intent(in) :: nterms integer, dimension(:), intent(inout) :: terms integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp integer, intent(in) :: gene integer, intent(in) :: genemod ! alleles for first marker (will generate numal-1 dummy variables) type (allele_data), intent(inout) :: allele_buffer logical, intent(in) :: useimp type (ped_data) :: dataset ! model likelihood and degrees of freedom double precision, intent(out) :: mlik integer, intent(out) :: mpar double precision, dimension(3), intent(out) :: statval double precision, intent(out) :: pval integer, intent(in) :: plevel ! local variables integer, parameter :: KNOWN=0, MISS=-9999 ! regression work arrays b and cov are in AS164_class integer, dimension(:), allocatable :: varlist integer, dimension(:), allocatable :: nca, nct double precision, dimension(:,:), allocatable :: x double precision, dimension(nterms) :: means ! levels of covariates type (variable_data) :: covariates integer :: ordsiz integer, dimension(dataset%nobs) :: caseord integer :: istrata integer, dimension(0:dataset%nobs) :: strata integer, dimension(dataset%nobs) :: stratpos ! ! nfix=number of fixed effects (including dummy variables) ! integer :: a1, a2, gpos, ifail, i, ica, icat, ico, ii, is, it, j, k, & ncat, ncov, nfix, nobs, nstrata, ntot, & ped, pedoffset, pos, nvar, strattyp, vpos, ycol, ypos integer :: naff double precision :: asyp, chi2, st, tval character (len=3) :: allel, histo character (len=20) :: label ! functions ! chip, zp character (len=6) :: pstring interface subroutine ascend(n, ia) integer, intent(in) :: n integer, dimension(:), intent(inout) :: ia end subroutine end interface ordsiz=dataset%nobs+1 mpar=0 mlik=0.0D0 pval=1.0d0 statval=0.0d0 nvar=nterms ypos=terms(nterms) ycol=locpos(ypos) if (typ == 1) then write(outstr,'(/a/3a/a/)') & '----------------------------------------------------------------', & ' Conditional logistic regression analysis of trait "', trim(loc(ypos)),'"', & '----------------------------------------------------------------' if (styp == -1) then write(outstr,'(a)') 'Stratum variable: Pedigree' else if (styp == -2) then write(outstr,'(a)') 'Stratum variable: Sibship' else write(outstr,'(3a)') 'Stratum variable: "', trim(loc(styp)), '"' end if else if (plevel > 0) then write(outstr,'(/3a/a)') & 'SDT: "',trim(loc(gene)),'"', & '---------------------------' end if call varlevels(COMPLETE_OBS, gene, allele_buffer%numal, nterms, terms, & loc, loctyp, locpos, dataset, covariates, plevel) nfix=covariates%totvars if (gene > 0) nfix=nfix+allele_buffer%numal-2 ifail=0 ncov=nfix*(nfix+1)/2 strattyp=styp if (styp > 0) strattyp=locpos(styp) ! ! allocate work arrays -- pass through and count strata ! dataset%untyped=.true. do i=1, dataset%nobs if (dataset%actset(dataset%iped(i)) > 0) then if (complete(useimp, i, nvar, terms, locpos, loctyp, dataset)) then dataset%untyped(i)=.false. end if end if end do call getstrata(strattyp, dataset, istrata, strata, stratpos) nobs=0 nstrata=0 useful: do j=1, istrata ica=0 ico=0 do ii=strata(j-1)+1, strata(j) i=stratpos(ii) if (dataset%plocus(i,ycol) == 1.0d0) then ico=ico+1 else if (dataset%plocus(i,ycol) == 2.0d0) then ica=ica+1 end if end do if (ica*ico > 0) then nstrata=nstrata+1 nobs=nobs+ica+ico end if end do useful if (nstrata > 0) then allocate(varlist(nfix)) allocate(nca(nstrata), nct(nstrata)) allocate(x(nobs, nfix)) call clean_AS164() allocate(b(nfix)) allocate(r(ncov)) allocate(cov(ncov)) nca=0 nct=0 cov=0.0d0 means=0.0d0 ! ! copy phenotype data to work array, incl dummy coding for first marker ! logcss requires cases then controls within each stratum ! nobs=0 naff=0 ntot=0 is=0 do j=1, istrata ica=0 ico=0 caseord=0 ntot=ntot+strata(j)-strata(j-1) do ii=strata(j-1)+1, strata(j) i=stratpos(ii) if (.not.dataset%untyped(i)) then if (dataset%plocus(i,ycol) == 2.0d0) then naff=naff+1 ica=ica+1 caseord(ica)=i else if (dataset%plocus(i,ycol) == 1.0d0) then ico=ico+1 caseord(ordsiz-ico)=i end if end if end do if (ica*ico > 0) then is=is+1 do k=1, ica i=caseord(k) nobs=nobs+1 nca(is)=nca(is)+1 call fixeff(i, nobs, 0, gene, genemod, allele_buffer, useimp, & nterms, terms, nloci, loctyp, locpos, & covariates, dataset, x, 1) if (plevel > 1) then write(outstr,'(a,i5,a,a35,a1)', advance='no') & 'Stratum ', is, ' Case ', & trim(dataset%pedigree(dataset%iped(i))) // '--' // trim(dataset%id(i)), ' ' write(outstr,*) x(nobs,1:nfix) end if end do do k=1, ico i=caseord(ordsiz-k) nobs=nobs+1 nct(is)=nct(is)+1 call fixeff(i, nobs, 0, gene, genemod, allele_buffer, useimp, & nterms, terms, nloci, loctyp, locpos, & covariates, dataset, x, 1) if (plevel > 1) then write(outstr,'(a,i5,a,a35,a1)', advance='no') & 'Stratum ', is, ' Control ', & trim(dataset%pedigree(dataset%iped(i))) // '--' // trim(dataset%id(i)), ' ' write(outstr,*) x(nobs,1:nfix) end if end do end if end do if (plevel > 1) write(outstr,'(//a/)') 'Iterating ...' call ascend(nfix, varlist) call logccs(nstrata, nobs, nfix, ncov, varlist, nca, nct, x, & b, cov, chi2, st, ifail, plevel) if (ifail == 1) then write(outstr,'(/a/)') & 'NOTE: Exceeded maximum number of iterations.' else if (ifail == 2) then write(outstr,'(/a/)') & 'ERROR: Problem inverting covariance matrix.' else if (ifail == 3) then write(outstr,'(/a/)') & 'ERROR: Underflow evaluating likelihood.' end if mpar=nfix if (typ == 1 .or. plevel > 0) then write(outstr,'(/a/a)') & ' Variable Beta Stand Error t-Value', & ' -----------------------------------------------------' end if i=0 ii=0 icat=0 do j=1, nterms-1 pos=terms(j) ncat=1 if (pos == gene) then ncat=allele_buffer%numal-1 else if (loctyp(pos) == LOC_CAT) then icat=icat+1 ncat=covariates%martable(icat)%ncells-1 end if do k=1, ncat i=i+1 ii=ii+i if (pos == gene .and. cov(ii) > 0.0d0) then statval(1)=b(i) statval(2)=cov(ii) pval=zp(abs(b(i))/sqrt(cov(ii))) end if if (typ == 1 .or. plevel > 0) then label=loc(pos) if (pos == gene) then call wrall(allele_buffer%allele_names(k+1), allel) call juststr('l',allel,3) label=label(1:min(8,len_trim(label))) // '*' // trim(allel) else if (ncat > 1) then write(allel, '(i3)') k+1 label=label(1:min(8,len_trim(label))) // '*' // trim(adjustl(allel)) end if tval=0.0d0 if (cov(ii) > 0.0d0) tval=abs(b(i))/sqrt(cov(ii)) call phist(zp(tval), 1.0d0, histo) write(outstr,'(2x,a10,1x,f12.4,3x,f12.4,3x,f12.4,1x,a3)') & label, b(i), sqrt(cov(ii)), tval, histo end if end do end do asyp=chip(chi2, nfix) pval=chip(st, nfix) if (typ == 1 .or. plevel > 0) then write(outstr,'(/a,i7,a,f5.1,a)') 'No. usable observations =', nobs, & ' (',float(100*nobs)/float(ntot),'%)' write(outstr,'(a,i7/a,i7,a,f4.1,a/a,i7)') & ' Number of affecteds =', naff, & ' Number of unaffecteds =', nobs-naff, ' (1 :', & dble(nobs-naff)/dble(naff) ,')', & ' Number of strata =', nstrata write(outstr,'(a,g14.4/a,i7/a,g14.4/a,g14.4,3a)') & ' Conditional LRTS =', chi2, & ' Degrees of freedom =', nfix, & ' Asymptotic P-value =', asyp, & ' Score test =', st, ' (P=', trim(pstring(pval)), ')' else call phist(asyp, pval, histo) write(outstr,'(a20,2(1x,i6),1x,f10.1,2(1x,a),2(1x,a))') & loc(gene), nobs, nfix+1, chi2, pstring(asyp), pstring(pval), 'SDT ', histo end if else if (typ == 1 .or. plevel > 0) then write(outstr,'(/a)') 'No usable observations.' else write(outstr,'(a20,2(1x,i6),1x,a10,2(1x,a6),1x,a)') & loc(gene), nobs, nfix+1, '-' , '-' , '-' , 'SDT' end if end if end subroutine clreg ! ! Locate beginnings and ends of strata ! stratpos is position of ith individual ! strata 0 1 2 3 ! 0 3 5 7 ! stratpos 2 4 7 1 5 3 6 ! from data: ! B A C A B C A ! subroutine getstrata(styp, dataset, nstrata, strata, stratpos) use contingency_table use ped_class implicit none integer, intent(in) :: styp type (ped_data) :: dataset integer, intent(out) :: nstrata integer, dimension(0:dataset%nobs), intent(out) :: strata integer, dimension(dataset%nobs), intent(out) :: stratpos ! local variables integer, parameter :: KNOWN=0, MISS=-9999 type (table_data) :: stable integer, dimension(:), allocatable :: counters integer :: currf, currm, lev, i, ped, pedoffset, pos, sta double precision, dimension(1) :: val nstrata=0 strata=0 stratpos=0 if (styp == -1) then pos=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (.not.dataset%untyped(i)) then pos=pos+1 stratpos(pos)=i end if end do nstrata=nstrata+1 strata(nstrata)=pos end if end do else if (styp == -2) then pos=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0 .and. dataset%nfound(ped) > 0) then i=dataset%num(ped-1)+dataset%nfound(ped) currf=dataset%fa(i) currm=dataset%mo(i) do while (i <= dataset%num(ped)) if (.not.dataset%untyped(i)) then if (dataset%fa(i) /= currf .or. dataset%mo(i) /= currm) then nstrata=nstrata+1 currf=dataset%fa(i) currm=dataset%mo(i) end if pos=pos+1 stratpos(pos)=i strata(nstrata)=pos end if i=i+1 end do end if end do else call setup_table(1, 30, stable) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) if (.not.dataset%untyped(i) .and. dataset%plocus(i,styp) /= MISS) then val(1)=dataset%plocus(i,styp) call insert_table(1, val, stable, 1) end if end do end if end do call sort_table(stable) nstrata=stable%ncells do i=1, nstrata strata(i)=stable%icount(stable%idx(i))+strata(i-1) end do allocate(counters(nstrata)) counters=0 pos=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) if (.not.dataset%untyped(i) .and. dataset%plocus(i,styp) /= MISS) then lev=findlev(dataset%plocus(i,styp), stable) counters(lev)=counters(lev)+1 pos=strata(lev-1)+counters(lev) stratpos(pos)=i end if end do end if end do end if end subroutine getstrata ! ! Haplotype Relative Risk ! subroutine dohrr(trait, locnam, gene, iter, mincnt, gt, thresh, & dataset, allele_buffer, pval, plevel) use outstream use alleles_class use ped_class use rngs use statfuns implicit none integer, intent(in) :: trait character (len=*), intent(in) :: locnam integer, intent(in) :: gene integer, intent(in) :: iter integer, intent(in) :: mincnt integer, intent(in) :: gt double precision, intent(in) :: thresh type (ped_data) :: dataset type (allele_data), intent(inout) :: allele_buffer double precision, intent(out) :: pval integer, intent(in) :: plevel ! local variables integer, parameter :: KNOWN=0, MISS=-9999 ! ! array for allele counts in cases and controls ! integer, dimension(dataset%nobs) :: aff integer, dimension(dataset%maxsiz,2) :: set integer, dimension(allele_buffer%numal,4) :: cntall ! integer, dimension(dataset%nped) :: numaff ! integer :: cg1, cg2, pg1, pg2, mg1, mg2, tr1, tr2, nt1, nt2 integer :: df, gen2, i, idx, it, j, k, nca, nco, nuntyp, tailp integer :: num, ped, pedoffset, totaff logical :: xmale character (len=1) :: sx character (len=3) :: allel, histo character (len=7) :: gtp, gtp2 double precision :: asyp, casden, conden, chisq, mchisq, ochisq, pexp, vchisq ! functions ! chip integer :: getnam character (len=6) :: pstring double precision :: binz, isaff interface subroutine simped(ped, dataset, allele_buffer, set) use alleles_class use ped_class integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data), intent(in) :: allele_buffer integer, dimension(:,:), intent(out) :: set end subroutine simped subroutine xsimped(ped, dataset, allele_buffer, set) use alleles_class use ped_class integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data), intent(in) :: allele_buffer integer, dimension(:,:), intent(out) :: set end subroutine xsimped function twobyk(sta, fin, cntall, pexp) double precision twobyk integer, intent(in) :: sta, fin integer, dimension(:,:), intent(in) :: cntall double precision, intent(in) :: pexp end function twobyk end interface ! df=-1 gen2=gene+1 nuntyp=0 do j=1, allele_buffer%numal cntall(j,4)=allele_buffer%allele_names(j) do k=1, 3 cntall(j,k)=0 end do end do totaff=0 mchisq=0.0D0 vchisq=0.0D0 ! ! If high print level, then list transmitted and nontransmitted alleles ! for each informative proband ! if (plevel > 1) then write(outstr,'(a/a)') 'Informative Child Trans Not Tr ', & 'Pedigree ID Sex Mat Pat Mat Pat' end if ! do ped=1, dataset%nped numaff(ped)=0 if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped) do i=pedoffset+1, num dataset%untyped(i)=.false. end do do i=pedoffset+dataset%nfound(ped)+1, num xmale=(allele_buffer%xlinkd .and. dataset%sex(i) == 1) if (.not.observed(i, gene, dataset)) then nuntyp=nuntyp+1 dataset%untyped(i)=.true. else if (isaff(dataset%plocus(i,trait), thresh, gt) == 2.0) then numaff(ped)=numaff(ped)+1 totaff=totaff+1 aff(totaff)=i pg1=MISS pg2=MISS if (observed(dataset%fa(i), gene, dataset)) then call get_namedgeno(dataset%fa(i), gene, gen2, dataset, & allele_buffer, pg1, pg2) end if mg1=MISS mg2=MISS if (observed(dataset%mo(i), gene, dataset)) then call get_namedgeno(dataset%mo(i), gene, gen2, dataset, & allele_buffer, mg1, mg2) end if call get_namedgeno(i, gene, gen2, dataset, allele_buffer, cg1, cg2) if (xmale) then call xtrans(mg1, mg2, cg1, cg2, tr1, tr2, nt1, nt2) else call trans(pg1, pg2, mg1, mg2, cg1, cg2, tr1, tr2, nt1, nt2, 0) end if ! *all* transmitted alleles cntall(cg1,2)=cntall(cg1,2)+1 if (.not.xmale) cntall(cg2,2)=cntall(cg2,2)+1 ! nontransmitted alleles if (nt1 /= MISS) cntall(nt1,1)=cntall(nt1,1)+1 if (nt2 /= MISS .and. .not.allele_buffer%xlinkd) then cntall(nt2,1)=cntall(nt2,1)+1 end if ! print out transmitted and nontransmitted genotypes if (plevel > 1) then tr1=allele_buffer%allele_names(cg1) if (.not.xmale) tr2=allele_buffer%allele_names(cg2) if (nt1 /= MISS) nt1=allele_buffer%allele_names(nt1) if (nt2 /= MISS .and. .not.allele_buffer%xlinkd) then nt2=allele_buffer%allele_names(nt2) else nt2=MISS end if call wrgtp(tr1,tr2,gtp,'/', '', 2) call wrgtp(nt1,nt2,gtp2,'/', '', 2) sx='m' if (dataset%sex(i) == 2) then sx='f' else if (dataset%sex(i) == MISS) then sx=' ' end if write(outstr,'(a10,a10,2x,a1,1x,2(1x,a8))') & dataset%pedigree(ped), dataset%id(i), sx, gtp, gtp2 end if end if end do end if end do ! nca=0 nco=0 do i=1,allele_buffer%numal nco=nco+cntall(i,1) nca=nca+cntall(i,2) cntall(i,3)=cntall(i,1)+cntall(i,2) if (cntall(i,3) > 0) df=df+1 end do ! Calculate association statistic if (df < 0) df=0 pexp=0.0D0 ochisq=0.0D0 asyp=1.0D0 if (nca > 0 .and. nco > 0) then pexp=dble(nca)/dble(nca+nco) ochisq=twobyk(1, allele_buffer%numal, cntall, pexp) if (df > 0) asyp=chip(ochisq, max(1,df)) end if ! if (plevel > 0) then write(outstr,'(/a,a15,a/a/a)') & ' ---- HRR Analysis for "',locnam,'" ---------' , & ' Allele Affected Control Total Dev', & ' ------------------------------------------------' casden=max(1.0d0, dble(nca)) conden=max(1.0d0, dble(nco)) do i=1, allele_buffer%numal call wrall(cntall(i,4),allel) write(outstr,'(3x,a3,2x,2(2x,i5,1x,a1,f4.3,a1),i8,1x,f6.1)') & allel, cntall(i,2), '(', dble(cntall(i,2))/casden, ')', & cntall(i,1), '(', dble(cntall(i,1))/conden, ')', & cntall(i,3), binz(cntall(i,2),cntall(i,3),pexp) end do write(outstr,'(a/a8,2(2x,i5,7x),i8)') & ' -------------------------------------------------', & 'Total',nca,nco,nca+nco write(outstr,'(/a,i6/a,i6)') & ' No. trait(+) marker(-) =',nuntyp, & ' No. trait(+) marker(+) =',nca/2 write(outstr,'(a,f6.1/a,i4/a,3x,a)') & ' Contingency Pearson chi-sq =',ochisq, & ' Nominal degrees of freedom =',df, & ' Nominal P-value =', pstring(asyp) end if ! ! if nca=0 or nco=0 or iter=0 or df=0, then Monte-Carlo procedure superfluous ! it=0 tailp=0 if (nca == 0 .or. nco == 0 .or. df == 0 .or. iter == 0) then pval=1.0D0 else ! ! Sequential Monte-Carlo P-value after Besag & Clifford Biometrika 1991 ! P= tailp/it if tailp=mincnt or (tailp+1)/(it+1) if tailp<mincnt && it=iter ! do while (it /= iter .and. tailp /= mincnt) it=it+1 do j=1, allele_buffer%numal do k=1, 3 cntall(j,k)=0 end do end do totaff=0 do ped=1, dataset%nped if (numaff(ped)>0) then pedoffset=dataset%num(ped-1) if (allele_buffer%xlinkd) then call xsimped(ped, dataset, allele_buffer, set) do i=totaff+1, totaff+numaff(ped) idx=aff(i) pg1=MISS pg2=MISS mg1=MISS mg2=MISS if (.not.dataset%untyped(dataset%fa(idx))) then pg1=set(dataset%fa(idx)-pedoffset,1) pg2=set(dataset%fa(idx)-pedoffset,2) end if if (.not.dataset%untyped(dataset%mo(idx))) then mg1=set(dataset%mo(idx)-pedoffset,1) mg2=set(dataset%mo(idx)-pedoffset,2) end if cg1=set(idx-pedoffset,1) cg2=set(idx-pedoffset,2) if (dataset%sex(idx) == 1) then call xtrans(mg1,mg2,cg1,cg2,tr1,tr2,nt1,nt2) else call trans(pg1, pg2, mg1, mg2, cg1,cg2,tr1,tr2,nt1,nt2,1) end if cntall(cg1,2)=cntall(cg1,2)+1 if (dataset%sex(idx) /= 1) cntall(cg2,2)=cntall(cg2,2)+1 if (nt1 /= MISS) cntall(nt1,1)=cntall(nt1,1)+1 if (nt2 /= MISS) cntall(nt2,1)=cntall(nt2,1)+1 end do else call simped(ped, dataset, allele_buffer, set) do i=totaff+1, totaff+numaff(ped) idx=aff(i) pg1=MISS pg2=MISS mg1=MISS mg2=MISS if (.not.dataset%untyped(dataset%fa(idx))) then pg1=set(dataset%fa(idx)-pedoffset,1) pg2=set(dataset%fa(idx)-pedoffset,2) end if if (.not.dataset%untyped(dataset%mo(idx))) then mg1=set(dataset%mo(idx)-pedoffset,1) mg2=set(dataset%mo(idx)-pedoffset,2) end if cg1=set(idx-pedoffset,1) cg2=set(idx-pedoffset,2) call trans(pg1, pg2, mg1, mg2, cg1, cg2, tr1, tr2, nt1, nt2, 1) cntall(cg1,2)=cntall(cg1,2)+1 cntall(cg2,2)=cntall(cg2,2)+1 if (nt1 /= MISS) cntall(nt1,1)=cntall(nt1,1)+1 if (nt2 /= MISS) cntall(nt2,1)=cntall(nt2,1)+1 end do end if totaff=totaff+numaff(ped) end if end do ! nco=0 do i=1,allele_buffer%numal nco=nco+cntall(i,1) cntall(i,3)=cntall(i,1)+cntall(i,2) end do pexp=dble(nca)/dble(nca+nco) chisq=twobyk(1, allele_buffer%numal, cntall, pexp) call moment(it, chisq, mchisq, vchisq) if (chisq > ochisq .or. (chisq == ochisq .and. random() > 0.5)) then tailp=tailp+1 end if if (plevel > 1) then write(outstr,'(/a,i4,a,f6.1)') 'Pseudosample ',it,': Chisq=',chisq do i=1,allele_buffer%numal write(outstr,'(i8,2(2x,i5,1x,a1,f3.2,a1),i8)') & cntall(i,4), & cntall(i,2), '(', float(cntall(i,2))/float(nca), ')', & cntall(i,1), '(', float(cntall(i,1))/float(nco), ')', cntall(i,3) end do end if end do if (tailp < mincnt) then tailp=tailp+1 it=it+1 end if vchisq=vchisq/dble(max(1,it-1)) pval=dble(tailp)/dble(it) end if if (plevel > 0) then write(outstr,'(a,i0,a,i0,3a/a,f6.1,a,f6.1,a)') & ' Equalled or exceeded by =',tailp,'/',it, & ' simulated values (', trim(pstring(pval)), ')', & ' Mean (Var) simulated chi-sqs =',mchisq,' (',vchisq,')' else if (plevel > -2) then call phist(asyp, pval, histo) write(outstr,'(a20,2(1x,i6),1x,f10.1,2(1x,a),1x,i6,2(1x,a))') & locnam, nca/2, df, ochisq, pstring(asyp), pstring(pval), it, 'HRR ', histo end if if (iter==0) pval=asyp end subroutine dohrr ! ! Monte-Carlo approach to various TDTs ! subroutine dotdt(trait, locnam, gene, genetyp, freqfnd, iter, mincnt, & use2, typ, cutoff, gt, thresh, dataset, pval, plevel) use outstream use alleles_class use ped_class use rngs use statfuns implicit none integer, intent(in) :: trait character (len=*), intent(in) :: locnam integer, intent(in) :: gene, genetyp integer, intent(in) :: freqfnd integer, intent(in) :: iter integer, intent(in) :: mincnt integer, intent(in) :: use2 integer, intent(in) :: typ integer, intent(in) :: cutoff integer, intent(in) :: gt double precision, intent(in) :: thresh type (ped_data) :: dataset double precision, intent(out) :: pval integer, intent(in) :: plevel ! integer, parameter :: KNOWN=0, MISS=-9999 ! ! array for allele counts in cases and controls ! type (allele_data) :: allele_buffer integer, dimension(dataset%nobs) :: aff integer, dimension(dataset%nobs,2) :: set logical, dimension(dataset%nobs) :: untyped integer :: nallele, ngcount integer, dimension(:,:), allocatable :: cntall integer, dimension(:,:), allocatable :: gcount integer, dimension(dataset%nped) :: numaff integer :: cg1, cg2, pg1, pg2, mg1, mg2, tr1, tr2, nt1, nt2 integer :: num, ped, pedoffset integer :: alltr, allnt, df, gdf, gen2, i, it, j, k, mxiter, ntest, tailp, tot integer :: prob, probandi logical :: xmale character (len=3) :: allel, allel2, histo double precision :: celltdt, tdt, otdt, gtdt, mgtdt, mcnem double precision :: asyp, bestm, bestp, ewens, ftdev, gasyp character (len=7) :: gtp, gtp2 ! functions ! chip integer :: getnam logical :: tdtuse character (len=6) :: pstring double precision :: bonf, clcmcn, isaff, ln interface subroutine freq(gene, loctyp, fndr, dataset, allele_buffer) use ped_class use alleles_class integer, intent(in) :: gene integer, intent(in) :: loctyp integer, intent(in) :: fndr type (ped_data), intent(in) :: dataset type (allele_data), intent(inout) :: allele_buffer end subroutine freq subroutine csimped(ped, dataset, untyped, set, xlinkd) use ped_class integer, intent(in) :: ped type (ped_data) :: dataset logical, dimension(:), intent(in) :: untyped integer, dimension(:,:), intent(inout) :: set logical, intent(in) :: xlinkd end subroutine subroutine incpo(tr, nt, nall, cntall) integer, intent(in) :: tr, nt integer, intent(inout) :: nall integer, dimension(:,:), intent(inout) :: cntall end subroutine incpo subroutine incr(tr1, tr2, nt1, nt2, ngcount, gcount) integer, intent(in) :: tr1, tr2 integer, intent(in) :: nt1, nt2 integer, intent(inout) :: ngcount integer, dimension(:,:), intent(inout) :: gcount end subroutine incr subroutine shuffle(nallele, cntall, tot, cutoff, tdt, mxiter, mincnt, pvalue) integer, intent(in) :: nallele integer, intent(inout) :: cntall(:,:) integer, intent(in) :: tot integer, intent(in) :: cutoff double precision, intent(in) :: tdt integer, intent(inout) :: mxiter integer, intent(in) :: mincnt double precision, intent(out) :: pvalue end subroutine shuffle function clcchi(ngcount, gcount, cutoff) double precision :: clcchi integer, intent(in) :: ngcount integer, dimension(:,:), intent(in) :: gcount integer, intent(in) :: cutoff end function clcchi end interface ! call setup_freq(10, allele_buffer) call freq(gene, genetyp, freqfnd, dataset, allele_buffer) allocate(cntall(allele_buffer%numgtp, 4), & gcount(allele_buffer%numgtp, 4)) df=0 asyp=1.0d0 ewens=0.0D0 gdf=0 gen2=gene+1 nallele=0 ngcount=0 ntest=0 mgtdt=0.0D0 tot=0 tdt=0.0D0 do i=1, allele_buffer%numgtp do j=1,4 gcount(i,j)=0 cntall(i,j)=0 end do end do probandi=0 ! ! If high print level, then list transmitted and nontransmitted alleles ! for each informative proband ! if (plevel > 1) then write(outstr,'(a/a)') 'Informative Child Trans Not Tr ', & 'Pedigree ID Mat Pat Mat Pat' end if ! do ped=1, dataset%nped numaff(ped)=0 if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped) do i=pedoffset+1, pedoffset+dataset%nfound(ped) untyped(i)=.not.observed(i, gene, dataset) if (untyped(i)) then set(i,1)=MISS set(i,2)=MISS else call get_namedgeno(i, gene, gen2, dataset, allele_buffer, & set(i,1), set(i,2)) end if end do do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped) xmale=(allele_buffer%xlinkd .and. dataset%sex(i) == 1) untyped(i)=.false. if (.not.observed(i, gene, dataset)) then untyped(i)=.true. set(i,1)=MISS set(i,2)=MISS else call get_namedgeno(i, gene, gen2, dataset, allele_buffer, & set(i,1), set(i,2)) pg1=set(dataset%fa(i),1) pg2=set(dataset%fa(i),2) mg1=set(dataset%mo(i),1) mg2=set(dataset%mo(i),2) ! ! nonfounder affected & typed & 1 or 2 parents heterozygous at marker ! if (isaff(dataset%plocus(i,trait), thresh, gt) == 2.0 .and. & tdtuse(pg1, pg2, mg1, mg2, numaff(ped), use2, allele_buffer%xlinkd)) then numaff(ped)=numaff(ped)+1 probandi=probandi+1 aff(probandi)=i if (xmale) then call xtrans(mg1, mg2, set(i,1), set(i,2), tr1, tr2, nt1, nt2) else call trans(pg1, pg2, mg1, mg2, set(i,1), set(i,2), tr1, tr2, nt1, nt2, typ) end if if (plevel > 1) then call wrgtp(tr1, tr2, gtp, '/', '', 2) call wrgtp(nt1, nt2, gtp2, '/', '', 2) write(outstr,'(a10,a10,2(1x,a8))') dataset%pedigree(ped), dataset%id(i), gtp, gtp2 end if call incpo(tr1, nt1, nallele, cntall) call incpo(tr2, nt2, nallele, cntall) call incr(tr1, tr2, nt1, nt2, ngcount, gcount) end if end if end do end if end do ! if (plevel > 1) then write(outstr,*) end if if (plevel > 0) then write(outstr,'(/a,i3)') 'Number of informative probands: ', probandi write(outstr,'(/a,a10,a/a/a)') & ' - Allele by Allele TDT:"',locnam,'" -', & ' Allele Trans Not Tr TDT P-value', & ' --------------------------------------' end if bestm=0.0D0 bestp=1.0D0 do i=1, allele_buffer%numal alltr=0 allnt=0 do j=1, nallele if (cntall(j,1) == i) then alltr=alltr+cntall(j,3) allnt=allnt+cntall(j,4) else if (cntall(j,2) == i) then alltr=alltr+cntall(j,4) allnt=allnt+cntall(j,3) end if end do if ((alltr+allnt) > cutoff) then ntest=ntest+1 mcnem=clcmcn(alltr, allnt) ewens=ewens+mcnem pval=binp(dble(alltr), dble(allnt)) if (pval < bestp) then bestp=pval bestm=mcnem end if if (plevel > 0) then call wrall(allele_buffer%allele_names(i), allel) write(outstr,'(3x,a3,2x,2i8,f6.1,4x,a)') & allel, alltr, allnt, mcnem, pstring(pval) end if end if end do if (ntest > 1) ewens=dble(ntest-1)*ewens/dble(ntest) if (ntest > 0) asyp=min(1.0D0,(ntest-1)*bestp) ! if (plevel > 0) then if (cutoff > 0) then write(outstr,'(/a,i4)') & 'Not using rows with totals =<',cutoff end if if (ntest > 0) then write(outstr,'(/a,i4,3(/a,3x,f8.6)/)') & 'No. of alleles used = ', ntest, & 'Bonferroni corr. 5% = ', bonf(ntest-1,0.05D0), & 'Bonferroni corr. 1% = ', bonf(ntest-1,0.01D0), & 'Bonferroni corr. 0.1%= ', bonf(ntest-1,0.001D0) else write(outstr,'(a)') 'No alleles meet inclusion criteria' end if else if (plevel > -2) then if (probandi > 0) then call phist(asyp, asyp, histo) write(outstr,'(a20,2(a1,i6),a1,f10.1,2(a1,a),a1,i6,2(a1,a))') & locnam, tabsep, probandi, tabsep, ntest, tabsep, bestm, tabsep, & pstring(asyp), tabsep, pstring(asyp), tabsep, 0, tabsep, & 'TDT-Best ', tabsep, histo else write(outstr,'(a20,2(a1,i6),a1,a10,2(a1,a6),a1,i6,a1,a,a1)') & locnam, tabsep, probandi, tabsep, ntest, tabsep, '-' , tabsep, & '-' , tabsep, '-' , tabsep, 0, tabsep, 'TDT-Best ', tabsep write(outstr,'(a20,2(a1,i6),a1,a10,2(a1,a6),a1,i6,a1,a,a1)') & locnam, tabsep, probandi, tabsep, ntest, tabsep, '-' , tabsep, & '-' , tabsep, '-' , tabsep, 0, tabsep, 'TDT-All ', tabsep write(outstr,'(a20,2(a1,i6),a1,a10,2(a1,a6),a1,i6,a1,a,a1)') & locnam, tabsep, probandi, tabsep, ntest, tabsep, '-' , tabsep, & '-' , tabsep, '-' , tabsep, 0, tabsep, 'TDT-Ewens', tabsep write(outstr,'(a20,2(a1,i6),a1,a10,2(a1,a6),a1,i6,a1,a,a1)') & locnam, tabsep, probandi, tabsep, ntest, tabsep, '-' , tabsep, & '-' , tabsep, '-' , tabsep, 0, tabsep, 'TDT-Gtp ', tabsep end if end if if (probandi == 0) then return end if ! alltr=0 allnt=0 if (plevel > 0) then write(outstr,'(/a/a/a)') & ' -------- Global Allelic TDT --------', & ' All 1 All 2 Tr=1 Tr=2 TDT', & ' ------------------------------------' end if do i=1, nallele celltdt=0.0D0 alltr=alltr+cntall(i,3) allnt=allnt+cntall(i,4) if ((cntall(i,3)+cntall(i,4)) > cutoff) then celltdt=dble(cntall(i,3)-cntall(i,4))**2 & /dble(cntall(i,3)+cntall(i,4)) tdt=tdt+celltdt df=df+1 end if if (plevel > 0) then call wrall(allele_buffer%allele_names(cntall(i,1)), allel) call wrall(allele_buffer%allele_names(cntall(i,2)), allel2) write(outstr,'(2(3x,a3,2x),2i8,f6.1)') & allel, allel2 ,cntall(i,3), cntall(i,4), celltdt end if end do tot=alltr+allnt asyp=1.0D0 if (df > 0) asyp=chip(tdt, df) ! if (plevel > 0) then write(outstr,'(/a,f6.1)') 'Allelic TDT Pearson chi-square=',tdt if (cutoff > 0) then write(outstr,'(a,i4)') 'Not using rows with totals =<',cutoff end if write(outstr,'(12x,a,i4)') 'Degrees of freedom=',df write(outstr,'(23x,a,3x,a)') 'P-value=', pstring(asyp) end if if (iter > 0 .and. tot > 0) then mxiter=10*iter call shuffle(nallele, cntall, tot, cutoff, tdt, mxiter, mincnt, pval) else mxiter=0 pval=1.0D0 end if if (plevel > 0) then write(outstr,'(a,i7,a,3x,a)') & 'Empiric P-value (', mxiter, ' iter)=', pstring(pval) write(outstr,'(/a,f6.1)') ' Ewens allelic TDT chi-square=', ewens write(outstr,'(12x,a,i4)') 'Degrees of freedom=', ntest-1 write(outstr,'(23x,a,3x,a)') 'P-value=', pstring(chip(ewens, ntest-1)) write(outstr,'(/a/a/a)') & ' ----- Genotypic Transmission Test ------', & ' Genotype Trans Expected Dev', & ' ----------------------------------------' else if (plevel > -2) then call phist(asyp, pval, histo) write(outstr,'(a20,2(a1,i6),a1,f10.1,2(a1,a),a1,i6,2(a1,a))') & locnam, tabsep, probandi, tabsep, df, tabsep, tdt, tabsep, & pstring(asyp), tabsep, pstring(pval), tabsep, mxiter, tabsep, & 'TDT-All ', tabsep, histo asyp=1.0D0 df=max(0,ntest-1) if (df > 0) asyp=chip(ewens,df) call phist(asyp, asyp, histo) write(outstr,'(a20,2(a1,i6),a1,f10.1,2(a1,a),a1,i6,2(a1,a))') & locnam, tabsep, probandi, tabsep, df, tabsep, ewens, tabsep, & pstring(asyp), tabsep, pstring(asyp), tabsep, 0, tabsep, & 'TDT-Ewens', tabsep, histo end if ! otdt=0.0D0 do i=1, ngcount if (gcount(i,3) > cutoff) then gdf=gdf+1 if (gcount(i,4) > cutoff) then otdt=otdt+dble(gcount(i,3))* & ln(dble(4*gcount(i,3))/dble(gcount(i,4))) end if end if call wrgtp(gcount(i,1),gcount(i,2),gtp,'/', '', 1) if (plevel > 0) then write(outstr,'(8x,a7,1x,i8,1x,f9.1,1x,f6.1)') & gtp, gcount(i,3), 0.25D0*dble(gcount(i,4)), & ftdev(dble(gcount(i,3)), 0.25D0*dble(gcount(i,4))) end if end do otdt=otdt+otdt gdf=max(gdf-1,1) gasyp=chip(otdt, gdf) ! ! Monte-Carlo only if iter>0 ! it=0 tailp=0 if (iter == 0 .or. tot == 0) then pval=1.0D0 else ! Sequential Monte-Carlo P-value after Besag & Clifford Biometrika 1991 ! P= tailp/it if tailp=mincnt or (tailp+1)/(it+1) if tailp<mincnt && it=iter do while (it /= iter .and. tailp /= mincnt) it=it+1 do j=1, ngcount do k=1, 4 gcount(j,k)=0 end do end do ngcount=0 probandi=0 do ped=1, dataset%nped if (numaff(ped)>0) then pedoffset=dataset%num(ped-1) call csimped(ped, dataset, untyped, set, allele_buffer%xlinkd) do i=probandi+1, probandi+numaff(ped) prob=aff(i) pg1=set(dataset%fa(prob),1) pg2=set(dataset%fa(prob),2) mg1=set(dataset%mo(prob),1) mg2=set(dataset%mo(prob),2) cg1=set(prob,1) cg2=set(prob,2) call trans(pg1, pg2, mg1, mg2, cg1, cg2, tr1, tr2, nt1, nt2, typ) call incr(tr1, tr2, nt1, nt2, ngcount, gcount) end do probandi=probandi+numaff(ped) end if end do gtdt=clcchi(ngcount, gcount, cutoff) mgtdt=mgtdt+gtdt if (gtdt > otdt .or. (gtdt == otdt .and. random() > 0.5D0)) then tailp=tailp+1 end if if (plevel > 1) then write(outstr,'(/a,i4,a,f6.1)') 'Pseudosample ',it,': gX2 =',gtdt do i=1, ngcount call wrgtp(gcount(i,1), gcount(i,2), gtp, '/', '', 1) write(outstr,'(8x,a7,1x,2i8)') gtp, gcount(i,3), gcount(i,4) end do end if end do if (tailp < mincnt) then tailp=tailp+1 it=it+1 end if mgtdt=mgtdt/dble(it) pval=dble(tailp)/dble(it) end if if (plevel > 0) then write(outstr,'(/a,f6.1/a,i4)') & 'Genotypic Transmission Chi-sq =',otdt, & ' Nominal degrees of freedom =',gdf if (cutoff > 0) then write(outstr,'(a,i4)') 'Not using rows with totals =<',cutoff end if write(outstr,'(14x,a,3x,a)') 'Nominal P-value =', pstring(gasyp) write(outstr,'(6x,a,i0,a,i0,3a/a,f6.1)') & 'Equalled or exceeded by =',tailp,'/',it, ' simulated values (', & trim(pstring(pval)), ')', 'Mean of simulated chi-squares =', mgtdt else if (plevel > -2) then call phist(gasyp, pval, histo) write(outstr,'(a20,2(a1,i6),a1,f10.1,2(a1,a),a1,i8,2(a1,a))') & locnam, tabsep, probandi, tabsep, gdf, tabsep, otdt, tabsep, & pstring(gasyp), tabsep, pstring(pval), tabsep, it, tabsep, & 'TDT-Gtp ',tabsep, histo end if if (iter==0) pval=asyp end subroutine dotdt ! ! test if useful for TDT ! function tdtuse(pg1, pg2, mg1, mg2, naff, use2, xlinkd) logical :: tdtuse integer, intent(in) :: pg1, pg2 integer, intent(in) :: mg1, mg2 integer, intent(in) :: naff integer, intent(in) :: use2 logical, intent(in) :: xlinkd ! integer, parameter :: KNOWN=0 ! tdtuse=.false. ! both parents untyped if (pg1 < KNOWN .or. mg1 < KNOWN) return ! only using one proband per family if (naff > 0 .and. use2 > 2) return ! both parents homozygous if (xlinkd .and. mg1 == mg2) return if (pg1 == pg2 .and. mg1 == mg2) return tdtuse=.true. end function tdtuse ! ! randomization test for allelic TDT -- shuffle table ITER times ! using TOT swaps per shuffle ! Genotype counts: all1, all2, #all1 trans, #all2 trans ! subroutine shuffle(nallele, cntall, tot, cutoff, tdt, mxiter, mincnt, pvalue) use rngs integer, intent(in) :: nallele integer, intent(inout) :: cntall(:,:) integer, intent(in) :: tot integer, intent(in) :: cutoff double precision, intent(in) :: tdt integer, intent(inout) :: mxiter integer, intent(in) :: mincnt double precision, intent(out) :: pvalue ! local variables integer :: toc, cum, oldcum, row, col integer :: i, it, swap, tailp double precision :: simtdt ! functions interface function clctdt(ngcount, gcount, cutoff) double precision :: clctdt integer, intent(in) :: ngcount integer, dimension(:,:), intent(in) :: gcount integer, intent(in) :: cutoff end function clctdt end interface ! ! Sequential Monte-Carlo P-value after Besag & Clifford Biometrika 1991 ! P= tailp/it if tailp=mincnt or (tailp+1)/(it+1) if tailp<mincnt && it=iter ! it=0 tailp=0 do while (it /= mxiter .and. tailp /= mincnt) it=it+1 do i=1, tot swap=irandom(1, tot) oldcum=0 rowloop: do row=1, nallele do col=3, 4 if (cntall(row,col) > 0) then cum=oldcum+cntall(row,col) if (swap <= cum .and. swap > oldcum) then toc=4 if (col == 4) toc=3 exit rowloop end if oldcum=cum end if end do end do rowloop ! if (col > 4) then ! write(*,*) 'Swap at count ', swap, ' giving row, col=', row, col ! do kk=1, nallele ! write(*,*) cntall(kk,:) ! end do ! end if cntall(row,col)=cntall(row,col)-1 cntall(row,toc)=cntall(row,toc)+1 end do simtdt=clctdt(nallele, cntall, cutoff) if (simtdt > tdt .or. (simtdt == tdt .and. random() > 0.5)) then tailp=tailp+1 end if end do if (tailp < mincnt) then tailp=tailp+1 it=it+1 end if mxiter=it pvalue=dble(tailp)/dble(mxiter) end subroutine shuffle ! ! calculate symmetry pearson chi-square ! function clctdt(ngcount, gcount, cutoff) double precision :: clctdt ! ! Genotype counts ! genotype allele1,allele2, number transmitted, number not trans ! integer, intent(in) :: ngcount integer, dimension(:,:), intent(in) :: gcount integer, intent(in) :: cutoff ! integer :: j ! clctdt=0.0D0 do j=1, ngcount if ((gcount(j,3)+gcount(j,4)) > cutoff) then clctdt=clctdt+dble(gcount(j,3)-gcount(j,4))**2 & /dble(gcount(j,3)+gcount(j,4)) end if end do end function clctdt ! ! calculate g.o.f. LR chi-square ! function clcchi(ngcount, gcount, cutoff) double precision :: clcchi ! ! Genotype counts ! genotype allele1,allele2, number transmitted, ! expected number based on parental genotypes ! ! integer, intent(in) :: ngcount integer, dimension(:,:), intent(in) :: gcount integer, intent(in) :: cutoff ! integer :: j ! clcchi=0.0D0 do j=1, ngcount if (gcount(j,3) > cutoff .and. gcount(j,4) > cutoff) then clcchi=clcchi+dble(gcount(j,3))*log(dble(4*gcount(j,3))/dble(gcount(j,4))) end if end do clcchi=clcchi+clcchi end function clcchi ! ! Test the 4 possible unions of gametes 1 2 3 4 -> 13 14 23 24 ! if typ=0 return both parental contributions, else 2=pat, 1=mat ! subroutine trans(pg1, pg2, mg1, mg2, cg1, cg2, tr1, tr2, nt1, nt2, typ) use rngs integer, intent(in) :: pg1, pg2 integer, intent(in) :: mg1, mg2 integer, intent(in) :: cg1, cg2 integer, intent(out) :: tr1, tr2 integer, intent(out) :: nt1, nt2 integer, intent(in) :: typ ! integer, parameter :: MISS=-9999 ! tr1=MISS tr2=MISS nt1=MISS nt2=MISS if ((pg1 == MISS).and.(mg1 /= MISS)) then if (mg1 == cg1 .and. mg2 == cg2) then if (mg1 == mg2) then tr1=mg1 nt1=mg2 end if else if ((mg1 == cg1).or.(mg1 == cg2)) then tr1=mg1 nt1=mg2 else if((mg2 == cg1).or.(mg2 == cg2)) then tr1=mg2 nt1=mg1 end if else if((pg1 /= MISS).and.(mg1 == MISS)) then if ((pg1 == cg1).and.(pg2 == cg2)) then if (pg1 == pg2) then tr2=pg1 nt2=pg2 end if else if ((pg1 == cg1).or.(pg1 == cg2)) then tr2=pg1 nt2=pg2 else if((pg2 == cg1).or.(pg2 == cg2)) then tr2=pg2 nt2=pg1 end if else if(pg1 == mg1 .and. pg2 == mg2 .and. pg1 == cg1 .and. pg2 == cg2) then if (pg1 == pg2) then tr1=mg1 nt1=mg2 tr2=pg2 nt2=pg1 else if (typ == 0) then if (random() > 0.5) then tr1=mg1 nt1=mg2 tr2=pg2 nt2=pg1 else tr1=mg2 nt1=mg1 tr2=pg1 nt2=pg2 end if end if else if(((pg1 == cg1).and.(mg1 == cg2)) .or. ((pg1 == cg2).and.(mg1 == cg1))) then tr1=mg1 nt1=mg2 tr2=pg1 nt2=pg2 else if(((pg1 == cg1).and.(mg2 == cg2)) .or. ((pg1 == cg2).and.(mg2 == cg1))) then tr2=pg1 nt2=pg2 tr1=mg2 nt1=mg1 else if(((pg2 == cg1).and.(mg1 == cg2)) .or. ((pg2 == cg2).and.(mg1 == cg1))) then tr2=pg2 nt2=pg1 tr1=mg1 nt1=mg2 else if(((pg2 == cg1).and.(mg2 == cg2)) .or. ((pg2 == cg2).and.(mg2 == cg1))) then tr2=pg2 nt2=pg1 tr1=mg2 nt1=mg1 end if ! check to see which parental contribution to retain if (typ == 1) then tr2=MISS nt2=MISS else if (typ == 2) then tr1=MISS nt1=MISS end if end subroutine trans ! ! Transmission of X-linked marker to a male ! subroutine xtrans(mg1, mg2, cg1, cg2, tr1, tr2, nt1, nt2) integer, intent(in) :: mg1, mg2 integer, intent(inout) :: cg1, cg2 integer, intent(out) :: tr1, tr2 integer, intent(out) :: nt1, nt2 ! integer, parameter :: MISS=-9999 tr1=MISS nt1=MISS tr2=MISS nt2=MISS if (mg1 /= MISS) then if ((mg1 == cg1) .or. (mg1 == cg2)) then tr1=mg1 nt1=mg2 else if ((mg2 == cg1) .or. (mg2 == cg2)) then tr1=mg2 nt1=mg1 end if end if end subroutine xtrans ! ! Increment counts of transmitted and nontransmitted alleles: parentwise ! subroutine incpo(tr, nt, nall, cntall) integer, intent(in) :: tr, nt integer, intent(inout) :: nall integer, dimension(:,:), intent(inout) :: cntall ! integer, parameter :: MISS=-9999 interface subroutine insgen(a1, a2, ngcount, gcount, typ, haplo) integer, intent(in) :: a1, a2 integer, intent(inout) :: ngcount integer, dimension(:,:), intent(inout) :: gcount integer, intent(in) :: typ integer, intent(in) :: haplo end subroutine end interface ! if (tr == MISS .or. nt == MISS .or. tr == nt) return if (tr <= nt) then call insgen(tr, nt, nall, cntall, 3, 1) else call insgen(nt, tr, nall, cntall, 4, 1) end if end subroutine incpo ! ! Increment counts of transmitted and expected genotypes ! Revised after reading Thomas 1999 ! subroutine incr(tr1, tr2, nt1, nt2, ngcount, gcount) integer, intent(in) :: tr1, tr2 integer, intent(in) :: nt1, nt2 integer, intent(inout) :: ngcount integer, dimension(:,:), intent(inout) :: gcount ! integer, parameter :: MISS=-9999 interface subroutine insgen(a1, a2, ngcount, gcount, typ, haplo) integer, intent(in) :: a1, a2 integer, intent(inout) :: ngcount integer, dimension(:,:), intent(inout) :: gcount integer, intent(in) :: typ integer, intent(in) :: haplo end subroutine end interface ! ! only use cases both parents typed if (nt1 == MISS .or. nt2 == MISS) return ! case call insgen(tr1, tr2, ngcount, gcount, 3, 1) ! 4 pseudo-sibs for control distribution call insgen(tr1, tr2, ngcount, gcount, 4, 1) call insgen(tr1, nt2, ngcount, gcount, 4, 1) call insgen(nt1, tr2, ngcount, gcount, 4, 1) call insgen(nt1, nt2, ngcount, gcount, 4, 1) end subroutine incr ! ! update counts of genotypes or haplotypes for cases or controls -- ! binary search and insertion sort ! subroutine insgen(a1, a2, ngcount, gcount, typ, haplo) integer, intent(in) :: a1, a2 integer, intent(inout) :: ngcount integer, dimension(:,:), intent(inout) :: gcount integer, intent(in) :: typ integer, intent(in) :: haplo ! integer :: g1, g2, hi, j, k, lo, pos ! if genotype, order by allele size rather than parent of origin if (haplo == 2 .or. a1 <= a2) then g1=a1 g2=a2 else g1=a2 g2=a1 end if pos=1 hi=ngcount lo=1 do while (hi >= lo) pos=lo+(hi-lo)/2 if (g1 > gcount(pos,1) .or. & (g1 == gcount(pos,1) .and. g2 > gcount(pos,2))) then lo=pos+1 else if (g1 < gcount(pos,1) .or. & (g1 == gcount(pos,1) .and. g2 < gcount(pos,2))) then hi=pos-1 else gcount(pos,typ)=gcount(pos,typ)+1 return end if end do ! else create new category do j=ngcount, pos, -1 do k=1, 4 gcount(j+1,k)=gcount(j,k) end do end do gcount(lo,1)=g1 gcount(lo,2)=g2 gcount(lo,3)=0 gcount(lo,4)=0 gcount(lo,typ)=1 ngcount=ngcount+1 end subroutine insgen ! ! Do LD analysis for unphased data ! subroutine ldp(numal, numal2, plevel) use outstream implicit none integer, intent(in) :: numal integer, intent(in) :: numal2 integer, intent(in) :: plevel ! contingency table -- counts also will contain marginal allelic counts integer :: ncells, nhcat integer, dimension(numal) :: name1 integer, dimension(numal2) :: name2 double precision, dimension(:), allocatable :: counts integer, dimension(:), allocatable :: scatter ! other local variables integer :: ioerr, ple double precision :: pval character (len=10) :: loc1, loc2 interface subroutine ascend(n, ia) integer, intent(in) :: n integer, dimension(:), intent(inout) :: ia end subroutine subroutine ld2(loc1, numal, name1, loc2, numal2, name2, & typ, ngcat, nhcat, nxcat, counts, pval, sumtyp, plevel) character (len=*), intent(in) :: loc1 integer, intent(in) :: numal integer, dimension(:), intent(in) :: name1 character (len=*), intent(in) :: loc2 integer, intent(in) :: numal2 integer, dimension(:), intent(in) :: name2 integer, intent(in) :: typ integer, intent(in) :: ngcat integer, intent(in) :: nhcat integer, intent(in) :: nxcat double precision, dimension(:), intent(inout) :: counts double precision, intent(inout) :: pval integer, intent(in) :: sumtyp integer, intent(in) :: plevel end subroutine end interface ! loc1='Locus 1' loc2='Locus 2' ple=max(1, plevel) ncells=numal*(numal+1)*numal2*(numal2+1)/4 nhcat=numal*numal*numal2*numal2 call ascend(numal, name1) call ascend(numal2, name2) ! allocate genotype counts plus room for marginal counts allocate(counts(ncells+numal+numal2)) write(outstr,'(i3,a,$)') ncells,' genotype counts> ' read(*,*,iostat=ioerr) counts(1:ncells) if (ioerr==0) then call ld2(loc1, numal, name1, loc2, numal2, name2, 1, ncells, nhcat, 0, & counts, pval, 0, ple) ! input error else write(outstr,'(a,i3,a)') 'ERROR: Expected ',ncells,' genotype counts!' end if end subroutine ldp ! ! Two SNPs, unphased and phased data ! subroutine cubicld(loc1, loc2, typ, counts, pval, sumtyp, plevel) use outstream use statfuns implicit none character (len=20), intent(in) :: loc1, loc2 integer :: typ ! counts = observed contingency table (length ncells) double precision, dimension(:), intent(inout) :: counts double precision, intent(inout) :: pval integer, intent(in) :: sumtyp, plevel ! local variables double precision, parameter :: pi=3.1415926535897932d0 integer :: i, ibest, nobs, nunph, nph, off double precision, dimension(19) :: ex double precision, dimension(4) :: lik double precision, dimension(4,4) :: eh double precision :: c0, c1, c2, c3 double precision :: a1, a2, a3 double precision :: d, e, onethird, p, q, q3, r, rootq, th double precision :: h1, h2, h3, h4, tot double precision :: chisq, den, dcov, dprime, p1, p2, pearsonr, q1, q2, r2 character (len=3) :: histo ! functions character (len=6) :: pstring interface subroutine cubiclik(typ, nunph, nph, p, counts, h1, h2, h3, h4, ex, lik, eh) implicit none integer :: typ integer, intent(in) :: nunph, nph double precision, intent(in) :: p double precision, dimension(:), intent(in) :: counts double precision, intent(in) :: h1, h2, h3, h4 double precision, dimension(19), intent(inout) :: ex double precision, intent(out) :: lik double precision, dimension(4), intent(out) :: eh end subroutine cubiclik end interface nph=0 nunph=0 onethird=1.0d0/3.0d0 lik=0.0d0 if (typ /= 2) then do i=1, 9 nunph=nunph+int(counts(i)) end do end if tot=dble(2*nunph) ibest=1 h1=0.0d0 h2=0.0d0 h3=0.0d0 h4=0.0d0 if (typ /= 1) then off=0 if (typ == 3) off=9 h1=2*counts(off+1)+counts(off+2)+counts(off+4)+counts(off+7) h2=2*counts(off+3)+counts(off+2)+counts(off+5)+counts(off+8) h3=2*counts(off+6)+counts(off+4)+counts(off+5)+counts(off+9) h4=2*counts(off+10)+counts(off+7)+counts(off+8)+counts(off+9) tot=tot+h1+h2+h3+h4 nph=int(h1+h2+h3+h4)/2 eh(ibest,1)=h1/tot eh(ibest,2)=h2/tot eh(ibest,3)=h3/tot eh(ibest,4)=h4/tot end if if (typ /= 2) then c0 = (counts(8)+counts(6)+2*counts(9)+h4) * & (counts(2)+counts(4)+2*counts(1)+h1) c1 = counts(5)*(h4+2*(counts(9)+counts(1)-counts(7)-counts(3))+h1-h3-h2)- & counts(2)*(counts(6)+h4+2*(counts(9)+counts(7)+counts(8))+counts(4)+h3)- & counts(4)*(counts(8)+h4+(2*(counts(6)+counts(9)+counts(3)))+h2) - & counts(8)*(h1+(2*(counts(1)+counts(3)))+h2) - & counts(6)*(counts(8)+h1+(2*(counts(1)+counts(7)))+h3) - & (h4+2*counts(9))*(h1+(2*counts(1))) - & counts(5)**2-((2*counts(7))+h3)*(h2+(2*counts(3))) c2 = counts(5)*(h3+(2*(counts(7)-counts(1)-counts(9)+counts(3)))-h1-h4+h2) + & 3*(counts(5)**2) c3 = -2*counts(5)**2 ! write(*,*) 'Coefs: ', c3, c2, c1, c0 ! Cubic? if (int(counts(5)) > 0) then a1=c2/c3 a2=c1/c3 a3=c0/c3 q = (a1 * a1 - 3 * a2) / 9.0d0 r = (2 * a1 * a1 * a1 - 9.0d0 * a1 * a2 + 27.0d0 * a3) / 54.0d0 q3 = q*q*q d = q3-r*r if (d <= 0.0d0) then ibest=1 e=(sqrt(-d)+abs(r))**onethird if (r > 0.0d0) e=-e p=e+q/e-a1/3.0d0 call cubiclik(typ, nunph, nph, p, & counts, h1, h2, h3, h4, ex, lik(1), eh(1,:)) else th=acos(r/sqrt(q3)) rootq=sqrt(q) a1=a1/3.0d0 call cubiclik(typ, nunph, nph, -2*rootq *cos(th/3.0d0)- a1, & counts, h1, h2, h3, h4, ex, lik(1), eh(1,:)) call cubiclik(typ, nunph, nph, -2*rootq *cos((th+2*pi)/3.0d0)-a1, & counts, h1, h2, h3, h4, ex, lik(2), eh(2,:)) call cubiclik(typ, nunph, nph, -2*rootq *cos((th-2*pi)/3.0d0)-a1, & counts, h1, h2, h3, h4, ex, lik(3), eh(3,:)) if (lik(2) > lik(ibest)) ibest=2 if (lik(3) > lik(ibest)) ibest=3 ! write(*,*) 'Three roots... best=', ibest, ': ', & ! -2*rootq *cos(th/3.0d0) - a1, '(', lik(1), ')', & ! -2*rootq *cos((th+2*pi)/3.0d0) -a1, '(', lik(2), ')', & ! -2*rootq *cos((th+4*pi)/3.0d0) -a1, '(', lik(3), ')' end if else q=-0.5d0*(c1+sign(1.0d0, c1)*sqrt(c1*c1-4*c2*c0)) if (q /= 0.0d0) then if (c2 /= 0.0d0) then call cubiclik(typ, nunph, nph, q/c2, & counts, h1, h2, h3, h4, ex, lik(1), eh(1,:)) end if call cubiclik(typ, nunph, nph, c0/q, & counts, h1, h2, h3, h4, ex, lik(2), eh(2,:)) ibest=1 if (lik(2) > lik(ibest) .or. lik(ibest) == 0.0d0) ibest=2 ! write(*,*) 'Two roots... best=', ibest, ': ', & ! q/c2, '(', lik(1), ')', & ! c0/q, '(', lik(2), ')' else ibest=0 end if end if end if nobs=nunph+nph if (ibest > 0) then p1=(eh(ibest,1)+eh(ibest,3))/tot p2=(eh(ibest,1)+eh(ibest,2))/tot q1=1.0d0-p1 q2=1.0d0-p2 den=p1*p2*q1*q2 dcov=eh(ibest,1)/tot-p1*p2 pearsonr=0.0d0 r2=pearsonr if (den > 0.0d0) then pearsonr=dcov/sqrt(den) r2=dcov*dcov/den end if if (dcov < 0.0D0) then dprime=dcov/min(p1*p2,q1*q2) else if (dcov == 0.0D0 .or. den == 0.0d0) then dprime=0.0D0 else dprime=dcov/(min(p1,p2)-p1*p2) end if dprime=abs(dprime) else chisq=0.0d0 dprime=0.0d0 r2=0.0d0 end if ! do i=1, 3 ! write(*,*) i, lik(i), ': ', eh(i,1:4)/tot ! end do chisq=0.5d0*tot*r2 pval=chip(chisq,1) if (plevel > -2) then call phist(pval, 1.0D0, histo) write(outstr,'(2(a14,a1),i6,a1,1x,f6.3,a1,f5.3,a1,f6.1,a1,i3,a1,a,2(a1,a))') & loc1, tabsep, loc2, tabsep, nobs, tabsep, dprime, tabsep, r2, & tabsep, chisq, tabsep, 1, tabsep, pstring(pval), tabsep, 'LD ', & tabsep, histo end if if (sumtyp==1) pval=r2 if (sumtyp==2) pval=dprime if (sumtyp==3) pval=pearsonr end subroutine cubicld ! ! Likelihood for pairwise SNP LD table under given level of LD ! subroutine cubiclik(typ, nunph, nph, praw, counts, h1, h2, h3, h4, ex, lik, eh) implicit none integer :: typ integer, intent(in) :: nunph, nph double precision, intent(in) :: praw double precision, dimension(:), intent(in) :: counts double precision, intent(in) :: h1, h2, h3, h4 double precision, dimension(19), intent(inout) :: ex double precision, intent(out) :: lik double precision, dimension(4), intent(out) :: eh integer :: i, off double precision :: prop1, prop2, p, tot double precision, parameter :: eps=1.0d-6 lik=-1.0d308 eh=0.0d0 p=praw if (praw < 0.0d0 .and. praw > -1.0d-6) p=0.0d0 if (praw > 1.0d0 .and. praw < 1.00001d0) p=1.0d0 if (p < 0.0d0 .or. p > 1.0d0) return lik=0.0d0 ex=0.0d0 tot=dble(nunph+nph) prop1=dble(nunph)/tot prop2=1.0d0-prop1 prop1=0.5d0*prop1/tot prop2=0.5d0*prop2/tot if (typ /= 2) then eh(1)=2*counts(1)+counts(2)+counts(4)+p*counts(5)+h1 eh(2)=2*counts(3)+counts(2)+counts(6)+(1.0d0-p)*counts(5)+h2 eh(3)=2*counts(7)+counts(8)+counts(4)+(1.0d0-p)*counts(5)+h3 eh(4)=2*counts(9)+counts(8)+counts(6)+p*counts(5)+h4 else eh(1)=h1 eh(2)=h2 eh(3)=h3 eh(4)=h4 end if ! write(*,*) eh(1), eh(2), eh(3), eh(4) ! write(*,*) eh(1)/(2*tot), eh(2)/(2*tot), eh(3)/(2*tot), eh(4)/(2*tot) if (typ /= 2) then ex(1)=0.5d0*prop1*eh(1)*eh(1) ex(2)=prop1*eh(1)*eh(2) ex(3)=0.5d0*prop1*eh(2)*eh(2) ex(4)=prop1*eh(2)*eh(3) ex(5)=prop1*(eh(1)*eh(4)+eh(2)*eh(3)) ex(6)=prop1*eh(2)*eh(4) ex(7)=0.5d0*prop1*eh(3)*eh(3) ex(8)=prop1*eh(3)*eh(4) ex(9)=0.5d0*prop1*eh(4)*eh(4) do i=1, 9 ! write(*,*) i, counts(i), ex(i) if (counts(i) > eps .and. ex(i) > eps) then lik=lik-counts(i)*log(counts(i)/ex(i)) ! write(*,*) i, 'lik=', lik end if end do end if if (typ /= 1) then off=0 if (typ == 3) off=9 ex(off+1)=0.5d0*prop2*eh(1)*eh(1) ex(off+2)=prop2*eh(1)*eh(2) ex(off+3)=0.5d0*prop2*eh(2)*eh(2) ex(off+4)=prop2*eh(1)*eh(3) ex(off+5)=prop2*eh(2)*eh(3) ex(off+6)=0.5d0*prop2*eh(3)*eh(3) ex(off+7)=prop2*eh(1)*eh(4) ex(off+8)=prop2*eh(2)*eh(4) ex(off+9)=prop2*eh(3)*eh(4) ex(off+10)=0.5d0*prop2*eh(4)*eh(4) do i=1, 10 if (counts(off+i) > eps .and. ex(off+i) > eps) then lik=lik-counts(off+i)*log(counts(off+i)/ex(off+i)) end if end do end if end subroutine cubiclik ! ! Do LD analysis for unphased and phased data ! subroutine ld2(loc1, numal, name1, loc2, numal2, name2, & typ, ngcat, nhcat, nxcat, counts, pval, sumtyp, plevel) use outstream use AS164_class use statfuns implicit none character (len=*), intent(in) :: loc1 integer, intent(in) :: numal integer, dimension(:), intent(in) :: name1 character (len=*), intent(in) :: loc2 integer, intent(in) :: numal2 integer, dimension(:), intent(in) :: name2 integer, intent(in) :: typ integer, intent(in) :: ngcat integer, intent(in) :: nhcat integer, intent(in) :: nxcat ! counts = observed contingency table (length ncells) double precision, dimension(:), intent(inout) :: counts double precision, intent(inout) :: pval integer, intent(in) :: sumtyp integer, intent(in) :: plevel ! ! loglinear model work arrays ! ! scatter = scatter matrix connecting observed and full contingency table ! full = expected values for full (unobserved) contingency table (length nfull) ! ex = expected values for contingency table iteration i ! oldex = expected values for contingency table iteration i-1 ! model = design matrix (length nfull x totpars) ! offset = offset for full (length nfull) ! integer, dimension(:), allocatable :: scatter integer , dimension(:), allocatable :: scatter double precision, dimension(:), allocatable :: full double precision, dimension(:), allocatable :: ex double precision, dimension(:), allocatable :: oldex double precision, dimension(:), allocatable :: model double precision, dimension(:), allocatable :: offset ! ! loglinear model parameters (AS164) b, cov are in AS164_class ! ! local variables integer :: a1, a2, df, df1, i, ii, ncells, nfull, npg, & nhap, nmal, nobs, noff, npars, nph, nunph, totpars logical :: xlinkd character (len=3) :: allel, allel2, histo character (len=5) :: rsquare double precision :: lnoff double precision :: ase, bigd, chisq, d, den, dprime, hedrick, & lrts, p1, p2, pearsonr, q1, q2, r2 ! functions character (len=6) :: pstring interface subroutine haptogen(numal, numal2, scatter, typ, xlinkd) integer, intent(in) :: numal integer, intent(in) :: numal2 integer, dimension(:), intent(inout) :: scatter integer, intent(in) :: typ logical, intent(inout) :: xlinkd end subroutine subroutine twohwe(numal, numal2, nfull, totpars, model, typ, xlinkd) integer, intent(in) :: numal integer, intent(in) :: numal2 integer, intent(in) :: nfull integer, intent(out) :: totpars double precision, dimension(:), intent(inout) :: model integer, intent(in) :: typ logical, intent(in) :: xlinkd end subroutine subroutine twofrq(numal, numal2, ncells, counts, typ, xlinkd) integer, intent(in) :: numal integer, intent(in) :: numal2 integer, intent(in) :: ncells double precision, dimension(:), intent(inout) :: counts integer, intent(in) :: typ logical, intent(in) :: xlinkd end subroutine subroutine emllm(ncells, nfull, totpars, npars, counts, scatter, model, & ex, oldex, full, offset, b, cov, lrts, plevel) integer, intent(in) :: ncells integer, intent(in) :: nfull integer, intent(in) :: totpars integer, intent(in) :: npars double precision, dimension(:), intent(inout) :: counts integer, dimension(:), intent(inout) :: scatter double precision, dimension(:), intent(inout) :: model double precision, dimension(:), intent(inout) :: ex double precision, dimension(:), intent(inout) :: oldex double precision, dimension(:), intent(inout) :: full double precision, dimension(:), intent(inout) :: offset double precision, dimension(:), intent(inout) :: b double precision, dimension(:), intent(inout) :: cov double precision, intent(out) :: lrts integer, intent(in) :: plevel end subroutine subroutine gl(nr, nc, design, sta, levels, reps, droplev) integer, intent(in) :: nr ! rows of design matrix integer, intent(in) :: nc ! cols of design matrix double precision, dimension(:), intent(inout) :: design integer, intent(in) :: sta ! first col integer, intent(in) :: levels ! number of cols integer, intent(in) :: reps ! repeats per level logical, intent(in) :: droplev ! drop first column end subroutine subroutine ldtab(numal, numal2, counts, ex, typ, xlinkd) integer, intent(in) :: numal integer, intent(in) :: numal2 double precision, dimension(:), intent(in) :: counts double precision, dimension(:), intent(in) :: ex integer, intent(in) :: typ logical, intent(in) :: xlinkd end subroutine end interface ! ! set up design and scatter matrices ! nhap=numal*numal2 npg=nhap*(nhap+1)/2 totpars=nhap nfull=nhcat ncells=0 nmal=0 nph=0 nunph=0 xlinkd=(nxcat > 0) if (typ == 1) then ! unphased problem npg=0 ncells=ngcat do i=1, ngcat nunph=nunph+int(counts(i)) end do noff=nunph else if (typ == 2) then ! phased data ncells=npg noff=ncells do i=1, npg nph=nph+int(counts(i)) end do noff=nph else if (typ == 3) then ! both ncells=ngcat+npg nfull=nhcat+nhcat totpars=totpars+1 do i=1, ngcat nunph=nunph+int(counts(i)) end do do i=1, npg nph=nph+int(counts(ngcat+i)) end do noff=nunph end if ! If X-linked, male haplotypes are added at end if (xlinkd) then ncells=ncells+nxcat nfull=nfull+nxcat totpars=totpars+1 do i=1, nxcat nmal=nmal+int(counts(ngcat+npg+i)) end do end if ! nobs=nph+nunph+nmal call twofrq(numal, numal2, ncells, counts, typ, xlinkd) npars=totpars df1=ncells-totpars allocate(scatter(nfull)) allocate(ex(ncells), oldex(ncells)) allocate(full(nfull), offset(nfull)) allocate(model(nfull*totpars)) if (allocated(b)) then deallocate(b) deallocate(cov) end if allocate(b(totpars), cov(totpars*(totpars+1)/2)) do i=1, nfull*totpars model(i)=0.0d0 end do call gl(nfull-nxcat, npars, model, 1, nhap, nhap, .false.) call gl(nfull, npars, model, 1, nhap, 1, .false.) if (typ == 3) then call gl(nfull-nxcat, npars, model, nhap+1, 2, (nfull-nxcat)/2, .true.) end if if (xlinkd) then call gl(nfull, npars, model, npars, 2, nfull-nxcat , .true.) end if call haptogen(numal, numal2, scatter, typ, xlinkd) ! ! offset by N to give haplotype proportions lnoff=log(float(noff)) do i=1, nfull offset(i)=lnoff end do ! ! write(outstr,*) ncells, nfull, totpars, npars ! write(outstr,*) (counts(kk), kk=1, ncells) ! if (plevel > 0) then if (typ == 1) then write(outstr,'(a,i0,a,i0,a)') & 'Modelling ', ngcat, ' unphased genotypes (N=', nunph,').' else if (typ == 2) then write(outstr,'(a,i0,a,i0,a)') & 'Modelling ', npg, ' phased genotypes (N=', nph,').' else write(outstr,'(a,2(i0,a,i0,a))') & 'Modelling ', npg,' phased genotypes (N=', nph, ') and ', & ngcat, ' unphased genotypes (N=', nunph,').' end if if (xlinkd) then write(outstr,'(a,i0,a,i0,a)') 'And ', nxcat, ' male haplotypes (N=', nmal,').' end if end if call emllm(ncells, nfull, totpars, npars, counts, scatter, model, & ex, oldex, full, offset, b, cov, lrts, plevel) ! if (plevel > 1) then call ldtab(numal, numal2, counts, ex, typ, xlinkd) end if ! ii=0 a1=1 a2=1 hedrick=0.0D0 bigd=0.0D0 r2=0.0D0 if (numal == 2 .and. numal2 == 2) then p1=dble(counts(ncells+a1)) p2=dble(counts(ncells+numal+a2)) q1=1.0d0-p1 q2=1.0d0-p2 den=p1*p2*q1*q2 if (den > 0.0d0) then r2=exp(b(1))-p1*p2 r2=r2*r2/den end if end if if (plevel > 0) then write(outstr,'(/a/a)') & ' Haplotype Prop 95% CL D D''', & ' ----------------------------------------------------' end if do i=1, nhap ii=ii+i ase=1.96d0*sqrt(cov(ii)) p1=dble(counts(ncells+a1)) p2=dble(counts(ncells+numal+a2)) q1=1.0d0-p1 q2=1.0d0-p2 d=exp(b(i))-p1*p2 if (d < 0.0D0) then dprime=d/min(p1*p2,q1*q2) else if (d == 0.0D0 .or. p1 == 0.0D0 .or. p2 == 0.0D0 .or. & q1 == 0.0d0 .or. q2 == 0.0d0) then dprime=0.0D0 else dprime=d/(min(p1,p2)-p1*p2) end if if (abs(dprime) > abs(bigd)) bigd=abs(dprime) hedrick=hedrick+p1*p2*abs(dprime) if (plevel > 0) then call wrall(name1(a1), allel) call wrall(name2(a2), allel2) write(outstr,'(1x,a3,1x,a3,3x,f6.4,3x,f6.4,a,f6.4,2(3x,f7.4))') & allel, allel2, exp(b(i)), & max(0.0d0,exp(b(i)-ase)), '--', min(1.0d0,exp(b(i)+ase)), d, dprime end if a2=a2+1 if (a2 > numal2) then a1=a1+1 a2=1 end if end do call twohwe(numal, numal2, nfull, totpars, model, typ, xlinkd) call emllm(ncells, nfull, totpars, totpars, counts, scatter, model, & ex, oldex, full, offset, b, cov, chisq, plevel) df=(numal-1)*(numal2-1) chisq=chisq-lrts pval=chip(chisq,df) rsquare=' - ' if (numal /= 2 .or. numal2 /= 2) then r2=chisq/dble(nobs) pearsonr=sqrt(r2) end if if (plevel > 0) then write(outstr,'(/a,i10/a,f12.2,a,i4,3a)') & ' Number of genotypes used =', nobs, & ' LD Model LR Chi-square =', lrts, ' (df=', df1, & ', P=', trim(pstring(chip(lrts,df1))), ')' write(outstr,'(a,f12.2,a,i4,3a/a,7x,f7.4)') & ' LR Chi-square (D=0) =', chisq, ' (df=', df, & ', P=', trim(pstring(pval)), ')' , & ' Hedrick weighted mean D'' =', hedrick if (numal == 2 .and. numal2 == 2) then write(outstr,'(17x,a,7x,f7.4)') 'r-squared =', r2 end if else if (plevel > -2) then if (numal == 2 .and. numal2 == 2) then write(rsquare,'(f5.3)') r2 end if call phist(pval, 1.0D0, histo) write(outstr,'(2(a14,a1),i6,a1,1x,f6.3,a1,a5,a1,f6.1,a1,i3,a1,a,2(a1,a))') & loc1, tabsep, loc2, tabsep, nobs, tabsep, hedrick, tabsep, rsquare, & tabsep, chisq, tabsep, df, tabsep, pstring(pval), tabsep, 'LD ', & tabsep, histo end if deallocate(b) deallocate(cov) if (sumtyp==1) pval=r2 if (sumtyp==2) pval=hedrick if (sumtyp==3) pval=pearsonr end subroutine ld2 ! ! Map haplotypes to genotypes 1=phase unknown 2=phase KNOWN ! subroutine haptogen(numal, numal2, scatter, typ, xlinkd) integer, intent(in) :: numal integer, intent(in) :: numal2 integer, dimension(:), intent(inout) :: scatter integer, intent(in) :: typ logical, intent(inout) :: xlinkd ! ! integer :: i1, i2, j1, j2, n, ng, pos ! functions integer :: clcpos ! ng=0 pos=0 if (typ == 1 .or. typ == 3) then n=numal2*(numal2+1)/2 do i1=1, numal do j1=1, numal2 do i2=1, numal do j2=1, numal2 pos=pos+1 scatter(pos)=n*(clcpos(i1,i2)-1)+clcpos(j1,j2) end do end do end do end do ng=n*numal*(numal+1)/2 end if if (typ == 2 .or. typ == 3) then n=numal*numal2 do i1=1, n do j1=1, n pos=pos+1 scatter(pos)=ng+clcpos(i1,j1) end do end do ng=ng+n*(n+1)/2 end if if (xlinkd) then do i1=1, numal do j1=1, numal2 pos=pos+1 scatter(pos)=ng+numal*(i1-1)+j1 end do end do end if return end subroutine haptogen ! ! Double HWE ! subroutine twohwe(numal, numal2, nfull, totpars, model, typ, xlinkd) integer, intent(in) :: numal integer, intent(in) :: numal2 integer, intent(in) :: nfull integer, intent(out) :: totpars double precision, dimension(:), intent(inout) :: model integer, intent(in) :: typ logical, intent(in) :: xlinkd ! integer :: bloc, i,j, i1, i2, j1, j2, mpos, nhp ! bloc=1 nhp=numal+numal2 totpars=nhp if (typ == 3) then totpars=totpars+1 bloc=bloc+1 end if if (xlinkd) then totpars=totpars+1 end if do i=1, nfull*totpars model(i)=0.0d0 end do ! mpos=0 do i=1, bloc do i1=1, numal do j1=1, numal2 do i2=1, numal do j2=1, numal2 model(mpos+i1)=model(mpos+i1)+1.0d0 model(mpos+i2)=model(mpos+i2)+1.0d0 model(mpos+numal+j1)=model(mpos+numal+j1)+1.0d0 model(mpos+numal+j2)=model(mpos+numal+j2)+1.0d0 if (i == 2) model(mpos+nhp+1)=model(mpos+nhp+1)+1.0d0 mpos=mpos+totpars end do end do end do end do end do if (xlinkd) then do i=1, numal do j=1, numal2 model(mpos+i)=model(mpos+i)+1.0d0 model(mpos+numal+j)=model(mpos+numal+j)+1.0d0 model(mpos+totpars)=model(mpos+totpars)+1.0d0 mpos=mpos+totpars end do end do end if end subroutine twohwe ! ! Marginal allele frequencies two loci ! subroutine twofrq(numal, numal2, ncells, counts, typ, xlinkd) integer, intent(in) :: numal integer, intent(in) :: numal2 integer, intent(in) :: ncells double precision, dimension(:), intent(inout) :: counts integer, intent(in) :: typ logical, intent(in) :: xlinkd ! integer :: i,j,i1, i2, j1, j2, n, pos double precision :: tot ! do pos=ncells+1, ncells+numal+numal2 counts(pos)=0.0d0 end do tot=0.0d0 pos=0 if (typ == 1 .or. typ == 3) then do i1=1, numal do i2=1, i1 do j1=1, numal2 do j2=1, j1 pos=pos+1 tot=tot+counts(pos) counts(ncells+i1)=counts(ncells+i1)+counts(pos) counts(ncells+i2)=counts(ncells+i2)+counts(pos) counts(ncells+numal+j1)=counts(ncells+numal+j1)+counts(pos) counts(ncells+numal+j2)=counts(ncells+numal+j2)+counts(pos) end do end do end do end do end if if (typ == 2 .or. typ == 3) then n=numal*numal2 j1=0 i1=1 do i=1, n j1=j1+1 if (j1 > numal2) then j1=1 i1=i1+1 end if j2=0 i2=1 do j=1, i j2=j2+1 if (j2 > numal2) then j2=1 i2=i2+1 end if pos=pos+1 tot=tot+counts(pos) counts(ncells+i1)=counts(ncells+i1)+counts(pos) counts(ncells+i2)=counts(ncells+i2)+counts(pos) counts(ncells+numal+j1)=counts(ncells+numal+j1)+counts(pos) counts(ncells+numal+j2)=counts(ncells+numal+j2)+counts(pos) end do end do end if tot=tot+tot if (xlinkd) then do i=1, numal do j=1, numal2 pos=pos+1 tot=tot+counts(pos) counts(ncells+i)=counts(ncells+i)+counts(pos) counts(ncells+numal+j)=counts(ncells+numal+j)+counts(pos) end do end do end if do pos=ncells+1, ncells+numal+numal2 counts(pos)=counts(pos)/tot end do return end subroutine twofrq ! ! Show table of genotypes and haplotypes ! subroutine ldtab(numal, numal2, counts, ex, typ, xlinkd) use outstream integer, intent(in) :: numal integer, intent(in) :: numal2 double precision, dimension(:), intent(in) :: counts double precision, dimension(:), intent(in) :: ex integer, intent(in) :: typ logical, intent(in) :: xlinkd ! integer :: i,j,i1, i2, j1, j2, n, pos character (len=7) :: gtp1, gtp2 ! functions double precision :: ftdev ! pos=0 if (typ == 1 .or. typ == 3) then write(outstr,'(/a)') 'Unphased Genotypes Observed Expected Deviance' do i1=1, numal do i2=1, i1 do j1=1, numal2 do j2=1, j1 call wrgtp(i2, i1, gtp1, '/', '', 1) call wrgtp(j2, j1, gtp2, '/', '', 1) pos=pos+1 write(outstr,'(a,1x,a,7x,f6.0,2(3x,f6.1))') & gtp1, gtp2, counts(pos), ex(pos), ftdev(counts(pos), ex(pos)) end do end do end do end do end if if (typ == 2 .or. typ == 3) then write(outstr,'(a)') 'Phased Genotypes Observed Expected Deviance' n=numal*numal2 j1=0 i1=1 do i=1, n j1=j1+1 if (j1 > numal2) then j1=1 i1=i1+1 end if j2=0 i2=1 do j=1, i j2=j2+1 if (j2 > numal2) then j2=1 i2=i2+1 end if pos=pos+1 write(outstr,'(2i3,a,2i3,9x,f6.0,2(3x,f6.1))') & i1, i2,';',j1, j2, counts(pos), ex(pos), ftdev(counts(pos), ex(pos)) end do end do end if if (xlinkd) then write(outstr,'(a)') 'Male Haplotypes Observed Expected Deviance' do i=1, numal do j=1, numal2 call wrgtp(i, j, gtp1, '/', '', 0) pos=pos+1 write(outstr,'(3x,a,12x,f6.0,2(3x,f6.1))') & gtp1, counts(pos), ex(pos), ftdev(counts(pos), ex(pos)) end do end do end if end subroutine ldtab ! ! Two locus linkage disequilibrium: autosomal or X-linked loci ! identify typed founders or nonfounders who have untyped parents ! subroutine twold(zrec, maxhap, gene1, loc1, ltyp1, gene2, loc2, ltyp2, & allele_buffer1, allele_buffer2, dataset, iter, pval, & sumtyp, plevel) use outstream use alleles_class use locus_types use ped_class implicit none ! Assume zero recombination (so parental haplotypes usable) integer, intent(in) :: zrec integer, intent(in) :: maxhap integer, intent(in) :: gene1 character (len=20), intent(in) :: loc1 integer, intent(in) :: ltyp1 integer, intent(in) :: gene2 character (len=20), intent(in) :: loc2 integer, intent(in) :: ltyp2 type (allele_data), intent(in) :: allele_buffer1, allele_buffer2 type (ped_data) :: dataset integer, intent(in) :: iter double precision, intent(out) :: pval ! Summary output statistic type 0=P-value 1=r2 2=Hedrick D' integer, intent(in) :: sumtyp integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS=-9999 ! ! integer :: tr1, tr2, nt1, nt2, tr3, tr4, nt3, nt4 integer :: g11, g12, g21, g22, g31, g32 integer :: c1, c2, c3, c4 integer :: f1, f2, f3, f4 integer :: m1, m2, m3, m4 character (len=1) :: ch character (len=1) :: sx(2) = (/'m', 'f'/) character (len=3) :: allel1, allel2 logical :: autosomal, last, xmale, xlinked integer :: ped, pedoffset integer :: cutoff, gene12, gene22, i, idx, j, maxcounts, & ngcat, nhap, nhcat, npg, ntyped, nxcat, pos, totgeno, & tothap, totmal, typ logical, dimension(dataset%maxsiz) :: eligible ! (phased and unphased) genotype counts double precision, dimension(:), allocatable :: counts ! haplotype counts (assuming no intergametic effects) integer, dimension(allele_buffer1%numal*allele_buffer2%numal) :: tble double precision :: d, dprime ! functions logical :: useld double precision :: ftdev interface subroutine inchap(g11, g12, g21, g22, ngcat, npg, & allele_buffer1, allele_buffer2, counts, typ) use alleles_class integer, intent(in) :: g11, g12 integer, intent(in) :: g21, g22 integer, intent(in) :: ngcat integer, intent(in) :: npg type (allele_data), intent(in) :: allele_buffer1, allele_buffer2 double precision, dimension(:), intent(inout) :: counts integer, intent(in) :: typ end subroutine subroutine ld2(loc1, numal, name1, loc2, numal2, name2, & typ, ngcat, nhcat, nxcat, counts, pval, sumtyp, plevel) implicit none character (len=*), intent(in) :: loc1 integer, intent(in) :: numal integer, dimension(:), intent(in) :: name1 character (len=*), intent(in) :: loc2 integer, intent(in) :: numal2 integer, dimension(:), intent(in) :: name2 integer, intent(in) :: typ integer, intent(in) :: ngcat integer, intent(in) :: nhcat integer, intent(in) :: nxcat ! counts = observed contingency table (length ncells) double precision, dimension(:), intent(inout) :: counts double precision, intent(inout) :: pval integer, intent(in) :: sumtyp integer, intent(in) :: plevel end subroutine subroutine cubicld(loc1, loc2, typ, counts, pval, sumtyp, plevel) use outstream implicit none character (len=20), intent(in) :: loc1, loc2 integer :: typ double precision, dimension(:), intent(inout) :: counts double precision, intent(inout) :: pval integer, intent(in) :: sumtyp, plevel end subroutine end interface ! pval=1.0d0 if (sumtyp > 0) pval=0.0d0 if (allele_buffer1%numal <= 1 .or. allele_buffer2%numal <= 1) return ! ngcat=allele_buffer1%numgtp * allele_buffer2%numgtp nxcat=allele_buffer1%numal*allele_buffer2%numal npg=nxcat*(nxcat+1)/2 nhcat=nxcat*nxcat ! if (plevel > 0) then write(outstr,'(/a,a14,a,a14,a/a/)') & 'Assoc for locus "', trim(loc1),'" c. locus "',trim(loc2),'"', & '---------------------------------------------------' end if if (.not.same_loctyp(ltyp1, ltyp2)) then if (plevel > 0) then write(outstr,'(a/a)') & 'NOTE: Mixed sex-linked and autosomal markers!', & ' Pooled D'' (HEDRICK) = 0.0' else if (plevel > -2) then write(outstr,'(2(a14,a1),i6,a1,1x,f6.3,a1,f6.1,a1,f6.1,a1,i4,a1,f6.4,a1,a)') & loc1, tabsep, loc2, tabsep, 0, tabsep, 0.0D0, tabsep, 0.0D0, tabsep, & 0.0d0, tabsep, 0, tabsep, 1.0D0, tabsep, 'LD ' end if return end if ! autosomal=same_loctyp(ltyp1, LOC_CODOM) xlinked=same_loctyp(ltyp1, LOC_XLIN) cutoff=0 gene12=gene1+1 gene22=gene2+1 ntyped=0 totgeno=0 tothap=0 totmal=0 ! allocate contingency table including extra room for marginal allele counts maxcounts=ngcat+npg+nhcat+allele_buffer1%numal+allele_buffer2%numal allocate(counts(maxcounts)) do i=1, maxcounts counts(i)=0.0d0 end do do i=1, nxcat tble(i)=0 end do ! ! If high print level, then list transmitted and nontransmitted alleles ! for each informative proband ! if (plevel > 2) then write(outstr,'(a/a)') & ' Informative Parent Trans Not Tr', & 'Pedigree ID Sex 1 2 1 2' end if ! ! Identify typed founders or nonfounders who have untyped parents ! do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, pedoffset+dataset%nfound(ped) if (observed(i, gene1, dataset) .and. observed(i, gene2, dataset)) then eligible(i-pedoffset)=.true. else eligible(i-pedoffset)=.false. end if end do do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped) if (observed(i, gene1, dataset) .and. observed(i, gene2, dataset) .and. & .not.eligible(dataset%fa(i)-pedoffset) .and. & .not.eligible(dataset%mo(i)-pedoffset)) then eligible(i-pedoffset)=.true. else eligible(i-pedoffset)=.false. end if end do ! ! Go through eligible offspring ! do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped) call get_geno(i, gene1, gene12, dataset, c1, c2) call get_geno(i, gene2, gene22, dataset, c3, c4) call get_geno(dataset%fa(i), gene1, gene12, dataset, f1, f2) call get_geno(dataset%fa(i), gene2, gene22, dataset, f3, f4) call get_geno(dataset%mo(i), gene1, gene12, dataset, m1, m2) call get_geno(dataset%mo(i), gene2, gene22, dataset, m3, m4) if ((eligible(dataset%fa(i)-pedoffset) .or. & eligible(dataset%mo(i)-pedoffset)) .and. & useld(c1, c2, c3, c4, f1, f2, f3, f4, m1, m2, m3, m4)) then xmale=(dataset%sex(i) /= 2 .and. xlinked) if (xmale) then call xtrans(m1, m2, c1, c2, tr1, tr2, nt1, nt2) call xtrans(m3, m4, c3, c4, tr3, tr4, nt3, nt4) else call trans(f1, f2, m1, m2, c1, c2, tr1, tr2, nt1, nt2, 0) call trans(f3, f4, m3, m4, c3, c4, tr3, tr4, nt3, nt4, 0) end if ! ! Note that once the haplotypes are used, the parent is set to ineligible ! along with any other full or half siblings ! if (eligible(dataset%fa(i)-pedoffset) .and. .not.xmale) then idx=dataset%fa(i)-pedoffset ntyped=ntyped+1 if (autosomal .and. zrec == 1) then tothap=tothap+2 call inchap(tr2, nt2, tr4, nt4, & ngcat, npg, allele_buffer1, allele_buffer2, counts, 2) call tabhap(tr2, tr4, allele_buffer1, allele_buffer2, tble) call tabhap(nt2, nt4, allele_buffer1, allele_buffer2, tble) else if (xlinked) then totmal=totmal+1 call inchap(tr2, tr4, 0, 0, & ngcat, npg, allele_buffer1, allele_buffer2, counts, 3) call tabhap(tr2, tr4, allele_buffer1, allele_buffer2, tble) end if eligible(idx)=.false. if (idx > dataset%nfound(ped)) then do j=dataset%nfound(ped)+1, dataset%num(ped)-pedoffset if (eligible(j) .and. & (dataset%fa(pedoffset+idx) == dataset%fa(pedoffset+j) .or. & dataset%mo(pedoffset+idx) == dataset%mo(pedoffset+j))) then eligible(j)=.false. end if end do end if if (plevel > 2) then write(outstr,'(a10,a10,1x,a1,2x,4(1x,i3))') & dataset%pedigree(ped), dataset%id(pedoffset+idx), 'm', tr2, tr4, nt2, nt4 end if end if if (eligible(dataset%mo(i)-pedoffset)) then idx=dataset%mo(i)-pedoffset ntyped=ntyped+1 if (zrec == 1) then tothap=tothap+2 call inchap(tr1, nt1, tr3, nt3, & ngcat, npg, allele_buffer1, allele_buffer2, counts, 2) call tabhap(tr1, tr3, allele_buffer1, allele_buffer2, tble) call tabhap(nt1, nt3, allele_buffer1, allele_buffer2, tble) else if (xmale) then totmal=totmal+1 call inchap(tr1, tr3, 0, 0, & ngcat, npg, allele_buffer1, allele_buffer2, counts, 3) call tabhap(tr1, tr3, allele_buffer1, allele_buffer2, tble) else tothap=tothap+2 call inchap(tr1, tr2, tr3, tr4, & ngcat, npg, allele_buffer1, allele_buffer2, counts, 2) call tabhap(tr1, tr2, allele_buffer1, allele_buffer2, tble) call tabhap(tr3, tr4, allele_buffer1, allele_buffer2, tble) end if eligible(idx)=.false. if (idx > dataset%nfound(ped)) then do j=dataset%nfound(ped)+1, dataset%num(ped)-pedoffset if (eligible(j) .and. (dataset%fa(pedoffset+idx) == dataset%fa(pedoffset+j) .or. & dataset%mo(pedoffset+idx) == dataset%mo(pedoffset+j))) then eligible(j)=.false. end if end do end if if (plevel > 2) then write(outstr,'(a10,a10,1x,a1,2x,4(1x,i3))') & dataset%pedigree(ped), dataset%id(pedoffset+idx),'f', tr1, tr3, nt1, nt3 end if end if end if end do do i=pedoffset+1, dataset%num(ped) if (eligible(i-pedoffset)) then xmale=(dataset%sex(i) /= 2 .and. xlinked) if (xmale) then totmal=totmal+1 call get_geno(i, gene1, gene12, dataset, g11, g12) call get_geno(i, gene2, gene22, dataset, g21, g22) call inchap(g11, g21, 0, 0, & ngcat, npg, allele_buffer1, allele_buffer2, counts, 3) if (plevel > 2) then write(outstr,'(a10,a10,1x,a1,2x,2(1x,i3),2(2x,a1,1x))') & dataset%pedigree(ped), dataset%id(i), 'm', g11, g21,'-','-' end if ! ! NB: if imputation on and X-linked marker, then unimputable pedigrees ! differ significantly from imputable pedigrees ! else totgeno=totgeno+1 call get_geno(i, gene1, gene12, dataset, g11, g12) call get_geno(i, gene2, gene22, dataset, g21, g22) call inchap(g11, g12, g21, g22, & ngcat, npg, allele_buffer1, allele_buffer2, counts, 1) if (plevel > 2) then ch='x' if (dataset%sex(i) /= MISS) ch=sx(dataset%sex(i)) write(outstr,'(a10,a10,1x,a1,2x,2(1x,i3,a1,i3))') & dataset%pedigree(ped), dataset%id(i), ch, & g11,'/',g12, g21, '/', g22 end if end if end if end do end if end do typ=0 if (totgeno > 0) typ=typ+1 if (tothap > 0) typ=typ+2 if (totmal == 0) nxcat=0 if (typ > 0) then ! if only unphased or phased genotypes, reduce table to that length if (typ == 1) then do i=ngcat+npg+1, ngcat+npg+nxcat counts(i-npg)=counts(i) end do else if (typ == 2) then do i=ngcat+1, ngcat+npg+nxcat counts(i-ngcat)=counts(i) end do end if ! tothap=tothap+totmal nhap=allele_buffer1%numal*allele_buffer2%numal if (nhap <= maxhap) then if (allele_buffer1%numal == 2 .and. allele_buffer2%numal == 2 .and. & plevel <= 0) then call cubicld(loc1, loc2, typ, counts, pval, sumtyp, plevel) else call ld2(loc1, allele_buffer1%numal, allele_buffer1%allele_names, & loc2, allele_buffer2%numal, allele_buffer2%allele_names, & typ, ngcat, nhcat, nxcat, counts, pval, sumtyp, plevel) end if else call ldtest(loc1, allele_buffer1, loc2, allele_buffer2, tble, iter, & pval, plevel) if (plevel > 0) then write(outstr,'(/a,i0,a/7x,a,i0,a)') & 'NOTE: Skipped full log-linear model (max haplotypes set at ', & maxhap, ').', 'Number of possible haplotypes was ', nhap,'.' end if end if else if (plevel > 0) then write(outstr,'(a)') 'No usable observations.' else if (plevel > -2) then write(outstr,'(2(a14,1x),5x,a)') loc1, loc2, '0 - - - - LD' end if end subroutine twold ! ! increment count of phased or unphased genotype, haplotype ! contingency table is partitioned 1..ngcat...ngcat+npg... ! subroutine inchap(g11, g12, g21, g22, ngcat, npg, & allele_buffer1, allele_buffer2, counts, typ) use alleles_class integer, intent(in) :: g11, g12 integer, intent(in) :: g21, g22 integer, intent(in) :: ngcat integer, intent(in) :: npg type (allele_data), intent(in) :: allele_buffer1, allele_buffer2 double precision, dimension(:), intent(inout) :: counts integer, intent(in) :: typ ! integer, parameter :: MISS=-9999 integer :: idx ! functions integer :: clcpos, getnam ! if (g11 == MISS .or. g21 == MISS) return ! if (typ == 1) then idx=allele_buffer2%numgtp * (clcpos(getnam(g11,allele_buffer1), & getnam(g12,allele_buffer1))-1) + & clcpos(getnam(g21,allele_buffer2), getnam(g22,allele_buffer2)) else if (typ == 2) then idx=ngcat+clcpos(allele_buffer2%numal*(getnam(g11,allele_buffer1)-1)+ & getnam(g21,allele_buffer2), & allele_buffer2%numal*(getnam(g12,allele_buffer1)-1) + & getnam(g22,allele_buffer2)) else if (typ == 3) then idx=ngcat + npg + allele_buffer2%numal*(getnam(g11,allele_buffer1)-1) + & getnam(g12,allele_buffer2) end if ! write(*,*) 'index: ',idx, ' ', typ, ' (',g11,g12,g21,g22,')' ! write(*,*) 'size: ', size(counts), allele_buffer1%numgtp, allele_buffer2%numgtp ! write(*,*) getnam(g11,allele_buffer1), & ! getnam(g12,allele_buffer1), & ! getnam(g21,allele_buffer2), & ! getnam(g22,allele_buffer2) counts(idx)=counts(idx)+1.0d0 end subroutine inchap ! ! straight haplotype count ! subroutine tabhap(g1, g2, allele_buffer1, allele_buffer2, tble) use alleles_class integer, intent(in) :: g1, g2 type (allele_data), intent(in) :: allele_buffer1, allele_buffer2 integer, dimension(allele_buffer1%numal*allele_buffer2%numal), intent(inout) :: tble ! integer, parameter :: MISS=-9999 integer :: idx ! functions integer :: getnam ! if (g1 == MISS .or. g2 == MISS) return ! idx=allele_buffer2%numal * (getnam(g1, allele_buffer1)-1) + & getnam(g2, allele_buffer2) tble(idx)=tble(idx)+1 end subroutine tabhap ! ! Check if useful triad for haplotype inference ! function useld(c1, c2, c3, c4, f1, f2, f3, f4, m1, m2, m3, m4) logical :: useld integer, intent(in) :: c1, c2, c3, c4 integer, intent(in) :: f1, f2, f3, f4 integer, intent(in) :: m1, m2, m3, m4 ! integer, parameter :: KNOWN=0 logical :: het1, het2, hom1, hom2 ! useld=.false. if (c1 <= KNOWN .or. c3 <= KNOWN) return if (f1 <= KNOWN .or. f3 <= KNOWN) return if (m1 <= KNOWN .or. m3 <= KNOWN) return ! drop out uninformative triads: eg 1.2/3.4 x 1.2/1.3 -> 1.2/3.3 ! but keep: eg 1.2/3.3 x 1.2/3.3 -> 1.2/3.3 het1=(c1 == f1 .and. c2 == f2 .and. c1 == m1 .and. c2 == m2 .and. c1 /= c2) hom1=(f1 == f2 .and. m1 == m2 .and. f1 == m1) het2=(c3 == f3 .and. c4 == f4 .and. c3 == m3 .and. c4 == m4 .and. c3 /= c4) hom2=(f3 == f4 .and. m3 == m4 .and. f3 == m3) ! if (het1 .and. .not.hom2) return if (het2 .and. .not.hom1) return ! useld=.true. end function useld ! ! LRTS and Permutation P for haplotype table ! subroutine ldtest(loc1, allele_buffer1, loc2, allele_buffer2, tble, & iter, pval, plevel) use outstream use alleles_class use statfuns implicit none character (len=20) :: loc1, loc2 type (allele_data), intent(in) :: allele_buffer1, allele_buffer2 integer, dimension(allele_buffer1%numal*allele_buffer2%numal), intent(inout) :: tble integer, intent(in) :: iter double precision, intent(inout) :: pval integer, intent(in) :: plevel ! local variables double precision, dimension(allele_buffer1%numal*allele_buffer2%numal) :: e integer, dimension(allele_buffer1%numal) :: rows integer, dimension(allele_buffer2%numal) :: cols integer :: df, econ, ncon, ncells, tot double precision :: asyp, bigd, d, dprime, dtot, hedrick, obschi, p1, p2 integer i, idx, j character (len=3) :: allel1, allel2, histo character (len=5) :: rsquare ! functions character (len=6) :: pstring double precision :: ftdev ncells=allele_buffer1%numal*allele_buffer2%numal do i=1, allele_buffer1%numal rows(i)=0 end do do j=1, allele_buffer2%numal cols(j)=0 end do tot=0 idx=0 do i=1, allele_buffer1%numal do j=1, allele_buffer2%numal idx=idx+1 tot=tot+tble(idx) rows(i)=rows(i)+tble(idx) cols(j)=cols(j)+tble(idx) end do end do if (tot==0) then if (plevel > 0) then write(outstr,'(a)') 'No usable observations.' else write(outstr,'(2(a14,1x),5x,a)') & loc1, loc2, '0 - - - - - LD' end if return end if ! if (plevel > 0) then write(outstr,'(a/a)') & ' Haplotype Observed Expected D D'' DEV', & ' -----------------------------------------------------------------' end if dtot=1.0d0/dble(tot) bigd=0.0d0 hedrick=0.0d0 idx=0 do i=1, allele_buffer1%numal do j=1, allele_buffer2%numal idx=idx+1 p1=dble(rows(i))*dtot p2=dble(cols(j))*dtot e(idx)=dble(rows(i))*dble(cols(j))*dtot d=(dble(tble(idx))-e(idx))*dtot dprime=0.0d0 if (d < 0.0d0) then dprime=d/min(p1*p2,(1.0d0-p1)*(1.0d0-p2)) else if (d > 0.0d0) then dprime=d/(min(p1,p2)-p1*p2) end if if (abs(dprime) > abs(bigd)) bigd=abs(dprime) hedrick=hedrick+p1*p2*abs(dprime) if (plevel > 0) then call wrall(allele_buffer1%allele_names(i), allel1) call wrall(allele_buffer2%allele_names(j), allel2) write(outstr, '(1x,a3,1x,a3,i8,1x,a1,f5.3,a1,1x,f9.1,2x,f7.4,2x,f7.4,1x,f6.1)') & allel1, allel2, tble(idx), '(',tble(idx)*dtot, ')', e(idx), & d, dprime, ftdev(dble(tble(idx)), e(idx)) end if end do end do call upchi(ncells, tble, e, obschi) df=(allele_buffer1%numal-1)*(allele_buffer2%numal-1) asyp=chip(obschi, df) if (iter > 0) then call simchi(allele_buffer1%numal, rows, allele_buffer2%numal, cols, tble, & e, obschi, tot, iter, pval) end if if (plevel > 0) then write(outstr,'(/a,i4/a,3x,f6.4)') & ' Number of individuals used =', tot, & ' Pooled D'' (HEDRICK) =', hedrick if (allele_buffer1%numal == 2 .and. allele_buffer2%numal == 2) then d=d/sqrt(p1*(1.0D0-p1))/sqrt(p2*(1.0D0-p2)) write(outstr,'(20x,a,3x,f6.4)') 'r-squared =', d*d end if write(outstr,'(a,f6.1/a,i4)') 'Linkage disequilibrium Chi-sq =', obschi, & ' Nominal degrees of freedom =', df write(outstr,'(14x,a,3x,a)') 'Nominal P-value =', pstring(asyp) if (iter>0) then write(outstr,'(14x,a,3x,2a,i0,a)') 'Empiric P-value =', pstring(pval), & ' (',10*tot*iter,' MCMC iterations)' end if else rsquare=' - ' if (allele_buffer1%numal == 2 .and. allele_buffer2%numal == 2) then d=d/sqrt(p1*(1.0D0-p1))/sqrt(p2*(1.0D0-p2)) write(rsquare,'(f5.3)') d*d end if call phist(pval, 1.0D0, histo) write(outstr,'(2(a14,a1),i6,a1,1x,f6.3,a1,a5,a1,f6.1,a1,i4,a1,a,2(a1,a))') & loc1, tabsep, loc2, tabsep, tot, tabsep, hedrick, tabsep, rsquare, & tabsep, obschi, tabsep, df, tabsep, pstring(pval), tabsep, 'LD ', & tabsep, histo end if end subroutine ldtest ! ! Infer haplotypes for SNPs in complete LD ! subroutine compld(gene1, gene2, newgene, cutoff, & allele_buffer1, allele_buffer2, dataset) use outstream use alleles_class use ped_class implicit none integer, intent(in) :: gene1, gene2 integer, intent(in) :: newgene integer, intent(in) :: cutoff type (allele_data), intent(in) :: allele_buffer1, allele_buffer2 type (ped_data) :: dataset integer, parameter :: KNOWN=0, MISS=-9999 ! data table integer, dimension(4) :: haps integer :: a1, a2, base1, base2, g12, g22, i, newg2, ped integer :: g1, g2, g3, g4, h1, h2, ntyp, zerohap character (len=7) :: chap base1=allele_buffer1%allele_names(1) base2=allele_buffer2%allele_names(1) g12=gene1+1 g22=gene2+1 haps = 0 newg2=newgene+1 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (observed(i, gene1, dataset) .and. observed(i, gene2, dataset)) then call get_geno(i, gene1, g12, dataset, g1, g2) call get_geno(i, gene2, g22, dataset, g3, g4) if (g1 == g2 .or. g3 == g4) then a1=1 a2=1 if (g1 /= base1) a1=a1+2 if (g2 /= base1) a2=a2+2 if (g3 /= base2) a1=a1+1 if (g4 /= base2) a2=a2+1 haps(a1)=haps(a1)+1 haps(a2)=haps(a2)+1 end if end if end do end if end do ntyp=0 h1=MISS h2=MISS zerohap=0 i=0 write(outstr,'(/a/a)') 'Haplotype Code Count', & '--------- ----- ------' do a1=1, 2 do a2=1, 2 i=i+1 if (haps(i) <= cutoff) then zerohap=i end if call wrgtp(allele_buffer1%allele_names(a1), & allele_buffer2%allele_names(a2), chap, '/', '', 2) write(outstr,'(1x,a7,4x,i2,1x,i8)') chap, 10*a1+a2, haps(i) end do end do ! Check if LD is complete if (zerohap == 0) then write(outstr,'(/a)') 'ERROR: more than 3 gametes present.' if (cutoff > 0) then write(outstr,'(7x,a)') 'Count of rare haplotype exceeds chosen threshold.' end if return end if ! else fill in phased genotypes if (zerohap==2 .or. zerohap==3) then h1=11 h2=22 else h1=12 h2=21 end if do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (observed(i, gene1, dataset) .and. observed(i, gene2, dataset)) then call get_geno(i, gene1, g12, dataset, g1, g2) call get_geno(i, gene2, g22, dataset, g3, g4) if (g1 == g2 .or. g3 == g4) then ntyp=ntyp+1 a1=11 a2=11 if (g1 /= base1) a1=a1+10 if (g2 /= base1) a2=a2+10 if (g3 /= base2) a1=a1+1 if (g4 /= base2) a2=a2+1 call order(a1, a2) call set_geno(i, newgene, newg2, dataset, a1, a2) else ntyp=ntyp+1 call set_geno(i, newgene, newg2, dataset, h1, h2) end if else call set_geno(i, newgene, newg2, dataset, MISS, MISS) end if end do end if end do write(outstr, '(/a,i5,a)') 'Created phased genotypes for ', & ntyp, ' individuals.' end subroutine compld ! ! LD-based clumping of markers indicating lowest P-value SNP in ! each clump as per PLINK etc ! Algorithm actually follows example of that in ldpred ! typ=1 save results to locstat 2=print only to screen ! subroutine clumpld(typ, alpha, ldradius, window, maxhap, dataset, plevel) use interrupt use outstream use locstring_widths use genetic_maps use sorts use alleles_class use ped_class use locus_types use locus_data implicit none integer, intent(in) :: typ double precision, intent(in) :: alpha, ldradius, window integer, intent(in) :: maxhap type (ped_data) :: dataset integer, intent(in) :: plevel ! local variables integer, parameter :: MISS=-9999 integer, dimension(nloci) :: idx integer, dimension(0:nloci) :: succ type (allele_data) :: allele_buffer1, allele_buffer2 integer :: i, ii, j, jj, nelig, nvar, ndrop, previous double precision :: r ! functions character (len=6) :: pstring interface subroutine moskld(maxhap, loc1, loc2, loc, locpos, loctyp, & allele_buffer1, dataset, r) use interrupt use outstream use alleles_class use ped_class use locus_types implicit none integer, intent(in) :: maxhap integer, intent(in) :: loc1, loc2 character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (allele_data), intent(in) :: allele_buffer1 type (ped_data) :: dataset double precision, intent(out) :: r end subroutine moskld end interface write(outstr, '(/a/3a/a)') & '------------------------------------------------------', & 'LD Clumping for "', trim(adjustl(whichstat)), '"', & '------------------------------------------------------' if (locstat_typ /= 0) then write(outstr, '(a)') 'Inappropriate type of test statistic!' return end if idx=0 ndrop=0 nvar=nloci do i=1, nvar idx(i)=i end do call srank(nvar, locstat, idx) nelig=0 do i=1, nvar if (locstat(idx(i)) > alpha) exit nelig=nelig+1 end do write(outstr, '(2a/a,i0/a,f6.4/a,f12.6)') & 'Critical alpha = ', pstring(alpha), & 'Eligible markers = ', nelig, & 'LD r threshold = ', ldradius, & 'Testing window = ', window if (locstat(idx(1)) > alpha) then write(outstr,'(/a,g12.6,a)') & 'Most significant test ', locstat(idx(1)), ' > critical alpha!' end if if (nelig == 0) then write(outstr,'(/a)') 'No active markers!' return end if succ(0)=0 do ii=2, nelig succ(ii-1)=ii end do succ(nelig)=0 if (plevel > 1) then write(outstr,'(/a/a)') & 'Dropped Marker Chr Position Stat Neighbour r', & '--------------- --- ----------- ------------ ----------------------' end if ii=1 previous=0 do while (ii /= 0) i=idx(ii) call freq(locpos(i), loctyp(i), 0, dataset, allele_buffer1) previous=ii jj=succ(ii) inner: do while (jj /= 0) j=idx(jj) if (map(j) /= MISS) then if (group(i) /= group(j)) then previous=jj jj=succ(jj) cycle else if (abs(map(i)-map(j)) > window) then previous=jj jj=succ(jj) cycle end if end if call moskld(maxhap, i, j, loc, locpos, loctyp, & allele_buffer1, dataset, r) if (r > ldradius) then ndrop=ndrop+1 succ(previous)=succ(jj) if (plevel > 1) then write(outstr,'(a15,1x,a2,1x,a12,1x,g12.6,1x,a15,1x,f6.4)') & loc(j), group(j), mapstring(map(j)), locstat(j), loc(i), r end if else previous=jj end if jj=succ(jj) end do inner ii=succ(ii) if (irupt > 0) exit !!! write(*,*) !!! do i=1, nelig !!! write(*,*) i, succ(i), idx(i), loc(idx(i)), locstat(idx(i)), group(idx(i)), ':', map(idx(i)) !!! end do !!! write(*,*) end do write(outstr, '(/a,i0,a,i0,a)') & 'Can drop ', ndrop, ' and retain ', nelig-ndrop, ' eligible markers.' if (plevel > -1) then write(outstr,'(/a/a)') & 'Selected Marker Chr Position Stat', & '--------------- --- ----------- ------------' ii=1 do while (ii /= 0) i=idx(ii) write(outstr,'(a15,1x,a2,1x,a12,1x,g12.6)') & loc(i), group(i), mapstring(map(i)), locstat(i) ii=succ(ii) end do end if ! output to locstat, overwriting P-values if (typ == 1) then whichstat='LD pruning: 0=Below_cut 1=Superfluous 2=Keep' locstat_typ=2 do i=1, nloci if (locstat(i) /= MISS) then if (locstat(i) > alpha) then locstat(i)=0 else locstat(i)=1 end if end if end do ii=1 do while (ii /= 0) locstat(idx(ii))=2 ii=succ(ii) end do end if end subroutine clumpld ! ! An improved correction for multiple testing ! Moskvina V, Schmidt KM (2008) Genet Epidemiol 32: 567-573 ! subroutine moskvina(window, alpha, maxhap, nloci, loc, loctyp, & locpos, locord, map, dataset, efftests, plevel) use interrupt use outstream use alleles_class use ped_class use locus_types implicit none double precision, intent(in) :: window, alpha integer, intent(in) :: maxhap integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(inout) :: locord double precision, dimension(:), intent(in) :: map type (ped_data) :: dataset double precision, intent(out) :: efftests integer, intent(in) :: plevel ! local variables integer, parameter :: MISS=-9999 type (allele_data) :: allele_buffer1, allele_buffer2 integer :: i, ii, j, jj, nord, ntests, numwin logical :: eval double precision :: curr, gap, loga, r, rmax, thistest ! functions character (len=6) :: pstring interface subroutine moskld(maxhap, loc1, loc2, loc, locpos, loctyp, & allele_buffer1, dataset, r) use interrupt use outstream use alleles_class use ped_class use locus_types implicit none integer, intent(in) :: maxhap integer, intent(in) :: loc1, loc2 character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (allele_data), intent(in) :: allele_buffer1 type (ped_data) :: dataset double precision, intent(out) :: r end subroutine moskld end interface loga=log10(alpha) numwin=50 nord=0 do i=1, nloci if (same_loctyp(loctyp(i), LOC_CODOM)) then nord=nord+1 locord(nord)=i end if end do efftests=0.0d0 if (nord == 0) then write(outstr,'(/a)') 'No active markers!' return end if efftests=1.0d0 if (plevel > 1) then write(outstr,'(/a/a/a15,1x,f6.4,1x,f9.1)') & 'Marker max r Neff', & '--------------- ------ ----------', & loc(locord(1)), rmax, efftests end if do ii=2, nord i=locord(ii) call freq(locpos(i), loctyp(i), 0, dataset, allele_buffer1) curr=map(i) rmax=0.0d0 eval=.true. ! Unsuccessfully parallelized this inner loop OMP DO ORDERED ! reverted 20150402 inner: do jj=ii-1, max(ii-numwin,1), -1 if (eval) then j=locord(jj) if (map(j) /= MISS) then gap=map(i)-map(j) if (gap < 0.0d0 .or. gap > window) eval=.false. end if call moskld(maxhap, i, j, loc, locpos, loctyp, & allele_buffer1, dataset, r) if (r > rmax) rmax=r if (rmax >= 0.999d0) eval=.false. end if end do inner ! thistest=1.0d0-rmax**(-1.31d0*loga) if (rmax >= 0.999) then thistest=0.0d0 else thistest=sqrt(1.0d0-rmax**(-1.31d0*loga)) end if if (plevel > 1) then write(outstr,'(a15,1x,f6.4,1x,f9.1)') loc(i), rmax, efftests end if efftests=efftests+thistest if (irupt > 0) exit end do ntests=min(nord, ii) write(outstr,'(/a,f9.1,a,f6.1,a/5a)') & 'Effective number of tests = ', efftests, & ' (', 100.d0*efftests/dble(ntests), '%)', & 'Equivalent critical alpha = ', & trim(pstring(1.0d0-(1-alpha)**(1.0d0/efftests))), & ' (exp-wide P=', trim(pstring(alpha)), ')' end subroutine moskvina ! ! wrapper for twold ! subroutine moskld(maxhap, loc1, loc2, loc, locpos, loctyp, & allele_buffer1, dataset, r) use interrupt use outstream use alleles_class use ped_class use locus_types implicit none integer, intent(in) :: maxhap integer, intent(in) :: loc1, loc2 character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (allele_data), intent(in) :: allele_buffer1 type (ped_data) :: dataset double precision, intent(out) :: r ! local variables type (allele_data) :: allele_buffer2 call freq(locpos(loc2), loctyp(loc2), 0, dataset, allele_buffer2) call twold(1, maxhap, locpos(loc1), loc(loc1), loctyp(loc1), & locpos(loc2), loc(loc2), loctyp(loc2), & allele_buffer1, allele_buffer2, dataset, & 0, r, 1, -2) r=sqrt(r) end subroutine moskld ! ! Standardization of quantitative trait overall or *within* family ! as required by the approach of Commenge ! subroutine stand(trait, dataset, typ) use ped_class implicit none integer, intent(in) :: trait type (ped_data) :: dataset integer, intent(in) :: typ ! integer, parameter :: MISS=-9999 integer :: i, n, ped double precision :: mu, sd logical :: last ! if (typ==2) then do ped=1, dataset%nped if (dataset%actset(ped) > 0) then n=0 mu=0.0D0 sd=0.0D0 do i=dataset%num(ped-1)+1, dataset%num(ped) if (dataset%plocus(i,trait) /= MISS) then n=n+1 call moment(n, dataset%plocus(i,trait), mu, sd) end if end do if (n > 0) then sd=sqrt(sd/dble(max(1,n-1))) do i=dataset%num(ped-1)+1, dataset%num(ped) if (dataset%plocus(i,trait) /= MISS) then dataset%plocus(i,trait)=(dataset%plocus(i,trait)-mu)/sd end if end do end if end if end do else if (typ == 1) then n=0 mu=0.0D0 sd=0.0D0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (dataset%plocus(i,trait) /= MISS) then n=n+1 call moment(n, dataset%plocus(i,trait), mu, sd) end if end do end if end do sd=sqrt(sd/dble(max(1,n-1))) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (dataset%plocus(i,trait) /= MISS) then dataset%plocus(i,trait)=(dataset%plocus(i,trait)-mu)/sd end if end do end if end do end if end subroutine stand ! ! subroutine lifetab(date1, date2, censor, covar, covtyp, & width1, width2, typ, dataset, plevel) use outstream use julian_epoch use locus_types use contingency_table use read_data use ped_class use statfuns implicit none integer, intent(in) :: date1, date2 integer, intent(in) :: censor integer, intent(in) :: covar, covtyp double precision, intent(in) :: width1, width2 integer, intent(in) :: typ type (ped_data) :: dataset integer, intent(in) :: plevel ! ! local variables integer, parameter :: KNOWN=0, MISS=-9999 ! ! covariate tabulation type (table_data) :: covtable integer :: nlev(3) integer, dimension(:,:,:), allocatable :: nevents, riskset double precision, dimension(:,:,:), allocatable :: pyar double precision, dimension(:), allocatable :: interv1, interv2 character (len=10) :: sdate1, sdate2 integer :: naff, nobs, nvals, unaff integer :: g1, g2, i, i2, icov, j, k, k2, pedoffset, ped, pos, sx double precision :: curage, mid, minage, minsta, maxage, maxsta, & minfin, maxfin, rang, scal, totpyar, val(1), x, w1, w2 double precision :: finish, start, surv ! loglinear model integer imod, ncells, ncov, npars, totpars double precision, dimension(:), allocatable :: counts double precision, dimension(:), allocatable :: model double precision, dimension(:), allocatable :: offset double precision, dimension(:), allocatable :: b double precision, dimension(:), allocatable :: cov integer :: df double precision :: asyp, lrts0, lrts, pred ! functions character (len=6) :: pstring double precision :: ln, togreg interface subroutine gl(nr, nc, design, sta, levels, reps, droplev) integer, intent(in) :: nr ! rows of design matrix integer, intent(in) :: nc ! cols of design matrix double precision, dimension(:), intent(inout) :: design integer, intent(in) :: sta ! first col integer, intent(in) :: levels ! number of cols integer, intent(in) :: reps ! repeats per level logical, intent(in) :: droplev ! drop first column end subroutine subroutine loglin(ncells, totpars, npars, counts, model, offset, b, cov, lrts) integer, intent(in) :: ncells integer, intent(in) :: totpars integer, intent(in) :: npars double precision, dimension(:), intent(inout) :: counts double precision, dimension(:), intent(inout) :: model double precision, dimension(:), intent(inout) :: offset double precision, dimension(:) :: b double precision, dimension(:) :: cov double precision :: lrts end subroutine loglin end interface ! nobs=0 nvals=0 minfin=1.0d99 maxfin=-1.0d99 minsta=1.0d99 maxsta=-1.0d99 minage=1.0d99 maxage=-1.0d99 scal=365.25d0 if (typ > 2) scal=1.0d0 w1=width1*scal w2=width2*scal call setup_table(1, 50, covtable) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) dataset%untyped(i)=.true. if (date1 == 0) then start=0.0d0 else start=dataset%plocus(i,date1) end if finish=dataset%plocus(i,date2) if (start /= MISS .and. finish /= MISS) then val(1)=1.0d0 if (covar /= MISS) then if (ismarker(covtyp)) then if (observed(i, covar, dataset)) then call get_geno(i, covar, covar+1, dataset, g1, g2) val(1)=encgtp(g1, g2) else val(1)=MISS end if else val(1)=dataset%plocus(i,covar) end if if (val(1) /= MISS) then call insert_table(1, val, covtable, 1) else end if end if if (val(1) /= MISS) then dataset%untyped(i)=.false. nobs=nobs+1 curage=finish-start if (start < minsta) minsta=start if (start > maxsta) maxsta=start if (finish < minfin) minfin=finish if (finish > maxfin) maxfin=finish if (curage < minage) minage=curage if (curage > maxage) maxage=curage end if end if end do end if end do if (nobs == 0) then write(outstr,'(a)') ' No usable observations.' return end if nlev(1)=1 if (covar /= MISS) nlev(1)=max(1, covtable%ncells) nlev(2)=1+int((maxsta-minsta)/w1) nlev(3)=1+int(maxage/w2) write(outstr, '(/a/a)') & 'Variable Range Strata Stratum width', & '-------- ------------------------- -------- -------------' if (typ == 1) then call wrdate(minsta+epoch, sdate1, 1) call wrdate(maxsta+epoch, sdate2, 1) write(outstr, '(a,3x,3a,i10,2x,f12.1)') & 'Start ', sdate1, ' -- ', sdate2, nlev(2), w1 call wrdate(minfin+epoch, sdate1, 1) call wrdate(maxfin+epoch, sdate2, 1) write(outstr, '(a,3x,3a,i10,2x,f12.1)') & 'Stop ', sdate1, ' -- ', sdate2, nlev(3), w2 write(outstr, '(a,3x,f10.1,a,f10.1,i10,2x,f12.1)') & 'Followed', minage/scal, ' -- ', maxage/scal, nlev(3), w2 else write(outstr, '(3(a,3x,f10.1,a,f10.1,i10,2x,f12.1/))') & 'Start ', minsta, ' -- ', maxsta, nlev(2), w1, & 'Stop ', minfin, ' -- ', maxfin, nlev(3), w2, & 'Followed', minage, ' -- ', maxage, nlev(3), w2 end if if (covar /= MISS) then write(outstr, '(/a,i2,a)') 'Covariate levels (', nlev(1), ')' call sort_table(covtable) do i=1, covtable%ncells pos=covtable%idx(i) call wrtrait(covtable%categories(pos,1)%rvalue, sdate1, covtyp, ' ', 9, 4) write(outstr,'(a10,1x,i6)') sdate1, covtable%icount(pos) end do end if allocate(nevents(nlev(1), nlev(2), nlev(3))) allocate(riskset(nlev(1), nlev(2), nlev(3))) allocate(pyar(nlev(1), nlev(2), nlev(3))) allocate(interv1(nlev(2)+1)) allocate(interv2(nlev(3)+1)) nevents=0 riskset=0 pyar=0.0d0 x=minsta interv1(1)=x do i=2, nlev(2)+1 x=x+w1 interv1(i)=x end do x=0.0d0 interv2(1)=x do i=2, nlev(3)+1 x=x+w2 interv2(i)=x end do do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) if (.not.dataset%untyped(i)) then if (date1 == 0) then start=0.0d0 else start=dataset%plocus(i,date1) end if finish=dataset%plocus(i,date2) icov=1 if (covar /= MISS) then if (ismarker(covtyp)) then if (observed(i, covar, dataset)) then call get_geno(i, covar, covar+1, dataset, g1, g2) x=encgtp(g1, g2) else x=MISS end if else x=dataset%plocus(i,covar) end if icov=findlev(x, covtable) end if ! j = age stratum ! k = event stratum curage=finish-start j=1+int((start-minsta)/w1) k=1+int(curage/w2) do i2=1, nlev(3) if (i2 < k) then riskset(icov,j,i2)=riskset(icov,j,i2)+1 if (k > 1) then pyar(icov,j,i2)=pyar(icov,j,i2)+w2 else pyar(icov,j,i2)=pyar(icov,j,i2)+interv2(i2+1)-start end if else if (i2 == k) then riskset(icov,j,i2)=riskset(icov,j,i2)+1 pyar(icov,j,i2)=pyar(icov,j,i2)+ curage - interv2(k) if (dataset%plocus(i,censor)==2) then nevents(icov,j,i2)=nevents(icov,j,i2) + 1 end if exit end if end do end if end do end if end do do i=1, nlev(1) if (nlev(1) > 1) then pos=covtable%idx(i) call wrtrait(covtable%categories(pos,1)%rvalue, sdate1, covtyp, ' ', 9, 4) write(outstr,'(/a,a10)') 'Covariate = ', sdate1 end if if (typ==1) then write(outstr, '(/a/a)') & 'Entered Time Stratum Riskset Events Person-years Incidence Surv', & '------------- ------------- --------- ------ ------------ ---------- -----' else write(outstr, '(/a/a)') & 'Entered Time Stratum Riskset Events Person-time Incidence Surv', & '------------- ------------- --------- ------ ------------ ---------- -----' end if naff=0 totpyar=0.0d0 do j=1, nlev(2) surv=1.0d0 do k=1, nlev(3) if (k>1) then write(outstr, '(a13)', advance='no') ' ' else if (typ == 1) then call wrdate(interv1(j)+epoch, sdate1, 1) write(outstr, '(a10,a)', advance='no') & sdate1, ' - ' else write(outstr, '(f10.1,a)', advance='no') & interv1(j), ' - ' end if end if x=0.0d0 if (pyar(i,j,k)>0.0d0) x=dble(nevents(i,j,k))/pyar(i,j,k)*scal naff=naff+nevents(i,j,k) totpyar=totpyar+pyar(i,j,k) if (riskset(i,j,k) > 0) then surv=surv*(1.0d0-dble(nevents(i,j,k))/dble(riskset(i,j,k))) end if write(outstr, '(1x,f10.1,a,i11,i8,f14.0,2x,f10.8,2x,f5.3)') & interv2(k)/scal, ' - ', riskset(i,j,k), nevents(i,j,k), & pyar(i,j,k)/scal, x, surv end do end do x=0.0d0 if (totpyar > 0.0d0) x=dble(naff)/totpyar*scal if (nlev(1) > 1) then nobs=covtable%icount(covtable%idx(i)) end if write(outstr, '(29x,a/27x,i11,i8,f14.0,2x,f10.8,2x,f5.3)') & '--------- ------- ------------ ---------- -----', & nobs, naff, totpyar/scal, x, surv end do ! ! Fit poisson model ! ncells=nlev(1)*nlev(2)*nlev(3) totpars=nlev(1)+nlev(2)+nlev(3)-2 ncov=totpars*(totpars+1)/2 allocate(counts(ncells), offset(ncells)) allocate(b(totpars), cov(ncov), model(ncells*totpars)) pos=0 do i=1, nlev(1) do j=1, nlev(2) do k=1, nlev(3) pos=pos+1 counts(pos)=dble(nevents(i,j,k)) offset(pos)=ln(pyar(i,j,k)) end do end do end do imod=1 b=0.0d0 cov=0.0d0 model=0.0d0 npars=totpars call gl(ncells, totpars, model, 1, nlev(1), nlev(2)*nlev(3), .false.) call gl(ncells, totpars, model, nlev(1)+1, nlev(2), nlev(3), .true.) call gl(ncells, totpars, model, nlev(1)+nlev(2), nlev(3), 1, .true.) call loglin(ncells, totpars, npars, counts, model, offset, b, cov, lrts0) df=ncells-npars asyp=chip(lrts0, df) write(outstr,'(/a,f8.1/a,i6/a,5x,a)') & ' No interaction model LRTS =', lrts0, & ' Degrees of freedom =', df, & ' Nominal P-value =', pstring(asyp) ! ! Test for effect of covariate ! if (nlev(1) > 1) then imod=2 b=0.0d0 cov=0.0d0 model=0.0d0 npars=nlev(2)+nlev(3)-1 call gl(ncells, totpars, model, 1, 1, ncells, .false.) call gl(ncells, totpars, model, 2, nlev(2), nlev(3), .true.) call gl(ncells, totpars, model, 1+nlev(2), nlev(3), 1, .true.) call loglin(ncells, totpars, npars, counts, model, offset, b, cov, lrts) lrts=lrts-lrts0 df=nlev(1)-1 asyp=chip(lrts, df) write(outstr,'(/a,f8.1/a,i6/a,5x,a)') & ' No main effect of covariate =', lrts, & ' Degrees of freedom =', df, & ' Nominal P-value =', pstring(asyp) end if if (plevel > 0) then i=0 write(outstr, '(/a/a)') & 'Term Estimate', & '------------------ -------------' if (nlev(1)==1 .or. imod > 1) then i=i+1 write(outstr, '(a,3x,f12.2)') 'Intercept ', exp(b(i)) else do j=1, nlev(1) i=i+1 write(outstr, '(a,i2,1x,f12.2)') 'Covar stratum ', j, exp(b(i)) end do end if do j=2, nlev(2) i=i+1 write(outstr, '(a,i2,1x,f12.2)') 'Entry stratum ', j, exp(b(i)) end do do j=2, nlev(3) i=i+1 write(outstr, '(a,i2,1x,f12.2)') 'Time stratum ', j, exp(b(i)) end do end if if (plevel > 1) then write(outstr, '(/a)') 'Cell Observed Expected Design Matrix' do i=1, ncells pred=0.0d0 pos=(i-1)*totpars k=pos do j=1,npars pos=pos+1 pred=pred+b(j)*model(pos) end do write(outstr,'(i4,1x,i11,1x,f11.1,2x)', advance='no') & i, int(counts(i)), exp(pred+offset(i)) do i2=k+1, k+min(20, npars) write(outstr, '(1x,i1)', advance='no') int(model(i2)) end do write(outstr,*) end do end if end subroutine lifetab ! ! Kaplan-Meier estimator of survival function and the Nelson-Aalen ! estimator of cumulative hazard. ! The Nelson-Aalen estimator is used to produce residuals, if requested. ! These are the deviance residuals of Therneau et al Biometrika 1990: ! equivalent to a variance-stabilized transformed martingale residual. ! subroutine prodlim(trait, censor, dataset, typ, resid, plevel) use outstream use ped_class implicit none integer, intent(in) :: trait integer, intent(in) :: censor type (ped_data) :: dataset integer, intent(in) :: typ integer, intent(in) :: resid integer, intent(in) :: plevel ! ! local variables integer, parameter :: MISS=-9999 integer, dimension(dataset%nobs,2) :: set double precision, dimension(dataset%nobs) :: haz, onset integer :: naff, nobs, nvals, unaff integer :: i, j, k, last, ped, pedoffset double precision :: res, x double precision :: dn, na, pl, va logical :: newval ! naff=0 nobs=0 nvals=0 do i=1, dataset%nobs set(i,1)=0 set(i,2)=0 end do do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) if (dataset%plocus(i,trait) /= MISS .and. & dataset%plocus(i,censor) /= MISS) then nobs=nobs+1 x=dataset%plocus(i,trait) newval=.true. j=0 do j=j+1 if (j > nvals) exit if (x <= onset(j)) then newval=(x < onset(j)) exit end if end do if (newval) then do k=nvals, j, -1 onset(k+1)=onset(k) set(k+1,1)=set(k,1) set(k+1,2)=set(k,2) end do nvals=nvals+1 onset(j)=x set(j,1)=0 set(j,2)=0 end if set(j,2)=set(j,2)+1 if (dataset%plocus(i,censor) == 2) then naff=naff+1 set(j,1)=set(j,1)+1 end if end if end do end if end do ! if (plevel > 1) then write(outstr,'(2(/a))') & ' Rank Age-at-onset Failed Obs', & ' ----------------------------------' do j=1,nvals write(outstr,'(1x,i4,2x,f12.4,2i8)') j, onset(j), set(j,1), set(j,2) end do end if write(outstr,'(2(/a))') & ' Age-at-onset Failed Riskset H(t) S(t) ase', & ' ---------------------------------------------------' na=0.0D0 pl=1.0D0 va=0.0D0 last=0 unaff=nobs-naff do j=1, nvals if (set(j,1) /= 0) then last=j dn=dble(set(j,1))/dble(nobs) na=na+dn pl=pl*(1.0D0-dn) va=va+dn/dble(max(1,nobs-set(j,1))) if (plevel >= 0) then write(outstr,'(1x,f12.4,2(1x,i8),3(1x,f6.4))') & onset(j), set(j,1), nobs, na, pl, pl*sqrt(va) end if end if haz(j)=na nobs=nobs-set(j,2) end do if (plevel < 0 .and. last > 0) then write(outstr,'(1x,f12.4,2(1x,i8),3(1x,f6.4))') & onset(last), set(last,1), nobs, na, pl, pl*sqrt(va) end if write(outstr,'(/a/a//i5,a,i5,a)') & ' H(t) = Nelson-Aalen estimator of integrated hazard', & ' S(t) = Kaplan-Meier estimator of survivor function', & naff,' affecteds and ',unaff,' unaffecteds used' ! ! else replace age-at-onset with residual ! if (typ == 2) then do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (dataset%plocus(i,trait) /= MISS) then x=dataset%plocus(i,trait) j=0 do j=j+1 if (x == onset(j) .or. j > nvals) exit end do if (dataset%plocus(i,censor) == 2.0D0) then res=1.0D0-haz(j) dataset%plocus(i,resid)=sign(1.0D0,res)*sqrt(-2*(res+log(1.0D0-res))) else dataset%plocus(i,resid)=-sqrt(2*haz(j)) end if end if end do end if end do end if end subroutine prodlim ! ! Rank trait values ! 1=rank all ! 2=within family rank ! 3=Blom score all ! 4=within family Blom score ! subroutine dorank(trget, trait, typ, dataset) use contingency_table use ped_class use statfuns implicit none integer, intent(in) :: trget integer, intent(in) :: trait integer, intent(in) :: typ type (ped_data) :: dataset ! Quantitative trait values type (table_data) :: table ! integer, parameter :: MISS=-9999 ! local variables integer :: i, ped double precision :: den ! functions ! ppnd ! ! tabulate sorted values and frequencies for sample if (typ==1 .or. typ==3) then call setup_table(1, 100, table) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (dataset%plocus(i,trait) /= MISS) then call insert_table(1, dataset%plocus(i, trait), table, 1) end if end do end if end do call sort_table(table) den=1.0d0/(dble(table%ntot)+0.25d0) ! assign rank or Blom score of each record to target variable do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (dataset%plocus(i,trait) /= MISS) then dataset%plocus(i,trget)=findrank(dataset%plocus(i,trait), table) if (typ==3) then dataset%plocus(i,trget)= ppnd((dataset%plocus(i,trget)-0.375d0)*den) end if else dataset%plocus(i,trget)=MISS end if end do end if end do call clean_table(table) ! ! or give within family rank or Blom score ! else if (typ==2 .or. typ==4) then do ped=1, dataset%nped if (dataset%actset(ped) > 0) then call setup_table(1, dataset%num(ped)-dataset%num(ped-1), table) do i=dataset%num(ped-1)+1, dataset%num(ped) if (dataset%plocus(i,trait) /= MISS) then call insert_table(1, dataset%plocus(i, trait), table, 1) end if end do call sort_table(table) den=1.0d0/(dble(table%ntot)+0.25d0) do i=dataset%num(ped-1)+1, dataset%num(ped) if (dataset%plocus(i,trait) /= MISS) then dataset%plocus(i,trget)=findrank(dataset%plocus(i,trait), table) if (typ==4) then dataset%plocus(i,trget)= ppnd((dataset%plocus(i,trget)-0.375d0)*den) end if else dataset%plocus(i,trget)=MISS end if end do call clean_table(table) end if end do end if end subroutine dorank ! ! Quantile normalization ! missing values are dealt with reuse of nearest value rather than ! linear interpolation ! subroutine quantnorm(nloc, loclist, loc, locpos, loctyp, & dataset, plevel) use outstream use ped_class use locus_types use sorts implicit none integer, intent(in) :: nloc ! number of dimensions integer, intent(in) :: loclist(nloc) ! variable list character (len=*), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp type (ped_data) :: dataset integer, intent(in) :: plevel ! local variables integer, parameter :: MISS=-9999 ! Position of eligible traits integer, dimension(nloc) :: idx ! Ranks of quantitative trait values integer, dimension(dataset%nobs) :: irank, valpos double precision, dimension(dataset%nobs) :: qtrait, means ! integer :: i, itrait, j, maxobs, n, ntraits, ped, pos, trait double precision :: invn maxobs=0 ntraits=0 irank=0 means=0.0d0 if (plevel > 1) then write(outstr,'(/a)') 'Traits for normalization:' end if do i=1, nloc trait=loclist(i) if (isqtrait(loctyp(trait))) then ntraits=ntraits+1 idx(ntraits)=locpos(trait) if (plevel > 1) then write(outstr,'(a)') loc(trait) end if end if end do write(outstr,'(/a,i0,a)') & 'Performing quantile normalization on ', ntraits, ' traits.' if (ntraits == 0) return ! max number of values do itrait=1, ntraits trait=idx(itrait) n=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (dataset%plocus(i,trait) /= MISS) then n=n+1 end if end do end if end do if (n > maxobs) maxobs=n end do ! do itrait=1, ntraits trait=idx(itrait) n=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (dataset%plocus(i,trait) /= MISS) then n=n+1103438 qtrait(n)=dataset%plocus(i, trait) irank(n)=n end if end do end if end do call srank(n, qtrait(1:n), irank(1:n)) if (n == maxobs) then do i=1, maxobs pos=irank(i) means(pos)=means(pos)+qtrait(i) end do else invn=dble(maxobs)/(dble(n)+0.25d0) do i=1, maxobs pos=min(maxobs, idnint(invn*dble(irank(i))-0.375d0)) j=min(n, idnint(dble(pos)/invn)) means(pos)=means(pos)+qtrait(j) end do end if end do invn=1.0d0/dble(ntraits) do i=1, maxobs means(i)=invn*means(i) end do if (plevel > 0) then write(outstr,'(a)') 'Quantile Mean value' invn=1.0d0/dble(maxobs) do i=1, maxobs write(outstr,'(f8.6,1x,g12.4)') invn*dble(i), means(i) end do end if do itrait=1, ntraits trait=idx(itrait) n=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (dataset%plocus(i,trait) /= MISS) then n=n+1 qtrait(n)=dataset%plocus(i, trait) irank(n)=n valpos(n)=i end if end do end if end do call srank(n, qtrait(1:n), irank(1:n)) if (n == maxobs) then do i=1, n pos=irank(i) dataset%plocus(valpos(i), trait)=means(pos) end do else invn=dble(maxobs)/(dble(n)+0.25d0) do i=1, n pos=min(maxobs, idnint(invn*dble(irank(i)))) dataset%plocus(valpos(i), trait)=means(pos) end do end if end do end subroutine quantnorm ! ! ordinal index each proband for a target trait within a family ! subroutine docum(trget, loctyp, trait, dataset) use outstream use locus_types use ped_class implicit none integer, intent(in) :: trget, loctyp integer, intent(in) :: trait type (ped_data) :: dataset ! local variables integer, parameter :: MISS=-9999 integer :: i, n, ped, pedoffset double precision :: stot n=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) stot=0.0d0 do i=pedoffset+1, dataset%num(ped) dataset%plocus(i,trait) = MISS if (dataset%plocus(i,trget) /= MISS) then n=n+1 stot=stot+1.0d0 dataset%plocus(i,trait) = stot end if end do end if end do write(outstr,'(a,i0,a)') & 'Generated index for ', n, ' eligible individuals according to pedigree position.' end subroutine docum ! ! Gene drop a single marker, conditionally on ! observed founder genotypes ! subroutine wrdrop(gene, dataset, plevel) use alleles_class use ped_class use rngs implicit none integer, intent(in) :: gene type (ped_data) :: dataset integer, intent(in) :: plevel ! local variables integer, parameter :: MISS=-9999 integer, dimension(dataset%maxsiz, 2) :: set integer :: gen2, i, ii, num, ped, pedoffset logical :: fin interface subroutine genoff(idx, fa, mo, set) integer, intent(in) :: idx integer, intent(in) :: fa integer, intent(in) :: mo integer, dimension(:,:), intent(in out) :: set end subroutine subroutine gencopy(idx, origin, set) integer, intent(in) :: idx integer, intent(in) :: origin integer, dimension(:,:), intent(inout) :: set end subroutine gencopy end interface if (gene == MISS) return gen2=gene+1 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset set(1:num,1:2)=MISS ii=pedoffset do i=1, dataset%nfound(ped) ii=ii+1 call get_geno(ii, gene, gen2, dataset, set(i,1), set(i,2)) end do do fin=.true. ii=pedoffset+dataset%nfound(ped) do i=dataset%nfound(ped)+1, num ii=ii+1 if (set(i,1) == MISS) then if (set(dataset%fa(ii)-pedoffset,1) /= MISS .and. & set(dataset%mo(ii)-pedoffset,1) /= MISS) then if (dataset%imztwin(ii) /= MISS) then call gencopy(i, dataset%imztwin(ii)-pedoffset, set) else call genoff(i, dataset%fa(ii)-pedoffset, & dataset%mo(ii)-pedoffset, set) end if if (plevel > 1) then write(outstr,'(a,1x,a,a,i0,a,i0)') & dataset%pedigree(ped), dataset%id(ii), ' -> ', set(i,1), '/', set(i,2) end if else fin=.false. end if end if end do if (fin) exit end do ii=pedoffset do i=1, num ii=ii+1 call set_geno(ii, gene, gen2, dataset, set(i,1), set(i,2)) end do end if end do end subroutine wrdrop ! ! Simulate a single marker, either unconditionally, or ! consistent with ibd sharing at a given locus ! subroutine wrsim(typ, mark, gene, allele_buffer, allele_buffer2, dataset, plevel) use alleles_class use ped_class use rngs implicit none integer, intent(in) :: typ integer, intent(in) :: mark integer, intent(in) :: gene type (allele_data), intent(inout) :: allele_buffer, allele_buffer2 type (ped_data) :: dataset integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS=-9999 integer, dimension(dataset%maxsiz, 2) :: set, sibd integer, dimension(2*dataset%maxsiz) :: key integer :: a1, a2, gen2, i, ii, mark2, num, nuntyp, ped, pedoffset ! functions integer :: getnam interface subroutine simped(ped, dataset, allele_buffer, set) use alleles_class use ped_class integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data), intent(in) :: allele_buffer integer, dimension(:,:), intent(out) :: set end subroutine simped subroutine found(cumfrq, allele) double precision, dimension(:), intent(in) :: cumfrq integer, intent(out) :: allele end subroutine found subroutine pedibd(typ, ped, dataset, set, sibd) use ped_class implicit none integer, intent(in) :: typ integer, intent(in) :: ped type (ped_data), intent(in) :: dataset integer, dimension(:,:), intent(in) :: set integer, dimension(:,:), intent(in out) :: sibd end subroutine pedibd end interface ! gen2=gene+1 mark2=mark+1 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset ! Unconditional simulation if (typ == 1) then call simped(ped, dataset, allele_buffer, set) ii=pedoffset do i=1, num ii=ii+1 call set_geno(ii, mark, mark2, dataset, set(i,1), set(i,2)) end do else ! Conditional on ibd at gene call loadset(gene, ped, allele_buffer2, dataset, set, nuntyp) call pedibd(2, ped, dataset, set, sibd) if (typ == 2) then ! Simulate based on given allele frequencies, ibd and missingness do i=1, 2*dataset%nfound(ped) call found(allele_buffer%cum_freqs, key(i)) end do ii=pedoffset do i=1, num ii=ii+1 a1=key(sibd(i,1)) a2=key(sibd(i,2)) call order(a1, a2) if (dataset%untyped(ii)) then a1=-a1 a2=-a2 end if call set_geno(ii, mark, mark2, dataset, a1, a2) end do else ! Perfect marker -- permutation removes LD induced by ordering ! of alleles in target genotypes do i=1, 2*dataset%nfound(ped) key(i)=i end do call permut(2*dataset%nfound(ped), key) ii=pedoffset do i=1, num ii=ii+1 a1=key(sibd(i,1)) a2=key(sibd(i,2)) call order(a1, a2) call set_geno(ii, mark, mark2, dataset, a1, a2) end do end if end if end if end do end subroutine wrsim ! ! Simulate a quantitative trait of given heritability, ! either unconditionally, or ! consistent with complete linkage to a given locus ! subroutine wrsimq(typ, trait, loctyp, prevalence, h2, & gene, allele_buffer, allele_buffer2, dataset, plevel) use alleles_class use ped_class use locus_types use rngs use statfuns implicit none integer, intent(inout) :: typ integer, intent(inout) :: trait integer, intent(inout) :: loctyp double precision, intent(in) :: prevalence double precision, intent(inout) :: h2 integer, intent(in) :: gene type (allele_data), intent(inout) :: allele_buffer, allele_buffer2 type (ped_data) :: dataset integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS=-9999 integer, dimension(dataset%maxsiz, 2) :: set, sibd integer, dimension(2*dataset%maxsiz) :: key double precision, dimension(:), allocatable :: kin ! integer :: astat, cfa, cmo, g1, g2, gen2, i, ii, num, nuntyp, & ped, pedoffset integer (kind=8) :: nn double precision :: aconst, cumfrq(2), econst, midpar, segsd, thresh ! functions interface subroutine kinship(ped, dataset, kin) use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(in) :: dataset double precision, dimension(:), intent(inout) :: kin end subroutine kinship subroutine pedibd(typ, ped, dataset, set, sibd) use ped_class implicit none integer, intent(in) :: typ integer, intent(in) :: ped type (ped_data), intent(in) :: dataset integer, dimension(:,:), intent(in) :: set integer, dimension(:,:), intent(in out) :: sibd end subroutine pedibd subroutine found(cumfrq, allele) double precision, dimension(:), intent(in) :: cumfrq integer, intent(out) :: allele end subroutine end interface ! nn=int(dataset%maxact, kind=8) nn=nn*(nn+1)/int(2, kind=8) if (typ == 1) then allocate(kin(nn), stat=astat) if (astat /= 0) then write(outstr,'(a,i0,a)') & 'ERROR: Could not allocate kinship matrix of ', nn, ' elements.' return end if end if thresh=0.0d0 if (loctyp == LOC_AFF .and. prevalence /= MISS) then thresh=ppnd(1.0d0-prevalence) end if aconst=sqrt(h2+h2) econst=sqrt(1.0D0-h2) cumfrq(1)=0.5D0 cumfrq(2)=1.0D0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset ! Unconditional simulation of trait under control of additive polygenes if (typ == 1) then call kinship(ped, dataset, kin) do i=pedoffset+1, pedoffset+dataset%nfound(ped) dataset%plocus(i,trait)=dble(randn()) end do do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped) midpar=0.5D0*(dataset%plocus(dataset%fa(i),trait)+ & dataset%plocus(dataset%mo(i),trait)) cfa=dataset%fa(i)-pedoffset cmo=dataset%mo(i)-pedoffset cfa=cfa*(cfa+1)/2 cmo=cmo*(cmo+1)/2 segsd=sqrt(1.0D0-0.25D0*(kin(cfa)+kin(cmo))) dataset%plocus(i,trait)=midpar+segsd*dble(randn()) end do do i=pedoffset+1, dataset%num(ped) dataset%plocus(i,trait)=aconst*dataset%plocus(i,trait)+econst*dble(randn()) if (loctyp == LOC_AFF) then if (dataset%plocus(i,trait) >= thresh) then dataset%plocus(i,trait)=2.0D0 else dataset%plocus(i,trait)=1.0D0 end if end if end do else ! Conditional on ibd at marker gen2=gene+1 call loadset(gene, ped, allele_buffer2, dataset, set, nuntyp) call pedibd(2, ped, dataset, set, sibd) do i=1, 2*dataset%nfound(ped) call found(allele_buffer%cum_freqs, key(i)) end do ii=pedoffset do i=1, num ii=ii+1 dataset%plocus(ii,trait)= & aconst*dble(key(sibd(i,1))+key(sibd(i,2))-3) + econst*dble(randn()) if (loctyp == LOC_AFF) then if (dataset%plocus(ii,trait) >= thresh) then dataset%plocus(ii,trait)=2.0D0 else dataset%plocus(ii,trait)=1.0D0 end if end if end do end if end if end do if (allocated(kin)) deallocate(kin) end subroutine wrsimq ! ! Simulate QTL genotypes conditional on binary trait values, heritability and ! marginal QTL penetrances by rejection sampling ! subroutine wrsimqtl(trait, gene, smlfreq, smlpen, h2, dataset, plevel) use outstream use alleles_class use ped_class use locus_types use rngs use statfuns implicit none integer, intent(in) :: trait integer, intent(in) :: gene double precision, dimension(2) :: smlfreq double precision, dimension(3) :: smlpen double precision, intent(inout) :: h2 type (ped_data) :: dataset integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS=-9999 integer, dimension(dataset%maxsiz, 2) :: set double precision, dimension(dataset%maxsiz) :: liab double precision, dimension(dataset%maxsiz*(dataset%maxsiz+1)/2) :: kin ! integer :: cfa, cmo, g, gen2, i, ii, num, npheno, nreject, & ped, pedoffset, pheno, totreject logical :: fin double precision :: prevalence , p, q double precision, dimension(2) :: cumfrq double precision, dimension(3) :: mu double precision :: aconst, dev, econst, midpar, pred, segsd, thresh ! table of simulated genotypes v. affection status integer, dimension(3) :: ngeno integer, dimension(3,3) :: genotable ! total elapsed time character (len=20) :: slin integer :: it1, it2, ticks ! functions ! ppnd interface subroutine kinship(ped, dataset, kin) use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(in) :: dataset double precision, dimension(:), intent(inout) :: kin end subroutine kinship subroutine found(cumfrq, allele) double precision, dimension(:), intent(in) :: cumfrq integer, intent(out) :: allele end subroutine found subroutine genoff(idx, fa, mo, set) integer, intent(in) :: idx integer, intent(in) :: fa integer, intent(in) :: mo integer, dimension(:,:), intent(in out) :: set end subroutine genoff subroutine gencopy(idx, origin, set) integer, intent(in) :: idx integer, intent(in) :: origin integer, dimension(:,:), intent(inout) :: set end subroutine gencopy end interface ! call system_clock(it1) gen2=gene+1 genotable=0 cumfrq(1)=smlfreq(1) cumfrq(2)=1.0d0 prevalence=smlfreq(1)*smlfreq(1)*smlpen(1) + & 2*smlfreq(1)*smlfreq(2)*smlpen(2) + smlfreq(2)*smlfreq(2)*smlpen(3) thresh=ppnd(1.0d0-prevalence) mu(1)=thresh-ppnd(1.0d0-smlpen(1)) mu(2)=thresh-ppnd(1.0d0-smlpen(2)) mu(3)=thresh-ppnd(1.0d0-smlpen(3)) write(outstr,'(2(a,1x,f6.4/),a,3(1x,f6.4)/a,1x,f6.4)') & 'Trait prevalence =', prevalence, & 'QTL allele frequency =', smlfreq(1), & 'QTL penetrances =', smlpen, & 'Trait MFT heritability =', h2 if (plevel > 0) then dev=smlfreq(1)*smlfreq(1)*mu(1)*mu(1) + & 2*smlfreq(1)*smlfreq(2)*mu(2)*mu(2) + & smlfreq(2)*smlfreq(2)*mu(3)*mu(3) write(outstr,'(a,1x,f6.2/a,3(1x,f6.2)/a,3(1x,f6.4)/a,1x,f6.4)') & 'Prevalence threshold =', thresh, & 'Genotype deviations =', mu, & 'Genotype frequencies =', smlfreq(1)*smlfreq(1), & 2*smlfreq(1)*smlfreq(2), smlfreq(2)*smlfreq(2), & 'Locus-specific h2 =', dev if (plevel > 1) then write(outstr,'(/a/a)') 'Pedigree Size Npheno Samples', & '------------ ------ ------ ----------' end if end if aconst=sqrt(h2+h2) econst=sqrt(1.0D0-h2) totreject=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset npheno=0 do i=pedoffset+1, dataset%num(ped) if (dataset%plocus(i, trait) /= MISS) then npheno=npheno+1 end if end do ! Conditional simulation of qtl genotypes conditional on trait values call kinship(ped, dataset, kin) ! rejection sampling loop nreject=0 10 continue ii=pedoffset do i=1, dataset%nfound(ped) ii=ii+1 call found(cumfrq, set(i,1)) call found(cumfrq, set(i,2)) g=set(i,1)+set(i,2)-1 call order(set(i,1), set(i,2)) liab(i)=dble(randn()) dev=aconst*liab(i)+mu(g)+econst*dble(randn()) pred=1.0d0 if (dev > thresh) pred=2.0d0 ! write(*,*) 'ped=', trim(dataset%pedigree(ped)), & ! ' id=', trim(dataset%id(ii)), & ! ' trait=', dataset%plocus(ii,trait), & ! ' pred=', pred, & ! ' liab=', liab(i), ' dev=', dev, & ! ' geno=', set(i,1), '/', set(i,2) if (dataset%plocus(ii,trait) /= MISS .and. dataset%plocus(ii,trait) /= pred) then nreject=nreject+1 goto 10 end if end do do i=dataset%nfound(ped)+1, num set(i,1)=MISS set(i,2)=MISS end do do fin=.true. ii=pedoffset+dataset%nfound(ped) do i=dataset%nfound(ped)+1, num ii=ii+1 if (set(i,1) == MISS) then cfa=dataset%fa(ii)-pedoffset cmo=dataset%mo(ii)-pedoffset if (set(cfa,1) /= MISS .and. set(cmo,1) /= MISS) then if (dataset%imztwin(ii) /= MISS) then call gencopy(i, dataset%imztwin(ii)-pedoffset, set) liab(i)=liab(dataset%imztwin(ii)-pedoffset) else call genoff(i, cfa, cmo, set) g=set(i,1)+set(i,2)-1 midpar=0.5d0*(liab(cfa) + liab(cmo)) cfa=cfa*(cfa+1)/2 cmo=cmo*(cmo+1)/2 segsd=sqrt(1.0D0-0.25D0*(kin(cfa)+kin(cmo))) liab(i)=midpar+segsd*dble(randn()) end if dev=aconst*liab(i)+mu(g)+econst*dble(randn()) pred=1.0d0 if (dev > thresh) pred=2.0d0 ! write(*,*) 'ped=', trim(dataset%pedigree(ped)), & ! ' id=', trim(dataset%id(ii)), & ! ' trait=', dataset%plocus(ii,trait), & ! ' pred=', pred, & ! ' liab=', liab(i), ' dev=', dev, & ! ' geno=', set(i,1), '/', set(i,2) if (dataset%plocus(ii,trait) /= MISS .and. dataset%plocus(ii,trait) /= pred) then nreject=nreject+1 goto 10 end if else fin=.false. end if end if end do if (fin) exit end do ii=pedoffset do i=1, num ii=ii+1 pheno=1 if (dataset%plocus(ii,trait) /= MISS) pheno=int(dataset%plocus(ii,trait))+1 g=set(i,1)+set(i,2)-1 genotable(pheno,g)=genotable(pheno,g) + 1 call set_geno(ii, gene, gen2, dataset, set(i,1), set(i,2)) ! write(*,*) trim(dataset%pedigree(ped)), ' ', trim(dataset%id(i)), ' ', & ! dataset%plocus(i,trait), liab(i), set(i,1), set(i,2) end do totreject=totreject+nreject if (plevel > 1) then write(outstr,'(a12,2(1x,i6),2x,i0)') & dataset%pedigree(ped), num, npheno, nreject end if end if end do ! do i=1, 3 ngeno(i)=genotable(i,1)+genotable(i,2)+genotable(i,3) mu(i)=dble(2*genotable(i,1)+genotable(i,2))/dble(max(1,2*ngeno(i))) end do write(outstr,'(/a/a,3(/a,3i7,i9,1x,f6.4))') & 'Affection 1/1 1/2 2/2 Total Freq', & '---------- ------ ------ ------ -------- ------', & 'Unknown ', genotable(1,1:3), ngeno(1), mu(1), & 'Unaffected ', genotable(2,1:3), ngeno(2), mu(2), & 'Affected ', genotable(3,1:3), ngeno(3), mu(3) call system_clock(it2, count_rate=ticks) write(slin, '(f20.2)') float(it2-it1)/float(ticks) slin=adjustl(slin) write(outstr, '(/a,1x,i0/a,1x,2a)') & 'Total rejection samples=', totreject, & 'Elapsed time =', trim(slin), ' s' end subroutine wrsimqtl ! ! Permute trait values within pedigrees ! subroutine permdata(trait, dataset) use ped_class use rngs implicit none integer, intent(in) :: trait type (ped_data) :: dataset integer :: i, num, ped, pedoffset, pos double precision :: tmp do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset do i=1, num pos=irandom(1, num) tmp=dataset%plocus(i,trait) dataset%plocus(i,trait)=dataset%plocus(pos,trait) dataset%plocus(pos,trait)=tmp end do end if end do end subroutine permdata ! ! Convert to/from Julian etc ! typ=1 Greg->Jul ! 2 Jul->Greg ! subroutine dateconv(trait, dataset, fstring, typ, plevel) use outstream use julian_epoch use datestring use ped_class use locus_types use locus_data use categorical_data implicit none integer, intent(in) :: trait type (ped_data) :: dataset character(len=*) :: fstring integer, intent(inout) :: typ integer, intent(in) :: plevel ! integer, parameter :: MISS=-9999 ! parse string date integer, dimension(1) :: catidx type (cat_data) :: categories character (len=20) :: edate, sdate integer (kind=8) :: tdate integer :: i, ierr, lpos, nchanged, nfailed, ped ! call wrdate(epoch, edate, 1) nchanged=0 nfailed=0 lpos=locpos(trait) ! parse categorical trait level if (loctyp(trait) == LOC_CAT) then catidx(1)=trait call load_cat_levels(1, catidx, categories) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (dataset%plocus(i,lpos) /= MISS) then call get_label_tab(dataset%plocus(i,lpos), categories%cat_tables(1), sdate) call parse_string_date(sdate, tdate, fstring, ierr) if (ierr == 0) then nchanged=nchanged+1 if (typ == 1) then dataset%plocus(i,lpos)=tojulian(dfloat(tdate))-epoch else if (typ == 2) then dataset%plocus(i,lpos)=dfloat(tdate) else dataset%plocus(i,lpos)=getyear(dfloat(tdate)) end if else nfailed=nfailed+1 if (plevel > 1) then write(*,'(5a)') 'Failed parsing "', trim(sdate), & '" using format "', trim(fstring), '"' end if end if end if end do end if end do ! quantitative (Julian or YYYYMMDD integer) else do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (dataset%plocus(i,lpos) /= MISS) then nchanged=nchanged+1 if (typ == 1) then dataset%plocus(i,lpos)=tojulian(dataset%plocus(i,lpos))-epoch else if (typ == 2) then dataset%plocus(i,lpos)=togreg(dataset%plocus(i,lpos)+epoch) else dataset%plocus(i,lpos)=getyear(dataset%plocus(i,lpos)) end if end if end do end if end do end if write(outstr,'(/a,i0,2a)', advance='no') & 'Converted ', nchanged, ' dates at "', trim(loc(trait)) if (typ == 1) then write(outstr,'(3a)') '" to Julian (epoch="', trim(edate), '").' else if (typ == 2) then write(outstr,'(a)') '" to Gregorian.' else write(outstr,'(a)') '" to decimal years.' end if if (nfailed > 0) then write(outstr,'(/a,i0,a)') 'ERROR: Failed conversion of ', nfailed, ' dates' end if end subroutine dateconv ! ! identify rare alleles at a marker locus and list for combination ! subroutine combine(crit, recto, nf, recfro, allele_buffer) use alleles_class implicit none double precision, intent(in) :: crit double precision, dimension(:), intent(out) :: recto integer, intent(out) :: nf double precision, dimension(:), intent(out) :: recfro type (allele_data), intent(in) :: allele_buffer ! integer, parameter :: KNOWN=0 integer :: i ! nf=0 if (crit == 2.0d0) then nf=nf+1 recfro(nf)=allele_buffer%allele_names(allele_buffer%topall) recto(nf)=1.0d0 do i=1, allele_buffer%numal if (i /= allele_buffer%topall) then nf=nf+1 recfro(nf)=allele_buffer%allele_names(i) recto(nf)=2.0d0 end if end do else do i=1, allele_buffer%numal if (allele_buffer%allele_freqs(i) <= crit) then nf=nf+1 recfro(nf)=allele_buffer%allele_names(i) end if end do ! recode to 999 or nearest available allele number recto(1)=1000.0D0 10 continue recto(1)=recto(1)-1.0D0 do i=1, allele_buffer%numal if (int(recto(1)) == allele_buffer%allele_names(i)) goto 10 end do end if end subroutine combine ! ! swap diallelic marker alleles eg 1->2 2->1 ! subroutine swapalleles(loc, gene, allele_buffer, dataset, plevel) use outstream use alleles_class use ped_class implicit none character (len=*), intent(in) :: loc integer, intent(in) :: gene type (allele_data), intent(in) :: allele_buffer type (ped_data) :: dataset integer, intent(in) :: plevel ! integer, parameter :: MISS=-9999 integer :: a1, a2, g1, g2, gen2, i, n, ped, sgn character (len=3) :: allel1, allel2 ! a1=allele_buffer%allele_names(1) a2=allele_buffer%allele_names(2) call wrall(a1, allel1) call wrall(a2, allel2) gen2=gene+1 n=0 ! do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) n=n+1 if (.not.missing(i, gene, dataset)) then call get_geno(i, gene, gen2, dataset, g1, g2) if (g1 == g2) then sgn=sign(1, g1) if (abs(g1) == a1) then g1=sgn*a2 g2=sgn*a2 else g1=sgn*a1 g2=sgn*a1 end if call set_geno(i, gene, gen2, dataset, g1, g2) end if end if end do end if end do if (plevel > -1) then write(outstr,'(/7a,i0,a,i0,a)') & 'Swapped alleles ', trim(adjustl(allel1)), ' and ', & trim(adjustl(allel2)),' at "', trim(loc), '" for ', & n, ' of a possible ', dataset%nobs, ' individuals.' end if end subroutine swapalleles ! ! renumber alleles to consecutive integers ! subroutine renumb(loc, gene, typ, allele_buffer, dataset) use outstream use alleles_class use ped_class use sorts implicit none character (len=*), intent(inout) :: loc integer, intent(in) :: gene integer, intent(inout) :: typ type (allele_data), intent(inout) :: allele_buffer type (ped_data) :: dataset ! integer, parameter :: MISS=-9999 integer :: i, g1, g2, gen2, ped integer :: ifreq(allele_buffer%numal), ord(allele_buffer%numal) ! functions integer :: getnam ! write(outstr,'(/3a,i3,a)') & 'Renumbering alleles at "', trim(loc), '" to 1..', allele_buffer%numal,'.' ! if (typ == 3) then write(outstr,'(a)') 'Ordering by sample allele frequency.' do i=1, allele_buffer%numal ifreq(i)=int(1000.0D0*allele_buffer%allele_freqs(i)) ord(i)=i end do call isort(1, allele_buffer%numal, ifreq, ord, 2) do i=1, allele_buffer%numal ifreq(ord(i))=i end do end if ! gen2=gene+1 ! do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (.not.missing(i, gene, dataset)) then call get_namedgeno(i, gene, gen2, dataset, allele_buffer, g1, g2) if (typ == 3) then g1=ifreq(g1) g2=ifreq(g2) call order(g1,g2) end if if (.not.observed(i, gene, dataset)) then g1=-g1 g2=-g2 end if call set_geno(i, gene, gen2, dataset, g1, g2) end if end do end if end do end subroutine renumb ! ! recode alleles or values for particular locus -- ! replace all "from" values with "to" values ! subroutine recode(loc, gene, loctyp, nto, recto, nf, recfro, dataset, plevel) use outstream use ped_class use locus_types implicit none character (len=*), intent(in) :: loc integer, intent(in) :: gene integer, intent(in) :: loctyp integer, intent(in) :: nto double precision, dimension(:), intent(inout) :: recto integer, intent(in) :: nf double precision, dimension(:), intent(in) :: recfro type (ped_data) :: dataset integer, intent(in) :: plevel ! integer, parameter :: KNOWN=0, MISS=-9999 integer :: change, g1, g2, i, j, gen2, nchange, new1, new2, nmiss, & ped, visible character (len=3) :: allel character (len=9) :: newval, oldval double precision :: swp ! if (plevel > -1) then write(outstr,'(/2a)') 'Recoding locus ', loc ! if (ismarker(loctyp)) then write(outstr,'(a)', advance='no') 'From: ' do i=1, nf call wrall(int(recfro(i)), allel) write(outstr,'(1x,a3)', advance='no') allel end do write(outstr,'(/a)', advance='no') 'To : ' do i=1, nto call wrall(int(recto(i)), allel) write(outstr,'(1x,a3)', advance='no') allel end do write(outstr,*) else write(outstr,'(a,(t7,10(1x,f6.1)):)') 'From: ', recfro(1:nf) write(outstr,'(a,(t7,10(1x,f6.1)):)') 'To : ', recto(1:nto) end if write(outstr,*) end if if (nto < nf) then do i=nto+1, nf recto(i)=recto(nto) end do end if ! gen2=gene+1 nchange=0 nmiss=0 if (ismarker(loctyp)) then do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) call get_geno(i, gene, gen2, dataset, g1, g2) new1=g1 new2=g2 change=0 visible=0 if (g1 == MISS) then do j=1, nf if (recfro(j) == MISS .and. recto(j) > KNOWN) then new1=int(recto(j)) new2=int(recto(j)) change=2 visible=2 exit end if end do else do j=1, nf if (abs(g1) == int(recfro(j))) then if (recto(j) == MISS) then new1=MISS new2=MISS change=2 visible=2 nmiss=nmiss+1 exit else new1=sign(int(recto(j)), g1) change=change+1 if (new1 > KNOWN) visible=visible+1 end if end if if (abs(g2) == int(recfro(j))) then if (recto(j) == MISS) then new1=MISS new2=MISS change=2 visible=2 nmiss=nmiss+1 exit else new2=sign(int(recto(j)), g2) change=change+1 if (new2 > KNOWN) visible=visible+1 end if end if if (change == 2) exit end do end if if (change /= 0) then call order(new1, new2) call set_geno(i, gene, gen2, dataset, new1, new2) if (visible /= 0) then nchange=nchange+1 if (plevel > 1) then call wrgtp(g1, g2, oldval, '/', '', 1) call wrgtp(new1, new2, newval, '/', '', 1) write(outstr,'(a,1x,3a)') & trim(dataset%pedigree(ped)) // '--' // trim(dataset%id(i)), & oldval, ' -> ', newval end if end if end if end do end if end do else if (.not.isspecial(loctyp)) then do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) do j=1, nf if (dataset%plocus(i,gene) == recfro(j)) then dataset%plocus(i,gene)=recto(j) if (recto(j) == MISS) then nmiss=nmiss+1 end if nchange=nchange+1 if (plevel > 1) then call wrtrait(recfro(j), oldval, loctyp, ' ', 9, 4) call wrtrait(recto(j), newval, loctyp, ' ', 9, 4) write(outstr,'(a,1x,3a)') & trim(dataset%pedigree(ped)) // '--' // trim(dataset%id(i)), & oldval, ' -> ', newval end if exit end if end do end do end if end do end if write(outstr,'(a,i0,a)') 'Recoded ',nchange,' values.' if (nmiss > 0) then write(outstr,'(a,i0,a)') 'Set ',nmiss,' values to missing.' end if end subroutine recode ! ! Replace missing genotypes with reference (typ=1) or major (typ=2) allele ! homozygote. Most useful when sequence data (wt by omission) ! Filtering on trait performed by setting dataset%untyped using filter_snp() ! before call. ! subroutine refgeno(typ, loc, gene, loctyp, locnote, allele_buffer, dataset, plevel) use outstream use alleles_class use ped_class use locus_types implicit none integer, intent(in) :: typ character (len=*), intent(in) :: loc integer, intent(in) :: gene integer, intent(in) :: loctyp character (len=40), intent(in) :: locnote type (allele_data), intent(inout) :: allele_buffer type (ped_data) :: dataset integer, intent(in) :: plevel ! integer, parameter :: KNOWN=0 integer :: g1, g2, gcode, gen2, i, nchange, ped, refall character (len=1) :: alt, ref character (len=7) :: gtp ! functions integer :: aval gen2=gene+1 gcode=gencode(loctyp) nchange=0 call get_refalleles(locnote, ref, alt) if (typ == 2 .or. ref == ' ') then refall=allele_buffer%allele_names(allele_buffer%topall) else refall=aval(ref, gcode) end if do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (.not.observed(i, gene, dataset) .and. .not.dataset%untyped(i)) then call get_geno(i, gene, gen2, dataset, g1, g2) nchange=nchange+1 g1=refall g2=refall call set_geno(i, gene, gen2, dataset, g1, g2) end if end do end if end do if (plevel > 0) then call wrgtp(refall, refall, gtp, '/', '', 1) write(outstr,'(a,i8,1x,a)') loc, nchange, gtp end if end subroutine refgeno ! ! Recast aff or cat to qua or qua to aff or cat ! subroutine recast(typ, trait, dataset, plevel) use outstream use ped_class use locus_types implicit none integer, intent(in) :: typ integer, intent(in) :: trait type (ped_data) :: dataset integer, intent(in) :: plevel ! integer, parameter :: MISS=-9999 integer :: i, notapp, ped double precision :: in_no, in_yes, out_no, out_yes, val out_no=1.0d0 out_yes=2.0d0 if (typ == LOC_QUA) then out_no=0.0d0 out_yes=1.0d0 end if in_no=MISS in_yes=MISS notapp=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (dataset%plocus(i,trait) /= MISS) then val=dataset%plocus(i,trait) if (in_no == MISS) then in_no = val else if (in_yes == MISS .and. val /= in_no) then if (val > in_no) then in_yes = val else in_yes = in_no in_no = val end if else if (val /= in_no .and. val /= in_yes) then notapp=notapp+1 end if end if end do end if end do do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (dataset%plocus(i,trait) /= MISS) then val=dataset%plocus(i,trait) if (val == in_yes) then val=out_yes else if (val == in_no) then val=out_no else val=MISS end if dataset%plocus(i,trait)=val end if end do end if end do if (notapp /= 0) then write(outstr,'(a,i0,a)') 'NOTE: There were ', notapp, & ' equivocal phenotype values for transformation.' end if if (plevel > 1) then write(outstr,*) 'Mapping [No] ', in_no, ' -> ', out_no write(outstr,*) ' [Yes] ', in_yes, ' -> ', out_yes end if end subroutine recast ! ! Dummy encode a SNP 1=add 2=dom 3=rec ! subroutine snpenc(gene, trait, typ, dataset) use ped_class use outstream implicit none integer, intent(in) :: gene integer, intent(in) :: trait integer, intent(in) :: typ type (ped_data) :: dataset ! integer, parameter :: KNOWN=0, MISS=-9999 ! local variables integer :: base, i, g1, g2, gen2, n, ped double precision, dimension(3) :: score ! gen2=gene+1 base=MISS mainloop: do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) call get_geno(i, gene, gen2, dataset, g1, g2) if (g1 > KNOWN) base=g1 if (base /= MISS) exit mainloop end do end if end do mainloop if (base == MISS) then write(outstr,'(a)') 'ERROR: No observed genotypes.' return end if score(1)=0.0d0 score(2)=mod(typ,3)*0.5d0 score(3)=1.0d0 write(*,*) typ, base, score n=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) dataset%plocus(i, trait)=MISS call get_geno(i, gene, gen2, dataset, g1, g2) if (g1 > KNOWN) then n=n+1 if (g1 == base .and. g2 == base) then dataset%plocus(i, trait)=score(1) else if (g1 == base .or. g2 == base) then dataset%plocus(i, trait)=score(2) else dataset%plocus(i, trait)=score(3) end if end if end do end if end do write(outstr, '(a,i0,a)') 'Coded dummy variable for ', n, ' genotypes.' end subroutine snpenc ! ! Multipoint IBS sharing for all pairs ! subroutine wribs(trait, gt, thresh, nloci, loc, loctyp, locpos, & dataset, plevel) use interrupt use outstream use locus_types use comp_ops use ped_class implicit none integer, intent(in) :: trait integer, intent(in) :: gt double precision, intent(in) :: thresh integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc ! all locus names integer, dimension(:), intent(in) :: loctyp ! locus types integer, dimension(:), intent(in) :: locpos ! locus column type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel ! integer, parameter :: MISS=-9999 ! local variables ! list of marker loci, observed marker loci for person i integer :: nmark, nuse integer, dimension(nloci) :: mark, umark ! marker genotypes for person i integer, dimension(nloci,2) :: geno ! list of active IDs integer :: nact integer, dimension(dataset%nobs) :: actif integer :: g1, g2, g3, g4, gene, i, j, k, ped, peri, perj integer :: ibs, iden, nibs ! functions double precision :: isaff ! nmark=0 do k=1, nloci if (isactdip(loctyp(k))) then nmark=nmark+1 mark(nmark)=locpos(k) end if end do if (plevel > 0) then write(outstr,'(/a,i0,a)') & 'Pairwise mean identity-by-state sharing based on ', nmark, ' markers.' end if ! ! List of potentially useful individuals nact=0 if (trait == MISS) then do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) do k=1, nmark if (observed(i, mark(k), dataset)) then nact=nact+1 actif(nact)=i exit end if end do end do end if end do else gene=locpos(trait) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (isaff(dataset%plocus(i,gene),thresh,gt) == 2.0d0) then do k=1, nmark if (observed(i, mark(k), dataset)) then nact=nact+1 actif(nact)=i exit end if end do end if end do end if end do end if ! if (nact == 0) then write(outstr,'(a)') 'No useful active individuals!' return end if if (plevel > 0) then if (trait /= MISS) then write(outstr,'(3a)') 'Subsetting on "', trim(loc(trait)), '".' call defpro(gt, thresh, .true.) end if write(outstr,'(a,i0,a/)') & 'There are ', nact, ' potentially useful individuals.' end if write(outstr,'(a)') 'ped1 id1 ped2 id2 shared nloci kin' ! do i=1, nact-1 peri=actif(i) ped=dataset%iped(peri) nuse=0 do k=1, nmark gene=mark(k) if (observed(peri, gene, dataset)) then nuse=nuse+1 umark(nuse)=gene call get_geno(peri, gene, gene+1, dataset, & geno(nuse,1), geno(nuse,2)) end if end do do j=i+1, nact perj=actif(j) ibs=0 iden=0 do k=1, nuse gene=umark(k) if (observed(perj, gene, dataset)) then nibs=1 call get_geno(perj, gene, gene+1, dataset, g1, g2) g3 = geno(k,1) g4 = geno(k,2) if (g1 == g3 .and. g2 == g4) then nibs=2 ! else if (g1 == g4 .and. g2 == g3) then ! nibs=2 else if (g1 /= g3 .and. g2 /= g4 .and. & g1 /= g4 .and. g2 /= g3) then nibs=0 end if ibs=ibs+nibs iden=iden+1 end if end do if (iden == 0) then write(outstr,'(a,3(1x,a),2(1x,i0),1x,a)') & trim(dataset%pedigree(ped)), & trim(dataset%id(peri)), & trim(dataset%pedigree(dataset%iped(perj))), & trim(dataset%id(perj)), & ibs, iden, 'x' else write(outstr,'(a,3(1x,a),2(1x,i0),1x,f6.4)') & trim(dataset%pedigree(ped)), & trim(dataset%id(peri)), & trim(dataset%pedigree(dataset%iped(perj))), & trim(dataset%id(perj)), & ibs, iden, dble(ibs)/dble(2*iden) end if end do if (irupt > 0) exit end do end subroutine wribs ! ! Principal components or classical MDS analysis of multipoint IBS sharing ! subroutine ibspca(typ, nloci, loc, loctyp, locpos, & ncomps, loadvars, dataset, plevel) use interrupt use outstream use locus_types use ped_class implicit none integer, intent(in) :: typ integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc ! all locus names integer, dimension(:), intent(in) :: loctyp ! locus types integer, dimension(:), intent(in) :: locpos ! locus column integer, intent(in) :: ncomps ! no. of factors integer, dimension(:), intent(inout) :: loadvars ! where to save loadings type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel ! integer, parameter :: MISS=-9999 ! local variables ! list of marker loci, observed marker loci for person i integer :: nmark, nuse integer, dimension(nloci) :: mark, umark ! marker genotypes for person i integer, dimension(nloci,2) :: geno ! list of active IDs integer :: nact integer, dimension(dataset%nobs) :: actif ! IBS correlations and loadings integer, dimension(:), allocatable :: sharedloci double precision, dimension(:), allocatable :: ibscor double precision, dimension(:,:), allocatable :: loadings ! integer :: g1, g2, gene, i, idx, j, k, ncov, n2, ped, peri, perj, ntyp integer :: ibs, iden, ncrit, nibs, noshare, tenth double precision :: den integer (kind=8):: cpu_t1, cpu_t2, ticks ! functions double precision :: isaff ! write(outstr,'(a/a,i0,a/a)') & '------------------------------------------------', & 'IBS marker sharing: first ', ncomps, ' principal components', & '------------------------------------------------' nmark=0 do k=1, nloci if (ismarker(loctyp(k)) .and. isactive(loctyp(k))) then nmark=nmark+1 mark(nmark)=locpos(k) end if end do if (nmark == 0) then write(outstr,'(a)') 'No active markers!' return end if ncrit=nmark/2 write(outstr,'(/a,i0,a,i0,a)') & 'Pairwise mean identity-by-state sharing based on ', ncrit, ' to ', nmark, ' markers.' ! ! List of potentially useful individuals nact=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) ntyp=0 do k=1, nmark if (observed(i, mark(k), dataset)) then ntyp=ntyp+1 if (ntyp >= ncrit) then nact=nact+1 actif(nact)=i exit end if end if end do end do end if end do ! if (nact == 0) then write(outstr,'(a)') 'No useful active individuals!' return end if write(outstr,'(a,i0,a/)') & 'There are ', nact, ' potentially useful individuals.' ncov=nact*(nact+1)/2 n2=nact*nact tenth=ncov/10 allocate(sharedloci(ncov), ibscor(ncov), loadings(nact, nact)) ! idx=0 noshare=0 call system_clock(cpu_t1) do i=1, nact peri=actif(i) nuse=0 do k=1, nmark gene=mark(k) if (observed(peri, gene, dataset)) then nuse=nuse+1 umark(nuse)=gene call get_geno(peri, gene, gene+1, dataset, & geno(nuse,1), geno(nuse,2)) end if end do do j=1, i-1 idx=idx+1 perj=actif(j) ibs=0 iden=0 ibscor(idx)=0.0d0 do k=1, nuse gene=umark(k) if (observed(perj, gene, dataset)) then nibs=1 call get_geno(perj, gene, gene+1, dataset, g1, g2) if (g1 == geno(k,1) .and. g2 == geno(k,2)) nibs=2 if (g1 == geno(k,2) .and. g2 == geno(k,1)) nibs=2 if (g1 /= geno(k,1) .and. g2 /= geno(k,2) .and. & g1 /= geno(k,2) .and. g2 /= geno(k,1)) nibs=0 ibs=ibs+nibs iden=iden+1 end if end do sharedloci(idx)=iden if (iden > 0) then ibscor(idx)=dble(ibs)/dble(2*iden) else noshare=noshare+1 end if if (mod(idx,tenth) == 0) then call system_clock(cpu_t2, count_rate=ticks) write(outstr,'(i0,a,i0,a)') & idx, 'th pair completed (', (cpu_t2-cpu_t1)/ticks, 's)' end if end do idx=idx+1 ibscor(idx)=1.0d0 if (irupt > 0) exit end do if (noshare > 0) then write(outstr,'(a,i0,a)') & 'There are ', noshare, ' pairs of individuals who share no markers in common.' end if ! perform PCA idx=0 do i=1, min(nact, 5) peri=actif(i) write(outstr,'(a, 5(1x,f5.3))') & dataset%id(peri), (ibscor(idx+j), j=1, i) idx=idx+i end do if (nact > 5) then peri=actif(6) write(outstr,'(a, 6(1x,f5.3),a/)') & dataset%id(peri), (ibscor(idx+j), j=1, 6), '...' end if if (typ == 2) then ibscor=1.0d0-ibscor call dcentre(nact, n2, ibscor) ibscor=-0.5d0*ibscor end if write(outstr,'(a)') 'Extracting principal components' call eigen(1, nact, ibscor, loadings) if (plevel > 0) then write(outstr,'(/a)') 'Variances for the principal components' write(outstr,'(9x,6(1x,g10.4):)') (ibscor(j), j=ncomps,1,-1) do i=1, ncomps den=den+ibscor(i) end do write(outstr,'(a)') 'Proportion of total variance due to each component' write(outstr,'(9x,6(2x,f5.3,4x):)') (ibscor(j)/den, j=ncomps,1,-1) write(outstr,'(a)') 'Loadings of each variable on components' g1=nact if (plevel == 1) g1=min(g1, 10) do i=1, g1 idx=actif(i) write(outstr,'(a10,6(f7.4,4x):)') & trim(dataset%pedigree(dataset%iped(idx))) // ' ' // trim(dataset%id(idx)), & (loadings(i,j), j=ncomps,1,-1) end do if (g1 < nact) then write(outstr,'(a)') '...' end if write(outstr,*) end if if (typ == 2) then do i=1, nact do k=1, ncomps loadings(i,k)=sqrt(ibscor(k))*loadings(i,k) end do end do end if ! write out loadings write(outstr,'(a,i0,a)', advance='no') & 'Writing loadings on first ', ncomps, ' components to:' do k=1, ncomps write(outstr,'(3a)', advance='no') ' "', trim(loc(loadvars(k))),'"' loadvars(k)=locpos(loadvars(k)) end do write(outstr,'(a)') '.' do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) do k=1, ncomps dataset%plocus(i,loadvars(k))=MISS end do end do end if end do do i=1, nact idx=actif(i) do k=1, ncomps dataset%plocus(idx,loadvars(k))=loadings(i,nact+1-k) end do end do end subroutine ibspca ! ! Monte-Carlo approach to estimating IBD sharing at a marker ! typ=1 as lower triangular matrix ! 2 pairwise ! subroutine wribd(nmark, mark, loc, loctyp, locpos, dataset, & burnin, iter, typ, plevel) use interrupt use outstream use alleles_class use ped_class use ibd_class implicit none integer, intent(in) :: nmark ! number of markers for ibd estimate integer, dimension(:), intent(in) :: mark ! markers for ibd estimate character (len=20), dimension(:), intent(in) :: loc ! all locus names integer, dimension(:), intent(in) :: loctyp ! locus types integer, dimension(:), intent(in) :: locpos ! locus column type (ped_data), intent(inout) :: dataset integer, intent(in) :: burnin integer, intent(in) :: iter integer, intent(in) :: typ integer, intent(in) :: plevel ! integer, parameter :: MISS=-9999 ! marker information type (allele_data), dimension(:), pointer :: alleles ! local variables integer :: gene, i, idx, j, k, m2, & maxsiz, ncertain, nn, nntot, & num, ped, pedoffset, pos character (len=7) :: gtp double precision :: den, res ! functions interface subroutine freq(gene, loctyp, fndr, dataset, allele_buffer) use ped_class use alleles_class integer, intent(in) :: gene integer, intent(in) :: loctyp integer, intent(in) :: fndr type (ped_data), intent(in) :: dataset type (allele_data), intent(inout) :: allele_buffer end subroutine freq subroutine markeribd(gene, iter, burnin, allele_buffer, & ped, dataset, ibdcount, ibdvar, plevel) use interrupt use pairlist_class use alleles_class use ped_class implicit none integer, intent(in) :: gene integer, intent(in) :: iter, burnin type (allele_data), intent(inout) :: allele_buffer integer, intent(in) :: ped type (ped_data), intent(inout) :: dataset double precision, dimension(:), intent(out) :: ibdcount double precision, dimension(:), intent(out) :: ibdvar integer, intent(in) :: plevel end subroutine markeribd subroutine kinship(ped, dataset, kin) use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(in) :: dataset double precision, dimension(:), intent(inout) :: kin end subroutine kinship subroutine frater(ped, dataset, kin, dom) use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(inout) :: dataset double precision, dimension(:), intent(inout) :: kin, dom end subroutine frater end interface ! if (typ == 2) then write(outstr,'(a14,2(1x,a12),2(1x,a6))') 'ped', 'id1', 'id2', 'ibd', 'kin' end if allocate(alleles(nmark)) do j=1, nmark call freq(locpos(mark(j)), loctyp(mark(j)), 0, dataset, alleles(j)) end do ! maxsiz=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset maxsiz=max(maxsiz, num) end if end do m2=maxsiz*(maxsiz+1)/2 allocate(a(m2), c(m2), csd(m2)) if (nmark > 1) then allocate(mibd(nmark, m2), mibdsd(nmark, m2)) end if do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset nn=num*(num+1)/2 if (nmark==1) then call markeribd(locpos(mark(1)), iter, burnin, alleles(1), & ped, dataset, c, csd, plevel-1) else do j=1, nmark call markeribd(locpos(mark(j)), iter, burnin, alleles(j), & ped, dataset, c, csd, plevel-1) do k=1, nn mibd(j,k)=c(k) mibdsd(j,k)=csd(k) end do end do do k=1, nn c(k)=0.0d0 csd(k)=-1.0d0 do j=1, nmark if (mibdsd(j,k)==0.0d0) then ncertain=ncertain+1 c(k)=mibd(j,k) csd(k)=mibdsd(j,k) exit end if end do end do do k=1, nn if (csd(k)==-1.0d0) then res=0.0d0 den=0.0d0 do j=1, nmark den=den+1.0d0/mibdsd(j,k) end do den=1.0d0/den do j=1, nmark res=res+den*mibd(j,k)/mibdsd(j,k) end do c(k)=res end if end do end if ! output idx=0 if (typ == 5 .or. typ == 7) then do i=1, num write(outstr,*) (c(j), j=idx+1, idx+i) idx=idx+i end do else if (mod(typ,2) == 1) then write(outstr,'(/2a)') & 'Pedigree ', dataset%pedigree(ped) do i=1, num write(outstr,'(a10)', advance='no') dataset%id(pedoffset+i) do j=1, nmark call prgtp(pedoffset+i, locpos(mark(j)), dataset, gtp) write(outstr,'(1x,a7)', advance='no') gtp end do write(outstr,'(1x,50f5.2,(/6x,50f5.2):)') & (c(j), j=idx+1, idx+i) idx=idx+i end do else call kinship(ped, dataset, a) do i=1, num do j=1, i idx=idx+1 write(outstr,'(a14,2(1x,a12),2(1x,f6.3))') & dataset%pedigree(ped), dataset%id(pedoffset+i), & dataset%id(pedoffset+j), c(idx), a(idx) end do end do end if end if end do deallocate(a, c, csd) if (nmark > 1) then deallocate(mibd, mibdsd) end if deallocate(alleles) end subroutine wribd ! ! Monte-Carlo approach to estimating IBD sharing at a marker for a pedigree ! subroutine markeribd(gene, iter, burnin, allele_buffer, & ped, dataset, ibdcount, ibdvar, plevel) use outstream use interrupt use pairlist_class use alleles_class use ped_class implicit none integer, intent(in) :: gene integer, intent(in) :: iter, burnin type (allele_data), intent(inout) :: allele_buffer integer, intent(in) :: ped type (ped_data), intent(inout) :: dataset ! ibd matrix double precision, dimension(:), intent(out) :: ibdcount double precision, dimension(:), intent(out) :: ibdvar integer, intent(in) :: plevel ! local variables integer, parameter :: KNOWN=0, MISS=-9999 ! proposal and work array: pedigree sized integer, dimension(dataset%maxsiz,2) :: set integer, dimension(dataset%maxsiz,2) :: sibd integer, dimension(dataset%maxsiz,2) :: set2 integer, dimension(2*dataset%maxsiz) :: key ! current state of untyped logical, dimension(dataset%maxsiz) :: untyped ! untyped matings type (pairlist_data) cntmat double precision, dimension(allele_buffer%numgtp) :: gfrq ! local variables integer :: g1, g2, gen2, i, idx, it, j, nfam, npairs integer :: num, pedoffset, pedtyp logical :: alltyp character (len=7) :: gtp double precision :: zibd ! Metropolis summary integer :: iprop ! functions integer :: getnam interface subroutine update(idx, all1, all2, set) integer, intent(in) :: idx integer, intent(in) :: all1 integer, intent(in) :: all2 integer, dimension(:,:), intent(inout) :: set end subroutine update subroutine tabmat(ped, dataset, cntmat) use pairlist_class use ped_class integer, intent(in) :: ped type (ped_data), intent(in) :: dataset type (pairlist_data), intent(inout) :: cntmat end subroutine tabmat subroutine drop(it, ped, dataset, cntmat, numal, gfrq, & set, sibd, set2, key, iprop, plevel) use pairlist_class use ped_class implicit none integer, intent(in) :: it integer, intent(in) :: ped type (ped_data) :: dataset type (pairlist_data), intent(inout) :: cntmat integer, intent(in) :: numal double precision, dimension(numal*(numal+1)/2) :: gfrq integer, dimension(:,:), intent(inout), target :: set, sibd integer, dimension(:,:), intent(inout) :: set2 integer, dimension(:), intent(inout) :: key integer, intent(out) :: iprop integer, intent(in) :: plevel end subroutine drop subroutine pedibd(typ, ped, dataset, set, sibd) use ped_class implicit none integer, intent(in) :: typ integer, intent(in) :: ped type (ped_data), intent(in) :: dataset integer, dimension(:,:), intent(in) :: set integer, dimension(:,:), intent(in out) :: sibd end subroutine pedibd subroutine kinship(ped, dataset, kin) use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(in) :: dataset double precision, dimension(:), intent(inout) :: kin end subroutine kinship end interface ! gen2=gene+1 pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset npairs=num*(num+1)/2 call filltri(num, npairs, ibdcount, 0.0D0, 0.0D0) call filltri(num, npairs, ibdvar, 0.0D0, 0.0D0) untyped(1:num)=dataset%untyped(pedoffset+1:dataset%num(ped)) alltyp=.true. pedtyp=0 do i=pedoffset+1, dataset%num(ped) call get_geno(i, gene, gen2, dataset, g1, g2) if (.not.observed(i, gene, dataset)) then if (i <= pedoffset+dataset%nfound(ped)) then alltyp=.false. end if dataset%untyped(i)=.true. if (g1 == 0 .or. g1 == MISS) then g1=MISS g2=MISS else g1=getnam(g1, allele_buffer) g2=getnam(g2, allele_buffer) end if else pedtyp=pedtyp+1 dataset%untyped(i)=.false. g1=getnam(g1, allele_buffer) g2=getnam(g2, allele_buffer) end if call update(i-pedoffset, g1, g2, set) end do if (pedtyp > 1) then ! IBD: all genotypes KNOWN if (alltyp) then do it=1, iter call pedibd(2, ped, dataset, set, sibd) idx=0 do i=1, num do j=1, i idx=idx+1 call share(sibd(i,1), sibd(i,2), sibd(j,1), sibd(j,2), zibd) call moment(it, zibd, ibdcount(idx), ibdvar(idx)) end do end do end do else ! IBD: some untyped markers: ! produce genotype frequencies for Metropolis criterion ! enumerate untyped founder matings call genot(allele_buffer, gfrq) call tabmat(ped, dataset, cntmat) ! Metropolis simulation of genotypes if (plevel > 2) then write(outstr,'(/2a,4(/a,i4))') & 'Metropolis simulation of pedigree ', dataset%pedigree(ped), & 'Untyped Individuals: ', num-pedtyp, & 'Possible genotypes : ', allele_buffer%numgtp, & 'UnT x UnT matings : ', cntmat%npairs, & 'Burn-in (iters) : ', burnin end if do it=1, burnin call drop(it, ped, dataset, cntmat, allele_buffer%numal, gfrq, & set, sibd, set2, key, iprop, 0) if (irupt > 0) exit end do do it=1, iter call drop(it, ped, dataset, cntmat, allele_buffer%numal, gfrq, & set, sibd, set2, key, iprop, plevel) call pedibd(2, ped, dataset, set, sibd) idx=0 do i=1, num do j=1, i idx=idx+1 call share(sibd(i,1), sibd(i,2), sibd(j,1), sibd(j,2), zibd) call moment(it, zibd, ibdcount(idx), ibdvar(idx)) end do end do if (irupt > 0) exit end do ! record new starting genotypes j=pedoffset do i=1, num j=j+1 if (dataset%untyped(j)) then g1=-allele_buffer%allele_names(set(i,1)) g2=-allele_buffer%allele_names(set(i,2)) call set_geno(j, gene, gen2, dataset, g1, g2) end if end do end if else call kinship(ped, dataset, ibdcount) end if !---DEBUG ! call prgtp(pedoffset+1, gene, dataset, gtp) ! write(outstr,'(/2a/a10,1x,a7,1x,f5.2)') & ! 'Pedigree ', dataset%pedigree(ped), & ! dataset%id(pedoffset+1), gtp, 1.0d0 ! idx=1 ! do i=2, num ! call prgtp(pedoffset+i, gene, dataset, gtp) ! write(outstr,'(a10,1x,a7,1x,50f5.2,(/6x,50f5.2):)') & ! dataset%id(pedoffset+i), gtp, (ibdcount(j), j=idx+1, idx+i-1), 1.0d0 ! idx=idx+i-1 ! end do dataset%untyped(pedoffset+1:dataset%num(ped))=untyped(1:num) call clean_pairs(cntmat) end subroutine markeribd ! ! Write kinship coefficients ! subroutine dokin(typ, dataset) use outstream use interrupt use ped_class implicit none integer, intent(in) :: typ type (ped_data), intent(inout) :: dataset ! local variables integer, parameter :: MISS=-9999 ! numerator relationship matrix double precision, dimension(:), allocatable :: kin ! gk,gl,hk,hl are parent-pair indices for dominance integer :: astat, fa1, fa2, gk, gl, hk, hl, i, idx, ii, j, mo1, mo2 ! bilin 1=(unilineal or unrelated) 4=MZ, 3=fs 2=other bilineal ! ndom=number of non-full-sib pairs where bilineal relationship ! ninbred=number of inbred individuals integer :: bilin, ndom integer (kind=8) :: nn integer :: num, ped, pednum, pedoffset double precision :: dom, meanf, x character (len=2), dimension(4), parameter :: rel = & (/ ' ', 'Bi', 'FS', 'MZ' /) ! functions integer :: clcpos interface subroutine kinship(ped, dataset, kin) use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(in) :: dataset double precision, dimension(:), intent(inout) :: kin end subroutine kinship end interface ! nn=int(dataset%maxact, kind=8) nn=nn*(nn+1)/int(2, kind=8) allocate(kin(nn), stat=astat) if (astat /= 0) then write(outstr, '(a,i6,a/7x,a,i0,a/7x,a)') & 'ERROR: The largest active pedigree in this dataset contains ', & dataset%maxact, ' members.', 'The kinship matrix would contain ', & nn, ' elements,', 'and matrices are not yet represented sparsely!' return end if meanf=0.0D0 ndom=0 if (typ == 4) then write(outstr,'(4(/a))') & '--------------------------------------------------', & 'Bilineally-related non-full-sibling relative pairs', & '--------------------------------------------------', & 'Pedigree Person-1 Person-2 R K' else if (typ == 9) then continue else if (typ == 10) then write(outstr,'(a)') 'ped1 id1 ped2 id2 kin' else write(outstr,'(3(/a))') & '--------------------------------------------------', & 'Coefficient of relationship for all relative pairs', & '--------------------------------------------------' if (typ == 2) then write(outstr,'(a//a/)') & 'NOTE: Writing one relative pair per record', & 'Pedigree Person-1 Person-2 R K' end if end if ! pednum=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pednum=pednum+1 pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset call kinship(ped, dataset, kin) idx=0 if (typ == 1) then write(outstr,'(/2a)') 'Pedigree ', dataset%pedigree(ped) do i=1, num write(outstr,'(a8,1x,50f5.2,(/6x,50f5.2):)') & dataset%id(pedoffset+i), kin(idx+1:idx+i) idx=idx+i end do else do i=pedoffset+1, dataset%num(ped) do j=pedoffset+1, i idx=idx+1 bilin=1 if (i == j) then dom=1.0D0 else if (j == dataset%imztwin(i)) then dom=1.0D0 bilin=4 else if (i > pedoffset+dataset%nfound(ped) .and. & j > pedoffset+dataset%nfound(ped)) then fa1=dataset%fa(i)-pedoffset mo1=dataset%mo(i)-pedoffset fa2=dataset%fa(j)-pedoffset mo2=dataset%mo(j)-pedoffset gk=clcpos(fa1, fa2) hl=clcpos(mo1, mo2) gl=clcpos(fa1, mo2) hk=clcpos(mo1, fa2) dom=kin(gk)*kin(hl)+kin(gl)*kin(hk) dom=0.25D0*dom if (dom > 0.0d0) then if (fa1 == fa2 .and. mo1 == mo2) then bilin=3 else bilin=2 end if if (bilin==2) then ndom=ndom+1 end if end if else dom=0.0D0 end if if (typ == 2) then write(outstr,'(a10,2(1x,a14),1x,f6.4,1x,f6.4,1x,a)') & dataset%pedigree(ped), dataset%id(i), dataset%id(j), & kin(idx), dom, rel(bilin) else if (typ == 9) then if (i == j) then kin(idx)=kin(idx)-1.0d0 else kin(idx)=0.5d0*kin(idx) end if write(outstr,'(i0,2(1x,i0),1x,f6.4)') pednum, i, j, kin(idx) else if (typ == 10) then write(outstr,'(a,3(1x,a),1x,f6.4)') & trim(dataset%pedigree(ped)), trim(dataset%id(i)), & trim(dataset%pedigree(ped)), trim(dataset%id(j)), kin(idx) else if (typ == 4 .and. bilin == 2) then write(outstr,'(a10,2(1x,a14),1x,f6.4,1x,f6.4,1x,a)') & dataset%pedigree(ped), dataset%id(i), dataset%id(j), & kin(idx), dom, rel(bilin) end if end do if (irupt > 0) exit end do end if end if end do if (ndom > 0 .and. typ /= 9 .and. typ /= 10) then write(outstr,'(/a,i0)') & 'Bilineal non-sibling pairs = ', ndom end if deallocate(kin) end subroutine dokin ! ! Calculate kinship coefficient ! subroutine kinship(ped, dataset, kin) use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(in) :: dataset double precision, dimension(:), intent(inout) :: kin ! local variables integer, parameter :: MISS=-9999 integer :: i, idx, j, num, pedoffset, posfa, posmo ! functions integer :: clcpos ! idx=0 pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset do i=1, dataset%nfound(ped) do j=1, i-1 idx=idx+1 kin(idx)=0.0D0 end do idx=idx+1 kin(idx)=1.0D0 end do do i=dataset%nfound(ped)+1, num do j=1, i-1 idx=idx+1 if (dataset%imztwin(pedoffset+i) /= MISS) then if (pedoffset+j == dataset%imztwin(pedoffset+i)) then kin(idx)=1.0d0 else if (dataset%imztwin(pedoffset+i) == dataset%imztwin(pedoffset+j)) then kin(idx)=1.0d0 else posfa=clcpos(dataset%fa(pedoffset+i)-pedoffset, j) posmo=clcpos(dataset%mo(pedoffset+i)-pedoffset, j) kin(idx)=0.5d0*(kin(posfa)+kin(posmo)) end if else posfa=clcpos(dataset%fa(pedoffset+i)-pedoffset, j) posmo=clcpos(dataset%mo(pedoffset+i)-pedoffset, j) kin(idx)=0.5d0*(kin(posfa)+kin(posmo)) end if end do idx=idx+1 posfa=clcpos(dataset%fa(pedoffset+i)-pedoffset, dataset%mo(pedoffset+i)-pedoffset) kin(idx)=1.0D0+0.5D0*kin(posfa) end do end subroutine kinship ! ! Calculate coefficient of fraternity ! subroutine frater(ped, dataset, kin, dom) use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(inout) :: dataset double precision, dimension(:), intent(inout) :: kin, dom ! local variables integer :: i, idx, j, num ! functions interface function delta7(peri, perj, ped, dataset, kin) use ped_class implicit none double precision :: delta7 integer, intent(in) :: peri, perj, ped type (ped_data), intent(in) :: dataset double precision, dimension(:), intent(in) :: kin end function delta7 end interface ! idx=0 num=dataset%num(ped)-dataset%num(ped-1) do i=1, num do j=1, i idx=idx+1 dom(idx)=delta7(i, j, ped, dataset, kin) end do end do end subroutine frater ! ! Coefficient of fraternity for one pair of relatives ! peri and perj are relative to start of current pedigree ! function delta7(peri, perj, ped, dataset, kin) use ped_class implicit none double precision :: delta7 integer, intent(in) :: peri, perj, ped type (ped_data), intent(in) :: dataset double precision, dimension(:), intent(in) :: kin ! local variables double precision, parameter :: quarter = 0.25d0 integer :: gk, gl, hl, hk, pedoffset integer :: fa1, fa2, mo1, mo2 double precision :: res ! functions integer :: clcpos ! pedoffset=dataset%num(ped-1) if (peri == perj) then res=1.0D0 else if (pedoffset+perj == dataset%imztwin(pedoffset+peri)) then res=1.0D0 else if (peri > dataset%nfound(ped) .and. perj > dataset%nfound(ped)) then fa1=dataset%fa(pedoffset+peri)-pedoffset mo1=dataset%mo(pedoffset+peri)-pedoffset fa2=dataset%fa(pedoffset+perj)-pedoffset mo2=dataset%mo(pedoffset+perj)-pedoffset gk=clcpos(fa1, fa2) hl=clcpos(mo1, mo2) gl=clcpos(fa1, mo2) hk=clcpos(mo1, fa2) res=kin(gk)*kin(hl)+ kin(gl)*kin(hk) res=quarter * res else res=0.0D0 end if delta7=res end function delta7 ! ! Estimate inbreeding coefficient for pedigree ! subroutine inbreeding(ped, dataset, iter, fvalues, estimator) use outstream use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(in) :: dataset integer, intent(in) :: iter double precision, dimension(dataset%maxact), intent(out) :: fvalues integer, intent(out) :: estimator ! double precision, dimension(:), allocatable :: kin integer :: astat integer (kind=8) :: nn interface subroutine exact_inbreeding(ped, dataset, kin, fvalues) use outstream use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(in) :: dataset double precision, dimension(:), intent(inout) :: kin double precision, dimension(dataset%maxact), intent(out) :: fvalues end subroutine exact_inbreeding end interface nn=int(dataset%maxact, kind=8) nn=nn*(nn+1)/int(2,kind=8) allocate(kin(nn), stat=astat) if (astat /= 0) then call drop_inbreeding(ped, dataset, iter, fvalues) estimator=2 else call exact_inbreeding(ped, dataset, kin, fvalues) estimator=1 deallocate(kin) end if end subroutine inbreeding ! ! kinship based version ! subroutine exact_inbreeding(ped, dataset, kin, fvalues) use outstream use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(in) :: dataset double precision, dimension(:), intent(inout) :: kin double precision, dimension(dataset%maxact), intent(out) :: fvalues integer :: i, idx, ii, pedoffset, num, nfound interface subroutine kinship(ped, dataset, kin) use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(in) :: dataset double precision, dimension(:), intent(inout) :: kin end subroutine kinship end interface pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset nfound=dataset%nfound(ped) fvalues=0.0d0 call kinship(ped, dataset, kin) idx=dataset%nfound(ped)*(dataset%nfound(ped)+1)/2 ii=pedoffset+dataset%nfound(ped) do i=dataset%nfound(ped)+1, num ii=ii+1 idx=idx+i fvalues(i)=kin(idx)-1.0d0 end do end subroutine exact_inbreeding ! ! MC version ! subroutine drop_inbreeding(ped, dataset, iter, fvalues) use outstream use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(in) :: dataset integer, intent(in) :: iter double precision, dimension(dataset%maxact), intent(out) :: fvalues ! local variables: IBD alleles integer, parameter :: MISS = -9999 integer, dimension (dataset%maxact,2) :: sibd integer, dimension (dataset%maxact) :: fcount integer :: i, ii, it, j, num, nfound, par1, par2, pedoffset logical :: fin interface subroutine genoff(idx, fa, mo, set) integer, intent(in) :: idx integer, intent(in) :: fa integer, intent(in) :: mo integer, dimension(:,:), intent(in out) :: set end subroutine subroutine gencopy(idx, origin, set) integer, intent(in) :: idx integer, intent(in) :: origin integer, dimension(:,:), intent(inout) :: set end subroutine gencopy end interface pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset nfound=dataset%nfound(ped) j=0 do i=1, nfound j=j+1 sibd(i,1)=j j=j+1 sibd(i,2)=j end do do i=nfound+1, num fcount(i)=0 end do do it=1, iter do i=nfound+1, num sibd(i,1)=MISS sibd(i,2)=MISS end do do fin=.true. ii=pedoffset+nfound do i=nfound+1, num ii=ii+1 if (sibd(i,1) == MISS) then par1=dataset%fa(ii)-pedoffset par2=dataset%mo(ii)-pedoffset if (sibd(par1,1) /= MISS .and. sibd(par2,1) /= MISS) then if (dataset%imztwin(ii) /= MISS) then call gencopy(i, dataset%imztwin(ii)-pedoffset, sibd) else call genoff(i, par1, par2, sibd) end if else fin=.false. end if end if end do if (fin) exit end do do i=nfound+1, num if (sibd(i,1) == sibd(i,2)) then fcount(i)=fcount(i)+1 end if end do end do fvalues=dble(fcount)/dble(iter) end subroutine drop_inbreeding ! ! inbreeding for all active pedigrees ! subroutine doinbred(iter, dataset, trait, plevel) use outstream use ped_class implicit none integer, intent(in) :: iter type (ped_data), intent(inout) :: dataset integer, intent(in) :: trait integer, intent(in) :: plevel ! local variables: IBD alleles integer, parameter :: MISS = -9999 integer, dimension (dataset%maxact,2) :: sibd double precision, dimension (dataset%maxact) :: fvalues ! integer :: i, idx, ii, it, j, k, par1, par2, n0625, ninbred, tot integer :: estimator, fcount, nfound, nfall, num, ped, pedoffset double precision :: dinbred, maxf, meanf, fis, ll, ul, diter ! dataset%untyped=.false. if (trait /= MISS) then dataset%plocus(:,trait)=MISS end if dinbred=0.0d0 maxf=0.0d0 meanf=0.0D0 diter=dble(iter) n0625=0 ninbred=0 tot=0 if (trait /= MISS .or. plevel > -1) then write(outstr,'(3(/a)/a,i6,a)') & '--------------------------------------------------', & 'Individuals with non-zero inbreeding coefficient', & '--------------------------------------------------', & 'Coefficients estimated using ', iter, ' MC iterations.' if (plevel > -1) then write(outstr,'(/a/a)') & 'Pedigree Person Father Mother F MC 95%CI', & '---------- -------------- -------------- -------------- ------ -------------' end if end if ! do ped=1, dataset%nped if (dataset%actset(ped) > 0) then call inbreeding(ped, dataset, iter, fvalues, estimator) pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset nfound=dataset%nfound(ped) tot=tot+num-nfound ii=pedoffset+nfound if (trait /= MISS) then dataset%plocus((pedoffset+1):(pedoffset+num),trait)=0.0d0 end if do i=nfound+1, num ii=ii+1 if (fvalues(i) > 0.0d0) then ninbred=ninbred+1 maxf=max(maxf, fvalues(i)) meanf=meanf+fvalues(i) if (fvalues(i) >= 0.0625d0) n0625=n0625+1 if (plevel > -1) then write(outstr,'(a10,3(1x,a14),1x,f6.4)', advance='no') & dataset%pedigree(ped), dataset%id(ii), & dataset%id(dataset%fa(ii)), dataset%id(dataset%mo(ii)), & fvalues(i) if (estimator == 2) then fcount=anint(fvalues(i)*diter) call propci(fcount, iter, 95.0d0, fis, ll, ul) write(outstr,'(2x,f6.4,a,f6.4)') ll, '-', ul else write(outstr,*) end if end if end if if (trait /= MISS) then dataset%plocus(ii,trait)=fvalues(i) end if end do end if end do if (plevel > -2) then if (tot > 0) then if (ninbred > 0) dinbred=meanf/dble(ninbred) meanf=meanf/dble(tot) end if write(outstr,'(/a,f8.6,a,i0,a/a,i0)') & 'Mean inbreeding coefficient = ', meanf, & ' (based on ', tot, ' nonfounder individuals)', & 'Number of inbred individuals = ', ninbred if (ninbred > 0) then write(outstr,'(a,i0/a,f8.6,a,f8.6,a)') & 'Number with F >= 1/16 = ', n0625, & 'Mean F in inbred individuals = ', dinbred, ' (max F=', maxf,')' end if end if end subroutine doinbred ! ! ! A~ = (T~)' D~ T~ ! subroutine invkin(ped, dataset, ainv) use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(in) :: dataset double precision, dimension(:), intent(inout) :: ainv ! local variables integer :: i, inc, j, jj, k, num, pedoffset, pos double precision :: res ! functions integer :: clcpos ! ! calculate T~ pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset do i=1,num*(num+1)/2 ainv(i)=0.0D0 end do pos=0 do i=1, num pos=pos+i ainv(pos)=1.0D0 end do do i=dataset%nfound(ped)+1, num ainv(clcpos(dataset%fa(pedoffset+i)-pedoffset, i))=-0.5D0 ainv(clcpos(dataset%mo(pedoffset+i)-pedoffset, i))=-0.5D0 end do ! ! evaluate product r' D~ r where D~[i,i]=1 i=1..nfound; 2 i=nfound+1,num ! pos=0 do i=1, num inc=i-1 do j=1, i pos=pos+1 jj=pos res=0.0D0 do k=i, dataset%nfound(ped) res=res+ainv(jj)*ainv(jj+inc) jj=jj+k end do do k=max(dataset%nfound(ped)+1, i), num res=res+2*ainv(jj)*ainv(jj+inc) jj=jj+k end do ainv(pos)=res inc=inc-1 end do end do end subroutine invkin ! ! Calculate standard deviation of segregation error ! (used for gametic model breeding value calculation) ! subroutine segerr(ped, dataset, rsd) use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(inout) :: dataset double precision, dimension(:), intent(out) :: rsd ! local variables double precision, dimension(:), allocatable :: kin integer :: cfa, cmo, i, ii, num, pedoffset integer (kind=8) :: nn double precision, parameter :: rthalf = 0.70710678118655D0 ! functions integer :: clcpos interface subroutine kinship(ped, dataset, kin) use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(in) :: dataset double precision, dimension(:), intent(inout) :: kin end subroutine kinship end interface ! pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset nn=int(num, kind=8) nn=nn*(nn+1)/int(2, kind=8) allocate(kin(nn)) call kinship(ped, dataset, kin) do i=1, dataset%nfound(ped) rsd(i)=rthalf end do ii=dataset%nfound(ped) do i=pedoffset+dataset%nfound(ped)+1, dataset%num(ped) ii=ii+1 cfa=dataset%fa(i)-pedoffset cmo=dataset%mo(i)-pedoffset rsd(ii)=sqrt(1.0D0-0.25D0*(kin(clcpos(cfa,cfa)) + & kin(clcpos(cmo,cmo)))) end do deallocate(kin) end subroutine segerr ! ! Give kinships among affecteds ! subroutine casekin(locnam, trait, gt, thresh, dataset, statval, pval, & iter, plevel) use outstream use ped_class use comp_ops use rngs implicit none character (len=*), intent(inout) :: locnam integer, intent(inout) :: trait integer, intent(inout) :: gt double precision, intent(in) :: thresh type (ped_data), intent(inout) :: dataset double precision, dimension(3), intent(out) :: statval double precision, intent(out) :: pval integer, intent(in) :: iter integer, intent(in) :: plevel ! local variables: numerator relationship matrix integer, parameter :: MISS=-9999 double precision, dimension(dataset%maxact*(dataset%maxact+1)/2) :: kin ! list of affected individuals integer :: naff, aff(dataset%maxact) integer :: i, idlen, ii, it, j, nel, nfam, ninbred, npairs, nspor, & pos, totaff, totpairs integer :: num, ped, pedoffset logical :: ispor, last double precision :: globalr, inb, meanf, meanr, mkin, sdf, sdr ! null distribution simulated values integer :: ftailp, rtailp double precision :: fpval double precision :: simf(iter), simr(iter) ! functions integer :: clcpos character (len=6) :: pstring double precision :: isaff interface subroutine kinship(ped, dataset, kin) use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(in) :: dataset double precision, dimension(:), intent(inout) :: kin end subroutine kinship function delta7(peri, perj, ped, dataset, kin) use ped_class implicit none double precision :: delta7 integer, intent(in) :: peri, perj, ped type (ped_data), intent(in) :: dataset double precision, dimension(:), intent(in) :: kin end function delta7 end interface ! write(outstr,'(/a/3a/a)') & '----------------------------------------------------', & 'Relationships of probands with trait "', trim(locnam),'"', & '----------------------------------------------------' if (thresh /= MISS) call defpro(gt, thresh, .true.) if (plevel == 0) then write(outstr,'(a/a)') & 'Pedigree Aff Sporad Inbred mean R mean F', & '---------- ------ ------ ------ ------ ------' end if nfam=0 totaff=0 totpairs=0 globalr=0.0d0 meanf=0.0D0 meanr=0.0D0 statval=0.0d0 simf=0.0d0 simr=0.0d0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset naff=0 idlen=2 ii=pedoffset do i=1, num ii=ii+1 if (isaff(dataset%plocus(ii,trait), thresh, gt) == 2.0d0) then naff=naff+1 aff(naff)=i idlen=max(idlen, len_trim(dataset%id(ii))) end if end do ! ! Skip if nobody affected ! if (naff > 0) then ! ! calculate mean inbreeding for affecteds ! and print out kinships for cases ! nfam=nfam+1 npairs=naff*(naff-1)/2 totaff=totaff+naff totpairs=totpairs+npairs call kinship(ped, dataset, kin) if (plevel > 0) then write(outstr,'(/2a,1x,a,i0,a/a)') & 'Pedigree ', trim(dataset%pedigree(ped)), & '(', naff, ' affected members)', 'R' do i=1, naff write(outstr,'(a)', advance='no') & dataset%id(pedoffset+aff(i))(1:idlen) write(outstr,'(50(1x,f5.3),(/5x,50(1x,f5.3):))') & (kin(clcpos(aff(i), aff(j))), j=1,i) end do write(outstr,'(a)') 'K' do i=1, naff write(outstr,'(a)', advance='no') & dataset%id(pedoffset+aff(i))(1:idlen) write(outstr,'(50(1x,f5.3),(/5x,50(1x,f5.3):))') & (delta7(aff(i), aff(j), ped, dataset, kin), j=1,i) end do end if ninbred=0 nspor=0 inb=0.0D0 mkin=0.0D0 do i=1, naff pos=aff(i) inb=inb+kin(clcpos(pos,pos))-1.0D0 if (kin(clcpos(pos,pos)) > 1.0D0) then ninbred=ninbred+1 if (plevel > 0) then write(outstr,'(3a)') & 'Proband ', dataset%id(pedoffset+pos), ' is inbred.' end if end if ispor=.true. do j=1, i-1 mkin=mkin+kin(clcpos(pos,aff(j))) if (kin(clcpos(pos,aff(j))) /= 0.0D0) then ispor=.false. end if end do if (ispor) then do j=i+1, naff if (kin(clcpos(pos,aff(j))) /= 0.0D0) then ispor=.false. exit end if end do end if if (ispor) then nspor=nspor+1 if (plevel > 0) then write(outstr,'(3a)') & 'Proband ', dataset%id(pedoffset+pos), ' is a sporadic case.' end if end if end do meanf=meanf+inb meanr=meanr+mkin inb=inb/dble(naff) if (npairs > 0) mkin=mkin/dble(npairs) if (plevel == 0) then write(outstr,'(a10,3i7,2(2x,f6.4))') & dataset%pedigree(ped), naff, nspor, ninbred, mkin, inb end if ! ! permute trait values among phenotyped pedigree members for null distribution ! nel=0 ii=pedoffset do i=1, num ii=ii+1 if (dataset%plocus(ii,trait) /= MISS) then nel=nel+1 aff(nel)=i end if end do do it=1, iter inb=0.0D0 mkin=0.0D0 call permut(nel, aff) ! take first naff indices as new cases do i=1, naff pos=aff(i) inb=inb+kin(clcpos(pos,pos))-1.0D0 do j=1, i-1 mkin=mkin+kin(clcpos(pos,aff(j))) end do end do simf(it)=simf(it)+inb simr(it)=simr(it)+mkin end do end if end if end do ! ! write mean R and F for all affecteds ! if (totaff > 0) then globalr=2*(dble(totaff)+meanf+meanr)/dble(totaff)/dble(totaff+1) meanf=meanf/dble(totaff) meanr=meanr/dble(totpairs) statval(1)=meanr statval(2)=meanf write(outstr,'(3(/a,1x,f8.6,a,i0,a))') & 'Mean relatedness of cases = ', & statval(1), ' (based on ', totpairs, ' affected relative pairs)', & 'Mean inbreeding of cases = ', & statval(2), ' (based on ', totaff, ' affected individuals)', & 'Kinship correction 1/[1-E(r)] = ', & 1.0d0/(1.0d0-globalr), ' (for ', totaff, ' affected individuals)' if (iter > 0) then ftailp=0 rtailp=0 meanf=0.0d0 meanr=0.0d0 sdf=0.0d0 sdr=0.0d0 do it=1, iter simf(it)=simf(it)/dble(totaff) simr(it)=simr(it)/dble(totpairs) if (simf(it) > statval(2) .or. & (simf(it) == statval(2) .and. random() > 0.5)) then ftailp=ftailp+1 end if if (simr(it) > statval(1) .or. & (simr(it) == statval(1) .and. random() > 0.5)) then rtailp=rtailp+1 end if call moment(it, simf(it), meanf, sdf) call moment(it, simr(it), meanr, sdr) end do sdf=sqrt(sdf/dble(max(1,iter-1))) sdr=sqrt(sdr/dble(max(1,iter-1))) fpval=dble(ftailp)/dble(iter) pval=dble(rtailp)/dble(iter) write(outstr,'(/a,i0,a/2(/a,1x,f8.6,a,f8.6,3a))') & 'Kinship in ', iter, ' permuted datasets:', & 'Expected relatedness of cases = ', & meanr, ' (SD=', sdr, ', Permutation P=', trim(pstring(pval)), ')', & 'Expected inbreeding of cases = ', & meanf, ' (SD=', sdf, ', Permutation P=', trim(pstring(fpval)), ')' if (plevel > 1) then write(outstr,'(//a)') 'Pseudosample R F' do it=1, iter write(outstr,*) it, simr(it), simf(it) end do end if end if else write(outstr,'(a)') 'No cases meeting criteria for affection.' end if end subroutine casekin ! ! Find the ancestor(s) shared by the maximum number of affecteds ! Also calculate inbreeding among all cases within each family ! subroutine ancest(locnam, trait, gt, thresh, dataset, plevel) use outstream use ped_class use comp_ops implicit none character (len=*), intent(inout) :: locnam integer, intent(inout) :: trait integer, intent(inout) :: gt double precision, intent(in) :: thresh type (ped_data), intent(inout) :: dataset integer, intent(inout) :: plevel ! local variables: numerator relationship matrix integer, parameter :: MISS=-9999 double precision, dimension(dataset%maxact) :: fvalues ! list of affected individuals integer :: aff(dataset%maxact) integer :: num, ped, pedoffset integer :: astat, bestid, nid, bestfa, nfa, bestmo, nmo, cfa, cmo, i, idx, naff, totaff integer (kind=8) :: nn double precision :: meanf, x ! functions double precision :: isaff ! meanf=0.0D0 totaff=0 write(outstr,'(/a/3a/a)') & '--------------------------------------------------', & 'Ancestors of probands with trait "', trim(locnam), '"', & '--------------------------------------------------' if (thresh /= MISS) call defpro(gt, thresh, .true.) write(outstr,'(/a/a)') & 'Pedigree Father Mother Number of Affected Descendents', & '---------- ---------- ---------- ------------------------------' do ped=1, dataset%nped if (dataset%actset(ped) > 0 .and. & (dataset%num(ped)-dataset%num(ped-1)-dataset%nfound(ped))>1) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset naff=0 do i=1, num if (isaff(dataset%plocus(pedoffset+i,trait), thresh, gt) == 2.0d0) then naff=naff+1 aff(i)=1 else aff(i)=0 end if end do ! ! Skip if nobody affected ! if (naff > 0) then ! ! calculate mean inbreeding for affecteds ! totaff=naff+totaff call inbreeding(ped, dataset, 200, fvalues, i) do i=1, num if (aff(i) == 1) then meanf=meanf+fvalues(i) end if end do ! ! Accumulate counts of descendents who are affected ! bestid=MISS nid=0 bestfa=MISS nfa=0 bestmo=MISS nmo=0 do i=num, dataset%nfound(ped)+1, -1 cfa=dataset%fa(pedoffset+i)-pedoffset cmo=dataset%mo(pedoffset+i)-pedoffset aff(cfa)=aff(cfa)+aff(i) aff(cmo)=aff(cmo)+aff(i) end do ! ! Find largest count of affecteds as low in the pedigree as possible ! do i=num, dataset%nfound(ped)+1, -1 if (aff(i) > nid) then nid=aff(i) bestid=pedoffset+i end if cfa=dataset%fa(pedoffset+i)-pedoffset cmo=dataset%mo(pedoffset+i)-pedoffset if ((aff(cfa)+aff(cmo)) > (nfa+nmo)) then bestfa=dataset%fa(pedoffset+i) nfa=aff(cfa) bestmo=dataset%mo(pedoffset+i) nmo=aff(cmo) end if end do do i=dataset%nfound(ped), 1, -1 if (aff(i) > nid) then nid=aff(i) bestid=pedoffset+i end if end do ! ! Write the best individual ancestor and ancestral mating ! call wrdesc(dataset%pedigree(ped), dataset%id(bestid), dataset%sex(bestid), nid, naff) write(outstr,'(a10,1x,a10,1x,a10,1x,2(i4,a,f5.1,a))') & dataset%pedigree(ped), dataset%id(bestfa), dataset%id(bestmo), & nfa, ' (', float(100*nfa)/float(naff),'%), ', & nmo, ' (', float(100*nmo)/float(naff),'%)' if (plevel > 1) then write(outstr,*) do i=1, num if (aff(i) > 1) then call wrdesc(dataset%pedigree(ped), dataset%id(pedoffset+i), & dataset%sex(pedoffset+i), aff(i), naff) end if end do write(outstr,*) end if end if end if end do ! ! write mean F for all affecteds ! if (totaff > 0) meanf=meanf/dble(totaff) write(outstr,'(/a,1x,f8.6,a,i5,a)') & 'Mean inbreeding of cases = ', & meanf,' (based on ', totaff, ' affected individuals)' end subroutine ancest ! ! write person and number of descendants ! subroutine wrdesc(pedigree, cid, sx, ndesc, ntot) use outstream use idstring_widths character (len=ped_width), intent(in) :: pedigree character (len=id_width), intent(in) :: cid integer, intent(in) :: sx integer, intent(in) :: ndesc integer, intent(in) :: ntot if (sx == 1) then write(outstr,'(a10,1x,a10,12x,i4,a,f5.1,a)') & pedigree, cid, ndesc, ' (', float(100*ndesc)/float(ntot), '%)' else write(outstr,'(a10,12x,a10,1x,i4,a,f5.1,a)') & pedigree, cid, ndesc, ' (', float(100*ndesc)/float(ntot), '%)' end if end subroutine wrdesc ! ! Parse a mixed model ! subroutine mksegmod(narg, words, trait, gt, thresh, offset, censor, & nvar, varlist, nloci, loc, lochash, loctyp, & priran, nqtl, linkf, modtyp, shap) use outstream use mcmc_model use locus_types use locus_list use idhash_class use comp_ops integer, intent(in) :: narg character (len=*), dimension(:), intent(in) :: words integer, intent(in) :: trait integer, intent(out) :: gt double precision, intent(out) :: thresh integer, intent(out) :: offset integer, intent(out) :: censor integer, intent(out) :: nvar integer, dimension(:), intent(out) :: varlist integer, intent(inout) :: nloci character (len=20), dimension(:), intent(inout) :: loc type (hash_table) :: lochash integer, dimension(:), intent(inout) :: loctyp integer, intent(out) :: priran integer, intent(out) :: nqtl integer, intent(out) :: linkf integer, intent(out) :: modtyp double precision, intent(out) :: shap ! ! model pars 1=P(all) 2=a 3=d 4=AA 5=AB 6=BB ! 7=mu 8=totvar 9=VA 10=VD 11=VG 12=VC 13=VS 14=VE ! 15=sdG 16=sdC 17=sdS 18=sdE ! 19=a2 20=d2 21=h2 22=c2 23=s2 24=e2 ! 25..MAXPAR=Betas ! double precision, parameter :: pi23 = 3.2898681337d0, pi26 = 1.6449340668d0 character (len=3) :: keyword integer :: i, icov, isav double precision :: falcd, p, q ! functions logical :: isreal double precision :: fval ! censor=MISS isav=MISS linkf=LINK_UNSPEC modtyp=GLM_GAUSS nqtl=1 nvar=0 offset=MISS priran=0 shap=MISS do i=1, MAXPAR paract(i)=P_EXCL par(i)=MISS parscal(i)=0.0D0 end do ! default model additive QTL (free: mu, VT, a) paract(PTYP_a)=P_FREE paract(PTYP_mu)=P_FREE paract(PTYP_VT)=P_FREE paract(PTYP_pa)=P_FIX paract(PTYP_AA)=P_DERIV paract(PTYP_AB)=P_DERIV paract(PTYP_BB)=P_DERIV paract(PTYP_VA)=P_DERIV paract(PTYP_VE)=P_DERIV paract(PTYP_sdE)=P_DERIV paract(PTYP_a2)=P_DERIV paract(PTYP_e2)=P_DERIV gt=0 thresh=MISS i=3 if (iscomp(words(3))) then call docomp(i, words, gt, thresh) end if ! do while (i <= narg) if (words(i) /= '+') keyword=words(i)(1:3) ! parameters to be estimated if (keyword == 'd' .or. keyword == 'vd' .or. keyword == 'd2') then paract(PTYP_d)=P_FREE paract(PTYP_VD)=P_DERIV paract(PTYP_d2)=P_DERIV i=i+1 else if (keyword == 'p' .or. keyword == 'fre') then paract(PTYP_pa)=P_FREE i=i+1 else if (keyword == 'a' .or. keyword == 'va') then i=i+1 else if (keyword == 'g' .or. keyword == 'vg' .or. & keyword == 'h2') then paract(PTYP_h2)=P_FREE paract(PTYP_VG)=P_DERIV paract(PTYP_sdG)=P_DERIV i=i+1 else if (keyword == 'c' .or. keyword == 'vc' .or. & keyword == 'c2') then paract(PTYP_c2)=P_FREE paract(PTYP_VC)=P_DERIV paract(PTYP_sdC)=P_DERIV i=i+1 else if (keyword == 's' .or. keyword == 'vs' .or. & keyword == 's2') then paract(PTYP_s2)=P_FREE paract(PTYP_VS)=P_DERIV paract(PTYP_sdS)=P_DERIV i=i+1 else if (i < narg .and. keyword == 'lin') then if (words(i+1) == 'ln') then linkf=LINK_LOG else if (words(i+1)(1:3) == 'mft') then linkf=LINK_MFT modtyp=GLM_BINOM else if (words(i+1)(1:3) == 'pro') then linkf=LINK_PROBIT else if (words(i+1)(1:3) == 'log') then linkf=LINK_LOGIT else if (words(i+1)(1:2) == 'id') then linkf=LINK_ID else linkf=ival(words(i+1)) end if if (linkf == LINK_UNSPEC) linkf=LINK_ID i=i+2 else if (i < narg .and. keyword == 'lik') then if (words(i+1)(1:3) == 'wei') then modtyp=GLM_WEIB else if (words(i+1)(1:3) == 'gam') then modtyp=GLM_GAMMA else if (words(i+1)(1:3) == 'poi') then modtyp=GLM_POISS else if (words(i+1)(1:3) == 'bin') then modtyp=GLM_BINOM else if (words(i+1)(1:3) == 'mft') then modtyp=GLM_BINOM linkf=LINK_MFT else modtyp=GLM_GAUSS end if i=i+2 else if (i < narg .and. keyword == 'fix') then if (words(i+1) == 'var') then paract(PTYP_VT)=P_FIX i=i+2 else if (words(i+1) == 'p' .or. words(i+1) == 'fre') then paract(PTYP_pa)=P_FIX i=i+2 else if (words(i+1) == 'a' .or. words(i+1) == 'va') then paract(PTYP_a)=P_FIX i=i+2 else if (words(i+1) == 'd' .or. words(i+1) == 'vd') then paract(PTYP_d)=P_FIX i=i+2 else if (words(i+1) == 'g' .or. words(i+1) == 'vg') then paract(PTYP_VG)=P_FIX paract(PTYP_h2)=P_DERIV i=i+2 else if (words(i+1) == 'c' .or. words(i+1) == 'vc') then paract(PTYP_VC)=P_FIX paract(PTYP_c2)=P_DERIV i=i+2 else if (words(i+1) == 's' .or. words(i+1) == 'vs') then paract(PTYP_VS)=P_FIX paract(PTYP_s2)=P_DERIV i=i+2 else if (words(i+1) == 'm' .or. words(i+1) == 'mu') then paract(PTYP_mu)=P_FIX i=i+2 else write(outstr,'(3a)') 'Cannot fix "', trim(words(i+1)), '".' i=i+2 end if else if (i < narg .and. keyword == 'cov') then call gettrait(words(i+1), LOC_ANY, 0, nloci, loc, lochash, loctyp, icov, 0) if (icov /= MISS) then nvar=nvar+1 varlist(nvar)=icov else write(outstr,'(3a)') 'Skipping "', & trim(words(i+1)), '": not an active trait.' end if i=i+2 else if (i < narg .and. keyword == 'off') then call gettrait(words(i+1), LOC_QUA, 0, nloci, loc, lochash, loctyp, offset, 0) if (offset == MISS) then write(outstr,'(3a)') & 'Variable "', trim(words(i+1)), '": not suitable for offset.' end if i=i+2 else if (i < narg .and. keyword == 'cen') then call gettrait(words(i+1), LOC_QUA, LOC_AFF, nloci, loc, lochash, loctyp, censor, 0) if (censor == MISS) then write(outstr,'(3a)') & 'Variable "', trim(words(i+1)), '": not suitable for censoring indicator.' end if i=i+2 else if (i < narg .and. keyword == 'sav') then call gettrait(words(i+1), LOC_CODOM, LOC_QUA, nloci, loc, lochash, loctyp, isav, 0) if (isav == MISS) then write(outstr,'(3a)') & 'Variable "', trim(words(i+1)), '": cannot save simulated data.' else priran=-isav end if i=i+2 else if (keyword == 'pri') then priran=1 i=i+1 ! starting values for parameters or values to evaluate likelihood at else if (i < narg) then ! write(outstr,*) len(words(i+1)), '"', trim(words(i+1)), '" ', isreal(words(i+1)) if (isreal(words(i+1))) then if (keyword == 'ava') then par(PTYP_a)=fval(words(i+1)) i=i+2 else if (keyword == 'dva') then par(PTYP_d)=fval(words(i+1)) i=i+2 else if (keyword == 'pva') then par(PTYP_pa)=fval(words(i+1)) i=i+2 else if (keyword == 'mu') then par(PTYP_mu)=fval(words(i+1)) i=i+2 else if (keyword == 'var') then par(PTYP_VT)=fval(words(i+1)) i=i+2 else if (keyword == 'AA') then par(PTYP_AA)=fval(words(i+1)) i=i+2 else if (keyword == 'AB') then par(PTYP_AB)=fval(words(i+1)) i=i+2 else if (keyword == 'BB') then par(PTYP_BB)=fval(words(i+1)) i=i+2 else if (keyword == 'eva') then par(PTYP_VE)=fval(words(i+1)) i=i+2 else if (keyword == 'SD') then par(PTYP_sdE)=fval(words(i+1)) i=i+2 else if (keyword == 'gva') then par(PTYP_VG)=fval(words(i+1)) i=i+2 else if (keyword == 'cva') then par(PTYP_VC)=fval(words(i+1)) i=i+2 else if (keyword == 'sva') then par(PTYP_VS)=fval(words(i+1)) i=i+2 else if (keyword == 'nqt') then nqtl=ival(words(i+1)) i=i+2 else if (keyword == 'sha') then shap=fval(words(i+1)) i=i+2 else write(outstr,'(3a)') 'Skipping unknown keyword "', trim(words(i)), '".' i=i+1 end if else write(outstr,'(3a)') 'Skipping unknown keyword "', trim(words(i)), '".' i=i+1 end if else write(outstr,'(3a)') 'Skipping unknown keyword "', trim(words(i)), '".' i=i+1 end if end do nvar=nvar+1 varlist(nvar)=trait ! ! Binomial likelihood can be explicitly requested, but is usually ! inferred using the trait type ! if (loctyp(trait) == LOC_AFF .or. thresh /= MISS) then modtyp=GLM_BINOM end if ! if link function not set, set to conjugate link if (linkf == LINK_UNSPEC) then if (modtyp == GLM_GAUSS) then linkf=LINK_ID else if (modtyp == GLM_BINOM) then linkf=LINK_LOGIT else if (modtyp == GLM_POISS .or. modtyp == GLM_WEIB .or. modtyp == GLM_GAMMA) then linkf=LINK_LOG end if end if ! ! if nqtl=0, assume a Gaussian additive polygenic model ! if (nqtl == 0) then paract(PTYP_pa)=P_EXCL paract(PTYP_a)=P_EXCL paract(PTYP_d)=P_EXCL paract(PTYP_AA)=P_EXCL paract(PTYP_AB)=P_EXCL paract(PTYP_BB)=P_EXCL paract(PTYP_VA)=P_EXCL paract(PTYP_a2)=P_EXCL paract(PTYP_d2)=P_EXCL if (paract(PTYP_h2) == P_EXCL .and. paract(PTYP_c2) == P_EXCL .and. & paract(PTYP_s2) == P_EXCL) then paract(PTYP_h2)=P_FREE paract(PTYP_VG)=P_DERIV paract(PTYP_sdG)=P_DERIV paract(PTYP_e2)=P_DERIV end if ! ! if specified p+var+genotypic means, set a, d, mu, and then VA, VD and VE ! 1=P(all) 2=a 3=d 4=AA 5=AB 6=BB 7=mu 8=totvar 9=VA 10=VD 11=VG 12=VC 13=VS 14=VE ! 15=sdG 16=sdC 17=sdS 18=sdE 19=a2 20=d2 21=h2 22=c2 23=s2 24=e2 25..MAXPAR=Betas ! else if (par(PTYP_pa) /= MISS .and. & ((par(PTYP_a) /= MISS .and. par(PTYP_d) /= MISS .and. & par(PTYP_mu) /= MISS) .or. & (par(PTYP_AA) /= MISS .and. par(PTYP_AB) /= MISS .and. & par(PTYP_BB) /= MISS)) .and. & (par(PTYP_VT) /= MISS .or. par(PTYP_sdE) /= MISS .or. & par(PTYP_VE) /= MISS .or. modtyp == GLM_BINOM .or. & modtyp == GLM_POISS)) then p=par(PTYP_pa) q=1.0D0-p if (par(PTYP_a) == MISS) then par(PTYP_a)=0.5D0*abs(par(PTYP_BB)-par(PTYP_AA)) if (paract(PTYP_d2) /= P_EXCL) then par(PTYP_d)=(par(PTYP_AB)-0.5D0*(par(PTYP_AA)+par(PTYP_BB)))/par(PTYP_a) else par(PTYP_d)=0.0D0 end if par(PTYP_mu)=p*p*par(PTYP_AA) + 2*p*q*par(PTYP_AB) + q*q*par(PTYP_BB) else par(PTYP_AA)=2*q*(par(PTYP_a)-par(PTYP_pa)*par(PTYP_d))-par(PTYP_mu) par(PTYP_AB)=par(PTYP_AA)+par(PTYP_a)*(par(PTYP_d)-1.0d0) par(PTYP_BB)=par(PTYP_AA)-par(PTYP_a)-par(PTYP_a) end if falcd=par(PTYP_d)*par(PTYP_a) par(PTYP_VA)=2*p*q*(par(PTYP_a)+(q-par(PTYP_pa))*falcd)**2 par(PTYP_VD)=4*p*q*p*q*falcd*falcd if (modtyp == GLM_BINOM) then if (linkf == LINK_LOGIT) then par(PTYP_sdE)=sqrt(pi23) else if (linkf == LINK_PROBIT) then par(PTYP_sdE)=1.0d0 else par(PTYP_sdE)=sqrt(par(PTYP_mu)*(1.0d0-par(PTYP_mu))) end if else if (modtyp == GLM_WEIB .or. modtyp == GLM_GAMMA) then par(PTYP_sdE)=sqrt(pi26) end if if (par(PTYP_VT) == MISS) then if (par(PTYP_VE) == MISS) then par(PTYP_VE)=par(PTYP_sdE)*par(PTYP_sdE) end if par(PTYP_VT)=par(PTYP_VA)+par(PTYP_VD)+par(PTYP_VE) else par(PTYP_VE)=par(PTYP_VT)-par(PTYP_VA)-par(PTYP_VD) par(PTYP_sdE)=sqrt(par(PTYP_VE)) end if par(PTYP_a2)=par(PTYP_VA)/par(PTYP_VT) par(PTYP_d2)=par(PTYP_VD)/par(PTYP_VT) else if (par(PTYP_AA) /= MISS .or. par(PTYP_AB) /= MISS .or. par(PTYP_BB) /= MISS) then write(outstr,'(/a)') & 'NOTE: Need to specify 3 genotypic means, allele frequency and variance.' end if ! ! Binomial likelihood can be explicitly requested, but is usually ! inferred using the trait type ! If binomial or poisson likelihood, alter parameter set ! if (modtyp == GLM_BINOM .or. modtyp == GLM_POISS .or. & modtyp == GLM_WEIB .or. modtyp == GLM_GAMMA) then paract(PTYP_VT)=P_EXCL paract(PTYP_e2)=P_EXCL paract(PTYP_VE)=P_DERIV paract(PTYP_sdE)=P_DERIV do i=PTYP_h2, PTYP_s2 if (paract(i) == P_FREE .or. paract(i) == P_FIX) then paract(i-10)=paract(i) paract(i)=P_EXCL par(i)=MISS end if end do end if ! if binomial with logistic link or weibull, give estimate of heritability if ((modtyp == GLM_BINOM .and. linkf /= LINK_ID) .or. & modtyp == GLM_WEIB .or. modtyp == GLM_GAMMA) then do i=PTYP_h2, PTYP_s2 if (paract(i-10) /= P_EXCL) paract(i)=P_DERIV end do end if ! if ordinary poisson, set shap to 1.0, as acts as offset multiplier ! Weibull and Gamma needs a good starting value too if (shap == MISS) then shap=1.0d0 end if end subroutine mksegmod ! ! Names and preliminary estimates for fixed effects part of mixed model ! subroutine preseg(nvar, fixed, loc, loctyp, gene, allele_buffer, covariates) use AS164_class use alleles_class use covariate_data use mcmc_model integer, intent(in) :: nvar integer, dimension(:), intent(in) :: fixed character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, intent(in) :: gene type (allele_data) :: allele_buffer type (variable_data) :: covariates ! ! nvar=number of variables ! gene=factor coded gene (numal-1 levels) ! nfix=number of columns in design matrix ! integer :: i, j, icat, ii, pos, ppos character (len=3) :: allel double precision :: lrts integer :: df ! if (nvar < 2) return i=1 ii=1 icat=0 par(PTYP_mu)=b(i) parscal(PTYP_mu)=sqrt(cov(ii)) ppos=RANPAR do j=1, nvar-1 pos=fixed(j) ncat=1 if (pos == gene) then ncat=allele_buffer%numal-1 else if (loctyp(pos) == LOC_CAT) then icat=icat+1 ncat=covariates%martable(icat)%ncells-1 end if do k=1, ncat i=i+1 ii=ii+i ppos=ppos+1 par(ppos)=b(i) parscal(ppos)=sqrt(cov(ii)) paract(ppos)=1 parnam(ppos)=loc(pos) if (pos == gene) then call wrall(allele_buffer%allele_names(k+1), allel) call juststr('l',allel,3) parnam(ppos)=loc(pos)(1:min(10,len_trim(loc(pos)))) // '*' // trim(allel) else if (ncat > 1) then write(allel, '(i3)') k+1 parnam(ppos)=trim(parnam(ppos)) // '*' // trim(adjustl(allel)) end if ! write(*,*) 'PRESEG ', ppos, parnam(ppos), paract(ppos), par(ppos), parscal(ppos) end do end do end subroutine preseg ! ! Mixed model MCMC: simulate genotypes at 1..N unlinked QTLs ! Gaussian breeding values ! family intercepts ! regression coefficients for fixed effects ! subroutine segsim(linkf, modtyp, shap, trait, gt, thresh, offset, censor, & nvar, fixed, gene, genemod, allele_buffer, & nloci, loc, loctyp, locpos, & burnin, iter, nbatch, nsamples, tune, nchain, nqtl, dataset, & mlik, mpar, priran, mcalg, plevel) use outstream use interrupt use alleles_class use mcmc_model use covariate_data use rngs use smooths implicit none ! ! linkf=link function 1=identity 2=logit 3=probit 4=MFT 5=log ! modtyp=likelihood 1=gaussian 2=binomial 3=poisson 4=weibull ! offset=address of offset variable ! censor=address of the right censoring (binary) variable ! nchain=number of random effects chains (actually copies per family) ! nvar=number of named variables (covariates and trait) ! nfix=number of columns in design matrix ! nqtl=number of QTLs/major diallelic genes ! tune=fudge factor for parameter proposals, usually 0.3 ! integer, intent(in) :: linkf integer, intent(in) :: modtyp double precision, intent(in) :: shap integer, intent(in) :: trait integer, intent(in) :: gt double precision, intent(in) :: thresh integer, intent(in) :: offset integer, intent(in) :: censor integer, intent(in) :: nvar integer, dimension(:), intent(inout) :: fixed integer, intent(in) :: gene integer, intent(in) :: genemod type (allele_data) :: allele_buffer integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos integer, intent(in) :: burnin integer, intent(in) :: iter integer, intent(in) :: nbatch integer, intent(in) :: nsamples double precision, intent(in) :: tune integer, intent(in) :: nchain integer, intent(in) :: nqtl ! ! type (ped_data), intent(inout) :: dataset double precision, intent(out) :: mlik integer, intent(out) :: mpar integer, intent(in) :: priran integer, intent(in) :: mcalg integer, intent(in) :: plevel ! ! QTL model type (allele_data) :: qtl_buffer ! and proposal type (allele_data) :: prop_buffer ! ! model pars 1=P(all) 2=a 3=d 4=AA 5=AB 6=BB ! 7=mu 8=totvar 9=VA 10=VD 11=VG 12=VC 13=VS 14=VE ! 15=sdG 16=sdC 17=sdS 18=sdE ! 19=a2 20=d2 21=h2 22=c2 23=s2 24=e2 ! 25..MAXPAR=Betas ! a and d are Falconer style except d is proportion of a so ! VA = 2pq(a+(p-q)(ad))^2 ! VD = 4(pq(ad))^2 ! ! levels of covariates ! incl fixed effects and their observed means (for imputation) type (variable_data) :: covariates ! observed and imputed data type (mixed_data), dimension(:), pointer :: families ! list of useful pedigrees integer, dimension(dataset%nped) :: usedfams ! ! model loglikelihood and summaries ! keep nthin equally spaced realizations of LL as well as a grand mean ! thinsamp=max(1, 10*iter/nsamples), so nthin (<=nsamples) samples from run ! integer :: nthin, thinit, thinsamp double precision, dimension(:), allocatable :: batlik double precision :: estlik, lik, newlik, cvlik ! ! batch intercorrelations etc ! store this and previous batch to calculate order-1 autocorr ! batchit indicates which observation up to in this batch (1..sampit) ! sampit=max(1, 10*iter/nbatch), so nbatch batches per run ! curbat is current batch ! proprate is acceptance rate for proposals ! integer :: batchit, bpar, curbat, sampit ! ! Offset and censoring variables for fixed effect model are in locus() ! after the fixed effects ! integer :: cpos, nextra, opos ! Target variable to save BLUPs or genotypes integer :: saveas ! ! other local variables ! maxit=10*(iter+burnin), ! ncens=number of censored observations ! nprops=no. of proposal types, npar=no. of parameters in model ! nsubit=number of times genotype sampler run per family ! set to tot*max(1,nqtl)/nfam ! oobounds=proposal outside bounds ! pos=current cursor pos ! ncol=nfix+2 (for offset and censoring indicator) ! anyran=any random effects ! bsign=reverse sign of coefficients (eg Weibull as Poisson) ! enull=null hypothesis value for parameter (usually 0) ! likcor=1/nchains (likelihood correction for data replication) ! lmax, rmax=no. of slice expansion iterations to left and right ! integer :: anyran, bsign, gene1, gene2, i, ichain, ii, it, j, k, maxit, & maxsiz, ncens, ncol, ncomp, nmz, nobs, npar, nprops, nships, & nsubit, nvals, oobounds, pos, tailp, tot, totobs, tpos, typ, & whichblup integer :: cfa, cmo, ctwin, fam, nfam, nfix, num, ped, pedoffset integer :: it1, it2, ticks double precision :: den, enull, likcor, pcens, sd, val ! ! adjust=1.0 when binomial so trait scores as 0,1 double precision :: adjust ! ! baslik=offset for the likelihoods to be averaged etc; ! ncomp=number of random effects per person; ! hival=upper bound for pars (binomial v. continuous models); nullik=lik ! for null model proposal; pval=empirical p for null; ymean, yvar=sample ! grand mean and variance. ! double precision :: baslik, totfrq, hival, pval, ymean, yvar, zstat ! ! empfrq=realized QTL1 allele freq in pedigrees; ! empmu, empvar=realized pA,VA,VC,VS,VE,V(A+C+S+E)/VE in pedigrees ! double precision :: empfrq, empvar(6), empmu(6), empve, empvef double precision :: parmode logical :: last, mkstart character (len=1) :: ch character (len=20) :: slin ! functions double precision :: isaff, logit interface subroutine preseg(nvar, fixed, loc, loctyp, gene, allele_buffer, covariates) use AS164_class use alleles_class use covariate_data use mcmc_model integer, intent(in) :: nvar integer, dimension(:), intent(in) :: fixed character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, intent(in) :: gene type (allele_data) :: allele_buffer type (variable_data) :: covariates end subroutine preseg subroutine segerr(ped, dataset, rsd) use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(inout) :: dataset double precision, dimension(:), intent(out) :: rsd end subroutine segerr subroutine simped(ped, dataset, allele_buffer, set) use alleles_class use ped_class integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data), intent(in) :: allele_buffer integer, dimension(:,:), intent(out) :: set end subroutine simped subroutine set2hap(ichain, iqtl, num, set, hset, typ) integer, intent(in) :: ichain, iqtl integer, intent(in) :: num integer, dimension(:,:), intent(inout) :: set integer, dimension(:,:,:,:), intent(inout) :: hset integer, intent(in) :: typ end subroutine set2hap subroutine initvc(nchain, nfam, families) use mcmc_model integer, intent(in) :: nchain integer, intent(in) :: nfam type (mixed_data), dimension(:), pointer :: families end subroutine initvc subroutine updateblups(whichblup, nvals, nchain, nfam, families) use mcmc_model integer, intent(in) :: whichblup integer, intent(in) :: nvals integer, intent(in) :: nchain integer, intent(in) :: nfam type (mixed_data), dimension(:), pointer :: families end subroutine updateblups subroutine oneprop(it, typ, mcalg, linkf, modtyp, nchain, nqtl, nfix, ncol, totobs, & nprops, ncomp, tune, yvar, qtl_buffer, prop_buffer, & nfam, families, dataset, & empmu, empvar, lik, newlik, plevel) use alleles_class use mcmc_model use ped_class implicit none integer, intent(in) :: it integer, intent(inout) :: typ integer, intent(in) :: mcalg integer, intent(in) :: linkf integer, intent(in) :: modtyp integer, intent(in) :: nchain integer, intent(in) :: nqtl integer, intent(in) :: nfix integer, intent(in) :: ncol integer, intent(in) :: totobs integer, intent(in) :: nprops integer, intent(in) :: ncomp double precision, intent(in) :: tune double precision, intent(in) :: yvar type (allele_data) :: qtl_buffer, prop_buffer integer, intent(in) :: nfam type (mixed_data), dimension(:), pointer :: families type (ped_data), intent(inout) :: dataset double precision, intent(out) :: empmu(6) double precision, intent(out) :: empvar(6) double precision, intent(in) :: lik double precision, intent(out) :: newlik integer, intent(in) :: plevel end subroutine oneprop subroutine pedlik(linkf, modtyp, nchain, nqtl, nfix, ncol, & qtl_buffer, nfam, families, dataset, lik, oobounds, plevel) use alleles_class use mcmc_model use ped_class implicit none integer, intent(in) :: linkf integer, intent(in) :: modtyp integer, intent(in) :: nchain integer, intent(in) :: nqtl integer, intent(in) :: nfix integer, intent(in) :: ncol type (allele_data) :: qtl_buffer integer, intent(in) :: nfam type (mixed_data), dimension(:), pointer :: families type (ped_data), intent(in) :: dataset double precision, intent(out) :: lik integer, intent(inout) :: oobounds integer, intent(in) :: plevel end subroutine pedlik subroutine autocorr(typ, nobs, nvars, x, cor) integer, intent(in) :: typ integer, intent(in) :: nobs, nvars double precision, dimension(:,:), intent(in) :: x double precision, dimension(:), intent(out) :: cor end subroutine autocorr subroutine dobatch(nbatch, nvar, batch, batchse) integer, intent(in) :: nbatch, nvar double precision, dimension(:,:), intent(in) :: batch double precision, dimension(:), intent(out) :: batchse end subroutine dobatch subroutine traceplot(fil, nobs, nmult, yvals) use outstream use grapheps implicit none character (len=*), intent(in) :: fil integer, intent(in) :: nobs, nmult double precision, dimension(:), intent(inout) :: yvals end subroutine traceplot end interface ! write(outstr,'(/a/3a/a)') & '------------------------------------------------', & 'Finite Polygenic Model analysis for "', trim(loc(trait)), '"', & '------------------------------------------------' ! ! covariate levels and means call varlevels(ALL_OBS, gene, allele_buffer%numal, nvar, fixed, & loc, loctyp, locpos, dataset, covariates, plevel) call xmeans(nvar, fixed, nloci, loctyp, locpos, dataset, covariates) call preseg(nvar, fixed, loc, loctyp, gene, allele_buffer, covariates) nfix=covariates%totvars if (gene > 0) nfix=nfix+allele_buffer%numal-2 npar=RANPAR+nfix ! extra parameters eg shape of multiparameter density if (modtyp == GLM_WEIB .or. modtyp == GLM_GAMMA) then npar=npar+1 parnam(npar)='log Shape' paract(npar)=P_FREE end if ! variance components estimated from distribution of individuals' random effects bpar=npar+1 parnam(bpar)='Realized pA' paract(bpar)=P_EXCL if (paract(PTYP_pa) > 0) paract(bpar)=4 bpar=bpar+1 parnam(bpar)='Realized VG' paract(bpar)=P_EXCL if (paract(PTYP_VG) > 0 .or. par(PTYP_h2) > 0) paract(bpar)=4 bpar=bpar+1 parnam(bpar)='Realized VC' paract(bpar)=P_EXCL if (paract(PTYP_VC) > 0 .or. par(PTYP_c2) > 0) paract(bpar)=4 bpar=bpar+1 parnam(bpar)='Realized VS' paract(bpar)=P_EXCL if (paract(PTYP_VS) > 0 .or. par(PTYP_s2) > 0) paract(bpar)=4 bpar=bpar+1 parnam(bpar)='Realized VE' paract(bpar)=4 bpar=bpar+1 parnam(bpar)='VE(F+R)/VE(F)' paract(bpar)=4 allocate(batch(bpar, nbatch+1)) allocate(batlik(max(nbatch+1,nsamples+1))) ! ncol=nfix+2 cpos=0 ncens=0 nextra=0 opos=0 if (offset /= MISS) then nextra=nextra+1 fixed(nvar+nextra)=offset opos=locpos(offset) end if if (censor /= MISS) then nextra=nextra+1 fixed(nvar+nextra)=censor cpos=locpos(censor) end if tpos=locpos(trait) ! ! Initial values and bounds for model parameters ! bsign=1 nterms=0 oobounds=0 ! hival=1.0D99 adjust=0.0D0 if (loctyp(trait) == LOC_AFF .or. thresh /= MISS) adjust=1.0D0 if (modtyp == GLM_BINOM .and. (linkf == LINK_ID .or. linkf == LINK_MFT)) then hival=0.99999D0 end if do i=1, npar if (paract(i) == P_FREE) then nterms=nterms+1 terms(nterms)=i end if proprate(i)=0 proptyp(i)=0 end do do i=1, bpar epar(i)=0.0D0 blpar(i)=0.00001D0 bupar(i)=hival sdpar(i)=0.0D0 batch(i,1:nbatch+1)=0.0D0 end do do i=1, nfix blpar(RANPAR+i)=-1.0D99 bupar(RANPAR+i)=1.0D99 end do ! tighter bounds (0-1) on heritabilities etc do i=PTYP_a2, PTYP_e2 bupar(i)=0.99999D0 end do blpar(PTYP_d)=-1.5D0 bupar(PTYP_d)=1.5D0 ! blpar(PTYP_mu)=-1.0D99 ! bounds adjustments if binomial likelihood if (modtyp == GLM_BINOM) then if (linkf == LINK_ID) blpar(PTYP_mu)=0.00001D0 bupar(PTYP_VT)=0.25D0 end if ! default QTL allele frequency of 0.5 if (par(PTYP_pa) == MISS) par(PTYP_pa)=0.5D0 blpar(PTYP_pa)=0.000001D0 bupar(PTYP_pa)=0.5D0 ! Weibull model parameters need to be reversed pcens=0.0d0 if (modtyp == GLM_WEIB) then bsign=-1 par(npar)=log(shap) parscal(npar)=0.05D0 blpar(npar)=0.000001D0 else if (modtyp == GLM_GAMMA) then par(npar)=log(shap) parscal(npar)=0.05D0 blpar(npar)=0.000001D0 end if ! tailp=0 baslik=0.0D0 empfrq=0.0D0 estlik=0.0D0 likcor=1.0D0/dble(nchain) cvlik=0.0D0 totfrq=0.0D0 allocate(qtl_buffer%allele_names(2)) allocate(qtl_buffer%allele_freqs(2)) allocate(qtl_buffer%cum_freqs(2)) allocate(qtl_buffer%gtp_freqs(3)) qtl_buffer%allele_names(1)=1 qtl_buffer%allele_names(2)=2 call genfreq(par(PTYP_pa), qtl_buffer) allocate(prop_buffer%allele_names(2)) allocate(prop_buffer%allele_freqs(2)) allocate(prop_buffer%cum_freqs(2)) allocate(prop_buffer%gtp_freqs(3)) prop_buffer%allele_names(1)=1 prop_buffer%allele_names(2)=2 call genfreq(0.5d0, prop_buffer) gprop=0 grate=0 ! maxsiz=0 nfam=0 nmz=0 nships=0 lik=0.0D0 ymean=0.0D0 yvar=0.0D0 mlik=0.0d0 mpar=0 totobs=0 ! count of useful pedigrees ! do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset nobs=0 cfa=MISS cmo=MISS ctwin=MISS do i=pedoffset+1, dataset%num(ped) if (complete(.false., i, nvar+nextra, fixed, locpos, loctyp, dataset)) then nobs=nobs+1 totobs=totobs+1 if (num > dataset%nfound(ped)) then if (dataset%fa(i) /= cfa .and. dataset%mo(i) /= cmo) then cfa=dataset%fa(i) cmo=dataset%mo(i) nships=nships+1 end if if (dataset%imztwin(i) /= MISS) then if (dataset%imztwin(i) /= ctwin) then nmz=nmz+1 ctwin=dataset%imztwin(i) end if end if end if end if end do if (nobs > 0) then if (modtyp == GLM_POISS .or. modtyp == GLM_WEIB .or. modtyp == GLM_GAMMA) then do i=pedoffset+1, dataset%num(ped) val=dataset%plocus(i,tpos) if (val /= MISS .and. val < 0.0d0) then write(outstr, '(7a)', advance='no') & 'ERROR: Model type is "', trim(densid(modtyp)), & '" but trait value for ', trim(dataset%pedigree(ped)), '--', & trim(dataset%id(i)), ' = ' write(outstr,*) val return end if end do end if nfam=nfam+1 usedfams(nfam)=ped maxsiz=max(maxsiz, num) end if end if end do ! copy data across to mixed_data structures call setup_props(maxsiz) allocate(families(nfam)) totobs=0 do fam=1, nfam ped=usedfams(fam) pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset call setup_mix(ped, dataset, nchain, nqtl, ncol, families(fam)) ii=pedoffset do i=1, num ii=ii+1 val=MISS if (dataset%plocus(ii,tpos) /= MISS) then totobs=totobs+1 if (thresh /= MISS) then val=isaff(dataset%plocus(ii,tpos),thresh,gt)-adjust else if (dataset%plocus(ii,tpos) /= MISS) then val=dataset%plocus(ii,tpos)-adjust end if call moment(totobs, val, ymean, yvar) end if families(fam)%yval(i)=val ! everyone needs fixed effects -- impute missing values call fixeff(ii, i, 0, gene, genemod, allele_buffer, .false., & nvar, fixed, & nloci, loctyp, locpos, covariates, & dataset, families(fam)%vals, 1) ! fixed effects model offset families(fam)%vals(i, ncol-1)=0.0D0 if (opos > 0) then if (dataset%plocus(ii, opos) /= MISS) then families(fam)%vals(i, ncol-1)=dataset%plocus(ii, opos) end if end if ! censoring variable families(fam)%vals(i, ncol)=MISS if (families(fam)%yval(i) /= MISS) then families(fam)%vals(i, ncol)=1.0D0 end if if (cpos > 0) then if (dataset%plocus(ii,cpos) /= MISS) then families(fam)%vals(i, ncol)=dataset%plocus(ii,cpos)-1.0D0 if (dataset%plocus(ii,cpos) == 1.0d0) then ncens=ncens+1 end if end if end if end do call segerr(ped, dataset, families(fam)%rsd) do j=1, nchain do k=1, nqtl call simped(ped, dataset, qtl_buffer, set) call set2hap(j, k, num, set, families(fam)%hset, 1) end do end do end do yvar=yvar/dble(totobs) ! ! number of random effects per individual ! Variance may be fixed ! anyran=0 whichblup=0 ncomp=nqtl do i=PTYP_VG, PTYP_VS if (paract(i) == P_FREE .or. paract(10+i) == P_FREE .or. & paract(i) == P_FIX .or. paract(10+i) == P_FIX) then ncomp=ncomp+1 whichblup=i end if end do if (ncomp > 0) then anyran=1 if (whichblup == 0) whichblup=nqtl end if ! sampling fraction for batches and thinned samples sampit=max(1, 1+10*iter/nbatch) thinsamp=max(1, 1+10*iter/nsamples) ! ! Summarize model to be fitted ! if (nfam > 0) then write(outstr,'(7(/a,i7))') & 'Number of families = ', nfam, & 'Number of sibships = ', nships, & 'Number of MZ twinships = ', nmz, & 'Number of observations = ', totobs, & 'Burn-in MCMC iterations = ', 10*burnin, & 'Evaluated MCMC iterations = ', 10*iter, & 'Number of MCMC chains = ', nchain if (mcalg == 1) then write(outstr,'(a)') 'Metropolis sampler = Sliced' else write(outstr,'(a)') 'Metropolis sampler = Ordinary' end if write(outstr,'(2a/2a)') & 'Model type = ', densid(modtyp), & 'Link type = ', linkid(linkf) if (censor /= MISS) then write(outstr,'(2a)') & 'Censoring indicator = ', loc(censor) end if write(outstr,'(3a,$)') & 'Fixed Effects = ', trim(loc(trait)), ' ~ mu' pos=34+len_trim(loc(trait)) do j=1, nvar-1 write(outstr,'(2a,$)') ' + ', trim(loc(fixed(j))) pos=pos+3+len_trim(loc(fixed(j))) if (terms(j) == gene) then write(outstr,'(a,$)') '(M)' pos=pos+3 end if if (pos > 80) then pos=35 write(outstr,'(/30x,a,$)') ' ' end if end do if (offset /= MISS) then write(outstr,'(/2a)') 'Offset (for intercept) = ', loc(offset) end if write(outstr,'(/a,$)') 'Random Effects =' do j=PTYP_VA, PTYP_VE if (paract(j) /= P_EXCL) then write(outstr,'(2a,$)') ' ', trim(parnam(j)) end if end do write(outstr,'(/2(/a,f12.6))') & 'Global trait mean = ', ymean, & 'Global trait variance = ', yvar if (censor /= MISS) then pcens=dble(ncens)/dble(max(1,totobs)) write(outstr,'(a,f10.4)') & 'Proportion censored obs. = ', pcens end if else write(outstr,'(/a)') 'No eligible families!' return end if ! ! Two alternate samplers: one genotypic, updates family by family ! the other, variance components, updates whole dataset ! ! Generate starting values and proposal stepsizes parscal(PTYP_pa)=0.25D0 ! Total mean and variance if (par(PTYP_mu) == MISS) then par(PTYP_mu)=ymean if (modtyp == GLM_BINOM .and. linkf /= LINK_ID) then par(PTYP_mu)=logit(ymean) else if ((modtyp == GLM_POISS .and. linkf == LINK_LOG) .or. & modtyp == GLM_WEIB .or. modtyp == GLM_GAMMA) then par(PTYP_mu)=log(ymean) end if end if ! This set by preseg() if covariates if (nfix == 0) then if (modtyp == GLM_GAUSS) then parscal(PTYP_mu)=sqrt(yvar/dble(totobs)) else if (modtyp == GLM_BINOM) then parscal(PTYP_mu)=0.05D0 else parscal(PTYP_mu)=sqrt(par(PTYP_mu)/dble(totobs)) end if end if if (par(PTYP_VT) == MISS) then par(PTYP_VT)=yvar if (linkf == 4) then par(PTYP_VT)=1.0D0 end if end if parscal(PTYP_VT)=tune*yvar if (modtyp /= GLM_GAUSS) parscal(PTYP_VT)=tune ! ! Qtl -- reintroduced 20090729 (a2 lost sign info) ! if (par(PTYP_a) == MISS) then if (paract(PTYP_a) == 1) then par(PTYP_a)=0.1d0*sqrt(yvar) else par(PTYP_a)=0.0d0 end if end if if (par(PTYP_d) == MISS) then par(PTYP_d)=0.0d0 end if parscal(PTYP_a)=tune*sqrt(yvar) parscal(PTYP_d)=tune do j=PTYP_VA, PTYP_VE if (par(j) == MISS) then if (paract(j) == P_FREE) then par(j)=0.5D0 else par(j)=0.0D0 end if end if parscal(j)=sqrt(parscal(PTYP_VT)) end do ! ! These give stepsize for random effects proposals: VG, VC, VS ! do j=PTYP_sdG, PTYP_sdE parscal(j)=sqrt(parscal(j-4)) end do ! do j=PTYP_a2, PTYP_s2 if (par(j) == MISS) then if (paract(j) == P_FREE) then par(j)=0.1D0 else par(j)=0.0D0 end if end if parscal(j)=sqrt(tune/6) end do call qtlmod(linkf, modtyp, nqtl, qtl_buffer) ! ! Need starting values for additive polygenic a/o sibship random ! effects? mkstart=(paract(PTYP_VG) == P_FREE .or. paract(PTYP_h2) == P_FREE .or. & paract(PTYP_VG) == P_FIX .or. paract(PTYP_h2) == P_FIX .or. & paract(PTYP_VS) == P_FREE .or. paract(PTYP_s2) == P_FREE .or. & paract(PTYP_VS) == P_FIX .or. paract(PTYP_s2) == P_FIX) ! Likelihood at starting values lik=0.0D0 if (mkstart) then call initvc(nchain, nfam, families) end if ! ! Main loop - either propose and test a parameter tweak or a ! new set of QTL genotypes ! start with a genotype proposal (typ=nterms+1) ! if (plevel > 0) then write(outstr,'(/a/a)') & ' Parameter Start Value Proposal SD Bounds', & '-------------- ----------- ----------- --------------------' do i=1, nterms write(outstr,'(a, 2(1x,f12.6),2(1x,d10.4))') & parnam(terms(i)), par(terms(i)), parscal(terms(i)), & blpar(terms(i)), bupar(terms(i)) end do do i=1, npar if (paract(i) == 2) then write(outstr,'(a,1x,f12.6,8x,a)') & parnam(i), par(i), 'Fixed' end if end do write(outstr,'(/a/a)') & ' Covariate Mean Value', & '-------------- ----------' do i=1, nfix write(outstr,'(a, 1x,f12.6)') parnam(RANPAR+i), covariates%means(i) end do end if call pedlik(linkf, modtyp, nchain, nqtl, nfix, ncol, & qtl_buffer, nfam, families, dataset, lik, oobounds, plevel) if (plevel > 0) then write(outstr,'(/a,g13.6)') 'LogLik at starting values = ', lik write(outstr,'(/a,20(1x,a3):)') & 'MCMCPAR it lik prop', (parnam(terms(i))(1:5), i=1, nterms) write(outstr,'(a)') & 'MCMCEMP it lik pA VA VC VS VE VarRat' end if ! ! burn-in/warm-up ! it=0 irupt=0 nprops=nterms+anyran typ=nterms+1 maxit=10*burnin call system_clock(it1) do while (it < maxit .and. irupt == 0) it=it+1 call oneprop(it, typ, mcalg, linkf, modtyp, nchain, nqtl, nfix, ncol, totobs, & nprops, ncomp, tune, yvar, qtl_buffer, prop_buffer, & nfam, families, dataset, & empmu, empvar, lik, newlik, plevel) lik=newlik typ=irandom(1, nprops) end do if (plevel > -1) then call system_clock(it2, count_rate=ticks) write(slin, '(f20.2)') float(it2-it1)/float(ticks) slin=adjustl(slin) write(outstr,'(/a,i0,3a/)') & 'Completed ', it, ' burn-in iterations (', trim(slin), ' s)' end if ! ! utilised simulations ! it=0 batchit=0 curbat=1 irupt=0 thinit=0 nthin=0 nvals=0 maxit=10*iter baslik=likcor*dble(int(lik)) ! scale factor for stored likelihood do while (it < maxit .and. irupt == 0) it=it+1 typ=irandom(1, nprops) call oneprop(it, typ, mcalg, linkf, modtyp, nchain, nqtl, nfix, ncol, totobs, & nprops, ncomp, tune, yvar, qtl_buffer, prop_buffer, & nfam, families, dataset, & empmu, empvar, lik, newlik, plevel) ! ! Sample from run following completion of burn-in ! Batch for standard errors ! do i=1, 3 batch(i,curbat)=batch(i,curbat)+par(i) call moment(it, par(i), epar(i), sdpar(i)) end do do i=7, npar batch(i,curbat)=batch(i,curbat)+par(i) call moment(it, par(i), epar(i), sdpar(i)) end do ! summarize genotypic means rather than genotypic deviations do i=PTYP_AA, PTYP_BB val=par(i)+par(PTYP_mu) batch(i,curbat)=batch(i,curbat)+val call moment(it, val, epar(i), sdpar(i)) end do ! summarize empirical random effect variances do i=npar+1, bpar batch(i,curbat)=batch(i,curbat)+empvar(i-npar) call moment(it, empvar(i-npar), epar(i), sdpar(i)) end do ! likelihood call moment(it, likcor*newlik-baslik, estlik, cvlik) ! ! batched or thinned values ! batchit=batchit+1 thinit=thinit+1 if (thinit == thinsamp) then thinit=0 nthin=nthin+1 batlik(nthin)=likcor*newlik end if if (batchit == sampit) then batchit=0 nvals=nvals+1 do i=1, bpar batch(i,curbat)=batch(i,curbat)/dble(sampit) end do curbat=curbat+1 ! accumulate BLUPs if (whichblup /= 0) then call updateblups(whichblup, nvals, nchain, nfam, families) end if ! print current iteration values of random effects if (priran == 1 .or. plevel > 3) then do k=1, nfam do j=1, nchain call wrfpm(it, linkf, modtyp, j, nqtl, nfix, families(k), dataset) end do end do end if end if ! Print parameter values for this iteration if (plevel > 0) then write(outstr,'(a,i7,1x,d14.8,1x,i2,(20(1x,g12.4)):)') & 'MCMCPAR ',it, newlik, typ, (par(terms(i)), i=1,nterms) write(outstr,'(a,i7,1x,d14.8,1x,f5.3,5(1x,g12.4))') & 'MCMCEMP ',it, newlik, (empvar(j), j=1,6) end if lik=newlik end do ! ! end of main MCMC loop ! ! model pars 1=P(all) 2=a 3=d 4=AA 5=AB 6=BB ! 7=mu 8=totvar 9=VA 10=VD 11=VG 12=VC 13=VS 14=VE ! 15=sdG 16=sdC 17=sdS 18=sdE ! 19=a2 20=d2 21=h2 22=c2 23=s2 24=e2 ! 25..MAXPAR=Betas ! ! lag-1 interbatch correlations ! call autocorr(1, nvals, bpar, batch, covbat1) if (it < maxit) then write(outstr,'(/a,i6,a/)') & 'NOTE: Due to user interruption, only ', it, & ' iterations actually carried out.' end if call dobatch(nvals, bpar, batch, batchse) estlik=estlik+baslik cvlik=sqrt(cvlik/dble(max(1, it-1))) cvlik=100.0D0*cvlik/abs(estlik) yvar=100.0D0 write(outstr,'(/a,i5)') 'Number of simulated QTLs = ', nqtl if (nqtl > 0) then write(outstr,'(a,f12.6)') 'QTL increasing allele freq = ', epar(PTYP_pa) end if write(outstr,'(/a,f12.6)') 'Intercept = ', bsign*epar(PTYP_mu) if (nqtl > 0) then write(outstr,'(a,f12.6,a,f5.1,a)') 'Additive QTL variance = ', & epar(PTYP_VA),' (',epar(PTYP_a2)*yvar,'%)' if (paract(PTYP_VD) /= 0) then write(outstr,'(a,f12.6,a,f5.1,a)') 'Dominance QTL variance = ', & epar(PTYP_VD),' (',epar(PTYP_d2)*yvar,'%)' end if end if if (paract(PTYP_VG) /= 0) then write(outstr,'(a,f12.6,a,f5.1,a)') 'Additive polygenic var = ', & epar(PTYP_VG),' (',epar(PTYP_h2)*yvar,'%)' end if if (paract(PTYP_VC) /= 0) then write(outstr,'(a,f12.6,a,f5.1,a)') 'Family environmental var = ', & epar(PTYP_VC),' (',epar(PTYP_c2)*yvar,'%)' end if if (paract(PTYP_VS) /= 0) then write(outstr,'(a,f12.6,a,f5.1,a)') 'Maternal effect variance = ', & epar(PTYP_VS),' (',epar(PTYP_s2)*yvar,'%)' end if if (paract(PTYP_VE) /= 0) then write(outstr,'(a,f12.6,a,f5.1,a)') 'Environmental variance = ', & epar(PTYP_VE),' (',epar(PTYP_e2)*yvar,'%)' end if if (modtyp == GLM_WEIB) then write(outstr,'(a,f9.3)') & 'Weibull shape parameter = ', exp(epar(RANPAR+nfix+1)) if (paract(PTYP_VG) /= 0 .and. pcens < 1.0d0) then write(outstr,'(a,f9.3)') 'Yazdi et al heritability = ', & epar(PTYP_VG)/(epar(PTYP_VG) + epar(PTYP_VC) + epar(PTYP_VS) + 1.0d0/(1.0d0-pcens)) end if else if (modtyp == GLM_GAMMA) then write(outstr,'(a,f9.3/a,f9.3)') & 'Gamma shape parameter = ', exp(epar(RANPAR+nfix+1)), & 'Gamma scale parameter = ', exp(epar(PTYP_mu)-(epar(RANPAR+nfix+1))) end if call traceplot('sp-mcmc.eps', nthin, thinsamp, batlik) call unidens(nthin, batlik, parmode, plevel-2) write(outstr,'(2(a,g13.6/),a,f8.2,a)') & 'Modal model loglikelihood = ', parmode, & 'Mean model loglikelihood = ', estlik, & 'C.V. Loglikelihood = ', cvlik, '%' ! write(outstr,'(/a,i5,a,i10,a//2a/2a)') & 'Summarized run as ', nvals, ' batches of size ', sampit,' :', & 'Parameter Mean Mode SD ', & ' Z-value MC-SE S', & '---------------- ---------- ---------- ----------', & ' ---------- -------- -' ! den=dble(nchain)/dble(max(1, it-1)) j=0 do i=1, bpar if (paract(i) /= 0) then bsign=1 enull=0.0D0 ! Reverse sign on Weibull parameters if (modtyp == GLM_WEIB) then if (i == PTYP_mu .or. (i > RANPAR .and. i <= (RANPAR+nfix))) then bsign=-1 end if end if ! change null for ratios and for genotypes if (index(parnam(i), '/') > 0) enull=1.0d0 if (i == PTYP_AA .or. i == PTYP_AB .or. i == PTYP_BB) then enull=par(PTYP_mu) end if ch=' ' if (paract(i) == P_FIX) ch='f' if (paract(i) == P_DERIV) ch='d' sd=sqrt(den*sdpar(i)) zstat=0.0D0 parmode=batch(i,1) if (paract(i) /= P_FIX .and. sd > 0.0d0) then zstat=abs(epar(i)-enull)/sd do j=1, nvals batlik(j)=batch(i, j) end do call unidens(nvals, batlik, parmode, plevel-2) end if if (epar(i) < 1.0d6) then write(outstr,'(a,4(1x,f12.4),1x,f10.4,1x,a1)') & parnam(i), bsign*epar(i), bsign*parmode, sd, zstat, & batchse(i), ch else write(outstr,'(a,4(1x,e12.4),1x,e10.4,1x,a1)') & parnam(i), bsign*epar(i), bsign*parmode, sd, zstat, & batchse(i), ch end if end if end do k=2 if (mcalg == 3) k=1 write(outstr,'(/a/a/a,i14,4x,f5.3,3a)') & 'Proposal N Accepted', & '------------ ------------- --------', & 'Genotype ', gprop, dble(grate)/dble(max(1,gprop)), ' (', algid(k), ')' k=mcalg if (mcalg == 3) k=1 do i=1, npar if (paract(i) == 1) then pval=dble(proprate(i))/dble(max(1,proptyp(i))) write(outstr,'(a,i12,4x,f5.3,3a)') & parnam(i), proptyp(i), pval, ' (', algid(k), ')' end if end do if (mcalg /= 3) then write(outstr,'(/a/7x,a/7x,a)') & 'NOTE: For ordinary Metropolis sampling (M), the proposal ', & 'acceptance rate is optimally 0.2-0.6. The slice ', & 'sampler (S) is more robust, but slower.' end if ! ! Show BLUPs if requested or not too onerous ! if ((whichblup /= 0 .and. totobs < 21) .or. priran == 1) then write(outstr,'(/a)') 'Pedigree Individual Observed BLUP' do k=1, nfam pedoffset=dataset%num(families(k)%iped-1) do i=1, families(k)%num write(outstr,'(a12,a12)', advance='no') & dataset%pedigree(families(k)%iped), & dataset%id(pedoffset+i) if (dataset%plocus(pedoffset+i,tpos) == MISS) then write(outstr,'(4x,a1,4x,f9.4)') 'x', families(k)%blup(i) else if (loctyp(trait) == LOC_AFF) then call wraff(dataset%plocus(pedoffset+i,tpos), ch, 1) write(outstr,'(4x,a1,4x,f9.4)') ch, families(k)%blup(i) else write(outstr,'(2f9.4)') & dataset%plocus(pedoffset+i,tpos), families(k)%blup(i) end if end do end do end if ! ! Save BLUPs or genotypes if requested ! if (priran < 0) then saveas=-priran gene1=locpos(saveas) if (loctyp(saveas) == LOC_QUA) then write(outstr,'(3a)') 'Saving BLUPs to "', trim(loc(saveas)), '".' do k=1, nfam ii=dataset%num(families(k)%iped-1) do i=1, families(k)%num ii=ii+1 dataset%plocus(ii,gene1)=families(k)%blup(i) end do end do else if (loctyp(saveas) == LOC_CODOM) then write(outstr,'(3a)') 'Saving QTL genotypes to "', trim(loc(saveas)), '".' gene2=gene1+1 do k=1, nfam ii=dataset%num(families(k)%iped-1) do i=1, families(k)%num ii=ii+1 call set_geno(ii, gene1, gene2, dataset, & families(k)%hset(i,1,1,1), families(k)%hset(i,1,1,2)) end do end do end if end if mpar=nterms mlik=-estlik-estlik call clean_props() deallocate(families) deallocate(batch) end subroutine segsim ! ! QTL genotypic log frequencies ! subroutine genfreq(pall, qtl_buffer) use alleles_class double precision, intent(in) :: pall type (allele_data) :: qtl_buffer qtl_buffer%allele_freqs(1)=pall qtl_buffer%allele_freqs(2)=1.0D0-pall qtl_buffer%cum_freqs(1)=pall qtl_buffer%cum_freqs(2)=1.0D0 qtl_buffer%gtp_freqs(1)=2*log(pall) qtl_buffer%gtp_freqs(2)=log(pall)+log(1.0D0-pall) qtl_buffer%gtp_freqs(3)=2*log(1.0D0-pall) end subroutine genfreq ! ! One iteration of the sampler: either parameters or random effects ! Give "empirical" estimates of random effects variances ! subroutine oneprop(it, typ, mcalg, linkf, modtyp, nchain, nqtl, nfix, ncol, totobs, & nprops, ncomp, tune, yvar, qtl_buffer, prop_buffer, & nfam, families, dataset, & empmu, empvar, lik, newlik, plevel) use outstream use alleles_class use mcmc_model use ped_class implicit none integer, intent(in) :: it integer, intent(inout) :: typ integer, intent(in) :: mcalg integer, intent(in) :: linkf integer, intent(in) :: modtyp integer, intent(in) :: nchain integer, intent(in) :: nqtl integer, intent(in) :: nfix integer, intent(in) :: ncol integer, intent(in) :: totobs integer, intent(in) :: nprops integer, intent(in) :: ncomp double precision, intent(in) :: tune double precision, intent(in) :: yvar type (allele_data) :: qtl_buffer, prop_buffer integer, intent(in) :: nfam type (mixed_data), dimension(:), pointer :: families type (ped_data), intent(inout) :: dataset double precision, intent(out) :: empmu(6) double precision, intent(out) :: empvar(6) double precision, intent(in) :: lik double precision, intent(out) :: newlik integer, intent(in) :: plevel ! integer :: ichain, j, k, nsubit interface subroutine slprop(iprop, linkf, modtyp, nchain, nqtl, nfix, ncol, & qtl_buffer, nfam, families, dataset, lik, newlik, plevel) use alleles_class use mcmc_model use ped_class integer, intent(in) :: iprop integer, intent(in) :: linkf integer, intent(in) :: modtyp integer, intent(in) :: nchain integer, intent(in) :: nqtl integer, intent(in) :: nfix integer, intent(in) :: ncol type (allele_data) :: qtl_buffer integer, intent(in) :: nfam type (mixed_data), dimension(:), pointer :: families type (ped_data), intent(in) :: dataset double precision, intent(in) :: lik double precision, intent(out) :: newlik integer, intent(in) :: plevel end subroutine slprop subroutine mhprop(iprop, linkf, modtyp, nchain, nqtl, nfix, ncol, & tune, yvar, qtl_buffer, nfam, families, dataset, & lik, newlik, plevel) use alleles_class use mcmc_model use ped_class implicit none integer, intent(in) :: iprop integer, intent(in) :: linkf integer, intent(in) :: modtyp integer, intent(in) :: nchain integer, intent(in) :: nqtl integer, intent(in) :: nfix integer, intent(in) :: ncol double precision, intent(in) :: tune double precision, intent(in) :: yvar type (allele_data) :: qtl_buffer integer, intent(in) :: nfam type (mixed_data), dimension(:), pointer :: families type (ped_data), intent(inout) :: dataset double precision, intent(in) :: lik double precision, intent(out) :: newlik integer, intent(in) :: plevel end subroutine mhprop subroutine empval(linkf, modtyp, nchain, nqtl, nfix, nfam, families, totobs, & empmu, empvar) use mcmc_model integer, intent(in) :: linkf integer, intent(in) :: modtyp integer, intent(in) :: nchain integer, intent(in) :: nqtl integer, intent(in) :: nfix integer, intent(in) :: nfam type (mixed_data), dimension(:), pointer :: families integer, intent(in) :: totobs double precision, intent(out) :: empmu(6) double precision, intent(out) :: empvar(6) end subroutine empval end interface newlik=0.0D0 ! update global parameter estimates via slice sampling if (typ <= nterms) then typ=terms(typ) if (mcalg == 1 .or. mcalg == 3) then call slprop(typ, linkf, modtyp, nchain, nqtl, nfix, ncol, & qtl_buffer, nfam, families, dataset, & lik, newlik, plevel) else call mhprop(typ, linkf, modtyp, nchain, nqtl, nfix, ncol, & tune, yvar, qtl_buffer, nfam, families, dataset, & lik, newlik, plevel) end if call empval(linkf, modtyp, nchain, nqtl, nfix, & nfam, families, totobs, empmu, empvar) else ! or update trait locus genotypes typ=0 do k=1, nfam ! ! minimize calls to oneseg between parameter trials ! nsubit=max(1, families(k)%num*ncomp) nsubit=max(1, ncomp) do j=1, nsubit do ichain=1, nchain call oneseg(it, linkf, modtyp, ichain, nqtl, nfix, qtl_buffer, & prop_buffer, families(k), dataset, mcalg, plevel) end do end do do ichain=1, nchain newlik=newlik+families(k)%famlik(ichain) end do end do call empval(linkf, modtyp, nchain, nqtl, nfix, & nfam, families, totobs, empmu, empvar) if (plevel > 1) then write(outstr,'(a,2(a,g12.5),a,f5.3, 4(a, f9.4))') & 'Shuffle genotypes',' lik=', newlik, ' (old=',lik, ') p(A)=', empvar(1), & ' VG=', empvar(2), ' VC=', empvar(3), ' VS=', empvar(4), ' VE=', empvar(5) end if end if end subroutine oneprop ! ! ! Metropolis sampler for global parameters ! subroutine mhprop(iprop, linkf, modtyp, nchain, nqtl, nfix, ncol, & tune, yvar, qtl_buffer, nfam, families, dataset, & lik, newlik, plevel) use outstream use alleles_class use mcmc_model use ped_class use rngs implicit none integer, intent(in) :: iprop integer, intent(in) :: linkf integer, intent(in) :: modtyp integer, intent(in) :: nchain integer, intent(in) :: nqtl integer, intent(in) :: nfix integer, intent(in) :: ncol double precision, intent(in) :: tune double precision, intent(in) :: yvar type (allele_data) :: qtl_buffer integer, intent(in) :: nfam type (mixed_data), dimension(:), pointer :: families type (ped_data), intent(inout) :: dataset double precision, intent(in) :: lik double precision, intent(out) :: newlik integer, intent(in) :: plevel ! local variables integer :: k, oobounds double precision :: origval ! Metropolis criterion variables double precision :: lr, qa ! functions interface subroutine pedlik(linkf, modtyp, nchain, nqtl, nfix, ncol, & qtl_buffer, nfam, families, dataset, lik, oobounds, plevel) use alleles_class use mcmc_model use ped_class implicit none integer, intent(in) :: linkf integer, intent(in) :: modtyp integer, intent(in) :: nchain integer, intent(in) :: nqtl integer, intent(in) :: nfix integer, intent(in) :: ncol type (allele_data) :: qtl_buffer integer, intent(in) :: nfam type (mixed_data), dimension(:), pointer :: families type (ped_data), intent(in) :: dataset double precision, intent(out) :: lik integer, intent(inout) :: oobounds integer, intent(in) :: plevel end subroutine pedlik end interface ! oobounds=0 origval=par(iprop) proptyp(iprop)=proptyp(iprop)+1 call parprop(iprop, tune, yvar, oobounds) call pedlik(linkf, modtyp, nchain, nqtl, nfix, ncol, & qtl_buffer, nfam, families, dataset, newlik, oobounds, plevel) if (oobounds == 0) then lr=newlik-lik qa=min(1.0D0,exp(lr)) else qa=0.0D0 end if ! ! If accepted, update variance components and family likelihoods ! if (qa > random()) then if (plevel > 1) then write(outstr,'(a,2(a,1x,f9.4),2(a,g12.5),a)') & 'Propose ',parnam(iprop), origval,'->', par(iprop), & ' lik=', newlik, ' (old=',lik,') accepted ' end if proprate(iprop)=proprate(iprop)+1 else if (plevel > 1) then write(outstr,'(a,2(a,1x,f9.4),2(a,g12.5),a)') & 'Propose ',parnam(iprop), origval,'->', par(iprop), & ' lik=', newlik, ' (old=',lik,') rejected ' end if par(iprop)=origval call qtlmod(linkf, modtyp, nqtl, qtl_buffer) newlik=lik end if end subroutine mhprop ! end-of-mhprop ! ! Slice sampler for global parameters ! subroutine slprop(iprop, linkf, modtyp, nchain, nqtl, nfix, ncol, & qtl_buffer, nfam, families, dataset, lik, newlik, plevel) use outstream use alleles_class use mcmc_model use ped_class use rngs implicit none integer, intent(in) :: iprop integer, intent(in) :: linkf integer, intent(in) :: modtyp integer, intent(in) :: nchain integer, intent(in) :: nqtl integer, intent(in) :: nfix integer, intent(in) :: ncol type (allele_data) :: qtl_buffer integer, intent(in) :: nfam type (mixed_data), dimension(:), pointer :: families type (ped_data), intent(in) :: dataset double precision, intent(in) :: lik double precision, intent(out) :: newlik integer, intent(in) :: plevel ! local variables integer :: it, lmax, oobounds, rmax ! slice sampler for global parameters double precision :: ltlik, ltval, origval, rtlik, rtval, slicelik ! functions interface subroutine pedlik(linkf, modtyp, nchain, nqtl, nfix, ncol, & qtl_buffer, nfam, families, dataset, lik, oobounds, plevel) use alleles_class use mcmc_model use ped_class implicit none integer, intent(in) :: linkf integer, intent(in) :: modtyp integer, intent(in) :: nchain integer, intent(in) :: nqtl integer, intent(in) :: nfix integer, intent(in) :: ncol type (allele_data) :: qtl_buffer integer, intent(in) :: nfam type (mixed_data), dimension(:), pointer :: families type (ped_data), intent(in) :: dataset double precision, intent(out) :: lik integer, intent(inout) :: oobounds integer, intent(in) :: plevel end subroutine pedlik end interface ! oobounds=0 origval=par(iprop) ! always a success, but multiple function evaluations proprate(iprop)=proprate(iprop)+1 proptyp(iprop)=proptyp(iprop)+2 slicelik=log(dble(random()))+lik ! while loops expanding the slice lmax=irandom(1, slmax) rmax=slmax-lmax ! left extent of slice ltval=par(iprop)-dble(random())*parscal(iprop) if (ltval < blpar(iprop)) then ltval=blpar(iprop) lmax=0 end if par(iprop)=ltval call parbounds(iprop, oobounds) call pedlik(linkf, modtyp, nchain, nqtl, nfix, ncol, & qtl_buffer, nfam, families, dataset, ltlik, oobounds, plevel) do while (lmax > 0 .and. ltlik > slicelik) ltval=ltval-parscal(iprop) if (ltval < blpar(iprop)) then ltval=blpar(iprop) lmax=0 end if par(iprop)=ltval call parbounds(iprop, oobounds) call pedlik(linkf, modtyp, nchain, nqtl, nfix, ncol, & qtl_buffer, nfam, families, dataset, ltlik, oobounds, plevel) proptyp(iprop)=proptyp(iprop)+1 lmax=lmax-1 end do ! right extent of slice rtval=ltval+parscal(iprop) if (rtval > bupar(iprop)) then rtval=bupar(iprop) rmax=0 end if par(iprop)=rtval call parbounds(iprop, oobounds) call pedlik(linkf, modtyp, nchain, nqtl, nfix, ncol, & qtl_buffer, nfam, families, dataset, rtlik, oobounds, plevel) do while (rmax > 0 .and. rtlik > slicelik) rtval=rtval+parscal(iprop) if (rtval > bupar(iprop)) then rtval=bupar(iprop) rmax=0 end if par(iprop)=rtval call parbounds(iprop, oobounds) call pedlik(linkf, modtyp, nchain, nqtl, nfix, ncol, & qtl_buffer, nfam, families, dataset, rtlik, oobounds, plevel) proptyp(iprop)=proptyp(iprop)+1 rmax=rmax-1 end do ! sample within slice, shrinking if unsuccessful it=0 do it=it+1 proptyp(iprop)=proptyp(iprop)+1 par(iprop)=ltval+dble(random())*(rtval-ltval) call parbounds(iprop, oobounds) call pedlik(linkf, modtyp, nchain, nqtl, nfix, ncol, & qtl_buffer, nfam, families, dataset, newlik, oobounds, plevel) if (newlik > slicelik .or. it > (10*slmax)) exit if (par(iprop) < origval) then ltval=par(iprop) ltlik=newlik else rtval=par(iprop) rtlik=newlik end if end do if (plevel > 1) then write(outstr,'(a,2(a,1x,f9.4),2(a,g12.5),a)') & 'Propose ',parnam(iprop), origval,'->', par(iprop), & ' lik=', newlik, ' (old=',lik,') accepted ' end if end subroutine slprop ! end-of-slprop ! ! Make a proposal for one QTL model parameter for Metropolis sampler ! oobounds!=0 when proposal is illegal ! subroutine parprop(typ, tune, yvar, oobounds) use mcmc_model use rngs implicit none integer, intent(in) :: typ double precision, intent(in) :: tune double precision, intent(in) :: yvar integer, intent(inout) :: oobounds if (typ == 7) then ! mu proposal par(PTYP_mu)=par(PTYP_mu)+1.5D0*dble(randn())*parscal(typ) else if (typ == 8) then ! vt proposal par(PTYP_VT)=par(PTYP_VT)+dble(tune*rantri())*yvar else if (typ == 1 .or. (typ >= 19 .and. typ <= 23)) then ! p or proportion of variance due to random effect call triprop(tune, par(typ)) else if (typ <= RANPAR) then par(typ)=par(typ)+dble(tune*randn())*parscal(typ) else if (typ > RANPAR) then ! fixed effect par(typ)=par(typ)+7.0D0*dble(tune*randn())*parscal(typ) end if ! bounds check call parbounds(typ, oobounds) end subroutine parprop ! end-of-parprop ! ! Check Metropolis proposal ! oobounds!=0 when proposal is illegal ! subroutine parbounds(typ, oobounds) use mcmc_model implicit none integer, intent(in) :: typ integer, intent(out) :: oobounds oobounds=0 if (par(typ) < blpar(typ)) then oobounds=oobounds+1 else if (par(typ) > bupar(typ)) then oobounds=oobounds+2 else if ((par(PTYP_a2)+par(PTYP_d2)+par(PTYP_h2)+par(PTYP_c2)+par(PTYP_s2)) > 1.0D0) then oobounds=oobounds+4 end if ! if (oobounds > 0) then ! write(*,*) 'Bounds: ', oobounds, ' ', trim(parnam(typ)), ' = ', par(typ), & ! ' Var: a2=', par(PTYP_a2), ' d2=', par(PTYP_d2), ' h2=', par(PTYP_h2), & ! ' c2=', par(PTYP_c2), ' s2=', par(PTYP_s2) ! write(*,*) ' Var: VA=', par(PTYP_VA), ' VD=', par(PTYP_VD), ' VG=', par(PTYP_VG), & ! ' VC=', par(PTYP_VC), ' VS=', par(PTYP_VS) ! write(*,*) 'pA=', par(PTYP_pa), ' AA=', par(PTYP_AA), ' AB=', par(PTYP_AB), ' BB=', par(PTYP_BB) ! end if end subroutine parbounds ! end-of-parbounds ! ! QTL allelic deviations, allele and genotype frequencies ! For identity link models, use ! pA, mu, totvar, a2, d2, h2, c2 to calculate all other parameters ! For other GLMs, use ! VA etc ! model pars 1=P(all) 2=a 3=d 4=AA 5=AB 6=BB ! 7=mu 8=totvar 9=VA 10=VD 11=VG 12=VC 13=VS 14=VE ! 15=sdG 16=sdC 17=sdS 18=sdE ! 19=a2 20=d2 21=h2 22=c2 23=s2 24=e2 ! 25..MAXPAR=Betas ! subroutine qtlmod(linkf, modtyp, nqtl, qtl_buffer) use alleles_class use mcmc_model use statfuns integer, intent(in) :: linkf integer, intent(in) :: modtyp integer, intent(in) :: nqtl type (allele_data) :: qtl_buffer ! double precision, parameter :: pi23 = 3.2898681337d0, pi26 = 1.6449340668d0 integer :: i, firstvar double precision :: falcd, mu, pq, q, revar, var ! functions ! ppnd double precision :: alogit ! firstvar=11 mu=par(PTYP_mu) var=par(PTYP_VT) ! SML: a d if (nqtl > 0) then firstvar=9 q=1.0D0-par(PTYP_pa) pq=par(PTYP_pa)*q falcd=par(PTYP_a)*par(PTYP_d) call genfreq(par(PTYP_pa), qtl_buffer) par(PTYP_AA)=2*q*(par(PTYP_a)-par(PTYP_pa)*falcd) par(PTYP_AB)=par(PTYP_AA)-par(PTYP_a)+falcd par(PTYP_BB)=par(PTYP_AA)-par(PTYP_a)-par(PTYP_a) par(PTYP_VA)=2*nqtl*pq*(par(PTYP_a)+(q-par(PTYP_pa))*falcd)**2 par(PTYP_VD)=4*nqtl*pq*pq*falcd*falcd end if ! VC: (a2 d2) h2 c2 s2 revar=0.0d0 do i=firstvar, 13 revar=revar+par(i) end do do i=firstvar, 13 if (paract(10+i) == 1 .or. paract(10+i) == 2) then par(i)=par(10+i)*var else if (paract(10+i) == 3) then if (modtyp == GLM_BINOM) then if (linkf == LINK_LOGIT) then par(10+i)=par(i)/(revar + pi23) else if (linkf == LINK_PROBIT) then par(10+i)=par(i)/(revar + 1.0d0) else if (linkf == LINK_MFT) then par(10+i)=par(i) end if else if (modtyp == GLM_WEIB) then par(10+i)=par(i)/(revar + pi26) else par(10+i)=par(i)/var end if end if end do ! SDs do i=11, 13 if (par(i) > 0.0D0) then par(i+4)=sqrt(par(i)) else par(i+4)=1.0d-9 end if end do ! e2 par(PTYP_e2)=1.0d0-par(PTYP_a2)-par(PTYP_d2)-par(PTYP_h2)-par(PTYP_c2)-par(PTYP_s2) if (modtyp == GLM_GAUSS) then par(PTYP_VE)=par(PTYP_e2)*var else if (modtyp == GLM_BINOM) then if (linkf == LINK_LOGIT) then mu=alogit(mu) else if (linkf /= LINK_ID) then mu=ppnd(mu) end if par(PTYP_VE)=mu*(1.0d0-mu) if (linkf == LINK_MFT) then par(PTYP_VE)=par(PTYP_e2) end if else if (modtyp == GLM_POISS .or. modtyp == GLM_WEIB .or. & modtyp == GLM_GAMMA) then if (linkf == LINK_LOG) mu=exp(mu) par(PTYP_VE)=mu end if if (par(PTYP_VE) > 0.0d0) then par(PTYP_sdE)=sqrt(par(PTYP_VE)) else par(PTYP_sdE)=1.0d-9 end if end subroutine qtlmod ! ! check bounds on linear binomial model terms ! subroutine chkbin(nqtl, oobounds) use mcmc_model integer, intent(in) :: nqtl integer, intent(out) :: oobounds ! local variables integer :: i double precision :: pred ! do i=1, 3 pred=par(PTYP_mu)+nqtl*par(3+i) if (pred < 0.0D0) then oobounds=1 exit else if (pred > 1.0D0) then oobounds=2 exit end if end do end subroutine chkbin ! end-of-chkbin ! ! Circularized triangular random proportion ! subroutine triprop(tune, p) use rngs double precision, intent(in) :: tune double precision, intent(out) :: p p=p+dble(tune*rantri()) if (p > 1.0D0) then p=p-1.0D0 else if (p < 0.0D0) then p=1.0D0-p end if end subroutine triprop ! end-of-triprop ! ! link function for binary data ! linkf=1 identity 2 logit 3 probit 4 MFT 5=Log ! subroutine linfun(linkf, y, thresh) use statfuns integer, intent(in) :: linkf double precision, intent(inout) :: y double precision, intent(in) :: thresh ! functions double precision :: alogit external alogit ! if (linkf == 1) return if (linkf == 2) then y=alogit(y) else if (linkf == 3) then y=zp(y) else if (linkf == 4) then y=y-thresh if (y >= thresh) then y=1.0D0 else y=0.0D0 end if else if (linkf == 5) then y=exp(y) end if end subroutine linfun ! end-of-linfun ! ! Poisson or Binomial or Gaussian or Weibull or Gamma log density for FPM ! function dens(x, mu, sd, shap, cens, modtyp) #if SUN use, intrinsic :: ieee_arithmetic use, intrinsic :: ieee_exceptions #endif use glm_types use statfuns double precision :: dens double precision, intent(in) :: x double precision, intent(in) :: mu double precision, intent(in) :: sd double precision, intent(in) :: shap double precision, intent(in) :: cens ! modtyp: gaussian=1 binomial=1 poisson=3 weibull=4 integer, intent(in) :: modtyp ! double precision, parameter :: small=2.0D-200 ! double precision :: ln ! dens = 0.0D0 if (modtyp == GLM_GAUSS) then dens = dnorm(x, mu, sd) else if (modtyp == GLM_BINOM) then dens = ln(x*mu+(1.0D0-x)*(1.0D0-mu)) else if (modtyp == GLM_POISS) then if (x >= 0.0d0 .and. mu > small) then dens = dpois(x, mu) end if else if (modtyp == GLM_WEIB) then if (x >= 0.0d0 .and. mu > small) then dens = dweib(x, mu, shap, cens) end if else if (modtyp == GLM_GAMMA) then if (x >= 0.0d0 .and. mu > small) then dens = dgamma(x, mu, shap) end if end if #if SUN if (ieee_is_nan(dens)) then #else if (isnan(dens)) then #endif write(*,*) 'dens=', dens, x, mu, ' model=', modtyp write(*,*) 'shap=', shap, ' cens=', cens stop end if end function dens ! end-of-dens ! ! Calculate likelihood under FPM for entire sample of pedigrees ! over all chains (replicates) ! subroutine pedlik(linkf, modtyp, nchain, nqtl, nfix, ncol, & qtl_buffer, nfam, families, dataset, lik, oobounds, plevel) use alleles_class use mcmc_model use ped_class implicit none integer, intent(in) :: linkf integer, intent(in) :: modtyp integer, intent(in) :: nchain integer, intent(in) :: nqtl integer, intent(in) :: nfix integer, intent(in) :: ncol type (allele_data) :: qtl_buffer integer, intent(in) :: nfam type (mixed_data), dimension(:), pointer :: families type (ped_data), intent(in) :: dataset double precision, intent(out) :: lik integer, intent(inout) :: oobounds integer, intent(in) :: plevel ! local variables integer :: ichain, k ! lik=0.0D0 call qtlmod(linkf, modtyp, nqtl, qtl_buffer) if (modtyp == GLM_BINOM .and. linkf == LINK_ID .and. oobounds == 0) then call chkbin(nqtl, oobounds) end if if (oobounds == 0) then do k=1, nfam do ichain=1, nchain call seglik(linkf, modtyp, ichain, nqtl, nfix, qtl_buffer, & families(k), dataset, plevel) lik=lik+families(k)%famlik(ichain) end do end do else lik=BADLIK end if end subroutine pedlik ! end-of-pedlik ! ! Calculate likelihood under FPM for one pedigree (one chain/replicate) ! subroutine seglik(linkf, modtyp, ichain, nqtl, nfix, qtl_buffer, & family, dataset, plevel) use alleles_class use mcmc_model use ped_class use statfuns implicit none integer, intent(in) :: linkf integer, intent(in) :: modtyp integer, intent(in) :: ichain integer, intent(in) :: nqtl integer, intent(in) :: nfix type (allele_data), intent(in) :: qtl_buffer type (mixed_data), intent(inout) :: family type (ped_data), intent(in) :: dataset integer, intent(in) :: plevel ! local variables integer :: curmo, i double precision :: indlik, indglik, shap, yp ! functions ! integer parcon double precision :: dens external dens ! shap=1.0D0 if (modtyp == GLM_WEIB .or. modtyp == GLM_GAMMA) then shap=exp(par(RANPAR+nfix+1)) end if ! family%famlik(ichain)=0.0D0 family%gtplik(ichain)=0.0D0 ! Founders: different VG and VS likelihoods from those of nonfounders do i=1, family%nfound call seglf(OLD, i, ichain, linkf, modtyp, shap, nqtl, nfix, & qtl_buffer, family, dataset, yp, indlik, indglik) family%famlik(ichain)=family%famlik(ichain)+indlik family%gtplik(ichain)=family%gtplik(ichain)+indglik end do ! ! Nonfounders curmo=MISS do i=family%nfound+1, family%num call seglnf(OLD, i, ichain, curmo, linkf, modtyp, shap, nqtl, nfix, & qtl_buffer, family, dataset, yp, indlik, indglik) family%famlik(ichain)=family%famlik(ichain)+indlik family%gtplik(ichain)=family%gtplik(ichain)+indglik end do ! Familial environmental effect contribution if (par(PTYP_VC) > 0.0D0) then family%gtplik(ichain)=family%gtplik(ichain) + & dnorm(family%fammu(ichain), 0.0D0, par(PTYP_sdC)) end if ! famlik is total family likelihood family%famlik(ichain)=family%famlik(ichain)+family%gtplik(ichain) end subroutine seglik ! end-of-seglik ! ! Update (gene-dropping) genotypes at one of N unlinked QTLs ! or Gaussian polygenotype or familial random intercept ! subroutine oneseg(it, linkf, modtyp, ichain, nqtl, nfix, qtl_buffer, & prop_buffer, family, dataset, mcalg, plevel) use outstream use mcmc_model use ped_class use alleles_class use rngs use statfuns implicit none integer, intent(in) :: it integer, intent(in) :: linkf integer, intent(in) :: modtyp integer, intent(in) :: ichain integer, intent(in) :: nqtl integer, intent(in) :: nfix type (allele_data) :: qtl_buffer, prop_buffer type (mixed_data) :: family type (ped_data) :: dataset integer, intent(in) :: mcalg integer, intent(in) :: plevel ! ! lik=model likelihood, lr=likelihood ratio newlik/lik, ! qa=Metropolis criterion double precision :: lr, qa double precision :: yp ! ! local variables integer :: curmo, i, ieff, iqtl, j, ocurmo integer :: nspec, speceff(3) logical :: xmale double precision :: indglik, indlik, newglik, newlik, shap ! functions interface subroutine simped(ped, dataset, allele_buffer, set) use alleles_class use ped_class integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data), intent(in) :: allele_buffer integer, dimension(:,:), intent(out) :: set end subroutine simped subroutine isimped(ped, dataset, qtl_buffer, set) use ped_class use alleles_class integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data) :: qtl_buffer integer, dimension(:,:), intent(inout) :: set end subroutine isimped subroutine set2hap(ichain, iqtl, num, set, hset, typ) integer, intent(in) :: ichain, iqtl integer, intent(in) :: num integer, dimension(:,:), intent(inout) :: set integer, dimension(:,:,:,:), intent(inout) :: hset integer, intent(in) :: typ end subroutine set2hap end interface ! shap=1.0D0 if (modtyp == GLM_WEIB .or. modtyp == GLM_GAMMA) then shap=exp(par(RANPAR+nfix+1)) end if xmale=.false. ieff=0 nspec=0 do i=PTYP_VG, PTYP_VS if (par(i) > 0.0D0) then nspec=nspec+1 speceff(nspec)=i end if end do if ((nqtl+nspec) == 0) return ! iqtl=irandom(1, nqtl+nspec) if (plevel > 2) then if (iqtl <= nqtl) then write(outstr,'(a)') '# it pedigree id lik trait pred (sd) qtl proposed' else write(outstr,'(a,a)') '# it pedigree id lik ', & 'trait pred bval ( sd ) proposed' end if end if newglik=0.0D0 newlik=0.0D0 do i=1, family%num newbval(i)=family%bval(i, ichain) newmval(i)=family%mval(i, ichain) end do newfmu=family%fammu(ichain) ! ! evaluate likelihood for each pedigree ! parscal 15=sdG 16=sdC 17=sdS ! ieff=0 nchanges=family%num if (iqtl > nqtl) then ieff=speceff(iqtl-nqtl) if (mcalg == 3) then call oneslice(ieff, linkf, modtyp, shap, ichain, nqtl, nfix, & qtl_buffer, family, dataset, plevel) return else if (ieff == PTYP_VG) then call simpol(parscal(PTYP_sdG), ichain, family) else if (ieff == PTYP_VC) then newfmu=family%fammu(ichain)+0.5D0*parscal(PTYP_sdC)*dble(randn()) else call simmat(parscal(PTYP_sdS), ichain, family) end if else if (iqtl > 0) then if (irandom(1, family%num) == 1) then if (plevel > 2) write(outstr,'(a)') '*Simped proposal*' call simped(family%iped, dataset, prop_buffer, set) call set2hap(ichain, iqtl, family%num, set, family%hset, 3) else call set2hap(ichain, iqtl, family%num, set, family%hset, 2) call isimped(family%iped, dataset, prop_buffer, set) call set2hap(ichain, iqtl, family%num, set, family%hset, 3) end if end if ! ! Likelihood ratio if more efficient if (ieff > 0 .and. (2*nchanges) < family%num) then curmo=MISS ocurmo=MISS lr=0.0D0 do j=1, nchanges i=changes(j) if (i <= family%nfound) then call seglf(NEW, i, ichain, linkf, modtyp, shap, nqtl, nfix, qtl_buffer, & family, dataset, yp, indlik, indglik) lr=lr+indlik+indglik newglik=newglik+indglik call seglf(OLD, i, ichain, linkf, modtyp, shap, nqtl, nfix, qtl_buffer, & family, dataset, yp, indlik, indglik) lr=lr-indlik-indglik newglik=newglik-indglik if (plevel > 2) then call wronep(i, it, ichain, yp, iqtl, nqtl, ieff, indlik+indglik, & family, dataset) end if else call seglnf(NEW, i, ichain, curmo, linkf, modtyp, shap, nqtl, nfix, & qtl_buffer, family, dataset, yp, indlik, indglik) lr=lr+indlik+indglik newglik=newglik+indglik call seglnf(OLD, i, ichain, ocurmo, linkf, modtyp, shap, nqtl, nfix, & qtl_buffer, family, dataset, yp, indlik, indglik) lr=lr-indlik-indglik newglik=newglik-indglik if (plevel > 2) then call wronep(i, it, ichain, yp, iqtl, nqtl, ieff, indlik+indglik, & family, dataset) end if end if end do newlik=family%famlik(ichain)+lr newglik=family%gtplik(ichain)+newglik else ! ! else complete likelihood do i=1, family%nfound call seglf(NEW, i, ichain, linkf, modtyp, shap, nqtl, nfix, qtl_buffer, & family, dataset, yp, indlik, indglik) if (plevel > 2) then call wronep(i, it, ichain, yp, iqtl, nqtl, ieff, & indlik+indglik, family, dataset) end if if (indlik == BADLIK) then qa=0.0D0 go to 115 end if newlik=newlik+indlik newglik=newglik+indglik end do curmo=MISS do i=family%nfound+1, family%num call seglnf(NEW, i, ichain, curmo, linkf, modtyp, shap, nqtl, nfix, & qtl_buffer, family, dataset, yp, indlik, indglik) if (plevel > 2) then call wronep(i, it, ichain, yp, iqtl, nqtl, ieff, & indlik+indglik, family, dataset) end if if (indlik == BADLIK) then qa=0.0D0 go to 115 end if newlik=newlik+indlik newglik=newglik+indglik end do ! ! Familial environmental effect contribution if (par(PTYP_VC) > 0.0D0) then newglik=newglik+dnorm(newfmu, 0.0D0, par(PTYP_sdC)) end if ! famlik is total family likelihood newlik=newlik+newglik lr=newlik-family%famlik(ichain) end if qa=min(1.0D0,exp(lr)) ! If bounds were exceeded qa set to 0 and jumped to here: 115 continue ! ! If accepted, update genotypes ! gprop=gprop+1 if (qa > random()) then grate=grate+1 if (plevel > 2) then write(outstr,'(2a,4(a,f12.4))') & 'Proposal accepted for pedigree ', dataset%pedigree(family%iped), & ' oldgtp=', family%gtplik(ichain), ' newgtp=', newglik, & ' oldlik=', family%famlik(ichain), ' newlik=', newlik end if family%famlik(ichain)=newlik family%gtplik(ichain)=newglik if (iqtl > nqtl) then do i=1, family%num family%bval(i, ichain)=newbval(i) family%mval(i, ichain)=newmval(i) end do end if family%fammu(ichain)=newfmu else if (plevel > 2) then write(outstr,'(2a,4(a,f12.4))') & 'Proposal rejected for pedigree ', dataset%pedigree(family%iped), & ' oldgtp=', family%gtplik(ichain), ' newgtp=', newglik, & ' oldlik=', family%famlik(ichain), ' newlik=', newlik end if if (iqtl <= nqtl .and. iqtl > 0) then call set2hap(ichain, iqtl, family%num, set, family%hset, 1) end if end if end subroutine oneseg ! ! Slice sampler updating Gaussian polygenotype ! subroutine oneslice(ieff, linkf, modtyp, shap, ichain, nqtl, nfix, & qtl_buffer, family, dataset, plevel) use mcmc_model use ped_class use alleles_class use rngs implicit none integer, intent(in) :: ieff integer, intent(in) :: linkf integer, intent(in) :: modtyp double precision, intent(in) :: shap integer, intent(in) :: ichain integer, intent(in) :: nqtl integer, intent(in) :: nfix type (allele_data) :: qtl_buffer type (mixed_data) :: family type (ped_data) :: dataset integer, intent(in) :: plevel ! ! local variables integer :: i, idx, it, lmax, rmax integer :: mztwin_proposal, twinlist(5) double precision :: baslik, newglik, newlik, ltlik, rtlik, slicelik double precision :: basgtp, ltval, origval, prop, rtval ! functions interface subroutine ascend(n, ia) integer, intent(in) :: n integer, dimension(:), intent(inout) :: ia end subroutine ascend end interface ! it=10 ! Proposal to change one random effect for this pedigree; ! change may have ramifications to offspring and twin likelihood contribution nchanges=0 mztwin_proposal=0 if (ieff == 11) then idx=irandom(1, family%num) ! if an MZ twin, indicate the first member of the twinship if (family%imztwin(idx) /= MISS) then idx=family%imztwin(idx) end if origval=family%bval(idx, ichain) nchanges=nchanges+1 changes(nchanges)=idx do i=family%nfound+1, family%num if (family%fa(i) == idx .or. family%mo(i) == idx) then nchanges=nchanges+1 changes(nchanges)=i mztwin_proposal=mztwin_proposal+1 twinlist(mztwin_proposal)=i else if (family%imztwin(i) == idx) then nchanges=nchanges+1 changes(nchanges)=i end if end do if (mztwin_proposal > 0) then write(*,*) 'MZ twin proposal ' end if else if (ieff == 12) then origval=family%fammu(ichain) nchanges=family%num call ascend(nchanges, changes) else if (ieff == 13) then do idx=irandom(1, family%num) if (family%mval(idx,ichain) /= MISS) exit end do origval=family%mval(idx,ichain) if (idx > family%nfound) then do i=family%nfound+1, family%num if (family%mo(i) == family%mo(idx)) then nchanges=nchanges+1 changes(nchanges)=i end if end do else nchanges=nchanges+1 changes(nchanges)=idx end if end if ! current likelihood for changed subset only call idxlik(linkf, modtyp, shap, ichain, nqtl, nfix, & qtl_buffer, family, dataset, baslik, basgtp) ! slice threshold and initial proposals for slice width slicelik=log(dble(random()))+baslik ! while loops expanding the slice gprop=gprop+3 lmax=irandom(1, it) rmax=it-lmax ltval=origval-dble(random())*parscal(4+ieff) call sliceprop(ieff, idx, mztwin_proposal, twinlist, ichain, ltval, family) call idxlik(linkf, modtyp, shap, ichain, nqtl, nfix, & qtl_buffer, family, dataset, ltlik, newglik) do while (lmax /= 0 .and. ltlik > slicelik) ltval=ltval-parscal(4+ieff) call sliceprop(ieff, idx, mztwin_proposal, twinlist, ichain, ltval, family) call idxlik(linkf, modtyp, shap, ichain, nqtl, nfix, & qtl_buffer, family, dataset, ltlik, newglik) gprop=gprop+1 lmax=lmax-1 end do ! rtval=ltval+parscal(4+ieff) call sliceprop(ieff, idx, mztwin_proposal, twinlist, ichain, rtval, family) call idxlik(linkf, modtyp, shap, ichain, nqtl, nfix, & qtl_buffer, family, dataset, rtlik, newglik) do while (rmax /= 0 .and. rtlik > slicelik) rtval=rtval+parscal(4+ieff) call sliceprop(ieff, idx, mztwin_proposal, twinlist, ichain, rtval, family) call idxlik(linkf, modtyp, shap, ichain, nqtl, nfix, & qtl_buffer, family, dataset, rtlik, newglik) gprop=gprop+1 rmax=rmax-1 end do ! sample within slice, shrinking if unsuccessful it=0 do it=it+1 gprop=gprop+1 prop=ltval+dble(random())*(rtval-ltval) call sliceprop(ieff, idx, mztwin_proposal, twinlist, ichain, prop, family) call idxlik(linkf, modtyp, shap, ichain, nqtl, nfix, & qtl_buffer, family, dataset, newlik, newglik) if (newlik > slicelik) exit if (prop < origval) then ltval=prop ltlik=newlik else rtval=prop rtlik=newlik end if end do grate=grate+1 family%famlik(ichain)=family%famlik(ichain)+newlik-baslik family%gtplik(ichain)=family%gtplik(ichain)+newglik-basgtp end subroutine oneslice ! end-of-oneslice ! ! copy proposal to appropriate location ! subroutine sliceprop(ieff, idx, mztwin_proposal, twinlist, ichain, prop, family) use mcmc_model implicit none integer, intent(in) :: ieff integer, intent(in) :: idx integer :: mztwin_proposal, twinlist(5) integer, intent(in) :: ichain double precision, intent(in) :: prop type (mixed_data) :: family integer :: i if (ieff == 11) then family%bval(idx, ichain)=prop if (mztwin_proposal > 0) then do i=1, mztwin_proposal family%bval(twinlist(i), ichain)=prop end do end if else if (ieff == 12) then family%fammu(ichain)=prop else if (ieff == 13) then do i=1, nchanges family%mval(changes(i), ichain)=prop end do end if end subroutine sliceprop ! end-of-sliceprop ! ! Gaussian polygenotype likelihood contribution of individual idx (and ! affected relatives) ! subroutine idxlik(linkf, modtyp, shap, ichain, nqtl, nfix, & qtl_buffer, family, dataset, lik, gtplik) use mcmc_model use ped_class use alleles_class use statfuns implicit none integer, intent(in) :: linkf integer, intent(in) :: modtyp double precision, intent(in) :: shap integer, intent(in) :: ichain integer, intent(in) :: nqtl integer, intent(in) :: nfix type (allele_data) :: qtl_buffer type (mixed_data) :: family type (ped_data) :: dataset double precision, intent(out) :: lik double precision, intent(out) :: gtplik ! local variables integer :: curmo, idx, j double precision :: indglik, indlik, yp ! functions ! dnorm curmo=MISS gtplik=0.0D0 lik=0.0D0 do j=1, nchanges idx=changes(j) if (idx <= family%nfound) then call seglf(OLD, idx, ichain, linkf, modtyp, shap, nqtl, nfix, & qtl_buffer, family, dataset, yp, indlik, indglik) else call seglnf(OLD, idx, ichain, curmo, linkf, modtyp, shap, nqtl, nfix, & qtl_buffer, family, dataset, yp, indlik, indglik) end if if (indlik == BADLIK) then lik=BADLIK return end if gtplik=gtplik+indglik lik=lik+indlik end do ! Familial environmental effect contribution if (par(PTYP_VC) > 0.0D0) then gtplik=gtplik+dnorm(family%fammu(ichain), 0.0D0, par(PTYP_sdC)) end if lik=lik+gtplik end subroutine idxlik ! ! Likelihood contribution of a founder ! subroutine seglf(typ, idx, ichain, linkf, modtyp, shap, nqtl, nfix, & qtl_buffer, family, dataset, yp, lik, gtplik) use mcmc_model use ped_class use alleles_class use statfuns implicit none integer, intent(in) :: typ ! old or new integer, intent(in) :: idx ! person integer, intent(in) :: ichain ! chain integer, intent(in) :: linkf ! GLM link function integer, intent(in) :: modtyp ! GLM lik double precision, intent(in) :: shap ! Weibull, Gamma etc shape integer, intent(in) :: nqtl ! no. QTLs integer, intent(in) :: nfix ! no. fixed effects coefficients type (allele_data) :: qtl_buffer ! QTL parameters type (mixed_data) :: family ! mixed model data for current pedigree type (ped_data) :: dataset ! pedigree double precision, intent(out) :: yp ! linear predictor double precision, intent(out) :: lik double precision, intent(out) :: gtplik ! ! local variables integer :: gtp, j ! functions double precision :: dens external dens ! lik=0.0D0 gtplik=0.0D0 yp=par(PTYP_mu) if (linkf == 4) yp=0.0d0 if (typ==OLD) then yp=yp+family%bval(idx,ichain)+family%mval(idx,ichain)+family%fammu(ichain) else yp=yp+newbval(idx)+newmval(idx)+newfmu end if do j=1, nfix yp=yp+par(RANPAR+j)*family%vals(idx,j) end do ! offset yp=yp+family%vals(idx, nfix+1) ! QTL contributions do j=1, nqtl gtp=family%hset(idx,ichain, j,2)*(family%hset(idx,ichain,j,2)-1)/2 + & family%hset(idx,ichain,j,1) yp=yp+par(3+gtp) gtplik=gtplik+qtl_buffer%gtp_freqs(gtp) end do call linfun(linkf, yp, par(PTYP_mu)) ! Bound check binary phenotypes -- why need to evaluate unphenotypeds if (modtyp == GLM_BINOM .and. (yp < 0.0D0 .or. yp > 1.0D0)) then lik=BADLIK return end if ! Phenotypic likelihood contribution if (family%yval(idx) /= MISS) then lik=lik+dens(family%yval(idx), yp, par(PTYP_sdE), shap, & family%vals(idx,nfix+2), modtyp) ! Sibship/maternal effect contribution -- ! if founder and phenotype unobserved, does not contribute information (cf genes) if (par(PTYP_VS) > 0.0D0) then if (typ==OLD) then gtplik=gtplik+dnorm(family%mval(idx,ichain), 0.0D0, par(PTYP_sdS)) else gtplik=gtplik+dnorm(newmval(idx), 0.0D0, par(PTYP_sdS)) end if end if end if ! Gaussian polygenotype contribution if (par(PTYP_VG) > 0.0D0) then if (typ==OLD) then gtplik=gtplik+dnorm(family%bval(idx,ichain), 0.0D0, par(PTYP_sdG)) else gtplik=gtplik+dnorm(newbval(idx), 0.0D0, par(PTYP_sdG)) end if end if end subroutine seglf ! ! Likelihood contribution of a nonfounder ! subroutine seglnf(typ, idx, ichain, curmo, linkf, modtyp, shap, & nqtl, nfix, qtl_buffer, family, dataset, yp, lik, gtplik) use mcmc_model use ped_class use alleles_class use statfuns implicit none integer, intent(in) :: typ ! old or new integer, intent(in) :: idx ! person integer, intent(in) :: ichain ! MCMC chain/replicate integer, intent(inout) :: curmo integer, intent(in) :: linkf integer, intent(in) :: modtyp double precision, intent(in) :: shap integer, intent(in) :: nqtl integer, intent(in) :: nfix type (allele_data) :: qtl_buffer type (mixed_data) :: family type (ped_data) :: dataset double precision, intent(out) :: yp double precision, intent(out) :: lik double precision, intent(out) :: gtplik ! local variables double precision :: ypf double precision :: midpar ! functions double precision :: dens external dens ! lik=0.0D0 gtplik=0.0D0 call fpmpred(typ, idx, ichain, linkf, nqtl, nfix, family, yp, ypf) call linfun(linkf, yp, par(PTYP_mu)) ! Bound check binary phenotypes -- why need to evaluate unphenotypeds if (modtyp == GLM_BINOM .and. (yp < 0.0D0 .or. yp > 1.0D0)) then lik=BADLIK return end if ! Phenotypic likelihood contribution if (family%yval(idx) /= MISS) then lik=lik+dens(family%yval(idx), yp, par(PTYP_sdE), shap, & family%vals(idx,nfix+2), modtyp) ! Sibship/maternal effect contribution ! If no sibship members phenotyped, does not contribute to likelihood if (par(PTYP_VS) > 0.0D0 .and. family%mo(idx) /= curmo) then curmo=family%mo(idx) if (typ==OLD) then gtplik=gtplik+dnorm(family%mval(idx,ichain), 0.0D0, par(PTYP_sdS)) else gtplik=gtplik+dnorm(newmval(idx), 0.0D0, par(PTYP_sdS)) end if end if end if ! Gaussian polygenotype transmission contribution if (par(PTYP_VG) > 0.0D0) then if (family%imztwin(idx) == MISS) then if (typ==OLD) then midpar=0.5D0*(family%bval(family%fa(idx),ichain)+ & family%bval(family%mo(idx),ichain)) gtplik=gtplik+dnorm(family%bval(idx,ichain), midpar, par(PTYP_sdG)*family%rsd(idx)) else midpar=0.5D0*(newbval(family%fa(idx))+ & newbval(family%mo(idx))) gtplik=gtplik+dnorm(newbval(idx), midpar, par(PTYP_sdG)*family%rsd(idx)) end if end if end if end subroutine seglnf ! ! Resimulate (gene-dropping) genotypes at a single autosomal locus ! in descendants of randomly selected index ! subroutine isimped(ped, dataset, qtl_buffer, set) use ped_class use alleles_class use rngs integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data) :: qtl_buffer integer, dimension(:,:), intent(inout) :: set ! integer, parameter :: MISS=-9999 integer :: i, idx, num, pedoffset logical :: fin ! functions interface subroutine found(cumfrq, allele) double precision, dimension(:), intent(in) :: cumfrq integer, intent(out) :: allele end subroutine subroutine genoff(idx, fa, mo, set) integer, intent(in) :: idx integer, intent(in) :: fa integer, intent(in) :: mo integer, dimension(:,:), intent(in out) :: set end subroutine subroutine gencopy(idx, origin, set) integer, intent(in) :: idx integer, intent(in) :: origin integer, dimension(:,:), intent(inout) :: set end subroutine gencopy end interface ! select an index person or mating and zero out descendants pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset i=irandom(1, num) if (i <= dataset%nfound(ped) .or. irandom(1,2) == 1) then set(i,1)=MISS set(i,2)=MISS else idx=i+pedoffset set(dataset%fa(idx)-pedoffset,1)=MISS set(dataset%fa(idx)-pedoffset,2)=MISS set(dataset%mo(idx)-pedoffset,1)=MISS set(dataset%mo(idx)-pedoffset,2)=MISS end if ii=pedoffset+dataset%nfound(ped) do i=dataset%nfound(ped)+1, num ii=ii+1 if (set(dataset%fa(ii)-pedoffset,1) == MISS .or. & set(dataset%mo(ii)-pedoffset,1) == MISS) then set(i,1)=MISS set(i,2)=MISS end if end do ! fill in missing genotypes do i=1, dataset%nfound(ped) if (set(i,1) == MISS) then call found(qtl_buffer%cum_freqs, set(i,1)) call found(qtl_buffer%cum_freqs, set(i,2)) call order(set(i,1), set(i,2)) end if end do ! do fin=.true. ii=pedoffset+dataset%nfound(ped) do i=dataset%nfound(ped)+1,num ii=ii+1 if (set(i,1) == MISS) then if (set(dataset%fa(ii)-pedoffset,1) /= MISS .and. & set(dataset%mo(ii)-pedoffset,1) /= MISS) then if (dataset%imztwin(ii) /= MISS) then call gencopy(i, dataset%imztwin(ii)-pedoffset, set) else call genoff(i, dataset%fa(ii)-pedoffset, & dataset%mo(ii)-pedoffset, set) end if else fin=.false. end if end if end do if (fin) exit end do end subroutine isimped ! ! Propose updated additive polygenic values in a pedigree ! subroutine simpol(vsd, ichain, family) use mcmc_model use rngs double precision, intent(in) :: vsd integer, intent(in) :: ichain type (mixed_data) :: family ! integer :: i, idx, npro ! ! select an 1-4 index persons or matings or everyone ! choose to alter descendants or not ! do i=1, family%num sim(i)=0 end do if (irandom(1, family%num) == 1) then do i=1, family%num if (family%imztwin(i) == MISS) then sim(i)=1 end if end do else npro=irandom(1,4) do i=1, npro idx=irandom(1, family%num) ! if a twin, indicate the first member of the twinship if (family%imztwin(idx) /= MISS) then idx=family%imztwin(idx) end if if (irandom(1,2) == 1 .and. idx > family%nfound) then if (family%imztwin(family%fa(idx)) /= MISS) then sim(family%imztwin(family%fa(idx)))=1 else sim(family%fa(idx))=1 end if if (family%imztwin(family%mo(idx)) /= MISS) then sim(family%imztwin(family%mo(idx)))=1 else sim(family%mo(idx))=1 end if else sim(idx)=1 end if end do if (irandom(1,4) == 1) then do i=family%nfound+1, family%num if (sim(family%fa(i)) == 1 .or. sim(family%mo(i)) == 1) then sim(i)=1 end if end do end if end if ! tweak indicated breeding value nchanges=0 do i=1, family%num if (sim(i) == 1) then nchanges=nchanges+1 changes(nchanges)=i newbval(i)=family%bval(i,ichain)+vsd*dble(randn()) else newbval(i)=family%bval(i,ichain) end if end do ! also do MZ cotwins of index do i=family%nfound+1, family%num if (family%imztwin(i) /= MISS) then if (sim(family%imztwin(i)) == 1) then sim(i)=1 changes(nchanges)=i newbval(i)=newbval(family%imztwin(i)) end if end if end do ! also have to recalculate contribution for unaltered offspring of those with ! altered breeding values do i=family%nfound+1, family%num if (sim(i) == 0 .and. (sim(family%fa(i)) == 1 .or. & sim(family%mo(i)) == 1)) then nchanges=nchanges+1 changes(nchanges)=i end if end do end subroutine simpol ! end-of-simpol ! ! Propose updated sibship/maternal effects in a pedigree ! subroutine simmat(vstep, ichain, family) use mcmc_model use rngs double precision, intent(in) :: vstep integer , intent(in) :: ichain type (mixed_data) :: family ! integer :: elig, i, idx elig=0 nchanges=0 do i=1, family%num if (family%yval(i) /= MISS) then elig=elig+1 changes(elig)=i newmval(i)=family%mval(i, ichain) end if end do ! idx=changes(irandom(1,elig)) newmval(idx)=family%mval(idx,ichain)+vstep*dble(randn()) if (idx > family%nfound) then do j=family%nfound+1, family%num if (family%mo(j) == family%mo(idx)) then newmval(j)=newmval(idx) nchanges=nchanges+1 changes(nchanges)=j end if end do else nchanges=nchanges+1 changes(nchanges)=idx end if end subroutine simmat ! end-of-simmat ! ! Get empirical estimates of random effects ! Tote up empirical statistics for random effects: VG, VC, VS, VE ! subroutine empval(linkf, modtyp, nchain, nqtl, nfix, nfam, families, totobs, & empmu, empvar) use mcmc_model integer, intent(in) :: linkf integer, intent(in) :: modtyp integer, intent(in) :: nchain integer, intent(in) :: nqtl integer, intent(in) :: nfix integer, intent(in) :: nfam type (mixed_data), dimension(:), pointer :: families integer, intent(in) :: totobs double precision, intent(out) :: empmu(6) double precision, intent(out) :: empvar(6) ! local variables integer :: fam, i, ichain, ifam, nships, tfound, tot, totall double precision :: shap, ve, vef, yp, ypf ifam=0 nships=0 tot=0 totall=0 tfound=0 do j=1, 6 empmu(j)=0.0D0 empvar(j)=0.0D0 end do ve=0.0d0 vef=0.0d0 shap=1.0D0 if (modtyp == GLM_WEIB .or. modtyp == GLM_GAMMA) then shap=exp(par(RANPAR+nfix+1)) end if do fam=1, nfam ! empirical allele count for 1st qtl if (nqtl > 0) then do i=1, families(fam)%nfound do ichain=1, nchain totall=totall+families(fam)%hset(i,ichain,1,1) + & families(fam)%hset(i,ichain,1,2) end do end do tfound=tfound+families(fam)%nfound end if ! VG if (par(PTYP_VG) > 0.0D0) then do i=1, families(fam)%num do ichain=1, nchain tot=tot+1 call moment(tot, families(fam)%bval(i,ichain), empmu(2), empvar(2)) end do end do end if ! VC if (par(PTYP_VC) > 0.0D0) then do ichain=1, nchain ifam=ifam+1 call moment(ifam, families(fam)%fammu(ichain), empmu(3), empvar(3)) end do end if ! VS: random effect not always estimated if (par(PTYP_VS) > 0.0D0) then do ichain=1, nchain cmo=MISS do i=families(fam)%nfound+1, families(fam)%num if (families(fam)%mo(i) /= cmo .and. & families(fam)%mval(i,ichain) /= MISS) then cmo=families(fam)%mo(i) nships=nships+1 call moment(nships, families(fam)%mval(i,ichain), empmu(4), empvar(4)) end if end do end do end if ! VE (does not deal well with censoring) do i=1, families(fam)%num if (families(fam)%yval(i) /= MISS) then do ichain=1, nchain call fpmpred(OLD, i, ichain, linkf, nqtl, & nfix, families(fam), yp, ypf) if (modtyp == GLM_WEIB) then yp=-yp/shap ypf=-ypf/shap else if (modtyp == GLM_GAMMA) then yp=yp/shap ypf=ypf/shap end if call linfun(linkf, yp, par(PTYP_mu)) call linfun(linkf, ypf, par(PTYP_mu)) yp=families(fam)%yval(i)-yp ve=ve+yp*yp ypf=families(fam)%yval(i)-ypf vef=vef+ypf*ypf end do end if end do end do empvar(1)=0.0d0 if (totall > 0) then empvar(1)=dble(4*tfound-totall)/dble(2*tfound) end if empvar(2)=empvar(2)/dble(max(1,tot-1)) empvar(3)=empvar(3)/dble(max(1,ifam-1)) empvar(4)=empvar(4)/dble(max(1,nships-1)) empvar(5)=ve/dble(nchain*totobs) empvar(6)=ve/vef end subroutine empval ! end-of-empval ! ! Initialize additive genetic and/or maternal random effects ! subroutine initvc(nchain, nfam, families) use mcmc_model use rngs integer, intent(in) :: nchain integer, intent(in) :: nfam type (mixed_data), dimension(:), pointer :: families integer :: cfa, cmo, fam, i, ichain double precision :: mateff, midpar, segsd ! Breeding values if (paract(PTYP_h2) == 1 .or. paract(PTYP_VG) == 1 .or. & paract(PTYP_h2) == 2 .or. paract(PTYP_VG) == 2) then segsd=par(PTYP_sdG)/sqrt(2.0D0) do fam=1, nfam do i=1, families(fam)%nfound do ichain=1, nchain families(fam)%bval(i,ichain)=dble(randn())*par(PTYP_sdG) end do end do do i=families(fam)%nfound+1, families(fam)%num cfa=families(fam)%fa(i) cmo=families(fam)%mo(i) do ichain=1, nchain midpar=0.5D0*(families(fam)%bval(cfa,ichain) + & families(fam)%bval(cmo,ichain)) if (families(fam)%imztwin(i) /= MISS) then families(fam)%bval(i,ichain)=families(fam)%bval(families(fam)%imztwin(i),ichain) else families(fam)%bval(i,ichain)=midpar+dble(randn())*segsd end if end do end do end do end if ! Maternal/sibship effects if (paract(PTYP_s2) == 1 .or. paract(PTYP_VS) == 1 .or. & paract(PTYP_s2) == 2 .or. paract(PTYP_VS) == 2) then do fam=1, nfam do i=1, families(fam)%nfound if (families(fam)%yval(i) /= MISS) then do ichain=1, nchain families(fam)%mval(i,ichain)=dble(randn())*par(PTYP_sdS) end do else do ichain=1, nchain families(fam)%mval(i,ichain)=MISS end do end if end do ! need same maternal effect throughout sibship for given chain do ichain=1, nchain cmo=MISS mateff=0.0D0 do i=families(fam)%nfound+1, families(fam)%num if (families(fam)%yval(i) /= MISS) then if (families(fam)%mo(i) /= cmo) then cmo=families(fam)%mo(i) mateff=dble(randn())*par(PTYP_sdS) end if families(fam)%mval(i,ichain)=mateff else families(fam)%mval(i,ichain)=MISS end if end do end do end do end if end subroutine initvc ! end-of-initvc ! ! Copy or swap genotypes from set to hset ! 1=set->hset; 2=hset->set; 3=swap ! subroutine set2hap(ichain, iqtl, num, set, hset, typ) integer, intent(in) :: ichain, iqtl integer, intent(in) :: num integer, dimension(:,:), intent(inout) :: set integer, dimension(:,:,:,:), intent(inout) :: hset integer, intent(in) :: typ ! ! QTL genotypes ! integer :: i, tmp ! if (typ == 1) then hset(1:num,ichain,iqtl,1)=set(1:num,1) hset(1:num,ichain,iqtl,2)=set(1:num,2) else if (typ == 2) then set(1:num,1)=hset(1:num,ichain,iqtl,1) set(1:num,2)=hset(1:num,ichain,iqtl,2) else do i=1, num tmp=hset(i,ichain,iqtl,1) hset(i,ichain,iqtl,1)=set(i,1) set(i,1)=tmp tmp=hset(i,ichain,iqtl,2) hset(i,ichain,iqtl,2)=set(i,2) set(i,2)=tmp end do end if end subroutine set2hap ! end-of-set2hap ! ! FPM Linear predictor ! subroutine fpmpred(typ, idx, ichain, linkf, nqtl, nfix, & family, yp, ypf) use mcmc_model implicit none integer, intent(in) :: typ integer, intent(in) :: idx integer, intent(in) :: ichain integer, intent(in) :: linkf integer, intent(in) :: nqtl integer, intent(in) :: nfix type (mixed_data), intent(in) :: family ! yp and ypf are linear predictor for full model and fixed effects model ! respectively double precision, intent(out) :: yp double precision, intent(out) :: ypf integer :: gtp, j ! ypf=par(PTYP_mu) if (linkf == 4) ypf=0.0d0 do j=1, nfix ypf=ypf+par(RANPAR+j)*family%vals(idx,j) end do ! offset ypf=ypf+family%vals(idx, nfix+1) if (typ==OLD) then yp=ypf+family%fammu(ichain)+family%bval(idx,ichain)+family%mval(idx,ichain) else yp=ypf+newfmu+newbval(idx)+newmval(idx) end if do j=1, nqtl gtp=family%hset(idx,ichain,j,2)*(family%hset(idx,ichain,j,2)-1)/2+ & family%hset(idx,ichain,j,1) yp=yp+par(3+gtp) end do end subroutine fpmpred ! ! Accumulate BLUP for additive genetic effects ! subroutine updateblups(whichblup, nvals, nchain, nfam, families) use mcmc_model integer, intent(in) :: whichblup integer, intent(in) :: nvals integer, intent(in) :: nchain integer, intent(in) :: nfam type (mixed_data), dimension(:), pointer :: families integer :: fam, i, ichain, iqtl, totall double precision :: dchain, dn, dev, fmu dchain=1.0d0/dble(nchain) dn=1.0d0/dble(nvals) if (whichblup == 11) then do fam=1, nfam do i=1, families(fam)%num dev=0.0d0 do ichain=1, nchain dev=dev+families(fam)%bval(i,ichain) end do dev=dchain*dev-families(fam)%blup(i) families(fam)%blup(i)=families(fam)%blup(i)+dn*dev end do end do else if (whichblup == 12) then do fam=1, nfam fmu=0.0d0 do ichain=1, nchain fmu=fmu+families(fam)%fammu(ichain) end do fmu=dchain*fmu do i=1, families(fam)%num dev=fmu-families(fam)%blup(i) families(fam)%blup(i)=families(fam)%blup(i)+dn*dev end do end do else if (whichblup == 13) then do fam=1, nfam do i=1, families(fam)%num dev=0.0d0 do ichain=1, nchain dev=dev+families(fam)%mval(i,ichain) end do dev=dchain*dev-families(fam)%blup(i) families(fam)%blup(i)=families(fam)%blup(i)+dn*dev end do end do else ! QTLs do fam=1, nfam do i=1, families(fam)%num totall=-2*whichblup*nchain do ichain=1, nchain do iqtl=1, whichblup totall=totall+families(fam)%hset(i,ichain,iqtl,1) + & families(fam)%hset(i,ichain,iqtl,2) end do end do dev=dchain*totall-families(fam)%blup(i) families(fam)%blup(i)=families(fam)%blup(i)+dn*dev end do end do end if end subroutine updateblups ! ! Produce batch estimates of Monte-Carlo error variance ! subroutine dobatch(nbatch, nvar, batch, batchse) integer, intent(in) :: nbatch, nvar double precision, dimension(:,:), intent(in) :: batch double precision, dimension(:), intent(out) :: batchse integer :: contrib, i, idx, j, k, nb double precision :: bden, mu, val contrib=1 nb=nbatch if (nbatch > 20) then contrib=nbatch/20 nb=nbatch/contrib end if bden=1.0d0/dble(contrib) do i=1, nvar batchse(i)=0.0d0 mu=0.0d0 idx=0 do j=1, nb val=0.0d0 do k=1, contrib idx=idx+1 val=val+batch(i, idx) end do val=bden*val call moment(j, val, mu, batchse(i)) end do batchse(i)=sqrt(batchse(i)/dble(max(1,nb*(nb-1)))) end do end subroutine dobatch ! ! Print oneseg's proposed genotypes for one individual ! subroutine wronep(idx, it, ichain, yp, iqtl, nqtl, ieff, lik, family, dataset) use outstream use mcmc_model use ped_class implicit none integer, intent(in) :: idx integer, intent(in) :: it integer, intent(in) :: ichain double precision, intent(in) :: yp integer, intent(in) :: iqtl integer, intent(in) :: nqtl integer, intent(in) :: ieff double precision, intent(in) :: lik type (mixed_data), intent(in) :: family type (ped_data) :: dataset if (iqtl <= nqtl .and. nqtl > 0) then write(outstr,'(i7,1x,a10,1x,a10,3(1x,f9.4),1x,3(i3,a),i3)') & it, dataset%pedigree(family%iped), dataset%id(family%pid(idx)), & lik, family%yval(idx), yp, & set(idx,1), '/', set(idx,2),' -> ', & family%hset(idx,ichain,iqtl,1), '/', family%hset(idx,ichain,iqtl,2) else if (ieff == 11) then write(outstr,'(i7,1x,a10,1x,a10,4(1x,f9.4),2(a,f9.4))') & it, dataset%pedigree(family%iped), dataset%id(family%pid(idx)), & lik, family%yval(idx), yp, & family%bval(idx,ichain), ' (', par(PTYP_sdG), ') -> ', newbval(idx) else if (ieff == 13) then write(outstr,'(i7,1x,a10,1x,a10,4(1x,f9.4),2(a,f9.4))') & it, dataset%pedigree(family%iped), dataset%id(family%pid(idx)), & lik, family%yval(idx), yp, & family%mval(idx,ichain), ' (', par(PTYP_sdS), ') -> ', newmval(idx) end if end subroutine wronep ! end-of-wronep ! ! Print simulated genotypes from FPM iteration ! subroutine wrfpm(it, linkf, modtyp, ichain, nqtl, nfix, family, dataset) use outstream use mcmc_model use rngs use ped_class implicit none integer, intent(in) :: it integer, intent(in) :: linkf integer, intent(in) :: modtyp integer, intent(in) :: ichain integer, intent(in) :: nqtl integer, intent(in) :: nfix type (mixed_data), intent(in) :: family type (ped_data) :: dataset ! integer :: addsco, cmo, i, j, gtp character (len=1) :: ch double precision :: shap, sval, yp shap=1.0D0 if (modtyp == GLM_WEIB .or. modtyp == GLM_GAMMA) then shap=exp(par(RANPAR+nfix+1)) end if write(outstr,'(2a,$)') & '# MCMC it pedigree id fa mo sex ', & 'famlik gtplik fammu trait pred bval mval qtlall' do j=1, nqtl write(outstr,'(a,i2.2)', advance='no') ' qtl', j end do do j=1, nfix write(outstr,'(1x,a)', advance='no') trim(parnam(RANPAR+j)) end do write(outstr,*) 'offset censored' ! cmo=MISS sval=0.0D0 do i=1, family%num addsco=0 ! if VS>0 then unphenotyped individuals/sibships get random S value if (par(PTYP_VS) > 0.0D0) then if (family%mval(i, ichain) /= MISS) then sval=family%mval(i, ichain) else if (i <= family%nfound .or. family%mo(i) /= cmo) then cmo=family%mo(i) sval=par(PTYP_sdS)*dble(randn()) end if end if yp=par(PTYP_mu)+family%fammu(ichain)+family%bval(i,ichain)+sval do j=1, nfix yp=yp+par(RANPAR+j)*family%vals(i,j) end do ! offset yp=yp+family%vals(i, nfix+1) do j=1, nqtl gtp=family%hset(i,ichain,j,1) + family%hset(i,ichain,j,2) - 1 addsco=addsco+gtp-1 yp=yp+par(3+gtp) end do if (modtyp == GLM_WEIB) then yp=-yp/shap end if call linfun(linkf, yp, par(PTYP_mu)) ! write(outstr,'(a,i6,2(1x,a))', advance='no') & 'MCMC ', it, trim(dataset%pedigree(family%iped)), trim(dataset%id(family%pid(i))) if (family%fa(i) == MISS) then write(outstr,'(2(1x,a))', advance='no') 'x','x' else write(outstr,'(2(1x,a))', advance='no') & trim(dataset%id(family%pid(family%fa(i)))), & trim(dataset%id(family%pid(family%mo(i)))) end if call wrsex(dataset%sex(family%pid(i)), ch) write(outstr,'(1x,a1)', advance='no') ch write(outstr,'(2(1x,f12.2),f12.6)', advance='no') & family%famlik(ichain), family%gtplik(ichain), family%fammu(ichain) if (family%yval(i) == MISS) then write(outstr,'(6x,a)', advance='no') 'x ' else write(outstr,'(1x,f12.6)', advance='no') family%yval(i) end if write(outstr,'(3(1x,f12.6),1x,i3)', advance='no') & yp, family%bval(i,ichain), family%mval(i,ichain), addsco do j=1, nqtl write(outstr,'(1x,i1,a1,i1)', advance='no') & family%hset(i,ichain,j,1), '/', family%hset(i,ichain,j,2) end do do j=1, nfix+1 write(outstr,'(1x,f9.4)', advance='no') family%vals(i,j) end do write(outstr,'(1x,i1)') max(0, int(family%vals(i, nfix+2))) end do end subroutine wrfpm ! ! WLS analysis of familial correlations ! subroutine wlscor(cor, npairs, stderr) use outstream use AS164 integer, parameter :: nclass=18 double precision, dimension(nclass), intent(in) :: cor integer, dimension(nclass), intent(in) :: npairs double precision, dimension(nclass), intent(in) :: stderr ! corr=double entry correction, vweight=sampling variance for correlation double precision :: corr, vweight double precision :: x(3), r(6), cov(6), b(2) integer :: i, ifail, n character (len=14) :: model ! Marital, Gp-Gch, Hsib, PO, Fsib, MZtwin double precision, dimension(6) :: & rel = (/0.0d0, 0.25d0, 0.25d0, 0.5d0, 0.5d0, 1.0d0/), & frat= (/0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.25d0, 1.0d0/) model='Dominance (d2)' if (npairs(6) > 0 .and. 2*cor(5) > cor(6)) then model='Comm Env (c2)' frat(5)=1.0d0 end if n=0 call inicov(3, 6, r) do i=1, 6 if (npairs(i) > 0) then x(1)=rel(i) x(2)=frat(i) x(3)=cor(i) corr=1.0d0 if (i==3 .or. i > 4 ) corr=2.0d0 n=n+npairs(i)/int(corr) if (stderr(i) == 0.0d0) then vweight=1.0d0-cor(i)*cor(i) vweight=corr*vweight*vweight/dble(npairs(i)) else vweight=stderr(i)*stderr(i) end if call givenc(r, 6, 3, x, vweight, ifail) end if end do call alias(r, 6, 3, 1.0d-15, x, ifail) call bsub(r, 6, 3, b, 2, ifail) call var(r, 6, cov, 6, 3, n, 1, ifail) write(outstr,'(/a)') 'WLS estimates of heritability (approx SE)' write(outstr,'(2(/2a,f10.4,a,f6.4,a)/)') & 'Heritability ','= ', b(1), ' (', sqrt(cov(1)), ')', & model ,'= ', b(2), ' (', sqrt(cov(3)), ')' end subroutine wlscor ! ! MFT ! subroutine domft(trait, prevalence, logrid, higrid, gridstep, & dataset, mlik, mpar, herit, iter, typ, plevel) use interrupt use outstream use ped_class use ibd_class use statfuns use mftcontrol use mftfuns implicit none integer, intent(in) :: trait double precision, intent(in) :: prevalence double precision, intent(in) :: logrid double precision, intent(in) :: higrid double precision, intent(in) :: gridstep type (ped_data), intent(inout) :: dataset double precision, intent(out) :: mlik integer, intent(out) :: mpar double precision, intent(out) :: herit integer, intent(in) :: iter integer, intent(in) :: typ ! 1=AE 2=CE integer, intent(in) :: plevel integer, parameter :: MISS=-9999 ! MFT work arrays double precision, dimension(:), allocatable :: correl, low, up integer, dimension(:), allocatable :: infin integer :: maxpts double precision :: mcerr, h2, lik, prev, step, thresh double precision, dimension(:), allocatable :: gridpar, gridlik, & lowlik, upplik, varwt integer :: i, ift, igrid, j, n, ngrid, nn, num, pedoffset, ped, pos integer :: naff, ntot character (len=2), dimension(2) :: model = (/ 'h2', 'c2' /) ! functions double precision :: ln interface subroutine kinship(ped, dataset, kin) use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(in) :: dataset double precision, dimension(:), intent(inout) :: kin end subroutine kinship end interface mcerr=0.0d0 herit=0.0d0 mpar=1 mlik=0.0d0 naff=0 ntot=0 dataset%untyped=.true. do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset do i=pedoffset+1, dataset%num(ped) if (dataset%plocus(i,trait) /= MISS) then ntot=ntot+1 dataset%untyped=.false. if (dataset%plocus(i,trait) == 2.0d0) naff=naff+1 end if end do end if end do if (ntot < 2 .or. naff == 0 .or. naff == ntot) then write(outstr,'(/a)') 'No eligible cases!' return end if if (prevalence /= MISS) then prev=prevalence else prev=dble(naff)/dble(ntot) end if thresh=ppnd(1.0d0-prev) ngrid=11 if (gridstep >= 1.0d0 .and. gridstep > (higrid-logrid)) then ngrid=int(gridstep)+1 step=(higrid-logrid)/dble(max(1,ngrid-1)) else ngrid=max(1,int((higrid-logrid)/gridstep)+1) step=gridstep end if allocate(gridlik(ngrid), lowlik(ngrid), upplik(ngrid), & gridpar(ngrid), varwt(ngrid)) gridlik=0.0d0 lowlik=0.0d0 upplik=0.0d0 h2=logrid do igrid=1, ngrid-1 gridpar(igrid)=h2 h2=h2+step end do gridpar(ngrid)=min(0.99d0, higrid) n=dataset%maxact nn=n*(n-1)/2 allocate(correl(nn), low(n), up(n)) allocate(infin(n)) allocate(a(n*(n+1)/2)) a=1.0d0 write(outstr,'(a,f6.4)') 'Prevalence = ', prev if (plevel > 1) then write(outstr,'(/3a/a)') & 'Pedigree Size ', model(typ), ' lik error ift', & '-------------- ----- ----- --------------- ------------- ---' end if do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset n=0 do i=pedoffset+1, dataset%num(ped) if (dataset%plocus(i,trait) /= MISS) then n=n+1 low(n)=thresh up(n)=thresh if (dataset%plocus(i,trait) == 1.0d0) then infin(n)=0 else if (dataset%plocus(i,trait) == 2.0d0) then infin(n)=1 end if end if end do if (typ == 1) then call kinship(ped, dataset, a) end if ! mecdf and mvndst expect lower triangle do igrid=1, ngrid h2=gridpar(igrid) nn=0 pos=1 do i=2, num if (.not.dataset%untyped(pedoffset+i)) then do j=1, i-1 if (.not.dataset%untyped(pedoffset+j)) then nn=nn+1 correl(nn)=h2*a(pos+j) end if end do end if pos=pos+i end do if (mftalgo == 1) then call mecdf(n, low, 2*infin-1, correl, lik, ift) if (ift == -1) then write(outstr,'(3a)') & 'NOTE: Pedigree ', trim(dataset%pedigree(ped)),' too large to integrate.' else if (ift > 0) then write(outstr,'(3a)') & 'NOTE: Mendel-Elston approximation failed for pedigree', & trim(dataset%pedigree(ped)),'.' end if else call mvndst(n, low, up, infin, correl, & mfteval*n, abseps, releps, mcerr, lik, ift) if (ift == 2) then write(outstr,'(3a)') & 'NOTE: Pedigree ', trim(dataset%pedigree(ped)),' too large to integrate.' else if (ift == 1) then write(outstr,'(3a/7x,a)') & 'NOTE: Exceeded maximum number of evaluations for pedigree ', & trim(dataset%pedigree(ped)), '.', 'Consider increasing "iter".' end if end if gridlik(igrid)=gridlik(igrid)+ln(lik) lowlik(igrid)=lowlik(igrid)+ln(lik-mcerr) upplik(igrid)=upplik(igrid)+ln(lik+mcerr) if (plevel > 1) then write(*,'(a14,1x,i5,1x,f5.3,2(1x,g14.6),1x,i1)') & dataset%pedigree(ped), n, h2, lik, mcerr, ift end if end do end if end do deallocate(a) if (plevel > -1) then write(outstr,'(/3x,a,5x,a,12x,a)') model(typ), 'logLik','99% Interval' do igrid=1, ngrid if (gridlik(igrid) > mlik .or. mlik == 0) then mlik=gridlik(igrid) herit=gridpar(igrid) end if write(outstr,'(f5.3,3(1x,g14.6))') & gridpar(igrid), gridlik(igrid), lowlik(igrid), upplik(igrid) end do end if if (mftalgo == 1) then varwt=1.0d0 else varwt=abs(lowlik-upplik) end if call polyinter(4, ngrid, gridlik, gridpar, varwt, h2, lik, plevel) if (h2 <= 1.0d0 .and. h2 >= 0.0d0 .and. lik /= 0.0d0 .and. lik > mlik) then mlik=lik herit=h2 end if if (plevel > -1) then write(outstr,'(/f5.3,1x,g14.6)') h2, lik end if end subroutine domft ! ! Variance components analysis ! subroutine sibqtl(tranam, trait, locnam, gene, & allele_buffer, dataset, pval, plevel, invalg, toler) use interrupt use outstream use alleles_class use ped_class use ibd_class use AS319 use likelihoods use varmet_optimizer use statfuns implicit none character (len=*), intent(inout) :: tranam integer, intent(inout) :: trait character (len=*), intent(inout) :: locnam integer, intent(in) :: gene type (allele_data) :: allele_buffer type (ped_data), intent(inout) :: dataset double precision, intent(out) :: pval integer, intent(in) :: plevel integer, intent(in) :: invalg double precision, dimension(3), intent(in) :: toler ! integer, parameter :: KNOWN=0, MISS=-9999 double precision, parameter :: gradtl = 1.0D-12 ! variance components model parameter estimates integer :: npar double precision, dimension(4) :: parest integer, dimension(dataset%maxsiz,2), target :: set ! local variables integer :: currf, currm, fam, fin, funeval, gen2, i, ii, ier, & j, k, maxfn, maxsiz, nn, nobs, npairs, num, & ped, pedoffset, pos, totobs character (len=3) :: histo double precision :: aelik, aqelik, d2, lod, ymean, yvar ! functions character (len=6) :: pstring interface subroutine kinship(ped, dataset, kin) use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(in) :: dataset double precision, dimension(:), intent(inout) :: kin end subroutine kinship end interface interface subroutine nucibd(gene, setoffset, fa, mo, sta, fin, set, untyped, allele_buffer, ibd) use alleles_class integer, intent(in) :: gene integer, intent(in) :: setoffset integer, intent(in) :: fa, mo integer, intent(in) :: sta, fin integer, dimension(:,:), intent(in) :: set logical, dimension(:), intent(in) :: untyped type (allele_data), intent(in) :: allele_buffer double precision, dimension(:), intent(inout) :: ibd end subroutine nucibd end interface ! if (plevel > 0) then write(outstr,'(/a/5a/a)') & '-----------------------------------------------------', & 'VC linkage analysis for "', trim(tranam), '" v "' , trim(locnam), '"', & '-----------------------------------------------------' end if ! pval=1.0d0 funeval=0 gen2=gene+1 maxsiz=0 vc_invalg=invalg vc_nfix=1 nfam=0 npar=4 npairs=0 totobs=0 ymean=0.0D0 yvar=0.0D0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset do i=pedoffset+1, dataset%num(ped) if (observed(i, gene, dataset)) then dataset%untyped(i)=.false. else dataset%untyped(i)=.true. end if end do ! full sibs fin=dataset%num(ped) currf=dataset%fa(fin) currm=dataset%mo(fin) do k=dataset%num(ped)-1, pedoffset+dataset%nfound(ped), -1 if (dataset%fa(k) /= currf .or. dataset%mo(k) /= currm) then nobs=0 do i=k+1,fin if (dataset%plocus(i,trait) /= MISS .and. .not.dataset%untyped(i)) then nobs=nobs+1 end if end do if (nobs > 0) then nfam=nfam+1 totobs=totobs+nobs npairs=npairs+nobs*(nobs-1)/2 maxsiz=max(maxsiz, fin-k) end if ! now update to next sibship fin=k currf=dataset%fa(fin) currm=dataset%mo(fin) end if end do end if end do ! copy data across to ibd_data structures if (npairs == 0) then if (plevel > 0) then write(outstr,'(2(/a,i5))') & 'Number of sibships = ', nfam, & 'Number of observations = ', totobs else if (plevel > -2) then write(outstr,'(a14,1x,i6,3x,a,4x,f10.1,2(1x,f6.4),1x,i6,2(1x,a))') & locnam, npairs, '-', 0.0, 1.0d0, 1.0d0, 0, 'VC ', ' ' end if return end if allocate(families(nfam)) allocate(m(maxsiz)) allocate(a(maxsiz*(maxsiz+1)/2), c(maxsiz*(maxsiz+1)/2)) ! fam=0 totobs=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset i=0 do ii=pedoffset+1, dataset%num(ped) i=i+1 if (observed(ii, gene, dataset)) then call get_namedgeno(ii, gene, gen2, dataset, allele_buffer, & set(i,1), set(i,2)) else set(i,1)=MISS set(i,2)=MISS end if end do ! full sibs fin=dataset%num(ped) currf=dataset%fa(fin) currm=dataset%mo(fin) do k=dataset%num(ped)-1, pedoffset+dataset%nfound(ped), -1 if (dataset%fa(k) /= currf .or. dataset%mo(k) /= currm) then nobs=0 do i=k+1, fin if (dataset%plocus(i,trait) /= MISS .and. .not.dataset%untyped(i)) then nobs=nobs+1 end if end do ! reduce ibd matrix to that for phenotyped individuals only if (nobs > 0) then fam=fam+1 call setup_ibd(ped, nobs, 1, families(fam)) nobs=0 do i=k+1, fin if (dataset%plocus(i,trait) /= MISS .and. .not.dataset%untyped(i)) then nobs=nobs+1 totobs=totobs+1 families(fam)%yval(nobs)=dataset%plocus(i,trait) call moment(totobs, families(fam)%yval(nobs), ymean, yvar) end if end do ! kinships call filltri(nobs, nobs*(nobs+1)/2, families(fam)%a, 1.0D0, 0.5D0) ! ibds call nucibd(gene, pedoffset, currf, currm, k+1, fin, & set, dataset%untyped, allele_buffer, c) if (fin-k > nobs) then nn=0 pos=0 do i=k+1, fin do j=k+1, i pos=pos+1 if (dataset%plocus(i,trait) /= MISS .and. .not.dataset%untyped(i) .and. & dataset%plocus(j,trait) /= MISS .and. .not.dataset%untyped(j)) then nn=nn+1 families(fam)%c(nn)=c(pos) end if end do end do else nn=nobs*(nobs+1)/2 families(fam)%c=c(1:nn) end if end if ! now update to next sibship fin=k currf=dataset%fa(fin) currm=dataset%mo(fin) end if end do end if end do ! ! plug in starting values and iterate for MLEs ! yvar=yvar/dble(totobs) maxfn=5000 ! npar=3 parest(1)=ymean parest(2)=0.1D0*yvar parest(3)=0.9D0*yvar ! aelik=0.0D0 vc_typ=1 call varmet('mvn', mvnlik, npar, parest, aelik, gradtl, toler(1), maxfn, ier, plevel) funeval=max(funeval, ifn) if (ier /= 0) call vmerr(ier, maxfn) aelik=mvnlik('AE lik', npar, parest) ! npar=4 vc_typ=2 parest(4)=abs(parest(3)) parest(3)=0.1D0*abs(parest(2)) parest(2)=0.9D0*abs(parest(2)) aqelik=0.0D0 call varmet('mvn', mvnlik, npar, parest, aqelik, gradtl, toler(1), maxfn, ier, plevel) funeval=max(funeval, ifn) if (ier /= 0) call vmerr(ier, maxfn) ! aqelik=mvnlik('AQE lik', npar, parest) d2=aelik-aqelik lod=0.217142D0*d2 pval=chip(d2,1) ! parest(2)=abs(parest(2)) parest(3)=abs(parest(3)) parest(4)=abs(parest(4)) yvar=100.0D0/(parest(2)+parest(3)+parest(4)) if (plevel > 0) then write(outstr,'(2(/a,i5))') & 'Number of sibships = ', nfam, & 'Number of observations = ', totobs write(outstr,'(a,f12.6,3(/a,f12.6,a,f5.1,a))') & 'Trait mean = ', parest(1), & 'Additive genetic variance = ', parest(2), ' (',parest(2)*yvar,'%)', & 'QTL genetic variance = ', parest(3), ' (',parest(3)*yvar,'%)', & 'Environmental variance = ', parest(4), ' (',parest(4)*yvar,'%)' write(outstr,'(a,f8.2,4x,a,f5.2,a/a,i5)') & 'Linkage chi-square (lod) = ', d2, ' (', lod, ')', & 'Total function evaluations = ', funeval else if (plevel > -2) then call phist(pval,1.0D0,histo) write(outstr,'(a20,1x,i6,3x,a,4x,f10.1,1x,a,1x,f6.4,1x,i6,2(1x,a))') & locnam, npairs, '-', lod, pstring(pval), 1.0D0, 0, 'VC ',histo end if deallocate(a, c, m) deallocate(families) end subroutine sibqtl ! ! Variance components analysis ! modtyp 1=MVN 2=MFT 3=MFT_BOBYQA ! typ 1=CE 2=AE 3=ACE 4=ADE ! 5=AQE (6=AQE emp kin for Q) ! 7=CQE (8=AQE ibd inline in script) ! 9=QE (emp kin for Q) ! subroutine varcom(modtyp, nterms, terms, nloci, loc, loctyp, locpos, & gene, genemod, allele_buffer, & nmark, mark, dataset, & totobs, mlik, mpar, pval, plevel, burnin, iter, typ, & invalg, optim, toler) use interrupt use outstream use alleles_class use ped_class use ibd_class use kinship_io use covariate_data use AS164_class use AS319 use likelihoods use varmet_optimizer use bobyqa_optimizer use statfuns use mftcontrol use glm_types implicit none integer, intent(in) :: modtyp ! model class 1=Gaussian 2=MFT integer, intent(in) :: nterms ! no. variables in model integer, dimension(:), intent(in) :: terms ! variable integer, intent(in) :: nloci ! total no. loci character (len=20), dimension(:), intent(in) :: loc ! all locus names integer, dimension(:), intent(in) :: loctyp ! locus types integer, dimension(:), intent(in) :: locpos ! locus column integer, intent(in) :: gene ! marker as covariate integer, intent(in) :: genemod ! allelic or genotypic model type (allele_data) :: allele_buffer ! covariate marker information integer, intent(in) :: nmark ! number of markers for ibd estimate integer, dimension(:), intent(in) :: mark ! markers for ibd estimate type (ped_data), intent(inout) :: dataset integer, intent(out) :: totobs ! number of contributing records double precision, intent(out) :: mlik integer, intent(out) :: mpar double precision, intent(out) :: pval integer, intent(in) :: plevel integer, intent(in) :: burnin integer, intent(in) :: iter integer, intent(inout) :: typ integer, intent(in) :: invalg integer, intent(in) :: optim double precision, dimension(3), intent(in) :: toler ! double precision :: gradtl = 1.0D-10, liktol = 0.1d0 integer, parameter :: MISS=-9999 ! list of useful pedigrees and numbers of usable records integer, dimension(dataset%nped) :: usedfams, usednobs ! variance components model parameter estimates integer :: npar double precision, dimension(:), allocatable :: parest, blpar, bupar ! marker information type (allele_data), dimension(:), pointer :: alleles ! levels of covariates type (variable_data) :: covariates ! if using big kinship matrix logical, dimension(dataset%nobs) :: active ! local variables integer :: ctwin, fam, i, icat, idf, ier, ii, funeval, j, k, m2, & maxfn, maxsiz, ncat, ncertain, nmodels, nmz, nn, nntot, nobs, & num, ped, pedoffset, pos, ppos, stand, tot, vpos, ypos integer :: g1, g2, geno, genelevels, opt character (len=3) :: allel, all2, histo character (len=3), dimension(9) :: ranmod = (/ & 'C ', 'A ', 'A+C', 'A+D', 'A+Q', 'A+Q', 'C+Q', ' ', 'G '/) character (len=20) :: label logical :: singlemodel, simple double precision :: adjust, ase, den, lik, lik_ae, lik_ae0, lik_e, domtest, & gentest, offset, res, val, va, vd, ve, wmean, wvar, & xscale, ymean, yscale, yscale2, yvar double precision :: lo95, up95 ! fixed effects for best model double precision, dimension(:), allocatable :: fixest double precision, dimension(:), allocatable :: vcvmat ! control variables for BOBYQA ! npt is number of interpolation conditions ! rhobeg and rhoend are initial and final trust region radiuses integer :: npt double precision :: rhobeg, rhoend ! work array for BOBYQA double precision, dimension(:), allocatable :: workmat ! functions character (len=6) :: pstring interface subroutine freq(gene, loctyp, fndr, dataset, allele_buffer) use ped_class use alleles_class integer, intent(in) :: gene integer, intent(in) :: loctyp integer, intent(in) :: fndr type (ped_data), intent(in) :: dataset type (allele_data), intent(inout) :: allele_buffer end subroutine freq subroutine markeribd(gene, iter, burnin, allele_buffer, & ped, dataset, ibdcount, ibdvar, plevel) use interrupt use pairlist_class use alleles_class use ped_class implicit none integer, intent(in) :: gene integer, intent(in) :: iter, burnin type (allele_data), intent(inout) :: allele_buffer integer, intent(in) :: ped type (ped_data), intent(inout) :: dataset double precision, dimension(:), intent(out) :: ibdcount double precision, dimension(:), intent(out) :: ibdvar integer, intent(in) :: plevel end subroutine markeribd subroutine kinship(ped, dataset, kin) use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(in) :: dataset double precision, dimension(:), intent(inout) :: kin end subroutine kinship subroutine frater(ped, dataset, kin, dom) use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(inout) :: dataset double precision, dimension(:), intent(inout) :: kin, dom end subroutine frater subroutine empkin(ped, dataset, kin, plevel) use interrupt use outstream use alleles_class use ped_class use locus_types use locus_data implicit none integer, intent(in) :: ped type (ped_data), intent(in) :: dataset double precision, dimension(:), intent(out) :: kin integer, intent(in) :: plevel end subroutine empkin subroutine thinibd(ped, dataset, nobs, ibd1, ibd2) use ped_class integer, intent(in) :: ped type (ped_data) :: dataset integer, intent(in) :: nobs double precision, dimension(:), intent(in) :: ibd1 double precision, dimension(:), intent(out) :: ibd2 integer :: i, ii, num, pedoffset, pos end subroutine thinibd subroutine vcprofile(modtyp, whichpar, vc_nfix, npar, parest, modlik, lo95, up95) use brent_vcdata integer, intent(in) :: modtyp, whichpar integer, intent(in) :: npar, vc_nfix double precision, dimension(:), intent(in) :: parest double precision, intent(in) :: modlik double precision, intent(out) :: lo95, up95 end subroutine vcprofile subroutine vcov(va, vq, ve, vcvmat) use AS319 use ibd_class use symmetric_matrix double precision, intent(in) :: va, vq, ve double precision, dimension(:), intent(out) :: vcvmat end subroutine vcov end interface ! if (((typ == 9 .or. typ < 5) .and. plevel > -2) .or. plevel > 0) then if (modtyp == GLM_BINOM) then write(outstr,'(/a/3a/a)') & repeat('-',48), & 'Multifactorial theshold model for "', trim(loc(terms(nterms))), '"', & repeat('-',48) else write(outstr,'(/a/3a/a)') & repeat('-',48), & 'Variance components analysis for "', trim(loc(terms(nterms))), '"', & repeat('-',48) end if end if genelevels=0 singlemodel=.false. if (typ > 128) then singlemodel=.true. typ=typ-128 end if vc_invalg=invalg call varlevels(ALL_OBS, gene, allele_buffer%numal, nterms, terms, & loc, loctyp, locpos, dataset, covariates, plevel) call xmeans(nterms, terms, nloci, loctyp, locpos, dataset, covariates) stand=1 opt=2 if (optim == 3) then opt=3 stand=2 end if if (stand == 2) then yscale=covariates%sds(covariates%totvars+1) end if vc_nfix=covariates%totvars+1 if (gene > 0) then if (genemod == 1) then genelevels=allele_buffer%numal-1 else genelevels=allele_buffer%numgtp-1 end if vc_nfix=vc_nfix+genelevels-1 end if if (nmark > 0) then allocate(alleles(nmark)) do j=1, nmark call freq(locpos(mark(j)), loctyp(mark(j)), 0, dataset, alleles(j)) end do end if ! ier=0 mftlik_plevel=plevel mftlik_nerrors=0 mftlik_interval=0.0d0 maxsiz=0 ncertain=0 nfam=0 nntot=0 npt=0 nmodels=0 nmz=0 simple=.false. tot=0 ypos=locpos(terms(nterms)) domtest=0.0D0 lik=0.0D0 lik_ae0=0.0D0 lik_ae=0.0D0 lik_e=0.0D0 lo95=0.0d0 up95=0.0d0 pval=1.0d0 adjust=0.0D0 ymean=covariates%means(covariates%totvars+1) yvar=covariates%sds(covariates%totvars+1)**2 yscale=1.0d0 yscale2=1.0d0 wmean=ymean wvar=yvar if (loctyp(terms(nterms)) == LOC_AFF) then adjust=1.0D0 else if (stand == 2) then adjust=ymean yscale=covariates%sds(covariates%totvars+1) yscale2=yscale*yscale wmean=0.0d0 wvar=1.0d0 end if do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset nobs=0 ctwin=MISS do i=pedoffset+1, dataset%num(ped) if (complete(.false., i, nterms, terms, locpos, loctyp, dataset)) then dataset%untyped(i)=.false. nobs=nobs+1 tot=tot+1 if (dataset%imztwin(i) /= MISS) then if (dataset%imztwin(i) /= ctwin) then nmz=nmz+1 ctwin=dataset%imztwin(i) end if end if else dataset%untyped(i)=.true. end if end do if (nobs > 0) then nfam=nfam+1 usedfams(nfam)=ped usednobs(nfam)=nobs maxsiz=max(maxsiz, num) end if end if end do ! copy data across to ibd_data structures allocate(families(nfam)) allocate(m(maxsiz)) m2=maxsiz*(maxsiz+1)/2 allocate(a(m2), c(m2), csd(m2)) allocate(censor(maxsiz)) if (nmark > 1) then allocate(mibd(nmark, m2), mibdsd(nmark, m2)) end if totobs=0 do fam=1, nfam ped=usedfams(fam) pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset nn=num*(num+1)/2 nntot=nntot+nn call setup_ibd(ped, usednobs(fam), vc_nfix, families(fam)) nobs=0 ii=pedoffset do i=1, num ii=ii+1 if (.not.dataset%untyped(ii)) then nobs=nobs+1 totobs=totobs+1 val=(dataset%plocus(ii,ypos)-adjust)/yscale families(fam)%yval(nobs)=val call fixeff(ii, nobs, 1, gene, genemod, allele_buffer, .false., & nterms, terms, nloci, loctyp, locpos, & covariates, dataset, families(fam)%vals, stand) end if end do ! load the random effects covariance matrices (a and c) if (typ == 9) then ier=has_kinmat() if (ier == 0) then if (plevel > 0) then write(outstr,'(a)') 'Using current kinship matrix.' end if active=.false. active((pedoffset+1):(pedoffset+num))= & .not.dataset%untyped((pedoffset+1):(pedoffset+num)) call get_kinship(dataset%nobs, totobs, active, a) call thinibd(ped, dataset, nobs, a, families(fam)%a) if (plevel > 2) then call print_ibd(families(fam)) end if else if (plevel > 1) then write(outstr,'(3a)') & 'Estimating empirical kinship (all active markers) for pedigree ', & trim(dataset%pedigree(ped)), '.' end if call empkin(ped, dataset, a, plevel) call thinibd(ped, dataset, nobs, a, families(fam)%a) end if else if (typ == 1 .or. typ == 7) then call filltri(nobs, nobs*(nobs+1)/2, families(fam)%a, 1.0D0, 1.0D0) else call kinship(ped, dataset, a) call thinibd(ped, dataset, nobs, a, families(fam)%a) end if ! if (typ == 1 .or. typ == 2 .or. typ == 9) then call filltri(nobs, nobs*(nobs+1)/2, families(fam)%c, 0.0D0, 0.0D0) else if (typ == 3) then call filltri(nobs, nobs*(nobs+1)/2, families(fam)%c, 1.0D0, 1.0D0) else if (typ == 4) then call frater(ped, dataset, a, c) call thinibd(ped, dataset, nobs, c, families(fam)%c) else if (typ == 5 .or. typ == 7) then if (plevel > 1) then write(outstr,'(a,i0,3a)') 'Estimating IBD at ', nmark, & ' markers for pedigree ', trim(dataset%pedigree(ped)), '.' end if if (nmark==1) then call markeribd(locpos(mark(1)), iter, burnin, alleles(1), & ped, dataset, c, csd, plevel-1) else do j=1, nmark call markeribd(locpos(mark(j)), iter, burnin, alleles(j), & ped, dataset, c, csd, plevel-1) do k=1, nn mibd(j,k)=c(k) mibdsd(j,k)=csd(k) end do end do do k=1, nn c(k)=0.0d0 csd(k)=-1.0d0 do j=1, nmark if (mibdsd(j,k)==0.0d0) then ncertain=ncertain+1 c(k)=mibd(j,k) csd(k)=mibdsd(j,k) exit end if end do end do do k=1, nn if (csd(k)==-1.0d0) then res=0.0d0 den=0.0d0 do j=1, nmark den=den+1.0d0/mibdsd(j,k) end do den=1.0d0/den do j=1, nmark res=res+den*mibd(j,k)/mibdsd(j,k) end do c(k)=res end if end do end if call thinibd(ped, dataset, nobs, c, families(fam)%c) else if (typ == 6) then if (plevel > 1) then write(outstr,'(3a)') & 'Estimating empirical kinship (all active markers) for pedigree ', & trim(dataset%pedigree(ped)), '.' end if call empkin(ped, dataset, c, plevel) call thinibd(ped, dataset, nobs, c, families(fam)%c) write(outstr,'(a)') 'Comparing A to Q' j=0 do i=1, (nobs*(nobs+1)/2) if (a(i) /= c(i)) then j=j+1 end if end do write(outstr,'(a,i0,a)') 'A and Q differ at ', j, ' values.' else if (typ == 8) then if (plevel > 1) then write(outstr,'(4a)') & 'Reading empirical kinship matrix from standard input for ', & 'pedigree ', trim(dataset%pedigree(ped)), '.' end if read(*,*) c(1:nn) call thinibd(ped, dataset, nobs, c, families(fam)%c) end if end do ! generate starting values for fixed effects call covreg() if (((typ == 9 .or. typ < 5) .and. plevel > -2) .or. plevel > 0) then if (vc_nfix > 1) then write(outstr, '(3a)', advance='no') ' Fixed: ', & trim(loc(terms(nterms))), ' ~ mu' do j=1, nterms-1 write(outstr,'(2a)', advance='no') ' + ', trim(loc(terms(j))) if (terms(j) == gene) then write(outstr,'(a)', advance='no') '(M)' end if end do write(outstr,*) end if write(outstr,'(2a)', advance='no') 'Random: ', ranmod(typ) if ((typ < 9 .and. typ > 4) .and. nmark > 0) then write(outstr,'(2a)', advance='no') '{', trim(loc(mark(1))) do j=2, nmark write(outstr,'(2a)', advance='no') '-', trim(loc(mark(j))) end do write(outstr,'(a)', advance='no') '}' end if write(outstr,'(/3(/a,i7))') & 'Number of families = ', nfam, & 'Number of MZ twinships = ', nmz, & 'Number of observations = ', tot if (nmark > 1) then write(outstr,'(a,f9.1,a)') & 'Rel pairs perfect IBD info = ', & dble(100*ncertain)/dble(nntot), '%' end if end if ! ! plug in starting values and iterate for MLEs ! npar=vc_nfix+3 allocate(parest(npar), blpar(npar), bupar(npar)) allocate(fixest(vc_nfix)) allocate(vcvmat(vc_nfix*(vc_nfix+1)/2)) if (opt == 3) then bobyqa_liktyp=modtyp npar=vc_nfix+3 npt=2*npar+1 if (modtyp == GLM_GAUSS) then rhobeg=toler(2) rhoend=toler(3) else rhobeg=2*toler(2) rhoend=50.0d0*toler(3) end if allocate(workmat((npt+5)*(npt+npar)+3*npar*(npar+5)/2)) do i=1, npar blpar(i)=-1.0d99 bupar(i)=+1.0d99 end do end if if (vc_nfix > 1) then do i=1, vc_nfix parest(i)=b(i) end do else if (modtyp == GLM_GAUSS) then parest(1)=wmean else parest(1)=ppnd(1.0d0-ymean) end if if (plevel > 1) then write(outstr,'(a,f9.4)') ' Observed mean = ', ymean write(outstr,'(a,f9.4)') ' Intercept = ', parest(1) end if end if ! ! variance components starting values based on AE model ! if (plevel > 1) then write(outstr,'(/a/)') 'Base Model generating starting values.' end if vc_typ=1 funeval=0 maxfn=5000 if (modtyp == GLM_GAUSS) then npar=vc_nfix+1 parest(npar)=0.5d0*wvar npar=npar+1 parest(npar)=0.5d0*wvar blpar(npar)=0.0001d0 bupar(npar)=0.9999d0*wvar if (opt == 2) then call varmet('mvn', mvnlik, npar, parest, lik_ae0, & gradtl, toler(1), maxfn, ier, plevel) else if (opt == 3) then npt=2*npar+1 call bobyqa(npar, npt, parest, blpar, bupar, rhobeg, rhoend, plevel, maxfn, workmat) lik_ae0 = mvnlik('AE lik', npar, parest) ifn=bobyqa_funeval end if else npar=vc_nfix+1 parest(npar)=0.5d0 blpar(npar)=0.0001d0 bupar(npar)=99.999d0 if (opt == 2) then call varmet('mft', mftlik, npar, parest, lik_ae0, & gradtl, toler(1), maxfn, ier, plevel) else if (opt == 3) then npt=2*npar+1 call bobyqa(npar, npt, parest, blpar, bupar, rhobeg, rhoend, plevel, maxfn, workmat) lik_ae0 = mftlik('mft', npar, parest) ifn=bobyqa_funeval end if end if ! funeval=0 maxfn=5000 ! ADE if (typ > 2 .and. typ < 9) then vc_typ=2 nmodels=nmodels+1 ! if (plevel > 1) then write(outstr,'(/a/)') '2 variance components model' end if if (modtyp == GLM_GAUSS) then npar=npar+1 parest(npar)=parest(npar-1) blpar(npar)=0.0001d0 bupar(npar)=0.9999d0*wvar parest(npar-1)=0.0001d0 if (opt == 2) then call varmet('mvn', mvnlik, npar, parest, lik, gradtl, toler(1), maxfn, ier, plevel) else if (opt == 3) then npt=2*npar+1 call bobyqa(npar, npt, parest, blpar, bupar, rhobeg, rhoend, plevel, maxfn, workmat) lik = mvnlik('ADE', npar, parest) ifn=bobyqa_funeval end if else npar=npar+1 parest(npar)=0.0d0 blpar(npar)=0.0000d0 bupar(npar)=0.9999d0 if (opt == 2) then call varmet('mft', mftlik, npar, parest, lik, gradtl, toler(1), maxfn, ier, plevel) else if (opt == 3) then npt=2*npar+1 call bobyqa(npar, npt, parest, blpar, bupar, rhobeg, rhoend, plevel, maxfn, workmat) lik = mvnlik('MVN', npar, parest) ifn=bobyqa_funeval end if end if funeval=max(funeval, ifn) ! if (ier /= 0) call vmerr(ier, maxfn) ! if (modtyp == GLM_GAUSS) then lik = mvnlik('mvnlik', npar, parest) else lik = mftlik('mftlik',npar, parest) end if fixest=parest(1:vc_nfix) if (modtyp == GLM_GAUSS) then va=abs(parest(vc_nfix+1)) vd=abs(parest(vc_nfix+2)) ve=abs(parest(vc_nfix+3)) ! starting values for AE run parest(vc_nfix+1)=va+vd parest(vc_nfix+2)=ve else va=abs(parest(vc_nfix+1))/(1.0d0+abs(parest(vc_nfix+1))) vd=abs(parest(vc_nfix+2))/(1.0d0+abs(parest(vc_nfix+2))) ve=1.0d0-va-vd end if end if ! AE if (.not.singlemodel .or. nmodels == 0) then if (plevel > 1) then write(outstr,'(/a/)') 'AE Model' end if nmodels=nmodels+1 vc_typ=1 if (modtyp == GLM_GAUSS) then npar=vc_nfix+2 if (opt == 2) then call varmet('mvn', mvnlik, npar, parest, lik_ae, gradtl, toler(1), maxfn, ier, plevel) else if (opt == 3) then npt=2*npar+1 blpar(npar)=0.0001d0 bupar(npar)=0.9999d0*wvar call bobyqa(npar, npt, parest, blpar, bupar, rhobeg, rhoend, plevel, maxfn, workmat) lik_ae = mvnlik('AE lik', npar, parest) ifn=bobyqa_funeval end if else npar=vc_nfix+1 if (opt == 2) then call varmet('mft', mftlik, npar, parest, lik_ae, gradtl, toler(1), maxfn, ier, plevel) else if (opt == 3) then npt=2*npar+1 call bobyqa(npar, npt, parest, blpar, bupar, rhobeg, rhoend, plevel, maxfn, workmat) lik_ae = mftlik('mft', npar, parest) ifn=bobyqa_funeval end if end if funeval=max(funeval, ifn) ! if (ier /= 0) call vmerr(ier, maxfn) ! if (typ > 2 .and. typ < 9) domtest=lik_ae-lik if (singlemodel) then lik=lik_ae fixest=parest(1:vc_nfix) vd=0.0D0 if (modtyp == GLM_GAUSS) then va=abs(parest(vc_nfix+1)) ve=abs(parest(vc_nfix+2)) else va=abs(parest(vc_nfix+1))/(1.0d0+abs(parest(vc_nfix+1))) ve=1.0d0-va end if end if if (abs(lik_ae - lik_ae0) > liktol) then write(outstr,'(/a,g14.6,a/7x,a,f14.6,a,f14.6)') & 'NOTE: Repeat runs of base model differed by ', & abs(lik_ae - lik_ae0), ':', & '-2*LL1 = ', lik_ae0, ' -2*LL2 = ', lik_ae if (modtyp == GLM_BINOM .and. mftalgo == 2) then write(outstr,'(7x,a)', advance='no') 'Interval for -2*LL2 =' write(outstr,*) mftlik_interval end if end if end if ! Choose simplest model to report if (.not.singlemodel) then if ((typ == 9 .or. typ < 5) .and. domtest <= 3.84D0) then if (modtyp == GLM_GAUSS) then simple=.true. lik = mvnlik('MVN',npar, parest) else simple=.true. lik = mftlik('MFT',npar, parest) end if fixest=parest(1:vc_nfix) vd=0.0D0 if (modtyp == GLM_GAUSS) then va=abs(parest(vc_nfix+1)) ve=abs(parest(vc_nfix+2)) call vcprofile(modtyp, vc_nfix+1, vc_nfix, npar, parest, lik_ae, lo95, up95) else va=abs(parest(vc_nfix+1))/(1.0d0+abs(parest(vc_nfix+1))) ve=1.0d0-va call vcprofile(modtyp, vc_nfix+1, vc_nfix, npar, parest, lik_ae, lo95, up95) end if else if (typ > 2) then npar=vc_nfix+3 else lik=lik_ae if (modtyp == GLM_GAUSS) then simple=.true. call vcprofile(modtyp, vc_nfix+1, vc_nfix, npar, parest, lik_ae, lo95, up95) else simple=.true. call vcprofile(modtyp, vc_nfix+1, vc_nfix, npar, parest, lik_ae, lo95, up95) end if end if ! test A(D)E v E if (modtyp == GLM_GAUSS .and. vc_nfix == 1) then lik_e = dble(tot)*(log(wvar)+1.0D0) else if (plevel > 1) then write(outstr,'(/a/)') 'E Model' end if vc_typ=0 if (modtyp == GLM_GAUSS) then if (opt == 2) then call varmet('mvn', mvnlik, npar, parest, lik_e, gradtl, toler(1), maxfn, ier, plevel) else if (opt == 3) then npt=2*npar+1 blpar(npar)=0.0001d0 bupar(npar)=1.9999d0*wvar call bobyqa(npar, npt, parest, blpar, bupar, rhobeg, rhoend, plevel, maxfn, workmat) lik_e = mvnlik('E lik', npar, parest) ifn=bobyqa_funeval end if else if (opt == 2) then call varmet('mft', mftlik, npar, parest, lik_e, gradtl, toler(1), maxfn, ier, plevel) else if (opt == 3) then npt=2*npar+1 call bobyqa(npar, npt, parest, blpar, bupar, rhobeg, rhoend, plevel, maxfn, workmat) lik_e = mftlik('mft', npar, parest) ifn=bobyqa_funeval end if end if funeval=max(funeval, ifn) end if gentest=lik_e-lik end if ! va=yscale2*va lo95=yscale2*lo95 up95=yscale2*up95 vd=yscale2*vd ve=yscale2*ve wvar=100.0D0/(va + vd + ve) pval=0.5d0*chip(domtest,1) ! if (((typ == 9 .or. typ < 5) .and. plevel > -2) .or. plevel > 0) then offset=0.0d0 ! rescale intercept if standardized variates if (stand == 2) then icat=0 ppos=2 offset=ymean do j=1, nterms-1 pos=terms(j) ncat=1 if (stand == 2 .and. loctyp(pos) == LOC_QUA) then offset=offset-fixest(ppos)*yscale*covariates%means(ppos-1)/covariates%sds(ppos-1) else if (pos == gene) then ncat=genelevels else if (loctyp(pos) == LOC_CAT) then icat=icat+1 ncat=covariates%martable(icat)%ncells-1 end if ppos=ppos+ncat end do end if ! icat=0 ppos=1 vpos=1 if (modtyp == GLM_BINOM) then write(outstr,'(2(/a,g14.6))') & 'Trait mean / intercept = ', fixest(ppos), & 'Trait prevalence = ', & zp(abs(fixest(ppos))/(1.0d0+abs(fixest(ppos)))) vcvmat=0.0d0 else call vcov(va, vd, ve, vcvmat) write(outstr,'(/a,g14.6,a,g14.6,a)') & 'Trait mean / intercept = ', yscale*fixest(ppos)+offset, & ' (ase=', yscale*sqrt(vcvmat(vpos)), ')' end if do j=1, nterms-1 pos=terms(j) ncat=1 xscale=1.0d0 if (stand == 2 .and. loctyp(pos) == LOC_QUA) then xscale=1.0d0/covariates%sds(ppos) end if if (pos == gene) then ncat=genelevels g1=1 g2=1 else if (loctyp(pos) == LOC_CAT) then icat=icat+1 ncat=covariates%martable(icat)%ncells-1 end if do k=1, ncat ppos=ppos+1 vpos=vpos+ppos label=loc(pos) if (pos == gene) then if (genemod == 1) then call wrall(allele_buffer%allele_names(k+1), allel) label=trim(label) // '*' // trim(adjustl(allel)) else g2=g2+1 if (g2 > allele_buffer%numal) then g1=g1+1 g2=g1 end if call wrall(allele_buffer%allele_names(g1), allel) call wrall(allele_buffer%allele_names(g2), all2) label=trim(label) // '*' // & trim(adjustl(allel)) // '/' // trim(adjustl(all2)) end if else if (ncat > 1) then write(allel, '(i3)') k+1 label=trim(label) // '*' // trim(adjustl(allel)) end if if (modtyp == GLM_GAUSS) then ase=sqrt(vcvmat(vpos)) write(outstr,'(3a,g14.6,a,g14.6,a,g9.2,a)') & 'Beta ',label , ' = ', xscale*yscale*fixest(ppos), & ' (ase=', xscale*yscale*ase, ', t=', fixest(ppos)/ase, ')' else write(outstr,'(3a,g14.6)') & 'Beta ',label , ' = ', xscale*yscale*fixest(ppos) end if end do end do if (typ /= 1 .and. typ /= 7) then write(outstr,'(/a,g14.6,a,f5.1,a)') & 'Additive genetic variance = ', va, ' (', va*wvar, '%)' if (simple) then write(outstr,'(a,g14.6,a,g14.6)') & '95% Profile likelihood CI = ', lo95, ' -- ', up95 end if else write(outstr,'(/a,g14.6,a,f5.1,a)') & 'Familial variance = ', va, ' (', va*wvar, '%)' if (simple) then write(outstr,'(a,g14.6,a,g14.6)') & '95% Profile likelihood CI = ', lo95, ' -- ', up95 end if end if if (npar == (vc_nfix+4-modtyp)) then if (typ == 4) then write(outstr,'(a,g14.6,a,f5.1,a)') & 'Dominance genetic variance = ', vd, ' (', vd*wvar, '%)' else if (typ >= 5 .and. typ < 9) then write(outstr,'(a,g14.6,a,f5.1,a)') & 'QTL genetic variance = ', vd, ' (', vd*wvar, '%)' else if (typ == 3) then write(outstr,'(a,g14.6,a,f5.1,a)') & 'Familial env variance = ', vd, ' (', vd*wvar, '%)' end if end if if (singlemodel) then if (plevel > -2) then write(outstr,'(a,g14.6)') & 'Model loglikelihood = ', -0.5D0*lik end if else write(outstr,'(a,g14.6,a,f5.1,a/a,g14.6)') & 'Environmental variance = ', ve, ' (', ve*wvar, '%)', & 'Model loglikelihood = ', -0.5D0*lik if (typ == 4) then write(outstr,'(/a,f10.2,4x,a,i1,a,f5.3,a)') & 'Chi-square testing VD=0 = ', domtest, ' (df=', 1, ', P=', pval, ')' else if (typ >= 5 .and. typ < 9) then write(outstr,'(/a,f10.2,4x,a,i1,a,f5.3,a)') & 'Chi-square testing VQ=0 = ', domtest, ' (df=', 1, ', P=', pval, ')' else if (typ == 3) then write(outstr,'(/a,f10.2,4x,a,i1,a,f5.3,a)') & 'Chi-square testing VC=0 = ', domtest, ' (df=', 1, ', P=', pval, ')' end if if (typ /= 1 .and. typ /= 7) then idf=npar-vc_nfix-1 if (modtyp == GLM_BINOM) idf=idf+1 write(outstr,'(/a,f10.2,4x,a,i1,a,f5.3,a)') & 'Chi-square testing VG=0 = ', gentest, & ' (df=', idf, ', P=', chip(gentest, idf), ')' else idf=npar-vc_nfix-1 if (modtyp == GLM_BINOM) idf=idf+1 write(outstr,'(/a,f10.2,4x,a,i1,a,f5.3,a)') & 'Chi-square testing VC=0 = ', gentest, & ' (df=', idf, ', P=', chip(gentest, idf), ')' end if write(outstr,'(a,i7)') 'Total function evaluations = ', funeval end if if (mftlik_nerrors > 0) then write(outstr,'(a/7x,a,i0,a)') & 'NOTE: MFT likelihood estimation error exceeded the ', & 'selected threshold for ', mftlik_nerrors, ' pedigrees.' end if else if (plevel > -1) then call phist(pval, 1.0D0, histo) write(outstr,'(a20,2(1x,i6),1x,f10.1,1x,a,1x,f6.4,1x,i6,2(1x,a))') & loc(mark(1)), nfam, tot, 0.217142D0*domtest, pstring(pval), 1.0D0, 0, 'VC ', histo do j=2, nmark write(outstr,'(a20,2(1x,i6))') loc(mark(j)), nfam, tot end do end if ! return model loglik for construction of LRTS mpar=npar mlik=lik deallocate(parest) if (opt == 3) then deallocate(blpar, bupar, workmat) end if deallocate(censor) deallocate(a, c, csd, m) if (nmark > 0) then if (nmark > 1) then deallocate(mibd, mibdsd) end if deallocate(alleles) end if deallocate(families) end subroutine varcom ! ! Regression analysis to generate starting values for varcom ! subroutine covreg() use AS164 use AS164_class use ibd_class ! local variables double precision, parameter :: delta=1.0d-5 double precision, parameter :: eps=1.0d-6 integer, parameter :: KNOWN=0, MISS=-9999 ! regression work arrays (b and cov are in AS164_class) double precision, dimension(:), allocatable :: x double precision, dimension(1) :: values ! ! local variables integer :: fam, i, ifail, nter, ncov ! ! allocate work arrays ! nter=families(1)%nvar+1 ncov=nter*(nter+1)/2 allocate(x(nter)) if (allocated(b)) then deallocate(b) deallocate(cov) end if if (allocated(r)) then deallocate(r) end if allocate(b(nter)) allocate(cov(ncov)) allocate(r(ncov)) call inicov(nter, ncov, r) do fam=1, nfam do i=1, families(fam)%nobs x(nter)=families(fam)%yval(i) x(1:(nter-1))=families(fam)%vals(i,1:(nter-1)) call givenc(r, ncov, nter, x, 1.0d0, ifail) end do end do call alias(r, ncov, nter, 1.0d-15, x, ifail) call bsub(r, ncov, nter, b, nter-1, ifail) end subroutine covreg ! ! Function to give profile likelihood for given parameter of MVN model ! subroutine vcprofile(modtyp, whichpar, vc_nfix, npar, parest, modlik, lo95, up95) use glm_types use brent_vcdata integer, intent(in) :: modtyp integer, intent(in) :: whichpar integer, intent(in) :: npar, vc_nfix double precision, dimension(:), intent(in) :: parest double precision, intent(in) :: modlik double precision, intent(out) :: lo95, up95 ! integer :: elig_par double precision :: brent, brent_proflik, brent_proflik_mft external :: brent_proflik, brent_proflik_mft ! Copy to work variables allocate(profpars(npar)) profpars(1:npar)=parest(1:npar) ppar=whichpar totpar=npar boundlik=modlik+3.84d0 ! get upper bound for VC estimation elig_par=vc_nfix+2 if (modtyp == GLM_BINOM) elig_par=elig_par-1 totvar=0.0d0 do i=vc_nfix+1, npar totvar=totvar+parest(i) end do ! Call brent if (whichpar == vc_nfix+1 .and. totpar == elig_par) then if (modtyp == GLM_GAUSS) then lo95=brent(0.0d0, parest(whichpar), brent_proflik, 0.001d0) up95=brent(parest(whichpar), totvar, brent_proflik, 0.001d0) else if (modtyp == GLM_BINOM) then totvar=1.0d0+totvar lo95=brent(0.0d0, parest(whichpar), brent_proflik_mft, 0.001d0) lo95=abs(lo95/(1.0d0+lo95)) up95=brent(parest(whichpar), totvar, brent_proflik_mft, 0.001d0) up95=abs(up95/(1.0d0+up95)) end if else lo95=0.0d0 up95=0.0d0 end if deallocate(profpars) end subroutine vcprofile ! ! Functions to give profile likelihood for A in AE model ! function brent_proflik(x) use brent_vcdata use likelihoods double precision :: brent_proflik double precision, intent(in) :: x double precision :: lik profpars(ppar)=x profpars(totpar)=totvar-x lik=mvnlik('Brent', totpar, profpars) brent_proflik=abs(lik-boundlik) end function brent_proflik ! function brent_proflik_mft(x) use brent_vcdata use likelihoods double precision :: brent_proflik_mft double precision, intent(in) :: x double precision :: lik profpars(ppar)=x profpars(totpar)=totvar-x lik=mftlik('mftlik', totpar, profpars) brent_proflik_mft=abs(lik-boundlik) end function brent_proflik_mft ! ! GLS model VCOV for fixed effects part of MVN mixed model ! subroutine vcov(va, vq, ve, vcvmat) use AS319 use ibd_class use symmetric_matrix double precision, intent(in) :: va, vq, ve double precision, dimension(:), intent(out) :: vcvmat ! local variables integer :: fam, i, ifault, nused, pos double precision :: quad, logdet double precision, dimension(vc_nfix*(vc_nfix+1)/2) :: faminf, totinf ! ifault=0 nused=0 totinf=0.0d0 ! do fam=1, nfam do i=1, families(fam)%ncov a(i)=families(fam)%a(i)*va+families(fam)%c(i)*vq end do pos=0 do i=1, families(fam)%nobs pos=pos+i a(pos)=a(pos)+ve end do if (vc_invalg == 0) then call syminv(a, families(fam)%nobs, c, logdet, ifault) else ifault=0 call geninv(a, families(fam)%nobs, c, logdet, i, ifault) end if if (ifault /= 0) then write(*,*) 'Problem inverting matrix:', a(1:5), '... IFAULT=', ifault else nused=nused+1 call quadxxm(families(fam)%nobs, vc_nfix, & families(fam)%vals, c, faminf) totinf=totinf+faminf end if end do if (nused > 0) then call syminv(totinf, vc_nfix, vcvmat, logdet, ifault) if (logdet == 0.0d0) then ifault=0 call addridge(vc_nfix, totinf, 1.01d0) call syminv(totinf, vc_nfix, vcvmat, logdet, ifault) end if else vcvmat=totinf end if end subroutine vcov ! ! Drop covariance matrix entries for unused records ! subroutine thinibd(ped, dataset, nobs, ibd1, ibd2) use ped_class integer, intent(in) :: ped type (ped_data) :: dataset integer, intent(in) :: nobs double precision, dimension(:), intent(in) :: ibd1 double precision, dimension(:), intent(out) :: ibd2 integer :: i, ii, num, pedoffset, pos pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset nn=num*(num+1)/2 if (nobs /= num) then nn=0 pos=0 ii=pedoffset do i=1, num ii=ii+1 if (.not.dataset%untyped(ii)) then do j=1, i if (.not.dataset%untyped(pedoffset+j)) then nn=nn+1 ibd2(nn)=ibd1(pos+j) end if end do end if pos=pos+i end do else ibd2(1:nn)=ibd1(1:nn) end if end subroutine thinibd ! ! Call to LINPACK routines to invert packed lower triangular symmetric matrix ! subroutine syminv(a, n, c, logdet, info) use LINPACK double precision, dimension(n*(n+1)/2), intent(in) :: a integer, intent(in) :: n double precision, dimension(n*(n+1)/2), intent(out) :: c double precision, intent(out) :: logdet integer :: info double precision, parameter :: lnten = 2.3025850929940459011d0 double precision, dimension(n,n) :: work double precision, dimension(2) :: det integer, dimension(n) :: ipivot double precision, dimension(n) :: w integer :: i, ii, j, lda ! unpack ii=0 do i=1, n do j=1, i-1 ii=ii+1 work(i,j)=a(ii) work(j,i)=a(ii) end do ii=ii+1 work(i,i)=a(ii) end do info=0 lda=n call dgefa (work, lda, n, ipivot, info) if (info == 0) then call dgedi (work, lda, n, ipivot, det, w, 11) end if ! pack result ii=0 do i=1, n do j=1, i ii=ii+1 c(ii)=work(i,j) end do end do logdet=0.0d0 if (det(1) > 0.0d0) then logdet=log(det(1))+lnten*det(2) end if end subroutine syminv ! ! Call to LINPACK routines to pseudo-invert packed lower triangular symmetric matrix ! subroutine geninv(a, n, c, logdet, matrank, info) use LINPACK double precision, dimension(n*(n+1)/2), intent(in) :: a integer, intent(in) :: n double precision, dimension(n*(n+1)/2), intent(out) :: c double precision, intent(out) :: logdet integer, intent(out) :: matrank integer :: info double precision, dimension(n,n) :: work, v double precision, dimension(n) :: w, s, e integer :: i, ii, j, k ! unpack ii=0 do i=1, n do j=1, i-1 ii=ii+1 work(i,j)=a(ii) work(j,i)=a(ii) end do ii=ii+1 work(i,i)=a(ii) end do info=0 k=0 matrank=n call matmpi (work,w,s,e,v,n,n,n,n,k,info) ! pack result and give approximate determinant matrank=k ii=0 logdet=0.0D0 do i=1, n do j=1, i ii=ii+1 c(ii)=work(i,j) end do if (c(ii) > 0.0d0) logdet=logdet-log(c(ii)) end do end subroutine geninv ! ! D. A. Harville. Use of the Gibbs sampler to invert large, possibly ! sparse, positive definite matrices. Linear Algebra and its ! Applications, 289:203-224, 1999. ! ! Proposal of Harville is Gibbs sampler using just (3) ! 1. Set arbitrary starting values for z, z* ! for instance z_i=0, z*_i=i ! 2. Sample Phi as a vector containing independent draws according ! with definition (5) and (6): ! (5) E(Phi)=0 (6) E(Phi[k]*Phi[l])=I*delta(k,l) ! 3. Update z, z* by using equations (3) ! (3) z_i[k] = Phi_i[k]/sqrt(c_ii) - ! Sum(z_j[k] c_ij, j=1,i-1)/c_ii - ! Sum(z_j[k-1] c_ij, j=i+1,n)/c_ii ! 4. p = p + 1 ! 5. Go to step 2 until abs(z'z*) < tol ! 6. Sample Phi as a vector containing independent draws according ! with definition (5) and (6) ! 7. Update z using equation (3) ! 8. Accumulate Cov(z) in s ! 9. Go to step 6 to compute the next round of iteration (B - p times) ! 10. Set the final estimate: Inv(C) = s/(B - p) ! subroutine gibinv(cov, n, invcov, logdet, iter, plevel) double precision, dimension(n*(n+1)/2), intent(in) :: cov integer, intent(in) :: n double precision, dimension(n*(n+1)/2), intent(out) :: invcov double precision, intent(out) :: logdet integer, intent(in) :: iter integer, intent(in) :: plevel ! double precision, parameter :: tol=1.0D-4 integer :: i, ii, it, j, nn double precision :: cz double precision, dimension(n) :: z, z2 ! nn=n*(n+1)/2 ! write(*,*) n, cov(1:nn) do i=1, n z(i)=0.0D0 z2(i)=dble(i) end do do i=1, nn invcov(i)=0.0D0 end do ! burn-in it=0 do it=it+1 if (plevel > 1) then write(*,*) 'Burnin ', it end if call oneinv(n, nn, cov, z) call oneinv(n, nn, cov, z2) cz=0.0D0 do i=1, n cz=cz+z(i)*z2(i) end do if (abs(cz) <= tol) exit end do ! main loop do it=1, 10*iter call oneinv(n, nn, cov, z) ii=0 do i=1, n do j=1, i ii=ii+1 invcov(ii)=invcov(ii)+(z(i)*z(j)-invcov(ii))/dble(it) end do end do if (plevel > 1) then write(*,*) 'It ', it end if end do ! Diagonal approximation to logdet ii=0 logdet=0.0D0 do i=1, n ii=ii+i logdet=logdet-log(invcov(ii)) end do ! write(*,*) n, invcov(1:nn) end subroutine gibinv ! ! One iteration of update of z ! subroutine oneinv(n, nn, cov, z) use rngs integer, intent(in) :: n integer, intent(in) :: nn double precision, dimension(nn), intent(in) :: cov double precision, dimension(n), intent(inout) :: z integer :: i, ii, j, k double precision :: res ! ii=0 do i=1, n res=0.0D0 do j=1, i-1 res= res + cov(ii+j)*z(j) end do k=ii+i do j=i+1, n res=res + cov(k+i)*z(j) k=k+j end do ii=ii+i z(i)=dble(randn())/sqrt(cov(ii)) - res/cov(ii) end do end subroutine oneinv ! ! Brent's one-dimensional minimizer ! ! The method used is a combination of golden section search and ! successive parabolic interpolation. Convergence is never much ! slower than that for a Fibonacci search. If F has a continuous ! second derivative which is positive at the minimum (which is not ! at AX or BX), then convergence is superlinear, and usually of the ! order of about 1.324.... ! ! INPUT PARAMETERS ! ! AX (real) left endpoint of initial interval ! BX (real) right endpoint of initial interval ! F Real function of the form REAL FUNCTION F(X) which evaluates ! F(X) for any X in the interval (AX,BX) ! Must be declared EXTERNAL in calling routine. ! TOL (real) desired length of the interval of uncertainty of the ! final result ( .ge. 0.0) ! ! OUTPUT PARAMETERS ! ! FMIN abcissa approximating the minimizer of F ! AX lower bound for minimizer ! BX upper bound for minimizer ! function brent(ax, bx, f, tol) double precision :: brent double precision, intent(in) :: ax, bx, tol double precision :: f ! double precision :: a,b,c,d,e,eps,xm,p,q,r,tol1,tol2,u,v,w double precision :: fu,fv,fw,fx,x ! C is the squared inverse of the golden ratio c = 0.5d0*(3.0d0 - sqrt(5.0d0)) ! EPS is approximately the square root of the relative machine precision. eps = 1.0d0 do eps = eps/2.0d0 tol1 = 1.0d0 + eps if (tol1 <= 1.0d0) exit end do eps = sqrt(eps) ! ! initialization ! a = ax b = bx v = a + c*(b - a) w = v x = v d = 0.0d0 e = 0.0d0 fx = f(x) fv = fx fw = fx ! ! main loop ! do xm = 0.5d0*(a + b) tol1 = eps*abs(x) + tol/3.0d0 tol2 = 2.0d0*tol1 ! check stopping criterion if (abs(x - xm) <= (tol2 - 0.5d0*(b - a))) exit ! is golden-section necessary if (abs(e) < tol1) go to 40 ! fit parabola r = (x - w)*(fx - fv) q = (x - v)*(fx - fw) p = (x - v)*q - (x - w)*r q = 2.0d0*(q - r) if (q .gt. 0.0d0) p = -p q = abs(q) r = e e = d ! is parabola acceptable if (abs(p) >= abs(0.5d0*q*r)) go to 40 if (p <= q*(a - x)) go to 40 if (p >= q*(b - x)) go to 40 ! a parabolic interpolation step d = p/q u = x + d ! F must not be evaluated too close to AX or BX if ((u - a) < tol2) d = sign(tol1, xm - x) if ((b - u) < tol2) d = sign(tol1, xm - x) go to 50 ! a golden-section step 40 continue if (x .ge. xm) e = a - x if (x .lt. xm) e = b - x d = c*e ! F must not be evaluated too close to X 50 continue if (abs(d) >= tol1) u = x + d if (abs(d) < tol1) u = x + sign(tol1, d) fu = f(u) ! update A, B, V, W, and X if (fu .le. fx) then if (u >= x) a = x if (u < x) b = x v = w fv = fw w = x fw = fx x = u fx = fu else if (u<x) a=u if (u>=x) b=u if (fu<=fw .or. w==x) then v = w fv = fw w = u fw = fu else if (fu<=fv .or. v==x .or. v==w) then v = u fv = fu end if end if end do brent = x end function brent ! ! Charles Reeve's Fibonacci search from STSPAC ! converted to modern Fortran, with fibonacci array dynamically allocated ! replacing REAL with double precision throughout !----------------------------------------------------------------------- ! FIBMIN WRITTEN BY CHARLES P. REEVE, STATISTICAL ENGINEERING ! DIVISION, NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, ! MARYLAND 20899 ! ! FOR: COMPUTING THE X VALUE (XMIN) AT WHICH THE FUNCTION FUNC(X) IS ! MINIMAL IN THE INTERVAL [XLO,XHI]. IN THAT INTERVAL FUNC IS ! ASSUMED TO BE UNIMODAL. THE TOLERANCE ON XMIN (TOL) MUST BE ! SPECIFIED. THE FUNCTION VALUE AT XMIN (FXMIN) IS RETURNED. ! THE MINIMUM IS FOUND USING A FIBONACCI SEARCH ALGORITHM. ! ! NOTE: IF TOL < [XHI-XLO]/[THE JX(TH) FIBONACCI NUMBER], THEN JX ! SHOULD BE INCREASED. THE 100(TH) FIBONACCI NUMBER IS ABOUT ! 3.5E+20. ! ! SUBPROGRAMS CALLED: -NONE- ! ! CURRENT VERSION COMPLETED AUGUST 12, 1988 !----------------------------------------------------------------------- subroutine fibmin (func, xlo, xhi, tol, xmin, fxmin) double precision :: func double precision, intent(in) :: xlo, xhi double precision, intent(in) :: tol double precision, intent(out) :: xmin, fxmin double precision, parameter :: lphi = 0.4812118d0, sq5 = 2.36068d0 integer, dimension(:), allocatable :: ifib integer :: i, j, k, l, m, n double precision :: bound, delta, xrange xrange = xhi-xlo bound = xrange/tol n=nint(log(sq5+bound)/lphi)+1 allocate(ifib(n)) ifib(1)=1 ifib(2)=1 do j=3, n ifib(j) = ifib(j-2)+ifib(j-1) end do delta = xrange/dble(ifib(j)) c1 = xlo c2 = delta k = 0 m = ifib(j-2) n = ifib(j-1) l = ifib(j) f1 = func(xlo) f2 = func(xhi) i = j-2 do i = i-1 if (i < 1) exit f1 = func(c1+c2*dble(m)) f2 = func(c1+c2*dble(n)) if (f1 == f2) then k = m l = n i = i-2 if (i < 1) exit m = k+ifib(i) n = k+l-m f3 = func(c1+c2*dble(m)) if (f3 >= f1) exit f4 = func(c1+c2*dble(n)) if (f4 >= f1) exit else if (f1 > f2) then k = m m = n n = k+l-m else l = n n = m m = k+l-n end if end do fbmin = 0.5d0*dble(k+l) xmin = c1+c2*fbmin fxmin = func(xmin) return end subroutine fibmin ! ! Fit curve and interpolates maximum of y ! Passes coefficients to brent_interp using AS164_class ! subroutine polyinter(idegree, nvals, yval, xval, varwt, maxx, maxy, plevel) use outstream use AS164 use AS164_class integer, intent(in) :: idegree integer, intent(in) :: nvals double precision, dimension(nvals), intent(in) :: yval, xval, varwt double precision, intent(out) :: maxx, maxy integer, intent(in) :: plevel integer :: nfix, nter, ncov double precision, parameter :: zero = 0.0d0 double precision, dimension(:), allocatable :: x integer :: i double precision :: xv ! functions double precision :: brent, brent_inter external :: brent, brent_inter maxx=xval(1) maxy=yval(1) if (nvals == 1 .or. idegree < 2) return nfix=idegree+1 nter=nfix+1 ncov=nter*(nter+1)/2 call clean_AS164() AS164_nterms=nter allocate(b(nfix), x(nter), cov(ncov), r(ncov)) call inicov(nter, ncov, r) do i= 1, nvals x(1)=1.0d0 xv=xval(i) x(2)=xv do j=2, idegree x(j+1)=xv*x(j) end do x(nter)=yval(i) call givenc(r, ncov, nter, x, varwt(i), ifail) end do call alias(r, ncov, nter, 1.0d-15, x, ifail) call bsub(r, ncov, nter, b, nter-1, ifail) call var(r, ncov, cov, ncov, nter, nobs, 1, ifail) maxx=brent(0.0d0, 1.0d0, brent_inter, 0.001d0) maxy=-brent_inter(maxx) if (plevel > 1) then write(outstr,'(/a,6(1x,g14.6):)') & 'Regression Coefficients:', b write(outstr,'(//a/a)') & 'X Y Predicted Inverse Weight', & '-------------- -------------- -------------- --------------' do i=1, nvals write(outstr,'(g14.6,3(1x,g14.6))') xval(i), yval(i), -brent_inter(xval(i)), varwt(i) end do write(outstr,'(/g14.6,1x,g14.6)') maxx, maxy end if end subroutine polyinter ! ! predicted value from polynomial regression equation ! function brent_inter(x) use AS164_class double precision :: brent_inter double precision, intent(in) :: x brent_inter=b(1) do j=2, AS164_nterms-1 brent_inter=brent_inter + b(j)*(x**(j-1)) end do brent_inter=-brent_inter end function brent_inter ! ! QDCRT computes the roots of the real polynomial ! A(1) + A(2)*Z + A(3)*Z**2 ! and stores the results in Z. It is assumed that A(3) is nonzero. ! ! Converted to be compatible with ELF90 by Alan Miller ! amiller @ bigpond.net.au ! Latest revision - 27 February 1997 ! subroutine qdcrt (a, z) implicit none integer, parameter :: DP = selected_real_kind(15, 60) double precision, dimension(3), intent(in) :: a complex (DP), dimension(2), intent(out) :: z ! local variables double precision :: d, r, w, x, y, zero = 0.0d0 if (a(1) == zero) goto 40 d = a(2)*a(2) - 4.0d0*a(1)*a(3) if (abs(d) <= 2.0d0*epsilon(1.0d0)*a(2)*a(2)) goto 20 r = sqrt(abs(d)) if (d < zero) goto 30 ! distinct real roots if (a(2) /= zero) goto 10 x = abs(0.5d0*r/a(3)) z(1) = cmplx(x, zero, DP) z(2) = cmplx(-x, zero, DP) return ! 10 continue w = -(a(2) + sign(r,a(2))) z(1) = cmplx(2.0d0*a(1)/w, zero, DP) z(2) = cmplx(0.5d0*w/a(3), zero, DP) return ! equal real roots 20 z(1) = cmplx(-0.5d0*a(2)/a(3), zero, DP) z(2) = z(1) return ! complex roots 30 continue x = -0.5d0*a(2)/a(3) y = abs(0.5D0*r/a(3)) z(1) = cmplx(x, y, DP) z(2) = cmplx(x,-y, DP) return ! case when a(1) = 0 40 continue z(1) = cmplx(zero, zero, DP) z(2) = cmplx(-a(2)/a(3), zero, DP) return end subroutine qdcrt ! ! Count proportion of observed homozygotes for a locus ! subroutine counthom(gene, dataset, obshom) use ped_class implicit none integer, intent(in) :: gene type (ped_data) :: dataset double precision, intent(out) :: obshom ! local variables integer, parameter :: MISS = -9999 integer :: g1, g2, gen2, i, nhomoz, nobs, ped gen2=gene+1 obshom=MISS nhomoz=0 nobs=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (observed(i, gene, dataset)) then nobs=nobs+1 call get_geno(i, gene, gen2, dataset, g1, g2) if (g1 == g2) nhomoz=nhomoz+1 end if end do end if end do if (nobs > 0) obshom=dble(nhomoz)/dble(nobs) end subroutine counthom ! ! Calculate observed and expected homozygosity for all individuals ! Save F_roh to quantitative variable ! subroutine globhom(dataset, long_roh, trait, plevel) use outstream use ped_class use locus_data use locus_types use genetic_maps use sorts use interrupt implicit none type (ped_data) :: dataset double precision, intent(in) :: long_roh integer, intent(in) :: trait integer, intent(in) :: plevel ! integer, parameter :: KNOWN=0, MISS=-9999 ! markers for haplotyping integer :: nmark integer, dimension(:), allocatable :: mark integer (kind=8), dimension(:), allocatable :: mapidx double precision, dimension(:), allocatable :: exphom, mapdist ! double precision :: fis, fstat, exptot, longrun, longestrun, & maplen, maxmaplen, meanroh, obsrun, rohstat double precision :: mapstart, mapend, runstart, runend, totrunlen integer :: eon, gene, g1, g2, i, ichr, j, jj, maxrun, nchrom, ndata, nfam, & nobs, ntot, num, ped, pedoffset, pos, run, tothom character (len=2) :: chr character (len=7) :: mapfmt ! functions integer :: chrnum interface subroutine globhom_onelocus(gene, loctyp, dataset, exphom) use ped_class use alleles_class integer, intent(in) :: gene, loctyp type (ped_data) :: dataset double precision, intent(out) :: exphom end subroutine globhom_onelocus end interface mapfmt=mapformat(mapunits, '14') exptot=0.0d0 fis=0.0d0 longrun=long_roh maplen=0.0d0 maxmaplen=0.0d0 meanroh=0.0d0 nmark=0 do j=1, nloci if (same_loctyp(loctyp(j), LOC_CODOM)) then nmark=nmark+1 end if end do if (nmark == 0) then write(outstr,'(a)') 'NOTE: No eligible markers!' return end if allocate(mark(nmark), exphom(nmark)) allocate(mapidx(nmark)) nmark=0 chr=' ' mapstart=0.0d0 mapend=0.0d0 do j=1, nloci if (same_loctyp(loctyp(j), LOC_CODOM)) then nmark=nmark+1 mark(nmark)=j ichr=chrnum(group(j)) mapidx(nmark)=1000000000_8*int(ichr, kind=8) + anint(1.0d6*map(j), kind=8) end if end do call long_isort(1, nmark, mapidx, mark, 2) !$OMP PARALLEL DO do jj=1, nmark j=mark(jj) call globhom_onelocus(locpos(j), loctyp(j), dataset, & exphom(jj)) end do !$OMP END PARALLEL DO if (plevel > 1) then eon=len_trim(loc(mark(1))) write(outstr,'(/2a,$)') 'Markers: ', trim(loc(mark(1))) pos=10+eon do j=2, nmark eon=len_trim(loc(mark(j))) pos=pos+eon+1 call newlin(9, 78, pos, eon+2) write(outstr,'(2a)', advance='no') ' ', trim(loc(mark(j))) end do write(outstr,*) end if write(outstr,'(/a/a)') & 'Pedigree ID NMark Hom E(Hom) F F_roh Longest Run', & '------------- -------------- -------- ------- ------- ------- ------- --------------' ! obsrun=0.0D0 ! nfam=0 nobs=0 ntot=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0 .and. irupt == 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset ntot=ntot+num do i=pedoffset+1, dataset%num(ped) ndata=0 do jj=1, nmark gene=locpos(mark(jj)) if (observed(i, gene, dataset)) then ndata=ndata+1 end if end do if (ndata > 0) then exptot=0.0d0 fstat=0.0d0 longestrun=0.0d0 rohstat=0.0d0 nobs=nobs+1 run=0 totrunlen=0.0d0 tothom=0 maxrun=0 mapstart=0.0d0 mapend=0.0d0 maplen=0.0d0 runstart=MISS runend=0.0d0 chr=' ' ! ! accumulate total map length and roh length ! do jj=1, nmark j=mark(jj) gene=locpos(j) if (observed(i, gene, dataset)) then ! new chromosome - reset all counters if (group(j) /= ' ' .and. chr /= group(j)) then maplen=maplen+mapend-mapstart mapstart=0.0d0 mapend=0.0d0 if (map(j) /= MISS) then mapstart=map(j) mapend=map(j) end if chr=group(j) if (runstart /= MISS .and. (runend-runstart) > longrun) then totrunlen=totrunlen + runend - runstart end if if (run > maxrun) then maxrun=run if (runstart /= MISS) longestrun=runend-runstart end if run=0 runstart=MISS runend=0.0d0 end if if (group(j) == chr .and. map(j) > mapend) then mapend=map(j) end if exptot=exptot+exphom(jj) call get_geno(i, gene, gene+1, dataset, g1, g2) if (g1 == g2) then fstat=fstat+1.0d0 run=run+1 tothom=tothom+1 if (map(j) /= MISS .and. chr == group(j)) then if (runstart == MISS) runstart=map(j) runend=map(j) end if else fstat=fstat-exphom(jj)/(1.0d0-exphom(jj)) if (run > maxrun) then maxrun=run if (runstart /= MISS) longestrun=runend-runstart end if if (runstart /= MISS .and. (runend-runstart) > longrun) then totrunlen=totrunlen + runend-runstart end if run=0 runstart=MISS runend=0.0d0 end if end if end do maplen=maplen+mapend-mapstart if (maplen > maxmaplen) maxmaplen=maplen if (runstart /= MISS .and. (runend - runstart) > longrun) then totrunlen=totrunlen + runend - runstart end if exptot=exptot/dble(ndata) fstat=fstat/dble(ndata) rohstat=totrunlen/maplen fis=fis+fstat meanroh=meanroh+rohstat obsrun=obsrun+dble(maxrun) write(outstr,'(a14,a14,i9,4(1x,f7.4),1x,i0,1x,g12.6)') & dataset%pedigree(ped), dataset%id(i), ndata, & dble(tothom)/dble(ndata), exptot, fstat, rohstat, & maxrun, longestrun/mapconstant if (trait /= MISS) then dataset%plocus(i,trait)=rohstat end if end if if (irupt > 0) exit end do end if end do fis=fis/dble(max(1,nobs)) meanroh=meanroh/dble(max(1,nobs)) obsrun=obsrun/dble(max(1,nobs)) write(outstr,'(/a)', advance='no') 'Total map length =' write(outstr, mapfmt, advance='no') maxmaplen/mapconstant write(outstr,'(1x,a)') mapunitname(mapunits) write(outstr,'(a,i7,a,f5.1,a,2(/a,f12.4)/a,f12.4,a,i0)') & 'No. usable observations =', nobs, & ' (',float(100*nobs)/float(ntot),'%)', & 'Mean inbreeding =', fis, & 'Mean inbreeding (roh) =', rohstat, & 'Mean homozyg run length =', obsrun, ' out of ', nmark ! deallocate(mark) deallocate(exphom) end subroutine globhom ! ! Homozygosity contribution for ith locus ! subroutine globhom_onelocus(gene, loctyp, dataset, exphom) use ped_class use alleles_class integer, intent(in) :: gene, loctyp type (ped_data) :: dataset double precision, intent(out) :: exphom type (allele_data) :: allele_buffer integer :: i interface subroutine freq(gene, loctyp, fndr, dataset, allele_buffer) use ped_class use alleles_class integer, intent(in) :: gene integer, intent(in) :: loctyp integer, intent(in) :: fndr type (ped_data), intent(in) :: dataset type (allele_data), intent(inout) :: allele_buffer end subroutine freq end interface call setup_freq(10, allele_buffer) call freq(gene, loctyp, 0, dataset, allele_buffer) exphom=0.0d0 do i=1, allele_buffer%numal exphom=exphom + allele_buffer%allele_freqs(i)*allele_buffer%allele_freqs(i) end do end subroutine globhom_onelocus ! ! Calculate observed and expected multipoint homozygosity ! Expected distribution simulated using given map ! subroutine mulhom(trait, gt, thresh, xlinkd, iter, mincnt, & nloci, loc, loctyp, locpos, map, dataset, plevel) use outstream use alleles_class use ped_class use locus_types use genetic_maps use rngs implicit none integer, intent(inout) :: trait integer, intent(inout) :: gt double precision, intent(in) :: thresh logical, intent(inout) :: xlinkd integer, intent(in) :: iter integer, intent(inout) :: mincnt integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp double precision, dimension(:), intent(in) :: map type (ped_data) :: dataset integer, intent(in) :: plevel ! integer, parameter :: KNOWN=0, MISS=-9999 ! all the markers type (allele_data), dimension(:), pointer :: alleles ! storage space for haplotypes integer, dimension(:,:,:), allocatable :: hset ! markers for haplotyping integer :: nmark integer, dimension(:), allocatable :: mark, hom, runlen, totrunlen, minrunlen double precision, dimension(:), allocatable :: exploc, locrun, recdist, varloc ! active families integer, dimension(dataset%nped) :: fam ! double precision :: bestrun, exprun, obsrun, simrun, varrun double precision :: bestz, expbest, simbest, varbest, x, z integer :: eon, g1, g2, gene, i, it, j, maxrun, naff, ndata, nfam, & nobs, ntot, num, ped, pedoffset, pos, run, tailp logical :: het character (len=3) :: histo character (len=21) :: mset ! double precision :: dist double precision :: homz, pval ! functions character (len=6) :: pstring double precision :: isaff interface subroutine simhap(nmark, recdist, alleles, ped, dataset, hset, plevel) use alleles_class use ped_class implicit none integer, intent(in) :: nmark double precision, dimension(:), intent(in) :: recdist type (allele_data), dimension(:), pointer :: alleles integer, intent(in) :: ped type (ped_data), intent(in) :: dataset integer, dimension(:,:,:), intent(inout) :: hset integer, intent(in) :: plevel end subroutine end interface ! dist=0.0d0 nmark=0 !-OMP PARALLEL DO do j=1, nloci if (same_loctyp(loctyp(j), LOC_CODOM)) then nmark=nmark+1 end if end do !-OMP END PARALLEL DO allocate(mark(nmark), recdist(nmark), hom(nmark)) allocate(minrunlen(nmark), runlen(nmark), totrunlen(nmark)) allocate(locrun(nmark), exploc(nmark), varloc(nmark)) allocate(hset(dataset%maxsiz, nmark, 2)) allocate(alleles(nmark)) do j=1, nmark call setup_freq(10, alleles(j)) end do nmark=0 !-OMP PARALLEL !-OMP DO ORDERED do j=1, nloci if (same_loctyp(loctyp(j), LOC_CODOM)) then nmark=nmark+1 mark(nmark)=j minrunlen(nmark)=1000000 totrunlen(nmark)=0 call freq(locpos(j), loctyp(j), 0, dataset, alleles(nmark)) if (map(j) /= MISS .and. map(j) >= dist) then recdist(nmark)=invmap(map(j)-dist,1) dist=map(j) else recdist(nmark)=0.50d0 dist=0.0d0 end if end if end do !-OMP END DO !-OMP END PARALLEL if (plevel > 0) then eon=len_trim(loc(mark(1))) write(outstr,'(/2a,$)') 'Markers: ', trim(loc(mark(1))) pos=10+eon do j=2, nmark eon=len_trim(loc(mark(j))) pos=pos+eon+1 call newlin(9, 78, pos, eon+2) write(outstr,'(2a,$)') ' ', trim(loc(mark(j))) end do write(outstr,'(//a/a)') & 'Pedigree ID Run Homozygosity pattern', & '--------- ---------- ---- --------------------' end if ! obsrun=0.0D0 exprun=0.0D0 expbest=0.0d0 varrun=0.0D0 varbest=0.0D0 exploc=0.0d0 varloc=0.0D0 ! nfam=0 nobs=0 ntot=0 !-OMP PARALLEL DO do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset ntot=ntot+num naff=0 if (trait == MISS) then do i=pedoffset+1, dataset%num(ped) dataset%untyped(i)=.true. end do else do i=pedoffset+1, dataset%num(ped) dataset%untyped(i)=(isaff(dataset%plocus(i,trait), thresh, gt)==2.0d0) end do end if if (xlinkd) then do i=pedoffset+1, dataset%num(ped) if (dataset%sex(i) /= 2) dataset%untyped(i)=.false. end do end if do i=pedoffset+1, dataset%num(ped) ndata=0 do j=1, nmark gene=locpos(mark(j)) if (observed(i, gene, dataset)) then ndata=ndata+1 end if end do if (ndata == nmark .and. dataset%untyped(i)) then naff=naff+1 run=0 maxrun=0 het=.true. do j=1, nmark gene=locpos(mark(j)) call get_geno(i, gene, gene+1, dataset, g1, g2) if (g1 == g2) then hom(j)=1 run=run+1 runlen(j)=run if (run > maxrun) maxrun=run if (het) then het=.not.het end if else run=0 runlen(j)=0 hom(j)=0 het=.true. end if end do do j=nmark, 2, -1 if (runlen(j) > runlen(j-1) .and. runlen(j-1) /= 0) then runlen(j-1)=runlen(j) end if if (runlen(j) < minrunlen(j)) minrunlen(j)=runlen(j) totrunlen(j)=totrunlen(j)+runlen(j) end do if (runlen(1) < minrunlen(1)) minrunlen(1)=runlen(1) totrunlen(1)=totrunlen(1)+runlen(1) obsrun=obsrun+dble(maxrun) if ((plevel == 1 .and. nobs <= 15) .or. plevel > 1) then write(outstr,'(a10,a10,i5,1x,(60i1))') & dataset%pedigree(ped), dataset%id(i), maxrun, (hom(j), j=1, nmark) end if else dataset%untyped(i)=.false. end if end do if (naff > 0) then nfam=nfam+1 fam(nfam)=ped nobs=nobs+naff end if end if end do !-OMP END PARALLEL DO if (plevel == 1 .and. nobs > 10) then write(outstr,'(a)') '...' end if gene=1 bestrun=0.0d0 do j=1, nmark if (dble(totrunlen(j)) > bestrun) then gene=j bestrun=dble(totrunlen(j)) end if locrun(j)=dble(totrunlen(j))/dble(nobs) end do bestrun=bestrun/dble(nobs) obsrun=obsrun/dble(nobs) if (plevel > 0) then write(outstr,'(/6x,a,i7,a,f5.1,a/6x,a,f12.4,a,i4/6x,a,f12.4,3a)') & 'No. usable observations =',nobs, & ' (',float(100*nobs)/float(ntot),'%)', & 'Mean homozyg run length =', obsrun, ' out of ', nmark, & 'Best homozyg run length =', bestrun, ' for "', trim(loc(mark(gene))), '"' end if ! it=0 tailp=0 pval=0.0D0 do while (it < iter .and. tailp < mincnt) it=it+1 simrun=0.0D0 totrunlen=0 !-OMP PARALLEL DO do j=1, nfam ped=fam(j) call simhap(nmark, recdist, alleles, ped, dataset, hset, plevel) call clcrun(ped, dataset, nmark, hset, runlen, totrunlen, simrun) end do !-OMP END PARALLEL DO simbest=0.0d0 !-OMP PARALLEL DO do j=1, nmark if (dble(totrunlen(j)) > simbest) then simbest=dble(totrunlen(j)) end if x=dble(totrunlen(j))/dble(nobs) call moment(it, x, exploc(j), varloc(j)) end do !-OMP END PARALLEL DO simbest=simbest/dble(nobs) simrun=simrun/dble(nobs) call moment(it, simrun, exprun, varrun) call moment(it, simbest, expbest, varbest) if (simrun > obsrun .or. (simrun == obsrun .and. random() > 0.5)) then tailp=tailp+1 end if if (plevel > 1) then write(outstr,'(/a,i4,2(a,f6.1))') & 'Pseudosample ',it,': mean run length =', simrun, ' exp locus best =', expbest end if end do write(outstr,'(/a//a/a)') & 'Length of runs of homozygosity that include a given marker', & 'Marker Mean run Minimum run Expected run Variance Z-statistic', & '-------------- --------- ----------- ------------ ----------- -----------' do j=1, nmark varloc(j)=varloc(j)/dble(max(1, it-1)) z=0.0d0 if (varloc(j) > 0.0d0) then z=(locrun(j)-exploc(j))/sqrt(varloc(j)) end if write(outstr,'(a14,f11.1,3x,i10,2x,f12.1,1x,f12.1,2x,f9.2)') & loc(mark(j)), locrun(j), minrunlen(j), exploc(j), varloc(j), z end do varbest=varbest/dble(max(1, it-1)) bestz=(bestrun-expbest)/sqrt(varbest) write(outstr,'(a)') & '-------------- --------- ----------- ------------ ----------- -----------' write(outstr,'(a14,f11.1,3x,i10,2x,f12.1,1x,f12.1,2x,f9.2)') & 'Best over all ', bestrun, minrunlen(gene), expbest, varbest, bestz varrun=varrun/dble(max(1, it-1)) homz=(obsrun-exprun)/sqrt(varrun) if (tailp < mincnt) then tailp=tailp+1 it=it+1 end if pval=dble(tailp)/dble(max(1,it)) if (plevel > 0) then write(outstr,'(/a,f12.4,a,f12.4,a/a,f12.4/6x,a,i4,a,i5,3a)') & ' Mean (Var) simulated runs =',exprun,' (',varrun,')', & ' Z statistic =',homz, & 'Equalled or exceeded by =',tailp,'/',it, & ' simulated values (', trim(pstring(pval)), ')' else write(outstr,'(/2a/2a)') ' Marker Set Aff Nmark', & ' Obs-Run Exp-Run Z Emp P Iters', & '--------------------- ------ ------', & ' ------- ------- ------ ------ -----' call phist(pval, pval, histo) mset=trim(loc(mark(1))) // ' - ' // trim(loc(mark(nmark))) call juststr('c', mset, 21) write(outstr,'(a21,$)') mset write(outstr,'(2i7,2(1x,f7.1),1x,f6.2,1x,a,1x,i6,2(1x,a))') & nobs, nmark, obsrun, exprun, homz, pstring(pval), it, 'HOM-Run', histo end if deallocate(alleles) deallocate(hset) deallocate(mark, recdist, hom) deallocate(locrun, minrunlen, exploc, varloc, runlen, totrunlen) end subroutine mulhom ! ! calculate average maximum run length of homozygosity ! subroutine clcrun(ped, dataset, nmark, hset, runlen, totrunlen, averun) use ped_class implicit none integer, intent(in) :: ped type (ped_data) :: dataset integer, intent(in) :: nmark integer, dimension(dataset%maxsiz,nmark,2), intent(in) :: hset integer, dimension(nmark), intent(inout) :: runlen, totrunlen double precision, intent(out) :: averun ! integer :: i, j, maxrun, num, pedoffset, run logical :: het ! pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset do i=1, num if (dataset%untyped(pedoffset+i)) then maxrun=0 run=0 het=.true. do j=1, nmark if (hset(i,j,1) == hset(i,j,2)) then run=run+1 if (run > maxrun) maxrun=run if (het) then runlen(j)=run het=.not.het end if else run=0 runlen(j)=0 het=.true. end if end do do j=nmark, 2, -1 if (runlen(j) > runlen(j-1) .and. runlen(j-1) /= 0) then runlen(j-1)=runlen(j) end if totrunlen(j)=totrunlen(j)+runlen(j) end do totrunlen(1)=totrunlen(1)+runlen(1) averun=averun+dble(maxrun) end if end do end subroutine clcrun ! ! Drop haplotypes for all family members for given map ! subroutine simhap(nmark, recdist, alleles, ped, dataset, hset, plevel) use outstream use alleles_class use ped_class use rngs implicit none integer, intent(in) :: nmark double precision, dimension(:), intent(in) :: recdist type (allele_data), dimension(:), pointer :: alleles integer, intent(in) :: ped type (ped_data), intent(in) :: dataset integer, dimension(:,:,:), intent(inout) :: hset integer, intent(in) :: plevel integer, parameter :: KNOWN=0, MISS=-9999 integer :: cfa, cmo, fagranp, i, ii, j, mogranp, num, pedoffset logical :: fin, done(dataset%maxsiz) ! functions interface subroutine found(cumfrq, allele) double precision, dimension(:), intent(in) :: cumfrq integer, intent(out) :: allele end subroutine end interface ! ! Initialize founders ! pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset do j=1, nmark do i=1, dataset%nfound(ped) call found(alleles(j)%cum_freqs, hset(i,j,1)) call found(alleles(j)%cum_freqs, hset(i,j,2)) end do end do do i=1, dataset%nfound(ped) done(i)=.true. end do do i=dataset%nfound(ped)+1, num done(i)=.false. end do ! ! then gene drop the nonfounders genotypes ! do fin=.true. ii=pedoffset+dataset%nfound(ped) do i=dataset%nfound(ped)+1, num ii=ii+1 if (.not.done(i)) then cfa=dataset%fa(ii)-pedoffset cmo=dataset%mo(ii)-pedoffset if (done(cfa) .and. done(cmo)) then fagranp=irandom(1, 2) mogranp=irandom(1, 2) do j=1, nmark if (recdist(j) > random()) fagranp=3-fagranp if (recdist(j) > random()) mogranp=3-mogranp hset(i,j,1)=hset(cfa,j,fagranp) hset(i,j,2)=hset(cmo,j,mogranp) end do done(i)=.true. else fin=.false. end if end if end do if (fin) exit end do ! if (plevel > 2) then do i=1, num write(outstr,'(i4,100i3:)') i, hset(i,1:nmark,1) write(outstr,'(4x,100i3:)') hset(i,1:nmark,2) end do end if end subroutine simhap ! ! Excluding genotypes from parental phenoset ! Straight Lange & Goradia AJHG 1987 40: 250-256 ! subroutine exclude(imp, nloci, loc, loctyp, locpos, dataset, & inconsist, imputd, plevel) use ped_class use alleles_class use locus_types implicit none integer, intent(in) :: imp integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data) :: dataset integer, intent(inout) :: inconsist integer, intent(out) :: imputd integer, intent(in) :: plevel ! integer, parameter :: KNOWN=0, MISS=-9999 integer :: i, pedincon !$OMP PARALLEL DO do i=1, nloci if (isactdip(loctyp(i))) then call exclude_onelocus(imp, locpos(i), loc(i), loctyp(i), dataset, & inconsist, imputd, pedincon, plevel) end if end do !$OMP END PARALLEL DO end subroutine exclude ! ! Exclude at one locus ! subroutine exclude_onelocus(imp, gene, loc, loctyp, dataset, & inconsist, imputd, pedincon, plevel) use ped_class use alleles_class use locus_types implicit none integer, intent(in) :: imp integer, intent(in) :: gene character (len=20), intent(in) :: loc integer, intent(in) :: loctyp type (ped_data) :: dataset integer, intent(inout) :: inconsist integer, intent(inout) :: imputd integer, intent(out) :: pedincon integer, intent(in) :: plevel ! integer, parameter :: KNOWN=0, MISS=-9999 integer, dimension(dataset%maxsiz,2) :: set type (allele_data) :: allele_buffer integer, dimension(:,:,:), allocatable :: gset integer :: currin, g, gen2, i, j, pedimp, ped interface subroutine exclude_oneped(imp, reduce, locnam, gene, xlinkd, ped, dataset, & allele_buffer, set, gset, inconsist, imputd, plevel) use ped_class use alleles_class implicit none integer, intent(inout) :: imp logical, intent(in) :: reduce character (len=20), intent(in) :: locnam logical, intent(in) :: xlinkd integer, intent(in) :: gene integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data), intent(in) :: allele_buffer integer, dimension(:,:) :: set integer, dimension(:,:,:) :: gset integer, intent(inout) :: inconsist integer, intent(out) :: imputd integer, intent(in) :: plevel end subroutine exclude_oneped end interface pedincon=0 call setup_freq(10, allele_buffer) call freq(gene, loctyp, 0, dataset, allele_buffer) if (allele_buffer%numal == 0) then gen2=gene+1 g=-1 do j=1, dataset%nobs call set_geno(j, gene, gen2, dataset, g, g) end do else if (allele_buffer%numal == 1) then gen2=gene+1 g=-allele_buffer%allele_names(1) do j=1, dataset%nobs if (.not.observed(j, gene, dataset)) then call set_geno(j, gene, gen2, dataset, g, g) end if end do else call calc_gtp_freqs(allele_buffer) allocate(gset(dataset%maxsiz,allele_buffer%numgtp+1,2)) do ped=1, dataset%nped if (dataset%num(ped-1)+dataset%nfound(ped) < dataset%num(ped)) then pedimp=imp currin=inconsist call exclude_oneped(pedimp, .true., loc, gene, & same_loctyp(loctyp, LOC_XLIN), ped, dataset, & allele_buffer, set, gset, inconsist, imputd, plevel) if (inconsist > currin) then pedincon=pedincon+1 end if end if end do deallocate(gset) deallocate(allele_buffer%gtp_freqs) end if end subroutine exclude_onelocus ! ! Do one pedigree at one locus ! subroutine exclude_oneped(imp, reduce, locnam, gene, xlinkd, ped, dataset, & allele_buffer, set, gset, inconsist, imputd, plevel) use outstream use ped_class use alleles_class implicit none integer, intent(inout) :: imp logical, intent(in) :: reduce character (len=20), intent(in) :: locnam logical, intent(in) :: xlinkd integer, intent(in) :: gene integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data), intent(in) :: allele_buffer integer, dimension(:,:) :: set integer, dimension(:,:,:) :: gset integer, intent(inout) :: inconsist integer, intent(out) :: imputd integer, intent(in) :: plevel ! integer, parameter :: EXTRA=10043, KNOWN=0, MISS=-9999 ! integer :: fam_numal integer, dimension(allele_buffer%numal+1) :: seen_alleles, fam_alleles integer :: currin, currf, currm, g1, g2, gen2, & i, ii, itwin, j, k, mxgeno, ngeno, sta ! commonest of unobserved alleles for this pedigree integer :: commonest_unseen integer :: num, pedoffset character (len=7) :: gtp double precision :: gfrq, mxfrq ! functions integer :: getnam interface subroutine exc(locnam, xlinkd, gene, ped, dataset, set, gset, & inconsist, plevel) use ped_class implicit none character (len=20), intent(in) :: locnam logical, intent(in) :: xlinkd integer, intent(in) :: gene integer, intent(in) :: ped type (ped_data) :: dataset integer, dimension(:,:), intent(inout) :: set integer, dimension(:,:,:), intent(inout) :: gset integer, intent(inout) :: inconsist integer, intent(in) :: plevel end subroutine exc subroutine wrset(locnam, ped, dataset, set, gset) use ped_class implicit none character (len=20), intent(in) :: locnam integer, intent(in) :: ped type (ped_data), intent(in) :: dataset integer, dimension(:,:), intent(in) :: set integer, dimension(:,:,:), intent(in) :: gset end subroutine wrset end interface ! do j=1, allele_buffer%numal+1 fam_alleles(j)=0 seen_alleles(j)=0 end do currin=inconsist commonest_unseen=1 pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset ! ! count alleles in current pedigree if reduce=T ! fam_alleles = {observed alleles | dummy allele | the extra alleles} ! gen2=gene+1 if (reduce) then do ii=pedoffset+1, dataset%num(ped) if (observed(ii, gene, dataset)) then call get_namedgeno(ii, gene, gen2, dataset, allele_buffer, g1, g2) seen_alleles(g1)=seen_alleles(g1)+1 seen_alleles(g2)=seen_alleles(g2)+1 end if end do fam_numal=0 do j=1, allele_buffer%numal if (seen_alleles(j) /= 0) then fam_numal=fam_numal+1 fam_alleles(fam_numal)=allele_buffer%allele_names(j) end if end do if (plevel > 1) then write(outstr,'(5a,i3,a,i3)') & 'Locus ', trim(locnam), ' Pedigree ', trim(dataset%pedigree(ped)), & ' No. Alleles=', fam_numal, ' of a maximum ', allele_buffer%numal end if if (fam_numal < allele_buffer%numal) then fam_numal=fam_numal+1 end if if (fam_numal == allele_buffer%numal) then fam_alleles(1:fam_numal)=allele_buffer%allele_names(1:fam_numal) else g1=fam_numal fam_alleles(g1)=EXTRA mxfrq=0.0d0 do j=1, allele_buffer%numal if (seen_alleles(j) == 0) then g1=g1+1 fam_alleles(g1)=allele_buffer%allele_names(j) if (allele_buffer%allele_freqs(j) > mxfrq) then mxfrq=allele_buffer%allele_freqs(j) commonest_unseen=allele_buffer%allele_names(j) end if end if end do end if else fam_numal=allele_buffer%numal do j=1, allele_buffer%numal fam_alleles(j)=j end do end if ! write(outstr,*) fam_alleles ! do ii=pedoffset+1, dataset%num(ped) ! write(outstr,*) gene, gen2, dataset%id(ii), ' (', dataset%imztwin(ii), ') ', & ! dataset%glocus(ii, gene), dataset%glocus(ii, gen2) ! end do ! ! synchronize MZ twins phenosets ! ii=pedoffset do i=1, num ii=ii+1 itwin=MISS set(i,1)=0 set(i,2)=0 if (dataset%imztwin(ii) /= MISS) then itwin=dataset%imztwin(ii)-pedoffset set(i,1)=set(itwin,1) set(i,2)=dataset%imztwin(ii) end if if (observed(ii, gene, dataset)) then set(i,1)=1 set(i,2)=ii if (itwin /= MISS) then if (set(itwin,2) == 0) then set(itwin,1)=1 set(itwin,2)=ii end if end if end if end do ! ! now can initialize phenosets ! ii=pedoffset do i=1, num ii=ii+1 if (set(i,1) == 1) then if (reduce) then call get_geno(set(i,2), gene, gene+1, dataset, & gset(i,1,1), gset(i,1,2)) else call get_namedgeno(set(i,2), gene, gen2, dataset, allele_buffer, & gset(i,1,1), gset(i,1,2)) end if else if (xlinkd .and. dataset%sex(ii) == 1) then ngeno=0 do j=1, fam_numal ngeno=ngeno+1 gset(i,ngeno,1)=fam_alleles(j) gset(i,ngeno,2)=fam_alleles(j) end do set(i,1)=ngeno else ngeno=0 do j=1, fam_numal do k=j, fam_numal ngeno=ngeno+1 gset(i,ngeno,1)=fam_alleles(j) gset(i,ngeno,2)=fam_alleles(k) end do end do set(i,1)=ngeno end if set(i,2)=0 end do ! ! locate beginnings and ends of sibships sta=dataset%nfound(ped)+1 currf=dataset%fa(pedoffset+sta) currm=dataset%mo(pedoffset+sta) ii=pedoffset+dataset%nfound(ped) do i=dataset%nfound(ped)+1, num ii=ii+1 if (dataset%fa(ii) /= currf .or. dataset%mo(ii) /= currm) then currf=dataset%fa(ii) currm=dataset%mo(ii) set(sta,2)=i sta=i end if end do ! last is special case set(sta,2)=num+1 ! ! loop through all nuclear families until all phenosets finalised ! call exc(locnam, xlinkd, gene, ped, dataset, set, gset, & inconsist, plevel) ! ! update dataset ! ! if inconsistency, zero entire pedigree and exit if (inconsist > currin) then g1=-allele_buffer%allele_names(1) do ii=pedoffset+1, dataset%num(ped) call set_geno(ii, gene, gen2, dataset, g1, g1) end do return end if ! ! write out phenosets for untyped individuals and update imputed loci ! if (imp > 0) then ii=pedoffset do i=1, num ii=ii+1 if (.not.observed(ii, gene, dataset)) then ngeno=set(i,1) if (ngeno == 1 .and. gset(i,1,1) /= EXTRA .and. gset(i,1,2) /= EXTRA) then imputd=imputd+1 if (plevel > 0) then call wrgtp(gset(i,1,1), gset(i,1,2), gtp, '/', '', 1) write(outstr,'(/8a/)') & 'NOTE: Imputed individual ', & trim(dataset%pedigree(ped)), '-', trim(dataset%id(i)), & ' at locus "', trim(locnam), '" to be ', gtp end if if (imp < 3) then call set_geno(ii, gene, gen2, dataset, gset(i,1,1), gset(i,1,2)) else call set_geno(ii, gene, gen2, dataset, -gset(i,1,1), -gset(i,1,2)) end if end if end if end do end if if (plevel > 1) then call wrset(locnam, ped, dataset, set, gset) end if ! ! Now sequentially initialise so-far untyped individuals to be a ! likely genotype. Move through the pedigree, impute ! the current untyped individual, prune genotypes for the remaining ! untyped individuals thus made illegal, until end of pedigree. ! Denote initialised genotypes with negative allele values. ! ! Do not perform sequential imputation if Mendelian errors detected or ! not full imputation ! ! If failure of sequential imputation, switch to MC start() algorithm ! if (imp < 3 .or. inconsist > currin) return ! ii=pedoffset do i=1, num ii=ii+1 if (set(i,1) > 1) then ngeno=set(i,1) mxgeno=1 mxfrq=0.0D0 if (reduce) then do j=1, ngeno if (gset(i,j,1) == EXTRA) then g1=commonest_unseen else g1=getnam(gset(i,j,1), allele_buffer) end if if (gset(i,j,2) == EXTRA) then g2=commonest_unseen else g2=getnam(gset(i,j,2), allele_buffer) end if gfrq=allele_buffer%gtp_freqs(g2*(g2-1)/2+g1) if (gfrq > mxfrq) then mxfrq=gfrq mxgeno=j end if end do else do j=1, ngeno g1=getnam(gset(i,j,1), allele_buffer) g2=getnam(gset(i,j,2), allele_buffer) gfrq=allele_buffer%gtp_freqs(g2*(g2-1)/2+g1) if (gfrq > mxfrq) then mxfrq=gfrq mxgeno=j end if end do end if call set_geno(ii, gene, gen2, dataset, -gset(i,mxgeno,1), -gset(i,mxgeno,2)) set(i,1)=1 gset(i,1,1)= gset(i,mxgeno,1) gset(i,1,2)= gset(i,mxgeno,2) if (plevel > 0) then call wrgtp(gset(i,1,1), gset(i,1,2), gtp, '/', '', 1) write(outstr,'(6a)') 'Starting ', & trim(dataset%pedigree(ped)), '-', trim(dataset%id(ii)), ' as ', gtp end if call exc(locnam, xlinkd, gene, ped, dataset, set, gset, inconsist, -2) ! ! if only one genotype in phenoset but dataset not yet updated then update else if (missing(ii, gene, dataset)) then if (commonest_unseen == EXTRA) then write(outstr,'(a)') 'ERROR: Commonest unseen allele is padding allele!' end if if (gset(i,j,1) == EXTRA .and. gset(i,j,2) == EXTRA) then call set_geno(ii, gene, gen2, dataset, -commonest_unseen, -commonest_unseen) else call set_geno(ii, gene, gen2, dataset, -gset(i,1,1), -gset(i,1,2)) end if if (plevel > 0) then call wrgtp(gset(i,1,1), gset(i,1,2), gtp, '/', '', 1) write(outstr,'(5a,i0,a,i0)') 'Already starting ', & trim(dataset%pedigree(ped)), '-', trim(dataset%id(ii)), ' as ', gtp end if end if ! ! check for failure of algorithm -- may need to switch to start() if (inconsist > currin) then write(outstr, '(a/7x,7a)') & 'ERROR: Encountered an inconsistency during sequential imputation', & 'of locus "', trim(locnam), '" after imputed ', & trim(dataset%pedigree(ped)), '--', trim(dataset%id(ii)), '.' return end if end do end subroutine exclude_oneped ! ! write out phenoset ! subroutine wrset(locnam, ped, dataset, set, gset) use outstream use ped_class implicit none character (len=20), intent(in) :: locnam integer, intent(in) :: ped type (ped_data), intent(in) :: dataset integer, dimension(:,:), intent(in) :: set integer, dimension(:,:,:), intent(in) :: gset ! integer :: i, ii, j, ngeno character (len=7) :: gtp write(outstr,'(/4a/a/a)') & 'Phenosets for locus "', trim(locnam), '" in pedigree ', dataset%pedigree(ped), & 'ID Count Legal Genotypes', & '-------------- -------- ---------------' ! i=0 do ii=dataset%num(ped-1)+1, dataset%num(ped) i=i+1 ngeno=set(i,1) write(outstr,'(a14,i9)', advance='no') dataset%id(ii), ngeno do j=1, min(ngeno, 10) call wrgtp(gset(i,j,1), gset(i,j,2), gtp, '/', '', 1) write(outstr, '(1x,a)', advance='no') trim(adjustl(gtp)) end do write(outstr,*) end do write(outstr,*) end subroutine wrset ! ! perform exclusion for the pedigree regardless of imputation level ! subroutine exc(locnam, xlinkd, gene, ped, dataset, set, gset, & inconsist, plevel) use outstream use ped_class implicit none character (len=20), intent(in) :: locnam logical, intent(in) :: xlinkd integer, intent(in) :: gene integer, intent(in) :: ped type (ped_data) :: dataset integer, dimension(:,:), intent(inout) :: set integer, dimension(:,:,:), intent(inout) :: gset integer, intent(inout) :: inconsist integer, intent(in) :: plevel ! ! local variables logical :: change, complete integer :: currm, currf, fin, i, it, incon, num, pedoffset, sta ! functions interface subroutine wrset(locnam, ped, dataset, set, gset) use ped_class implicit none character (len=20), intent(in) :: locnam integer, intent(in) :: ped type (ped_data), intent(in) :: dataset integer, dimension(:,:), intent(in) :: set integer, dimension(:,:,:), intent(in) :: gset end subroutine wrset subroutine famset(ped, dataset, currf, currm, sta, fin, gene, set, gset) use ped_class integer, intent(in) :: ped type (ped_data) :: dataset integer, intent(in) :: currf, currm integer, intent(in) :: sta, fin integer, intent(in) :: gene integer, intent(in) :: set(:,:) integer, intent(in) :: gset(:,:,:) end subroutine famset subroutine landg(xlinkd, currf, currm, sta, fin, sex, set, & gset, change, incon) logical, intent(in) :: xlinkd integer, intent(in) :: currf, currm integer, intent(in) :: sta, fin integer, dimension(:), intent(in) :: sex integer, dimension(:,:), intent(inout) :: set integer, dimension(:,:,:), intent(inout) :: gset logical, intent(inout) :: change integer, intent(inout) :: incon end subroutine landg end interface ! pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset it=0 change=.true. do if (plevel > 2) then write(outstr,'(/5a,i2/)') & 'Pedigree ', trim(dataset%pedigree(ped)), & ' Locus "', trim(locnam), '" Iteration ', it call wrset(locnam, ped, dataset, set, gset) end if ! Test if finished if (.not.change) return change=.false. complete=.true. sta=dataset%nfound(ped)+1 it=it+1 ! ! One iteration of pedigree - sibship by sibship ! sibships: do while (sta <= num) if (set(sta,2) < 0) then sta=-set(sta,2) cycle sibships end if currf=dataset%fa(pedoffset+sta)-pedoffset currm=dataset%mo(pedoffset+sta)-pedoffset fin=set(sta,2)-1 if (plevel > 2) then write(outstr,'(8a)') & 'Nuclear family: ', trim(adjustl(dataset%id(pedoffset+currf))), & ' x ', trim(adjustl(dataset%id(pedoffset+currm))), & ' Off: ', trim(adjustl(dataset%id(pedoffset+sta))), & ' to ', trim(adjustl(dataset%id(pedoffset+fin))) end if incon=0 call landg(xlinkd, currf, currm, sta, fin, & dataset%sex(pedoffset+1:dataset%num(ped)), & set, gset, change, incon) ! ! check to see if completely unambiguous -- skip in future if true ! complete=.true. if (set(currf,1) > 1 .or. set(currm,1) > 1) then complete=.false. else do i=sta, fin if (set(i,1) > 1) then complete=.false. exit end if end do end if if (complete) set(sta,2)=-fin-1 ! ! Check for inconsistencies. ! If being used to generate starting genotypes, ! don't print a worrying message. ! Old behaviour was to continue looking for errors, but probably cheapest ! to bail out now, as most are fall-out from the first inconsistency. ! if (incon > 0) then inconsist=inconsist+incon if (plevel > -2) then if (.not.xlinkd) then write(outstr,'(/5a/)') 'NOTE: Mendelian inconsistency in pedigree ', & trim(dataset%pedigree(ped)), ' at locus "', trim(locnam), '".' else write(outstr,'(/5a/)') 'NOTE: Mendelian inconsistency in pedigree ', & trim(dataset%pedigree(ped)), ' at X-linked locus "', trim(locnam), '".' end if call describe(locnam, gene, xlinkd, ped, dataset, & pedoffset+currf, pedoffset+currm, pedoffset+sta, pedoffset+fin, 10) call famset(ped, dataset, currf, currm, sta, fin, gene, set, gset) end if return end if ! increment to next sibship sta=fin+1 end do sibships end do end subroutine exc ! ! 2nd version of impute -- following Lange & Goradia, 1987 ! subroutine landg(xlinkd, currf, currm, sta, fin, sex, set, & gset, change, incon) logical, intent(in) :: xlinkd integer, intent(in) :: currf, currm integer, intent(in) :: sta, fin integer, dimension(:), intent(in) :: sex integer, dimension(:,:), intent(inout) :: set integer, dimension(:,:,:), intent(inout) :: gset logical, intent(inout) :: change integer, intent(inout) :: incon ! logical :: chachi, con, pcon, xmale ! logical :: keep(size(gset,2)), keep2(size(gset,2)) integer :: i, j, k, l, ngeno, ngeno1, ngeno2, totgen ! functions integer :: parcon interface subroutine prune(idx, ngeno, gset, keep) integer, intent(in) :: idx integer, intent(inout) :: ngeno integer, dimension(:,:,:), intent(inout) :: gset logical, dimension(:), intent(inout) :: keep end subroutine prune end interface ! xmale=.false. ngeno1=set(currf,1) ngeno2=set(currm,1) totgen=ngeno1+ngeno2 ! ! first prune parental genotypes inconsistent with children ! do j=1, ngeno1 keep(j)=.false. end do do k=1, ngeno2 keep2(k)=.false. end do do j=1, ngeno1 do k=1, ngeno2 pcon=.true. do i=sta, fin ngeno=set(i,1) xmale=(xlinkd .and. sex(i) /= 2) con=.false. do l=1, ngeno if (parcon(gset(i,l,1), gset(i,l,2), & gset(currf,j,1), gset(currf,j,2), & gset(currm,k,1), gset(currm,k,2), xmale) > 0) then con=.true. end if end do if (.not.con) then pcon=.false. exit end if end do ! ! save this parental genotype if consistent ! if (pcon) then keep(j)=.true. keep2(k)=.true. end if end do end do call prune(currf, ngeno1, gset, keep) call prune(currm, ngeno2, gset, keep2) if (totgen /= (ngeno1+ngeno2)) then change=.true. set(currf,1)=ngeno1 set(currm,1)=ngeno2 if (ngeno1 == 0) then incon=incon+1 end if if (ngeno2 == 0) then incon=incon+1 end if end if ! ! then examine each child's phenoset and remove genotypes inconsistent ! with the current parental phenosets ! do i=sta, fin ngeno=set(i,1) xmale=(xlinkd .and. sex(i) /= 2) if (ngeno > 1) then do l=1, ngeno keep(l)=.false. do j=1, ngeno1 do k=1, ngeno2 if (parcon(gset(i,l,1), gset(i,l,2), & gset(currf,j,1), gset(currf,j,2), & gset(currm,k,1), gset(currm,k,2), xmale) > 0) then keep(l)=.true. end if end do end do end do ! see if any alterations made chachi=.false. do l=1, ngeno if (.not.keep(l)) then chachi=.true. exit end if end do if (chachi) then change=.true. call prune(i, ngeno, gset, keep) set(i,1)=ngeno if (ngeno == 0) then incon=incon+1 end if end if end if end do end subroutine landg ! ! Remove unwanted genotypes from phenoset ! subroutine prune(idx, ngeno, gset, keep) integer, intent(in) :: idx integer, intent(inout) :: ngeno integer, dimension(:,:,:), intent(inout) :: gset logical, dimension(:), intent(inout) :: keep ! integer :: old, nkept interface subroutine swapg(idx, gset, j, k) integer, intent(in) :: idx integer, dimension(:,:,:), intent(inout) :: gset integer, intent(in) :: j, k end subroutine swapg end interface nkept=0 do old=1, ngeno if (keep(old)) then nkept=nkept+1 if (nkept /= old) call swapg(idx, gset, old, nkept) end if end do ! Mark end of old phenoset, so can print out if later needed gset(idx,ngeno+1,1)=0 ngeno=nkept end subroutine prune ! ! Swap two genotypes within a phenoset array ! subroutine swapg(idx, gset, j, k) integer, intent(in) :: idx integer, dimension(:,:,:), intent(inout) :: gset integer, intent(in) :: j, k integer :: tmp tmp=gset(idx,j,1) gset(idx,j,1)=gset(idx,k,1) gset(idx,k,1)=tmp tmp=gset(idx,j,2) gset(idx,j,2)=gset(idx,k,2) gset(idx,k,2)=tmp end subroutine swapg ! ! Calculate BLUPs for VC model ! save if requested ! subroutine doblup(locnam, trait, h2, blupout, dataset, plevel) use outstream use AS164_class use ped_class implicit none character (len=20), intent(in) :: locnam integer, intent(in) :: trait double precision, intent(in) :: h2 integer, intent(in) :: blupout type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel ! integer, parameter :: MISS=-9999 ! breeding values double precision, dimension(dataset%maxact+2) :: bval ! inverse numerator relationship matrix double precision, dimension(dataset%maxact*(dataset%maxact+1)/2) :: ainv integer :: i, ii, nobs, ntot, num, ped, pedoffset character (len=9) :: cval double precision :: fmu, gmu, lam, res, rss ! write(outstr,'(/a/3a,f5.1,a/a)') & '--------------------------------------------', & 'BLUPs for "', trim(locnam), '" with H2 =', 100.0d0*h2, '%', & '--------------------------------------------' if (plevel > -1 .or. blupout == MISS) then write(outstr,'(a/a)') & 'Pedigree Individual Observed BLUP FamMean Residual', & '------------ ---------- --------- --------- --------- ---------' end if ! if (allocated(cov)) then deallocate(cov) end if allocate(cov((dataset%maxact+2)*(dataset%maxact+3)/2)) ntot=0 fmu=0.0D0 gmu=0.0D0 rss=0.0D0 lam=(1.0D0-h2)/h2 ! do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset nobs=0 do ii=pedoffset+1, dataset%num(ped) if (dataset%plocus(ii,trait) /= MISS) then nobs=nobs+1 ntot=ntot+1 end if end do if (nobs > 0) then call blup(lam, trait, ped, dataset, ainv, bval, fmu) gmu=gmu+dble(nobs)*fmu ii=pedoffset do i=1, num ii=ii+1 res=0.0d0 if (dataset%plocus(ii,trait) /= MISS) then res=dataset%plocus(ii,trait)-fmu-bval(i) rss=rss+res*res end if if (plevel > -1) then cval=' x' if (dataset%plocus(ii,trait) /= MISS) then write(cval,'(f9.4)') dataset%plocus(ii,trait) end if write(outstr,'(a,2(1x,a),3(1x,f9.4))') & dataset%pedigree(ped)(1:12), dataset%id(ii)(1:10), & cval, bval(i), fmu, res end if if (blupout /= MISS) then dataset%plocus(ii,blupout)=bval(i) end if end do end if end if end do gmu=gmu/dble(ntot) rss=rss/dble(ntot) write(outstr,'(/a,f12.4/a,f12.4)') & 'Overall intercept =', gmu, & 'Mean Square Error (VE) =', rss deallocate(cov) end subroutine doblup ! ! Calculate BLUPs for current pedigree ! quantitative trait ! ! MME: intercept only, n1 obs ! [ Z'X Z'Z+lam A~ ] [ u ] [ Z'y ] [ !is.na(y)' lam Ainv+diag(!is.na(y)) ] [!is.na(y)*y ] ! [ X'X X'Z ] [ b ] = [ X'y ] -> [ n !is.na(y) ] [ Sum(y) ] ! subroutine blup(lam, trait, ped, dataset, ainv, bval, fmu) use AS164 use AS164_class use ped_class implicit none double precision, intent(in) :: lam integer, intent(in) :: trait integer, intent(in) :: ped type (ped_data), intent(in) :: dataset double precision, dimension(dataset%maxact*(dataset%maxact+1)/2) :: ainv double precision, dimension(dataset%maxact+2) :: bval double precision, intent(out) :: fmu ! integer, parameter :: MISS=-9999 logical, dimension(dataset%maxact) :: typed integer :: ncov, nter ! ! Heritability, estimated familial mean and RSS ! integer :: i, ii, ifail, j, nobs, num, pedoffset, pos double precision :: tot ! functions integer :: clcpos interface subroutine invkin(ped, dataset, ainv) use ped_class implicit none integer, intent(in) :: ped type (ped_data), intent(in) :: dataset double precision, dimension(:), intent(inout) :: ainv end subroutine invkin end interface ! pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset nobs=0 tot=0.0D0 i=0 do ii=pedoffset+1, dataset%num(ped) i=i+1 typed(i)=.false. if (dataset%plocus(ii,trait) /= MISS) then nobs=nobs+1 typed(i)=.true. tot=tot+dataset%plocus(ii,trait) end if end do fmu=tot/dble(nobs) pos=num+1 nter=num+2 ncov=nter*(nter+1)/2 call inicov(nter, ncov, cov) ! Additive genetic effects call invkin(ped, dataset, ainv) ii=pedoffset do i=1, num ii=ii+1 do j=1, num bval(j)=lam*ainv(clcpos(i,j)) end do bval(pos)=0.0d0 bval(nter)=0.0d0 if (typed(i)) then bval(i)=bval(i)+1.0d0 bval(pos)=1.0d0 bval(nter)=dataset%plocus(ii,trait) end if call givenc(cov, ncov, nter, bval, 1.0D0, ifail) end do ! Fixed effects ! Intercept bval=0.0d0 do i=1, num if (typed(i)) bval(i)=1.0D0 end do bval(pos)=dble(nobs) bval(nter)=tot call givenc(cov, ncov, nter, bval, 1.0D0, ifail) call bsub(cov, ncov, nter, bval, nter-1, ifail) if (ifail /= 0) write(*,'(a)') 'ERROR in bsub()' fmu = bval(pos) end subroutine blup ! ! Association haplotype analysis for unphased data ! ! counts ncells ncat*(na1*(na1+1)/2)*(na2*(na2+1)/2) ! full nfull ncat*(nh1*(nh1+1)/2)*(nh2*(nh2+1)/2) ! scatter nfull*nobs ! model nfull*(ncat + nh1 + nh2 + nh1*nh2 [ + ncat*nh1*nh2 ]) ! subroutine hapassoc(nmark, markers, & loc, loctyp, locpos, locnotes, dataset, pval, plevel) use outstream use alleles_class use ped_class use locus_types use AS164_class use contingency_table use statfuns use categorical_data implicit none integer, intent(in) :: nmark integer, dimension(:), intent(inout) :: markers character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos character (len=40), dimension(:), intent(in) :: locnotes type (ped_data), intent(in) :: dataset double precision, intent(out) :: pval integer, intent(in) :: plevel ! integer, parameter :: KNOWN=0, MISS=-9999 ! the trait data: complete and where no missing genotypes integer :: trait type (table_data) :: traittable double precision, dimension(1) :: val integer, dimension(:), allocatable :: ttab double precision, dimension(:), allocatable :: tprop ! the marker data type (allele_data), dimension(:), pointer :: alleles integer, dimension(:) , allocatable :: numals integer, dimension(:) , allocatable :: acounter ! ! loglinear model work arrays ! ! scatter = scatter matrix connecting observed and full contingency table ! full = expected values for full (unobserved) contingency table (length nfull) ! ex = expected values for contingency table iteration i ! oldex = expected values for contingency table iteration i-1 ! model = design matrix (length nfull x totpars) ! offset = offset for full (length nfull) ! integer, dimension(:), allocatable :: scatter ! counts = observed contingency table (length ncells) ! integer , dimension(:), allocatable :: scatter double precision, dimension(:), allocatable :: full double precision, dimension(:), allocatable :: ex double precision, dimension(:), allocatable :: oldex double precision, dimension(:), allocatable :: model double precision, dimension(:), allocatable :: offset double precision, dimension(:), allocatable :: counts ! ! loglinear model parameters (AS164) b, cov are in AS164_class ! ! local variables integer :: astat, g1, g2, hapwid, i, ii, idx, j, k, kk, lpos, mult, ncat, & ncells, nfull, nhap, nmarkers, nmiss, nobs, npars, nunique, & ntraits, ped, pedoffset, pos, tmp, totpars character (len=3) :: sall character (len=6) :: hapspace character (len=9) :: cval character (len=30) :: fstring character (len=80) :: haplotype logical :: sho integer :: unobshap, df1, df2 double precision :: ase, lnoff, lrts1, lrts2, pfreq ! functions integer :: clcpos character (len=6) :: pstring double precision :: ln interface subroutine freq(gene, loctyp, fndr, dataset, allele_buffer) use ped_class use alleles_class integer, intent(in) :: gene integer, intent(in) :: loctyp integer, intent(in) :: fndr type (ped_data), intent(in) :: dataset type (allele_data), intent(inout) :: allele_buffer end subroutine freq subroutine hap2gen(nrep, nmarkers, numals, scatter) integer, intent(in) :: nrep ! number of replicated blocks integer, intent(in) :: nmarkers ! number of loci in haplotype integer, dimension(nmarkers), intent(in) :: numals ! array of number of alleles per locus integer , dimension(:), intent(inout) :: scatter ! scatter array end subroutine hap2gen subroutine gl(nr, nc, design, sta, levels, reps, droplev) integer, intent(in) :: nr ! rows of design matrix integer, intent(in) :: nc ! cols of design matrix double precision, dimension(:), intent(inout) :: design integer, intent(in) :: sta ! first col integer, intent(in) :: levels ! number of cols integer, intent(in) :: reps ! repeats per level logical, intent(in) :: droplev ! drop first column end subroutine subroutine agl(nr, nc, design, sta, nalleles, nstrata) integer, intent(in) :: nr ! rows of design matrix integer, intent(in) :: nc ! cols of design matrix double precision, dimension(:), intent(inout) :: design integer, intent(in) :: sta ! first col integer, intent(in) :: nalleles ! number of cols integer, intent(in) :: nstrata ! repeat blocks end subroutine agl subroutine emllm(ncells, nfull, totpars, npars, counts, scatter, model, & ex, oldex, full, offset, b, cov, lrts, plevel) integer, intent(in) :: ncells integer, intent(in) :: nfull integer, intent(in) :: totpars integer, intent(in) :: npars double precision, dimension(:), intent(inout) :: counts integer, dimension(:), intent(inout) :: scatter double precision, dimension(:), intent(inout) :: model double precision, dimension(:), intent(inout) :: ex double precision, dimension(:), intent(inout) :: oldex double precision, dimension(:), intent(inout) :: full double precision, dimension(:), intent(inout) :: offset double precision, dimension(:), intent(inout) :: b double precision, dimension(:), intent(inout) :: cov double precision, intent(out) :: lrts integer, intent(in) :: plevel end subroutine emllm end interface ! ncat=1 pval=1.0d0 trait=MISS ntraits=0 nmarkers=nmark ! check argument list for a trait do i=1, nmarkers if (istrait(loctyp(markers(i)))) then ntraits=ntraits+1 pos=i end if end do if (ntraits > 0) then if (ntraits > 1) then write(outstr,'(a)') 'ERROR: No more than 1 trait currently allowed.' return end if if (pos /= nmarkers) then tmp=markers(pos) do i=pos, nmarkers-1 markers(i)=markers(i+1) end do markers(nmarkers)=tmp end if trait=markers(nmarkers) lpos=locpos(trait) nmarkers=nmarkers-1 call setup_table(1, 5, traittable) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do i=pedoffset+1, dataset%num(ped) if (dataset%plocus(i,lpos) /= MISS) then val(1)=dataset%plocus(i,lpos) call insert_table(1, val, traittable, 1) end if end do end if end do ncat=traittable%ncells write(hapspace,'(i6)') ncat hapspace=adjustl(hapspace) write(outstr,'(5a)') 'Trait: ', trim(loc(trait)),'(',trim(hapspace),')' end if allocate(alleles(nmarkers)) allocate(numals(nmarkers), acounter(nmarkers)) hapwid=0 nhap=1 ncells=ncat pos=10 write(outstr,'(a)', advance='no') 'Markers:' do j=1, nmarkers call freq(locpos(markers(j)), loctyp(markers(j)), 0, dataset, alleles(j)) numals(j)=alleles(j)%numal write(hapspace,'(i6)') numals(j) hapspace=adjustl(hapspace) pos=pos+len_trim(loc(markers(j)))+len_trim(hapspace)+3 if (pos > 72) then write(outstr,'(/a)', advance='no') repeat(' ', 8) pos=10 end if write(outstr,'(1x,4a)',advance='no') & trim(loc(markers(j))),'(',trim(hapspace),')' nhap=nhap*numals(j) ncells=ncells*numals(j)*(numals(j)+1)/2 if (alleles(j)%allele_names(numals(j)) > 10000) then hapwid=hapwid+2 else hapwid=hapwid+int(log10(dble(alleles(j)%allele_names(numals(j)))))+2 end if end do write(outstr,*) nfull=ncat*nhap*nhap totpars=ncat*nhap allocate(model(nfull*totpars), stat=astat) if (astat /= 0) then write(outstr,'(a,i0,a,i0,a)') & 'ERROR: Unable to allocate ', nfull, ' x ', totpars, ' model matrix.' deallocate(numals) deallocate(acounter) deallocate(alleles) return end if allocate(scatter(nfull)) allocate(counts(ncells), ex(ncells), oldex(ncells)) allocate(full(nfull), offset(nfull)) if (allocated(b)) then deallocate(b) deallocate(cov) end if allocate(b(totpars), cov(totpars*(totpars+1)/2)) ! ! accumulate counts ! nobs=0 nmiss=0 counts=0.0d0 person: do i=1, dataset%nobs if (dataset%actset(dataset%iped(i)) > 0) then if (trait /= MISS) then if (dataset%plocus(i, locpos(trait)) /= MISS) then mult=ncells/ncat idx=mult*(findlev(dataset%plocus(i,locpos(trait)), traittable)-1) else nmiss=nmiss+1 cycle person end if else mult=ncells idx=0 end if do j=1, nmarkers lpos=locpos(markers(j)) if (.not.observed(i, lpos, dataset)) then nmiss=nmiss+1 cycle person end if mult=2*mult/numals(j)/(numals(j)+1) call get_namedgeno(i, lpos, lpos+1, dataset, alleles(j), g1, g2) idx=idx+mult*(clcpos(g1,g2)-1) ! write(*,*) 'id=', i, ' loc=', j, ' numal=', numals(j), ' mult=', mult, g1, g2, idx end do nobs=nobs+1 idx=idx+1 counts(idx)=counts(idx)+1.0d0 ! write(*,*) 'id=', i, ' trait=', dataset%glocus(i, locpos(trait)), & ! ' idx=', idx, ' count=', counts(idx) end if end do person ! if (nobs < 1) then write(outstr,'(2(/a,i10))') & ' Number of loci =', nmarkers, & ' No. genotyped individuals =', nobs deallocate(b) deallocate(cov) deallocate(counts, scatter, ex, oldex, full, offset, model) deallocate(numals) deallocate(acounter) deallocate(alleles) return end if ! nonzero cells and marginal trait counts from table nunique=0 allocate(ttab(ncat), tprop(ncat)) ttab=0 tprop=0.0d0 k=0 do i=1, ncat do j=1, ncells/ncat k=k+1 if (counts(k) > 0.0d0) nunique=nunique+1 ttab(i)=ttab(i)+int(counts(k)) end do tprop(i)=dble(ttab(i))/dble(nobs) end do ! ! Set up base model ! do i=1, nfull*totpars model(i)=0.0d0 end do call agl(nfull, totpars, model, 1, nhap, 1) call gl(nfull, totpars, model, nhap+1, ncat, nfull/ncat, .true.) call hap2gen(ncat, nmarkers, numals, scatter) ! offset by N to give haplotype proportions ! lnoff=ln(dble(ttab(1))) lnoff=ln(dble(nobs)) do i=1, nfull offset(i)=lnoff end do ! ! fit model ! npars=nhap+ncat-1 df1=ncells-npars ! ! write(*,*) 'ncells, nfull, totpars, npars: ', ncells, nfull, totpars, npars ! write(*,*) 'scatter: ', size(scatter), ': ', scatter ! write(*,*) 'counts: ', size(counts), ': ', counts ! write(*,*) 'model: ', size(model) call emllm(ncells, nfull, totpars, npars, counts, scatter, model, & ex, oldex, full, offset, b, cov, lrts1, plevel) unobshap=0 do i=1, nhap if (exp(b(i))*dble(nobs) < 1.0d0) then unobshap=unobshap+1 end if end do write(hapspace,'(i6)') max(9,hapwid) hapspace=adjustl(hapspace) if (ncat == 1) then fstring='(/a,t' // trim(hapspace) // ',3x,a,5x,a)' write(outstr,fstring) 'Haplotype', 'Prop', '95%CL' write(outstr,'(a,2x,a,3x,a)') & repeat('-', max(9,hapwid)), repeat('-',6), repeat('-',14) fstring='(a,t' // trim(hapspace) // ',3x,f6.4,3x,f6.4,a,f6.4)' else ! fit stratified model model=0.0d0 call agl(nfull, totpars, model, 1, nhap, ncat) k=0 do i=1, ncat do j=1, nfull/ncat k=k+1 offset(k)=ln(dble(ttab(i))) end do end do npars=ncat*nhap df2=ncells-npars call emllm(ncells, nfull, totpars, npars, counts, scatter, model, & ex, oldex, full, offset, b, cov, lrts2, plevel) fstring='(/a,t' // trim(hapspace) // ')' write(outstr,fstring, advance='no') 'Haplotype' do j=1, ncat pos=traittable%idx(j) call wrtrait(traittable%categories(pos,1)%rvalue, cval, loctyp(trait), & get_notes(loc(trait), locnotes(trait)), 9, 4) cval=adjustl(cval) write(outstr,'(3x,a9)',advance='no') cval end do write(outstr,'(3x,a/a)', advance='no') 'Overall', & repeat('-', max(9,hapwid)-1) do j=1, ncat+1 write(outstr,'(3x,a9)',advance='no') repeat('-',9) end do write(outstr,*) fstring='(a,t' // trim(hapspace) // ',3x,f6.4,3x)' end if ii=0 do j=1, nmarkers acounter(j)=1 end do do i=1, nhap ii=ii+i ase=1.96d0*sqrt(cov(ii)) haplotype='' k=1 kk=1 do j=1, nmarkers call wrall(alleles(j)%allele_names(acounter(j)), sall) sall=adjustl(sall) kk=k+len_trim(sall)-1 haplotype(k:kk)=trim(sall) k=kk+2 end do if (ncat == 1) then if (nmarkers < 4 .or. b(i) > -6.5d0) then write(outstr,fstring) & trim(haplotype), exp(b(i)), & max(0.0d0, exp(b(i)-ase)), '--', min(1.0d0, exp(b(i)+ase)) end if else sho=nmarkers < 4 if (.not.sho) then do j=1, ncat if (b((j-1)*nhap+i) > -6.5d0) then sho=.true. exit end if end do end if if (sho) then pfreq=tprop(1)*exp(b(i)) write(outstr, fstring, advance='no') & trim(haplotype), exp(b(i)) do j=2, ncat pfreq=pfreq + tprop(j)*exp(b((j-1)*nhap+i)) write(outstr,'(3x,f6.4,3x)', advance='no') exp(b((j-1)*nhap+i)) end do write(outstr,'(3x,f6.4)') pfreq end if end if do j=1, nmarkers acounter(j)=acounter(j)+1 if (acounter(j) > numals(j)) then acounter(j)=1 else exit end if end do end do if (ncat > 1) then fstring='(/a8,10(i9,3x):)' write(outstr,fstring) trim(loc(trait)), ttab end if write(outstr,'(3(/a,i10))') & ' Number of loci =', nmarkers, & ' No. genotyped individuals =', nobs, & ' No. obs. unique genotypes =', nunique if (ncat == 1) then df1=df1+unobshap pval=chip(lrts1,df1) write(outstr,'(a,f13.2,a,i4,3a)') & ' LD Model LR Chi-square =', lrts1, ' (df=', df1, & ', P=', pstring(pval), ')' else df1=df1+unobshap df2=df2+ncat*unobshap pval=chip(lrts1-lrts2, df1-df2) write(outstr,'(a,f13.2,a,i4,3a)') & ' Stratified LD Chi-square =', lrts2, ' (df=', df2, & ', P=', pstring(chip(lrts2,df2)), ')', & ' Association Chi-square =', lrts1-lrts2, ' (df=', df1-df2, & ', P=', pstring(pval), ')' if (unobshap > 0) then write(outstr, '(/a/7x,i4,a)') & 'NOTE: Degrees of freedom calculation for association test assumes only ', & nhap-unobshap, ' haplotypes to be present in the population.' end if end if deallocate(ttab, tprop) deallocate(b) deallocate(cov) deallocate(counts, scatter, ex, oldex, full, offset, model) deallocate(numals) deallocate(acounter) deallocate(alleles) end subroutine hapassoc ! ! Appropriate design matrix columns for allelic model ! a1 a2 gen ! 2 0 1/1 ! 1 1 1/2 ! 1 1 2/1 ! 0 2 2/2 ! subroutine agl(nr, nc, design, sta, nalleles, nstrata) integer, intent(in) :: nr ! rows of design matrix integer, intent(in) :: nc ! cols of design matrix double precision, dimension(:), intent(inout) :: design integer, intent(in) :: sta ! first col integer, intent(in) :: nalleles ! number of cols integer, intent(in) :: nstrata ! repeat blocks ! local variables integer :: first, g1, g2, i, is, tot first=sta tot=nr*nc do do is=1, nstrata if (is > 1) first=first+nalleles do g1=1, nalleles do g2=1, nalleles i=first do k=1, nalleles if (k==g1) design(i)=design(i)+1.0d0 if (k==g2) design(i)=design(i)+1.0d0 i=i+1 if (i > tot) return end do first=first+nc end do end do if (first > tot) return end do end do end subroutine agl ! ! Phased genotype to unphased genotype mapping ! subroutine hap2gen(nrep, nmarkers, numals, scatter) integer, intent(in) :: nrep ! number of replicated blocks integer, intent(in) :: nmarkers ! number of loci in haplotype integer, dimension(nmarkers), intent(in) :: numals ! array of number of alleles per locus integer , dimension(:), intent(inout) :: scatter ! scatter array integer, dimension(2*nmarkers) :: phased integer, dimension(nmarkers) :: unphased, gmult integer :: block, gtp, h, i, k, ngeno, tot ! functions integer :: clcpos nhap=1 gmult(nmarkers)=1 nhap=numals(nmarkers) do i=nmarkers-1,1,-1 nhap=nhap*numals(i) gmult(i)=gmult(i+1)*numals(i+1)*(numals(i+1)+1)/2 end do ngeno=gmult(1)*numals(1)*(numals(1)+1)/2 tot=nrep*nhap*nhap h=1 block=0 do i=1, 2*nmarkers phased(i)=1 end do do while (h <= tot) do k=1, nmarkers unphased(k)=clcpos(phased(k), phased(nmarkers+k)) end do gtp=block+1 do k=1, nmarkers gtp=gtp+gmult(k)*(unphased(k)-1) end do ! write(*, '(i3)', advance='no') h ! write(*,*) (phased(k), k=1,2*nmarkers), & ! (unphased(k), k=1,nmarkers), gtp scatter(h)=gtp h=h+1 do i=1, 2*nmarkers phased(i)=phased(i)+1 if (phased(i) > numals(1+mod(i-1,nmarkers))) then phased(i)=1 else exit end if end do if (mod(h, nhap*nhap) == 1) then block=block+ngeno end if end do end subroutine hap2gen ! ! Convenience routine subroutine wrmat(nr, nc, mat) integer, intent(in) :: nr, nc double precision, dimension(nr*nc), intent(in) :: mat integer :: i, pos pos=0 do i=1, nr ! write(*,*) i, ': ', mat(pos+1:pos+nc) write(*,*) i, ': ', mat(pos+1:pos+i) ! pos=pos+nc pos=pos+i end do end subroutine wrmat ! ! The set of markers close to an index marker A B ! map distances are interpreted adjacently ie 10-5-15 = B unlinked ! C unlinked 10 ! subroutine nearloc(pos, thresh, maxcluster, nloci, loc, loctyp, & group, map, nmark, mark, plevel) use interrupt use locus_types use outstream implicit none integer, intent(inout) :: pos ! index marker double precision, intent(in) :: thresh ! criterion for close integer, intent(in) :: maxcluster ! max no of markers integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc ! all locus names integer, dimension(:), intent(in) :: loctyp ! locus types character (len=2), dimension(:), allocatable :: group ! genetic map double precision, dimension(:), intent(in) :: map integer, intent(out) :: nmark ! number of markers in set integer, dimension(:), intent(out) :: mark ! marker list integer, intent(in) :: plevel ! integer, parameter :: MISS=-9999 integer :: i, idx character (len=2) :: startchrom double precision :: dist, start nmark=0 start=MISS dist=0.0d0 if (pos <= 0) pos=1 if (pos > 0 .and. pos <= nloci) then idx=pos start=map(idx) startchrom=group(idx) if (same_loctyp(loctyp(idx), LOC_CODOM)) then nmark=1 mark(nmark)=idx end if end if pos=pos+1 if (start == MISS) return do while (pos <= nloci) if (same_loctyp(loctyp(pos), LOC_CODOM) .and. irupt == 0) then if (map(pos) /= MISS .and. & (startchrom == ' ' .or. (startchrom == group(pos)))) then dist=map(pos)-start if (dist > 0.0d0 .and. dist < thresh) then if (nmark < maxcluster) then nmark=nmark+1 mark(nmark)=pos else exit end if else exit end if else exit end if end if pos=pos+1 end do if (plevel > 1 .and. nmark > 0) then write(outstr, '(/3a)') 'Core locus: "', trim(loc(mark(1))), '"' do i=1, nmark write(outstr, '(i3,1x,a20,1x,f8.3)') i, loc(mark(i)), map(mark(i)) end do end if end subroutine nearloc ! ! Iterative peeling in pedigrees -- Description from thesis of Schelling 2004 ! ! 1. for each pedigree member i to initialize anterior values to the population genotype ! frequency and posterior values to unity subsequently calculate its ! penetrance values. ! 2. Then, for each connector i ! a) for families in which i is an offspring, its anterior value ai (ui ) ! is calculated non-recursively using (2.16) and the current values of ! the required quantities. ! b) for families in which i is a parent, its posterior value pij (ui ) ! through each mate j is calculated non-recursively using (2.17) and the ! current values of the required quantities. ! Repeat 2 until values converge ! ! Additionally, anterior, posterior and penetrance values may be scaled ! to sum to unity over genotype as described in Wang et al. (1996) to ! avoid numerical underflow. The log scaling factors Kai , Kgi and Kpij ! for the anterior, posterior and penetrance values are also calculated ! using the current values of the required quantities. They denote the ! accumulative log of the scaling factors for the anterior, posterior ! and penetrance values for member i with its mother mi and father pi . ! ! In 2.16 and 2.17, S denotes set of mates, C denotes set of full-sibs ! ! typ=1 likelihood ! typ=2 GPE ! subroutine dopeel(typ, gene, trait, maxiter, allele_buffer, dataset, & totlik, plevel) use outstream use ped_class use alleles_class implicit none integer, intent(in) :: typ integer, intent(in) :: gene, trait integer, intent(in) :: maxiter type (allele_data), intent(in) :: allele_buffer type (ped_data) :: dataset double precision, intent(out) :: totlik integer, intent(in) :: plevel ! local variables integer :: ifail, ped logical :: mesg1, mesg2 double precision, dimension(allele_buffer%numgtp) :: gfrq double precision, dimension(allele_buffer%numgtp, & allele_buffer%numgtp, & allele_buffer%numgtp) :: transprob double precision :: lik call genot(allele_buffer, gfrq) call filltrans(allele_buffer%numal, allele_buffer%numgtp, transprob) if (typ == 1) then if (plevel == 0) then write(outstr, '(/a/a)') & ' Pedigree LogLikelihood', & '---------- --------------' end if else if (plevel > 0) then write(outstr,'(/a/a)') & ' ID GPEs', & '-------------- ----------------------------------------' end if mesg1=.false. mesg2=.false. totlik=0.0d0 lik=totlik do ped=1, dataset%nped if (dataset%actset(ped) > 0) then call itpeel(typ, ped, dataset, gene, allele_buffer, gfrq, transprob, & trait, maxiter, lik, ifail, plevel) totlik=totlik+lik if (ifail == 1) mesg1=.true. if (ifail == 2) mesg2=.true. end if end do if (typ == 1) then if (plevel == 0) then write(outstr,'(a,g16.6)') ' Total', totlik else write(outstr, '(/a,g16.6)') & 'Total Log Likelihood = ', totlik end if if (mesg1) then write(outstr,'(/a,i4,a/7x,a)') & 'NOTE: * denotes a likelihood that did not converge in ', maxiter, & ' iterations.','If loops are present, this algorithm does not converge!' end if if (mesg2) then write(outstr,'(/a)') & 'NOTE: ** denotes a user interrupted calculation.' end if end if end subroutine dopeel ! ! pth ped ! subroutine itpeel(typ, ped, dataset, gene, allele_buffer, gfrq, transprob, & trait, maxiter, lik, ifail, plevel) use interrupt use outstream use ped_class use alleles_class use pairlist_class implicit none integer, intent(in) :: typ integer, intent(in) :: ped type (ped_data) :: dataset integer, intent(in) :: gene type (allele_data), intent(in) :: allele_buffer double precision, dimension(allele_buffer%numgtp), intent(in) :: gfrq double precision, dimension(allele_buffer%numgtp, & allele_buffer%numgtp, & allele_buffer%numgtp), intent(in) :: transprob integer, intent(in) :: trait integer, intent(in) :: maxiter double precision, intent(out) :: lik integer, intent(out) :: ifail integer, intent(in) :: plevel ! local variables integer, parameter :: KNOWN = 0, MISS=-9999 ! ! antp contains individual anterior values: num x ngeno ! postidx is list of matings: 1..nmatings x 2 (fa and mo) ! postp contains mating posterior values: nmatings x ngeno ! sibships is table of sibships: nmatings x 2 (start and end) ! ascale, pscale: scaling factors for anterior and posterior values ! peelseq is ordering of individuals: num ! type (pairlist_data) :: postidx double precision, dimension(:,:), allocatable :: antp, postp double precision, dimension(:), allocatable :: ascale, pscale integer, dimension(:,:), allocatable :: sibships integer, dimension(:), allocatable :: peelseq ! ! copy of current pedigree integer :: nfound, num, pedoffset integer, dimension(dataset%maxact) :: fa, mo, imztwin integer, dimension(dataset%maxact, 2) :: set ! List of legal genotypes integer, dimension(dataset%maxact) :: gtp ! count of mates per person integer :: maxmates integer, dimension(dataset%maxact) :: nmates integer, dimension(:,:), allocatable :: mates ! penetrance working array integer, dimension(allele_buffer%numgtp) :: penetrances double precision, dimension(allele_buffer%numgtp) :: gpe ! index person to peel to, and their likelihood results integer :: trget double precision, dimension(maxiter) :: tlik integer :: cfa, cmo, fin, g1, g2, gen2, i, idx, ii, it, & j, jkids, jsibs, m, maxgrp, nsub, nuntyp, pos, sta integer :: g, gf, gj, gm, gs, ngeno ! ! current genotype for ego, father, mother, sibling, child, jth_spouse integer :: geno, cgeno, fgeno, jgeno, mgeno, sgeno logical :: zerolik character (len=7) :: cgtp double precision :: contrib, currant, curpost, curscale, delta, & dose, kidres, oldlik, mcontrib, meandose, rat1, rat2, & res, sibres, totp, trans, trans1 ! functions integer :: clcpos, glist, nglist double precision :: ln interface subroutine connect(num,fa,mo,set,nsub,maxgrp) integer, intent(in) :: num integer, dimension(:), intent(in) :: fa integer, dimension(:), intent(in) :: mo integer, dimension(:,:), intent(out) :: set integer, intent(out) :: nsub integer, intent(out) :: maxgrp end subroutine connect function postprod(idx, geno, nmates, mates, postp) implicit none double precision :: postprod integer, intent(in) :: idx, geno integer, dimension(:) :: nmates integer, dimension(:,:) :: mates double precision, dimension(:,:), intent(in) :: postp end function postprod function postprodex(idx, except, geno, nmates, mates, postidx, postp) use pairlist_class implicit none double precision :: postprodex integer, intent(in) :: idx, except, geno integer, dimension(:) :: nmates integer, dimension(:,:) :: mates type (pairlist_data) :: postidx double precision, dimension(:,:), intent(in) :: postp end function postprodex function postscale(idx, nmates, mates, pscale) implicit none double precision :: postscale integer, intent(in) :: idx integer, dimension(:) :: nmates integer, dimension(:,:) :: mates double precision, dimension(:), intent(in) :: pscale end function postscale function postscalex(idx, except, nmates, mates, postidx, pscale) use pairlist_class implicit none double precision :: postscalex integer, intent(in) :: idx, except integer, dimension(:) :: nmates integer, dimension(:,:) :: mates type (pairlist_data) :: postidx double precision, dimension(:), intent(in) :: pscale end function postscalex subroutine itlik(trget, ngeno, gtp, nmates, mates, antp, postp, ascale, pscale, lik) integer, intent(in) :: trget integer, intent(in) :: ngeno integer, dimension(:), intent(in) :: nmates integer, dimension(:,:), intent(in) :: mates integer, dimension(:), intent(in) :: gtp double precision, dimension(:,:), intent(in) :: antp, postp double precision, dimension(:), intent(in) :: ascale, pscale double precision, intent(out) :: lik end subroutine itlik end interface ifail=0 gen2=gene+1 delta=0.0001d0 nfound=dataset%nfound(ped) pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset ngeno=allele_buffer%numgtp call workpointers(ped, dataset, fa, mo, imztwin) call connect(num, fa, mo, set, nsub, maxgrp) if (nsub > 1) then write(outstr,'(/3a,i0,a,2(/7x,a)/)') & 'NOTE: Pedigree ', trim(dataset%pedigree(ped)), ' contains ', nsub, ' components.', & 'This routine may not give correct results!', & 'Running subped first will separate out the components.' end if ! Transmission probabilities ! call filltrans(allele_buffer%numal, ngeno, transprob) ! Count up matings nmates=0 call setup_pairs(num, postidx) do i=nfound+1, num call insert_pair(fa(i), mo(i), postidx) call insert_pair(mo(i), fa(i), postidx) end do do pos=1, postidx%npairs nmates(postidx%pairs(pos,1))=nmates(postidx%pairs(pos,1))+1 end do maxmates=0 do i=1, num if (nmates(i) > maxmates) maxmates=nmates(i) end do ! if (plevel > 0) then write(outstr,'(/3a,4(/a,i7)/)') & 'Pedigree = "', trim(dataset%pedigree(ped)), '"', & 'Number of members = ', num, & 'Number of founders = ', nfound, & 'Number of nuclear families = ', postidx%npairs/2, & 'Largest number of mates = ', maxmates end if ! ! Record genotypes (here coded as a genotype number) ! Initialize anterior probabilities and posterior values (and peeling seq) ! allocate(peelseq(num)) allocate(antp(num, ngeno), ascale(num)) allocate(postp(postidx%npairs, ngeno), pscale(postidx%npairs)) allocate(sibships(postidx%npairs,2)) allocate(mates(num, maxmates)) trget=num nuntyp=num ii=pedoffset do i=1, num ii=ii+1 peelseq(i)=i gtp(i)=0 if (observed(ii, gene, dataset)) then call get_namedgeno(ii, gene, gen2, dataset, allele_buffer, g1, g2) if (g1 == MISS .or. g2 == MISS) then write(outstr,'(/a)') 'ERROR: Unknown allele. Aborting!' goto 999 end if gtp(i)=clcpos(g1,g2) nuntyp=nuntyp-1 end if do g=1, ngeno antp(i,g)=gfrq(g) end do ascale(i)=0.0d0 end do ! And pointer to one's marriage nodes nmates=0 do pos=1, postidx%npairs nmates(postidx%pairs(pos,1))=nmates(postidx%pairs(pos,1))+1 mates(postidx%pairs(pos,1),nmates(postidx%pairs(pos,1)))=pos postp(pos,1:ngeno)=1.0d0 pscale(pos)=0.0d0 end do ! ! List of sibships ! cfa=MISS cmo=MISS i=nfound do while (i < num) i=i+1 if (cfa /= fa(i) .or. cmo /= mo(i)) then cfa=fa(i) cmo=mo(i) sta=i pos=i do pos=pos+1 if (pos > num) exit if (cfa /= fa(pos) .or. cmo /= mo(pos)) exit end do fin=pos-1 pos=find_pair(cfa, cmo, postidx) sibships(pos,1)=sta sibships(pos,2)=fin pos=find_pair(cmo, cfa, postidx) sibships(pos,1)=sta sibships(pos,2)=fin i=fin end if end do ! ! Main loop ! it=0 oldlik=0.0d0 tlik=0.0d0 mainloop: do it=it+1 do i=1, num if (irupt > 0) then ifail=2 exit mainloop end if idx=peelseq(i) if (idx > nfound) then pos=find_pair(fa(idx), mo(idx), postidx) sta=sibships(pos,1) fin=sibships(pos,2) else sta=idx fin=idx end if ! ! ith individual anterior values ! if (idx > nfound) then ! ego's anterior value for g'th genotype totp=0.0d0 do g=1, nglist(gtp(idx), ngeno) geno=glist(gtp(idx),g) currant=0.0d0 ! Sum over anterior values for ego's father's gf'th genotype by do gf=1, nglist(gtp(fa(idx)),ngeno) fgeno=glist(gtp(fa(idx)), gf) if (antp(fa(idx),fgeno) > 0.0d0) then ! Product over posterior values of father's other matings by ! Sum over anterior values for ego's mother's gm'th genotype mcontrib=0.0d0 do gm=1, nglist(gtp(mo(idx)),ngeno) mgeno=glist(gtp(mo(idx)),gm) if (antp(mo(idx), mgeno) > 0.0d0) then ! ! Product over posterior values of mother's other matings by ! product over contribution of ego's siblings of contrib=1.0d0 trans1=transprob(geno, fgeno, mgeno) if (trans1 > 0.0d0) then do jsibs= sta, fin if (jsibs /= idx) then ! ! Sum over gs sibling genotypes of jth sibling of sibres=0.0d0 do gs=1, nglist(gtp(jsibs),ngeno) sgeno=glist(gtp(jsibs),gs) trans=transprob(sgeno, fgeno, mgeno) if (trans > 0.0d0) then ! Product of all posterior values of jsibs'th sibling's gs'th genotype sibres=sibres+trans*postprod(jsibs, sgeno, & nmates, mates, postp) end if end do contrib=contrib*sibres end if end do mcontrib=mcontrib + antp(mo(idx),mgeno) * & postprodex(mo(idx), fa(idx), mgeno, & nmates, mates, postidx, postp) * & trans1 * contrib end if end if end do currant=currant + antp(fa(idx), fgeno) * & postprodex(fa(idx), mo(idx), fgeno, & nmates, mates, postidx, postp) * & mcontrib end if end do antp(idx,geno) = currant totp=totp + currant end do totp=ln(totp) ! log scaling factor for anterior values curscale=ascale(fa(idx)) + ascale(mo(idx)) + totp + & postscalex(fa(idx), mo(idx), nmates, mates, postidx, pscale) + & postscalex(mo(idx), fa(idx), nmates, mates, postidx, pscale) do jsibs= sta, fin if (jsibs /= idx) then curscale = curscale + postscale(jsibs, nmates, mates, pscale) end if end do ascale(idx) = curscale ! rescale anterior values do g=1, nglist(gtp(idx), ngeno) geno=glist(gtp(idx),g) if (antp(idx, geno) /= 0.0d0) then antp(idx,geno) = exp(log(antp(idx,geno))-totp) end if end do end if ! ! ith individual posterior values ! totp=0.0d0 do g=1, nglist(gtp(idx), ngeno) geno=glist(gtp(idx),g) do m=1, nmates(idx) pos=mates(idx,m) j=postidx%pairs(pos, 2) curpost=0.0d0 gloop: do gj=1, nglist(gtp(j), ngeno) jgeno=glist(gtp(j),gj) if (antp(j,jgeno) > 0.0d0) then ! ! Product of posterior values for j via all other matings res=postprodex(j, idx, jgeno, nmates, mates, postidx, postp) ! ! Product of posterior value contributions for all offspring of i and j do jkids= sibships(pos,1), sibships(pos,2) kidres=0.0d0 do gs=1, nglist(gtp(jkids),ngeno) cgeno=glist(gtp(jkids),gs) trans=transprob(cgeno, geno, jgeno) if (trans > 0.0d0) then ! Product of posterior values for all matings of this child kidres=kidres+trans*postprod(jkids, cgeno, & nmates, mates, postp) end if end do res=res*kidres if (res == 0.0d0) cycle gloop end do curpost=curpost+antp(j,jgeno) * res end if end do gloop postp(pos,geno) = curpost totp=totp+curpost end do end do ! log scaling factor for posterior values totp=ln(totp) do m=1, nmates(idx) pos=mates(idx,m) j=postidx%pairs(pos, 2) curscale = ascale(j) + totp + & postscalex(j, idx, nmates, mates, postidx, pscale) do jkids=sibships(pos,1), sibships(pos,2) curscale = curscale + postscale(jkids, nmates, mates, pscale) end do pscale(pos)=curscale ! rescale posterior values do g=1, nglist(gtp(idx), ngeno) geno=glist(gtp(idx),g) if (postp(pos, geno) /= 0.0d0) then postp(pos,geno) = exp(log(postp(pos,geno))-totp) end if end do end do end do ! ! Likelihood ! call itlik(trget, ngeno, gtp, nmates, mates, antp, postp, ascale, pscale, lik) tlik(it)=lik if (plevel > 0) then rat1=0.0d0 if (oldlik /= 0.0d0) rat1=lik/oldlik write(outstr,'(3a,i4,2(a,g16.6),a,f8.4)') & 'Pedigree ', trim(dataset%pedigree(ped)), & ' It ', it, ' Lik ', lik, ' Diff ', lik-oldlik, ' Ratio ', rat1 end if if (plevel > 1) then write(outstr,'(/a/)') 'Scaled anterior values' do i=1, num penetrances=1 if (nglist(gtp(i), ngeno) == 1) then penetrances=0 penetrances(gtp(i))=1 end if write(outstr,'(a10,2x)', advance='no') & trim(dataset%id(pedoffset+i)) do g=1, ngeno if (penetrances(g)==1) then write(outstr,'(1x,f6.4)', advance='no') antp(i,g) else write(outstr,'(2x,a1,4x)', advance='no') '-' end if end do write(outstr,*) ' scale=', ascale(i) end do write(outstr,'(/a/)') 'Scaled posterior values' do pos=1, postidx%npairs penetrances=1 if (nglist(gtp(postidx%pairs(pos,1)), ngeno) == 1) then penetrances=0 penetrances(gtp(postidx%pairs(pos,1)))=1 end if write(outstr,'(a20,1x)', advance='no') & trim(dataset%id(pedoffset+postidx%pairs(pos,1))) // ',' // & trim(dataset%id(pedoffset+postidx%pairs(pos,2))) do g=1, ngeno if (penetrances(g)==1) then write(outstr,'(1x,f6.4)', advance='no') postp(pos,g) else write(outstr,'(2x,a1,4x)', advance='no') '-' end if end do write(outstr,*) ' scale=', pscale(pos) end do write(outstr,*) end if if (abs(lik-oldlik) <= delta .and. it > 2) exit if (it >= maxiter) then ifail=1 exit end if oldlik=lik end do mainloop ! ! GPEs ! if (typ == 2 .or. plevel > 2) then meandose=2*allele_buffer%allele_freqs(1) do idx=1, num zerolik=.false. if (gtp(idx) == 0) then totp=0.0d0 zerolik=.true. do geno=1, ngeno gpe(geno)=antp(idx,geno) * postprod(idx, geno, nmates, mates, & postp) totp=totp+gpe(geno) end do if (totp > 0.0d0) then zerolik=.false. do geno=1, ngeno gpe(geno)=gpe(geno)/totp end do end if else gpe=0.0d0 gpe(gtp(idx))=1.0d0 end if if (trait /= MISS) then if (zerolik) then dose=meandose else g=1 dose=2*gpe(g) do j=1, allele_buffer%numal-1 g=g+j dose=dose+gpe(g) end do end if dataset%plocus(pedoffset+idx,trait)=dose if (plevel > 0) then write(outstr, '(a30,2x,f6.4)') & trim(dataset%pedigree(ped)) // '--' // & trim(dataset%id(pedoffset+idx)), dose end if else write(outstr,'(a30,1x,20(1x,f6.4):)') & trim(dataset%pedigree(ped)) // '--' // & trim(dataset%id(pedoffset+idx)), gpe(1:ngeno) end if end do else if (typ == 1) then oldlik=lik cgtp=' ' if (ifail == 1) then cgtp='*' lik=tlik(1) else if (ifail == 2) then cgtp='**' lik=tlik(1) end if if (plevel == 0) then write(outstr, '(a10,g16.6,1x,a)') & trim(dataset%pedigree(ped)), oldlik, trim(cgtp) if (ifail /= 0) then write(outstr, '(a10,g16.6,a)') & trim(dataset%pedigree(ped)), lik, ' (After one iteration)' if (ifail == 1 .and. maxiter > 3) then rat1=tlik(maxiter)/tlik(maxiter-1) rat2=tlik(maxiter-1)/tlik(maxiter-2) if (abs(rat1-rat2) < 0.01d0) then write(outstr, '(a10,g16.6,a)') & trim(dataset%pedigree(ped)), tlik(maxiter)/rat1**(maxiter-1), & ' (Back interpolated)' end if end if end if else if (plevel > 0) then write(outstr, '(/a,g16.6,4a)') & 'Pedigree Log Likelihood = ', oldlik, & ' (via ', trim(dataset%id(trget+pedoffset)), ') ', trim(cgtp) if (ifail /= 0) then write(outstr, '(a,g16.6)') & 'First iteration LogLik = ', lik if (ifail == 1 .and. maxiter > 3) then rat1=tlik(maxiter)/tlik(maxiter-1) rat2=tlik(maxiter-1)/tlik(maxiter-2) if (abs(rat1-rat2) < 0.01d0) then write(outstr, '(a,g16.6)') & 'Back-interpolated LogLik = ', & tlik(maxiter)/rat1**(maxiter-1) end if end if end if end if end if 999 continue deallocate(mates, sibships) deallocate(antp, peelseq, postp) deallocate(ascale, pscale) end subroutine itpeel ! ! Create table of transmission probabilities ! subroutine filltrans(numal, ngeno, transprob) integer, intent(in) :: numal, ngeno double precision, dimension(ngeno,ngeno,ngeno), intent(out) :: transprob integer :: pg1, pg2, mg1, mg2, cg1, cg2 integer :: gc, gf, gm ! functions integer :: parcon gf=0 do pg1=1, numal do pg2=1, pg1 gf=gf+1 gm=0 do mg1=1, numal do mg2=1, mg1 gm=gm+1 gc=0 do cg1=1, numal do cg2=1, cg1 gc=gc+1 transprob(gc,gf,gm) = 0.25d0 * parcon(cg1, cg2, pg1, pg2, mg1, mg2, .false.) end do end do end do end do end do end do end subroutine filltrans ! ! Product of posterior values for all matings of ego ! function postprod(idx, geno, nmates, mates, postp) implicit none double precision :: postprod integer, intent(in) :: idx, geno integer, dimension(:) :: nmates integer, dimension(:,:) :: mates double precision, dimension(:,:), intent(in) :: postp integer :: i double precision :: p postprod=1.0d0 if (nmates(idx)==0) return do i=1, nmates(idx) p=postp(mates(idx,i),geno) if (p==0.0d0) then postprod=0.0d0 return end if postprod=postprod*p end do end function postprod ! ! Product of posterior values for all matings of ego save one ! function postprodex(idx, except, geno, nmates, mates, postidx, postp) use pairlist_class implicit none double precision :: postprodex integer, intent(in) :: idx, except, geno integer, dimension(:) :: nmates integer, dimension(:,:) :: mates type (pairlist_data) :: postidx double precision, dimension(:,:), intent(in) :: postp integer :: i double precision :: p postprodex=1.0d0 if (nmates(idx)==1) return do i=1, nmates(idx) if (postidx%pairs(mates(idx,i),2) /= except) then p=postp(mates(idx,i),geno) if (p==0.0d0) then postprodex=0.0d0 return end if postprodex=postprodex*p end if end do end function postprodex ! ! Sum of posterior value scaling factors for all matings of ego ! function postscale(idx, nmates, mates, pscale) implicit none double precision :: postscale integer, intent(in) :: idx integer, dimension(:) :: nmates integer, dimension(:,:) :: mates double precision, dimension(:), intent(in) :: pscale integer :: j postscale=0.0d0 if (nmates(idx)==0) return do j=1, nmates(idx) postscale=postscale + pscale(mates(idx,j)) end do end function postscale ! ! Sum of posterior value scaling factors for all matings of ego ! function postscalex(idx, except, nmates, mates, postidx, pscale) use pairlist_class implicit none double precision :: postscalex integer, intent(in) :: idx, except integer, dimension(:) :: nmates integer, dimension(:,:) :: mates type (pairlist_data) :: postidx double precision, dimension(:), intent(in) :: pscale integer :: j postscalex=0.0d0 if (nmates(idx)==1) return do j=1, nmates(idx) if (postidx%pairs(mates(idx,j),2) /= except) then postscalex = postscalex + pscale(mates(idx,j)) end if end do end function postscalex ! ! Length of list of genotypes ! function nglist(gtp,ngeno) integer :: nglist integer, intent(in) :: gtp, ngeno if (gtp == 0) then nglist=ngeno else nglist=1 end if end function nglist ! ! member of list of genotypes ! function glist(gtp, idx) integer :: glist integer, intent(in) :: idx, gtp if (gtp == 0) then glist=idx else glist=gtp end if end function glist ! ! Likelihood from iterative peeling ! subroutine itlik(trget, ngeno, gtp, nmates, mates, antp, postp, ascale, pscale, lik) integer, intent(in) :: trget integer, intent(in) :: ngeno integer, dimension(:), intent(in) :: gtp integer, dimension(:), intent(in) :: nmates integer, dimension(:,:), intent(in) :: mates double precision, dimension(:,:), intent(in) :: antp, postp double precision, dimension(:), intent(in) :: ascale, pscale double precision, intent(out) :: lik integer :: g, geno, m, pos double precision contrib, sumpscale ! functioons integer :: glist, nglist lik=0.0d0 do g=1, nglist(gtp(trget), ngeno) geno=glist(gtp(trget),g) contrib=antp(trget,geno) do m=1, nmates(trget) pos=mates(trget,m) contrib=contrib*postp(pos,geno) end do lik=lik+contrib end do sumpscale=0.0d0 do m=1, nmates(trget) pos=mates(trget,m) sumpscale=sumpscale+pscale(pos) end do if (lik /= 0.0d0) then lik=log(lik) + ascale(trget) + sumpscale end if end subroutine itlik ! ! Two locus version ! typ=1 likelihood ! typ=2 grid ! typ=3 GPE at r=0 ! typ=4 first locus allelic dose, r=0 ! subroutine dopeel2(typ, mark1, mark2, theta, maxiter, & allele_buffer1, allele_buffer2, dataset, plevel) use outstream use ped_class use alleles_class implicit none integer, intent(in) :: typ integer, intent(in) :: mark1, mark2 double precision, intent(in) :: theta integer, intent(in) :: maxiter type (allele_data), intent(in) :: allele_buffer1, allele_buffer2 type (ped_data) :: dataset integer, intent(in) :: plevel ! local variables integer, parameter :: MAXGRID = 11 double precision, parameter :: lodconst = 0.43429448190325182765d0 integer :: ifail, ig, ng1, ng2, ngeno, ped logical :: obrec, mesg1, mesg2 character (len=3) :: histo ! prior phased genotype frequencies integer, dimension(:,:), allocatable :: phased double precision, dimension(:), allocatable :: gfrq double precision :: lod integer :: ngrid integer, dimension(MAXGRID) :: istat double precision, dimension(MAXGRID) :: grid, lik, totlik ng1=allele_buffer1%numal**2 ng2=allele_buffer2%numal**2 ngeno=ng1*ng2 allocate(phased(ngeno,4)) allocate(gfrq(ngeno)) call fillphase(allele_buffer1, allele_buffer2, ngeno, phased, gfrq) if (typ == 2) then ngrid=2 grid(1)=0.5d0 grid(2)=theta else if (typ == 3 .or. typ == 4) then ngrid=1 grid(1)=theta else ngrid=11 grid(1)=0.5d0 grid(2)=0.0001d0 grid(3)=0.01d0 grid(4)=0.025d0 grid(5)=0.05d0 grid(6)=0.075d0 grid(7)=0.1d0 grid(8)=0.15d0 grid(9)=0.2d0 grid(10)=0.3d0 grid(11)=0.4d0 end if istat(1:ngrid)=0 if (plevel > 0) then write(outstr, '(/a/a)') & ' Pedigree LogLikelihood LOD Theta', & '-------------- -------------- --------- -------' end if mesg1=.false. mesg2=.false. obrec=.false. totlik=0.0d0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then call itpeel2(typ, ped, dataset, mark1, mark2, & allele_buffer1, allele_buffer2, ngeno, phased, gfrq, ngrid, & grid, lik, istat, maxiter, ifail, plevel) do ig=1, ngrid totlik(ig)=totlik(ig)+lik(ig) end do if (plevel > 0) then do ig=1, ngrid if (plevel == 0 .or. plevel == 1) then histo=' ' if (istat(ig) == 1) then histo='*' else if (istat(ig) == 2) then histo='**' else if (ifail == 3) then histo='(U)' else if (ifail == 4) then histo='(E)' end if if (lik(ig) /= 0.0d0) then lod=lodconst*(lik(ig)-lik(1)) else lod=-99.9d0 end if write(outstr,'(a14,g16.6,1x,f8.3,3x,f6.4,1x,a)') & dataset%pedigree(ped), lik(ig), lod, grid(ig), histo end if if (istat(ig) == 1) mesg1=.true. if (istat(ig) == 2) mesg2=.true. end do end if end if end do if (ngrid > 1) then write(outstr, '(/a/a)') & ' LogLikelihood LOD Theta', & '-------------- --------- -------' do ig=1, ngrid if (totlik(ig) /= 0.0d0 .and. istat(ig) /= 3) then lod=lodconst*(totlik(ig)-totlik(1)) else lod=-99.0d0 end if histo=' ' if (istat(ig) == 1) then histo='*' else if (istat(ig) == 2) then histo='**' end if write(outstr,'(g16.6,1x,f8.3,3x,f6.4,1x,a)') totlik(ig), lod, grid(ig), histo end do if (mesg1) then write(outstr,'(/a,i4,a/7x,a)') & 'NOTE: * denotes a likelihood that did not converge in ', maxiter, & ' iterations.','If loops are present, this algorithm does not converge!' end if if (mesg2) then write(outstr,'(/a)') & 'NOTE: ** denotes a user interrupted calculation.' end if end if end subroutine dopeel2 ! ! Iterative peeling two codominant loci over grid of recombination fractions: pth ped ! subroutine itpeel2(typ, ped, dataset, mark1, mark2, & allele_buffer1, allele_buffer2, ngeno, phased, gfrq, & ngrid, grid, famlik, istat, maxiter, ifail, plevel) use interrupt use outstream use ped_class use alleles_class use pairlist_class use genolist_class implicit none integer, parameter :: MAXGRID = 11 integer, intent(in) :: typ integer, intent(in) :: ped type (ped_data) :: dataset integer, intent(in) :: mark1, mark2 type (allele_data), intent(in) :: allele_buffer1, allele_buffer2 ! phased genotype frequencies integer, intent(in) :: ngeno integer, dimension(ngeno,4), intent(in) :: phased double precision, dimension(ngeno), intent(in) :: gfrq ! pedigree loglikelihoods over grid of intermarker thetas integer, intent(in) :: ngrid double precision, dimension(MAXGRID), intent(in) :: grid double precision, dimension(MAXGRID), intent(out) :: famlik ! status of that evaluation integer, dimension(MAXGRID), intent(inout) :: istat integer, intent(in) :: maxiter integer, intent(out) :: ifail integer, intent(in) :: plevel ! local variables integer, parameter :: KNOWN = 0, MISS=-9999 ! ! antp contains individual anterior values: num x ngeno ! postidx is list of matings: 1..nmatings x 2 (fa and mo) ! postp contains mating posterior values: nmatings x ngeno ! sibships is table of sibships: nmatings x 2 (start and end) ! ascale, pscale: scaling factors for anterior and posterior values ! peelseq is ordering of individuals: num ! type (pairlist_data) :: postidx double precision, dimension(:,:), allocatable :: antp, postp double precision, dimension(:), allocatable :: ascale, pscale integer, dimension(:,:), allocatable :: sibships integer, dimension(:), allocatable :: peelseq ! ! single locus phenosets used to generate joint phenosets integer, dimension(:,:), allocatable :: set1, set2 integer, dimension(:,:,:), allocatable :: gset1, gset2 ! ! copy of current pedigree integer :: nfound, num, pedoffset integer, dimension(dataset%maxact) :: fa, mo, imztwin ! List of legal genotypes type (genolist_data), dimension(dataset%maxact) :: gtp ! count of mates per person integer :: maxmates integer, dimension(dataset%maxact) :: nmates integer, dimension(:,:), allocatable :: mates ! penetrance working array integer, dimension(ngeno) :: penetrances ! GPEs double precision, dimension(ngeno) :: gpe ! index person to peel to, and their likelihood results integer :: trget double precision, dimension(maxiter) :: tlik integer :: cfa, cmo, fin, h1, h2, i, idx, ig, ii, it, & j, jkids, jsibs, k, m, nuntyp1, nuntyp2, ph1, ph2, pos, sta integer :: g, g1, g2, g3, g4, gf, gj, gm, gs, ng, ng1, ng2 integer :: imp, imputd, inconsist ! ! current genotype for ego, father, mother, sibling, child, jth_spouse integer :: geno, cgeno, fgeno, jgeno, mgeno, sgeno character (len=7) :: cgtp, cgtp2 double precision :: prec, pnrec double precision :: contrib, currant, curpost, curscale, delta, dose, & kidres, oldlik, lik, mcontrib, rat1, rat2, res, & sibres, totp, trans, trans1 integer, dimension(2) :: first, second ! functions integer :: glist2, nglist2 double precision :: ln, transprob interface subroutine exclude_oneped(imp, reduce, locnam, gene, xlinkd, ped, dataset, & allele_buffer, set, gset, inconsist, imputd, plevel) use ped_class use alleles_class implicit none integer, intent(inout) :: imp logical, intent(in) :: reduce character (len=20), intent(in) :: locnam logical, intent(in) :: xlinkd integer, intent(in) :: gene integer, intent(in) :: ped type (ped_data) :: dataset type (allele_data), intent(in) :: allele_buffer integer, dimension(:,:) :: set integer, dimension(:,:,:) :: gset integer, intent(inout) :: inconsist integer, intent(out) :: imputd integer, intent(in) :: plevel end subroutine exclude_oneped end interface interface function postprod(idx, geno, nmates, mates, postp) implicit none double precision :: postprod integer, intent(in) :: idx, geno integer, dimension(:) :: nmates integer, dimension(:,:) :: mates double precision, dimension(:,:), intent(in) :: postp end function postprod function postprodex(idx, except, geno, nmates, mates, postidx, postp) use pairlist_class implicit none double precision :: postprodex integer, intent(in) :: idx, except, geno integer, dimension(:) :: nmates integer, dimension(:,:) :: mates type (pairlist_data) :: postidx double precision, dimension(:,:), intent(in) :: postp end function postprodex function postscale(idx, nmates, mates, pscale) implicit none double precision :: postscale integer, intent(in) :: idx integer, dimension(:) :: nmates integer, dimension(:,:) :: mates double precision, dimension(:), intent(in) :: pscale end function postscale function postscalex(idx, except, nmates, mates, postidx, pscale) use pairlist_class implicit none double precision :: postscalex integer, intent(in) :: idx, except integer, dimension(:) :: nmates integer, dimension(:,:) :: mates type (pairlist_data) :: postidx double precision, dimension(:), intent(in) :: pscale end function postscalex subroutine itlik2(trget, gtp, nmates, mates, antp, postp, ascale, pscale, lik) use genolist_class integer, intent(in) :: trget type (genolist_data), dimension(:), intent(in) :: gtp integer, dimension(:), intent(in) :: nmates integer, dimension(:,:), intent(in) :: mates double precision, dimension(:,:), intent(in) :: antp, postp double precision, dimension(:), intent(in) :: ascale, pscale double precision, intent(out) :: lik end subroutine itlik2 end interface ifail=0 famlik(:)=0.0d0 delta=0.0001d0 ng1=allele_buffer1%numal**2 ng2=allele_buffer2%numal**2 nfound=dataset%nfound(ped) pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset call workpointers(ped, dataset, fa, mo, imztwin) ! Count up matings nmates=0 call setup_pairs(num, postidx) do i=nfound+1, num call insert_pair(fa(i), mo(i), postidx) call insert_pair(mo(i), fa(i), postidx) end do do pos=1, postidx%npairs nmates(postidx%pairs(pos,1))=nmates(postidx%pairs(pos,1))+1 end do maxmates=0 do i=1, num if (nmates(i) > maxmates) maxmates=nmates(i) end do ! if (plevel > 1) then write(outstr,'(/3a,4(/a,i7)/)') & 'Pedigree = "', trim(dataset%pedigree(ped)), '"', & 'Number of members = ', num, & 'Number of founders = ', nfound, & 'Number of nuclear families = ', postidx%npairs/2, & 'Largest number of mates = ', maxmates end if ! ! Produce phenosets ! allocate(set1(num,2)) allocate(set2(num,2)) allocate(gset1(num,allele_buffer1%numgtp+1,2)) allocate(gset2(num,allele_buffer2%numgtp+1,2)) inconsist=0 imputd=0 imp=0 call exclude_oneped(imp, .false., 'loc1 ', mark1, .false., & ped, dataset, allele_buffer1, set1, gset1, inconsist, imputd, plevel-2) call exclude_oneped(imp, .false., 'loc2 ', mark2, .false., & ped, dataset, allele_buffer2, set2, gset2, inconsist, imputd, plevel-2) if (inconsist > 0) then ifail=4 return end if nuntyp1=0 nuntyp2=0 do i=1, num if (set1(i,1) > 1) nuntyp1=nuntyp1+1 if (set2(i,1) > 1) nuntyp2=nuntyp2+1 ng=0 do j=1, set1(i,1) h1=2 if (gset1(i,j,1) == gset1(i,j,2)) h1=h1/2 do k=1, set2(i,1) h2=2 if (gset2(i,k,1) == gset2(i,k,2)) h2=h2/2 ng=ng+h1*h2 end do end do gtp(i)%ngeno=ng allocate(gtp(i)%glist(ng)) ng=0 do j=1, set1(i,1) h1=2 g1=gset1(i,j,1) g2=gset1(i,j,2) if (g1 == g2) h1=h1/2 first(1)=allele_buffer1%numal*(g1-1)+g2 first(2)=allele_buffer1%numal*(g2-1)+g1 do k=1, set2(i,1) h2=2 g3=gset2(i,k,1) g4=gset2(i,k,2) if (g3 == g4) h2=h2/2 second(1)=allele_buffer2%numal*(g3-1)+g4 second(2)=allele_buffer2%numal*(g4-1)+g3 do ph1=1, h1 do ph2=1, h2 ng=ng+1 gtp(i)%glist(ng)=ng2*(first(ph1)-1)+second(ph2) end do end do end do end do end do if (plevel > 1) then ii=pedoffset do i=1, num ii=ii+1 g1=MISS g2=MISS g3=MISS g4=MISS if (observed(ii, mark1, dataset)) then call get_geno(ii, mark1, mark1+1, dataset, g1, g2) end if if (observed(ii, mark2, dataset)) then call get_geno(ii, mark2, mark2+1, dataset, g3, g4) end if call wrgtp(g1, g2, cgtp, '/', '', 1) call wrgtp(g3, g4, cgtp2, '/', '', 1) write(outstr,'(a15,1x,a7,1x,a7,1x,i0,(10(1x,i0):))', advance='no') & trim(dataset%pedigree(ped)) // '--' // trim(dataset%id(ii)), & cgtp, cgtp2, gtp(i)%ngeno, gtp(i)%glist(1:min(10,gtp(i)%ngeno)) if (gtp(i)%ngeno > 10) then write(outstr,'(a,2(1x,i0))') '...', gtp(i)%glist((gtp(i)%ngeno-1):gtp(i)%ngeno) else write(outstr,*) end if end do end if ! ! Record joint genotypes (here coded as a genotype number) ! Initialize anterior probabilities and posterior values (and peeling seq) ! allocate(peelseq(num)) allocate(antp(num, ngeno), ascale(num)) allocate(postp(postidx%npairs, ngeno), pscale(postidx%npairs)) allocate(sibships(postidx%npairs,2)) allocate(mates(num, maxmates)) trget=num ii=pedoffset do i=1, num ii=ii+1 peelseq(i)=i do g=1, ngeno antp(i,g)=gfrq(g) end do ascale(i)=0.0d0 end do if (plevel > 2) write(outstr,*) ! Skip if no-one in pedigree typed at a locus if (nuntyp1 == num .or. nuntyp2 == num) then lik=0.0d0 ifail=3 return end if ! ! And pointer to one's marriage nodes nmates=0 do pos=1, postidx%npairs nmates(postidx%pairs(pos,1))=nmates(postidx%pairs(pos,1))+1 mates(postidx%pairs(pos,1),nmates(postidx%pairs(pos,1)))=pos postp(pos,1:ngeno)=1.0d0 pscale(pos)=0.0d0 end do ! ! List of sibships ! cfa=MISS cmo=MISS i=nfound do while (i < num) i=i+1 if (cfa /= fa(i) .or. cmo /= mo(i)) then cfa=fa(i) cmo=mo(i) sta=i pos=i do pos=pos+1 if (pos > num) exit if (cfa /= fa(pos) .or. cmo /= mo(pos)) exit end do fin=pos-1 pos=find_pair(cfa, cmo, postidx) sibships(pos,1)=sta sibships(pos,2)=fin pos=find_pair(cmo, cfa, postidx) sibships(pos,1)=sta sibships(pos,2)=fin i=fin end if end do ! ! Main loop ! do ig=1, ngrid ifail=0 prec=0.5d0*grid(ig) pnrec=0.5d0*(1.0d0-grid(ig)) it=0 oldlik=0.0d0 tlik=0.0d0 mainloop: do it=it+1 do i=1, num if (irupt > 0) then ifail=2 exit mainloop end if idx=peelseq(i) if (idx > nfound) then pos=find_pair(fa(idx), mo(idx), postidx) sta=sibships(pos,1) fin=sibships(pos,2) else sta=idx fin=idx end if ! ! ith individual anterior values ! if (idx > nfound) then ! ego's anterior value for g'th genotype totp=0.0d0 do g=1, nglist2(gtp(idx)) geno=glist2(gtp(idx),g) currant=0.0d0 ! Sum over anterior values for ego's father's gf'th genotype by do gf=1, nglist2(gtp(fa(idx))) fgeno=glist2(gtp(fa(idx)), gf) if (antp(fa(idx),fgeno) > 0.0d0) then ! Product over posterior values of father's other matings by ! Sum over anterior values for ego's mother's gm'th genotype mcontrib=0.0d0 do gm=1, nglist2(gtp(mo(idx))) mgeno=glist2(gtp(mo(idx)),gm) if (antp(mo(idx), mgeno) > 0.0d0) then ! ! Product over posterior values of mother's other matings by ! product over contribution of ego's siblings of contrib=1.0d0 trans1=transprob(geno, fgeno, mgeno, ngeno, phased, & prec, pnrec) if (trans1 > 0.0d0) then do jsibs= sta, fin if (jsibs /= idx) then ! ! Sum over gs sibling genotypes of jth sibling of sibres=0.0d0 do gs=1, nglist2(gtp(jsibs)) sgeno=glist2(gtp(jsibs),gs) trans=transprob(sgeno, fgeno, mgeno, ngeno, phased, & prec, pnrec) if (trans > 0.0d0) then ! Product of all posterior values of jsibs'th sibling's gs'th genotype sibres=sibres+trans*postprod(jsibs, sgeno, & nmates, mates, postp) end if end do contrib=contrib*sibres end if end do mcontrib=mcontrib + antp(mo(idx),mgeno) * & postprodex(mo(idx), fa(idx), mgeno, & nmates, mates, postidx, postp) * & trans1 * contrib end if end if end do currant=currant + antp(fa(idx), fgeno) * & postprodex(fa(idx), mo(idx), fgeno, & nmates, mates, postidx, postp) * & mcontrib end if end do antp(idx,geno) = currant totp=totp + currant end do totp=ln(totp) ! log scaling factor for anterior values curscale=ascale(fa(idx)) + ascale(mo(idx)) + totp + & postscalex(fa(idx), mo(idx), nmates, mates, postidx, pscale) + & postscalex(mo(idx), fa(idx), nmates, mates, postidx, pscale) do jsibs= sta, fin if (jsibs /= idx) then curscale = curscale + postscale(jsibs, nmates, mates, pscale) end if end do ascale(idx) = curscale ! rescale anterior values do g=1, nglist2(gtp(idx)) geno=glist2(gtp(idx),g) if (antp(idx, geno) /= 0.0d0) then antp(idx,geno) = exp(log(antp(idx,geno))-totp) end if end do end if ! ! ith individual posterior values ! totp=0.0d0 do g=1, nglist2(gtp(idx)) geno=glist2(gtp(idx),g) do m=1, nmates(idx) pos=mates(idx,m) j=postidx%pairs(pos, 2) curpost=0.0d0 gloop: do gj=1, nglist2(gtp(j)) jgeno=glist2(gtp(j),gj) if (antp(j,jgeno) > 0.0d0) then ! ! Product of posterior values for j via all other matings res=postprodex(j, idx, jgeno, nmates, mates, postidx, postp) ! ! Product of posterior value contributions for all offspring of i and j do jkids= sibships(pos,1), sibships(pos,2) kidres=0.0d0 do gs=1, nglist2(gtp(jkids)) cgeno=glist2(gtp(jkids),gs) trans=transprob(cgeno, geno, jgeno, ngeno, phased, & prec, pnrec) if (trans > 0.0d0) then ! Product of posterior values for all matings of this child kidres=kidres+trans*postprod(jkids, cgeno, & nmates, mates, postp) end if end do res=res*kidres if (res == 0.0d0) cycle gloop end do curpost=curpost+antp(j,jgeno) * res end if end do gloop postp(pos,geno) = curpost totp=totp+curpost end do end do ! log scaling factor for posterior values totp=ln(totp) do m=1, nmates(idx) pos=mates(idx,m) j=postidx%pairs(pos, 2) curscale = ascale(j) + totp + & postscalex(j, idx, nmates, mates, postidx, pscale) do jkids=sibships(pos,1), sibships(pos,2) curscale = curscale + postscale(jkids, nmates, mates, pscale) end do pscale(pos)=curscale ! rescale posterior values do g=1, nglist2(gtp(idx)) geno=glist2(gtp(idx),g) if (postp(pos, geno) /= 0.0d0) then postp(pos,geno) = exp(log(postp(pos,geno))-totp) end if end do end do end do ! ! Likelihood ! call itlik2(trget, gtp, nmates, mates, antp, postp, ascale, pscale, lik) tlik(it)=lik if (plevel > 1) then rat1=0.0d0 if (oldlik /= 0.0d0) rat1=lik/oldlik write(outstr,'(3a,i4,2(a,g16.6),a,f8.4)') & 'Pedigree ', trim(dataset%pedigree(ped)), & ' It ', it, ' Lik ', lik, ' Diff ', lik-oldlik, ' Ratio ', rat1 end if if (plevel > 2) then write(outstr,'(/a/)') 'Scaled anterior values' do i=1, num ng=nglist2(gtp(i)) if (ng < ngeno) then penetrances=0 do j=1, ng penetrances(gtp(i)%glist(j))=1 end do else penetrances=1 end if write(outstr,'(a10,2x)', advance='no') & trim(dataset%id(pedoffset+i)) do g=1, ngeno if (penetrances(g) == 1) then write(outstr,'(1x,f6.4)', advance='no') antp(i,g) else write(outstr,'(2x,a1,4x)', advance='no') '-' end if end do write(outstr,*) ' scale=', ascale(i) end do write(outstr,'(/a/)') 'Scaled posterior values' do pos=1, postidx%npairs ii=postidx%pairs(pos,1) ng=nglist2(gtp(ii)) if (ng < ngeno) then penetrances=0 do j=1, ng penetrances(gtp(ii)%glist(j))=1 end do else penetrances=1 end if write(outstr,'(a20,1x)', advance='no') & trim(dataset%id(pedoffset+postidx%pairs(pos,1))) // ',' // & trim(dataset%id(pedoffset+postidx%pairs(pos,2))) do g=1, ngeno if (penetrances(g) == 1) then write(outstr,'(1x,f6.4)', advance='no') postp(pos,g) else write(outstr,'(2x,a1,4x)', advance='no') '-' end if end do write(outstr,*) ' scale=', pscale(pos) end do write(outstr,*) end if if (abs(lik-oldlik) <= delta .and. it > 2) exit if (it >= maxiter) then ifail=1 exit end if oldlik=lik end do mainloop ! GPE if (typ == 3 .or. typ == 4) then if (typ == 3) then write(outstr,'(/a/a)') ' Individual Phased genotype (proportion)', & '-------------- -----------------------------' else write(outstr,'(/a/a)') ' Individual Allelic dose', & '-------------- -------------' end if do idx=1, num totp=0.0d0 gpe=0.0d0 do g=1, gtp(idx)%ngeno geno=gtp(idx)%glist(g) gpe(geno)=antp(idx,geno) * postprod(idx, geno, nmates, mates, postp) totp=totp+gpe(geno) end do if (totp > 0.0d0) then do g=1, gtp(idx)%ngeno geno=gtp(idx)%glist(g) gpe(geno)=gpe(geno)/totp end do end if write(outstr,'(a20,1x)', advance='no') & trim(dataset%pedigree(ped)) // '--' // & trim(dataset%id(pedoffset+idx)) if (typ == 3) then pos=20 do g=1, gtp(idx)%ngeno geno=gtp(idx)%glist(g) if (gpe(geno) > 0.0d0) then pos=pos+13 call newlin(22, 78, pos, 21) write(outstr,'(1x,2i1,a,2i1,1x,f6.4)', advance='no') & phased(geno,1), phased(geno,3), '|', & phased(geno,2), phased(geno,4), gpe(geno) end if end do write(outstr,*) else dose=0.0d0 do g=1, gtp(idx)%ngeno geno=gtp(idx)%glist(g) if (gpe(geno) > 0.0d0) then if (phased(geno,1) == 1) dose=dose+gpe(geno) if (phased(geno,2) == 1) dose=dose+gpe(geno) end if end do dose=0.5d0*dose write(outstr,'(1x,f6.4)') dose end if end do end if ! oldlik=lik cgtp=' ' if (ifail == 1) then cgtp='*' lik=tlik(1) else if (ifail == 2) then cgtp='**' lik=tlik(1) end if if (plevel > 1) then write(outstr, '(/a,g16.6,4a)') & 'Pedigree Log Likelihood = ', oldlik, & ' (via ', trim(dataset%id(trget+pedoffset)), ') ', trim(cgtp) if (ifail /= 0) then write(outstr, '(a,g16.6)') & 'First iteration LogLik = ', lik if (ifail == 1 .and. maxiter > 3) then rat1=tlik(maxiter)/tlik(maxiter-1) rat2=tlik(maxiter-1)/tlik(maxiter-2) if (abs(rat1-rat2) < 0.01d0) then write(outstr, '(a,g16.6)') & 'Back-interpolated LogLik = ', & tlik(maxiter)/rat1**(maxiter-1) end if end if end if end if famlik(ig)=lik istat(ig)=max(ifail, istat(ig)) end do deallocate(mates, sibships) deallocate(antp, peelseq, postp) deallocate(ascale, pscale) end subroutine itpeel2 ! ! Length of list of genotypes ! function nglist2(gtp) use genolist_class integer :: nglist2 type (genolist_data), intent(in) :: gtp nglist2=gtp%ngeno end function nglist2 ! ! member of list of genotypes ! function glist2(gtp, idx) use genolist_class integer :: glist2 type (genolist_data), intent(in) :: gtp integer, intent(in) :: idx glist2=gtp%glist(idx) end function glist2 ! ! Parent-offspring triad ! function transprob(geno, fgeno, mgeno, ngeno, phased, prec, pnrec) double precision :: transprob integer, intent(in) :: geno, fgeno, mgeno integer, intent(in) :: ngeno integer, dimension(ngeno,4), intent(in) :: phased double precision, intent(in) :: pnrec, prec ! functions double precision :: transmit transprob=transmit(phased(fgeno,1), phased(fgeno,2), & phased(fgeno,3), phased(fgeno,4), & phased(geno,1), phased(geno,3), prec, pnrec) if (transprob == 0.0d0) return transprob=transprob * transmit(phased(mgeno,1), phased(mgeno,2), & phased(mgeno,3), phased(mgeno,4), & phased(geno,2), phased(geno,4), prec, pnrec) end function transprob ! ! Transmission probabilities: two codominant loci, phased genotypes ! ! p11 | p12 c1 ! | => ! p21 | p22 c2 ! function transmit(p11, p12, p21, p22, c1, c2, prec, pnrec) double precision :: transmit integer, intent(in) :: p11, p12, p21, p22 integer, intent(in) :: c1, c2 double precision, intent(in) :: pnrec, prec double precision :: p p=0.0d0 if (p11 == c1 .and. p21 == c2) p=p+pnrec if (p11 == c1 .and. p22 == c2) p=p+prec if (p12 == c1 .and. p21 == c2) p=p+prec if (p12 == c1 .and. p22 == c2) p=p+pnrec transmit=p ! write(*,*) p11, p21, ';', p12, p22,' -> ', c1, c2, ' = ', transmit end function transmit ! ! Likelihood from iterative peeling ! subroutine itlik2(trget, gtp, nmates, mates, antp, postp, ascale, pscale, lik) use genolist_class integer, intent(in) :: trget type (genolist_data), dimension(:), intent(in) :: gtp integer, dimension(:), intent(in) :: nmates integer, dimension(:,:), intent(in) :: mates double precision, dimension(:,:), intent(in) :: antp, postp double precision, dimension(:), intent(in) :: ascale, pscale double precision, intent(out) :: lik integer :: g, geno, m, pos double precision contrib, sumpscale ! functioons integer :: glist2, nglist2 lik=0.0d0 do g=1, nglist2(gtp(trget)) geno=glist2(gtp(trget),g) contrib=antp(trget,geno) do m=1, nmates(trget) pos=mates(trget,m) contrib=contrib*postp(pos,geno) end do lik=lik+contrib end do sumpscale=0.0d0 do m=1, nmates(trget) pos=mates(trget,m) sumpscale=sumpscale+pscale(pos) end do if (lik /= 0.0d0) then lik=log(lik) + ascale(trget) + sumpscale end if end subroutine itlik2 ! ! Phased genotype frequencies ! subroutine fillphase(allele_buffer1, allele_buffer2, ngeno, phased, gfrq) use alleles_class type (allele_data), intent(in) :: allele_buffer1, allele_buffer2 integer, intent(in) :: ngeno integer, dimension(ngeno,4), intent(inout) :: phased double precision, dimension(ngeno), intent(inout) :: gfrq ! integer :: g1, g2, g3, g4, ng1, ng2 integer, dimension(2) :: first, second double precision :: p1, p2, p3, p4 ng1=allele_buffer1%numal * allele_buffer1%numal ng2=allele_buffer2%numal * allele_buffer2%numal do g1=1, allele_buffer1%numal p1=allele_buffer1%allele_freqs(g1) do g2=1, g1 first(1)=allele_buffer1%numal*(g1-1)+g2 first(2)=allele_buffer1%numal*(g2-1)+g1 p2=allele_buffer1%allele_freqs(g2)*p1 do g3=1, allele_buffer2%numal p3=allele_buffer2%allele_freqs(g3)*p2 do g4=1, g3 second(1)=allele_buffer2%numal*(g3-1)+g4 second(2)=allele_buffer2%numal*(g4-1)+g3 p4=allele_buffer2%allele_freqs(g4)*p3 phased(ng2*(first(1)-1)+second(1),1)=g1 phased(ng2*(first(1)-1)+second(1),2)=g2 phased(ng2*(first(1)-1)+second(1),3)=g3 phased(ng2*(first(1)-1)+second(1),4)=g4 gfrq(ng2*(first(1)-1)+second(1))=p4 phased(ng2*(first(1)-1)+second(2),1)=g1 phased(ng2*(first(1)-1)+second(2),2)=g2 phased(ng2*(first(1)-1)+second(2),3)=g4 phased(ng2*(first(1)-1)+second(2),4)=g3 gfrq(ng2*(first(1)-1)+second(2))=p4 phased(ng2*(first(2)-1)+second(1),1)=g2 phased(ng2*(first(2)-1)+second(1),2)=g1 phased(ng2*(first(2)-1)+second(1),3)=g3 phased(ng2*(first(2)-1)+second(1),4)=g4 gfrq(ng2*(first(2)-1)+second(1))=p4 phased(ng2*(first(2)-1)+second(2),1)=g2 phased(ng2*(first(2)-1)+second(2),2)=g1 phased(ng2*(first(2)-1)+second(2),3)=g4 phased(ng2*(first(2)-1)+second(2),4)=g3 gfrq(ng2*(first(2)-1)+second(2))=p4 end do end do end do end do end subroutine fillphase ! subroutine dochol(n) use iobuff use outstream use symmetric_matrix use rngs integer, intent(in) :: n double precision, dimension(n*(n+1)/2) :: a, r integer :: nn, nel, nullty, ifault nn=n*(n+1)/2 write(outstr,'(a,i0,a)') 'Enter ', nn, ' values (lower triangular by rows):' read(incstr(ilevel),*) a(1:nn) nel=0 do i=1, n write(outstr,'(10(1x,f6.3):)') a(nel+1:nel+i) nel=nel+i end do call chol(a, n, nn, r, nullty, ifault) if (ifault /= 0) then write(outstr,'(a,i0)') 'ifault = ', ifault end if write(outstr,*) nel=0 do i=1, n write(outstr,'(10(1x,f6.3):)') r(nel+1:nel+i) nel=nel+i end do if (nullty > 0) then write(outstr,'(/a,i0)') 'nullty = ', nullty end if end subroutine dochol ! subroutine doeigen(n) use iobuff use outstream integer, intent(in) :: n double precision, dimension(n*(n+1)/2) :: a double precision, dimension(n*n) :: r integer :: nel double precision :: den nel=n*(n+1)/2 den=0.0d0 write(outstr,'(a,i0,a)') 'Enter ', nel, ' values (lower triangular by rows):' read(incstr(ilevel),*) a(1:nel) nel=0 do i=1, n write(outstr,'(10(1x,f6.3):)') a(nel+1:nel+i) nel=nel+i end do call eigen(1, n, a, r) write(outstr,'(a/6(1x,g10.4):)') 'Eigenvalues: ', a(1:n) do i=1, n den=den+a(i) end do do i=1, n a(i)=a(i)/den end do write(outstr,'(a/6(2x,f5.3,4x):)') 'Proportion variance: ', a(1:n) write(outstr,'(a)') 'Eigenvectors: ' nel=0 do i=1, n write(outstr,'(6(1x,g10.4):)') (r(i+j*n),j=0,n-1) nel=nel+n end do end subroutine doeigen ! ! double centre a distance matrix (lower triangular form) ! used for MDS ! subroutine dcentre(n, nn, x) integer, intent(in) :: n, nn double precision, dimension(nn), intent(inout) :: x integer :: i, idx, j double precision, dimension(n) :: s double precision :: tot ! functions integer :: clcpos tot=0.0d0 do i=1, n s(i)=0.0d0 do j=1, n s(i)=s(i)+x(clcpos(i,j)) end do s(i)=s(i)/dble(n) tot=tot+s(i) end do tot=tot/dble(n) do i=1, n do j=1, i idx=clcpos(i,j) x(idx)=x(idx)-s(i)-s(j)+tot end do end do end subroutine dcentre ! ! Oakes' Kendall tau for bivariate survival analysis ! contrasting monozygotic twins v. other siblings. ! subroutine twinken(locnam, trait, cenloc, censor, mztwin, gt, thresh, dataset, & iter, mincnt, norder, plevel) use interrupt use outstream use ped_class use rngs use sorts implicit none character(len=20), intent(in) :: locnam, cenloc integer, intent(in) :: trait, censor integer, intent(in) :: mztwin integer, intent(in) :: gt double precision, intent(in) :: thresh type (ped_data), intent(inout) :: dataset integer, intent(in) :: iter integer, intent(in) :: mincnt integer, intent(in) :: norder integer, intent(in) :: plevel ! local integer, parameter :: KNOWN=0, MISS=-9999 ! integer, parameter :: nclass=3 integer, dimension(nclass) :: bnc, bnd, nc, nd integer, dimension(0:nclass) :: np double precision, dimension(nclass) :: btau, btaunorm, & btau_mu, btaunorm_mu, btau_var, & btaunorm_var, tau, taunorm, & boddsr, boddsrn, oddsr, oddsrn integer, dimension(:,:), allocatable :: pairs integer, dimension(:), allocatable :: blist, plist, ptype logical :: c1, c2, c3, c4, samefa, samemo, hasdz integer :: i, ii, it, j, jj, k, maxpairs, n, npairs, ped, tailp, tailpn, zyg double precision :: mzdz_mu, mzdz_var double precision :: mzdz_boddsr, mzdz_boddsrn, mzdz_oddsr, mzdz_oddsrn, pval ! extreme tail empirical P values integer :: ntopvals double precision, dimension(norder+2) :: topvals character (len=1), dimension(2) :: yn = (/ 'n', 'y' /) character (len=3), dimension(3) :: zygcode = (/ 'MZ ', 'DZ ', 'Sib' /) ! functions character (len=6) :: pstring double precision :: evdtailp, isaff hasdz=.not.(gt==16 .and. thresh==0.0d0) maxpairs=max(10000, 4*dataset%nact) allocate(pairs(maxpairs,2), plist(maxpairs), ptype(maxpairs), blist(maxpairs)) write(outstr,'(/a/5a/a)') & '--------------------------------------------------------------', & 'Twin survival analysis of "', trim(locnam), & '" for outcome "', trim(cenloc), '"', & '--------------------------------------------------------------' if (plevel > 1) then write(outstr,'(a)') 'Pedigree Person1 Person2 Zyg Trait1 Trait2' end if npairs=0 pairloop: do ped=1, dataset%nped if (dataset%actset(ped) > 0) then ! only iterate nonfounders do i=dataset%num(ped-1)+dataset%nfound(ped)+1, dataset%num(ped)-1 do j=i+1, dataset%num(ped) samefa=(dataset%fa(i) == dataset%fa(j)) samemo=(dataset%mo(i) == dataset%mo(j)) if (.not.samefa .or. .not.samemo) exit ! ! Share parents and zygosity indicator -- MZ (zyg=1) or DZ (zyg=2) twins ! if (dataset%plocus(i,trait) /= MISS .and. & dataset%plocus(j,trait) /= MISS .and. & dataset%plocus(i,censor) /= MISS .and. & dataset%plocus(j,censor) /= MISS) then npairs=npairs+1 if (npairs > maxpairs) exit pairloop zyg=2 if (dataset%plocus(i,mztwin) /= MISS .and. & dataset%plocus(i,mztwin) == dataset%plocus(j,mztwin)) then if (int(isaff(dataset%plocus(i,mztwin),thresh,gt)) == 2 .and. & int(isaff(dataset%plocus(j,mztwin),thresh,gt)) == 2) then zyg=1 end if else if (hasdz) then zyg=3 end if ptype(npairs)=zyg pairs(npairs,1)=i pairs(npairs,2)=j end if end do end do end if end do pairloop if (npairs > maxpairs) then npairs=npairs-1 write(outstr,'(a,i0,a)') 'NOTE: Only analysing first ', npairs, ' pairs.' end if if (plevel > 1) then do i=1, npairs write(outstr,'(a11,2(1x,a),3x,a,2x,2(1x,f9.4), 2(1x,a1))') & dataset%pedigree(dataset%iped(pairs(i,1)))(1:11), & dataset%id(pairs(i,1)), dataset%id(pairs(i,1)), & zygcode(ptype(i)), & dataset%plocus(pairs(i,1),trait), dataset%plocus(pairs(i,2),trait), & yn(int(dataset%plocus(pairs(i,1),censor))), & yn(int(dataset%plocus(pairs(i,2),censor))) end do end if np=0 ii=0 do k=1, nclass do i=1, npairs if (ptype(i) == k) then ii=ii+1 plist(ii)=i end if end do np(k)=ii end do do k=1, nclass call twinkencon(maxpairs, np(k-1), np(k), plist, pairs, trait, censor, dataset, & nc(k), nd(k), tau(k), taunorm(k)) oddsr(k)=(1.0d0+tau(k))/(1.0d0-min(0.999d0,tau(k))) oddsrn(k)=(1.0d0+taunorm(k))/(1.0d0-min(0.999d0,taunorm(k))) end do mzdz_oddsr=oddsr(1)/oddsr(2) mzdz_oddsrn=oddsrn(1)/oddsrn(2) btau_mu=0.0d0 btaunorm_mu=0.0d0 btau_var=0.0d0 btaunorm_var=0.0d0 it=0 do while (it < iter .and. irupt == 0) it=it+1 do k=1, nclass do i=np(k-1)+1, np(k) blist(i)=plist(irandom(1, np(k)-np(k-1))) end do call twinkencon(maxpairs, np(k-1), np(k), blist, pairs, trait, censor, dataset, & bnc(k), bnd(k), btau(k), btaunorm(k)) if (plevel > 1) then write(outstr,'(i0, 3(1x,i0), 2(1x, f7.4))') it, k, bnc(k), bnd(k), btau(k), btaunorm(k) end if call moment(it, btau(k), btau_mu(k), btau_var(k)) call moment(it, btaunorm(k), btaunorm_mu(k), btaunorm_var(k)) end do end do write(outstr,'(/a/a)') & 'Zyg Pairs Conc Disc Tau (BSE) OR Tau(n) (BSE) OR(n)', & '---- ------ ---- ----- ---------------- -------- ----------------- --------' do k=1, nclass n=np(k)-np(k-1) if (n > 0) then btau_var(k)=sqrt(btau_var(k)/dble(max(1,it))) btaunorm_var(k)=sqrt(btaunorm_var(k)/dble(max(1,it))) write(outstr,'(a,1x,i8,1x,i6,1x,i6,2(1x,f7.4,1x,a,f7.4,a,1x,f8.2))') & zygcode(k), n, nc(k), nd(k), tau(k), '(', btau_var(k), ')', & oddsr(k), taunorm(k), '(', btaunorm_var(k), ')', oddsrn(k) end if end do if (plevel > 0) then do k=1, nclass n=np(k)-np(k-1) if (n > 0) then boddsr(k)=(1.0d0+btau(k))/(1.0d0-min(0.999d0,btau(k))) boddsrn(k)=(1.0d0+btaunorm(k))/(1.0d0-min(0.999d0,btaunorm(k))) write(outstr,'(2a,2(1x,f7.4,11x,f8.2))') & zygcode(k), ' Bootstrap means ', & btau(k), boddsr(k), btaunorm(k), boddsrn(k) end if end do end if if (it < iter .or. plevel > 0) then write(outstr,'(/a,i0)') ' Bootstrap iterations = ', it end if ! ! Permute MZ and DZ labels ! Sequential Monte-Carlo P-value after Besag & Clifford Biometrika 1991 ! P= tailp/it if tailp=mincnt or (tailp+1)/(it+1) if tailp<mincnt && it=iter ! if (np(1) > 0 .and. np(2) > np(1)) then it=0 tailp=0 tailpn=0 ntopvals = norder+2 topvals=0.0d0 mzdz_mu=0.0d0 mzdz_var=0.0d0 do while (it < iter .and. tailpn < mincnt .and. irupt == 0) it=it+1 call permut(np(nclass), plist) do k=1, 2 call twinkencon(maxpairs, np(k-1), np(k), plist, pairs, trait, censor, dataset, & bnc(k), bnd(k), btau(k), btaunorm(k)) if (plevel > 1) then write(outstr,'(i0, 3(1x,i0), 2(1x, f7.4))') it, k, bnc(k), bnd(k), btau(k), btaunorm(k) end if boddsr(k)=(1.0d0+btau(k))/(1.0d0-min(0.999d0,btau(k))) boddsrn(k)=(1.0d0+btaunorm(k))/(1.0d0-min(0.999d0,btaunorm(k))) end do mzdz_boddsr=boddsr(1)/boddsr(2) mzdz_boddsrn=boddsrn(1)/boddsrn(2) topvals(1)=mzdz_boddsrn call dsort(ntopvals,topvals) call moment(it, mzdz_boddsrn, mzdz_mu, mzdz_var) if (mzdz_oddsr < mzdz_boddsr .or. & (mzdz_oddsr == mzdz_boddsr .and. random() > 0.5)) then tailp=tailp+1 end if if (mzdz_oddsrn < mzdz_boddsrn .or. & (mzdz_oddsrn == mzdz_boddsrn .and. random() > 0.5)) then tailpn=tailpn+1 end if end do if (tailpn < mincnt) then tailpn=tailpn+1 it=it+1 end if mzdz_var=mzdz_var/dble(max(1,it-1)) pval=evdtailp(tailpn, it, ntopvals, topvals, mzdz_oddsrn) write(outstr, '(a,1x,f8.2,a,f6.4)') write(outstr, '(a,f8.2/a,i0,a,i0,3a/a,f8.2,a,f8.2,a)') & ' MZ:DZ Ratio of OR(n) = ', mzdz_oddsrn, & ' Equalled or exceeded by = ',tailpn,'/',it, & ' simulated values (', trim(pstring(pval)), ')', & ' Mean (Var) simulated OR ratio= ', mzdz_mu, ' (', mzdz_var, ')' if (plevel > 1) then write(outstr,'(/a/11(1x,f8.2):)') ' Top simulated OR ratio:', & topvals(2:ntopvals) write(outstr, '(a,1x,f8.2,a,f6.4)') & 'Unnormalized MZ:DZ R = ', mzdz_oddsr, ' P=', dble(tailp)/dble(it) end if end if end subroutine twinken ! ! Estimate Kendall tau for one set of pairs stored pairs(sta+1, fin) ! subroutine twinkencon(maxpairs, sta, fin, plist, pairs, trait, censor, dataset, & nc, nd, tau, taunorm) use outstream use ped_class implicit none integer, intent(in) :: maxpairs, sta, fin integer, dimension(maxpairs), intent(in) :: plist integer, dimension(maxpairs,2), intent(in) :: pairs integer, intent(in) :: trait, censor type (ped_data), intent(in) :: dataset integer, intent(out) :: nc, nd double precision, intent(out) :: tau, taunorm logical :: c1, c2, c3, c4 integer :: i, ii, j, jj, np integer :: idelta, v1, v2, v3, v4 np=fin-sta nc=0 nd=0 tau=0.0d0 taunorm=0.0d0 do ii=sta+1, fin-1 i=plist(ii) c1=(dataset%plocus(pairs(i,1),censor)==2.0d0) c2=(dataset%plocus(pairs(i,2),censor)==2.0d0) do jj=ii+1, fin j=plist(jj) c3=(dataset%plocus(pairs(j,1),censor)==2.0d0) c4=(dataset%plocus(pairs(j,2),censor)==2.0d0) v1=0 v2=0 v3=0 v4=0 if (c1 .and. dataset%plocus(pairs(i,1),trait) <= & dataset%plocus(pairs(j,1),trait)) then v1=v1+1 end if if (c3 .and. dataset%plocus(pairs(j,1),trait) <= & dataset%plocus(pairs(i,1),trait)) then v2=v2+1 end if if (c2 .and. dataset%plocus(pairs(i,2),trait) <= & dataset%plocus(pairs(j,2),trait)) then v3=v3+1 end if if (c4 .and. dataset%plocus(pairs(j,2),trait) <= & dataset%plocus(pairs(i,2),trait)) then v4=v4+1 end if idelta=(v1-v2)*(v3-v4) if (idelta == 1) nc=nc+1 if (idelta == -1) nd=nd+1 end do end do tau=0.0d0 taunorm=0.0d0 if (np > 0) then tau=dble(nc-nd)/dble(np*(np-1)/2) if (nc+nd > 0) then taunorm=dble(nc-nd)/dble(nc+nd) end if end if end subroutine twinkencon ! ! Wrapper for EISPACK real symmetric matrix routines ! subroutine eigen(typ, n, a, z) use EISPACK implicit none integer, intent(in) :: typ integer, intent(in) :: n double precision, dimension(n*(n+1)/2), intent(inout) :: a double precision, dimension(n,n), intent(out) :: z ! eigenvectors ! local variables double precision, dimension(n,n) :: as ! square matrix double precision, dimension(n) :: w ! eigenvalues double precision, dimension(n) :: fv1 ! workspace double precision, dimension(n) :: fv2 ! workspace integer :: i, idx, j, ierr, nm idx=0 do i=1, n do j=1, i idx=idx+1 as(i,j)=a(idx) end do end do nm=n ierr=0 call rs(nm, n, as, w, typ, z, fv1, fv2, ierr) idx=0 do i=1, n a(i)=w(i) end do end subroutine eigen ! ! eigenvalues for full square real matrix ! subroutine eigens(n, as, w) use EISPACK implicit none integer, intent(in) :: n double precision, dimension(n,n) :: as ! square matrix double precision, dimension(n), intent(inout) :: w ! eigenvalues ! local variables double precision, dimension(n,n) :: z ! eigenvectors double precision, dimension(n) :: fv1 ! workspace double precision, dimension(n) :: fv2 ! workspace integer :: idx, ierr, nm nm=n ierr=0 call rs(nm, n, as, w, 0, z, fv1, fv2, ierr) if (ierr /= 0) write(*,*) 'ERROR: rs() ierr=', ierr end subroutine eigens ! ! MATMPI written by Charles P. Reeve, Statistical Engineering ! Division, National Bureau of Standards, Gaithersburg, ! Code converted using TO_F90 by Alan Miller ! Computes Moore-Penrose pseudo-inverse of NxM matrix (N >=M) ! SUBROUTINE matmpi(x, work, s, e, v, n, m, nx, mx, k, iflag) use LINPACK implicit none double precision, intent(in out) :: x(nx,*) double precision, intent(in out) :: work(*) double precision, intent(in out) :: s(*) double precision, intent(out) :: e(*) double precision, intent(out) :: v(mx,*) integer, intent(in) :: n integer, intent(in) :: m integer, intent(in) :: nx integer, intent(in) :: mx integer, intent(out) :: k integer, intent(out) :: iflag integer :: i, info, j, l double precision :: cutoff, rnderr, t, xmax DATA rnderr / 1.0E-14 / iflag = 0 IF (n > nx .OR. m > mx) THEN iflag = 1 RETURN END IF IF (n < m) THEN iflag = 2 RETURN END IF IF (k < 0) THEN iflag = 4 RETURN END IF ! largest element of x (in absolute value) IF (k == 0) THEN xmax = 0.0d0 DO i = 1, n DO j = 1, m xmax = DMAX1(xmax,ABS(x(i,j))) END DO END DO ! Compute cutoff point for a singular value being zero cutoff = 10.0d0*rnderr*xmax END IF ! Perform singular value factorization using LINPACK CALL dsvdc(x, nx, n, m, s, e, x, nx, v, mx, work, 21, info) ! Check whether singular values have been computed correctly IF (info /= 0) THEN iflag = 3 RETURN END IF IF (k == 0) THEN ! Determine number of nonzero singular values k = 0 DO j = 1, m IF (ABS(s(j)) > cutoff) THEN k = k+1 ELSE GO TO 40 END IF END DO END IF ! Compute pseudo-inverse (transposed) 40 continue DO j = 1, m DO l = 1, k v(j,l) = v(j,l)/s(l) END DO END DO DO i = 1, n DO j = 1, m t = 0.0d0 DO l = 1, k t = t+v(j,l)*x(i,l) END DO e(j) = t END DO DO j = 1, m x(i,j) = e(j) END DO END DO RETURN END SUBROUTINE matmpi ! ! Wrapper for syminv and geninv or memoized ! subroutine kininv(a, n, ainv, logdet, ifail, plevel) use outstream use popgen_kinship use symmetric_matrix double precision, dimension(n*(n+1)/2), intent(in) :: a integer, intent(in) :: n double precision, dimension(n*(n+1)/2), intent(out) :: ainv double precision, intent(out) :: logdet integer, intent(out) :: ifail integer, intent(in) :: plevel ! largest non-memoized array size integer, parameter :: MEMOTHRESH = 100 integer :: mrank ! elapsed time integer :: it1, it2, ticks character (len=20) :: slin ifail=0 mrank=n call system_clock(it1) if (n > MEMOTHRESH) then call load_kininv(n, logdet, ainv, ifail) if (ifail == 0) then if (plevel > 0) then call system_clock(it2, count_rate=ticks) write(slin, '(f20.2)') float(it2-it1)/float(ticks) slin=adjustl(slin) write(outstr,'(3a)') & 'Read existing inverse matrix in ', trim(slin), ' s.' call printmat(min(10,n), ainv, '(7x,10(1x,f6.4):)') end if return end if end if if (plevel > 1) then write(outstr,'(a,i0,a,i0,a)') 'Inverting ', n, ' x ', n, ' matrix...' call printmat(min(10,n), a, '(7x,10(1x,f6.4):)') end if call syminv(a, n, ainv, logdet, ifail) if (ifail /= 0) then if (plevel > 0) then write(outstr,'(a,i0)') & 'NOTE: Problem inverting kinship matrix, n=', n call printmat(min(10,n), a, '(7x,10(1x,f6.4):)') write(outstr,'(a)') & 'Utilizing generalized inverse kinship matrix.' call system_clock(it1) end if call geninv(a, n, ainv, logdet, mrank, ifail) if (plevel > 0) then call system_clock(it2, count_rate=ticks) write(slin, '(f20.2)') float(it2-it1)/float(ticks) slin=adjustl(slin) write(outstr,'(a,i0,a,i0,a,i0,3a)') & 'Pseudo-inverse ', n,' x ', n, ' kinship matrix of rank ', & mrank, ' calculated in ', trim(slin), ' s.' call printmat(min(10,n), ainv, '(7x,10(1x,f6.4):)') end if if (ifail /= 0) then write(outstr,'(a,i0)') & 'ERROR: Moore-Penrose inverse of kinship matrix calculation ifail=', ifail end if else if (plevel > 1 .or. (n > MEMOTHRESH .and. plevel > 0)) then call system_clock(it2, count_rate=ticks) write(slin, '(f20.2)') float(it2-it1)/float(ticks) slin=adjustl(slin) write(outstr,'(a,i0,a,i0,3a)') & 'Inverted ', n,' x ', n, ' kinship matrix in ', trim(slin), ' s.' call printmat(min(10,n), ainv, '(7x,10(1x,f6.4):)') end if if (n > MEMOTHRESH) then call save_kininv(n, logdet, ainv, ifail) end if end subroutine kininv