! ! Fortran 95 version of Sib-pair 20111108 20120501 ! ! 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 // ' ' 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 ! ! epoch for Julian dates (defaults to 2440588==1970-01-01), ! module julian_epoch double precision :: epoch = 2440588.0d0 end module julian_epoch ! ! 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 ! ! 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=171*mod(ix,177)-2*(ix/177) iy=172*mod(iy,176)-35*(iy/176) iz=170*mod(iz,178)-63*(iz/178) if (ix < 0) ix=ix+30269 if (iy < 0) iy=iy+30307 if (iz < 0) iz=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*(*) 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 end module rngs ! ! interrupt ! module interrupt integer :: irupt contains ! ! keyboard interrupt handler (exits after 6 interrupts, usually ctrl-C) ! subroutine handler() irupt=irupt+1 if (irupt > 5) then write(*,'(a)') 'Multiple interrupts received! Exiting.' stop end if end subroutine handler end module interrupt ! ! Output stream, formatting ! module outstream integer :: outstr ! stream integer :: logstr ! logging stream character (len=1) :: tabsep = ' ' ! character to separate output words end module outstream ! ! Input buffer, prompt string etc ! ilevel=0 historical or macro command; =1 keyboard; =2,3 files ! ilevold=last level, if ilevel currently 0 ! 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 integer, parameter :: NSTRM=4 integer, dimension(NSTRM) :: incstr = (/STDIN, 4, 10, 12/) character(len=256), dimension(2:NSTRM) :: infil=' ' end module iobuff ! ! iostat codes needed for wrinline etc ! module iocodes #if OPEN64 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=unzipped copy 4=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_COPY = 3, PORT_PIPE = 4 type, public :: ioport character (len=256) :: filnam character (len=1) :: stat = ' ' integer :: filtyp integer :: fstream #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 ! buffer for gzread integer, parameter :: ZBUFLEN = 65536 character (len=ZBUFLEN), target :: zbuffer ! current character and end of zbuffer integer :: zbufpos=0, zbufend=ZBUFLEN ! 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 ! 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 contains ! ! 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 #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) ios=ir zbufpos=0 end subroutine fgz_rewind ! ! Wrapper for gzread ! read one line of text from buffer ! subroutine fgz_read(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 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, eol, more, morez type (c_ptr) :: buf = c_null_ptr 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 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 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 ! 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 zbufpos=newzpos if (zbufpos > zbufend) then zbufpos=0 end if end do if (.not.advancing .and. eol) ios=eolcode end subroutine fgz_read ! ! 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, linlen, 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 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 #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 ! 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 ! 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 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 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) end subroutine pipe_read ! ! 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 gzipped files -- ! module fileio use iocodes use ioports #if ZLIB use f95zlib #endif #if POPEN use f95pipes #endif use outstream public :: close_port, newlun, open_port, readline, rewind_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 ! function isgzipped(filnam) logical :: isgzipped character (len=*), intent(in) :: filnam integer :: s character (len=1) :: ch1, ch2 isgzipped=.false. 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), '".' return end if read(s, iostat=ios) ch1, ch2 if (ios /= 0) then write(outstr, '(3a)') 'ERROR: Could not read header of "', trim(filnam), '".' else isgzipped=(ichar(ch1) == 31 .and. ichar(ch2) == 139) end if close(s, status='keep') return end function isgzipped ! ! 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, strm logical :: gzipped, apipe character(len=3) :: fileage #if !(ZLIB) character(len=len(filnam)) :: wrkfil #endif ios=0 apipe=.false. gzipped=.false. 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 (.not.apipe) gzipped=isgzipped(filnam) if (gzipped) then #if ZLIB call fgz_open(filnam, mode // 'b', port, ios) #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, iostat=ios) port%filtyp=PORT_COPY port%fstream=strm #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, iostat=ios) port%filnam=filnam port%filtyp=PORT_STANDARD port%fstream=strm 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) #endif #if POPEN else if (port%filtyp == PORT_PIPE) then call pipe_rewind(port, ios) #endif end if end subroutine rewind_port ! ! Read one record from file ! subroutine readline(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 read(port%fstream,'(a)', advance=advancing, iostat=ios) lin #if ZLIB else if (port%filtyp == PORT_GZIPPED) then call fgz_read(port, lin, advance=advancing, ios=ios) #endif #if POPEN else if (port%filtyp == PORT_PIPE) then call pipe_read(port, lin, advance=advancing, ios=ios) #endif end if end subroutine readline ! ! 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) #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 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 ! ! Scanner ! module scanner 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 ! ! Next token in buffer ! ! Need to know which word if reading pedigree or case-control data ! as slashes separate alleles in data but are allowed in ID strings ! ! typ action ! 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 ! subroutine nextword(pos, s, eos, reserved, nword, word, stat, typ) integer, intent(inout) :: pos character (len=*), intent(in) :: s integer, intent(in) :: eos logical :: reserved integer, intent(inout) :: nword character (len=*), intent(out) :: word integer, intent(out) :: stat integer, intent(in) :: typ integer :: i, iarg, sarg, sol character (len=1) :: ch stat=-1 if (pos > eos) return stat=0 ! ! start of main loop do while (pos <= eos) ch=s(pos:pos) ! a reserved operator is one word if (typ==2 .and. reserved(ch)) 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 == 4 .and. nword > 1) .or. & (typ == 3 .and. nword > 4)) .and. ch == '/') then continue ! quoted text, usually genotypes "a/b" else if (ch .eq.'"') then iarg=-1 ! skip leading blanks within quotes do pos=pos+1 if (pos==eos .or. s(pos:pos) /= ' ') exit end do sarg=pos do while (pos <= eos .and. s(pos:pos) /= '"') 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 else if (ch /= ' ' .and. ichar(ch) /= 9) then iarg=-1 sarg=pos findeow: do if (pos > eos) exit ch=s(pos:pos) if (ch ==' ' .or. ichar(ch) == 9 .or. ch == '"') exit if ((typ == 3 .or. typ == 4) .and. ch == '/') exit if (typ == 2) then ! kludge for exponential notation if (reserved(ch)) 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 end subroutine nextword ! ! extracts narg arguments from input string s ! subroutine args(s, narg, arg, typ) character (len=*), intent(in) :: s integer, intent(in) :: typ integer, intent(inout) :: narg character (len=*), dimension(:), intent(out) :: arg integer :: eol, i, iarg, maxwords, n, sarg, sol, stat character (len=1) :: ch character (len=40) :: 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, typ) if (stat == -1) exit arg(n)=word if (n == maxwords) exit end do narg=n end subroutine args ! ! extracts the nth whitespace-separated argument from input string s ! subroutine getword(s, which, word) character (len=*), intent(in) :: s integer, intent(in) :: which character (len=*), intent(out) :: word integer :: eol, i, iarg, n, sarg, sol, stat ! functions ! logical :: opchar word=' ' 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, 1) if (stat == -1) then word=' ' exit else if (n == which) then exit end if end do end subroutine getword ! ! Find end of nth whitespace-separated argument in input string s ! function wordpos(s, which) integer wordpos character (len=*), intent(in) :: s integer, intent(in) :: which integer :: eol, i, n, sol, stat character(len=3) :: 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, 1) if (stat == -1) then exit else if (n == which) then wordpos=i exit end if end do end function wordpos ! ! return count of whitespace-separated argument from input string s ! function countargs(s, typ) integer :: countargs character (len=*), intent(in) :: s integer, intent(in) :: typ character (len=3) :: word integer :: eol, i, iarg, n, sarg, 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, typ) end do countargs=n end function countargs ! ! extracts the matching value for a list of value=label pairs in a string ! subroutine getlabel(val, s, label) double precision, intent(in) :: val character (len=*), intent(in) :: s character (len=*), intent(out) :: label integer :: cpos, eol, i, iarg, n, sarg, sol, stat character (len=len(label)), dimension(0:2) :: circular ! functions double precision :: fval label=' ' circular(0:2)=' ' sol=sow(s) eol=len_trim(s) if (len(s) == 0 .or. s == '') return 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, 2) if (stat == -1) then return else if (circular(cpos) == '=') then if (fval(circular(mod(cpos+2,3))) == val) then label=circular(mod(cpos+1,3)) return end if end if end do end subroutine getlabel ! ! is a reserved character for primitives? "()*+-/<=>^:" ! function opchar(ch) logical :: opchar character(len=1) :: ch integer :: ich ! functions integer :: ichar ich=ichar(ch) opchar=((ich >= 40 .and. ich <= 43) .or. ich == 45 .or. & ich == 47 .or. ich==58 .or. & (ich >= 60 .and. ich <= 62) .or. ich == 94) end function opchar ! ! is a reserved character for name = value pair list? "=:,;" ! function opsimple(ch) logical :: opsimple character(len=1) :: ch integer :: ich ! functions integer :: ichar ich=ichar(ch) opsimple=(ich == 44 .or. ich == 58 .or. ich == 59 .or. ich == 61) end function opsimple end module scanner ! ! Hash table for indexing IDs etc ! module idhash_class integer, parameter :: HK_PED_ID=1, HK_ID=2, HK_LOCNAM=3 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 = 26 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 /) 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 /) integer :: nsiz, tload, w 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 < nrec) then deallocate(hashtab%address) allocate(hashtab%address(nsiz)) end if else allocate(hashtab%address(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 ! ! populate hash table ! subroutine fill_hash(hashtab, string_array) type (hash_table), intent(inout) :: hashtab character (len=*), dimension(:), intent(in) :: string_array integer :: i, iaddress, 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 ! ! 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 ! ! 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 end module idhash_class ! ! Locus name hash table ! module lochash_class use idhash_class contains subroutine make_lochash(nloci, loc, lochash) integer, intent(in) :: nloci character(len=20), dimension(:), intent(in) :: loc type (hash_table), intent(inout) :: lochash integer :: i, iaddress, idx, iprobe, j call setup_hash(HK_LOCNAM, nloci, lochash, 90) 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) 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. 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=20), dimension(:), intent(in) :: loc type (hash_table), intent(inout) :: lochash integer :: iaddress, 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) iaddress=lochash%address(j+1) 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, loc, lochash) integer, intent(in) :: nloci character(len=20), dimension(:), intent(in) :: loc type (hash_table), intent(inout) :: lochash write(*,'(a)') 'Locus name hash:' write(*,'(a,l1)') ' Up to date? ', lochash%current write(*,'(a,i0)') ' Table size ', lochash%nrec write(*,'(a,i0)') ' No. of loci ', nloci write(*,*) end subroutine show_lochash end module lochash_class ! ! Utilities to print arrays ! module showcomponent contains subroutine show_one_iarray(nam, sep, nval, isall, array) character (len=*) :: nam, sep integer :: nval 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(*,'(5(a,i0):)') (' ', array(i), i=1, nval) else write(*,*) end if end subroutine show_one_iarray ! subroutine show_one_carray(nam, sep, nval, isall, array) character (len=*) :: nam, sep integer :: nval 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(*,'(5(1x,3a):)') ('"', trim(array(i)), '"', i=1, nval) else write(*,*) end if end subroutine show_one_carray ! subroutine show_one_farray(nam, sep, nval, isall, array) character (len=*) :: nam, sep integer :: nval logical :: isall double precision, dimension(:) :: array write(*,'(a8,2x,l1)', advance='no') nam, isall if (isall) then write(*,'(i12,1x,a)', advance='no') size(array), sep write(*,*) array(1:nval) 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 ! 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 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(12), parameter :: typloc = & (/ 'm','x','m','h','i','y','h','t', 'q','a','c','d' /) character (len=12), dimension(12), parameter :: typlloc = & (/'marker ', 'xmarker ', & 'diploid ', 'haploid ', & 'mitochond ', 'ymarker ', & 'haploid ', 'trait ', & 'quantitative', 'affection ', & 'categorical ', '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 == '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)) 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 ! quantitative trait function isqtrait(loctyp) logical :: isqtrait integer, intent(in) :: loctyp isqtrait=(loctyp == LOC_QUA) end function isqtrait ! 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_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 end module locus_types ! ! Storage for the locus data ! module locus_data use outstream use lochash_class use showcomponent ! ! 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=20), dimension(:), allocatable :: loc ! Hash table for locus names type (hash_table), save :: lochash character(len=40), dimension(:), allocatable :: locnotes integer, dimension(:), allocatable :: loctyp, locpos, outpos ! position of locus on sex-averaged linkage map character (len=2), dimension(:), allocatable :: group double precision, dimension(:), allocatable :: map integer, dimension(:), allocatable :: locord integer, dimension(:), allocatable :: wloc ! collected statistics, such as P-values double precision, dimension(:), allocatable :: locstat ! ! twinning=the zygosity indicator locus number ! 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=20) :: twintrait=' ' ! ! sexmarker is sex-informative marker character (len=20) :: sexmarker=' ' ! ! whichstat is statistic held in locstat ! character (len=50) :: whichstat=' ' 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=0 locstat=MISS locord=0 wloc=0 end subroutine setup_loci ! ! 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=20), dimension(:), allocatable :: loc2 integer, dimension(:), allocatable :: loctyp2 integer, dimension(:), allocatable :: locpos2, outpos2 character (len=40), dimension(:), allocatable :: locnotes2 character (len=2), 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) use fileio use scanner type (ioport) :: port integer :: ioerr, narg, newsiz, oldsiz 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, 1) if (words(1)(1:1) /= 'E') then newsiz=newsiz+1 end if end do call rewind_port(port, ioerr) oldsiz=size(loc) if (newsiz>oldsiz) then newsiz=5*(1+newsiz/5) call expand_loci(newsiz-oldsiz, 0) end if end subroutine setupmer ! ! Allocate arrays for locus descriptions from PLINK .map file ! subroutine setup_plink(port, nmark, newsiz) use fileio type (ioport) :: port integer, intent(out) :: nmark integer, intent(out) :: newsiz 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) then newsiz=5*(1+newsiz/5) call expand_loci(newsiz-oldsiz, 0) end if end subroutine setup_plink ! ! initialize locstat (stores test statistic for each locus) ! subroutine setup_stat(comment) character (len=*) :: comment integer, parameter :: MISS=-9999 whichstat=comment locstat=MISS end subroutine setup_stat ! ! Diagnostics for locus structure ! subroutine show_locus_allocation() integer :: ter ter=min(5,size(loc)) write(*,'(a/a)') 'Array Alloc? N : Values', & '-------- --------------------' call show_one_carray('loc', ':', ter, allocated(loc), loc) call show_one_iarray('loctyp', ':', ter, allocated(loctyp), loctyp) call show_one_iarray('locpos', ':', ter, allocated(locpos), locpos) call show_one_iarray('outpos', ':', ter, allocated(outpos), outpos) call show_one_carray('locnotes', ':', ter, allocated(locnotes), locnotes) call show_one_carray('group', ':', ter, allocated(group), group) call show_one_farray('map', ':', ter, allocated(map), map) call show_one_farray('locstat', ':', ter, allocated(locstat), locstat) call show_one_iarray('locord', ':', ter, allocated(locord), locord) call show_one_iarray('wloc', ':', ter, 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 end module locus_data ! ! 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 = 512000000 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_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 bufwidth=DBUFWID 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) 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 ! else stored in file a%typ = 2 a%nrows = nr a%ncols = nc 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, newcols, setbufwidth) use rngs type (matrix_i1) :: a, b integer, intent(out) :: iflag integer, optional :: newrows integer, optional :: newcols integer, optional :: setbufwidth integer (kind=1), parameter :: zero = 0 integer :: bufwidth, ios, nr, nc integer (kind=8) :: bigi character (len=5) :: prefix 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 b%ncells = int(nc, kind=8) * int(nr, kind=8) b%typ = 2 if (b%ncells < mthresh) 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 (ios == 0) then b%dta=zero if (a%ncells > 0) then if (a%typ == 1) then b%dta=a%dta else rewind(a%stream) read(a%stream) b%dta(1:a%nrows,1:a%ncols) end if end if return end if end if ! stored as file 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 :: i iflag=0 write(stream) 'Matrix' write(stream) a%nrows, a%ncols, a%isize, a%bufwidth if (a%typ == 1) then write(stream) a%dta 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)') 'ERROR: error writing matrix data.' 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%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 ! ! Read a matrix ! subroutine matrix_read(stream, a, iflag) integer, intent(in) :: stream type (matrix_i1), intent(out) :: 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(out) :: 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 a%bufwidth=DBUFWID 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 ! try and store in memory if (a%ncells < mthresh) then a%typ = 1 if (allocated(a%dta)) deallocate(a%dta) allocate(a%dta(a%nrows, a%ncols), stat=ios) if (ios == 0) then if (a%ncells <= CHUNKSIZE) then read(stream, err=999, end=999) a%dta else ichunk=int(a%ncells/CHUNKSIZE, kind=4) iblock=a%ncells/ichunk sta=1 fin=iblock do i=1, ichunk read(stream, err=999, end=999) a%dta(1:a%nrows,sta:fin) sta=sta+iblock fin=fin+iblock end do fin=a%ncols read(stream, err=999) a%dta(1:a%nrows,sta:fin) end if return end if end if ! fall through to file storage a%typ = 2 a%thiscol = 0 inquire(a%stream, opened=sopen) if (sopen) close(a%stream, status='delete') if (allocated(a%dta)) deallocate(a%dta) allocate(a%dta(a%nrows, a%bufwidth), stat=ios) write(a%filnam,'(a,i0)') 'matrix_', 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 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%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 :: i, j, 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 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 iflag=-3 return end subroutine matrix_get_el ! ! Print matrix ! subroutine matrix_print(a) type (matrix_i1) :: a integer :: i, istride, 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(*,'(2a)') 'Filename=', 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 ! ! One big pedigree data structure ! Updating size requires copying entire structure ! (hopefully maintaining contiguous storage) ! ! 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 module idstring_widths integer, parameter :: ped_width = 20 integer, parameter :: id_width = 14 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 if (allocated(dataset%plocus)) then call cleanup_peds(dataset) end if astat=0 sstat=0 isnps=max(numcol(SCLASS), numloc(SCLASS)) igeno=max(numcol(GCLASS), numloc(GCLASS)) ipheno=max(numcol(PCLASS), numloc(PCLASS)) if (plevel > 1) then write(outstr,'(3(/a,i0))') & 'Number of declared SNPs = ', isnps, & 'Number of declared markers = ', igeno, & '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 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) 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) 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,').' 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 end if 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 ! ! 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 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) if (abs(g1) > 64) g1=sign(10000,g1)+g1 if (abs(g2) > 64) g2=sign(10000,g2)+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) type (ped_data) :: dataset integer :: i, j, ter integer (kind=1) :: i1 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 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(5, dataset%nped) write(*,'(/a/a)') & 'Array Alloc? N : Values', & '-------- --------------------' call show_one_carray('pedigree', ':', ter, allocated(dataset%pedigree), dataset%pedigree) call show_one_iarray('num', ': (0)', ter, allocated(dataset%num), dataset%num) call show_one_iarray('nfound', ':', ter, allocated(dataset%nfound), dataset%nfound) call show_one_iarray('actset', ':', ter, allocated(dataset%actset), dataset%actset) ter=min(5,dataset%nobs) call show_one_iarray('actset', ':', ter, allocated(dataset%iped), dataset%iped) call show_one_iarray('imztwin', ':', ter, allocated(dataset%imztwin), dataset%imztwin) call show_one_carray('id', ':', ter, allocated(dataset%id), dataset%id) call show_one_iarray('fa', ':', ter, allocated(dataset%fa), dataset%fa) call show_one_iarray('mo', ':', ter, allocated(dataset%mo), dataset%mo) call show_one_iarray('sex', ':', 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=1,min(3,dataset%numloc(SCLASS)/2) call matrix_get_el(idx, j, dataset%slocus, i1, iflag) write(*,'(b8.8,a)', advance='no') i1, ' ' end do if (i < ter) write(*,'(a)',advance='no') '; ' end do write(*,*) else write(*,*) 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(*,'(3(1x,i0,a,i0):)', advance='no') & (dataset%glocus(i,j),'/',dataset%glocus(i,j+1), & j=1,min(3,dataset%numloc(GCLASS))) if (i < ter) write(*,'(a)',advance='no') '; ' end do write(*,*) else write(*,*) 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(*,'(3g9.4:)', advance='no') & (dataset%plocus(i,j),j=1,min(3,dataset%numloc(PCLASS))) if (i < ter) write(*,'(a)',advance='no') '; ' end do write(*,*) else write(*,*) end if write(*,'(a8,2x,l1)', advance='no') 'untyped', allocated(dataset%untyped) if (allocated(dataset%untyped)) then write(*,'(i12,a,5l2)') & 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, copyfreq, expand_alleles, cleanup_alleles, genot, & calc_gtp_freqs, setup_freq 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 :: 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 end type allele_data 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%numgtp=allele_buffer%numgtp 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 end if allele_buffer%numal=0 allele_buffer%numgtp=0 allele_buffer%typed=0 allele_buffer%untyped=0 allele_buffer%totall=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 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 ! ! 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 ! ! Statistical functions library ! module statfuns ! public :: betacf, ibeta, gammad, alngam, & ! fp, tp, chip, chi2nc, zp, & ! mvbvu, & ! ppnd, chisqd, 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 ! ! intialize 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*dfloat(n1), n1) end if else if (n1 > 4.0d5) then fp=chip(dfloat(n2)/x, n2) else if (dfloat(n1)*x > dfloat(n2)) then fp=1.0d0-ibeta(dfloat(n2)/(dfloat(n2)+dfloat(n1)*x), 0.5d0*dfloat(n2), 0.5d0*dfloat(n1)) else fp=ibeta(dfloat(n1)*x/(dfloat(n2)+dfloat(n1)*x), 0.5d0*dfloat(n1), 0.5d0*dfloat(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) 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 if (df <= 0 .or. chisq <= 0.0d0) then chip=1.0d0 return end if if (df == 1) then z=sqrt(chisq) p=2*zp(z) else p=1.0d0-gammad(0.5d0*chisq, 0.5d0*dfloat(df), ifault) end if if (p == 0.0d0 .and. df > 1) then v=twoninths/dfloat(df) z=((chisq/dfloat(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 ! double precision function alngam(xvalue, ifault) 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 ! ! 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 ! double precision function zp(z) 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 ! ! 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 ! ! 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. ! double precision function ppnd(p) double precision, intent(in) :: p double precision :: q, r double precision, parameter :: split1 = 0.425 double precision, parameter :: split2 = 5 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 )/2 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 - p ) if ( r > 0 ) 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 end if if ( q < 0 ) 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) ! DOUBLE PRECISION FUNCTION probst(t, idf, ifault) 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 ! ! 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(dfloat(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(dfloat(n)+1.0d0, ierr) end function lfact ! ! Log gaussian density ! double precision function dnorm(x, mu, sd) 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 end module statfuns ! ! MVN integration control variables ! 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 :: 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 vaules 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 out) :: maxpts double precision, intent(in out) :: abseps double precision, intent(in out) :: 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 ! double precision function mvndfn( n, w ) use statfuns 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 ! ! 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 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 ! ! 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 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 ! ! Environmental (automatic) variables for evaluator integer, parameter :: ENVNUM = 13 character (len=6), dimension(ENVNUM) :: env = & (/'female','male ','isfou ','isnon ', & 'num ','nfoun ', & 'anymis', 'anytyp','alltyp','numtyp','famnum','index ','commar' /) 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 end module comp_ops ! ! String utilities ! module string_utilities public :: chfind, escape, strfind 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 ! ! Compare string to a search string, allowing wildcards '*.', 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, wpos logical :: looking, wild 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=.false. looking=.true. strfind=.true. do while (looking) if (regexp(pos:pos) == '*') then wild=.true. wpos=pos pos=pos+1 looking=(pos <= lenr) else ! this character matches? if (regexp(pos:pos) == '.' .and. .not.wild) then strfind=.true. 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) then looking=.true. if (strfind) then wild=.false. else pos=wpos end if end if pos=pos+1 i=i+1 ! target exhausted? If regexp ends in wild card, then found if (i > lent) then looking=.false. if (regexp(pos:pos) == '*' .and. pos == lenr) wild=.true. if (pos <= lenr .and. .not.wild) 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) 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 ! ! Escape a target character, usually " ! subroutine escape(str, trget) character (len=*) :: str character (len=1) :: trget integer :: i, n, siz siz=len(str) n=len_trim(str) i=n do while (i > 0) if (str(i:i) == trget) then if (n < siz) then #if defined (WIN32) || defined (IFORT) || defined (NOESCAPE) str=str(1:(i-1)) // '\' // str(i:n) #else str=str(1:(i-1)) // '\\' // str(i:n) #endif n=n+1 else write(*,'(3a/7x,a,i5,a)') & 'ERROR: Ran out of room while escaping <',trget,'>.', & 'Buffer length is ', siz, ' characters.' return end if end if i=i-1 end do end subroutine escape end module string_utilities ! ! Miniscm ! module scheme_lang use extras use interrupt use outstream use iobuff use string_utilities #if JAPI use japi #endif private public :: cleanup_mem, get_string, get_var, isafun, list_var, init_scheme, & read_scheme_image, repl_scheme, save_scheme_image ! ! binary images of scheme workspace need to match correct version ! bump version number if eg add new procedures ! character (len=5), parameter :: scheme_version = '00011' 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_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_GETENV=159, & OP_INQUIRE=160, OP_ISATTY=161, OP_APROPOS=162, & OP_HELP=163, OP_VERSION=164, OP_GENSYM=165 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 integer, parameter :: OP_RUNCMD=501, OP_LSLOCI=502, OP_NLOCI=503, & OP_LOCNAM=504, OP_LOCTYP=505, OP_LOCORD=506, & OP_LOCSTAT=507, OP_SETSTAT=508, OP_LOCNOT=509, & OP_SETNOTE=510, OP_LOCRANK=511, OP_MAPPOS=512, & OP_CHROM=513, OP_STATRES=514, OP_INITSTAT=515 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 #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_JSEPERATOR=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 integer :: cell_segment = 500 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 ! 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 ! fcell = number of free cells ! integer :: memsiz type (mcell), dimension(:), allocatable :: mem integer :: nextfree integer :: fcells ! ! i/o streams ! integer, parameter :: MAXPORT=5 integer, dimension(5) :: portaddress = (/21, 22, 23, 24, 25/) integer :: nports = 0 integer :: LOADSTR=26 character (len=512) :: loadfil contains ! Memory management 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)) do j=1, siz mem(j)%iflag=T_FREE mem(j)%value=0 mem(j)%slength=0 mem(j)%keynum=-1 mem(j)%car=nil mem(j)%cdr=nil end do 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)) do j=1, memsiz tmpmem(j)%iflag=mem(j)%iflag tmpmem(j)%value=mem(j)%value slen=mem(j)%slength tmpmem(j)%slength=slen if (slen > 0) then allocate(tmpmem(j)%svalue(slen)) tmpmem(j)%svalue=mem(j)%svalue end if tmpmem(j)%keynum=mem(j)%keynum tmpmem(j)%car=mem(j)%car tmpmem(j)%cdr=mem(j)%cdr end do call cleanup_mem() allocate(mem(siz)) do j=1, memsiz mem(j)%iflag=tmpmem(j)%iflag mem(j)%value=tmpmem(j)%value slen=tmpmem(j)%slength mem(j)%slength=slen if (slen > 0) then allocate(mem(j)%svalue(slen)) mem(j)%svalue=tmpmem(j)%svalue deallocate(tmpmem(j)%svalue) end if mem(j)%keynum=tmpmem(j)%keynum mem(j)%car=tmpmem(j)%car mem(j)%cdr=tmpmem(j)%cdr end do do j=memsiz+1, siz mem(j)%iflag=T_FREE mem(j)%value=0 mem(j)%slength=0 mem(j)%car=nil mem(j)%cdr=nil mem(j)%keynum=-1 end do 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 mem(j)%slength=0 deallocate(mem(j)%svalue) end if mem(j)%iflag=T_FREE mem(j)%value=0 mem(j)%keynum=-1 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 ! ! 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 ! ! 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) integer :: a, b integer, intent(in) :: plevel integer :: i 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(a) call gc_mark(b) call clrmark(nil) fcells=0 nextfree=nil do i=1, memsiz if (ismark(i)) then call clrmark(i) else call cleanup_bank(i, i) call set_cdr(i, nextfree) nextfree = i fcells=fcells+1 end if end do if (plevel > 0) then write(outstr,'(a,i0,a,i0,a)') 'GC recovered ', fcells, ' of ', memsiz, ' cells' end if end subroutine gc ! ! Get next free cell ! function getcell(a, b) integer :: getcell integer, intent(in) :: a, b integer :: newsiz, x if (nextfree == nil) then ! write(*,*) 'Run out of memory! calling GC, fcells=', fcells call gc(a, b, 0) ! write(*,*) 'Called GC, nextfree=', nextfree, ' fcells=', fcells if (nextfree == nil) then ! write(*,*) 'memsiz=', memsiz newsiz=memsiz+cell_segment call setup_mem(newsiz) call gc(a, b, 0) ! write(*,*) 'Called GC again, memsiz=', memsiz, ' nextfree=', nextfree end if end if x=nextfree nextfree=cdr(x) fcells=fcells-1 call set_car(x, nil) call set_cdr(x, nil) ! write(*,*) 'set ', x, ' nextfree=', nextfree, ' fcells=', fcells getcell=x end function getcell ! ! Cell type operations ! ! 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_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_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 get_value(p) double precision :: get_value integer, intent(in) :: p if (mem(p)%keynum == 1) then get_value=real(transfer(mem(p)%value, 1), kind=8) else get_value=transfer(mem(p)%value, get_value) end if end function get_value ! function rvalue(p) double precision :: rvalue integer, intent(in) :: p if (mem(p)%keynum == 2) then rvalue=transfer(mem(p)%value, rvalue) else rvalue=dble(mem(p)%value) end if end function rvalue ! ! 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 ! 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 ! 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 ! ! allowing access to Scheme environment from Sib-pair ! accessible variables are atomic ! 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, newlen, reslen, slen, tmp, varend, varsta, x, y character (len=40) :: cbuff slen=len(string) eos=len_trim(string) istat=0 varsta=pos+1 varend=fin if (string(varsta:varsta) == '(') varsta=varsta+1 if (string(varend:varend) == ')') varend=varend-1 if (varsta <= varend) then tmp=oblist do while (tmp /= nil) if (ceqstr(string(varsta:varend), caar(tmp))) exit tmp=cdr(tmp) end do if (tmp == nil) then istat=-1 goto 999 end if tmp=car(tmp) x=envir do while (x /= nil) y=car(x) do while (y /= nil) if (caar(y) == tmp) exit y=cdr(y) end do if (y /= nil) exit x=cdr(x) end do if (x /= nil) then reslen=0 cbuff=' ' if (isstring(cdar(y)) .or. isport(cdar(y))) then istat=1 reslen=get_strlen(cdar(y)) else if (isnumber(cdar(y))) then istat=2 if (isinteger(cdar(y))) then write(cbuff, '(i20)') get_ivalue(cdar(y)) reslen=len_trim(adjustl(cbuff)) else write(cbuff, '(g20.12)') get_value(cdar(y)) reslen=len_trim(adjustl(cbuff)) end if else if (cdar(y) == t) then cbuff='1' reslen=1 else if (cdar(y) == f) then cbuff='0' reslen=1 end if newlen=reslen+len_trim(string)-fin+pos-1 if (slen > newlen) then if (istat==1) then string=string(1:(pos-1)) // & get_string(cdar(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 ! ! List Sib-pair accessible (atomic or pair) variables ! subroutine list_var(typ, ple) integer, intent(in) :: typ, ple integer :: i, obj, s, x, y character (len=1) :: ch character (len=20) :: string obj=oblist do while (obj /= nil) s=car(obj) x=envir do while (x /= nil) y=car(x) do while (y /= nil) if (caar(y) == s) then if (typ==1) then if (isstring(cdar(y))) then write(outstr, '(3a)') get_string(car(s)), '=', get_string(cdar(y)) else if (isnumber(cdar(y))) then write(string, '(i20)') get_ivalue(cdar(y)) write(outstr, '(3a)') get_string(car(s)), '=', adjustl(trim(string)) end if else 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 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 macro function exists ! function isafun(nam) integer :: isafun character (len=*), intent(in) :: nam integer :: tmp, x, y isafun=0 tmp=oblist do while (tmp /= nil) if (ceqstr(trim(nam), caar(tmp))) exit tmp=cdr(tmp) end do if (tmp == nil) then return end if tmp=car(tmp) x=envir do while (x /= nil) y=car(x) do while (y /= nil) if (caar(y) == tmp) exit y=cdr(y) end do if (y /= nil) exit x=cdr(x) end do if (x /= nil) then if (ceqstr('*sp-fun*', car(cdar(y)))) then isafun=cdr(cdar(y)) end if end if end function isafun ! 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 ! 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. mem(p)%keynum == 1) end function isinteger function isfloat(p) logical :: isfloat integer :: p isfloat=(isnumber(p) .and. mem(p)%keynum == 2) end function isfloat ! ! 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(reg1, reg2) integer cons integer :: reg1, reg2 cons=getcell(reg1, reg2) call set_type(cons, T_PAIR) mem(cons)%car = reg1 mem(cons)%cdr = reg2 end function cons ! ! 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 number ! function mk_number(num) integer :: mk_number integer (kind=8), intent(in) :: num integer :: tmp tmp=getcell(nil, nil) call set_type(tmp, ior(T_NUMBER, T_ATOM)) call set_ivalue(tmp, num) mk_number=tmp end function mk_number ! ! Declare a real ! function mk_real(num) integer :: mk_real double precision, intent(in) :: num integer :: tmp tmp=getcell(nil, nil) 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) 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 ! ! 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)) else read(str,'(i40)') x mk_atom=mk_number(x) end if else mk_atom=mk_symbol(str) end if end function mk_atom ! ! Make a constant ! function mk_const(nam) integer :: mk_const character (len=*) :: nam integer :: nchar integer (kind=8) :: x if (nam == 't') then mk_const=t else if (nam == 'f') then mk_const=f else if (nam(1:1) == 'b') then read(nam, '(1x,b20)') x mk_const=mk_number(x) else if (nam(1:1) == 'd') then read(nam, '(1x,i20)') x mk_const=mk_number(x) else if (nam(1:1) == 'o') then read(nam, '(1x,o20)') x mk_const=mk_number(x) else if (nam(1:1) == 'x') then read(nam, '(1x,z20)') x mk_const=mk_number(x) else if (nam(1:1) == '\') then nchar=len_trim(nam) 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(12)) 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 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) 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) 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) 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) ! write(*,*) 'reversing ', i, p, ' next from tmp=', tmp end do ! write(*,*) 'finished reversing ', i, p, ' next from tmp=', tmp 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 ! ! 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') infp=STDIN write(outstr, '(a)', advance='no') prompt_string read(infp, '(a)', iostat=ios) scheme_lin 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 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 backslash=(ch == '\') 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) integer, intent(in) :: l, ndigits, space character (len=40) :: str character (len=8) :: fstring 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 (isinteger(l)) then write(str, '(i40)') get_ivalue(l) else if (isfloat(l)) then if (ndigits < 0) then write(fstring,'(a)') '(g40.12)' else write(fstring, '(i8)') ndigits fstring='(f40.' // trim(adjustl(fstring)) // ')' end if write(str, fstring) get_value(l) end if call padprint(trim(adjustl(str)), space) else if (isstring(l)) then if (print_flag==1) then write(outfp,'(3a)',advance='no') '"', get_string(l), '"' else call padprint(get_string(l), space) end if else if (issymbol(l)) then write(outfp,'(a)',advance='no') get_string(car(l)) ! // ' ' else if (isproc(l)) then write(outfp,'(a,i0,a)', advance='no') '#' else if (ismacro(l)) then write(outfp,'(a)',advance='no') '#' else if (isclosure(l)) then write(outfp,'(a)',advance='no') '#' 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) character (len=*), intent(in) :: str integer, intent(in) :: space if (space < 0) then ilen=len(str) if (ilen < -space) then write(outfp, '(a)', advance='no') repeat(' ',-space-ilen) end if end if write(outfp, '(a)', advance='no') str if (space > 0) then ilen=len(str) if (ilen < space) then write(outfp, '(a)', advance='no') repeat(' ',space-ilen) end if end if end subroutine padprint ! 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 opexe10 ! load -- let* ! subroutine opexe0(op, inline) integer :: op integer :: inline integer :: x, y 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 open', car(scm_args)) return else infp=LOADSTR open(infp, file=trim(loadfil), status='old') write(outstr, '(3a)') 'Loading "', trim(loadfil), '".' end if end if oper=OP_T0LVL ! top level else if (op == OP_T0LVL) then if (inline /= 3) 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)) 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 = cons(code, nil) 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))) 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)) ! macro else if (op == OP_0MACRO) then x = car(code) if (ispair(x)) then x=caar(code) code=cons(lambda, cons(cdar(code), cdr(code))) else code = cadr(code) end if 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) scm_args=cadr(scm_args) 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 logical :: int_op integer (kind=8) :: d, i, v double precision :: rv int_op=.true. ! + 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 (isfloat(car(x))) then if (int_op) then int_op=.false. rv=v end if rv=rv+get_value(car(x)) else if (int_op) then v=v+get_ivalue(car(x)) else rv=rv+get_value(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 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 (isfloat(car(scm_args))) then int_op=.false. rv = get_value(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 (isfloat(car(x))) then if (int_op) then int_op=.false. rv=v end if rv=rv-get_value(car(x)) else if (int_op) then v=v-get_ivalue(car(x)) else rv=rv-dfloat(get_ivalue(car(x))) end if x=cdr(x) end do if (i==1) then if (int_op) then v=-v else rv=-rv end if end if 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.0 do while (x /= nil) if (.not.isnumber(car(x))) then call error1('Argument to * is not a number: ', car(x)) return else if (isfloat(car(x))) then if (int_op) then int_op=.false. rv=v end if rv=rv*get_value(car(x)) else if (int_op) then v=v*get_ivalue(car(x)) else rv=rv*get_ivalue(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 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 (get_value(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 (isfloat(car(scm_args))) then v = int(get_value(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 (isfloat(car(x))) then d=int(get_value(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 x=cdr(x) end do call s_return(mk_number(v)) ! 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 (isfloat(car(scm_args))) then int_op=.false. rv = get_value(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 (isfloat(car(x))) then if (int_op) then int_op=.false. rv=v end if if (get_value(car(x)) /= 0) then rv=mod(rv, get_value(car(x))) else call error0('Divided by zero!') return end if 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)) 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 i = get_ivalue(cadr(scm_args)) if (i /= 0) then v = mod(get_ivalue(car(scm_args)), 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 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 :: x double precision :: v logical :: comp ! 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))) ! 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(get_value(car(scm_args)) == 0.0d0) ! positive? else if (op == OP_POSP) then call s_retbool(get_value(car(scm_args)) > 0.0d0) ! negative? else if (op == OP_NEGP) then call s_retbool(get_value(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 v = get_value(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 (op == OP_NUMEQ) then comp=(v==get_value(car(x))) else if (op == OP_LESS) then comp=(vget_value(car(x))) else if (op == OP_LEQ) then comp=(v<=get_value(car(x))) else if (op == OP_GEQ) then comp=(v>=get_value(car(x))) 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 call s_retbool(get_listlen(car(scm_args)) >= 0) ! 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) then call gc(nil, nil, 1) call s_return(t) ! memory-allocate else if (op == OP_GCVERB) then if (.not.isnumber(car(scm_args))) then call error0('memory-allocate -- argument must be a number!') return end if #if ALL_DOUBLEINT call setup_mem(get_ivalue(car(scm_args))) #else call setup_mem(int(get_ivalue(car(scm_args)), kind=4)) #endif call s_return(t) ! new segment size else if (op == OP_NEWSEGMENT) then if (.not.isnumber(car(scm_args))) then call error0('new segment -- argument must be a number!') return end if cell_segment=get_ivalue(car(scm_args)) write(outstr, '(a,i4,a)') & 'Allocation of new memory in increments of ', cell_segment, ' cells' call s_return(t) 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=5000) :: 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)) then if (plevel >= 0) call printatom(scm_args, 0, -1) 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') '(' call s_save(OP_P1LIST, cdr(scm_args), nil) 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) 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 :: x, y integer (kind=8) :: v double precision :: rv ! exponentiation if (op == OP_EXP) then x = car(scm_args) rv=exp(rvalue(x)) call s_return(mk_real(rv)) ! natural log else if (op == OP_LOG) then x = car(scm_args) rv = log(rvalue(x)) call s_return(mk_real(rv)) ! sine else if (op == OP_SIN) then x = car(scm_args) rv = sin(rvalue(x)) call s_return(mk_real(rv)) ! cosine else if (op == OP_COS) then x = car(scm_args) rv = cos(rvalue(x)) call s_return(mk_real(rv)) ! tan else if (op == OP_TAN) then x = car(scm_args) rv = tan(rvalue(x)) call s_return(mk_real(rv)) ! arcsine else if (op == OP_ASIN) then x = car(scm_args) rv = asin(rvalue(x)) call s_return(mk_real(rv)) ! arcosine else if (op == OP_ACOS) then x = car(scm_args) rv = acos(rvalue(x)) call s_return(mk_real(rv)) ! arctan else if (op == OP_ATAN) then x = car(scm_args) rv = atan(rvalue(x)) call s_return(mk_real(rv)) ! sqrt else if (op == OP_SQRT) then x = car(scm_args) 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 ! truncate else if (op == OP_TRUNCATE) then x = car(scm_args) rv = int(rvalue(x)) call s_return(mk_real(rv)) ! round else if (op == OP_ROUND) then x = car(scm_args) rv = anint(rvalue(x)) call s_return(mk_real(rv)) ! abs else if (op == OP_ABS) then x = car(scm_args) if (isinteger(x)) then v=abs(get_ivalue(x)) call s_return(mk_number(v)) else rv = abs(rvalue(x)) call s_return(mk_real(rv)) end if else if (op == OP_EXPT) then x = car(scm_args) y = cadr(scm_args) if (isinteger(x) .and. isinteger(y) .and. get_ivalue(y) >= 0) then v = get_ivalue(x) ** get_ivalue(y) call s_return(mk_number(v)) else rv = rvalue(x) ** rvalue(y) call s_return(mk_real(rv)) 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=get_value(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. 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=get_value(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. 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=get_value(car(scm_args)) 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 (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 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 end if end subroutine opexe8 ! ! string functions ! subroutine opexe9(op) integer :: op integer :: i, ioerr, j, l, v, x logical :: comp, inword, intresult double precision :: rv character (len=1) :: ch, sep character (len=40) :: str character (len=200) :: bigstr ch=' ' ! make-string if (op == OP_MKSTRING) then l=get_ivalue(car(scm_args)) 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 (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 (ch == sep .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 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 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('Argument is not a string: ', car(scm_args)) return else if (.not.isstring(cadr(scm_args))) then call error1('Argument 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 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 is not a string: ', car(scm_args)) return end if j=10 intresult=.true. str=get_string(car(scm_args)) if (cdr(scm_args) /= nil) then j=get_ivalue(cadr(scm_args)) end if if (j == 2) then read(str,'(b40)', iostat=ioerr) i else if (j == 8) then read(str,'(o40)', iostat=ioerr) i else if (j == 16) then read(str,'(z40)', iostat=ioerr) i else read(str,'(i40)', iostat=ioerr) i if (ioerr /= 0) then intresult=.false. read(str,'(f40.0)', iostat=ioerr) rv end if end if if (ioerr /= 0) then call s_return(f) else if (intresult) then call s_return(mk_number(int(i,kind=8))) else call s_return(mk_real(rv)) end if ! number->string else if (op == OP_NUM2STR) then x=car(scm_args) if (isnumber(x)) then if (isinteger(x)) then write(str,'(i40)') get_ivalue(x) else write(str,'(g40.12)') get_value(x) end if call s_return(mk_string(trim(adjustl(str)))) 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 ! ! Nonstandard library additions for system interface such as system, read-line ! 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 ! ! Extensions for i/o and accessing system facilities eg inquire, time, date ! subroutine opexe10(op, plevel) use string_utilities 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 #if IFORT || SUN || OPEN64 logical :: isatty character (len=24) :: fdate #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 == -2) 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 == -2) 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 ! 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. scan(buff(2:2), 'Aa') > 0) then write(outfp, buff, advance='no') get_string(car(x)) else if (isnumber(car(x))) then if (isinteger(car(x)) .and. scan(buff(2:2), 'Ii') > 0 ) then write(outfp, buff, advance='no') get_ivalue(car(x)) else if (isinteger(car(x)) .and. scan(buff(2:2), 'Bb') > 0 ) then write(outfp, buff, advance='no') get_ivalue(car(x)) else if (isfloat(car(x)) .and. scan(buff(2:2), 'fFgG') > 0) then write(outfp, buff, advance='no') get_value(car(x)) else call printatom(car(x), 0, -1) end if else call printatom(car(x), 0, -1) end if x=cdr(x) if (x /= nil) then call error0('Fortran format takes a single argument!') end if else i=1 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, eg affecting padding if (ch == '@' .and. i 0) then print_flag=0 call printatom(car(x), -n, d) x=cdr(x) else if (ch == '%') then write(outfp,*) else if (ch == '~') then write(outfp, '(a)', advance='no') '~' 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) // '"') end if end if else call error0('Expected [] args...!') end if call s_return(un) ! fdate, getenv else if (op == OP_FDATE) then call s_return(mk_string(trim(fdate()))) else if (op == OP_TIME) then call s_return(mk_number(int(time(), kind=8))) else if (op == OP_GETENV) then call getenv(get_string(car(scm_args)), buff) call s_return(mk_string(trim(buff))) else if (op == OP_INQUIRE) then inquire(file=get_string(car(scm_args)), exist=ios) call s_retbool(ios) else if (op == OP_ISATTY) then #if !OPEN64 call s_retbool(isatty(5)) #else call s_return(t) #endif ! 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(t) else if (op == OP_HELP) then typ=1 strm=outstr if (isclosure(car(scm_args))) then i=car(cdr(caar(scm_args))) if (isstring(i)) then typ=10 write(outstr, '(a)') get_string(i) end if else if (isstring(car(scm_args))) then str=get_string(car(scm_args)) if (strfind('*stat*', 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 typ=2 str='*' // get_string(car(scm_args)) // '*' nports=nports+1 strm=portaddress(nports) open(strm,file='sib-pair.hlp',status='unknown') end if end if if (typ == 1 .or. typ == 2) then write(strm, '(a)') & 'Sib-pair Scheme (' // scheme_version // ') is a minimal scheme interpreter.', & 'It implements integer/flonum arithmetic and strings.', & ' (version) prints Sib-pair version.', & ' (apropos ) lists commands containing that string.', & ' (file-exists? ) test 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 "{~[:num:][@][ASD~%]}" ...) formatted output.', & ' (string-split []) splits string on white space or optional char.', & ' (substring? ) returns start of substring in string.', & ' (seq ) generate sequence.', & ' (system ) passes command to shell.', & ' (getenv ) returns value of environment variable.', & ' (isatty?) tests if interactive session.', & ' (date) returns current date and time.', & ' (time) returns current time as seconds since epoch.' write(strm, '(a)') & 'Sib-pair locus dataset accessors:', & ' (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.', & ' (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").', & ' (locrank ) returns rank of locus test statistic.', & ' (map-position ) returns map position for locus.', & ' (chromosome ) returns 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.', & ' (stat-result ["pval|lik|npars|lrt|df|stat|var"]) returns result of last model.' write(strm, '(a)') & 'Sib-pair phenotype dataset accessors:', & ' (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-name [<idx>...]) give ID for index.', & ' (individual-index [(<id>|<idx>)...]) give index for ID', & ' (father [<idx>...]) father indices.', & ' (mother [<idx>...]) mother indices.', & ' (imztwin [<idx>...]) MZ twin pointer.', & ' (sex [<idx>...]) sex value for individual.', & ' (data <loc> [<idx>...]) phenotype for individual.', & ' (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 include:', & ' (pnorm <z>) (qnorm <p>) (fp <f> <df1> <df2>)', & ' (pchisq <x2> <df> [<ncp>]) (qchisq <p> <df>)', & ' (bivnor <p1> <p2> <r>) (pgamma <x> <p>) (lgamma <x>)' end if if (typ == 1 .or. typ == 2 .or. typ == 4) then #if JAPI write(strm, '(a)') & 'JAPI AWT GUI procedures include:', & ' (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 include:', & ' (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) write(outstr,*) do read(strm,'(a)', iostat=ioerr) buff if (ioerr /= 0) exit if (strfind(str, buff, 2)) then i=i+1 write(outstr,'(a)') trim(buff) end if end do nports=nports-1 close(strm,status='delete') end if call s_return(un) 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()) end if end subroutine opexe10 ! ! Statistical library ! subroutine opexe11(op) use statfuns integer :: op integer :: ifault, x, y, z integer (kind=8) :: v double precision :: rv ! 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_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 ! 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 end if end subroutine opexe11 ! ! Procedures that interact with Sib-pair ! subroutine opexe12(op, plevel) use statresults use locus_data use locus_types use pedigree_data use string_utilities 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, kind=8))) else if (typ == -1 .or. typ == LOC_DEL) then do i=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-n, kind=8))) end if else do i=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=1, nloci res=cons(mk_string(trim(loc(i))), res) end do else if (typ == -1) then do i=1, nloci if (isactive(loctyp(i))) then res=cons(mk_string(trim(loc(i))), res) end if end do else if (typ == LOC_DEL) then do i=1, nloci if (.not.isactive(loctyp(i))) then res=cons(mk_string(trim(loc(i))), res) end if end do else do i=1, nloci if (same_loctyp(loctyp(i), typ)) then res=cons(mk_string(trim(loc(i))), res) end if end do end if call s_return(non_alloc_rev(nil, res)) end if ! Return information about locus else if (op >= OP_LOCNAM .and. op <= OP_CHROM) then n=0 res=nil x=scm_args do while (x /= nil) n=n+1 i=0 if (isnumber(car(x))) then i = get_ivalue(car(x)) else if (isstring(car(x))) then str=trim(get_string(car(x))) do j=1, nloci if (str == loc(j)) then i=j exit end if end do end if if (i > 0 .and. i <= nloci) then if (op == OP_LOCNAM) then res=cons(mk_string(trim(loc(i))), res) 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=cons(mk_string(trim(str)), res) else if (op == OP_LOCORD) then res=cons(mk_number(int(i, kind=8)), res) else if (op == OP_LOCSTAT) then if (locstat(i) /= MISS) then res=cons(mk_real(locstat(i)), res) else res=cons(f, res) end if else if (op == OP_SETSTAT) then if (isnumber(cadr(scm_args))) then locstat(i)=get_value(cadr(scm_args)) call s_return(t) else call error0('Expected a number!') end if return else if (op == OP_LOCNOT) then res=cons(mk_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=cons(mk_number(int(v, kind=8)), res) else res=cons(f, res) end if else if (op == OP_MAPPOS) then res=cons(mk_real(map(i)), res) else if (op == OP_CHROM) then res=cons(mk_string(trim(group(i))), res) end if end if x=cdr(x) end do if (n == 1) then call s_return(car(res)) else call s_return(reverse(res)) end if ! ! access results from Sib-pair statistical procedures else if (op == OP_STATRES) then x=scm_args if (x == nil) then call s_return(mk_real(pval)) else if (isstring(car(x)) .or. issymbol(car(x))) then if (issymbol(car(scm_args))) then str=trim(get_string(caar(x))) else str=trim(get_string(car(x))) 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 end if ! initialize locstat else if (op == OP_INITSTAT) then x=scm_args if (x == nil) then call setup_stat(' ') else if (isstring(car(x))) then call setup_stat(trim(get_string(car(x)))) else call setup_stat(' ') end if call s_return(t) end if end subroutine opexe12 ! ! Manipulate Sib-pair dataset ! subroutine opexe13(op, plevel) use locus_data use locus_types use pedigree_data interface subroutine wrgtp(all1, all2, gtp, allsep, typ) integer, intent(in) :: all1 integer, intent(in) :: all2 character (len=*), intent(out) :: gtp character (len=1), intent(in) :: allsep integer, intent(in) :: typ end subroutine end interface integer :: op integer, intent(in) :: plevel integer, parameter :: MISS = -9999 integer :: i, idx, j, n, tmp, x, y, res integer :: g1, g2, ped character (len=1) :: ch character (len=20) :: buff double precision :: val n=0 res=nil x=scm_args if (op == OP_GETDATA .or. op == OP_GETSEX) then j=0 if (op == OP_GETDATA) then y=car(x) x=cdr(x) if (isnumber(y)) then j = get_ivalue(y) else if (isstring(y)) then call find_hashtab(trim(get_string(y)), loc, lochash, j) end if if (j < 1 .or. j > nloci) then call error0('Expected locus name or index!') return 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) tmp=getcell(res, nil) call set_type(tmp, ior(T_STRING, T_ATOM)) call set_string(tmp, ch) res=cons(tmp, res) end do end if end do else do ped=1, work%nped if (work%actset(ped) > 0) then do i=work%num(ped-1)+1, work%num(ped) n=n+1 tmp=getcell(res, nil) if (ismarker(loctyp(j))) then call get_geno(i, locpos(j), locpos(j)+1, work, g1, g2) call wrgtp(g1, g2, buff, '/', 1) call set_type(tmp, ior(T_STRING, T_ATOM)) call set_string(tmp, trim(adjustl(buff))) else if (isqtrait(loctyp(j))) then call set_type(tmp, ior(T_NUMBER, T_ATOM)) call set_value(tmp, work%plocus(i,locpos(j))) else call set_type(tmp, ior(T_NUMBER, T_ATOM)) call set_ivalue(tmp, int(work%plocus(i,locpos(j)), kind=8)) end if res=cons(tmp, res) end do end if end do end if else 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(*,*) '## ', i, work%id(i), j, loc(j) end if tmp=getcell(x, res) if (op == OP_GETSEX) then call wrsex(work%sex(i),ch) tmp=getcell(x, res) call set_type(tmp, ior(T_STRING, T_ATOM)) call set_string(tmp, ch) else if (ismarker(loctyp(j))) then call get_geno(i, locpos(j), locpos(j)+1, work, g1, g2) call wrgtp(g1, g2, buff, '/', 1) call set_type(tmp, ior(T_STRING, T_ATOM)) call set_string(tmp, trim(adjustl(buff))) res=cons(mk_string(trim(adjustl(buff))), res) else if (isqtrait(loctyp(j))) then call set_type(tmp, ior(T_NUMBER, T_ATOM)) call set_value(tmp, work%plocus(i,locpos(j))) else call set_type(tmp, ior(T_NUMBER, T_ATOM)) call set_ivalue(tmp, int(work%plocus(i,locpos(j)), kind=8)) end if res=cons(tmp, res) else res=cons(f, res) end if else 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_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=cons(mk_number(int(work%actset(i), kind=8)), res) end do call s_return(non_alloc_rev(nil, res)) else if (op == OP_SETACTIVE) then if (isnumber(car(x)) .and. isnumber(cadr(x))) then i=get_ivalue(car(x)) 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 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=cons(mk_string(trim(work%pedigree(i))), res) end do else do i=1, work%nped if (work%actset(i) > 0) then res=cons(mk_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 tmp=getcell(x, res) call set_type(tmp, ior(T_STRING, T_ATOM)) call set_string(tmp, ch) call set_string(tmp, trim(work%pedigree(i))) res=cons(tmp, res) 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_PEDSIZE) then if (x == nil) then do i=1, work%nped res=cons(mk_number(int(work%num(i)-work%num(i-1), kind=8)), 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 tmp=getcell(x, res) call set_type(tmp, ior(T_NUMBER, T_ATOM)) call set_ivalue(tmp, int(work%num(i)-work%num(i-1), kind=8)) res=cons(tmp, res) 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=cons(mk_number(int(j, kind=8)), 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) end if if (i > 0 .and. i <= work%nobs) then if (op == OP_IDLIST) then res=cons(mk_string(trim(work%id(i))), res) else if (work%actset(work%iped(i)) > 0) then res=cons(mk_number(int(i, kind=8)), 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_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=cons(mk_number(int(idx, kind=8)), 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 ! ! 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 do ped=1, work%nped if (work%actset(ped) > 0) then do i=work%num(ped-1)+1, work%num(ped) res=extractor(i, res) end do end if end do end subroutine alldata ! ! extractors for different pedigree data fields ! function extract_ped(i, res) use pedigree_data integer :: extract_ped integer, intent(in) :: i integer, intent(in) :: res extract_ped=cons(mk_number(int(i,kind=8)),res) end function extract_ped ! 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 ! 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 ! 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 ! 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 ! 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 ! ! GUI library (japi) ! #if JAPI subroutine opexe14(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_JSEPERATOR) 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 opexe14 #endif ! ! eggx graphics library ! #if EGGX subroutine opexe15(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 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 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 call gcloseall() call s_return(t) else if (op == OP_EGGNEWWINDOW) 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 call newwindow(int(get_ivalue(w), kind=4), & get_value(x), get_value(y), & get_value(i), get_value(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=get_value(x) ypos=get_value(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=get_value(x) ypos=get_value(y) xpos2=get_value(i) ypos2=get_value(j) 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=get_value(x) ypos=get_value(y) xpos2=get_value(i) ypos2=get_value(j) 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=get_value(x) ypos=get_value(y) xpos2=get_value(i) ypos2=get_value(j) 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=get_value(x) ypos=get_value(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=get_value(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=get_value(x) ypos=get_value(y) siz=14.0 if (isnumber(j)) siz=get_value(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=get_value(x) ypos=get_value(y) siz=14.0 if (isnumber(i)) siz=get_value(i) n=4 if (isnumber(j)) n=get_value(j) val=get_value(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 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)) end if end subroutine opexe15 #endif ! ! ! 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) call set_type(y, ior(T_PROC, T_ATOM)) call set_ivalue(y, int(op, kind=8)) 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, '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_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_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_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') 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_LOCTYP, 'loctyp') 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_LOCNOT, '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_CHROM, 'chromosome') call mk_proc(OP_FDATE, 'date') call mk_proc(OP_TIME, 'time') call mk_proc(OP_GETENV, 'getenv') call mk_proc(OP_INQUIRE, 'file-exists?') call mk_proc(OP_ISATTY, 'isatty?') call mk_proc(OP_APROPOS, 'apropos') call mk_proc(OP_HELP, 'help') call mk_proc(OP_VERSION, 'version') call mk_proc(OP_GENSYM, 'gensym') ! 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_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_FATHER, 'father') call mk_proc(OP_MOTHER, 'mother') call mk_proc(OP_GETSEX, 'sex') call mk_proc(OP_IMZTWIN, 'imztwin') call mk_proc(OP_GETDATA, 'data') ! statistical procedure call mk_proc(OP_PNORM, 'pnorm') 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') #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_JSEPERATOR, "j_seperator") 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 (caar x) (car (car x)))' call repl_scheme(3,0) scheme_lin='(define (cadr x) (car (cdr x)))' call repl_scheme(3,0) scheme_lin='(define (cdar x) (cdr (car x)))' call repl_scheme(3,0) scheme_lin='(define (cddr x) (cdr (cdr x)))' call repl_scheme(3,0) scheme_lin='(define (caaar x) (car (car (car x))))' call repl_scheme(3,0) scheme_lin='(define (caadr x) (car (car (cdr x))))' call repl_scheme(3,0) scheme_lin='(define (cadar x) (car (cdr (car x))))' call repl_scheme(3,0) scheme_lin='(define (caddr x) (car (cdr (cdr x))))' call repl_scheme(3,0) scheme_lin='(define (cdaar x) (cdr (car (car x))))' call repl_scheme(3,0) scheme_lin='(define (cdadr x) (cdr (car (cdr x))))' call repl_scheme(3,0) scheme_lin='(define (cddar x) (cdr (cdr (car x))))' call repl_scheme(3,0) scheme_lin='(define (cdddr x) (cdr (cdr (cdr x))))' call repl_scheme(3,0) scheme_lin='(define call/cc call-with-current-continuation)' 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 (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 (list-tail x k) (if (zero? k) x (list-tail (cdr x) (- k 1))))' call repl_scheme(3,0) scheme_lin='(define (list-ref x k) (if (null? x) x (car (list-tail x k))))' 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 (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 (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 (seq m n) (if (> m n) ''() (cons m (seq (+ 1 m) n))))' 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 (exit) ((pass-command "exit") (quit)))' call repl_scheme(3,0) scheme_lin='(define (run cmd) ' // & '(begin (pass-command (string-append cmd "; eval resume")) (quit)))' call repl_scheme(3,0) scheme_lin='(macro quasiquote (lambda (l) ' // & '(define (mcons f l r) (if (and (pair? r)' // & '(eq? (car r) (quote quote)) (eq? (car (cdr r)) (cdr f)) (pair? l)' // & '(eq? (car l) (quote quote)) (eq? (car (cdr l)) (car f)))' // & '(if (or (procedure? f) (number? f) (string? f)) f (list (quote quote) f))' // & '(list (quote cons) l r)))' // & '(define (mappend f l r) (if (or (null? (cdr f)) ' // & '(and (pair? r) (eq? (car r) (quote quote))' // & '(eq? (car (cdr r)) ''()))) l (list (quote append) l r)))' // & '(define (foo level form) (cond ((not (pair? form))' // & '(if (or (procedure? form) (number? form) (string? form)) ' // & 'form (list (quote quote) form)))' // & '((eq? (quote quasiquote) (car form))' // & '(mcons form (quote (quote quasiquote)) (foo (+ level 1) (cdr form))))' // & '(#t (if (zero? level) (cond ((eq? (car form) (quote unquote)) (car (cdr form)))' // & '((eq? (car form) (quote unquote-splicing))' // & '(error "Unquote-splicing wasn''t in a list:" form))' // & '((and (pair? (car form)) (eq? (car (car form)) (quote unquote-splicing)))' // & '(mappend form (car (cdr (car form))) (foo level (cdr form))))' // & '(#t (mcons form (foo level (car form)) (foo level (cdr form)))))' // & '(cond ((eq? (car form) (quote unquote)) ' // & '(mcons form (quote (quote unquote)) (foo (- level 1) (cdr form))))' // & '((eq? (car form) (quote unquote-splicing))' // & '(mcons form (quote (quote unquote-splicing))' // & '(foo (- level 1) (cdr form)))) (#t (mcons form (foo level (car form))' // & '(foo level (cdr form))))))))) (foo 0 (car (cdr l)))))' call repl_scheme(3,0) scheme_lin='(macro do (lambda (do-macro) (apply (lambda ' // & '(do vars endtest . body) (let ((do-loop (gensym)))' // & '`(letrec ((,do-loop (lambda ,(map (lambda (x) (if (pair? x) (car x) x))' // & '`,vars) (if ,(car endtest) (begin ,@(cdr endtest)) (begin ,@body' // & '(,do-loop ,@(map (lambda (x) (cond ((not (pair? x)) x) ((< (length x) 3) (car x))' // & '(else (car (cdr (cdr x)))))) `,vars))))))) (,do-loop ,@(map (lambda (x)' // & '(if (and (pair? x) (cdr x)) (car (cdr x)) ''())) `,vars))))) do-macro)))' call repl_scheme(3,0) end subroutine init_scm ! ! Initiate procedures ! subroutine init_globals() 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() end subroutine init_globals ! ! Error handling ! 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 ! 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 ! subroutine init_scheme() call setup_mem(100) 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, op, plevel integer, save :: mlevel = 1 plevel=0 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) then mlevel=inline plevel=-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 (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_GENSYM) then call opexe10(op, plevel) else if (op >= OP_PNORM .and. op <= OP_ALNGAM) then call opexe11(op) else if (op >= OP_RUNCMD .and. op <= OP_INITSTAT) then call opexe12(op, plevel) else if (op >= OP_NOBS .and. op <= OP_GETDATA) then call opexe13(op, plevel) #if JAPI else if (op >= OP_JSTART .and. op <= OP_JSETFLOWLAYOUT) then call opexe14(op) #endif #if EGGX else if (op >= OP_EGGETDISPLAYINFO .and. op <= OP_EGGLINETO) then call opexe15(op) #endif else write(*, '(a)') 'Bad op code! Exiting!' exit end if end do prompt_string='>> ' end subroutine repl_scheme end module scheme_lang ! ! 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 :: 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 ! ! read commands and write appropriate formula structure ! subroutine create_form(sta, fin, terms, nloci, loc, formula) use outstream integer :: sta, fin character (len=*), dimension(:), intent(in) :: terms integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc type (formula_data) :: formula integer, dimension(fin-sta+1) :: tmpeff integer :: fpos, i, lev, locnum, pos, prev logical :: fnd, interact character (len=1) :: cross = '*', minus = '-', plus = '+' ! functions integer isinenv formula%intercept=.true. formula%nterms=0 formula%maxrows=0 formula%maxlev=1 formula%neff=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 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 write(outstr,'(3a)') & 'ERROR: In model formula "-', trim(terms(pos+1)), '" not allowed.' end if end if prev=0 else locnum=isinenv(terms(pos)(1:20), nloci, loc) 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 write(outstr,'(3a)') & 'ERROR: In model formula "', trim(terms(pos)), '" is not a locus.' end if end if pos=pos+1 end do allocate(formula%effects(formula%neff)) allocate(formula%nlev(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)) formula%effects=tmpeff(1:formula%neff) formula%mainlen=0 formula%nlev=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 locnum=isinenv(terms(pos)(1:20), nloci, loc) 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 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%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%nlev(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(*,*) '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 end module formula_class ! ! 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 glm_types integer, parameter :: GLM_GAUSS=1, GLM_BINOM=2, GLM_POISS=3, GLM_WEIB=4, GLM_EXPON=5, GLM_EVD=6 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(6) = (/ 'Gaussian', 'Binomial', 'Poisson ', & 'Weibull ', 'Expntial', 'EVD ' /) character (len=8) :: linkid(5) = (/ 'Identity', 'Logit ', 'Probit ', & 'MFT ', 'Log '/) end module glm_types 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 ! ! 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_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 ! matrix inversion algorithm integer :: invalg = 1 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 end module ibd_class ! ! multidimensional contingency table of trait values ! ! 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, ! module contingency_table 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 double precision, dimension(:,:), allocatable :: categories integer, dimension(:), allocatable :: idx integer, dimension(:), allocatable :: icount end type table_data contains ! ! allocate space for contingency table ! subroutine setup_table(ncat, maxcells, table) integer :: ncat, maxcells type (table_data) :: table table%ncat = ncat table%ncells = 0 table%ntot = 0 table%hits= 0 table%misses= 0 allocate(table%categories(maxcells, ncat)) allocate(table%idx(maxcells)) allocate(table%icount(maxcells)) 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 end do table%ncat = 0 table%ncells = 0 table%ntot = 0 table%hits = 0 table%misses = 0 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 deallocate(table%categories) deallocate(table%idx) deallocate(table%icount) 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%categories(1:nrow, 1:ncol) = table%categories(1:nrow, 1:ncol) table2%idx(1:nrow) = table%idx(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%categories(1:nrow, 1:ncol) = table2%categories(1:nrow, 1:ncol) table%idx(1:nrow) = table2%idx(1:nrow) table%icount(1:nrow) = table2%icount(1:nrow) call clean_table(table2) end subroutine expand_table ! ! insert data ! subroutine insert_table(ncat, values, table, iwt) integer, intent(in) :: ncat double precision, intent(in) :: values(ncat) type (table_data) :: table integer, intent(in) :: iwt ! local variables integer :: catpos, endcat, endcell, hi, i, k, lo, pos double precision :: missrate endcell=table%ncells hi=endcell lo=1 pos=lo search: do while (hi >= lo) pos=(hi+lo)/2 catpos=table%idx(pos) ! test if higher do i=1, ncat if (values(i) > table%categories(catpos,i)) then lo=pos+1 cycle search else if (values(i) < table%categories(catpos,i)) then exit end if end do ! test if lower do i=1, ncat if (values(i) < table%categories(catpos,i)) then hi=pos-1 cycle search else if (values(i) > table%categories(catpos,i)) then exit end if end do ! just right table%hits=table%hits+1 table%ntot=table%ntot+iwt table%icount(pos)=table%icount(pos)+iwt return end do search ! ! else if not found ! if not enough room, expand table ! if (table%ncells == size(table%idx)) then missrate = dfloat(table%misses)/dfloat(table%hits+table%misses) call expand_table(max(10,int(500.d0*missrate)), table) end if ! insert new record table%ntot=table%ntot+iwt table%misses=table%misses+1 do k=table%ncells, lo, -1 table%idx(k+1)=table%idx(k) table%icount(k+1)=table%icount(k) end do table%ncells=table%ncells+1 table%idx(lo)=table%ncells table%icount(lo)=iwt table%categories(table%ncells,1:ncat)=values(1:ncat) end subroutine insert_table ! ! Search table ! function search_table(ncat, values, table) integer :: search_table integer, intent(in) :: ncat double precision, intent(in) :: values(ncat) type (table_data) :: table ! local variables integer :: catpos, endcat, hi, i, k, lo, pos hi=table%ncells lo=1 pos=lo search: do while (hi >= lo) pos=(hi+lo)/2 catpos=table%idx(pos) ! test if higher do i=1, table%ncat if (values(i) > table%categories(catpos,i)) then lo=pos+1 cycle search else if (values(i) < table%categories(catpos,i)) then exit end if end do ! test if lower do i=1, table%ncat if (values(i) < table%categories(catpos,i)) then hi=pos-1 cycle search else if (values(i) > table%categories(catpos,i)) then exit end if end do ! just right search_table=pos return end do search write(*,*) 'Couldn''t find ', values search_table=0 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 ! subroutine print_table(table) use outstream type (table_data) :: table ! local variables integer :: i do i=1, table%ncells write(outstr,*) i, ': ', table%categories(table%idx(i),1:table%ncat), table%icount(i) end do 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, j double precision, dimension(nmargin) :: values do i=1, table%ncells do j=1, nmargin values(j)=table%categories(table%idx(i),margin(j)) end do call insert_table(nmargin, values, martable, table%icount(i)) end do 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 double precision, dimension(mtable1%ncat) :: values 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%categories(catpos, k) /= values(k)) then match=.false. exit end if end do if (match .and. & table%categories(catpos, table%ncat) == & mtable2%categories(mtable2%idx(j),1)) then mat(matpos)=table%icount(pos) 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 ! ! reorder values in 1-D table to match order in table index ! subroutine sort_table(cat, table) integer :: cat type (table_data) :: table integer i double precision, dimension(table%ncells) :: catvals do i=1, table%ncells catvals(i)=table%categories(table%idx(i),cat) end do do i=1, table%ncells table%idx(i)=i table%categories(i,1)=catvals(i) end do end subroutine sort_table ! ! factor level based on position in (marginal) 1-D table ! function findlev(val, table) integer :: findlev double precision :: val type (table_data) :: table integer, parameter :: MISS=-9999 integer :: catpos, hi, i, lo, pos ! hi=table%ncells ! lo=1 ! pos=lo ! search: do while (hi >= lo) ! pos=(hi+lo)/2 ! catpos=table%idx(pos) !! test if higher ! if (val > table%categories(catpos,1)) then ! lo=pos+1 ! cycle search ! else if (val < table%categories(catpos,1)) then ! exit ! end if !! test if lower ! if (val < table%categories(catpos,1)) then ! hi=pos-1 ! cycle search ! else if (val > table%categories(catpos,1)) then ! exit ! end if !! just right ! findlev=pos ! return ! end do search !! not here, return 1 if (val==MISS) then findlev=MISS return end if do i=1, table%ncells catpos=table%idx(i) if (val == table%categories(catpos,1)) then findlev=i return end if end do write(*,*) 'ERROR: In findlev, ', val, ' not in table!' do i=1, table%ncells write(*,*) i, table%categories(table%idx(i),1) end do findlev=1 end function findlev ! ! find rank based on position in 1-D table ! function findrank(val, table) double precision findrank double precision val type (table_data) :: table integer i, cumsum cumsum=0 do i=1, table%ncells if (val == table%categories(table%idx(i),1)) then findrank = dfloat(cumsum + (1+table%icount(i))/2) + & 0.5d0*mod(1+table%icount(i), 2) return end if cumsum=cumsum+table%icount(i) 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*dfloat(table%ntot) end function findrank end module contingency_table ! ! 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=(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=(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 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 (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. totvars > 0) then write(outstr, '(/4x,a/2x,a)') 'Variable Levels', repeat('-', 20) 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,a14,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. ! Possibly including an intercept. ! Missing x values replaced by overall mean ! subroutine fixeff(idx, designpos, interc, gene, genemod, allele_buffer, nvar, & varlist, loctyp, locpos, covariates, dataset, vals) use alleles_class use ped_class use locus_types 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 integer, intent(in) :: nvar integer, dimension(:), intent(in) :: varlist 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, parameter :: KNOWN=0, MISS=-9999 integer :: a1, a2, genelevels, ii, icat, j, k, ncat, pos, vpos double precision :: freq double precision, 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 (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) a1=getnam(a1, allele_buffer)-1 a2=getnam(a2, allele_buffer)-1 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*dfloat(a1+a2) else vals(designpos,vpos)=covariates%means(vpos) 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) 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 values(1)=dataset%plocus(idx,locpos(pos)) ii=search_table(1, values, covariates%martable(icat))-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) end do end if vpos=vpos+ncat else vpos=vpos+1 if (dataset%plocus(idx, locpos(pos)) /= MISS) then vals(designpos,vpos)=dataset%plocus(idx,locpos(pos)) else vals(designpos,vpos)=covariates%means(vpos) end if end if end do end subroutine fixeff ! ! Means for set of variables (incl dummies) in formula ! subroutine xmeans(nvar, varlist, loctyp, locpos, dataset, covariates) use ped_class use locus_types implicit none ! position of y and x variables integer, intent(in) :: nvar integer, dimension(:), intent(in) :: varlist 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, nmeans, ncat, ped, pos, vpos double precision, dimension(1) :: values nmeans=covariates%totvars+1 allocate(covariates%means(nmeans)) do vpos=1, nmeans nobs(vpos)=0 covariates%means(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(j)=nobs(vpos)+1 covariates%means(j)=covariates%means(vpos)+0.5d0*dfloat(g1+g2) 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 covariates%means(vpos)=covariates%means(vpos)+dataset%plocus(i,locpos(pos))-1.0d0 end if else if (loctyp(pos) == LOC_CAT) then icat=icat+1 if (dataset%plocus(i,locpos(pos)) /= MISS) then ncat=covariates%martable(icat)%ncells-1 values(1)=dataset%plocus(i,locpos(pos)) ii=search_table(1, values, covariates%martable(icat))-1 if (ii > 0) then nobs(vpos+ii)=nobs(vpos+ii)+1 covariates%means(vpos+ii)=covariates%means(vpos+ii)+1.0d0 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 (dataset%plocus(i,locpos(pos)) /= MISS) then nobs(vpos)=nobs(vpos)+1 covariates%means(vpos)=covariates%means(vpos)+dataset%plocus(i,locpos(pos)) end if end if end do end do end if end do do vpos=1, nmeans if (nobs(vpos) > 0) then covariates%means(vpos)=covariates%means(vpos)/dfloat(nobs(vpos)) end if end do end subroutine xmeans end module covariate_data ! ! Work arrays for AS164 -- allow passing of results to other routines ! module AS164_class double precision, dimension(:), allocatable :: b double precision, dimension(:), allocatable :: cov double precision, dimension(:), allocatable :: r contains subroutine clean_AS164() if (allocated(b)) then deallocate(b, cov) end if if (allocated(r)) then deallocate(r) end if end subroutine clean_AS164 end module AS164_class ! ! 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 ! ! Actual varmet minimizer ! module optimizer public :: varmet, vmerr private :: grad contains subroutine varmet(fun, npar, b, f0, gradtl, toler, maxfn, ifault, plevel) use outstream use AS319 use interrupt ! double precision :: fun integer, intent(in) :: npar double precision, dimension(:), intent(inout) :: 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(npar, parest) use AS319 use ibd_class double precision :: fun integer, intent(in) :: npar double precision, dimension(:), intent(in) :: parest end function fun end interface ! ig = 0 ifn = 0 ler = .false. ifault = 0 np = npar + 1 ! if (maxfn == 0) maxfn = 1000 ! f0 = fun(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(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(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(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(fun, npar, b, f0, g, sa, er, ifault) use AS319 ! double precision :: fun integer, intent(in) :: npar double precision, dimension(:), intent(inout) :: 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(npar, parest) use AS319 use ibd_class double precision :: fun integer, intent(in) :: npar double precision, dimension(:), intent(in) :: 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(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 optimizer ! ! 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 double precision :: dev, obsp 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) 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/dfloat(max(1,gen_nloci)) gen_hs=gen_hs/dfloat(max(1,gen_nloci)) gen_ht=gen_ht/dfloat(max(1,gen_nloci)) if (plevel <= 0) then write(outstr,'(a14,20x,a21/a14,20x,3(1x,f6.4))') & '--------------', ' ------ ------ ------', & 'Multilocus ', gen_fis, gen_fit, gen_fst else write(outstr,'(/a/2(/a,3(3x,f6.4)))') & 'Results from combination of locus F statistics', & ' 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) integer, intent(in) :: outstr, plevel double precision :: gen_fis gen_fis=(gen_hs-gen_h0)/gen_hs if (plevel <= 0) then write(outstr,'(a14,22x,a6/a14,22x,f6.4)') & '--------------', '------', & 'Multilocus ', gen_fis else write(outstr,'(/a//a,3(3x,f6.4))') & 'Results from combination of locus F statistics', & ' Multilocus Fis =', gen_fis end if end subroutine popgen_homoz end module popgen_vcdata ! ! 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, j, k, pos pos=0 do i=1, n write(outstr,fstring) c((pos+1):(pos+i)) pos=pos+i end do end subroutine printmat ! ! 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 ! 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 x' S x or 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 end module symmetric_matrix ! ! The grapheps Postscript functions ! See http://swiss.csail.mit.edu/~jaffer/Docupage/grapheps ! module grapheps integer, parameter :: GSTRM = 22 contains subroutine pre_grapheps(outstr, xbound, ybound) integer, intent(in) :: outstr, xbound, ybound character (len=5) :: def0 #if IFORT || SUN character (len=24) :: fdate #endif 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: ', fdate() 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*dfloat(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*dfloat(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 represent "', 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 ! ! Main ! program nsp #if IFORT use ifport #endif use extras use rndseed use julian_epoch 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 locus_types use locus_data use fileio use mftcontrol use statfuns use statresults use string_utilities use scheme_lang ! ! 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=72) :: 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 integer :: nwid=9, ndec=4 ! field separator, and missing data token for sib-pair and "CSV" files character (len=1) :: fieldsep=',' character (len=3) :: cmisval=' ', misval='x' ! 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 ! ! 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) ! hassex=sex included in case-control data ! header=print locus names at top of file ! loconly=*inc*luding locus information only, ! last=last of a list, link=Linkage format, prompt=show a prompt, ! 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 ! sexchek=check/impute missing sexes ! 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 ! logical :: approx=.false., assfnd=.false., chek=.true., & fbatimp=.true., fixshape=.false., hassex=.true., last=.false., & mcp=.false., sexchek=.true., useimp=.false., xlinkd=.false. integer :: burnin=100, emiter=20, 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, prob, renumall, showorig, & skipline, tnum, tped, 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 ! 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, trait, weight double precision :: prevalence, qprev integer :: liabclass, liab, nliabclass ! 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, th2, th12 ! sexcrit=threshold for marker diagnosis of sex double precision :: sexcrit=0.999d0, thresh, toler ! ! Unspecified parental ID prefix ! misspar=how to treat multiple offspring where only one parent specified ! 0: new parent for each child ! 1: assume children of same parent are fullsibs ! character (len=8) :: unspecified='ZZ' integer :: misspar=0 ! ! 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 and alternative integer :: candal, other ! sizes for reallocation of arrays integer :: newsiz, oldsiz ! ! command counters: ! linlen=length of current command ! narg=no. arguments, nlin=no. lines of commands so far ! nord=number of selected loci ! numcmd=stored command buffer empty, echo/oldecho=echo input, ! prompt=show prompt, more=additional commands in buffer ! hascmd=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 ! integer :: linlen=0, narg=0, nlin=0, numcmd=0, plevel=0, pstyle=1 integer :: ioerr=0, imp=0, nrc=0, sigstat=0 integer :: nord=0 integer :: gui=0 logical :: echo=.true., more=.false., oldecho=.true., & prompt=.true., red=.false., silent=.false. logical :: filexist=.false., hascmd=.false., loconly=.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 :: imputd, newloc, newtyp=0, nhis, nrec=0, numtyp=0 integer :: nfam=0, nobs=0, nped=0, nprob=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 :: gzipped, reading double precision :: tmp integer :: eos, gen2, gcode, i, j, htyp, k, length, ltyp, n, & numal, numal2, pos, typ, typ1, typ2 logical :: isbin character (len=ped_width) :: bigped, deeped ! ! afftrait and liabtrait for Linkage locus and pedigree files ! fixmarker is a marker with prespecified allele frequencies ! character (len=20) :: afftrait=' ', cutnam=' ', & liabtrait=' ', fixmarker=' ' ! ! 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 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 integer :: MAXLOCI = 1000 ! ! line buffer and words integer :: maxwords = 1000 character (len=40), dimension(:), allocatable :: words character (len=3) :: keyword, keyw2 character (len=1) :: ch character (len=10) :: charnum ! ! macro variables and functions -- Sib-pair side ! buffers for name of macro (body goes into scheme_lin) ! character (len=40) :: macname ! ! functions ! chfind, strfind ! integer :: tid, omp_get_thread_num, omp_get_num_threads integer :: aval, findwh, findword, ival logical :: iscomment, iscomp, isint, isreal logical :: nextped, nonextped external :: nextped, nonextped character (len=2) :: compsign character (len=6) :: pstring character (len=8) :: wrpercent double precision :: bonf, fval, isaff, tetcor double precision :: togreg, tojulian #if !defined(GFORTRAN) && !defined (IFORT) && !defined (SUN) intrinsic :: signal #endif #if SUN integer :: hostnm, signal, time character (len=24) :: fdate logical :: isatty #endif ! ! external subroutines interfaces ! interface subroutine getbin(sta, fin, words, nloci, loc, lochash, loctyp, trait, gt, thresh) use outstream use locus_types use idhash_class 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 end subroutine getbin subroutine gettrait(nam, typ1, typ2, nloci, loc, lochash, loctyp, trait, plevel) use outstream use locus_types use idhash_class character (len=20), intent(in) :: nam integer, intent(in) :: typ1 integer, intent(in) :: typ2 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(in) :: plevel end subroutine gettrait subroutine loadnam(sta, fin, words, nloci, loc, lochash, loctyp, group, & map, locstat, chosen, nterms, terms, filter, typ) use outstream use locus_types use idhash_class 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(inout) :: loctyp character (len=2), 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 end subroutine loadnam subroutine docomp(pos, words, gt, thresh) use comp_ops integer, intent(inout) :: pos character (len=*), dimension(:), intent(in) :: words integer, intent(out) :: gt double precision, intent(out) :: thresh end subroutine docomp 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 end subroutine ldlist subroutine recode(loc, gene, loctyp, nto, recto, nf, recfro, dataset, plevel) use ped_class implicit none character (len=10), 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 listloci(nord, locord, nloci, loc, loctyp, outpos, locnotes, & typ, plevel) integer, intent(in) :: nord integer, intent(in) :: locord(nord) integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: outpos character (len=40), dimension(:), intent(in) :: locnotes integer, intent(in) :: typ integer, intent(in) :: plevel end subroutine listloci 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, nord, numloc) use fileio use parser_data use locus_data use storage_classes type (ioport) :: port character (len=*), intent(inout) :: lin character (len=40), dimension(:), intent(inout) :: words integer, intent(inout) :: nord 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=20), 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=2), dimension(:), intent(inout) :: group double precision, dimension(:), intent(inout) :: map double precision, dimension(:), intent(inout) :: locstat character (len=40), dimension(:), intent(inout) :: locnotes integer, dimension(:), intent(inout) :: ord end subroutine ordvar subroutine packer(typ, red, wrk, wrk2, nloci, loc, loctyp, locpos, & group, map, locnotes, dataset, plevel) use ped_class integer, intent(in) :: typ logical, intent(in) :: red integer, intent(in) :: wrk, wrk2 integer, intent(inout) :: nloci character (len=20), dimension(:), intent(inout) :: loc integer,dimension(:), intent(inout) :: loctyp integer,dimension(:), intent(inout) :: locpos character (len=2), dimension(:), intent(inout) :: group double precision, dimension(:), intent(inout) :: map character (len=40), dimension(:), intent(inout) :: locnotes type (ped_data) :: dataset integer, intent(inout) :: plevel end subroutine packer subroutine rdmerloc(port, xli, lin, nloci, loc, locpos, outpos, loctyp, locnotes, & numloc, twinning, twintype, twintrait) use fileio use storage_classes use parser_data type (ioport) :: port integer, intent(in) :: xli character (len=*), intent(inout) :: lin integer, intent(out) :: nloci character (len=20), dimension(:), intent(out) :: loc integer,dimension(:), intent(out) :: locpos, outpos integer,dimension(:), intent(out) :: loctyp character (len=40), dimension(:), intent(out) :: locnotes integer, dimension(NDATACLASS), intent(out) :: numloc integer, intent(out) :: twinning integer, intent(out) :: twintype character (len=20), intent(out) :: twintrait end subroutine rdmerloc subroutine rdplink(port, typ, chrcode, nloci, loc, locpos, outpos, & loctyp, locnotes, numloc, group, map) use outstream use fileio use parser_data use storage_classes use locus_types type (ioport) :: port integer, intent(in) :: typ, chrcode integer, intent(inout) :: nloci character (len=20), dimension(:), intent(inout) :: loc integer,dimension(:), intent(inout) :: locpos, outpos integer,dimension(:), intent(inout) :: loctyp character (len=40), dimension(:), intent(inout) :: locnotes ! Number of columns of data for each data class integer, dimension(NDATACLASS), intent(inout) :: numloc character (len=2), dimension(:), intent(inout) :: group double precision, dimension(:), intent(inout) :: map end subroutine rdplink 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 readmap(port, units, lin, words, plevel) use locus_data use outstream use fileio type (ioport) :: port integer, intent(in) :: units 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) 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 end subroutine readnames subroutine readcases(port, hassex, skipline, numloc, coltyp, & dataset, longnam, longest, nwarn, plevel) use outstream use fileio use locus_types use ped_class type (ioport) :: port logical, intent(in) :: hassex integer, intent(in) :: skipline 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 readcases subroutine readpeds(port, wrk, wrk2, skipline, link, unspecified, & mztwin, gt, thresh, sexchek, hassex, nextped, & numloc, coltyp, dataset, longnam, longest, nwarn, plevel) use fileio use ped_class type (ioport) :: port integer, intent(in) :: wrk, wrk2 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(sexcrit, sexmarker, 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 double precision, intent(in) :: sexcrit character(len=20), intent(in) :: sexmarker 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 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, nloci, loc, loctyp, locpos, & dataset, plevel) use outstream use ped_class use locus_types implicit none integer, intent(in) :: typ integer, intent(in) :: mztwin 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 mzfind 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, & dataset, droperr, ndiscard, inconsist, plevel) use ped_class 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=40), dimension(:), intent(in) :: locnotes 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, & misval, nrc, skip, filter, & nloci, loc, loctyp, locpos, 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) :: nwid integer, intent(in) :: ndec character (len=*), intent(in) :: misval integer, intent(in) :: nrc, skip, filter integer, intent(in) :: nloci character (len=*), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos 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, imp, nwid, ndec, sep, allsep, misval, twinning, & twintype, nloci, loc, loctyp, locpos, nord, locord, dataset) use ped_class implicit none integer, intent(in) :: strm integer, intent(in) :: typ 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 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 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 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 wrsnp(strm, trait, nloci, loc, loctyp, locpos, dataset) use ped_class use alleles_class use locus_types implicit none integer, intent(in) :: strm 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 wrsnp subroutine joinped(wrk, wrk2, typ, farg, larg, words, & nloci, loc, locpos, loctyp, locnotes, & 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 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, 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 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, dataset, plevel) use ped_class integer, intent(in) :: typ logical, intent(in out) :: red character (len=*), intent(in) :: pedfil integer, intent(in) :: nloci character (len=20), dimension(:), intent(in out) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in out) :: locpos, outpos character (len=40), dimension(:), intent(in out) :: locnotes integer, dimension(:), intent(inout) :: typed 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 function isinuse(string, nloci, loc) use parser_data logical isinuse character (len=*), intent(in) :: string integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc end function isinuse 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 function findml(nord, locord, loctyp) integer findml integer, intent(in) :: nord integer, dimension(:), intent(in) :: locord integer, dimension(:), intent(in out) :: loctyp end function findml 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, wtyp, wtag, expr, allele_buffer, dataset, & chek, imp, 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=40), dimension(:), intent(in) :: locnotes 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) :: droperr integer, intent(in) :: plevel end subroutine evalped subroutine showdata(fped, fid, larg, words, & nloci, loc, loctyp, locpos, & dataset, pedmask, nwid, ndec, misval, & fieldsep, allsep, pstyle) 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) :: 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, ndec character (len=*), intent(in) :: misval character (len=1), intent(in) :: fieldsep character (len=1), intent(in) :: allsep integer, intent(in) :: pstyle 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, wtyp, wtag, expr, & dataset, pedmask, nwid, ndec, misval, & fieldsep, allsep, 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 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, ndec character (len=*), intent(in) :: misval character (len=1), intent(in) :: fieldsep character (len=1), intent(in) :: allsep integer, intent(in) :: 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, nloc, loclist, loc, locpos, loctyp, & locnotes, dataset, iter, ndec, nwid, pval, plevel) use ped_class use contingency_table integer, intent(in) :: analys integer, intent(in) :: nloc ! number of dimensions integer, intent(in) :: loclist(nloc) ! variable 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 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 logrank(typ, nloc, loclist, 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 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, loctyp, locpos, & locnotes, dataset, mlik, mpar, pval, & nwid, ndec, plevel) use outstream use ped_class use formula_class use contingency_table integer, intent(in) :: sta, fin character (len=*), dimension(:), intent(in) :: terms 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 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 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, loc, loctyp, locpos, dataset) use ped_class implicit none integer, intent(in) :: typ integer, intent(in) :: nterms integer, dimension(:), intent(inout) :: terms 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 regress(typ, nterms, terms, loc, loctyp, locpos, & gene, genemod, allele_buffer, dataset, mlik, mpar, plevel) use alleles_class use ped_class integer, intent(in) :: typ integer, intent(in) :: nterms integer, dimension(:), intent(inout) :: terms 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 integer, intent(in) :: plevel end subroutine regress subroutine binreg(ilink, nterms, terms, 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 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, loc, loctyp, locpos, & gene, genemod, allele_buffer, & 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 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 ! 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, loctyp, locnotes, locnam, gene, genetyp, iter, mincnt, & norder, assfnd, gt, thresh, conibd, dataset, & freqfnd, use_fixfreq, fixfreq_buffer, allele_buffer2, & prevalence, pval, plevel, typ) use interrupt use outstream use popgen_vcdata use alleles_class use contingency_table use ped_class use locus_types integer, intent(in) :: trait integer, intent(in) :: loctyp character (len=*), intent(in) :: locnotes 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) :: plevel integer, intent(in) :: typ end subroutine doassoc subroutine hapassoc(nmark, markers, & loc, loctyp, locpos, 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(in) :: markers character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos 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 moskvina(window, alpha, maxhap, nloci, loc, loctyp, & locpos, locord, map, dataset, 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 integer, intent(in) :: plevel end subroutine moskvina 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, 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 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 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, toler) use interrupt use alleles_class use ped_class use ibd_class use AS319 implicit none character (len=10), intent(inout) :: tranam integer, intent(inout) :: trait character (len=10), 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 double precision, intent(in) :: toler end subroutine sibqtl subroutine varcom(modtyp, nterms, terms, loc, loctyp, locpos, & gene, genemod, allele_buffer, & nmark, mark, dataset, & mlik, mpar, pval, plevel, burnin, iter, typ, & approx, toler) use interrupt use outstream use alleles_class use ped_class use ibd_class use AS164_class use AS319 implicit none integer, intent(in) :: modtyp ! 1=Gaussian, 2=MFT integer, intent(in) :: nterms ! no. variables in model integer, dimension(:), intent(in) :: terms ! variable 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 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 logical, intent(in) :: approx double precision, intent(in) :: toler end subroutine varcom end interface interface subroutine nearloc(pos, thresh, maxcluster, nloci, loc, loctyp, & 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 double precision, dimension(:), intent(in) :: map ! genetic 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 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 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 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, 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 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 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 t0=time() initix=mod(t0,29282) if (t0 > 29282) then initiy=mod(t0/29282,29282) else initiy=mod(419*ix+6173,29282) end if initiz=mod(419*iy+6173,29282) ix=initix iy=initiy iz=initiz #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 NOESCAPE '|\/| Version : ', trim(version), & '|/\| Author : David L Duffy (c) 1995-2011', & #else '|\\/| Version : ', trim(version), & '|/\\| Author : David L Duffy (c) 1995-2011', & #endif '|||| Job run : ', fdate(), ' (', trim(datdir),')' write(outstr, '(a/)') & 'Type "help" for help, "quit" to quit, "ctrl-C" to interrupt.' #if WIN32 || OPEN64 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 imp=0 iter=200 jdraw=MISS ! Check the first argument on the command line call getarg(1, lin) hascmd=len_trim(lin) > 0 mapf=1 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 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.0D-6 tune=0.3 wrkdir=' ' if (prompt) call openlog(LSTR, logfil, nhis) ! ! intercept and act on SIGINT ! #if 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 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 hassex=.true. inline_input=.false. link=0 loconly=.false. inblock=0 numcmd=0 nwarn=0 red=.false. sexchek=.true. skipline=0 last_result=MISS t1=0.0 timer=0 use2=2 useimp=.false. zrec=1 ! ! main read-parse-eval loop ! ! Parse any command line arguments if (hascmd) then hascmd=.false. i=1 if (lin=='--help' .or. lin=='-h' .or. lin=='-?') then commands='help' ilevel=0 else if (lin=='--locus' .or. lin=='-l') then i=i+1 call getarg(i, lin) commands='loc "' // trim(lin) // '"' ilevel=0 else if (lin=='--include' .or. lin=='-i' .or. lin=='-f') then i=i+1 call getarg(i, lin) commands='inc "' // trim(lin) // '"' ilevel=0 else if (lin(1:1)=='-') then write(*,'(3a)') 'Command line flag "', trim(lin), '" not recognized.' else write(outstr, '(2a)') '-> ', lin(1:max(len_trim(lin), 72)) commands=lin ilevel=0 end if else ! check for an init file lin='sib-pair.ini' call findfile(lin, i) if (i /= 0) then commands='inc "' // trim(lin) // '"' ilevel=0 end if 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 write(*,'(/3a/)') 'Closing include file "',trim(infil(ilevel)),'".' close(incstr(ilevel), status='keep') 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 write(outstr,'(/2a/)') '-> ', lin(1:75) end if if (linlen == 0) cycle narg=maxwords call args(lin(1:linlen), narg, words, 1) 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(words(3), nloci, loc) 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).eq.'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).eq.'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).eq.'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).eq.'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).eq.'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(*,'(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 loc(nloci)=words(3) if (oldnam) then k=min(20, len_trim(loc(nloci))+1) loc(nloci)(k:k)='_' write(*,'(a/7x,3a/)') & 'WARNING: Locus is already declared or a reserved word.', & 'Changed name to "',loc(nloci)(1:k),'".' end if loctyp(nloci)=newtyp group(nloci)=' ' map(nloci)=MISS locnotes(nloci)=' ' if (narg > 4) then k=5 if (isreal(words(k))) then map(nloci)=fval(words(k)) k=k+1 end if i=wordpos(lin, k-1) locnotes(nloci)=lin(i:min(i+40,len_trim(lin))) call getchr(loc(nloci), locnotes(nloci), group(nloci)) 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 insert_lochash(trim(loc(nloci)), nloci, loc, lochash) 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')) then if (narg > 2) then if (narg > 3) then nwid=ival(words(3)) ndec=ival(words(4)) else ndec=ival(words(3)) end if if (nwid <= 0) then nwid=9 else if (nwid > 20) then nwid=20 end if 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/)') & 'NOTE: Number of decimal digits w.d w=', nwid, ' d=', ndec 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 ! 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 getword(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 getword(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 getword(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 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 ! set marker map else if (keyword == 'set' .and. keyw2 == 'map') then 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 if (mapf == 2) then write(outstr,'(/a/)') 'NOTE: Using Kosambi mapping function.' else write(outstr,'(/a/)') 'NOTE: Using Haldane mapping function.' 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 map(mark)=fval(words(5)) 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.' dist=dist+100.0d0 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 ! read map from file else if (keyword == 'rea' .and. keyw2 == 'map') then typ=1 if (narg == 2) then call fchooser(locfil, gui, plevel) else call getword(lin, 3, locfil) call concat(datdir, locfil) end if if (words(4)=='bp') typ=typ+1 if (words(4)=='kbp') typ=typ+2 call open_port(locfil, port, 'r', ioerr) if (ioerr == 0) then call make_lochash(nloci, loc, lochash) call readmap(port, typ, lin, words, plevel) call close_port(port, ioerr) else write(outstr,'(3a)') 'ERROR: File "', trim(locfil), '" not found.' end if ! read locus information else if (keyword == 'rea' .and. keyw2 == 'loc') then call args(lin, narg, words, 1) 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 if (words(3)(1:3) == 'lin') then call open_port(locfil, port, 'r', ioerr) if (ioerr == 0) then call rdlinloc(port, lin, words, nord, numloc) call close_port(port, ioerr) write(outstr,'(/a,i0,a)') & 'Read in names of ', nloci, ' loci from locus file.' 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 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) call rdmerloc(port, xlin, lin, nloci, loc, locpos, outpos, & loctyp, locnotes, numloc, twinning, twintype, & twintrait) call close_port(port, ioerr) call make_lochash(nloci, loc, lochash) write(outstr,'(/a,i0,a)') & 'Read in names of ', nloci, ' loci from locus file.' else write(outstr,'(3a)') 'ERROR: Unable to open "', trim(locfil), '".' end if 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 call setup_plink(port, i, j) call rdplink(port, typ, typ1, nloci, loc, locpos, outpos, & loctyp, locnotes, numloc, group, map) call close_port(port, ioerr) call make_lochash(nloci, loc, lochash) write(outstr,'(/a,i0,a)') & 'Read in names of ', nloci, ' loci from locus file.' 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 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(loc(nloci), nloci-1, loc) 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 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 ! 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 tmp=fval(words(3)) if (tmp > 0.0d0) then mthresh=int(tmp, kind=8) end if end if end if write(outstr, '(a,i0,a)') & 'Switch to file storage for genotype data when ', mthresh, ' genotypes.' ! ! 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 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) == 'nos') then hassex=.false. i=i+1 else if (words(i)(1:3) == 'nop') then link=4 i=i+1 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 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 ! ! readbin() and readbed() bypass usual input checks ! else if (keyword == 'rea' .and. & (keyw2 == 'bin' .or. keyw2 == 'pli')) 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') typ=typ+1 if (words(4)(1:3) == 'dat') typ=typ+2 call readbin(INSTRM, pedfil, wrkfil, typ, numloc, work, red, plevel) ! ! 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) lin='clear data; set loc trait aff; read ped ' // & trim(pedfil) // '.fam; ' // & 'run; merge plink ' // trim(pedfil) // ' ' // trim(words(4)) 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 getword(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 (plevel > 0) then call info(lin, burnin, imp, iter, initix, initiy, initiz, & ix, iy, iz, 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 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, 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) if (plevel >= -3) then write(outstr,'(a,i0,a)') 'Max record length is ', i, ' characters' end if if (link /= 3) then if (twinning /= MISS) then call gettrait(twintrait, LOC_ANY, 0, nloci, loc, lochash, loctyp, twinning, 0) if (twinning > 0) then write(outstr,'(a/)') 'Monozygotic twin pair error checking.' thresh=0.0d0 gt=16 if (twintype==2) gt=21 end if end if if (link == 4) then call readpeds(port, WRK, WRK2, skipline, link, unspecified, & twinning, gt, thresh, sexchek, hassex, nonextped, & numloc, coltyp, work, longnam, i, nwarn, plevel) else call readpeds(port, WRK, WRK2, skipline, link, unspecified, & twinning, gt, thresh, sexchek, hassex, nextped, & numloc, coltyp, work, longnam, i, nwarn, plevel) end if else call readcases(port, hassex, skipline, numloc, coltyp, & 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(sexcrit, sexmarker, nloci, loc, lochash, loctyp, locpos, & work, allele_buffer, inconsist, plevel) if (twinning /= MISS) then call gettrait(twintrait, LOC_ANY, 0, nloci, loc, lochash, loctyp, twinning, 0) if (twinning > 0) then write(outstr,'(a/)') 'Monozygotic twin pair error checking.' thresh=0.0d0 gt=16 if (twintype == 2) gt=21 call mzgtp(locpos(twinning), gt, thresh, & nloci, loc, loctyp, locpos, work, inconsist, -2) if (droperr > 0) then typ=4 call dropt2(locpos(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 check(.true., nloci, loc, loctyp, locpos, locnotes, 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,i5)') 'Number of warnings = ', nwarn end if write(outstr,'(a,i5)') 'Number of data problems = ', inconsist if (droperr > 0) then write(outstr,'(a,i5,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 (loconly) then loconly=.false. write(outstr,'(/3a/)') 'Closing include file "',trim(infil(ilevel)),'".' close(incstr(ilevel), status='keep') 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 ! else if (keyword == 'tes' .and. red) then if (narg==2 .and. words(2)=='sex') then call testsex(sexcrit, sexmarker, nloci, loc, lochash, loctyp, locpos, & work, allele_buffer, inconsist, plevel) 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) 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 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) else write(outstr,'(a)') 'ERROR: Need to specify quantitative trait for DOB.' end if else if (keyw2 == 'loc') then 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, work, droperr, & ndiscard, inconsist, plevel) else call check(.false., nloci, loc, loctyp, locpos, locnotes, work, droperr, & ndiscard, inconsist, plevel) end if else if (keyw2 == 'dup') then call mzfind(2, trait, nloci, loc, loctyp, locpos, work, plevel) else if (narg == 3) then call genmatch(words(2)(1:ped_width), words(3)(1:id_width), & nloci, loc, loctyp, locpos, work) 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. twinning /= MISS) then call gettrait(twintrait, LOC_ANY, 0, nloci, loc, lochash, loctyp, trait, 0) end if if (typ == 5) then call mzfind(1, trait, nloci, loc, loctyp, locpos, 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 person 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 write(outstr,'(/a/3a/)') & 'Extracting unrelated cases from pedigrees.', & 'Subjects must be nonmissing for "', trim(loc(trait)), '".' call wricas(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, 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, 1) i=i-1 end if call joinped(wrk, wrk2, 1, i, narg, words, & nloci, loc, locpos, loctyp, locnotes, 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 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, 2) 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') 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 if (words(4)(1:2) == 're') then typ=2 write(outstr,'(/3a)') & 'Replacing value of "', trim(loc(trait)), '" with nonparametric residual.' end if call prodlim(locpos(trait), locpos(prob), work, typ, 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 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, loc, loctyp, locpos, locnotes, & work, nwid, ndec, mlik(whlik), mpar(whlik), pval, plevel) else typ=4 call setup_stat(lin) if (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, work, allele_buffer, pval, plevel) locstat(i)=pval end if end do end if else write(outstr,'(/a)') 'ERROR: quantitative trait or covariate misspecified.' 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 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 tmp=dfloat(time())/86400d0 + 2440588d0 - epoch write(outstr,'(/a,i9,a,i9)') & 'Date: ', int(togreg(tmp+epoch)), ' = ', 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, 0, 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(loc(trait), locpos(trait), work, typ) 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 outfil=words(4) if (narg == 4) words(5)=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 Sib-pair type script: ', trim(outfil) end if call sibloci(ostr, nloci, loc, loctyp, outpos, map, locnotes) write(OSTR,'(2a/a)') 'read pedigree ', words(5), 'run' else if (words(3)(1:3) == 'mer') then outfil=words(4) 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 (twinning /= MISS) 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)) 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 outfil=words(4) 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 i=5 if (words(3)(1:3) == 'sup') i=8 write(OSTR,'(i5,4i3/a)') nmark, 0, xlin, i, 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, ' # ', 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, ' # ', 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))') 0.0, 0.0 end do end if end do write(OSTR,'(a)') '0 0' if (words(3)(1:3) /= 'mli') then call wrmap(OSTR, typ, mapf, nloci, loc, loctyp, locnotes, & nord, locord, group, map) 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,i3)') '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 else if (words(3)(1:3) == 'sag') then outfil=words(4) 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 else if (words(3)(1:3) == 'mor') then outfil=words(4) 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, nloci, loc, loctyp, locnotes, & nord, locord, group, map) 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 outfil=words(4) 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, nloci, loc, loctyp, locnotes, nord, & locord, group, map) else if (words(3)(1:3) == 'lok') then outfil=words(4) 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' 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 outfil=words(4) 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 else if (words(3)(1:3) == 'men') then outfil=words(4) ! 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 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 elseif (words(3)(1:3) == 'str') then if (narg == 4) then outfil='mainparams' else outfil=words(5) 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 outfil=words(4) 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 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 outfil=words(4) 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 call wrmap(OSTR, typ, mapf, nloci, loc, loctyp, locnotes, nord, locord, & group, map) close(ostr, status='keep') else if (words(3)(1:3) == 'mer') then outfil=words(4) 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, nloci, loc, loctyp, locnotes, nord, locord, & group, map) close(OSTR,status='keep') else if (words(3)(1:3) == 'lok') then outfil=words(4) 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, nloci, loc, loctyp, locnotes, nord, locord, & group, map) close(OSTR, status='keep') else if (words(3)(1:3) == 'sol') then outfil=words(4) 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, nloci, loc, loctyp, locnotes, nord, locord, & group, map) close(OSTR, status='keep') else if (words(3)(1:3) == 'pli') then outfil=words(4) 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, nloci, loc, loctyp, locnotes, nord, locord, & group, map) 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 outfil=words(4) if (outfil == ' ') outfil='mendel.var' else outfil=words(3) 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, nloci, loc, loctyp, locnotes, nord, locord, & group, map) close(OSTR,status='keep') ! 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, & misval, 0, 0, 1, & nloci, loc, loctyp, locpos, work) else if ((narg == 3 .or. narg == 4) .and. keyw2 == 'bin') then outfil=words(3) 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') .or. & keyw2 == 'sib' .or. keyw2 == 'ped' .or. keyw2 == 'gas') then if (narg == 2) then outfil=words(2) else outfil=words(3) 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, map, locnotes) write(OSTR,'(a)') 'read pedigree inline' end if call pedout(OSTR, header, pedmask, tabsep, allsep, imp, nwid, ndec, & misval, 0, 0, 1, & nloci, loc, loctyp, locpos, work) if (keyw2 == 'sib') then write(OSTR,'(a/a)') ';;;;', 'run' end if close(OSTR, status='keep') else if (keyw2=='men' .or. keyw2 == 'fis') then outfil=words(3) 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 (twinning /= MISS) then call gettrait(twintrait, LOC_ANY, 0, nloci, loc, lochash, loctyp, twinning, 0) if (twinning>0) twinning=locpos(twinning) end if if (typ == 10) then call wrcsv(OSTR, typ, imp, nwid, ndec, fieldsep, allsep, cmisval, & twinning, twintype, nloci, loc, loctyp, locpos, & 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 outfil=words(3) 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 outfil=words(3) call gettrait(words(4), LOC_AFF, 0, nloci, loc, lochash, loctyp, trait, 0) call gettrait(words(5), LOC_CODOM, LOC_XLIN, nloci, loc, lochash, loctyp, gene, 0) if (trait /= MISS) trait=locpos(trait) if (gene /= MISS) gene=locpos(gene) 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, allsep, & trim(words(6)), trim(words(7)), trim(words(8)), 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 outfil=words(3) 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 (twinning /= MISS) then call gettrait(twintrait, LOC_ANY, 0, nloci, loc, lochash, loctyp, twinning, 0) if (twinning > 0) 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 outfil=words(3) 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='.' else typ=1 fieldsep=',' cmisval=' ' end if if (narg>3) fieldsep=words(4)(1:1) if (narg>4) cmisval=words(5)(1:3) outfil=words(3) 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 (twinning /= MISS) then call gettrait(twintrait, LOC_ANY, 0, nloci, loc, lochash, loctyp, twinning, 0) if (twinning>0) twinning=locpos(twinning) end if call wrcsv(OSTR, typ, imp, nwid, ndec, fieldsep, allsep, cmisval, & twinning, twintype, nloci, loc, loctyp, locpos, & 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 outfil=words(3) 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: ', outfil end if end if if (twinning /= MISS) then call gettrait(twintrait, LOC_ANY, 0, nloci, loc, lochash, loctyp, twinning, 0) if (twinning>0) twinning=locpos(twinning) end if call wrcsv(OSTR, typ, imp, nwid, ndec, fieldsep, allsep, cmisval, & twinning, twintype, nloci, loc, loctyp, locpos, & nord, locord, work) close(OSTR, status='keep') else if (keyw2 == 'mor') then outfil=words(3) 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') else if (keyw2 == 'snp' .or. keyw2 == 'roa') then outfil=words(3) 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 (plevel > -2) then write(outstr,'(/2a)') 'Writing SNP-major genotype file: ', trim(outfil) if (trait /= MISS) then write(outstr,'(3a)') & 'Data for individuals phenotyped at "', trim(loc(trait)), '".' end if end if if (trait /= MISS) then trait=locpos(trait) end if call wrsnp(OSTR, trait, nloci, loc, loctyp, locpos, work) close(OSTR, status='keep') else if (keyw2 == 'arl') then outfil=words(3) 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 outfil=words(3) 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, nloci, loc, loctyp, locnotes, nord, locord, & group, map) call wrprd(OSTR, typ, trait, nloci, loc, loctyp, locpos, work) close(OSTR, status='keep') elseif (words(2)(1:3) == 'bea') then outfil=words(3) 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) outfil=words(3) call extprefix(outfil, '.bed') call gettrait(words(4), LOC_TRA, 0, nloci, loc, lochash, loctyp, trait, 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 end if if (trait /= MISS) trait=locpos(trait) call wrbed(OSTR, outfil, trait, allele_buffer, work) elseif (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 write(outstr,'(a)') 'ERROR: Pedigree file type not supported.' end if else if (keyword == 'hea' .or. keyword=='tai') then nrc=10 if (keyw2 == 'map') then j=1 if (narg > 2) nrc=max(1, ival(words(3))) k=min(nloci, nrc) if (keyword=='tai') then j=max(1,nloci-nrc) k=nloci end if do i=j, k if (map(i) /= MISS) then write(outstr, '(a14,1x,f12.6,1x,a2)') loc(i), map(i), group(i) else write(outstr, '(a14,6x,a,7x,a2)') loc(i), 'x', group(i) end if end do else if (keyw2 == 'loc') then if (narg > 2) nrc=max(1, ival(words(3))) nord=min(nloci, nrc) j=1 if (keyword=='tai') j=max(1,nloci-nrc+1) do i=1, nord locord(i)=j j=j+1 end do call listloci(nord, locord, nloci, loc, loctyp, outpos, locnotes, & 1, plevel) else if (red) then 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, misval, nrc, & skipline, 1, nloci, loc, loctyp, locpos, work) else write(outstr,'(a)') 'ERROR: Too many columns of data to view.' 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, misval, nrc, & skipline, 1, nloci, loc, loctyp, locpos, 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, initix, initiy, initiz, & ix, iy, iz, 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, work, -1) ! Fine grained summaries else if (keyword == 'sho') then if (keyw2 == 'map') then call loadnam(3, narg, words, nloci, loc, lochash, loctyp, group, map, & locstat, wloc, nord, locord, LOC_ANY, 3) call wrmap(0, 10, mapf, nloci, loc, loctyp, locnotes, nord, locord, & group, map) else if (keyw2 == 'chr') then call listchroms(nloci, loctyp, 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(work, 1) end if else if (keyw2(1:2) == 'id') then typ=1 if (narg > 2) then if (words(3)(1:3) == 'dup') then typ=2 else if (isint(words(3))) then typ=ival(words(3)) end if end if call listids(work, typ, plevel) 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, loc, lochash) call show_locus_allocation() call show_ped_allocation(work) else if (keyw2 == 'snp') then call show_snp(ival(words(3)), ival(words(4)), work) else if (keyw2 == 'loc') then call actped(2, red, pedfil, nloci, loc, loctyp, locpos, & outpos, locnotes, wloc, work, plevel) else if (keyw2 == 'mis') then call actped(4, red, pedfil, nloci, loc, loctyp, locpos, & outpos, locnotes, wloc, work, plevel) else if (twinning /= MISS) then call gettrait(twintrait, LOC_ANY, 0, nloci, loc, lochash, loctyp, twinning, 0) 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, work, plevel) end if else if (keyword == 'typ') then if (narg == 1) then typ=2 if (plevel < 2) typ=3 call actped(typ, red, pedfil, nloci, loc, loctyp, locpos, & outpos, locnotes, wloc, work, plevel) else call gettrait(words(2), LOC_ANY, 0, nloci, loc, lochash, loctyp, trait, 0) if (trait /= MISS) then call setup_stat(lin) 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 if (narg == 1) then typ=6 else if (keyw2(1:2) == 'Al') then typ=1 else if (keyw2(1:1) == 'G') then typ=2 else if (keyw2(1:1) == 'O') then typ=3 else if (keyw2(1:1) == 'D') then typ=4 else if (keyw2(1:2) == 'An') then typ=5 else if (keyw2(1:2) == 'Ex') 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 batches ',nbatch 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=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 (narg > 2) mfteval=ival(words(3)) if (narg > 3) abseps=fval(words(4)) if (narg > 4) releps=fval(words(5)) if (mfteval <= 0) mfteval=2000 if (abseps <= 0.0d0) abseps=5.0d-5 if (plevel > -1) then write(outstr,'(/a,i0,a/15x,a,g9.4/15x,a,g9.4/)') & 'NOTE: MVN cdf evaluations ', mfteval, ' * NDIM.', & 'Absolute err ', abseps, & 'Relative err ', releps 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=fval(words(3)) if (toler <= 0.0d0) toler=1.0d-6 if (plevel > -1) then write(outstr,'(/a,f9.4/)') 'NOTE: Convergence criterion ', toler end if else if (keyword == 'set' .and. keyw2 == 'inv') then if (narg > 2) then approx=(words(3)(1:3) == 'gib') end if if (plevel > -1) then if (approx) then write(outstr,'(/a/)') 'NOTE: Using approximate matrix inversion.' 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 == '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 ix=ival(words(3)) iy=ival(words(4)) iz=ival(words(5)) if (iy == 0) iy=ix if (iz == 0) iz=iy initix=ix initiy=iy initiz=iz end if if (plevel > -1) then write(outstr,'(a,3(1x,i5)/)') 'Seeds for RNG (AS183)=',ix,iy,iz 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 (fval(words(3)) > 0.0d0) then sexcrit=fval(words(3)) end if write(outstr,'(/a,f6.4/)') & 'NOTE: Threshold for marker diagnosis of sex ', sexcrit 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 end if else fixfreq=MISS fixmarker='' write(outstr,'(3a)') 'Marker allele frequencies for "', & trim(fixmarker), '" no longer prespecified.' 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 do i=1, nloci wloc(i)=0 if (group(i) /= ' ') then do j=4, narg if (group(i) == words(j)) then wloc(i)=1 exit end if end do end if end do else if (plevel > 1) then write(outstr,'(3a)') 'Searching for loci annotated "', trim(words(3)), '".' end if words(3)='*' // trim(words(3)) // '*' nord=0 do i=1, nloci wloc(i)=0 if (strfind(words(3), locnotes(i), 1)) then nord=nord+1 locord(nord)=i wloc(i)=1 end if end do 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, plevel) else do i=1, nord write(words(1), '(i10)') locord(i) 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, 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 getword(lin, i, wrkfil) call delfile(wrkfil, plevel) end do 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 else if (keyw2 == 'que') then do i=3, narg call getword(lin, i, wrkfil) inquire(file=wrkfil, exist=filexist) if (filexist) then write(outstr, '(3a)') & 'File "', trim(wrkfil), '" exists.' else write(outstr, '(3a)') & 'Unable to access file "', trim(wrkfil), '".' end if end do else if (keyw2 == 'fie' .or. keyw2 == 'wc') then do i=3, narg call getword(lin, i, wrkfil) call countfields(wrkfil, plevel) end do else if (keyw2 == 'cat') then do i=3, narg call getword(lin, i, wrkfil) call cat(wrkfil) end do write(outstr,*) else if (keyw2 == 'hea') 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 getword(lin, n, wrkfil) call head(wrkfil, j) else do i=3, n call getword(lin, i, wrkfil) write(outstr,'(/3a/)') '"', trim(wrkfil), '":' call head(wrkfil, j) end do end if else if (keyw2 == 'pri') then call fprinter(narg, words, lin, plevel) else write(outstr,'(a)') 'File operation not supported' 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 getword(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 (ilevel > 0 .and. ilevel < NSTRM) then ilevel=ilevel+1 if (narg == 1) then call fchooser(infil(ilevel), gui, plevel) else call getword(lin, 2, infil(ilevel)) end if open(incstr(ilevel), file=infil(ilevel), iostat=ioerr, status='old') if (ioerr == 0) then write(outstr,'(/3a)') 'Reading commands from "', trim(infil(ilevel)),'".' loconly=(keyword == 'loc') else write(*,'(/3a/)') 'ERROR: Unable to open "', trim(infil(ilevel)), '".' ilevel=ilevel-1 end if else write(*,'(/a/7x,a,i0,a/)') & 'ERROR: Cannot further nest "include" or "locus" commands.', & 'Nesting level=', ilevel, '.' end if 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 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 == '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.' 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' .and. narg > 2) then call gettrait(words(2), LOC_ANY, 0, nloci, loc, lochash, loctyp, trait, 0) oldnam=isinuse(words(narg), nloci, loc) 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) else if (oldnam) then write(outstr,'(3a)') 'ERROR: "', trim(words(narg)),'" in use or reserved.' 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 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 (same_loctyp(loctyp(i), typ1) .or. & same_loctyp(loctyp(i), typ2)) 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 (same_loctyp(loctyp(i), typ1) .or. & same_loctyp(loctyp(i), typ2)) 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 ! via frequency of commonest allele else if (words(3)(1:3) == 'max') then i=4 call docomp(i, words, gt, hival) if (gt == 0) then hival=fval(words(4)) gt=17 if (typ == 2) gt=gt+1 end if write(outstr,'(/2a,f6.4/)') & 'Selecting markers with max allele freq', compsign(gt), hival do i=1, nloci wloc(i)=0 if (same_loctyp(loctyp(i), typ1) .or. & same_loctyp(loctyp(i), typ2)) 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 ! 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=17 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*dfloat(ntyped)) end if if (words(3)(1:3) == 'mis') then write(outstr,'(/2a,i0,a/)') 'Selecting loci with ', compsign(gt), & ntyped, ' missing values.' else write(outstr,'(/2a,i0,a/)') 'Selecting loci with ', compsign(gt), & ntyped, ' observed values.' end if do i=1, nloci if (isaff(dfloat(wloc(i)), dfloat(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_ANY, 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=17 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') then if (narg > 3) then write(outstr,'(/a)', advance='no') & 'Selecting markers on chromosome' do j=4, narg write(outstr,'(1x,a)', advance='no') trim(words(j)) end do write(outstr,*) do i=1, nloci wloc(i)=0 if ((same_loctyp(loctyp(i), typ1) .or. & same_loctyp(loctyp(i), typ2)) .and. & group(i) /= ' ') then do j=4, narg if (group(i) == words(j)) then if (plevel > 0) then write(outstr,'(4a)') & 'Selected ', trim(loc(i)), 'on chr ', group(i) end if wloc(i)=1 exit end if end do end if end do else write(outstr,'(a)') & 'ERROR: Need to specify a chromosome name.' end if ! via a specified map position else if (words(3)(1:3) == 'pos') then loval=fval(words(4)) hival=fval(words(5)) if (hival >= loval) then write(outstr,'(/a)', advance='no') & 'Selecting markers in map interval ' write(outstr,*) loval, 'to', hival do i=1, nloci wloc(i)=0 if (same_loctyp(loctyp(i), typ1) .or. & same_loctyp(loctyp(i), typ2) .and. & map(i) /= MISS) then if (map(i) >= loval .and. map(i) <= hival) then if (plevel > 0) then write(outstr,'(3a,f9.3)') & 'Selected ', trim(loc(i)), ' on position ', map(i) end if wloc(i)=1 end if end if end do else write(outstr,'(a)') & 'ERROR: Need to specify a lower and upper map position.' end if ! 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 ((same_loctyp(loctyp(i), typ1) .or. & same_loctyp(loctyp(i), typ2)) .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 thresh=fval(words(4)) write(outstr,'(a)', advance='no') 'Selecting markers so intermarker r2 <' write(outstr,*) thresh do pos=1, nloci wloc(pos)=0 if (same_loctyp(loctyp(pos), typ1) .or. & same_loctyp(loctyp(pos), typ2)) then wloc(pos)=1 exit end if end do j=pos+1 do while (j <= nloci) wloc(j)=1 if (same_loctyp(loctyp(j), loctyp(pos))) then call freq(locpos(j), loctyp(j), fndr, work, allele_buffer2) nmark=0 do i=pos, 1, -1 if (wloc(i) == 1) 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 end if if (nmark > 20) exit ! avoid too exhaustive comparison end if end do end if if (wloc(j) == 1) then pos=j if (plevel > 0) then write(outstr,'(5a,f9.3)') & 'Selected "', trim(loc(j)), '" with intermarker r2 to "', & trim(loc(i)), '" of ', pval end if end if j=j+1 end do if (typ == 2) then do i=1, nloci if (loctyp(i) == loctyp(pos)) then wloc(i)=1-wloc(i) end if end do end if ! every Nth locus else if (words(3)(1:3) == 'eve' .and. ival(words(4)) > 0) 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 ! HWD or association test P-value else if (words(3)(1:3) == 'tes' .or. words(3)(1:3) == 'hwe') 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 (pcrit > 0.0d0 .and. pcrit < 1.0d0) then if (words(3)(1:3) == 'hwe') then write(outstr,'(2a)', 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 DO 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, -2) 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 PARALLEL DO else write(outstr,'(2a)', advance='no') & 'Selecting markers where test P-value ', compsign(gt) write(outstr,*) pcrit call selstat(' P-value', 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 getword(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) call readnames(port, nloci, loc, lochash, wloc) 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 words(3)='*' // trim(words(3)) // '*' do i=1, nloci wloc(i)=0 if (strfind(words(3), locnotes(i), 1)) then wloc(i)=1 end if end do 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=1, nloci if (mod(loctyp(i), LOC_CMP) < LOC_DEL) then loctyp(i)=loctyp(i)+LOC_DEL end if end do do i=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=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=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.' 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, loc, loctyp, locpos, & gene, genemod, allele_buffer, 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_AFF, LOC_QUA, 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) 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) 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 if (words(2) == 'snp') then typ=2 narg=4 words(2)='$m' words(3)='$x' words(4)='$h' write(outstr,'(/a/a)') & 'Marker NAll Allele(s) Freq Het Ntyped', & '-------------- ---- ----------- ------ ------ ------' 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) call wrfreq(wrk2, loc(j), group(j), map(j), & locnotes(j), allele_buffer, typ) 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) end if end if end do ! 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 call dopeel(typ, locpos(gene), trait, emiter, mcmc_buffer, work, 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 call dopeel(typ, locpos(gene), trait, emiter, allele_buffer, work, 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), gcode) end do do i=1, nf recfro(i)=aval(words(2+i), gcode) 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,'(/3a)') & '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,'(/3a)') & '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) == '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 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) else if (loctyp(trait) == LOC_CAT) then loctyp(trait)=LOC_AFF 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' .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 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), work) end if end if end do ! If diallelic marker, swap alleles else if (keyword == 'swa' .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 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 swapalleles(loc(trait), locpos(trait), allele_buffer, work) end if end if end do ! 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 call recode(loc(trait), locpos(trait), loctyp(trait), & 1, 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 ! ! 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) call gettrait(words(3), LOC_QUA, 0, nloci, loc, lochash, loctyp, trait, 0) typ=1 if (words(4)(1:3) == 'fam') typ=2 if (keyword == 'blo') typ=typ+2 if (trait /= MISS .and. 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') 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,'.' end if call mktmpfil(OSTR, pedfil, wrkdir, ioerr) if (ioerr == 0) then call simdata(OSTR, nped, ngen, nminoff, nmaxoff, numloc(TCLASS)) close(OSTR, status='keep') inline_input=.true. else write(outstr,'(a)') 'ERROR: Unable to create new pedigree file!' pedfil=' ' 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 (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' .and. red) then if (narg == 1) then call hashids(1, work, hashtab, 80, 1) else if (narg == 2) then if (keyw2 == 'sho') then call hashprint(hashtab, work, loc, plevel) else if (keyw2 == 'del') then if (plevel > 0) then write(outstr,'(a)') 'Hash table deleted.' end if call cleanup_hash(hashtab) else call getword(lin, narg, wrkfil) call open_port(wrkfil, port, 'r', ioerr) if (ioerr == 0) then call findids(port, lin, hashtab, work, plevel) else write(*,'(/3a/)') & 'ERROR: Problem opening ID file "', trim(wrkfil), '".' end if end if else if (keyw2 == 'siz') then call hashids(1, work, hashtab, ival(words(3)), 1) else if (narg == 3) then if (words(2) == 'id') 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) else if (words(2) == 'loc' .or. words(2) == 'locus') then if (.not.lochash%current) then call make_lochash(nloci, loc, lochash) end if call find_hashtab(trim(words(3)), 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 else if (words(2)(1:3) == 'sho' .or. words(3)(1:3) == 'loc') then call hashprint(lochash, work, loc, 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 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 else if ((keyword == 'upd' .or. keyword == 'mer') .and. red) then if (keyword == 'mer' .and. & (words(2) == 'pli' .or. words(2) == 'plink')) then call getword(lin, 3, wrkfil) call extprefix(wrkfil,'.bed') typ=1 if (words(4)(1:3) == 'com') typ=typ+1 call hashids(1, work, hashtab, 80, plevel) call readbed(TWRK, typ, wrkfil, hashtab, work, plevel) call make_lochash(nloci, loc, lochash) else if (words(2) == 'gen' .or. words(2) == 'geno' .or. & words(2) == 'genotypes') then call getword(lin, 3, wrkfil) skipline=1 if (narg > 3) skipline=ival(words(4)) call open_port(wrkfil, port, 'r', ioerr) if (ioerr == 0) then call readgeno(port, skipline, hashtab, work, plevel) call close_port(port, ioerr) else write(*,'(/3a/)') 'ERROR: Problem opening "', trim(wrkfil), '".' end if else if (words(2) == 'pro' .or. words(2) == 'probs' .or. & words(2) == 'probabilities') then call getword(lin, 3, wrkfil) call gettrait(words(4), LOC_QUA, 0, nloci, loc, lochash, loctyp, trait, 0) if (trait /= MISS) then call open_port(wrkfil, port, 'r', ioerr) if (ioerr == 0) then typ=1 if (words(5) == '5' .or. words(5)(1:3) == 'mac') typ=typ+1 call reclen(port, lin, i) call readprobs(port, typ, locpos(trait), i, work, plevel) call close_port(port, ioerr) else write(*,'(/3a/)') 'ERROR: Problem opening "', trim(wrkfil), '".' end if else write(*,'(/a/)') 'ERROR: Need to specify variable containing merge key.' end if else typ=1 if (keyword == 'mer') typ=typ+1 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 getword(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) call replacedata(port, typ, 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 call selped(typ, i, narg, words, work, plevel) ! ! print data for selected pedigree or individual ! else if (keyword == 'pri' .and. red .and. keyw2 == 'ped') then if (narg == 2) then call listpeds(work, 2) else i=narg+2 do j=3, narg if (words(j) == 'id') then i=j+1 end if end do call showdata(3, i, narg, words, nloci, loc, loctyp, locpos, & work, pedmask, nwid, ndec, misval, & tabsep, allsep, pstyle) 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, 2) 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 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 typ=3 if (.not.red) then typ=2 else if (keyw2 == 'ped') then typ=1 else if (keyw2 == 'loc') then typ=2 end if call packer(typ, red, wrk, wrk2, nloci, loc, loctyp, locpos, group, map, & locnotes, work, plevel) if (typ /= 2) hashtab%current=.false. if (typ /= 1) then call make_lochash(nloci, loc, lochash) if (twinning /= MISS) 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 end if call args(lin, narg, words, 2) i=2 if (keyw2 == 'whe') i=i+1 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, wtyp, wtag, expr, & work, pedmask, nwid, ndec, misval, & tabsep, allsep, pstyle, plevel) end if ! get summary of trait values of a given class of relatives of ego else if ((keyword == 'get') .and. red) then call gettrait(words(4), LOC_QUA, LOC_AFF, nloci, loc, lochash, loctyp, trait, 1) if (trait /= MISS) then gene=MISS if (narg > 4) then call gettrait(words(narg), LOC_QUA, LOC_AFF, nloci, loc, lochash, loctyp, gene, 1) end if write(outstr, '(/5a)') & 'Trait values in relatives for "', trim(loc(trait)), & '" summarized as "', trim(words(3)),'".' if (gene /= MISS) then write(outstr, '(3a)') & 'Storing summary statistic in variable "', trim(loc(gene)),'".' gene=locpos(gene) end if call getrelval(keyw2, words(3)(1:3), loc(trait), loctyp(trait), & locpos(trait), gene, work, plevel) else write(outstr,'(a)') 'ERROR: Need to specify relationship, statistic, trait.' end if ! Test mixture of distributions for quantitative trait else if ((keyword == 'mix' .or. keyword == 'his') .and. red) then call gettrait(words(2), LOC_QUA, 0, nloci, loc, lochash, loctyp, trait, 1) if (trait /= MISS) then histcat=21 nmix=ival(words(3)) if (keyword == 'his') then if (nmix > 0) histcat=nmix nmix=1 outfil='sib-pair.eps' if (narg == 4) outfil=words(4) else if (nmix < 1 .or. nmix > 5) 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 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 ! Means and correlations for traits else if ((keyword == 'mea' .or. keyword == 'cor') .and. red) then call loadnam(2, narg, words, nloci, loc, lochash, loctyp, & group, map, locstat, wloc, nord, locord, LOC_ANY, 1) call docov(1, nord, locord, loc, loctyp, locpos, work) ! 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(2, nord, locord, 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 ! Family based age imputation else if (keyword == 'imp' .and. narg==2 .and. red) then 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 ! 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 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, loc, loctyp, locpos, & gene, genemod, allele_buffer, work, & mlik(whlik), mpar(whlik), max(0, plevel)) else if (typ == 1000) then whlik=3-whlik call clreg(1, cltyp, nord, locord, loc, loctyp, locpos, & gene, genemod, allele_buffer, work, & mlik(whlik), mpar(whlik), statval, pval, plevel) else if (typ >= 4 .and. typ <= 8) then typ=typ-2 whlik=3-whlik ! ! 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, 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(dfloat(n)) if (n > 1) then meanp=meanp/dfloat(n) varstat=varstat/dfloat(n-1) withinvar=withinvar/dfloat(n) df=int(dfloat(n-1)*(1.0d0+withinvar/(varstat*(1.0d0+1.0d0/dfloat(n))))**2) varstat=(1.0d0+1.0d0/dfloat(n))*varstat + withinvar if (plevel > 0) then write(outstr,'(3(/a,g12.4)/a,i6)') & '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, 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, loc, loctyp, locpos, & gene, genemod, allele_buffer, work, & mlik(whlik), mpar(whlik), 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, 0) 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) outfil=words(i) 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') .and. red) then typ=1 if (keyword == 'kru' .and. narg >= 3) then call gettrait(words(2), LOC_QUA, 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, nord, locord, 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(locpos(trait), loctyp(trait), locnotes(trait), & work, nwid, ndec, plevel) end if else call listpeds(work, 1) end if else if (narg > 1) then call loadnam(2, narg, words, nloci, loc, lochash, loctyp, group, map, & locstat, wloc, nord, locord, LOC_ANY, 1) if (nord > 0) then call xtab(typ, nord, locord, 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, nmark, wloc, loc, locpos, loctyp, & locnotes, work, iter, nwid, ndec, pval, plevel) end if end do end if ! log linear model else if (keyword == 'llm' .and. red) then whlik=3-whlik call args(lin, narg, words, 2) call fitloglin(2, narg, words, nloci, loc, 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, 0, 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 write(outstr,'(/a/4a/a)') & '------------------------------------------------', & 'Relatives of index ', trim(words(2)), '--', trim(words(3)), & '------------------------------------------------' 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 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(i), iter, mincnt, assfnd, & norder, work, pval, plevel) locstat(j)=pval if (plevel > 0) then 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)) call ldp(numal, numal2, plevel) else if (red) then write(outstr,'(/a/a/a/)') & '---------------------------------------------------', & 'Inter-marker allelic association analysis', & '---------------------------------------------------' typ=3 if (narg == 2 .and. keyw2 == 'all') then typ=typ+1 else if (narg == 2 .and. keyw2 == 'r2') then typ=11 else if (narg == 2 .and. keyw2 == 'dpr') then typ=12 else if (narg > 3) then typ=100 else call gettrait(words(2), LOC_CODOM, LOC_XLIN, nloci, loc, lochash, loctyp, trait, 1) call gettrait(words(3), 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, 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) 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, 0, 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, typ, -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 ! 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=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, 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 call popgen_init() 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, nmark, wloc, 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 call setup_stat(lin) !$OMP PARALLEL DO do i=1, nloci if (isactdip(loctyp(i)) .and. irupt == 0) then call doassoc(locpos(trait), loctyp(trait), locnotes(trait), & loc(i), locpos(i), loctyp(i), & iter, mincnt, norder, assfnd, gt, thresh, & conibd, work, 0, .false., fixfreq_buffer, allele_buffer2, & prevalence, pval, plevel, typ) locstat(i)=pval end if end do !$OMP END PARALLEL DO 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 ! 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 typ=1 ! 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 == '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 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) 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.' 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) 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 write(outstr,'(/a/a)') & 'Marker 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 !$OMP PARALLEL DO 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 PARALLEL DO else if (typ /= 10) then !$OMP PARALLEL DO do i=1, nloci if (isactdip(loctyp(i)) .and. irupt == 0) then call doassoc(locpos(trait), loctyp(trait), locnotes(trait), & loc(i), locpos(i), loctyp(i), & iter, mincnt, norder, assfnd, gt, thresh, & conibd, work, fndr, (i == fixfreq), & fixfreq_buffer, allele_buffer2, & prevalence, locstat(i), 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 PARALLEL DO ! SNP type output (odds ratios) else 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, loc, loctyp, locpos, off, censor, & i, genemod, allele_buffer, mcp, useimp, fixshape, & iter, mincnt, work, shap, mlik(whlik), & mpar(whlik), statval, pval, -1) locstat(i)=pval tmp=1.96d0*sqrt(statval(3)) write(outstr,'(a14,a1,f8.3,a1,f8.3,a,f8.3,a1,g10.4,a1,a22)') & loc(i), 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 end if 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 !$OMP PARALLEL DO 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 !$OMP END PARALLEL DO else !$OMP PARALLEL DO 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, iter, mincnt, work, & locstat(i), plevel, typ) end if end do !$OMP END PARALLEL DO 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 call haploid_ass(trait, nord, locord, loc, locpos, loctyp, & locnotes, iter, mincnt, work, pval, plevel, typ) 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) 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 ! 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) 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 call getbin(2, narg, words, nloci, loc, lochash, loctyp, trait, gt, thresh) 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) trait=locpos(trait) call mulhom(trait, gt, thresh, xlinkd, iter, mincnt, & nloci, loc, loctyp, locpos, map, work, plevel) else write(outstr,'(/a/a/a)') & '----------------------------------------------------', & 'Overall marker homozygosity in all typed individuals', & '----------------------------------------------------' call globhom(work, 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 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 (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 == 6) then call doinbred(iter, work, trait, plevel) else if (typ < 5 .or. typ == 9) then call dokin(typ, work, trait) else if (typ == 5) then call casekin(loc(trait), locpos(trait), gt, thresh, work, statval, 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') 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 call ibskin(typ, trait, gt, thresh, nloci, loc, loctyp, locpos, work, plevel) 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/a,a10,a/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) 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) 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, 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, & map, nmarklist, marklist, plevel) if (nmarklist > 0) then if (nord > 1) then call regress(-1, nord, locord, loc, loctyp, locpos, & gene, genemod, allele_buffer, work, & mlik(whlik), mpar(whlik), plevel) end if whlik=3-whlik call varcom(modtyp, nord, locord, loc, loctyp, locpos, & gene, genemod, allele_buffer, nmarklist, marklist, work, & mlik(whlik), mpar(whlik), pval, & plevel, burnin, iter, typ, approx, toler) locstat(i)=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) outfil=words(narg) call qqplot(outfil) else if (narg > 2) outfil=words(narg) call sumplot(outfil) end if else if (keyw2 == 'tab') then call tabstat(plevel) 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 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 typ=2 th1=fval(words(4)) if (th1 < 0.0d0) th1=0.0d0 if (th1 > 0.5d0) th1=0.5d0 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 call freq(locpos(gene), loctyp(gene), fndr, work, allele_buffer2) 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 if ibd matrix in script) ! 7=CQE ! 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 == 'aqe' .or. keyword == 'AQE') then typ=5 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 if (words(i+1)=='inline') then typ=6 else write(outstr,'(3a)') & 'Skipping "', trim(words(i+1)), '": not an active marker.' 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 ! 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 if (nord > 1) then call regress(-1, nord, locord, loc, loctyp, locpos, & gene, genemod, allele_buffer, work, & mlik(whlik), mpar(whlik), plevel) end if call varcom(modtyp, nord, locord, loc, loctyp, locpos, & gene, genemod, allele_buffer, nmarklist, marklist, & work, mlik(whlik), mpar(whlik), pval, & plevel, burnin, iter, typ, approx, toler) else write(outstr,'(a)') 'ERROR: Need to specify trait.' end if else if (keyword == 'blu' .and. red) then call gettrait(words(2), LOC_ANY, 0, nloci, loc, lochash, loctyp, trait, 0) if (trait /= MISS) then gt=0 thresh=MISS if (same_loctyp(loctyp(trait), LOC_CODOM)) then call gettrait(words(3), LOC_QUA, LOC_AFF, & nloci, loc, lochash, loctyp, censor, 0) if (censor /= MISS) then censor=locpos(censor) if (narg > 3) then i=4 keyword=words(i)(1:3) if (iscomp(keyword)) call docomp(i, words, gt, thresh) end if end if call freq(locpos(trait), loctyp(trait), fndr, work, allele_buffer) call bluefreq(locpos(trait), censor, gt, thresh, work, & allele_buffer, plevel) if (censor == MISS) then call wrfreq(outstr, loc(trait), group(trait), map(trait), & locnotes(trait), allele_buffer, 21) end if else if (loctyp(trait) == LOC_QUA) then h2=fval(words(3)) if (h2 > 1.0D0) then h2=1.d00 else if (h2 /= MISS .and. h2 <= 0.0D0) then h2=0.d00 end if if (trait /= MISS .and. h2 /= MISS) then call doblup(loc(trait), locpos(trait), h2, 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 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 if (narg >= 3 .and. isreal(words(3))) pars(1)=max(0.0d0, fval(words(3))) if (narg >= 4 .and. isreal(words(4))) pars(2)=min(1.0d0, fval(words(4))) if (narg >= 5 .and. isreal(words(5))) pars(3)=fval(words(5)) whlik=3-whlik 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), iter, plevel) else write(outstr,'(a)') 'ERROR: Need to specify binary trait.' end if ! ! Bourgain etc QLS tests for categorical trait association ! else if ((keyword == 'wql') .and. red) then call gettrait(words(2), LOC_TRA, 0, nloci, loc, lochash, loctyp, trait, 0) if (trait /= MISS) then write(outstr,'(/a/3a/a)') & '--------------------------------------------------', & 'WQLS association testing 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 call setup_stat(lin) gt=COMP_NE thresh=MISS 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 bluefreq(locpos(i), locpos(trait), gt, thresh, work, & allele_buffer, plevel-2) call corchi(locpos(trait), loctyp(trait), locpos(i), loc(i), & prevalence, work, allele_buffer, iter, pval, plevel) locstat(i)=pval end if end do else write(outstr,'(a)') 'ERROR: Need to specify categorical trait.' end if else if ((keyword == 'mql') .and. red) then typ=1 if (words(narg)(1:3) == 'wql') then typ=2 narg=narg-1 end if call getbin(2, narg, words, nloci, loc, lochash, loctyp, trait, gt, thresh) qprev=prevalence if (narg == 3) then if (isreal(words(3))) qprev=fval(words(3)) else if (narg == 5) then if (isreal(words(5))) qprev=fval(words(5)) end if if (trait /= MISS) then write(outstr,'(/a/3a/a)') & '--------------------------------------------------', & 'MQLS association testing for trait "', trim(loc(trait)), '"', & '--------------------------------------------------' if (thresh /= MISS) call defpro(gt, thresh) if (qprev /= MISS) then write(outstr,'(a,f6.4)') 'Trait model prevalence = ', qprev 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) 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, 0, toler, work, allele_buffer, plevel) end if call domqls(typ, locpos(trait), gt, thresh, locpos(i), loc(i), qprev, & work, allele_buffer, iter, pval, plevel) locstat(i)=pval end if end do else write(outstr,'(a)') 'ERROR: Need to specify trait.' end if ! ! Quick random effects version of stratified SNP association test ! else if (keyword == 'str' .and. red) then call gettrait(words(2), LOC_TRA, 0, nloci, loc, lochash, loctyp, trait, 0) gt=0 thresh=MISS i=3 if (iscomp(words(i))) then call docomp(i, words, gt, thresh) end if call gettrait(words(i), LOC_TRA, 0, nloci, loc, lochash, loctyp, censor, 0) if (trait /= MISS .and. censor /= MISS) 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) if (plevel == -1 .or. plevel == 0) then write(outstr,'(/a/a)') & 'Marker Typed Strata Chi-square 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 whitehead(locpos(trait), loc(i), gt, thresh, locpos(i), allele_buffer, & locpos(censor), loctyp(censor), locnotes(censor), & work, pval, plevel) locstat(i)=pval end if end do 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, loc, loctyp, locpos, & gene, genemod, allele_buffer, work, & mlik(whlik), mpar(whlik), plevel) else if (linkf /= LINK_ID .and. modtyp == GLM_BINOM) then call binreg(GLM_BINOM, nord, locord, 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, 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 call segsim(linkf, modtyp, shap, trait, gt, thresh, off, & censor, nord, locord, gene, genemod, allele_buffer, 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 ! 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 typ=1 if (use2 == 3) typ=typ+1 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) then trait=locpos(trait) if (narg > 2) 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=1, nloci 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 nmarklist=0 nord=1 locord(nord)=trait typ=130 whlik=2 call varcom(modtyp, nord, locord, loc, loctyp, locpos, & MISS, genemod, allele_buffer, nmarklist, marklist, & work, mlik(1), mpar(1), pval, & plevel-2, burnin, iter, typ, approx, 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=1, nloci 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, plevel-2) typ=130 nord=2 locord(1)=gene locord(nord)=trait call regress(-1, nord, locord, loc, loctyp, locpos, & MISS, genemod, allele_buffer, work, & mlik(whlik), mpar(whlik), plevel-2) call varcom(modtyp, nord, locord, loc, loctyp, locpos, & MISS, genemod, allele_buffer, nmarklist, marklist, & work, mlik(2), mpar(2), pval, & plevel-2, burnin, iter, typ, approx, toler) expr(1,1)=mlik(1)-mlik(2) df=mpar(2)-mpar(1) pval=chip(expr(1,1), df) write(outstr,'(a14,2(a1,i6),a1,f10.1,a1,a6)') & loc(i), tabsep, allele_buffer%typed, 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. twinning /= MISS) 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=16 if (twintype==2) gt=21 end if if (censor /= MISS) then call twinken(loc(trait), locpos(trait), loc(censor), locpos(censor), & locpos(gene), gt, thresh, work, 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 write(outstr,'(a)') 'Need to specify trait' 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/),a,f12.4,i5,2x,a6)') & 'Term -2*LL NPar P-value', & '------ ----------- ---- -------', & 'Model0', mlik(3-whlik), mpar(3-whlik), & 'Model1', mlik(whlik), mpar(whlik), & 'LRTS ', expr(1,1), i, pstring(pval) 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') then i=ival(words(2)) j=ival(words(3)) if (i > 1 .and. j > 1) then call rcp(i, j, 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, int(anint(tmp))) i=i+2 else if (keyword == 'p' .or. keyword == 'pva') then lrts=chisqd(fval(words(i+1)), int(anint(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, dfloat(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 do i=1, nhis read(logstr, '(a)') lin write(*,'(i4,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(*,*) '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(*,*) '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) red=.false. nloci=0 numloc=0 numcol=0 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 close(incstr(ilevel), status='keep') ilevel=ilevel-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=4 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, 2) macname=words(2) scheme_lin=' ' 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) // '")' 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(words(2), nloci, loc) 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, 2) 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 else if (words(narg) /= '\') then 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, 2) 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 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 call evalped(narg, words, nloci, loc, lochash, loctyp, locpos, & locnotes, wtyp, wtag, expr, allele_buffer, work, & chek, imp, 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_peds(work) call cleanup_alleles(allele_buffer) call cleanup_mem() call clean_AS164() 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 escaped=(commands(i:i)=='\') 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 ! function ival(string) use outstream integer :: ival character(len=*), intent(in) :: string integer, parameter :: MISS=-9999 integer :: i, ioerr if (string.eq.' ') then ival=0 elseif (string == 'x' .or. string == 'X' .or. & string == '.' .or. string == 'NA') then ival=MISS else read(string,'(i40)',iostat=ioerr) i if (ioerr==0) then ival=i else write(outstr,'(2a/)') '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 if (string == ' ' .or. string == '-') then fval=BLANKD elseif (string == 'x' .or. string == 'X' .or. & string == '.' .or. string == 'NA') 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 ! ! 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 integer :: ichar 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 call wrform('i', len(string), 0, fstring) read(string, fstring, iostat=ioerr) v if (ioerr==0) then aval=v else write(outstr,'(3a/)') & 'ERROR: Unable to interpret allele "', trim(string), '".' aval=MISS end if 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 ! ! 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 ! ! 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 == '.') end function ismiss ! ! see if a string is a valid integer ! function isint(string) logical :: isint integer, parameter :: miss=-9999 character(len=*) string integer :: i, ich, j 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 if (string(i:i) == '-' .or. string(i:i)=='+') i=i+1 do j=i, len_trim(string) 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 double precision number ! function isreal(string) logical :: isreal integer, parameter :: miss=-9999 character(len=*) string integer :: ioerr 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 read(string,'(f20.0)',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 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 ! ! 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) double precision, intent(in) :: date character (len=*), intent(out) :: str integer, intent(in) :: typ ! function double precision :: togreg 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(value, ch, typ) double precision, intent(in) :: value 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 (value == 1.0d0) then ch=let(2+3*(typ-1)) else if (value == 2.0d0) then ch=let(3+3*(typ-1)) end if end subroutine wraff ! ! 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 /= '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 P-values as a string ! function pstring(pval) 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 (isnan(pval)) then continue #endif 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 integer, intent(in) :: lstr character (len=*) :: logfil integer, intent(out) :: nhis integer :: ioerr logical :: filexist #if IFORT || SUN character (len=24) :: fdate #endif logstr=lstr inquire(unit=logstr, opened=filexist) if (filexist) then write(outstr,'(a)') 'NOTE: Log stream was in use. Closing and reopening!' close(logstr,status='keep') end if inquire(file=logfil, exist=filexist) if (filexist) then open(logstr, file=logfil) close(logstr, status='delete') end if open(logstr, file=logfil, status='new', iostat=ioerr) if (ioerr == 0) then write(logstr,'(a/2a/a)') '#','# Sib-pair logfile created: ', fdate(),'#' 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(fil, stat) character (len=*), intent(inout) :: fil 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(fil) inquire(file=trim(nam), exist=filexist) if (filexist) then fil=nam stat=stat+1 return end if path=path((pos+1):) end do end subroutine findfile ! ! Delete a file ! subroutine delfile(filnam, plevel) 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) 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 ! subroutine reclen(port, buffer, longest) use fileio type (ioport) :: port character (len=*), intent(in out) :: buffer integer, intent(out) :: longest integer :: ioerr, ilen, lenbuff lenbuff=len(buffer) longest=0 ilen=0 call rewind_port(port, ioerr) do call readline(port, buffer, advance='no', ios=ioerr) if (ioerr == eolcode) then ilen=ilen+len_trim(buffer) if (ilen > longest) longest=ilen ilen=0 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, 1) 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 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) 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 -aF > ' // 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 ! ! Info ! subroutine info(lin, burnin, imp, iter, initix, initiy, initiz, & ix, iy, iz, mapf, mincnt, plevel, genemod, & showorig, chek, droperr, prompt, use2, gui, & twintrait, sexmarker, datdir, wrkdir) use extras use outstream use julian_epoch character (len=*) :: lin integer, intent(in) :: burnin integer, intent(in) :: imp integer, intent(in) :: iter integer, intent(in) :: initix, initiy, initiz integer, intent(in) :: ix, iy, iz 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=7), dimension(2) :: map = (/'Haldane' , 'Kosambi'/) character (len=9), dimension(2) :: modlabel = (/'Allelic ' , 'Genotypic'/) write(outstr,'(2a/)') 'Program version = ',version if (len_trim(hasextras) > 0) then write(outstr,'(2a)') 'Extra functionality = ', trim(hasextras) end if 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 = ', map(mapf), & ' Julian date epoch = ', string end subroutine info ! ! brief online help ! subroutine help(typ, regexp, lin, twrk) use outstream 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//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]', & 'To open a browser window for detailed help :', ' help.start', & '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 fie|wc <fil> [<fil>...] {count lines and words in file(s)}', & 'fil pri [/<str>/] [(<fmt>)] [+] [NR] [<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|h|q|a)[rm]] {list loci}' , & 'lis where <str> {list loci based on annotations}' , & 'las [<line no>|-<offset>] {cmd history}', & 'sho [chr|loc|map|mis] {show current chromosomes|loci|marker map|missingness}', & 'sho [ids [dup]|ped] {show current individual or pedigree IDs}', & 'sho [mac|mem|mz|path|sex] {show macros|memory|mztwins|search path|sex}' 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|<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}', & 'set pri rec|pai|obs|ver|<mask> {output style for print command}', & '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 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 <num> [<abs> [<rel>]] {MFT evaluation count and tolerance}', & '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}' write(strm,'(a)') 'set see <s1> <s2> <s3> {RNG seeds}', & 'set err [on|off] {remove nuclear family mendelian errors}', & 'set che [sex] [on|off] {disable mendelian or sex checking}', & 'set pre <prev>|off {fix population binary trait prevalence}', & 'set fre <mar> <p1>..<pN> {fix population allele frequencies}', & '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}' 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}', & 'tet <pre> <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}' 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 person?}', & ' ishom|ishet <mar> {hom/het genotype?}', & ' alla|allb <mar> {first/second allele of genotype}', & ' anytyp alltyp numtyp {available active markers? no. 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, person no. 1..n}' 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>...} {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 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> {rename locus}' write(strm,'(a)') & 'rea ped|mer <fil>|inline [skip <n>] [nos] [nop] {declare/read pedigree file}', & 'rea lin|ppd <fil>|inline {declare pedigree file Linkage type}', & 'rea cas <fil>|inline [sex] {declare pedigree file case data}', & '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 loc lin <fil> {read Linkage locus position,type,map}', & 'rea loc mer <fil> [xli] [snp] {read Merlin locus file}', & 'rea loc pli <fil> [app] [hum] {read PLINK .map file}' write(strm,'(a)') 'rea map <fil> [[k]bp] {read map, guessing format}', & '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}' write(strm,'(a)') & 'set sex <thr> {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 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 chr <chr>| pos <lo> <hi> {keep/drop loci on map position}', & 'kee|dro|und whe in <fil> {keep/drop loci listed in file}', & 'kee|dro|und whe <str> {keep/drop loci on annotations}', & 'kee|dro|und whe dis <dis>|r2 <r2>|pos <lo> <hi>|eve <Nth> {keep/drop loci on density}', & 'kee|dro|und whe mon|dia|snp {keep/drop monomorphic or diallelic markers}', & 'kee|dro|und whe max <c_op> <frq> {keep/drop loci on major allele frequency}', & 'kee|dro|und whe (hwe|tes) [<c_op> <pva>] {keep/drop loci on test P value}', & '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> {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|num] {recode nt alleles to/from numbers}', & '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> {recode SNP nucleotides to complementary strand}', & 'swa <mar> {swap SNP allele labels around}', & '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}', & 'kap <tra> <cen> [res] {survivor function estimate}' write(strm,'(a)') & 'dat (<yyyymmdd> jul)|(<num> gre) {julian date conversion}', & 'dat [<tra>] [jul|gre|yea] {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)}' 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> {merge data from phenotype file}', & 'mer pli <pre> [com] {merge data from plink .bim/.bed files}', & 'mer gen <fil> {merge data from genotype file (format: id loc a1 a2)}', & 'upd [<loc>..<locN>] inline|<fil> {update data from phenotype file}', & 'del <ped> <per>|all {delete/set all data missing for person 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> {simulate a pedigree}', & '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}', & '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> {divide into unrelated cases}' , & 'uni [seq] {generate numerical IDs}', & 'has [<fil>|(<ped> <id>)|sho|del|siz <pc>] {hash search for IDs}' write(strm,'(a)') & 'pri ped <ped1>...<pedN> [id <id1>...<idN>] {print data}', & 'wri {print data}', & 'hea [<nrec>|(<sta> <nrec>)|map|loc] {print head/part of pedigree, map, loci}', & 'tai [<nrec>|map|loc] {print tail of pedigree file, map or loci}', & '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>]] {write CSV type file}', & 'wri dot <fil> [<tra> [<mar>]] {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>] {write PLINK .bed .fam .bim files}', & 'wri ppd [dum] <fil> {write Linkage post-Makeped pedigree file}', & 'wri ram <tra> {write LDL_rams ped and dat files}', & 'wri sag <fil> {write SAGE pedigree file}', & 'wri sas <fil> [<sep>] {write SAS script with inline data cards}', & 'wri sib <fil> {write Sib-pair script with pedigree data inline}', & 'wri snp <fil> [<tra>] {write row-major SNP genotype data }', & 'wri sol <fil> [phe|gen] [nop] {write Solar type pedigree|phenotype|marker file}', & 'wri str <fil> [fou] {write Structure type data file}' write(strm,'(a)') & 'wri loc asp|tcl <fil> {write ASPEX locus file}', & 'wri loc bea <fil> {write Beagle marker 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] {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}' write(strm,'(a)') & 'wri map lok <fil> {write Loki parameter file}', & 'wri map men <fil> [new] {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}' 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> {show immediate relatives of index}', & '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}' 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>] {descriptive statistics}', & 'his <qua tra> [<nbins>] {histogram and normality test}', & 'plo <tr1> <tr2> [<tr3>] [<fil>] {Postscript scatterplot}' write(strm,'(a)') & 'mea|cor [<loc1>..<locN>] {phenotypic means and 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 [<tr1> [<tr2>..<trN>]] {contingency table and test}', & 'tab ped <tra> {tabulation by pedigree and Tarone test}', & 'llm <v1> + <v2> + <v1>*<v2> + ...[-1] {log-linear model of contingency table}', & 'llm ... [all] {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] {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}', & 'nef <win> <pcrit> {effective number (due LD) of marker tests}', & 'hom [<tra> [<c_op> <thr>]] {marker homozygosity}', & 'mul [<tra> [<c_op> <thr>]] {multipoint homozygosity}', & 'fst <pop> [fou] {Population genetic F-statistics}' write(strm,'(a)') & '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>]] {BLUE allele frequencies}', & 'gpe <mar> [mcmc] [<dose>] {ML/MCMC genotype probability estimates}', & 'pee <mar> {Iterative peeling likelihood calculator}' write(strm,'(a)') & 'ibs [kin | (<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 [<mar1> [...<marN>]] {test mendelism}', & 'tes <ped> <id> {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}', & 'mit|yha (<tra>|hap) [<mar1> [...<marN>]] {mitochondrial/Y haplotype association}', & 'mgt <tra> [<mar>] {VC allelic association test}', & 'wql <tra> {extended WQLS allelic association}', & 'mql <tra> [<c_op> <thr>] [<prev>] [wql] {MQLS allelic association}', & 'str <tra> <cov> {stratified allelic 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 <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] [cov <var1> [+ <var2>...] {MCMC fpm GLMM pars}', & 'fpm <tra> ... [lik wei cen <tra>] [pri|sav <blu>] {MCMC fpm survival analysis}' write(strm,'(a)') & 'twi <tra> [<zyg> [<c_op> <thr>]] {Classical twin analysis}', & 'ken <age> <tra> [<zyg> [<c_op> <thr>]] {Twin survival analysis}' write(strm,'(a)') & 'lrt {Compare last 2 models fitted (mix/VC/GLM/GLMM)}', & 'sum [<num> | plo [qq] [<fil>] | tab] {Summarize n highest tests from last command}' 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) #if IFORT use ifport #endif use outstream integer, intent(in) :: t0 integer :: elapsed ! functions #if SUN integer :: time #endif elapsed=time()-t0 if (elapsed < 120) then write(outstr,'(/a,i5,a)') 'This job has taken ',elapsed,' seconds' else if (elapsed < 7200) then write(outstr,'(/a,f5.1,a)') 'This job has taken ', float(elapsed)/60.0, ' minutes' else write(outstr,'(/a,f5.1,a)') 'This job has taken ', float(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 ! functions real :: secnds t2=real(secnds(0.0)) if (plevel /= 0) write(outstr,'(a,f8.2,a)') '[',t2-t1,' s]' t1=t2 end subroutine proct ! ! 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 character (len=20), intent(in) :: nam integer, intent(in) :: typ1 integer, intent(in) :: typ2 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(in) :: plevel integer, parameter :: MISS=-9999 integer :: i ! functions integer :: ival logical :: isreal trait=MISS if (nam == ' ') return if (isreal(nam)) then i=ival(nam) if (1 <= i .and. i <= nloci) trait=i 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(string, nloci, loc) use parser_data logical isinuse character (len=*), intent(in) :: string integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer :: i ! functions logical :: isreal isinuse=.false. do i=1, nloci if (loc(i) == string) then isinuse=.true. end if end do do i=1, toknum if (token(i) == string) then isinuse=.true. end if end do do i=1, envnum if (env(i) == string) then isinuse=.true. 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 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 ! functions logical :: iscomp interface subroutine gettrait(nam, typ1, typ2, nloci, loc, lochash, loctyp, trait, plevel) use outstream use locus_types use idhash_class character (len=20), intent(in) :: nam integer, intent(in) :: typ1 integer, intent(in) :: typ2 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(in) :: plevel end subroutine subroutine docomp(pos, words, gt, thresh) use comp_ops integer, intent(inout) :: pos character (len=*), dimension(:), intent(in) :: words integer, intent(out) :: gt double precision, intent(out) :: thresh end subroutine end interface call gettrait(words(sta), LOC_QUA, LOC_AFF, 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 .and. loctyp(trait) == LOC_QUA) then 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) use outstream use locus_types use idhash_class use string_utilities 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=20), dimension(:), intent(in) :: loc type (hash_table) :: lochash integer, dimension(:), intent(in out) :: loctyp character (len=2), 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 ! local variables integer :: ichr, i, j, locnum, nmark, offset, pos, span integer :: be, bymap, dir, en double precision, dimension(nloci) :: mapidx integer, dimension(nloci) :: ord ! functions ! chfind, strfind integer :: chrnum, isinenv, ival logical :: isreal interface 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 end subroutine actlist subroutine srank(n, dx, iy) integer, intent(inout) :: n double precision, dimension(:) :: dx integer, dimension(:) :: iy end subroutine srank end interface bymap=0 do locnum=1, nloci chosen(locnum)=0 end do nterms=0 ! 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 ! 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)) mapidx(nmark)=1.0d9*ichr + 1.0d6*map(locnum) 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 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 (isreal(words(pos))) then locnum=ival(words(pos)) if (locnum < 0 .or. locnum > nloci) locnum=0 else call find_hashtab(trim(words(pos)), 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 (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 ! ! 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))) 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 ! ! 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, plevel) use interrupt use outstream use locus_types integer, intent(in) :: nord integer, intent(in) :: locord(nord) integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: outpos character (len=40), dimension(:), intent(in) :: locnotes integer, intent(in) :: typ integer, intent(in) :: plevel integer :: i, ityp, j, eon, nmark, ntrait, pos character (len=1) :: cmp ! functions double precision :: bonf nmark=0 ntrait=0 if (typ == 1) then if (plevel > -2) then write(outstr,'(2(/a,1x,a,1x,a))') & 'Locus ','Type','Position', & '---------------','----','----------------' do j=1, nord i=locord(j) ityp=min(12, mod(loctyp(i), LOC_CMP)) if (ismarker(loctyp(i))) then nmark=nmark+1 cmp=' ' if (iscompressed(loctyp(i))) cmp='s' write(outstr,'(a15,2x,2a1,2x,i7,a2,i7,3x,a)') & loc(i), typloc(ityp), cmp, outpos(i)+5, '--', outpos(i)+6, trim(locnotes(i)) else write(outstr,'(a15,2x,a1,3x,i7,12x,a)') & loc(i), typloc(ityp), outpos(i)+5, trim(locnotes(i)) 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, nord write(outstr,'(a)') trim(loc(locord(j))) end do end if else if (typ == 2) then nmark=0 pos=0 do j=1, nord i=locord(j) eon=len_trim(loc(i)) pos=pos+eon+1 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 ! ! format free output ! subroutine newlin(sol, eol, pos, newpos) use outstream integer, intent(in) :: sol, eol integer, intent(inout) :: pos integer, intent(in) :: newpos integer :: i if (pos > eol) then pos=newpos write(outstr,*) do i=1, sol-1 write(outstr,'(a)', advance='no') ' ' end do end if return end subroutine newlin ! ! 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))) 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 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=1, nloci if (isactdip(loctyp(i))) then nmark=nmark+1 end if end do else do i=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 ! functions interface function findmk(sta, fin, loctyp) integer :: findmk integer, intent(in) :: sta integer, intent(in) :: fin integer, dimension(:), intent(in) :: loctyp end function end interface ! 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 ! ! Get a line from a port ! subroutine getlin(port, narg, words, lin, skipbl) use fileio use scanner 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, 1) if (skipbl /= 1 .or. narg /= 0) exit end do end subroutine getlin ! ! Read a MERLIN locus file ! subroutine rdmerloc(port, xli, lin, nloci, loc, locpos, outpos, loctyp, locnotes, & numloc, twinning, twintype, twintrait) use fileio use outstream use scanner use parser_data use storage_classes use locus_types type (ioport) :: port integer, intent(in) :: xli character (len=*), intent(inout) :: lin integer, intent(out) :: nloci character (len=20), dimension(:), intent(out) :: loc integer,dimension(:), intent(out) :: locpos, outpos integer,dimension(:), intent(out) :: loctyp character (len=40), 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=20), intent(out) :: twintrait ! local variables integer :: ioerr, k, mact, mclass, mdel, mdir, narg logical :: oldnam character (len=40), dimension(2) :: words ! functions interface function isinuse(string, nloci, loc) use parser_data logical isinuse character (len=*), intent(in) :: string integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc end function isinuse end interface nloci=0 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, 1) if (words(1)(1:1) /= 'E') then oldnam=isinuse(words(2), nloci, loc) nloci=nloci+1 loc(nloci)=words(2) numloc(TCLASS)=numloc(TCLASS)+1 outpos(nloci)=numloc(TCLASS) if (oldnam) then k=min(20, len_trim(loc(nloci))+1) loc(nloci)(k:k)='_' write(outstr,'(a/7x,3a/)') & 'WARNING: Locus is already declared or a reserved word.', & 'Changed name to "',loc(nloci)(1:k),'".' end if if (words(1)(1:1) == 'M') then loctyp(nloci)=mact locpos(nloci)=sign(numloc(mclass)+1, mdir) numloc(mclass)=numloc(mclass)+2 numloc(TCLASS)=numloc(TCLASS)+1 else if (words(1)(1:1) == 'A') then loctyp(nloci)=LOC_AFF locpos(nloci)=numloc(PCLASS)+1 numloc(PCLASS)=numloc(PCLASS)+1 else if (words(1)(1:1) == '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 loctyp(nloci)=LOC_QUA locpos(nloci)=numloc(PCLASS)+1 numloc(PCLASS)=numloc(PCLASS)+1 end if locnotes(nloci)=lin end if end do end subroutine rdmerloc ! ! Read PLINK .map file (combines locus and map information) ! typ=1: standard, one dummy trait, overwrite any existing loci ! 2: no dummy trait, append ! chrcode=1: standard codes for chromosomes, number, X, Y, Mt ! 2: and, 23=X 24=Y 25=PAR 26=Mit ! subroutine rdplink(port, typ, chrcode, nloci, loc, locpos, outpos, & loctyp, locnotes, numloc, group, map) use iobuff use outstream use scanner use parser_data use storage_classes use locus_types use fileio type (ioport) :: port integer, intent(in) :: typ, chrcode integer, intent(inout) :: nloci character (len=20), dimension(:), intent(inout) :: loc integer,dimension(:), intent(inout) :: locpos, outpos integer,dimension(:), intent(inout) :: loctyp character (len=40), dimension(:), intent(inout) :: locnotes ! Number of columns of data for each data class integer, dimension(NDATACLASS), intent(inout) :: numloc character (len=2), dimension(:), intent(inout) :: group double precision, dimension(:), intent(inout) :: map ! local variables integer, parameter :: MISS=-9999 integer :: firstsnp, ios, nmapped logical :: oldnam character (len=40), dimension(4) :: words ! functions integer :: ival double precision :: fval if (typ == 1) then 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 nmapped=0 firstsnp=nloci+1 do call readline(port, lin, ios=ios) if (ios /= 0) exit narg=4 call args(lin, narg, words, 1) if (narg > 0) then nloci=nloci+1 loc(nloci)=words(2) loctyp(nloci)=LOC_CODOM+LOC_CMP if (chrcode == 2) then if (words(1) == '23') words(1)='X' if (words(1) == '24') words(1)='Y' if (words(1) == '26') words(1)='MT' end if if (words(1) == 'X' .or. words(1) == 'x') loctyp(nloci)=LOC_XLIN+LOC_CMP if (words(1) == 'Y' .or. words(1) == 'y') loctyp(nloci)=LOC_YHA+LOC_CMP if (words(1) == 'MT' .or. words(1) == '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) locnotes(nloci)=trim(words(4)) // ' (chr ' // trim(words(1)) // ')' group(nloci)=words(1) map(nloci)=fval(words(3)) if (map(nloci) /= 0.0d0) nmapped=nmapped+1 end if end do if (nmapped == 0 .and. nloci > 1) then call rewind_port(port, ios) narg=4 do i=firstsnp, nloci call readline(port, lin, ios=ios) call args(lin, narg, words, 1) map(i)=1.0d-6*fval(words(narg)) end do end if end subroutine rdplink ! ! Read a mapfile -- attempts to intelligently decide ! what to read ! subroutine readmap(port, units, lin, words, plevel) use locus_data use outstream use fileio use scanner type(ioport) :: port integer, intent(in) :: units 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, & nampos, narg, nmark, searchpos, mapunits logical :: gzipped ! double precision :: dist ! functions logical :: isreal double precision :: fval ! map type not specified, so check first two records mapunits=units filtyp=1 chrpos=0 nampos=1 mappos=2 bppos=0 call readline(port, lin, ios=ioerr) if (ioerr /= 0) goto 999 if (plevel > 1) then write(outstr,'(/2a)') '1: ',lin(1:65) end if narg=size(words) call args(lin, narg, words, 1) 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=size(words) call args(lin, narg, words, 1) 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=size(words) call args(lin, narg, words, 1) 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=size(words) call args(lin, narg, words, 1) 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 (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 (plevel > 0) then write(outstr,'(a)') 'NOTE: Guessed name, position, chr.' end if else mappos=2 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 (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)') & 'ERROR: Did not recognize format! Trying name, position.' end if else if (narg >= 4) then if (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=2 end if if (plevel > 0) then write(outstr,'(a)') & 'NOTE: Guessed PLINK format; chr, name, pos (cM), coord (bp).' end if else write(outstr,'(a)') & 'ERROR: Did not recognize format! Trying name, position.' end if end if end if call rewind_port(port, ios) if (ios /= 0) then write(outstr,'(a,i0,a)') 'ERROR: Unable to rewind ios=', ios, '.' else if (plevel > 2) then write(outstr,'(a,i0,a)') 'NOTE: Rewound ios=', ios, '.' end if ! ! Read the mapfile ! call cntmark(nloci, loctyp, nmark, 1) mapped=0 if (filtyp == 1) then ! name-position pair per line ! hash search for matching locus do call readline(port, lin, ios=ioerr) if (ioerr /= 0) exit if (plevel > 1) then write(outstr,'(a)') lin(1:72) end if narg=3 call args(lin, narg, words, 1) call find_hashtab(trim(words(nampos)), loc, lochash, idx) if (idx > 0) then if (isreal(words(mappos))) then mapped=mapped+1 map(idx)=fval(words(mappos)) 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 if (mapped == nmark) exit end if end if end do else if (filtyp == 2) then ! name distance on alternate lines ! assumes map and data order same 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, 1) 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=size(words) call args(lin, narg, words, 1) 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 end if end do end if write(outstr,'(/a,i0,a)') & 'Matched up ', mapped, ' loci with their map positions.' if (mapunits > 1) then den=1.0d-6 if (mapunits == 3) den=1.0d-3 write(outstr,'(a)') 'Map positions now in Mbp' do i=1, nloci if (map(i) /= MISS) then narg=1 call args(locnotes(i), narg, words, 1) if (.not.(isreal(words(1)))) then write(words(1), '(i20)') int(map(i)) locnotes(i)=trim(adjustl(words(1))) // ' ' // trim(locnotes(i)) end if map(i)=den*map(i) end if end do end if return ! read error 999 continue write(outstr,'(a)') 'ERROR: io error in map file.' end subroutine readmap ! ! Read a list of locus names from a file to keep/drop/undrop ! subroutine readnames(port, nloci, loc, lochash, chosen) use fileio use outstream use idhash_class use scanner type (ioport) :: port integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc type (hash_table) :: lochash integer, dimension(:), intent(out) :: chosen character (len=40) :: buff, word integer :: ioerr, locnum chosen(1:nloci)=0 do call readline(port, buff, ios=ioerr) if (ioerr /= 0) exit call getword(buff, 1, word) call find_hashtab(trim(word), loc, lochash, locnum) if (locnum > 0) chosen(locnum)=1 end do end subroutine readnames ! ! Read a Linkage locus file ! subroutine rdlinloc(port, lin, words, nord, numloc) use fileio use outstream use parser_data use locus_types use locus_data use storage_classes type (ioport) :: port character (len=*), intent(inout) :: lin character (len=40), dimension(:), intent(inout) :: words integer, intent(inout) :: nord ! 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 interface function isinuse(string, nloci, loc) use parser_data logical isinuse character (len=*), intent(in) :: string integer, intent(in) :: nloci character (len=20), dimension(:), intent(in) :: loc end function isinuse 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 end subroutine getlin end interface 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(words(4), nloci, loc)) 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 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 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 double precision :: x ! functions integer :: aval, ival logical :: isint double precision :: fval ! allele_buffer%numal=0 allele_buffer%xlinkd=.false. allele_buffer%typed=0 allele_buffer%untyped=0 allele_buffer%totall=0 allele_buffer%topall=0 if (.not.allocated(allele_buffer%allele_names)) then allocate(allele_buffer%allele_names(50)) allocate(allele_buffer%allele_freqs(50)) allocate(allele_buffer%cum_freqs(50)) 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/dfloat(allele_buffer%numal) allele_buffer%allele_freqs(1)=x allele_buffer%cum_freqs(1)=x do i=2, allele_buffer%numal-1 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%topall=1 ! ! else read a list of allele frequencies ! padding out if sum to less than one ! else if (fin >= sta) then istep=1 ! May have specified allele names as well as frequencies if (typ == 2 .and. mod(fin-sta,2) == 1) then istep=2 do i=sta, fin, 2 if (aval(words(i), 1) < 1) then write(*,*) i, aval(words(i), 1) istep=1 exit 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) 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 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 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_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 ! 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=20), 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=2), dimension(:), intent(inout) :: group double precision, dimension(:), intent(inout) :: map double precision, dimension(:), intent(inout) :: locstat character (len=40), 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 ! do i=1, nloci ord(i)=0 end do open(twrk, status='scratch', form='unformatted') do i=1, nord pos=locord(i) ord(pos)=i write(twrk) loc(pos), loctyp(pos), locpos(pos), outpos(pos), group(pos), map(pos), & locstat(pos), locnotes(pos) 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 ! Note that SNPs stored as 2 genotypes per byte cannot be packed ! subroutine packer(typ, red, wrk, wrk2, nloci, loc, loctyp, locpos, group, map, & locnotes, dataset, plevel) use outstream use ped_class use locus_types integer, intent(in) :: typ logical, intent(in) :: red integer, intent(in) :: wrk, wrk2 integer, intent(inout) :: nloci character (len=20), dimension(:), intent(inout) :: loc integer,dimension(:), intent(inout) :: loctyp integer,dimension(:), intent(inout) :: locpos character (len=2), dimension(:), intent(inout) :: group double precision, dimension(:), intent(inout) :: map character (len=40), dimension(:), intent(inout) :: locnotes 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, dimension(NDATACLASS) :: numloc integer :: gkeep, gpos, pkeep, pos, ppos integer, dimension(dataset%numloc(GCLASS)) :: gactive integer, dimension(dataset%numloc(PCLASS)) :: pactive ! ! 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 gpos=0 ppos=0 pos=0 do i=1, nloci if (isactive(loctyp(i)) .or. & (dataset%hassnps == 2 .and. iscompressed(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 locpos(pos)=locpos(i) end if else 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 numloc(SCLASS) = dataset%numloc(SCLASS) 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 end if if (.not.red) return ! ! 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 /= 0) 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 /= 0) 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 ! ! 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/dfloat(ntest)) end if end function bonf ! ! 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, tty integer i, ij, j, k, kk, 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, intent(inout) :: 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, kk, 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 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 ! ! 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 100 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 ! ! 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 ! ! parse comparison in isaff ! 15='<', 16='>', 17='ge', 18='le',19='ne',20='eq' ! 21='odd', 22='even' ! subroutine docomp(pos, words, gt, thresh) use comp_ops 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 logical :: iscomp 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) use comp_ops use outstream integer, intent(in) :: gt double precision, intent(in) :: thresh integer, parameter :: MISS=-9999 ! functions character(len=2) :: compsign if (gt > 14) then if (thresh == MISS) then write(outstr,'(2a,1x,a/)') & 'NOTE: Proband defined as trait value ', compsign(gt), 'x' else if (gt <= COMP_EQ) then if (anint(thresh) == thresh) then write(outstr,'(2a,1x,i0/)') & 'NOTE: Proband defined as trait value ', compsign(gt), int(thresh) else write(outstr,'(2a,1x,f9.4/)') & 'NOTE: Proband defined as trait value ', compsign(gt), thresh end if else if (gt == COMP_ODD) then write(outstr,'(a/)') & 'NOTE: Proband defined as an odd trait value.' else if (gt == COMP_EVEN) then write(outstr,'(a/)') & 'NOTE: Proband defined as an even trait value.' end if end if end subroutine defpro ! ! 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 ! ! 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(int(anint(isaff)),2) == (22-gt)) then isaff=2.0d0 else isaff=1.0d0 end if else isaff=1.0d0 end if end if 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=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 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=20 ! integer :: nped ! number of pedigrees integer :: nobs ! number of records ! number of available columns of locus data integer, dimension(NDATACLASS) :: numcol integer :: astat, eon, ios, ityp, newsiz, oldsiz logical :: gzipped character (len=21) :: slin real :: telapsed, ttaken(2) double precision :: dataset_uses ! chunking of slocus integer :: i, iblock, ichunk, sta, fin integer(kind=8) :: nsnps #if SUN real :: dtime telapsed=dtime(ttaken) #else call dtime(ttaken, telapsed) #endif ityp=typ red=.false. 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, form='unformatted', 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 read(strm, err=999, end=999) 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 if (slin /= 'Sib-pair raw ped V2.0' .and. ityp == 1) then ityp=ityp+1 end if oldsiz=size(loc) read(strm) nloci newsiz=5*(1+nloci/5) call expand_loci(newsiz-oldsiz, 0) read(strm, err=999, end=999) loc(1:nloci), loctyp(1:nloci), & locpos(1:nloci), outpos(1:nloci), locnotes(1:nloci) read(strm, err=999, end=999) group(1:nloci), map(1:nloci) ! if (ityp == 3) then call newloctyp() end if ! read(strm, err=999, end=999) nped, nobs, numloc, numcol if (plevel > 1) then write(outstr,'(/a,i0,a/a/a,i0,a,i0/a,4(1x,i0)/)') & 'Read in descriptions of ', nloci, ' loci', & 'About to read in pedigree data: ', & 'nped=', nped, ' nobs=', nobs, & 'numcol=', numcol end if call cleanup_peds(dataset) call setup_peds(nped, nobs, numloc, numcol, dataset, astat, plevel) if (astat /= 0) return read(strm, err=999, end=999) dataset%nped, dataset%nact, dataset%maxsiz, & dataset%maxact, dataset%nobs, dataset%numloc, dataset%numcol, dataset%hassnps read(strm, err=999, end=999) dataset%pedigree, dataset%num, & dataset%nfound, dataset%actset read(strm, err=999, end=999) dataset%iped, dataset%imztwin, dataset%id, & dataset%fa, dataset%mo, dataset%sex if (dataset%hassnps /= 0) then 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 (ityp == 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 read(strm, err=999, end=999) dataset%glocus read(strm, err=999, end=999) dataset%plocus ! ! key variables state and state of scheme memory ! added 20090531 ! read(strm, iostat=ios) slin if (ios == 0 .and. slin == 'Other Variable States') then 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. #if SUN telapsed=dtime(ttaken) #else call dtime(ttaken, telapsed) #endif write(slin, '(f20.2)') telapsed 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 999 continue write(outstr,'(3a)') 'ERROR: Problem reading "', trim(filnam), '".' close(strm) call cleanup_peds(dataset) if (gzipped) call delfile(wrkfil, plevel-3) end subroutine readbin ! ! Write a Sib-pair binary file ! Default is a "Fortran unformatted write" dump of the ! locus and pedigree arrays. ! If compress=2, currently calls gzip to compress the resulting file ! subroutine writebin(strm, compress, filnam, dataset, plevel) use outstream use locus_types use locus_data use idstring_widths use locus_data use ped_class use scheme_lang implicit none integer, intent(in) :: strm, compress character (len=*), intent(inout) :: filnam type (ped_data), intent(in) :: dataset integer, intent(in) :: plevel integer, parameter :: MISS = -9999, WORDLEN=20 integer :: ios character (len=21) :: slin real :: telapsed, ttaken(2) ! chunking of slocus integer :: i, iblock, ichunk, sta, fin integer(kind=8) :: nsnps ! #if SUN real :: dtime telapsed=dtime(ttaken) #else call dtime(ttaken, telapsed) #endif open(strm, file=filnam, form='unformatted', 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.0' 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 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 (compress == 2) then call system('gzip ' // trim(filnam)) filnam=trim(filnam) // '.gz' end if #if SUN telapsed=dtime(ttaken) #else call dtime(ttaken, telapsed) #endif write(slin, '(f20.2)') telapsed 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 ! ! 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 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=20 ! 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 real :: telapsed, ttaken(2) integer :: aval double precision :: fval, dataset_uses #if SUN real :: dtime telapsed=dtime(ttaken) #else call dtime(ttaken, telapsed) #endif 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) 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, 1) 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 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, 1) 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, 1) 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) #if SUN telapsed=dtime(ttaken) #else call dtime(ttaken, telapsed) #endif write(slin, '(f20.2)') telapsed 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) ! id locus_name allele1 allele2 ... [quality score etc] ! subroutine readgeno(port, 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 implicit none ! i/o port for dataset type (ioport) :: port 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=20 ! ID strings and data strings character (len=id_width) :: curid character (len=WORDLEN), dimension(5) :: words ! index to matching record integer :: curidx integer :: g1, g2, gene, gen2, i, ios, keytyp, narg, nchanges, pos, pos2 integer :: matched, unmatched logical :: noskipid ! functions integer :: aval 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 unmatched=0 noskipid=.true. do i=1, skipline call readline(port, lin, ios=ios) end do i=0 do call readline(port, lin, ios=ios) if (ios /= 0) exit i=i+1 narg=5 call args(lin, narg, words, 4) if (words(1) /= curid) then curid=words(1) 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, '(2a)') 'Merging genotypes for ', trim(curid) end if matched=matched+1 noskipid=.true. end if end if if (noskipid) then call find_hashtab(trim(words(2)), loc, lochash, pos) if (pos /= 0) then gene=locpos(pos) gen2=gene+1 g1=aval(words(3),1) g2=aval(words(4),1) call set_geno(curidx, gene, gen2, dataset, g1, g2) nchanges=nchanges+1 else if (plevel > 2) then write(outstr, '(3a)') 'NOTE: Could not match ', trim(words(2)), '.' end if end if end do write(outstr,'(/a,i0,a,i0,a)') & 'Updated ', nchanges, ' genotypes for ', matched,' individuals.' 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, longest, dataset, plevel) use locus_types use locus_data use iobuff use fileio use scanner use locus_data 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 integer, intent(in) :: longest type (ped_data), intent(inout) :: dataset integer, intent(in) :: plevel integer, parameter :: MISS = -9999, WORDLEN=20 ! index to matching pedigree record integer, dimension(:), allocatable :: idx ! buffer for entire line of data character (len=longest) :: buffer character (len=40) :: word character (len=6) :: alleles integer :: a1, a2, g1, g2, gene, gen2, i, ii, ios, first, j, & n, nlines, nmar, nmatched, nobs, nwords, pos, stat integer (kind=8) :: ngeno real :: telapsed, ttaken(2) double precision, dimension(3) :: prob ! functions integer :: aval, ival double precision :: fval, dataset_uses #if SUN real :: dtime telapsed=dtime(ttaken) #else call dtime(ttaken, telapsed) #endif first=3 if (typ == 2) first=5 call filecols(port, buffer, 1, nwords, plevel-2) nobs=(nwords-first)/3 ! ! Need to match original ordering to order of records in dataset ! allocate(idx(nobs)) idx=0 nmatched=0 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 end if end if end do write(outstr,'(a,i0/a,i0)') & 'Number of individuals genotyped = ', nobs, & 'Number matching current dataset = ', nmatched ! ! read SNP data ! if (.not.lochash%current) then call make_lochash(nloci, loc, lochash) end if nlines=0 nmar=0 ngeno=0 ! skip header buffer=' ' if (typ == 1) then call readline(port, buffer, ios=ios) nlines=nlines+1 end if 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, 1) if (stat == -1) exit lineloop if (typ == 2) then call nextword(i, buffer, longest, opchar, n, word, stat, 1) if (stat == -1) exit lineloop end if call find_hashtab(trim(word), 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, 1) if (stat == -1) exit lineloop end if call nextword(i, buffer, longest, opchar, n, word, stat, 1) if (stat == -1) exit lineloop a1=aval(word, 2) alleles=trim(word) call nextword(i, buffer, longest, opchar, n, word, stat, 1) 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, 1) if (stat == -1) exit lineloop prob(j)=fval(word) end do ii=ii+1 ! write(*,*) 'writing data for person ', 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 #if SUN telapsed=dtime(ttaken) #else call dtime(ttaken, telapsed) #endif write(word, '(f20.2)') telapsed 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 ! ! 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) or as 4-bits per ! genotype (typ=2). ! subroutine readbed(strm, typ, filnam, hashtab, dataset, plevel) use locus_types use locus_data use iobuff use fileio use scanner use idstring_widths use locus_data use ped_class implicit none integer, intent(in) :: strm integer, intent(in) :: typ 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=20 integer (kind=1), parameter :: zero = 0 ! i/o port for .bim type (ioport) :: port ! 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 ! 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=256) :: prefix character (len=id_width) :: currfa, currmo integer :: cfa, cmo, curout, g1, g2, gtp, i, ifail, ii, imin, imaj, ios, & j, k, lpos, narg, nbytes, newsiz, nmar, pos, pos2, tenth integer :: nf, nmapped, nobs, nped, num, pedoffset integer :: snpperword integer (kind=8) :: ngeno ! last of previously declared loci (in locpos etc) integer :: lastold real :: telapsed, ttaken(2), t0, t1, tot0, tot1 ! functions integer :: aval, ival double precision :: fval, dataset_uses #if SUN real :: dtime telapsed=dtime(ttaken) #else call dtime(ttaken, telapsed) #endif ifail=0 prefix=filnam filnam=trim(prefix) // '.bim' call open_port(filnam, port, 'r', ios) if (ios /= 0) then filnam=trim(prefix) // '.bim.gz' 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 end if call setup_plink(port, nmar, newsiz) nmapped=0 curout=0 lastold=nloci newloc=dataset%numloc if (nloci > 0) then curout=outpos(nloci) end if if (typ == 1) then snpstorage = SNP_ONE snpperword=1 allocate(snpalleles(nmar,2)) allocate(snpswap(nmar)) ii=-1 nmar=0 do ii=ii+2 call readline(port, lin, ios=ios) if (ios /= 0) exit narg=6 call args(lin, narg, words, 1) nloci=nloci+1 nmar=nmar+1 loc(nloci)=words(2) loctyp(nloci)=LOC_CODOM+LOC_CMP if (words(1) == 'X') then loctyp(nloci)=LOC_XLIN+LOC_CMP end if snpalleles(nmar,1)=aval(words(5),1) snpalleles(nmar,2)=aval(words(6),1) snpswap(nmar)=(snpalleles(nmar,1) > snpalleles(nmar,2)) locpos(nloci)=-ii locnotes(nloci)=trim(words(4)) // ' (chr ' // trim(words(1)) // ') ' // & trim(words(5)) // '/' // trim(words(6)) group(nloci)=words(1) map(nloci)=fval(words(3)) if (map(nloci) /= 0.0d0) nmapped=nmapped+1 outpos(nloci)=curout+2*nmar end do newloc(SCLASS)=newloc(SCLASS)+ii+1 newloc(TCLASS)=newloc(TCLASS)+ii+1 else if (typ == 2) then snpstorage = SNP_TWO snpperword=2 nmar=0 do call readline(port, lin, ios=ios) if (ios /= 0) exit narg=6 call args(lin, narg, words, 1) nloci=nloci+1 nmar=nmar+1 loc(nloci)=words(2) loctyp(nloci)=LOC_CODOM+LOC_CMP if (words(1) == 'X') then loctyp(nloci)=LOC_XLIN+LOC_CMP end if locpos(nloci)=-nmar locnotes(nloci)=trim(words(4)) // ' (chr ' // trim(words(1)) // ') ' // & trim(words(5)) // '/' // trim(words(6)) group(nloci)=words(1) map(nloci)=fval(words(3)) if (map(nloci) /= 0.0d0) nmapped=nmapped+1 outpos(nloci)=curout+2*nmar end do newloc(SCLASS)=newloc(SCLASS)+1+nmar/2 newloc(TCLASS)=newloc(TCLASS)+1+nmar/2 end if if (nmapped == 0 .and. nmar > 0) then call rewind_port(port, ios) narg=4 do i=2, nloci call readline(port, lin, ios=ios) call args(lin, narg, words, 1) map(i)=1.0d-6*fval(words(4)) end do end if call close_port(port, ios) filnam=trim(prefix) // '.fam' write(outstr,'(a,a/a,i0)') & 'Pedigree file = ', trim(filnam), & 'Number of loci = ', nloci call open_port(filnam, port, 'r', ios) if (ios /= 0) then filnam=trim(prefix) // '.fam.gz' call open_port(filnam, port, 'r', ios) if (ios /= 0) then write(outstr,'(3a)') 'ERROR: Could not open .fam file "', trim(filnam),'".' return end if end if ! ! Need to match original ordering to order of records in dataset ! nobs=0 allocate(idx(dataset%nobs)) do call readline(port, lin, ios=ios) if (ios /= 0) exit narg=2 call args(lin, narg, words, 1) nobs=nobs+1 call matchid(HK_PED_ID, words(1), words(2), dataset, hashtab, idx(nobs), plevel) if (idx(nobs) == 0) then write(outstr,'(6a)') & 'ERROR: Cannot match ', trim(words(1)), '--', trim(words(2)), & ' found in .fam file.' return end if end do call close_port(port, ios) ! ! Space for new genotype data if (typ == 1) then call expand_sgeno(newloc(SCLASS)+3, dataset, ifail) else 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 write(outstr,'(a,i0/a,i0/2a)') & 'Number of individuals = ', nobs, & 'Number of genotypes = ', int(nobs, kind=8)*int(nmar, 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) /= 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 tenth=nmar/10 nbytes=int(ceiling(0.25d0*dfloat(nobs))) allocate(ibuff(nbytes)) if (typ == 1) then lpos=lastold do j=1, nmar read(strm, iostat=ios) ibuff if (ios /= 0) then write(outstr,'(3a)') 'ERROR: File "', trim(filnam), '" is truncated!' close(strm) return end if if (mod(j,tenth) == 0) then write(outstr,'(a,i0,a,i0)') 'Reading data for marker ', j, ' of ', nmar end if lpos=lpos+1 i=1 k=0 pos=locpos(lpos) pos2=pos+1 ig1(:)=zero ig2(:)=zero do ii=1, nobs gtp=ibits(ibuff(i),k,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))) k=mod(k+2,8) if (k==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) end do else if (typ == 2) then lpos=lastold do j=1, nmar read(strm, iostat=ios) ibuff if (ios /= 0) then write(outstr,'(3a)') 'ERROR: File "', trim(filnam), '" is truncated!' close(strm) return end if if (mod(j,tenth) == 0) then write(outstr,'(a,i0,a,i0)') 'Reading data for marker ', j, ' of ', nmar end if lpos=lpos+1 i=1 k=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),k,2) call fromplink(gtp, 1, 2, .FALSE., g1, g2, ngeno) call encode_geno2(g1, g2, ig1(idx(ii)), imin) k=mod(k+2,8) if (k==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 end if ! individual-major mode, read nmar/4 byte chunks else if (ichar(ch) == 0) then if (plevel > 0) then write(outstr,'(3a)') 'NOTE: File "', trim(filnam), '" is individual-major mode.' end if nbytes=int(ceiling(0.25d0*dfloat(nmar))) write(*,'(a)') 'ERROR: Individual-major mode not yet implemented!' else write(*,'(a,2(1x,z0))') 'ERROR: Unknown .bed file mode: ', ichar(ch) end if close(strm, status='keep') #if SUN telapsed=dtime(ttaken) #else call dtime(ttaken, telapsed) #endif write(slin, '(f20.2)') telapsed slin=adjustl(slin) write(outstr,'(a,i0,a/9x,i0,a)') & 'Read in ', 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.' end subroutine readbed ! ! 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 file containing just unrelated individuals ! Duplicates (if contiguous) are combined into the same "family" ! with appended copy numbers ! subroutine readcases(port, hassex, skipline, numloc, coltyp, & dataset, longnam, longest, nwarn, plevel) use iocodes use outstream use fileio use scanner use locus_types use ped_class type (ioport) :: port logical, intent(in) :: hassex integer, intent(in) :: skipline 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 :: MISS = -9999, WORDLEN=20 type (ped_data) :: buffer integer :: nobs, nped, num integer :: astat, biggest, col, eop, first, gcode, gcol, higen, i, ioerr, j, & narg, nfields, ncol, pcol, scol, sxpos integer (kind=1) :: i1 ! line buffer character(len=longest) :: lin ! ID strings and data strings character (len=ped_width) :: pedigree character (len=WORDLEN) :: slin character (len=WORDLEN), dimension(:), allocatable :: words real :: telapsed, ttaken(2) ! functions integer :: aval double precision :: fval, dataset_uses #if SUN real :: dtime telapsed=dtime(ttaken) #else call dtime(ttaken, telapsed) #endif biggest=1 first=2 if (hassex) first=first+1 sxpos=2 nwarn=0 nobs=0 num=0 longnam=1 nfields=first+numloc(TCLASS)-1 allocate(words(nfields)) nped=0 pedigree=' ' slin=' ' ! ! read through and count pedigrees ! call rewind_port(port, ioerr) do i=1, skipline call readline(port, slin, ios=ioerr) if (ioerr == eofcode) exit end do do call readline(port, slin, ios=ioerr) narg=1 call args(slin, narg, words, 3) if (ioerr == eofcode) 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 (words(1) /= pedigree) then if (num > 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 end if end do call rewind_port(port, ioerr) ! #if SUN telapsed=dtime(ttaken) #else call dtime(ttaken, telapsed) #endif write(slin, '(f20.2)') telapsed 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 ! ! Get first pedigree pedigree=' ' do i=1, skipline call readline(port, slin, ios=ioerr) if (ioerr == eofcode) exit end do do call readline(port, lin, ios=ioerr) narg=1 call args(lin, narg, words, 3) if (ioerr /= 0) then exit else if (narg==0 .or. words(1)(1:1) == '!' .or. words(1)(1:1) == '#') then continue else pedigree=words(1) exit end if end do call rewind_port(port, ioerr) ! ! Now read in data ! nobs=0 nped=1 num=0 do i=1, skipline call readline(port, slin, ios=ioerr) if (ioerr /= 0) exit end do do call readline(port, lin, ios=ioerr) narg=1 call args(lin, narg, words, 4) 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 else if (words(1)(1:1) == '!' .or. words(1)(1:1) == '#') then if (plevel > 1) write(outstr,'(a)') lin(1:79) else if (narg == 0) then continue else ncol=countargs(trim(lin),4) if (ncol /= nfields) then nwarn=nwarn+1 if (nwarn <= 25) then if (ncol < nfields) then write(outstr,'(/a,i0,a,i0,a/7x,a/)') & 'ERROR: Insufficient number of data fields (', & ncol, '; expected ', nfields,') in:', & lin(1:min(len_trim(lin),72)) else write(outstr,'(/a,i0,a,i0,a/7x,a/)') & 'NOTE: Excessive number of data fields (', & ncol, '; expected ', nfields,') in:', & lin(1:min(len_trim(lin),72)) end if end if end if narg=nfields call args(lin, narg, words, 4) if (words(1) /= pedigree) then dataset%pedigree(nped)=pedigree dataset%num(nped)=num+dataset%num(nped-1) dataset%nfound(nped)=num dataset%actset(nped)=1 nped=nped+1 num=0 pedigree=words(1) eop=len_trim(pedigree) longnam=max(longnam, eop) end if num=num+1 nobs=nobs+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 if (words(sxpos) == 'f' .or. words(sxpos) == 'F' .or. & words(sxpos) == '2') then dataset%sex(nobs)=2 else if (words(sxpos) == 'm' .or. words(sxpos) == 'M' .or. & words(sxpos) == '1') then dataset%sex(nobs)=1 end if end if ! all other variables col=0 gcol=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 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 #if SUN telapsed=dtime(ttaken) #else call dtime(ttaken, telapsed) #endif write(slin, '(f20.2)') telapsed 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, skipline, link, unspecified, & mztwin, gt, thresh, sexchek, hassex, nextped, & numloc, coltyp, dataset, longnam, longest, nwarn, plevel) use outstream use fileio use scanner use locus_types use ped_class type (ioport) :: port integer, intent(in) :: wrk, wrk2 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 :: MISS = -9999 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 integer :: pedidpos, indidpos, faidpos, moidpos, sxpos integer, dimension(NDATACLASS) :: numcol ! 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=20) :: slin character (len=8) :: extraidfmt character (len=20), dimension(:), allocatable :: words real :: telapsed, ttaken(2) ! functions integer :: aval 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 #if SUN real :: dtime telapsed=dtime(ttaken) #else call dtime(ttaken, telapsed) #endif biggest=0 extra=0 nwarn=0 ! ! 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=' ' ! ! 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, 3) 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 !? ! #if SUN telapsed=dtime(ttaken) #else call dtime(ttaken, telapsed) #endif write(slin, '(f20.2)') telapsed slin=adjustl(slin) write(outstr,'(a,i0,a,i0,a)') & 'Screened ', nped, ' pedigrees, ', nobs, ' records (' // trim(slin) // ' s).' maxsiz=3*biggest i=int(log10(dfloat(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) narg=nfields call args(lin, narg, words, 3) if (ioerr /= 0) then exit else if (words(1)(1:1) == '!' .or. words(1)(1:1) == '#') then if (plevel > 1) write(outstr,'(a)') lin(1:79) else if (narg == 0) then continue else if (words(1) == 'pedigree') then continue else if (narg==1 .and. words(1) == 'end') then continue else ncol=countargs(trim(lin),3) if (ncol /= nfields) then nwarn=nwarn+1 if (nwarn <= 25) then if (ncol < nfields) then write(outstr,'(/a,i0,a,i0,a/7x,a/)') & 'ERROR: Insufficient number of data fields (', & ncol, '; expected ', nfields,') in:', & lin(1:min(len_trim(lin),72)) else write(outstr,'(/a,i0,a,i0,a/7x,a/)') & 'NOTE: Excessive number of data fields (', & ncol, '; expected ', nfields,') in:', & lin(1:min(len_trim(lin),72)) end if end if end if narg=nfields call args(lin, narg, words, 3) 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 if (words(sxpos) == 'f' .or. words(sxpos) == 'F' .or. & words(sxpos) == '2') then buffer%sex(num)=2 else if (words(sxpos) == 'm' .or. words(sxpos) == 'M' .or. & words(sxpos) == '1') then buffer%sex(num)=1 end if end if ! all other variables col=0 gcol=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 else if (words(j) == 'MZ' .or. words(j) == 'mz') then pcol=pcol+1 buffer%plocus(num,pcol)=1.0d0 else if (words(j) == 'DZ' .or. words(j) == 'dz') then pcol=pcol+1 buffer%plocus(num,pcol)=0.0d0 else pcol=pcol+1 buffer%plocus(num,pcol)=fval(words(j)) 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 == '.') cfa='x' if (cmo == '0' .or. cmo == 'X' .or. cmo == '-' .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 /= MISS) 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 person ', & 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 person ', & 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 #if SUN telapsed=dtime(ttaken) #else call dtime(ttaken, telapsed) #endif write(slin, '(f20.2)') telapsed 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 person ', & 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: Person ', & 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: Person ', & 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=(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 ! Assign consistent sexes where missing, allowing for possible MZ twins ! 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 :: MISS=-9999 integer :: i, idx, it, j, newidx, nmiss, oldval, p1, p2, pos1, pos2, sxcode integer :: mzmiss, thistwin, thispos logical :: fin 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 /= MISS) 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 person ', & 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 person ', & 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 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,'(a10,1x,a12,1x,a,1x,a)') & pedigree, buffer%id(key1(i)), sx, cimp end if end do write(outstr,*) 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 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 csort(n, cx, iy) integer, intent(in) :: n character (len=*), intent(inout) :: cx(*) integer, intent(in out) :: iy(*) end subroutine csort 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 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 end subroutine msdsort 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 ! ! 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 ! ! 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 :: 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 end subroutine mkdummy ! ! Assign a locus type to every column of data file ! subroutine asstyp(nloci, loctyp, locpos, totloc, coltyp) 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 pos=pos+1 coltyp(pos)=loctyp(i) if (ismarker(loctyp(i))) then pos=pos+1 coltyp(pos)=loctyp(i) 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 type (ped_data) :: buffer 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 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 real :: telapsed, ttaken(2) ! functions double precision :: dataset_uses #if SUN real :: dtime telapsed=dtime(ttaken) #else call dtime(ttaken, telapsed) #endif 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 #if SUN telapsed=dtime(ttaken) #else call dtime(ttaken, telapsed) #endif write(selapsed, '(f20.2)') telapsed 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 ! subroutine replacedata(port, typ, nloci, loc, lochash, loctyp, locpos, & chosen, hashtab, dataset, longest, plevel) use locus_types use outstream use fileio use scanner use ped_class use idhash_class use lochash_class implicit none type (ioport) :: port integer, intent(in) :: typ 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 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=20), dimension(:), allocatable :: words integer :: dups, g1, g2, g3, g4, gcode, gene, gen2, i, idx, ioerr, j, k, keytyp, & narg, nchanges, nfields, nid, nvar, nwarn, pos, matched, unmatched logical :: found double precision :: val character (len=7) :: gtp, ogtp ! functions integer :: aval logical :: iscomment double precision :: fval ! allocate(words(3)) dataset%untyped=.true. 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, 4) if (words(1)(1:3) == 'ped' .and. words(2) == 'id' .and. narg > 2) then keytyp=HK_PED_ID nid=2 else if (words(1) == 'id' .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)) return end if exit end do deallocate(words) narg=countargs(trim(lin),4) allocate(words(2*narg)) call args(lin, narg, words, 4) 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 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 (chosen(pos) > 0) then nvar=nvar+1 fieldord(nvar)=pos fieldpos(nvar)=nfields end if if (ismarker(loctyp(pos))) then nfields=nfields+1 end if found=.true. 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)') 'Updating ', nvar,' 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 dups=0 nchanges=0 nwarn=0 matched=0 unmatched=0 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 if (iscomment(lin)) cycle narg=nfields call args(lin, narg, words, 4) if (narg /= nfields) then nwarn=nwarn+1 if (nwarn <= 25) then if (narg < nfields) then write(outstr,'(/a,i0,a,i0,a/7x,a/)') & 'ERROR: Insufficient number of data fields (', & narg, '; expected ', nfields,') in:', & lin(1:72) else write(outstr,'(/a,i0,a,i0,a/7x,a/)') & 'NOTE: Excessive number of data fields (', & narg, '; expected ', nfields,') in:', & lin(1: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. 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 if (typ == 1 .or. .not.observed(idx, locpos(j), dataset)) then gcode=gencode(loctyp(j)) g1 = aval(words(pos), gcode) g2 = aval(words(pos+1), gcode) if (typ == 1 .or. (typ == 2 .and. g1 /= MISS)) then nchanges=nchanges+1 nupdated(i)=nupdated(i)+1 if (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 call wrgtp(g1, g2, gtp, '/', 1) call wrgtp(g3, g4, ogtp, '/', 1) write(*,'(10a)') & 'Overwriting genotype at "', trim(loc(j)),'" for ', & trim(dataset%pedigree(dataset%iped(idx))), '--', & trim(dataset%id(idx)), ' to ', gtp, ' from ', ogtp end if end if call set_geno(idx, gene, gen2, dataset, g1, g2) end if end if else if (typ == 1 .or. dataset%plocus(idx,gene) == MISS) then val = fval(words(pos)) if (typ == 1 .or. (typ == 2 .and. val /= MISS)) then nchanges=nchanges+1 nupdated(i)=nupdated(i)+1 if (plevel > 1) then write(*,'(8a)') & 'Overwriting trait value at "', trim(loc(j)),'" for ', & trim(dataset%pedigree(dataset%iped(idx))), '--', & trim(dataset%id(idx)), ' to ', trim(words(pos)) end if end if dataset%plocus(idx,gene) = val end if end if end if end do 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) 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 write(outstr,'(/a,i0,a,i0,a)') & 'Merged in ', nchanges, ' values for ',matched,' individuals.' if (plevel > 0) then write(outstr,'(/a/a)') 'Locus Updates', & '-------------- -------' do i=1, nvar j=fieldord(i) write(outstr,'(a14,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,a)') 'Failed to match ', unmatched, ' IDs.' end if call cleanup_hash(hashtab) end subroutine replacedata ! ! Prefix filnam ! 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 len1=len_trim(dirnam) 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 (dirnam(len1:len1) == slash) then filnam=dirnam(1:len1) // filnam(1:len2) else filnam=dirnam(1:len1) // slash // filnam(1:len2) 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 path from filnam ! subroutine extpath(filnam) character (len=*), intent(inout) :: filnam character (len=1) :: bslash='\' 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 integer :: i 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 ! ! Utility to count number of columns in a file ! simpler scanner than args ! subroutine countfields(fil, plevel) use outstream use fileio use scanner character (len=*), intent(in) :: fil 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, & narg, nchanges, nwords, maxwords, totwords logical :: 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. nl=.true. changepoints=0 longest=0 ilen=0 lpos=0 nlines=0 narg=0 nchanges=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) == '!')) cycle ! 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 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. exit wordloop 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) 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/a,i0,a,2(/a,i0)/a,l1)') & 'Number of lines = ', nlines, & 'Length of longest line = ', longest, ' chars', & 'Total number of words = ', totwords, & 'Maximum words per line = ', maxwords, & 'Constant word count per line? = ', (nchanges == 1) 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 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 :: eos, iskip, narg, nchosen, nrec, sta logical :: printn integer, dimension(nwords) :: chosen character (len=256) :: fil, fstring, sstring logical :: isreal, success call getword(linbuf, nwords, fil) call open_port(fil, port, 'r', ioerr) if (ioerr == 0) then ! read the format, if present iskip=0 printn=.false. fstring=' ' sstring=' ' sta=3 do if (words(sta)(1:1) == '(') then fstring=words(sta) call getword(linbuf, sta, fstring) sta=sta+1 else if (words(sta)(1:1) == '/') then call getword(linbuf, sta, sstring) eos=len_trim(sstring) if (sstring(eos:eos) == '/') then sstring=sstring(2:(eos-1)) else sstring=sstring(2:eos) end if sstring='*' // trim(sstring) // '*' sta=sta+1 else if (words(sta)(1:1) == '+') then iskip=iskip+1 sta=sta+1 else if (words(sta) == 'NR') then printn=.true. sta=sta+1 else exit end if end do ! then column list nchosen=0 do i=sta, nwords-1 if (isreal(words(i))) then nchosen=nchosen+1 chosen(nchosen)=ival(words(i)) end if end do 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 end if if (plevel > 1) then write(outstr, '(3a)') 'Print format "', trim(fstring),'".' if (sstring /= ' ') then write(outstr, '(3a)') 'Searching for "', trim(sstring),'".' if (iskip > 0) then write(outstr, '(a,i0,a)') 'And skipping ', iskip, ' lines if found.' end if end if end if nrec=0 if (nchosen == 0) then if (sstring == ' ') then do call readline(port, linbuf, ios=ioerr) if (ioerr /= 0) exit nrec=nrec+1 if (printn) then write(outstr,fstring) nrec, trim(linbuf) else write(outstr,fstring) trim(linbuf) end if end do else do call readline(port, linbuf, ios=ioerr) if (ioerr /= 0) exit nrec=nrec+1 if (strfind(trim(sstring), trim(linbuf), 1)) then do i=1, iskip call readline(port, linbuf, ios=ioerr) if (ioerr /= 0) exit nrec=nrec+1 end do if (printn) then write(outstr,fstring) nrec, trim(linbuf) else write(outstr,fstring) trim(linbuf) end if end if end do end if else if (sstring == ' ') then do call readline(port, linbuf, ios=ioerr) if (ioerr /= 0) exit if (irupt > 0) exit narg=100 call args(linbuf, narg, words, 1) nrec=nrec+1 if (printn) then write(outstr,fstring) nrec,(trim(words(chosen(i))), i=1, nchosen) else write(outstr,fstring) (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 narg=100 nrec=nrec+1 if (strfind(trim(sstring), trim(linbuf), 1)) then do i=1, iskip call readline(port, linbuf, ios=ioerr) if (ioerr /= 0) exit nrec=nrec+1 end do call args(linbuf, narg, words, 1) if (printn) then write(outstr,fstring) nrec,(trim(words(chosen(i))), i=1, nchosen) else write(outstr,fstring) (trim(words(chosen(i))), i=1, nchosen) end if end if end do end if end if call close_port(port, ioerr) else write(*,'(3a)') 'Cannot open "', trim(fil), '".' end if end subroutine fprinter ! ! write Sib-pair locus declarations ! subroutine sibloci(ostr, nloci, loc, loctyp, outpos, map, locnotes) use interrupt use locus_types 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 double precision, dimension(nloci), intent(in) :: map character (len=40), dimension(nloci), intent(in) :: locnotes integer, parameter :: MISS = -9999 integer :: i, ltyp do i=1, nloci if (isactive(loctyp(i))) then ltyp=mod(loctyp(i), LOC_CMP) if (ismarker(ltyp)) then if (map(i) /= MISS) then write(ostr,'(3(a,1x),f12.6,1x,a)') & 'set locus', loc(i), typlloc(ltyp), map(i), trim(locnotes(i)) else write(ostr,'(3(a,1x),5x,a1,7x,a)') & 'set locus ', loc(i), typlloc(ltyp), '.', trim(locnotes(i)) end if else if (istrait(ltyp)) then write(ostr,'(3(a,1x),5x,a1,7x,a)') & 'set locus', loc(i), typlloc(ltyp), '.', trim(locnotes(i)) end if end if end do end subroutine sibloci ! ! 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 ! 5 = ASPEX ! 6 = MERLIN ! 7 = LOKI ! 8 = STRUCTURE ! 9 = SOLAR ! 11 = MORGAN ! 12 = Haploview ! 13 = PLINK ! subroutine wrmap(ostr, typ, mapf, nloci, loc, loctyp, locnotes, & nord, locord, group, map) use interrupt use outstream use scanner use locus_types integer, intent(in) :: ostr integer, intent(in) :: typ integer, intent(in) :: mapf integer, intent(in) :: nloci character (len=20), dimension(nloci), intent(in) :: loc integer, dimension(nloci), intent(in) :: loctyp character (len=40), dimension(nloci), intent(in) :: locnotes integer, intent(in) :: nord integer, dimension(nord), intent(in) :: locord character (len=2), dimension(nloci), intent(in) :: group double precision, dimension(nloci), intent(in) :: map integer, parameter :: MISS=-9999 integer :: i, k, narg logical :: frst character (len=21), dimension(1) :: tnam character (len=2) :: chr integer :: bpdist double precision :: dist ! functions logical :: isint, isreal integer :: ival double precision :: fval, invmap ! show map bpdist=0 dist=0.0d0 chr=' ' dir=MISS frst=.true. if (typ == 10) then write(outstr,'(/a//a/a)') & 'User specified marker map:', & 'Marker Pos (cM|Mbp) Theta Chrom' , & '----------- ------------ ----- -----' do k=1, nord i=locord(k) if (ismarker(loctyp(i)) .and. 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 if (ishaploid(loctyp(i))) then write(outstr,'(a15,f12.6,4x,a1,8x,a,3x,a)') & loc(i), map(i),'x' , group(i), trim(locnotes(i)) else write(outstr,'(a15,f12.6,f8.3,5x,a,3x,a)') & loc(i), map(i), invmap(dist,mapf), group(i), trim(locnotes(i)) end if dist=map(i) chr=group(i) else 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))) 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=1, nloci if (isactive(loctyp(i))) then if (frst) then frst=.not.frst else if (dist /= MISS .and. map(i) >= dist) 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 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=1, nloci if (isactive(loctyp(i))) then if (frst) then frst=.not.frst else if (dist /= MISS .and. map(i) >= dist) 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 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 ! 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, 2) if (isint(tnam(1))) then bpdist=ival(tnam(1)) else if (map(i) /= MISS) then bpdist=int(1.0d6*map(i)) end if write(ostr,'(a,i10)') loc(i), bpdist end if end do write(ostr,*) ! PLINK format else if (typ == 13) then chr='1 ' do i=1, nloci if (isactdip(loctyp(i))) then if (map(i) /= MISS) then if (group(i) /= ' ') chr=group(i) dist=map(i) narg=1 call args(locnotes(i), narg, tnam, 2) if (isint(tnam(1))) then bpdist=ival(tnam(1)) else bpdist=int(1.0d6*dist) end if end if write(ostr,'(a,1x,a,1x,f14.5,1x,i10)') & chr, loc(i), dist, bpdist end if end do write(ostr,*) 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, nloci, loc, loctyp) use locus_types 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) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp ! local variables integer :: 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 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 .or. loctyp(j) == LOC_CAT) then call onestripe(strm, i, 3, nwid, 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=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 ! 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) ! subroutine pedout(strm, header, pedmask, fieldsep, allsep, imp, nwid, ndec, & misval, nrc, skip, filter, & nloci, loc, loctyp, locpos, dataset) use interrupt use ped_class use locus_types 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) :: nwid integer, intent(in) :: ndec character (len=*), intent(in) :: misval integer, intent(in) :: nrc, skip, filter integer, intent(in) :: nloci character (len=*), 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=8) :: fdec, idec character (len=7) :: loc7, mis7 character (len=10) :: formid1, formid2, formid3, formid4 character (len=nwid) :: bigmiss character (len=3), dimension(4) :: name_formats integer, dimension(4) :: name_widths integer :: fin, g1, g2, i, j, nobs, pos, sta logical :: noimp double precision :: toobig, x interface subroutine pedhead(strm, typ, pedmask, name_widths, name_formats, nwid, & 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) :: nloci character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp end subroutine pedhead subroutine wrgtp(all1, all2, gtp, allsep, typ) integer, intent(in) :: all1 integer, intent(in) :: all2 character (len=*), intent(out) :: gtp character (len=1), intent(in) :: allsep integer, intent(in) :: typ end subroutine 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) toobig=dfloat(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)) // ')' if (strm == 6 .or. header > 1) then call pedhead(strm, header, pedmask, name_widths, name_formats, & nwid, 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) == 2) then write(strm,'(1x,a)',advance='no') 'f' else if (dataset%sex(i) == 1) then write(strm,'(1x,a)',advance='no') 'm' else write(strm,'(1x,a)',advance='no') trim(misval) end if end if ! phenotypes do j=1, nloci if (isactive(loctyp(j))) then write(strm,'(a)',advance='no') fieldsep 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 x=dataset%plocus(i,locpos(j)) 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 write(strm,fdec,advance='no') x 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 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, nttonum 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(dfloat(dataset%nped)))+1 write(name_formats(2), '(i3)') int(log10(dfloat(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. 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 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. 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_QUA) 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, imp, nwid, ndec, sep, allsep, misval, twinning, & twintype, nloci, loc, loctyp, locpos, nord, locord, dataset) use ped_class use locus_types implicit none integer, intent(in) :: strm integer, intent(in) :: typ 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 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 integer, intent(in) :: nord integer, intent(in) :: locord(nord) type (ped_data) :: dataset integer, parameter :: KNOWN=0, MISS=-9999 ! local variables logical :: noimp double precision :: toobig, value character (len=3) :: na character (len=7) :: famid, gtp, twinid character (len=10) :: fdec, idec character (len=20) :: loc20 integer :: currf, currm, fam, g1, g2, i, j, k, lpos, & ntwins, ped, prevtwin, twinship, twinidx ! functions logical :: isatwin fam=0 twinid=' ' prevtwin=0 twinship=0 noimp=(imp /= 2) na='NA' if (misval /= ' ') na=misval ! quantitative variable format toobig=dfloat(10**(nwid-ndec-1)) call wrform('f', nwid, ndec, fdec) call wrform('i', nwid, 0, idec) ! header if (typ == 1) then write(strm, '(9a)', advance='no') & 'ped',sep,'id',sep,'fa',sep,'mo',sep,'sex' else if (typ == 2) then write(strm, '(a)', advance='no') 'famid,id,fa,mo,sex,mztwin,hhid' na=' ' else if (typ == 3 .or. typ == 5) then write(strm, '(a)', advance='no') 'famid,id' na=' ' else if (typ == 4 .or. typ == 6) then write(strm, '(a)', advance='no') 'id' na=' ' else if (typ == 10) then na=' ' ! 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='.' end if ! ! variable names if (typ == 1) then do k=1, nord i=locord(k) if (isactive(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 (same_loctyp(loctyp(i), LOC_CODOM) .or. loctyp(i) == LOC_XLIN .or. & same_loctyp(loctyp(i), LOC_HAP)) 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))) 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))) 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 .and. 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 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 .and. dataset%plocus(i,twinning) > KNOWN) then ntwins=ntwins+1 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 do k=1, nord j=locord(k) 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(na) 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 value=dataset%plocus(i,locpos(j)) if (value /= MISS) then if (abs(value) <= toobig) then write(loc20, fdec) value else if (value == anint(value)) then write(loc20, idec) int(value) else write(loc20, '(g20.12)') value 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.0) 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, allsep, & trcoly, trcoln, trcolx, dataset) use ped_class implicit none integer, intent(in) :: strm integer, intent(in) :: trait integer, intent(in) :: gene character(len=1), intent(in) :: allsep ! Colours for affected, unaffected, missing character(len=*), intent(in) :: trcoly, trcoln, trcolx type (ped_data) :: dataset integer, parameter :: KNOWN=0, MISS=-9999 ! local variables character (len=7) :: gtp character (len=8) :: marriage, shap, shade character(len=8), dimension(3) :: 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' if (trcoln /= ' ') trait_colour(1)=trcoln if (trcoly /= ' ') trait_colour(2)=trcoly if (trcolx /= ' ') trait_colour(3)=trcolx 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/a/a/a/3a/a/)') 'digraph Ped_', dataset%pedigree(ped), ' {', & '# page = "8.2677165,11.692913" ;', 'ratio = "auto" ;', & 'mincross = 2.0 ;', '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 (observed(i, gene, dataset)) then call get_geno(i, gene, gen2, dataset, g1, g2) call wrgtp(g1, g2, gtp, allsep, 1) end if #if defined (WIN32) || defined (IFORT) || defined (NOESCAPE) write(strm,'(3a)', advance='no') 'label="\N\n', gtp, '"' #else write(strm,'(3a)', advance='no') 'label="\\N\\n', gtp, '"' #endif end if write(strm,'(3a)') ', regular=1,style=filled,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)) 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 ! ! Write out SNP-major data file with ! integer genotype encoding used by ROADTRIPS ! genotypes are -9,0,1,2 ! subroutine wrsnp(strm, trait, nloci, loc, loctyp, locpos, dataset) use ped_class use alleles_class use locus_types implicit none integer, intent(in) :: strm 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 type (allele_data) :: allele_buffer ! integer :: a2, g, g1, g2, gene, gen2, i, j, ped ! 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 ! 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 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 == 2) then a2=allele_buffer%allele_names(2) 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 if (observed(i, gene, dataset)) then call get_geno(i, gene, gen2, dataset, g1, g2) g=0 if (g1 == a2) g=g+1 if (g2 == a2) g=g+1 write(strm,'(1x,i2)', advance='no') g else write(strm,'(1x,i2)', advance='no') lmiss end if end if end do end if end do write(strm,*) end if end if end do end subroutine wrsnp ! ! Write out old-style PAP pedigree ! 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 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, num, ped, pedoffset, pos integer :: famcnt, famno, nex, nfam, sx ! 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 ! ii=pedoffset do i=1, num ii=ii+1 sx=1 if (dataset%sex(ii) == 2) sx=2 if (dataset%fa(ii) /= MISS .and. dataset%mo(ii) /= MISS) then 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 if 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 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 PLINK .bed format (also used by MENDEL 10.0+) ! subroutine wrbed(strm, filnam, trait, 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 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=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 real :: telapsed, ttaken(2) ! functions integer :: aval, ival double precision :: fval #if SUN real :: dtime telapsed=dtime(ttaken) #else call dtime(ttaken, telapsed) #endif 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%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 write(strm,'(a,1x,a,1x,f12.6,1x,i10,a3,1x,a3)') & trim(group(j)), loc(j), map(j), int(1000000*map(j)), 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 nobs=0 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then do i=dataset%num(ped-1)+1, dataset%num(ped) 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 do end if end do close(strm) ! ! write 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 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*dfloat(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') #if SUN telapsed=dtime(ttaken) #else call dtime(ttaken, telapsed) #endif write(slin, '(f20.2)') telapsed 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, totloc) use rngs implicit none integer, intent(in) :: strm integer, intent(in) :: nped integer, intent(in) :: ngen integer, intent(in) :: nminoff integer, intent(in) :: nmaxoff integer, intent(in) :: totloc 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 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,*) ped, i, ' x x ', sx(sex(i)), repeat(' x', totloc) else write(strm,*) ped, i, fa(i), mo(i), ' ', sx(sex(i)), repeat(' x', totloc) end if end do end do end subroutine simdata ! ! Write out data for particular pedigree or particular person ! subroutine showdata(fped, fid, larg, words, & nloci, loc, loctyp, locpos, & dataset, pedmask, nwid, ndec, misval, & fieldsep, allsep, pstyle) 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) :: 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, ndec character (len=*), intent(in) :: misval character (len=1), intent(in) :: fieldsep character (len=1), intent(in) :: allsep integer, intent(in) :: pstyle integer :: i, j, 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, & misval, nrc, skip, & filter, nloci, loc, loctyp, locpos, 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) :: nwid integer, intent(in) :: ndec character (len=*), intent(in) :: misval integer, intent(in) :: nrc, skip, filter integer, intent(in) :: nloci character (len=*), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data) :: dataset end subroutine pedout subroutine wrvert(nloci, loc, loctyp, locpos, & dataset, nwid, ndec, allsep) 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 type (ped_data) :: dataset integer, intent(in) :: nwid integer, intent(in) :: ndec character (len=1), intent(in) :: allsep 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 dataset%untyped(i)=.false. nrec=nrec+1 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, misval, & 0, 0, 2, nloci, loc, loctyp, locpos, dataset) ! write records vertically else if (pstyle == 4) then call wrvert(nloci, loc, loctyp, locpos, & dataset, nwid, ndec, allsep) ! 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 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=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, & dataset, nwid, ndec, allsep) 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 type (ped_data) :: dataset integer, intent(in) :: nwid integer, intent(in) :: ndec character (len=1), intent(in) :: allsep ! local variables integer, parameter :: MAXCOL=6, MISS=-9999 integer :: g1, g2, i, j integer :: nelig, nids integer, dimension(MAXCOL) :: idlist character (len=15) :: 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,'(a)', advance='no') 'Pedigree: ' do k=1, nids idx=idlist(k) gtp=dataset%pedigree(dataset%iped(idx)) call juststr('c',gtp,15) write(outstr,'(a1,a15)', advance='no') tabsep, gtp end do write(outstr,*) write(outstr,'(a)', advance='no') 'Person: ' do k=1, nids idx=idlist(k) gtp=dataset%id(idx) call juststr('c',gtp,15) write(outstr,'(a1,a15)', advance='no') tabsep, gtp end do write(outstr,*) write(outstr,'(a,1x,a)') repeat('-',10), repeat('-',15*nids) do j=1, nloci if (isactive(loctyp(j))) then write(outstr,'(a10)', 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), ' ', nwid, ndec) write(outstr,'(a1,a)', advance='no') tabsep, gtp end do 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 ! ! Decode genotype code ! subroutine decgtp(value, g1, g2) double precision, intent(in) :: value integer, intent(out) :: g1 integer, intent(out) :: g2 integer :: ival ival=int(value) g1=ival/1000 g2=mod(ival,1000) if (g1 < 0) then g1=10128+g1 g2=10128+g2 end if 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-10128 if (g2 > 10000) g2=g2-10128 encgtp=1000.0D0*dfloat(g1)+dfloat(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) then g1=g1-10128 g2=g2-10128 end if iencgtp=1000*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 :: isint integer :: ival val=MISS 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') then val=4.0d99 else if (chr == ' ') then continue else if (isint(chr)) then val=ival(chr) 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 write(chr,'(i2)') int(val) end if end subroutine decchr ! ! 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)') dfloat(100*num)/dfloat(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 ! ! Write out trait value to a string ! subroutine wrtrait(value, str, typ, catlabels, nwid, ndec) use locus_types use scanner double precision, intent(in) :: value character (len=*), intent(out) :: str integer, intent(in) :: typ character (len=*), intent(in) :: catlabels integer, intent(in) :: nwid, ndec integer, parameter :: MISS=-9999 integer :: g1, g2, slen double precision :: toobig character (len=10) :: fstring character (len=20) :: buffer if (value == MISS) then str=repeat(' ',nwid-ndec) // 'x' return end if str=' ' if (isactdip(typ)) then call decgtp(value, g1, g2) call wrgtp(g1, g2, str, '/', 1) else if (same_loctyp(typ, LOC_HAP)) then call decgtp(value, g1, g2) if (g1 == g2) then call wrall(g1, str) else call wrgtp(g1, g2, str, '/', 1) end if else if (typ == LOC_AFF) then call getlabel(value, catlabels, str) if (str == ' ') then str='y' if (value == 1.0d0) str='n' str=repeat(' ',nwid-ndec) // str(1:1) end if else if (typ == LOC_CAT) then call getlabel(value, catlabels, str) end if if (str == ' ') then slen=len(str) toobig=dfloat(10**(nwid-ndec-1)) if (value > toobig .or. & (value < 0.0d0 .and. -10.0d0*value > toobig)) then if (anint(value) == value) then call wrform('i', nwid, 0, fstring) write(buffer,fstring) int(value) else call wrform('g', nwid, ndec, fstring) write(buffer,fstring) value end if buffer=adjustl(buffer) if (len_trim(buffer) > slen) then str=buffer(1:(slen-1)) // '*' else str=buffer end if else if (anint(value) == value) then call wrform('i', min(nwid-ndec+1,slen), 0, fstring) write(str,fstring) int(value) else call wrform('f', slen, max(0, slen-nwid+ndec), fstring) write(str,fstring) value end if end if end if end if end subroutine wrtrait ! ! 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 ! subroutine wrgtp(all1, all2, gtp, allsep, typ) integer, intent(in) :: all1 integer, intent(in) :: all2 character (len=*), intent(out) :: gtp character (len=1), intent(in) :: allsep 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 write(sall,'(i3)') abs(all1) 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 write(sall,'(i3)') abs(all2) 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 else if (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 ! ! 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,'(a10,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 person ',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 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)=dfloat(ord(i)) end do else do i=1, num ii=ii+1 dataset%plocus(ii,trait)=dfloat(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 = ',dfloat(nobs)/dfloat(nped), & 'Mean pedigree depth = ',dfloat(totgen)/dfloat(nped) if (nped > onegen) then write(outstr,'(a,f10.1/a,f10.1)') & 'Mean size where >1 members = ', dfloat(nobs-onegen)/dfloat(nped-onemem), & 'Mean depth where >1 members= ', dfloat(totgen-onegen)/dfloat(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 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 subroutine csort(n, cx, iy) integer, intent(in) :: n character (len=*), intent(inout) :: cx(*) integer, intent(in out) :: iy(*) end subroutine csort 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 :: fa, gene, hapcon, htyp, 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), & dfloat(nproblems(j))/dfloat(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 A 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 ! subroutine testsex(sexcrit, sexmarker, 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 ! sexcrit=threshold for significant sex test double precision, intent(in) :: sexcrit character(len=20), intent(in) :: sexmarker 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, xgene, ygene 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 heterozygote call rate double precision :: zerr=0.001d0 ! work arrays integer, dimension(:), allocatable :: nxloci, nyloci, xhets double precision, dimension(:), allocatable :: sexrat interface subroutine gettrait(nam, typ1, typ2, nloci, loc, lochash, loctyp, trait, plevel) use outstream use locus_types use idhash_class character (len=20), intent(in) :: nam integer, intent(in) :: typ1 integer, intent(in) :: typ2 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(in) :: plevel end subroutine 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 ! classed=0 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 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 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 inconsist=inconsist+1 call wrgtp(g1, g2, sexgtp, '/', 1) 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 do end if end do end if end if end do 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('-',10), repeat('-',3), repeat('-',10), & repeat('-',14), repeat('-',8) if (sexpos /= MISS) write(outstr,'(2x,a)', advance='no') repeat('-',11) write(outstr,*) do i=1, dataset%nobs sexrat(i)=exp(sexrat(i))/(1.0D0+exp(sexrat(i))) 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 if (ygene > 0) then isex4=2 if (nyloci(i) > 0) isex4=1 classed(isex1, 3+isex4)=classed(isex1, 3+isex4)+1 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 (incon) then inconsist=inconsist+1 end if 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,a11,2x,a1,4x,f8.6,4x,i4,a,i4,10x,i4,5x,a)') & dataset%pedigree(dataset%iped(i)), dataset%id(i), sx, sexrat(i), & xhets(i), '/', nxloci(i), nyloci(i), sexgtp 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 deallocate(xhets) deallocate(nxloci) deallocate(nyloci) deallocate(sexrat) end subroutine testsex ! ! 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 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*dfloat(den-con)/dfloat(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,'(a10, 1x, i5, 1x, i5, 2x, f6.4)') & loc(idx(k)), err(k), tot(idx(k)), dfloat(err(k))/dfloat(tot(idx(k))) end if end if end if end do if (sexdis > 0) then write(outstr,'(a10, 1x, i5, 1x, i5, 2x, f6.4)') & 'SEX', sexdis, npairs, dfloat(sexdis)/dfloat(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,i5,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, nloci, loc, loctyp, locpos, & dataset, plevel) use interrupt use outstream use ped_class use locus_types implicit none integer, intent(in) :: typ integer, intent(in) :: mztrait 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, MINTYP=10, MISS=-9999 integer :: nmark integer, dimension(:), allocatable :: mark logical :: istwin double precision :: mistyping integer :: g1, g2, g3, g4, gene, i, j, k, & nonmatch, nfailure, npairs, ped, pedoffset, mztwin, typed mztwin=0 if (typ == 1 .and. mztrait /= MISS) mztwin=locpos(mztrait) mistyping=0.005d0 npairs=0 call cntmark(nloci, loctyp, nmark, 1) if (nmark == 0) then write(outstr,'(a)') & 'No usable markers for diagnosis of MZ twins/duplicates!' return end if nfailure=max(min(nmark,10), int(mistyping*dfloat(nmark))) allocate(mark(nmark)) nmark=0 do k=1, nloci if (isactdip(loctyp(k))) then nmark=nmark+1 mark(nmark)=locpos(k) end if end do typed=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) do k=1, nmark if (observed(i, mark(k), dataset)) then typed=typed+1 if (typed >= MINTYP) then dataset%untyped(i)=.false. exit end if end if end do end do ind end if end do if (plevel > -2) then write(outstr,'(3(/a),2(/a,i0)/a,i0,a,f5.3,a)') & '------------------------------------------------', & 'Searching for likely MZ twin pairs or duplicates', & '------------------------------------------------', & 'Maximum number of marker loci = ', nmark, & 'Number of individuals tested = ', typed, & 'Threshold for nonidentity = ', nfailure, & ' markers (', dfloat(nfailure)/dfloat(nmark), ')' if (mztwin /= 0) then write(outstr,'(3a)') & 'Writing MZ twin indicator to "', trim(loc(mztrait)), '".' end if if (plevel > 0) then if (typ == 1) then write(outstr,'(/a,7x,a,10x,a,10x,a)') & 'Pedigree', 'ID1', 'ID2', 'Concordance' else write(outstr,'(/2(a,7x,a,10x),a)') & 'Ped1', 'ID1', 'Ped2', 'ID2', 'Concordance' end if end if end if 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 call mztest(i, j, nmark, mark, dataset, nfailure, nonmatch, & typed, istwin) if (istwin .and. typed > 10) then if (dfloat(nonmatch)/dfloat(typed) <= mistyping) then npairs=npairs+1 if (mztwin /= 0) then dataset%plocus(i,mztwin)=1 dataset%plocus(j,mztwin)=1 end if if (plevel > 0) then write(outstr,'(a14,2(1x,a12),1x,i0,a1,i0,a,f6.4,a)') & dataset%pedigree(ped), dataset%id(i), dataset%id(j), & typed-nonmatch, '/', typed, & ' (', dfloat(typed-nonmatch)/dfloat(typed), ')' end if end if end if end if end do rel end if end do end if end do if (plevel > 0) write(outstr,*) write(outstr,'(a,i0)') 'Total putative MZ pairs = ', npairs else do i=1, dataset%nobs if (.not.dataset%untyped(i)) then do j=i+1, dataset%nobs if (.not.dataset%untyped(j)) then call mztest(i, j, nmark, mark, dataset, nfailure, nonmatch, & typed, istwin) if (plevel > 1) then write(outstr,'(2(a14,1x,a12),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, & ' (', dfloat(typed-nonmatch)/dfloat(typed), ')' end if if (istwin .and. typed > 10) then if (dfloat(nonmatch)/dfloat(typed) <= mistyping) then npairs=npairs+1 if (plevel > 0) then write(outstr,'(2(a14,1x,a12),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, & ' (', dfloat(typed-nonmatch)/dfloat(typed), ')' end if end if end if end if end do end if end do if (plevel > 0) write(outstr,*) write(outstr,'(a,i0)') 'Total putative duplicates = ', npairs 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 ! ! 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 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 ! functions double precision :: tojulian 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 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 :: 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 z=sqrt(mibs)+sqrt(mibs+1)-sqrt(4*ex+1) mibs=mibs/dfloat(den) ex=ex/dfloat(den) call moment(npairs, mibs, mean, var) write(outstr,'(a,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 ! EM algorithm of Choi et al Genet Epidemiol 33:668-678 ! Either founders only (typ=1), all individuals (typ=2), ! within pedigrees (typ=3), or subsetted on a phenotype (typ=4) ! 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 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 type (allele_data), dimension(:), pointer :: alleles ! coefficients to estimate kinship coefficients from IBS integer :: nmark 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 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, nmark, mark, locpos, alleles, dataset, useful, ibscoef) use outstream use alleles_class use ped_class use locus_types integer, intent(in) :: peri, perj integer, intent(in) :: nmark integer, dimension(nmark) :: mark integer, dimension(:), intent(in) :: locpos type (allele_data), dimension(:), pointer :: alleles type (ped_data), intent(in) :: dataset integer, intent(out) :: useful double precision, dimension(nmark,3), intent(out) :: ibscoef end subroutine ibskin_one end interface ! nmark=0 do j=1, nloci if (same_loctyp(loctyp(j), LOC_CODOM)) then nmark=nmark+1 end if end do allocate(mark(nmark)) allocate(alleles(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 > 1 .and. allele_buffer%typed > 0) then nmark=nmark+1 mark(nmark)=j call freq(locpos(j), loctyp(j), 0, dataset, alleles(nmark)) end if 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/)') & '----------------------------------------------------', & 'IBS based kinship estimates', & '----------------------------------------------------' if (typ == 4 .and. trait /= MISS) then write(outstr,'(3a)') 'Subsetting on "', trim(loc(trait)), '".' call defpro(gt, thresh) 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, nmark, mark, locpos, alleles, dataset, useful, ibscoef) if (useful > 0) then call emibskin(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 ! 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, nmark, mark, locpos, alleles, dataset, useful, ibscoef) if (useful > 0) then call emibskin(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 end do end if end do deallocate(kin) end if deallocate(ibscoef) deallocate(alleles) end subroutine ibskin ! ! Estimate kinship coefficients based on overall ibs sharing ! One pair of relatives ! subroutine ibskin_one(peri, perj, nmark, mark, locpos, alleles, dataset, useful, ibscoef) use outstream use alleles_class use ped_class use locus_types implicit none integer, intent(in) :: peri, perj integer, intent(in) :: nmark integer, dimension(nmark) :: mark integer, dimension(:), intent(in) :: locpos type (allele_data), dimension(:), pointer :: alleles type (ped_data), intent(in) :: dataset integer, intent(out) :: useful double precision, dimension(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, nmark gene=locpos(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(k)) ! State 2 if (g1 /= g3) then istate=2 p3=getfreq(g3, 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(k)) p2=getfreq(g2, 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(k)) p4=getfreq(g4, 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(k)) p4=getfreq(g4, alleles(k)) else p3=getfreq(g4, alleles(k)) p4=getfreq(g3, 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(k)) p2=getfreq(g3, alleles(k)) p3=getfreq(g4, alleles(k)) else p1=getfreq(g3, alleles(k)) p2=getfreq(g1, alleles(k)) p3=getfreq(g2, 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(k)) if (g1 == g3) then p2=getfreq(g4, alleles(k)) else p2=getfreq(g3, alleles(k)) end if else p1=getfreq(g3, alleles(k)) if (g1 == g3) then p2=getfreq(g2, alleles(k)) else p2=getfreq(g1, 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 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 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/dfloat(nused) k1=est1/dfloat(nused) k2=est2/dfloat(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 ! ! Find closest match of genotypes between index person and all other ! active individuals ! subroutine genmatch(tped, tid, nloci, loc, loctyp, locpos, dataset) 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) :: nloci character(len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data), intent(inout) :: dataset ! local integer, parameter :: MISS=-9999, KNOWN=0 integer :: nmark integer :: geno(nloci, 2), ord(nloci) integer :: g1, g2, highest, i, ibs(3), j, nhet, nid, nmatch, nped, ped, thisped character (len=1) :: sx character (len=7) :: gtp ! functions ! logical :: strfind interface subroutine cntibs(idx, nmark, geno, ord, locpos, dataset, nmatch, ibs) use ped_class integer, intent(in) :: idx integer, intent(in) :: nmark integer, dimension(:,:), intent(in) :: geno integer, dimension(:), intent(in) :: ord integer, dimension(:), intent(in) :: locpos type (ped_data), intent(in) :: dataset integer, intent(out) :: nmatch integer, intent(out) :: ibs(3) end subroutine cntibs end interface write(outstr,'(/a/4a/a)') & '------------------------------------------------------------', & 'Genetic (IBS) similarity to ', trim(tped),'--', trim(tid), & '------------------------------------------------------------' ! ! find the index case nhet=0 nmark=MISS thisped=0 nped=0 nid=0 search: do ped=1, dataset%nped if (dataset%actset(ped) > 0) then if (strfind(tped, dataset%pedigree(ped), 1)) then do i=dataset%num(ped-1)+1, dataset%num(ped) if (strfind(tid, dataset%id(i), 1)) then thisped=ped nid=i nmark=0 do j=1, nloci if (isactdip(loctyp(j)) .and. observed(i, locpos(j), dataset)) then nmark=nmark+1 ord(nmark)=j call get_geno(i, locpos(j), locpos(j)+1, dataset, & geno(nmark,1), geno(nmark,2)) if (geno(nmark,1) /= geno(nmark,2)) nhet=nhet+1 end if end do exit search end if end do end if end if end do search if (nmark <= 0) then if (nmark == MISS) then write(outstr,'(5a)') 'ERROR: Target individual ', & trim(tped),'--', trim(tid), ' not found!' else write(*,'(5a)') 'ERROR: Target individual ', & trim(tped),'--', trim(tid), & ' has no nonmissing marker genotypes.' end if return end if ! ! print out IBS of proband with rest of family write(outstr,'(5a,i5,a,f5.1,a/)') & 'Target individual ', trim(tped),'--', trim(tid), & ' is genotyped at ', nmark, ' markers (heterozygous at ', & dfloat(100*nhet)/dfloat(nmark),'%).' write(outstr,'(a,7(1x,a7):)') 'Pedigree Individual Sex ibs2 ibs1 ibs0 ', & (loc(ord(j)), j=1, min(nmark,6)) call wrsex(dataset%sex(nid),sx) write(outstr,'(2a,1x,a1,1x,a,$)') tped(1:10), tid, sx, ' - - -' do j=1, min(nmark, 6) call wrgtp(geno(j,1), geno(j,2), gtp, '/', 1) write(outstr,'(1x,a7,$)') gtp end do write(outstr,*) highest=0 do i=dataset%num(thisped-1)+1, dataset%num(thisped) if (i /= nid) then call cntibs(i, nmark, geno, ord, locpos, dataset, nmatch, ibs) if (nmatch > highest) highest=nmatch call wrsex(dataset%sex(i),sx) write(outstr,'(2a,1x,a1,1x,3i6)', advance='no') & dataset%pedigree(thisped)(1:10), dataset%id(i), & sx, ibs(3), ibs(2), ibs(1) do j=1, min(nmark, 6) call get_geno(i, locpos(ord(j)), locpos(ord(j))+1, dataset, g1, g2) call wrgtp(g1, g2, gtp, '/', 1) write(outstr,'(1x,a7)', advance='no') gtp end do write(outstr,*) end if end do write(outstr,*) ! ! print out incrementally best matches from other pedigrees ! do ped=1, dataset%nped if (dataset%actset(ped) > 0 .and. ped/=thisped) then do i=dataset%num(ped-1)+1, dataset%num(ped) call cntibs(i, nmark, geno, ord, locpos, dataset, nmatch, ibs) if (nmatch > highest) then highest=nmatch call wrsex(dataset%sex(i),sx) write(outstr,'(2a,1x,a1,1x,3i6)', advance='no') & dataset%pedigree(ped)(1:10), dataset%id(i), sx, & ibs(3), ibs(2), ibs(1) do j=1, min(nmark, 6) call wrgtp(int(dataset%plocus(i,locpos(ord(j)))), & int(dataset%plocus(i,locpos(ord(j))+1)), gtp, '/', 1) write(outstr,'(1x,a7)', advance='no') gtp end do write(outstr,*) end if end do end if end do end subroutine genmatch ! ! IBS at specified set of markers ! subroutine cntibs(idx, nmark, geno, ord, locpos, dataset, nmatch, ibs) use ped_class integer, intent(in) :: idx integer, intent(in) :: nmark integer, dimension(:,:), intent(in) :: geno integer, dimension(:), intent(in) :: ord integer, dimension(:), intent(in) :: locpos type (ped_data), intent(in) :: dataset integer, intent(out) :: nmatch integer, intent(out) :: ibs(3) integer, parameter :: KNOWN=0 integer :: g1, g2, gene, j, nibs nmatch=0 ibs(1)=0 ibs(2)=0 ibs(3)=0 do j=1, nmark gene=locpos(ord(j)) if (observed(idx, gene, dataset)) then nibs=2 call get_geno(idx, gene, gene+1, dataset, g1, g2) if (g1 == geno(j,1) .and. g2 == geno(j,2)) nibs=3 if (g1 == geno(j,2) .and. g2 == geno(j,1)) nibs=3 if (g1 /= geno(j,1) .and. g2 /= geno(j,2) .and. & g1 /= geno(j,2) .and. g2 /= geno(j,1)) nibs=1 ibs(nibs)=ibs(nibs)+1 nmatch=nmatch+nibs-1 end if end do end subroutine cntibs ! ! 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 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, 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 (nobs > 0) then ! Additive genetic effects call kinship(ped, dataset, a) call thincov(num, nobs, active, a) call syminv(a, nobs, ainv, logdet, i) if (i /= 0) then write(outstr,'(a,i0)') & 'ERROR: Problem inverting kinship matrix, nobs=', nobs if (nobs < 11) then ii=0 do j=1, nobs write(outstr,'(7x,10(1x,f6.4):)') a((ii+1):(ii+j)) ii=ii+j end do end if end if 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*dfloat(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 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 afreq=ns(i)/ds(i) 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), afreq, sqrt(0.5d0*afreq*(1.0d0-afreq)/ds(i)) end do write(outstr,*) end if topfrq=0.0d0 do i=1, allele_buffer%numal allele_buffer%allele_freqs(i)=ns(i)/ds(i) if (allele_buffer%allele_freqs(i) > topfrq) then topfrq=allele_buffer%allele_freqs(i) allele_buffer%topall=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 subroutine bluefreq ! ! MQLS of Bourgain et al 2003, Thornton et al 2007 ! subroutine domqls(typ, trait, gt, thresh, gene, locnam, prev, 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 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, iall, 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, z, zmax ! 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 double precision :: cs, ds1, ds2, v_wqls ! 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 call phist(pval, 1.0d0, histo) write(outstr,'(a14,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 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(dataset%maxact-nunobs)=0.0d0 if (aff == 2) then ymqls(dataset%maxact-nunobs)=1.0d0 else if (aff == 1) then ymqls(dataset%maxact-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 syminv(a, nobs, ainv, logdet, i) if (i /= 0) then write(outstr,'(a,i0)') & 'NOTE: Problems inverting kinship matrix, nobs=', nobs ii=0 do j=1, min(10,nobs) write(outstr,'(7x,10(1x,f6.4):)') a((ii+1):(ii+j)) ii=ii+j end do write(outstr,'(a)') & 'Utilizing approximate inverse kinship matrix.' call gibinv(a, nobs, ainv, logdet, 20) end if ! 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 quadmult(1, nobs, ones, 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 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 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*dfloat(g) totall(iall)=totall(iall)+g if (dataset%plocus(ii,trait) == 2) casall(iall)=casall(iall)+g end if end do ! null call quadmult(2, nobs, xval, ainv, a1) ns(1,iall)=ns(1,iall)+a1 ! WQLS alternative call quadxy(nobs, yval, ainv, xval, alt1) ns(2,iall)=ns(2,iall)+alt1 ! MQLS alternative do j=1, nobs ns(3,iall)=ns(3,iall)+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) == iall) g=g+1 if (set(i,2) == iall) g=g+1 xval(nobs)=0.5d0*dfloat(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/dfloat(max(iter,1)) call wrall(allele_buffer%allele_names(iall), 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(dfloat(tailp)/dfloat(iter)), iter end if end if end do end if totobs=totobs+nobs end if end do ! ! CorrX2 correction corzero=dfloat(totobs-totaff)/dfloat(totobs*totaff) corfact=term1/dfloat(totaff*totaff) - & 2*term2/dfloat(totobs*totaff) + & term3/dfloat(totobs*totobs) v_mqls=(mds1/mds2/mds2-1.0d0/ds1) v_wqls=(cs/ds2/ds2-1.0d0/ds1) zmax=0.0d0 if (plevel > 0) then 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 v=0.5d0*afreq*(1-afreq)*v_wqls z=(cfreq-afreq)/sqrt(v) ! MQLS variance mfreq=ns(3,i)/mds2 vm=0.5d0*afreq*(1-afreq)*v_mqls zm=(mfreq-afreq)/sqrt(vm) if (abs(zm) > abs(zmax)) zmax=zm ! CorrX2 variance afreq1=0.5d0*dfloat(totall(i))/dfloat(totobs) cfreq1=0.5d0*dfloat(casall(i))/dfloat(totaff) corvar=0.5d0*afreq*(1-afreq)*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 if (typ == 1) then cstat='MQLS' chi2=zmax*zmax pval=bonf(allele_buffer%numal-1, chip(chi2, 1)) else if (typ == 2) then cstat='WQLS' chi2=zm*zm pval=chip(chi2, 1) end if if (plevel == -1 .or. plevel == 0) then call phist(pval, 1.0d0, histo) write(outstr,'(a14,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 end if end subroutine domqls ! ! WQLS association chi-square ! extending Bourgain et al 2003 to categorical traits with more than 2 levels ! subroutine corchi(trait, loctyp, gene, locnam, prev, dataset, & allele_buffer, iter, pval, plevel) use ped_class use alleles_class use locus_types use outstream use symmetric_matrix use contingency_table use rngs use statfuns integer, intent(in) :: trait integer, intent(in) :: loctyp integer, intent(in) :: gene character (len=*) :: locnam double precision, intent(in) :: prev 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 :: astat, df, g, g1, g2, gen2, gpos, i, ii, ilev, j, k, 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 :: fulla 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 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 ! gen2=gene+1 nmiss=0 nuntyp=0 totobs=0 call setup_table(1, 30, traittable) do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) do ii=pedoffset+1, dataset%num(ped) dataset%untyped(ii)=.true. if (dataset%plocus(ii,trait) /= MISS) then if (observed(ii, gene, dataset)) then totobs=totobs+1 dataset%untyped(ii)=(dataset%imztwin(ii) /= MISS) 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,'(a14,2(a1,i6),a1,f10.1,3(a1,a))') & locnam, tabsep, totobs, tabsep, ncats+1, tabsep, & 0.0d0, tabsep, '-', 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) ! ! kinships ! 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 ! ! score statistic calculations ! nn=traitcols*(traitcols+1)/2 allocate(genos(dataset%maxact, ncats)) allocate(phenos(dataset%maxact, traitcols)) 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 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 (.not.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, fulla) a=fulla call thincov(num, nobs, active, a) call syminv(a, nobs, ainv, logdet, i) if (i /= 0) then write(outstr,'(a,i0)') & 'NOTE: Problems inverting kinship matrix, nobs=', nobs call printmat(min(10,nobs), a, '(7x,10(1x,f6.4):)') write(outstr,'(a)') & 'Utilizing approximate inverse kinship matrix.' call gibinv(a, nobs, ainv, logdet, 20) end if nobs=0 ii=pedoffset do i=1, num ii=ii+1 phenos(i,1:traitcols)=0.0d0 genos(i,1:ncats)=0.0d0 if (active(i)) 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, num do j=1, ncats genos(i,j)=genos(i,j)-allele_buffer%allele_freqs(j) end do end do ! ! S = u2' I21~ u2 ! I21 = U22-(U21' U11~ U21) ! ! u11 = ones Ainv ones call sumsym(nobs, ainv, fam_u11) u11=u11+fam_u11 ! u2 = phenos' Ainv genos call quadxym(nobs, traitcols, ncats, phenos, ainv, genos, fam_uscore) uscore=uscore+fam_uscore ! u12 = 1' Ainv phenos call quadxy1(nobs, traitcols, ainv, phenos, fam_u12) u12=u12+fam_u12 ! u22 = phenos' Ainv phenos call quadxym(nobs, traitcols, traitcols, phenos, ainv, phenos, fam_u22) u22=u22+fam_u22 ! if (plevel > 1) then ! write(*,*) ! write(*,*) 'Pedigree ', trim(dataset%pedigree(ped)) ! write(*,*) ! write(*,*) 'u2=', fam_uscore ! write(*,*) 'u11=', fam_u11 ! write(*,*) 'u12=', fam_u12 ! write(*,*) 'u22=', fam_u22 ! write(*,*) ! end if end if end if end do ! 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,i5,1x,f8.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, & ' WQLS 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,'(a14,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 ! ! 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 :: topfrq, 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=dfloat(dataset%nfound(ped))/dfloat(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/dfloat(max(1,totall)) else if (act == 1) then wei=1.0d0/dfloat(tfound) else if (act == 2) then wei=1.0d0/dfloat(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 topfrq=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) > topfrq) then topfrq=allele_buffer%allele_freqs(i) allele_buffer%topall=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=(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 20 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=2), intent(in) :: group double precision, intent(in) :: mappos character (len=40), 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=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 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) write(outstr,'(4x,a4,5x,f6.4,4x,i5,2x,20a1:)') & allel,allele_buffer%allele_freqs(i), & 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=dfloat(allele_buffer%totall)/dfloat(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=dfloat(allele_buffer%totall)/dfloat(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,'(a14,a1,i4,a1,1x,a4,a8,2(a1,f6.4),a1,i6,a1,a25)') & locnam, tabsep, 2, tabsep, allel, mentyp, & tabsep, allele_buffer%allele_freqs(i), & tabsep, corr*het, tabsep, allele_buffer%typed, tabsep, trim(adjustl(locnote)) exit end if end do ! other else if (allele_buffer%typed == 0) then write(outstr,'(a14,a1,3x,a1,a1,1x,a1,13x,a1,a1,5x,a1,a1,5x,a1,3x,a1,a1,a25)') & 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,'(a14,a1,i4,a1,1x,a4,8x,2(a1,a6),a1,i6,a1,a25)') & 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,'(a14,a1,i4,a1,1x,a4,a2,a4,2x,a1,a6,a1,f6.4,a1,i6,a1,a25)') & 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,'(a,1x,2a/a)') '3 2 #',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,' # ',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*dfloat(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*dfloat(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=int(1.0d6*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(outstr, '(a)', advance='no') ' ' do i=1, allele_buffer%numal if (pos>80) then pos=8 write(outstr, '(/a)', advance='no') ' ' end if call wrall(allele_buffer%allele_names(i), allel) write(outstr, '(1x,2a,f6.4)', advance='no') & trim(adjustl(allel)),'=', allele_buffer%allele_freqs(i) pos=len_trim(allel)+8 end do write(outstr,*) end if end subroutine wrfreq ! ! 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=10), parameter :: chrom='chromosome' 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 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=*) :: chr if (chr == ' ') then chrnum=0 else if (chr == 'X') then chrnum=123 else if (chr == 'Y') then chrnum=124 else read(chr, '(i2)') chrnum end if 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, topfrq, 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 topfrq=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 > topfrq) then topfrq=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=(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=(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 each locus ! subroutine actped(typ, red, pedfil, nloci, loc, loctyp, locpos, & outpos, locnotes, typed, dataset, plevel) use interrupt use outstream use ped_class use locus_types 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=*), dimension(:), intent(in out) :: locnotes integer, dimension(:), intent(inout) :: typed 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 real :: percent logical :: show character (len=1) :: ch character (len=8) :: wtype double precision :: meanval double precision, dimension(1) :: val ! functions double precision :: dataset_uses interface subroutine cntmark(nloci, loctyp, nmark, typ) integer, intent(in) :: nloci integer, dimension(nloci), intent(in) :: loctyp integer, intent(out) :: nmark integer, intent(in) :: typ end subroutine subroutine cntclasses(nloci, loctyp) integer, intent(in) :: nloci integer, dimension(nloci), intent(in) :: loctyp end subroutine 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 meanval=0.0d0 if (typ == 1) then call cntmark(nloci, loctyp, nmark, 2) write(outstr,'(3a/a,i7,a,i7)') & 'Pedigree file = "', trim(pedfil),'"', & 'Number of active loci = ',nmark,' of ',nloci 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,i7,a,i7))') & 'Number of active peds = ', dataset%nact , ' of ', dataset%nped, & 'Number of active inds = ',tnum , ' of ', size(dataset%id) write(outstr,'(a,i7)') & 'Largest active ped size = ', dataset%maxact write(outstr,'(a,f7.1,a)') & 'Dataset occupies = ', dataset_uses(dataset), ' Mb' end if call cntclasses(nloci, loctyp) if (typ > 1 .or. plevel > 0 .or. (plevel >= 0 .and. nloci < 100)) then call setup_table(1, 100, table) wtype='Typed' if (typ == 4) wtype='Missing' call coutyp(nloci, loctyp, locpos, dataset, tnum, typed) write(outstr,'(/2a/a)') & 'Locus Type Position ', wtype, & '---------- ---- ---------------- ------------' do j=1, nloci ltyp=loctyp(j) if (typ < 3) then show=isactive(ltyp) else show=.true. end if if (ismarker(ltyp) .and. show) then ltyp=mod(ltyp, LOC_DEL) if (.not.isactive(loctyp(i))) ltyp=12 if (typ < 4) then nt=typed(j) else nt=tnum-typed(j) end if val(1)=dfloat(nt) call insert_table(1, val, table, 1) percent=100.0*float(nt)/float(tnum) write(outstr,'(a10,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)) else if (istrait(ltyp) .and. show) then ltyp=mod(ltyp, LOC_DEL) if (.not.isactive(loctyp(i))) ltyp=12 if (typ < 4) then nt=typed(j) else nt=tnum-typed(j) end if val(1)=dfloat(nt) call insert_table(1, val, table, 1) percent=100.0*float(nt)/float(tnum) write(outstr,'(a10,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 if (irupt /= 0) exit end do call sort_table(1, 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+dfloat(nt)*table%categories(j,1) write(outstr,'(i12,i8,2x,f5.3)') & int(table%categories(j,1)), nt, & dfloat(cumn)/dfloat(max(1,table%ntot)) end do else do j=1, table%ncells nt=table%icount(j) meanval=meanval+dfloat(nt)*table%categories(j,1) end do end if meanval=meanval/dfloat(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,max(1, 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 = ', dfloat(dataset%nobs)/dfloat(max(1,dataset%nped)) if (onemem>0 .and. dataset%nped > onemem) then write(outstr,'(a,f12.1)') & 'Mean size where >1 members = ', dfloat(dataset%nobs-onemem)/dfloat(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(dataset, typ) use outstream use ped_class type (ped_data) :: dataset integer, intent(in) :: typ integer :: eop, ped, pos if (typ == 1) then write(outstr,'(/a)') 'Pedigrees:' pos=1 do ped=1, dataset%nped 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 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 listids(dataset, ithresh, plevel) use outstream use ped_class type (ped_data) :: dataset integer, intent(in) :: ithresh ! threshold for printing record integer, intent(in) :: plevel 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 idlen=2 nactive=0 nids=0 do ped=1, dataset%nped if (dataset%actset(ped)>0) then nactive=nactive+dataset%num(ped)-dataset%num(ped-1) person: do i=dataset%num(ped-1)+1, dataset%num(ped) idlen=max(idlen, len_trim(dataset%id(i))) hi=nids lo=1 pos=lo search: do while (hi >= lo) pos=(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 if (plevel>0 .or. nids<20) 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 ! ! Table of number of markers per chromosome ! subroutine listchroms(nloci, loctyp, group) use outstream use locus_types use contingency_table integer, intent(in) :: nloci integer, dimension(nloci), intent(in) :: loctyp character (len=2), dimension(nloci), intent(in) :: group type (table_data) :: table integer :: i, j character (len=2) :: lev double precision, dimension(1) :: val call setup_table(1, 5, table) do i=1, nloci if (ismarker(loctyp(i))) then call encchr(group(i), val(1)) call insert_table(1, val, table, 1) end if end do write(outstr,'(a)') 'Chrom Count' do i=1, table%ncells call decchr(table%categories(table%idx(i),1), lev) write(outstr,'(3x,a2,1x,i6)') lev, table%icount(i) end do end subroutine listchroms ! ! 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, dataset, & droperr, ndiscard, inconsist, plevel) use outstream use ped_class use locus_types 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=*), dimension(:), intent(in) :: locnotes 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, & p11, p12, p21, p22, sta integer :: bad1, bad2, badchild, errthresh, errtyp, tottyp integer :: ptyped logical :: ferr, pederr, thiserr, xlinkd 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,1) allocate(locus_index(nmark), locus_errors(nmark)) imark=0 tottyp=0 do j=1, nloci if (isactdip(loctyp(j))) then imark=imark+1 locus_index(imark)=j locus_errors(imark)=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) imark=0 do j=1, nloci if (isactdip(loctyp(j))) then imark=imark+1 ferr=.false. pederr=.false. xlinkd=(loctyp(j) == LOC_XLIN) badchild=MISS gene=locpos(j) gen2=gene+1 nkids=0 ptyped=0 currf=MISS currm=MISS ! Check for male X-linked heterozygotes 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,'}' call set_geno(i, gene, gen2, dataset, MISS, MISS) inconsist=inconsist+1 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 ((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 if end do end if 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 > 1 .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,'(a10,5x,i5,3x,f5.1,a)') & dataset%pedigree(family_index(ped)), family_errors(ped), & 100.0d0*family_errors(ped)/dfloat(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,'(a10,5x,i5,3x,f5.1,a,1x,a)') & loc(locus_index(imark)), locus_errors(imark), & 100.0d0*locus_errors(imark)/dfloat(dataset%nped), '%', & locnotes(locus_index(imark)) end if imark=imark-1 end do write(outstr,*) 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 person ', 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 person ', 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 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 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/dfloat(n)+28.2878d0/dfloat(n*n) b2=0.15984004d0 else a=1.1675d0+3.3232d0/dfloat(n)+63.698d0/dfloat(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 ! 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 ! 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 ! ! 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 + dfloat(16*size(dataset%iped)) dataset_uses=dataset_uses + dfloat(int(id_width)*size(dataset%id)) dataset_uses=dataset_uses + dfloat(8*size(dataset%plocus)) dataset_uses=dataset_uses + dfloat(2*size(dataset%glocus)) if (dataset%hassnps /= 0) then dataset_uses=dataset_uses + dfloat(matrix_size(dataset%slocus)) end if dataset_uses=dataset_uses + dfloat(int(ped_width)*size(dataset%pedigree)) dataset_uses=dataset_uses + dfloat(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 + dfloat(16*size(dataset%iped, kind=8)) dataset_uses=dataset_uses + dfloat(int(id_width, kind=8)*size(dataset%id, kind=8)) dataset_uses=dataset_uses + dfloat(8*size(dataset%plocus, kind=8)) dataset_uses=dataset_uses + dfloat(2*size(dataset%glocus, kind=8)) if (dataset%hassnps /= 0) then dataset_uses=dataset_uses + dfloat(matrix_size(dataset%slocus)) end if dataset_uses=dataset_uses + dfloat(int(ped_width, kind=8)*size(dataset%pedigree, kind=8)) dataset_uses=dataset_uses + dfloat(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 (commands(pos:pos)=='\') then 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 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, sta character (len=20), dimension(:), allocatable :: words character (len=20) :: token eol=len_trim(lin) i=1 sta=0 fin=0 do while (i <= eol) if (lin(i:i)=='\') then 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 narg=countargs(lin((sta+1):(fin-1)), 1) allocate(words(narg)) call args(lin((sta+1):(fin-1)), narg, words, 1) ! Special treatment for a locus list -- expand first if *sole* iterator if (narg==1 .and. words(1)(1:1)=='$') then j=0 j=loccode(words(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(words) 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 end if end if if (plevel > 1) then do i=1, narg write(outstr,*) i, 'th iterator value: "', trim(words(i)), '"' end do end if do i=narg, 1, -1 token=words(i) if ((sta+len_trim(token)+eol-fin) <= len(commands)) then commands = lin(1:(sta-1)) // trim(token) // & lin((fin+1):eol) // ';' // trim(commands) else write(outstr,'(a)') 'ERROR: Command buffer exhausted' exit end if end do else narg=countargs(lin, 1) if (narg==2 .and. lin(1:3)=='hel') then write(outstr,'(a)') & 'Matching braces enclose a list for macro style iteration eg {1 2}+2 -> 3; 4' 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 ! 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 do while (lin(fin:fin) /= ' ' .and. & lin(fin:fin) /= '.' .and. & lin(fin:fin) /= '/' .and. & lin(fin:fin) /= '*' .and. & lin(fin:fin) /= '+' .and. & lin(fin:fin) /= '-' .and. & lin(fin:fin) /= '^' .and. & #if defined (WIN32) || defined (IFORT) || defined (NOESCAPE) lin(fin:fin) /= '\' .and. & #else lin(fin:fin) /= '\\' .and. & #endif lin(fin:fin) /= '(' .and. & lin(fin:fin) /= ')' .and. & lin(fin:fin) /= '"' .and. & lin(fin:fin) /= '%' .and. fin <= eos) 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 command after "set plevel verbose"' 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 ! ! 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 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 ! three=((pos-sta) > 0 .and. (fin-pos) > 0) ! Zero function operation if (isop(cand2) .and. op(tag2) == 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(tag2) == 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(tag2) == 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.141592653590d0 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 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, togreg, tojulian 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 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 double precision :: encgtp 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 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)), loc, lochash, ilok) if (itok > 0) then wtyp(i)=partok wtag(i)=itok 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 (ienv > 0) then wtyp(i)=parenv wtag(i)=ienv 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=dfloat(aval(string(1:(slash-1)),1)) a2=dfloat(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 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, i, idx, j, k, nsibs, num, pedoffset, ped, pos, & reltyp, totobs character (len=1) :: ch character (len=9), dimension(13) :: relnam = (/ & 'All ', & 'Offspring', 'Son ', 'Daughter ', & 'Parent ', 'Father ', 'Mother ', & 'Sibling ', 'Brother ', 'Sister ', & 'Spouse ', 'Husband ', 'Wife ' /) 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 end if if (plevel >= 0) then write(outstr, '(/3a/a)') & 'Pedigree ID Rel Summary (', summary, ')', & '------------ ------------ --- --------------------' end if 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, 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, 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, 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)+dataset%nfound(ped) num=dataset%num(ped)-dataset%num(ped-1) do k=1, num nobs(k)=-1 end do nobs((dataset%nfound(ped)+1):num)=0 currf=MISS currm=MISS idx=num i=dataset%num(ped) do while (i > pedoffset) currf=dataset%fa(i) currm=dataset%mo(i) nsibs=0 pos=i-1 do while (dataset%fa(pos)==currf .and. dataset%mo(pos)==currm) nsibs=nsibs+1 pos=pos-1 end do do j=pos+1, i 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. nobs(idx) < MAXREC) then nobs(idx)=nobs(idx)+1 relid(idx, nobs(idx))=j end if end if end do do j=idx-nsibs, idx-1 nobs(j)=nobs(idx) do k=1, nobs(idx) relid(j,k)=relid(idx,k) end do end do i=pos idx=idx-nsibs-1 end do call prirelval(relnam(reltyp), summary, trait, loctyp, ped, nobs, relid, & sumval, totobs, 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 currf=dataset%fa(i) currm=dataset%mo(i) if (reltyp/=13) 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) 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, dataset, plevel) end if end do end if if (plevel <= 0 .and. totobs>=30) then write(outstr, '(a)') '...' end if write(outstr, '(/a,i6,a)') & 'Processed', totobs, ' trait values from relatives.' end subroutine getrelval ! ! Output single summary value for entire pedigree ! subroutine priallval(summary, trait, loctyp, ped, sumval, totobs, 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 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)) 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-dfloat(n) if (summary=='sum') then res=cumx else if (summary=='mea') then res=cumx/dfloat(n) else if (summary=='min') then res=minx else if (summary=='max') then res=maxx else if (summary=='cou') then res=dfloat(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 persion ! subroutine prirelval(relate, summary, trait, loctyp, ped, & nobs, relid, sumval, totobs, 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 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-dfloat(nobs(idx)) if (summary=='mea') res=res/dfloat(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 .and. & (plevel>0 .or. (plevel==0 .and. totobs<30))) then write(outstr, '(a12,1x,a12,1x,a3,12x,a)') & dataset%pedigree(ped), dataset%id(i), relate, 'x' 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 .and. & (plevel>0 .or. (plevel==0 .and. totobs<30))) then write(outstr, '(a12,1x,a12,1x,a3,12x,a)') & dataset%pedigree(ped), dataset%id(i), relate, 'x' 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 .and. & (plevel>0 .or. (plevel==0 .and. totobs<30))) then write(outstr, '(a12,1x,a12,1x,a3,12x,a)') & dataset%pedigree(ped), dataset%id(i), relate, 'x' 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=dfloat(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 .and. & (plevel>0 .or. (plevel==0 .and. totobs<30))) then write(outstr, '(a12,1x,a12,1x,a3,12x,a)') & dataset%pedigree(ped), dataset%id(i), relate, 'x' 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 .and. & (plevel>0 .or. (plevel==0 .and. totobs<30))) then write(outstr, '(a12,1x,a12,1x,a3,12x,a)') & dataset%pedigree(ped), dataset%id(i), relate, 'x' 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, wtyp, wtag, expr, allele_buffer, dataset, & chek, imp, 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 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) :: 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 integer, dimension(nloci) :: temptyp character (len=7) :: gtp 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, nmark, nloci, loctyp, locpos, tot, nped, & dataset, sta, fin, wtyp, wtag, expr) use parser_data use ped_class integer, intent(in) :: idx integer, intent(in out) :: nmark integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos integer, intent(in out) :: tot integer, intent(in out) :: nped 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, & dataset, droperr, ndiscard, inconsist, plevel) use ped_class 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=*), dimension(:), intent(in) :: locnotes 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, nmark, nloci, loctyp, locpos, tot, nped, & 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 (isactdip(tartyp)) then if (observed(i, tarpos, dataset) .and. x1 <= KNOWN) nmiss=nmiss+1 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 (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) if (plevel > 1) then write(outstr,'(8a,2(a,f4.0))') & 'Recoded ', trim(dataset%pedigree(dataset%iped(i))),'-', & trim(dataset%id(i)), & ' at "', trim(loc(trget)), '" from ', & gtp, ' to ', x1,'/',x2 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 (isactdip(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, dataset, droperr, & ndiscard, inconsist, plevel) if (imp >= 0) then call freq(locpos(trget), temptyp(trget), 0, dataset, allele_buffer) call start(1000, 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 (', & dfloat(100*nerr)/dfloat(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 (', dfloat(100*inconsist)/dfloat(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, nmark, nloci, loctyp, locpos, tot, nped, & dataset, sta, fin, wtyp, wtag, expr) use parser_data use ped_class use locus_types integer, intent(in) :: idx integer, intent(in out) :: nmark integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos integer, intent(in out) :: tot integer, intent(in out) :: nped 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, marcom integer (kind=1) :: ctyp integer :: ctag ! functions logical :: isenv, isvar, isvec interface subroutine marshare(idx, nloci, loctyp, locpos, dataset, marcom) use ped_class integer, intent(in) :: idx integer, intent(in) :: nloci integer, dimension(nloci), intent(in) :: loctyp integer, dimension(nloci), intent(in) :: locpos type (ped_data) :: dataset integer, intent(out) :: marcom end subroutine marshare end interface do j=sta,fin ctyp=wtyp(j) ! automatic/environmental variables if (isenv(ctyp)) then ctag=wtag(j) expr(j,1)=MISS expr(j,2)=MISS wtyp(j)=partra ! female male if (ctag < 3) then if (dataset%sex(idx) == MISS) then wtyp(j)=parmtr else expr(j,1)=dfloat(abs(dataset%sex(idx)-ctag)) expr(j,2)=expr(j,1) end if ! isfou else if (ctag == 3) then expr(j,1)=0.0d0 if (dataset%fa(idx)==MISS) expr(j,1)=1.0d0 expr(j,2)=expr(j,1) ! isnon else if (ctag == 4) then expr(j,1)=0.0d0 if (dataset%fa(idx)/=MISS) expr(j,1)=1.0d0 expr(j,2)=expr(j,1) ! num else if (ctag == 5) then expr(j,1)=dfloat(dataset%num(dataset%iped(idx))-dataset%num(dataset%iped(idx)-1)) expr(j,2)=expr(j,1) ! nfoun else if (ctag == 6) then expr(j,1)=dfloat(dataset%nfound(dataset%iped(idx))) expr(j,2)=expr(j,1) ! famnum else if (ctag == 11) then expr(j,1)=dfloat(nped) expr(j,2)=expr(j,1) ! index else if (ctag == 12) then expr(j,1)=dfloat(tot+idx-dataset%num(dataset%iped(idx)-1)) expr(j,2)=expr(j,1) ! commar else if (ctag == 13) then call marshare(idx, nloci, loctyp, locpos, dataset, marcom) expr(j,1)=dfloat(marcom) expr(j,2)=expr(j,1) ! anymis else if (ctag == 7) then expr(j,1)=0.0d0 do i=1, nloci if (isactive(loctyp(i))) then if (ismarker(loctyp(i))) then if (.not.observed(idx, locpos(i), dataset)) then expr(j,1)=1.0d0 exit end if else if (dataset%plocus(idx, locpos(i)) == MISS) then expr(j,1)=1.0d0 exit end if end if end if end do expr(j,2)=expr(j,1) ! anytyp alltyp numtyp else iloc=0 do i=1, nloci if (isactive(loctyp(i)) .and. ismarker(loctyp(i))) then if (observed(idx, locpos(i), dataset)) then iloc=iloc+1 end if end if end do expr(j,1)=0.0d0 if (ctag == 8) then if (iloc > 0) expr(j,1)=1.0d0 else if (ctag == 9) then if (iloc == nmark) expr(j,1)=1.0d0 else if (ctag == 10) then expr(j,1)=dfloat(iloc) end if expr(j,2)=expr(j,1) end if ! user defined variables else if (isvar(ctyp)) then if (isvec(ctyp)) then ctag=wtag(j) call get_geno(idx, locpos(ctag), locpos(ctag)+1, dataset, g1, g2) expr(j,1)=dfloat(g1) expr(j,2)=dfloat(g2) if (expr(j,1) <= KNOWN) then wtyp(j)=parmge+parvar wtag(j)=ctag end if else ctag=wtag(j) if (same_loctyp(loctyp(ctag), LOC_AFF) .and. & dataset%plocus(idx,locpos(ctag)) >= 1) then expr(j,1)=dataset%plocus(idx,locpos(ctag))-1.0d0 expr(j,2)=expr(j,1) else expr(j,1)=dataset%plocus(idx,locpos(ctag)) expr(j,2)=expr(j,1) end if 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 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, nmark, nloci, loctyp, locpos, tot, nped, & dataset, sta, fin, wtyp, wtag, expr) use parser_data use ped_class integer, intent(in) :: idx integer, intent(in out) :: nmark integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos integer, intent(in out) :: tot integer, intent(in out) :: nped 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 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, nmark, nloci, loctyp, locpos, tot, nped, & 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 person ', 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 write(outstr,'(/a,i5,a,i7,a/)') & 'Number of pedigrees selected=',uped,' (',nobs,' individuals)' 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 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 ! ! 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(words(i)(1:ped_width), 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(words(i)(1:id_width), 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 ! ! 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 write(outstr,'(/a,i6,a,i0,a/)') & 'Number of active pedigrees=', dataset%nact, & ' (', nobs, ' individuals)' end subroutine unsel ! ! Count or print individuals per pedigree fulfilling criterion ! subroutine docount(typ, farg, larg, words, & nloci, loc, lochash, loctyp, locpos, wtyp, wtag, expr, & dataset, pedmask, nwid, ndec, misval, fieldsep, allsep, & pstyle, plevel) use outstream use interrupt 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 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, ndec character (len=*), intent(in) :: misval character (len=1), intent(in) :: fieldsep character (len=1), intent(in) :: allsep integer, intent(in) :: 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, nmark, nloci, loctyp, locpos, tot, nped, & dataset, sta, fin, wtyp, wtag, expr) use parser_data use ped_class integer, intent(in) :: idx integer, intent(in out) :: nmark integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos integer, intent(in out) :: tot integer, intent(in out) :: nped 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, & misval, nrc, skip, filter, & nloci, loc, loctyp, locpos, 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) :: nwid integer, intent(in) :: ndec character (len=*), intent(in) :: misval integer, intent(in) :: nrc, skip, filter integer, intent(in) :: nloci character (len=*), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos type (ped_data) :: dataset end subroutine pedout subroutine wrvert(nloci, loc, loctyp, locpos, & dataset, nwid, ndec, allsep) 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 type (ped_data) :: dataset integer, intent(in) :: nwid integer, intent(in) :: ndec character (len=1), intent(in) :: allsep 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 dataset%untyped(:)=.true. do ped=1, dataset%nped if (dataset%actset(ped) > 0) then pedoffset=dataset%num(ped-1) 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, nmark, nloci, loctyp, locpos, tot, nped, & 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. 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, nmark, nloci, loctyp, locpos, tot, nped, & 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. 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,'(a,a1,i6,a1,i7,3(a1,i6))') & dataset%pedigree(ped)(1:14), 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 end if end do if (typ == 1) then write(outstr,'(a14,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, misval, & 0, 0, 2, nloci, loc, loctyp, locpos, dataset) ! write records vertically else if (pstyle == 4) then call wrvert(nloci, loc, loctyp, locpos, & dataset, nwid, ndec, allsep) ! 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, nmark, nloci, loctyp, locpos, tot, nped, & dataset, sta, fin, wtyp, wtag, expr) use parser_data use ped_class integer, intent(in) :: idx integer, intent(in out) :: nmark integer, intent(in) :: nloci integer, dimension(:), intent(in) :: loctyp integer, dimension(:), intent(in) :: locpos integer, intent(in out) :: tot integer, intent(in out) :: nped 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 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, nmark, nloci, loctyp, locpos, tot, nped, & 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*dfloat(ndel)/dfloat(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,i3,2a)', advance='no') 'Selecting pedigrees to contain ',nprob, & ' or more individuals where "', trim(words(farg)) else if (typ == 5) then write(outstr,'(/a,i3,2a)', advance='no') 'Selecting pedigrees to contain exactly ', & nprob,' individuals where "', trim(words(farg)) else if (typ == 6) THEN write(outstr,'(/a,i3,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 ! ! Count maximum number of active markers where proband and ! any of relatives is genotyped at ! subroutine marshare(idx, nloci, loctyp, locpos, dataset, marcom) use ped_class use locus_types integer, intent(in) :: idx integer, intent(in) :: nloci integer, dimension(nloci), intent(in) :: loctyp integer, dimension(nloci), 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)) .and. observed(idx, locpos(j), dataset)) then nmark=nmark+1 ord(nmark)=locpos(j) 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 ! ! 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 :: MISS=-9999 integer :: curr, exactdup, i, iaddress, idx, iprobe, & j, ncollision, ndup ! 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 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 (plevel > 1) then write(outstr,'(5a,i0,a)') 'NOTE: The ID "', & trim(dataset%pedigree(dataset%iped(i))), '--', & 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/)') & 'NOTE: Duplicates for ', ndup, ' IDs are present in the dataset.', & '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!' 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, 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, 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 type (hash_table) :: hashtab type (ped_data) :: dataset integer, intent(in) :: plevel ! local variables integer :: idx, ioerr, matched, narg, keytyp, tot logical :: iscomment character (len=40), dimension(2) :: words call filecols(port, lin, 10, narg, plevel-1) keytyp=HK_PED_ID if (narg == 1) keytyp=HK_ID if (.not.hashtab%current .or. (hashtab%keytyp /= keytyp)) then call hashids(keytyp, dataset, hashtab, 80, plevel-1) end if matched=0 tot=0 call rewind_port(port, ioerr) 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, 4) if (words(1)(1:3) == 'ped' .and. words(2) == 'id') cycle if (narg > 1) then tot=tot+1 call matchid(keytyp, words(1), words(2), dataset, & hashtab, idx, plevel) if (idx /= 0) then matched=matched+1 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, 4) if (words(1) == 'id') cycle if (narg > 0) then tot=tot+1 call matchid(keytyp, ' ', words(1), dataset, hashtab, idx, plevel) if (idx /= 0) then matched=matched+1 else if (plevel > 0) then write(outstr,'(3a)') & 'NOTE: Failed to match ID in "', trim(words(1)), '".' 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/a,f6.4)') & 'Number of ID matches = ', matched, & ' (', dfloat(matched)/dfloat(max(1,tot)), ')', & 'Prop of current dataset = ', dfloat(matched)/dfloat(max(1,dataset%nobs)) end subroutine findids ! ! 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=dfloat(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), dfloat(table(1))/max(1.0d0,n), & 'Female', table(2), dfloat(table(2))/max(1.0d0,n), & 'Unspec', table(3), '(',dfloat(table(3))/max(1.0d0,n+dfloat(table(3))),')' end subroutine sextable ! ! N-way cross-tabulation ! subroutine xtab(analys, nloc, loclist, loc, locpos, loctyp, & locnotes, dataset, iter, nwid, ndec, pval, plevel) use outstream use ped_class use contingency_table use locus_types integer, intent(in) :: analys integer, intent(in) :: nloc ! number of dimensions integer, intent(in) :: loclist(nloc) ! variable 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 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 maketab(nloc, loclist, loc, locpos, loctyp, & dataset, nmiss, table) use outstream use ped_class use contingency_table use locus_types integer, intent(in) :: nloc ! number of dimensions integer, intent(in) :: loclist(nloc) ! variable list character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp type (ped_data) :: dataset integer, intent(out) :: nmiss type (table_data) :: table end subroutine maketab subroutine wrtab(analys, nloc, loclist, loc, loctyp, locnotes, & table, nmiss, iter, nwid, ndec, pval) use contingency_table integer, intent(in) :: analys 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) use contingency_table 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) :: nwid, ndec end subroutine listab end interface pval=1.0d0 call maketab(nloc, loclist, 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 ! print rectangular or listwise table 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) then call wrtab(analys, nloc, loclist, loc, loctyp, locnotes, & table, nmiss, iter, nwid, ndec, pval) else call listab(nloc, loclist, loc, loctyp, locnotes, & table, nmiss, nwid, ndec) end if end subroutine xtab ! ! Generate crosstabulation ! subroutine maketab(nloc, loclist, loc, locpos, loctyp, & dataset, nmiss, table) use outstream use ped_class use contingency_table use locus_types integer, intent(in) :: nloc ! number of dimensions integer, intent(in) :: loclist(nloc) ! variable list character (len=20), dimension(:), intent(in) :: loc 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, MISS=-9999 double precision, dimension(nloc) :: val ! data for one individual ! local variables integer :: g1, g2, i, j, lpos, ltyp, ped ! functions double precision :: encgtp call setup_table(nloc, 100, table) nmiss=0 ! accumulate counts person: do i=1, dataset%nobs if (dataset%actset(dataset%iped(i)) > 0) then do j=1, nloc lpos=locpos(loclist(j)) ltyp=loctyp(loclist(j)) if (ismarker(ltyp)) then if (.not.observed(i, lpos, dataset)) then nmiss=nmiss+1 cycle person else call get_geno(i, lpos, lpos+1, dataset, g1, g2) val(j)=encgtp(g1, g2) end if else if (dataset%plocus(i,lpos) == MISS) then nmiss=nmiss+1 cycle person else val(j)=dataset%plocus(i,lpos) end if end if end do call insert_table(nloc, val, table, 1) end if end do person end subroutine maketab ! ! print summary of one-way table ! subroutine onetab(loc, loctyp, locnotes, table, nmiss, nwid, ndec) use outstream use contingency_table use locus_types character (len=20), intent(in) :: loc integer, intent(in) :: loctyp character (len=40), intent(in) :: locnotes type (table_data) :: table integer, intent(in) :: nmiss integer, intent(in) :: nwid, ndec ! local variables integer :: j, n1, n2 character (len=7) :: gtp, gtp2 if (loctyp == LOC_AFF) then n1=0 n2=0 do j=1, table%ncells if (table%categories(table%idx(j),1) == 1.0d0) n1=table%icount(j) if (table%categories(table%idx(j),1) == 2.0d0) n2=table%icount(j) 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), gtp, & loctyp, locnotes, nwid, ndec) call wrtrait(table%categories(table%idx(table%ncells),1), gtp2, & loctyp, locnotes, 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 ', gtp ,'...', trim(gtp2), ')' else write(outstr,'(a,1x,a,i6)', advance='no') loc,'x:',nmiss do j=1, table%ncells call wrtrait(table%categories(table%idx(j),1), gtp, & loctyp, locnotes, nwid, ndec) call juststr('r',gtp,7) write(outstr,'(1x,2a,i6)', advance='no') gtp,':', table%icount(j) end do write(outstr,*) end if end subroutine onetab ! ! print listwise contingency table ! subroutine listab(nloc, loclist, loc, loctyp, locnotes, & table, nmiss, nwid, ndec) use outstream use contingency_table 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) :: nwid, ndec ! local variables integer :: i, j, pos character (len=10) :: cval double precision :: wt do j=1, nloc cval=loc(loclist(j)) call juststr('c',cval,10) write(outstr,'(a10,1x)', advance='no') cval end do write(outstr,'(a/a)', advance='no') ' Count Percent', '------------------' do j=1, nloc write(outstr,'(a)', advance='no') '-----------' end do write(outstr,*) wt=100.0d0/dfloat(max(1, table%ntot)) do i=1, table%ncells pos= table%idx(i) do j=1, nloc call wrtrait(table%categories(pos,j), cval, loctyp(loclist(j)), & locnotes(loclist(j)), nwid, ndec) write(outstr,'(a10,1x)', advance='no') cval end do write(outstr,'(1x,i6,4x,f5.1)') table%icount(i), wt*dfloat(table%icount(i)) end do write(outstr,'(a)', advance='no') '------------------' do j=1, nloc write(outstr,'(a)', advance='no') '-----------' end do write(outstr,'(/2x,a,3x)',advance='no') 'Total' do j=1, nloc-1 write(outstr,'(a11)', advance='no') ' ' 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, nloc, loclist, loc, loctyp, locnotes, & table, nmiss, iter, nwid, ndec, pval) use outstream use contingency_table use locus_types integer, intent(in) :: analys 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 ! other local variables integer :: allele(2), df, g1, g2, het, i, icell, isor, issnp, j, k, & n(4), ncol, pos, t1, t2 integer, dimension(nloc) :: chosen character (len=10) :: cval1, cval2 double precision :: curr, er, e, kwstat, nr, odds1, oddsr, pa, pvalue, & rankg, se1, se2, ties double precision, dimension(1) :: mu, x, ss double precision, dimension(nloc) :: val ! functions double precision :: chip, encgtp character (len=6) :: pstring interface subroutine listab(nloc, loclist, loc, loctyp, locnotes, & table, nmiss, nwid, ndec) use contingency_table 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) :: nwid, ndec end subroutine listab subroutine kwtest(nloc, loclist, loc, loctyp, locnotes, & martable1, martable2, table, & nwid, ndec, pval) use outstream use contingency_table use locus_types 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 het=MISS isor=0 issnp=0 ncol=0 pa=0.0d0 t1=loclist(1) t2=loclist(nloc) 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. loctyp(t1) == LOC_AFF .and. loctyp(t2) == LOC_AFF) then do i=1, table%ncells g1=int(table%categories(table%idx(i),1)) g2=int(table%categories(table%idx(i),2)) n(7-2*g1-g2)=table%icount(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*dfloat(n(1))/dfloat(max(1,n(1)+n(2))) write(outstr,'(7x,a3,5x,i6,2x,i6,4x,f5.1)') & ' No',n(3),n(4),1.0D2*dfloat(n(3))/dfloat(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+dfloat(n(1)))*(0.5D0+dfloat(n(4)))/ & (0.5D0+dfloat(n(2)))/(0.5D0+dfloat(n(3))) e=1.0d0/(0.5D0+dfloat(n(1))) + 1.0d0/(0.5D0+dfloat(n(2))) + & 1.0d0/(0.5D0+dfloat(n(3))) + 1.0d0/(0.5D0+dfloat(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)), ')' ! ! one-way table of means else if (analys == 2 .or. (martable1%ncells < 8 .and. & loctyp(t2) == LOC_QUA)) then call kwtest(nloc, loclist, loc, loctyp, locnotes, & martable1, martable2, table, & nwid, ndec, pval) ! ! print as RxC table ! else if ((martable1%ncells < 20 .or. loctyp(t1) /= LOC_QUA) .and. & martable2%ncells < 8 .and. analys == 1) then write(outstr,'(/22x,a)') loc(t2) ! pad out sparse representation if SNP marker if (same_loctyp(loctyp(t2), LOC_CODOM) .and. martable2%ncat <= 3) then do i=1, martable2%ncells pos=martable2%idx(i) call decgtp(martable2%categories(pos,1), g1, g2) call addall(g1, issnp, 2, allele) call addall(g2, issnp, 2, allele) 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) 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+dfloat(tble(1)))/(0.5d0+dfloat(tble(2))) se1=1.0d0/(0.5d0+dfloat(tble(1))) + 1.0d0/(0.5d0+dfloat(tble(2))) end if do i=1, nloc-1 cval1=loc(loclist(i)) call juststr('c', cval1, 10) write(outstr,'(a10,a)', advance='no') cval1, ' ' end do do i=1, martable2%ncells call wrtrait(martable2%categories(martable2%idx(i),1), & cval2, loctyp(t2), locnotes(t2), nwid, ndec) write(outstr,'(3x,a10)', advance='no') cval2 end do 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,*) do i=1, nloc-1 write(outstr,'(a,1x)', advance='no') repeat('-',10) end do write(outstr,'(a)') repeat('-',14*(martable2%ncells+issnp+isor)) icell=0 do i=1, martable1%ncells do k=1, martable1%ncat call wrtrait(martable1%categories(martable1%idx(i),k), cval1, & loctyp(loclist(k)), locnotes(loclist(k)), nwid, ndec) write(outstr,'(a10,1x)', advance='no') cval1 end do nr=dfloat(martable1%icount(i)) er=nr/dfloat(max(1,martable1%ntot)) pa=0.0d0 do j=1, martable2%ncells icell=icell+1 e=dfloat(tble(icell))/max(1.0d0,nr) if (e == 1.0d0) then write(outstr,'(1x,i5,1x,a)', advance='no') tble(icell), '(1.00)' else write(outstr,'(1x,i5,1x,a,f4.3,a)', advance='no') tble(icell), '(',e,')' end if if (issnp == 2) then n(j)=tble(icell) end if ex(icell)=er*dfloat(martable2%icount(j)) end do if (issnp == 2) then call hwe2(n(1), n(2), n(3), pa, pvalue) 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+dfloat(tble(icell-1)))*(0.5d0+dfloat(tble(icell))) se2=sqrt(se1+1.0d0/(0.5d0+dfloat(tble(icell-1))) + & 1.0d0/(0.5d0+dfloat(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(' ',(nloc-1)*11), repeat('-',14*(martable2%ncells+issnp+isor)) write(outstr,'(2a,6x)', advance='no') & repeat(' ',(nloc-2)*11), 'Total' do j=1, martable2%ncells e=dfloat(martable2%icount(j))/dfloat(max(1,martable2%ntot)) if (e == 1.0d0) then write(outstr,'(1x,i5,1x,a)', advance='no') & martable2%icount(j), '[1.00]' else write(outstr,'(1x,i5,1x,a,f4.3,a)', advance='no') & martable2%icount(j), '[',e,']' end if end do write(outstr,*) call rctest(martable1%ncells, martable2%ncells, tble, ex, iter) else call listab(nloc, loclist, loc, loctyp, locnotes, & table, nmiss, nwid, ndec) end if end subroutine wrtab ! ! Kruskal-Wallis test ! subroutine kwtest(nloc, loclist, loc, loctyp, locnotes, & martable1, martable2, table, & nwid, ndec, pval) use outstream use contingency_table use locus_types use statfuns 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=10) :: cval1, cval2 integer :: df, i, icell, j, k, pos double precision :: curr, er, e, kwstat, nr, odds1, oddsr, pa, pvalue, & rankg, se1, se2, ties double precision, dimension(1) :: mu, x, ss double precision, dimension(nloc) :: val ! functions double precision :: encgtp character (len=6) :: pstring kwstat=0.0D0 df=0 write(outstr,'(/2a)') repeat(' ',nloc*11), loc(loclist(nloc)) 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,'(6x,a,14x,a,7x,a)') 'Mean', 'SD', 'Count' do i=1, nloc-1 write(outstr,'(a,1x)', advance='no') repeat('-',10) end do write(outstr,'(a)') repeat('-',39) pos=1 do i=1, martable1%ncells rankg=0.0D0 mu(1)=0.0D0 ss(1)=0.0D0 icell=0 do k=1, nloc-1 val(k)=martable1%categories(martable1%idx(i),k) end do strata: do if (pos > table%ncells) exit do k=1, nloc-1 if (table%categories(table%idx(pos),k) /= val(k)) exit strata end do icell=icell+table%icount(pos) x(1)=table%categories(table%idx(pos), nloc) rankg=rankg+dfloat(table%icount(pos))*findrank(x(1), martable2) call dssp(1, icell, table%icount(pos), x, mu, ss) pos=pos+1 end do strata kwstat=kwstat+rankg*rankg/dfloat(icell) do k=1, nloc-1 call wrtrait(val(k), cval1, loctyp(loclist(k)), locnotes(loclist(k)), & nwid, ndec) write(outstr,'(a10,1x)', advance='no') cval1 end do write(outstr,'(3x,f12.4,3x,f12.4,1x,i7)') & mu(1), sqrt(ss(1)/dfloat(max(icell-1,1))), icell end do ! Kruskal-Wallis test statistic, then correction for ties kwstat=12.0d0*kwstat/dfloat(table%ntot*(table%ntot+1)) - & dfloat(3*(table%ntot+1)) ties=0.0d0 do j=1, martable2%ncells ties=ties+dble(martable2%icount(j)**3-martable2%icount(j)) end do kwstat=kwstat/(1.0d0 - ties/dfloat(table%ntot**3-table%ntot)) df=(martable1%ncells-1) pval=chip(kwstat,df) write(outstr,'(/a,f7.2,a,i3,3a)') 'Kruskal-Wallis H=', kwstat, & ' df=',df,' (P=', trim(pstring(pval)), ')' end subroutine kwtest ! ! Logrank test: table 1..(nloc-2)=covariate levels (nloc-1)=time nloc=censor ! subroutine logrank(typ, nloc, loclist, loc, loctyp, locpos, locnotes, & dataset, nwid, ndec, lrstat, df, pval, plevel) use outstream use ped_class use contingency_table use locus_types use statfuns integer, intent(in) :: typ integer, intent(in) :: nloc integer, dimension(:), intent(in) :: loclist 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, 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 double precision :: encgtp character (len=6) :: pstring interface subroutine ascend(n, ia) integer, intent(in) :: n integer, dimension(:), intent(inout) :: ia end subroutine subroutine maketab(nloc, loclist, loc, locpos, loctyp, & dataset, nmiss, table) use outstream use ped_class use contingency_table use locus_types integer, intent(in) :: nloc ! number of dimensions integer, intent(in) :: loclist(nloc) ! variable list character (len=20), dimension(:), intent(in) :: loc integer, dimension(:), intent(in) :: locpos integer, dimension(:), intent(in) :: loctyp type (ped_data) :: dataset integer, intent(out) :: nmiss type (table_data) :: table end subroutine maketab end interface lrstat=0.0d0 df=0 call maketab(nloc, loclist, 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) 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) /= val(k)) then exit ingroups end if end do iev=findlev(table%categories(table%idx(pos), nloc-1), martable2) if (table%categories(table%idx(pos), nloc) == 2.0d0) then totaff=totaff+1 dij(iev,j)=dij(iev,j)+table%icount(pos) else cij(iev,j)=cij(iev,j)+table%icount(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) 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 call wrtrait(martable1%categories(martable1%idx(j),k), cval1, & loctyp(loclist(k)), locnotes(loclist(k)), 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), dfloat(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,'(a14,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, & 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 character (len=*), intent(in) :: locnam integer, intent(in) :: gene integer, intent(in) :: onset, censor integer, intent(in) :: iter, mincnt 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 ! functions integer :: clcpos double precision :: encgtp 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 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 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 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,'(a14,2(a1,i6),a1,f10.1,2(a1,a),a1,i6,a1,a)') & locnam, tabsep, 0, tabsep, 0, tabsep, lrstat, tabsep, & ' - ' , tabsep, ' - ' , tabsep, 0, tabsep, ' Surv' 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) 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), dfloat(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 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), dfloat(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/dfloat(max(1,it-1)) pval=dfloat(tailp)/dfloat(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 == -1 .or. plevel == 0) then call phist(asyp, pval, histo) write(outstr,'(a14,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(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)+(dfloat(dij(i,j))-dfloat(nij(i,j)*di(i))/dfloat(ni(i))) end if end do do j2=1, j-1 pos=pos+1 do i=1, timelev if (ni(i) > 1) then den=dfloat(ni(i)*ni(i)*(ni(i)-1)) vardiff(pos)=vardiff(pos)+dfloat(-di(i)*(ni(i)-di(i))*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=dfloat(ni(i)*ni(i)*(ni(i)-1)) vardiff(pos)=vardiff(pos)+dfloat(di(i)*(ni(i)-di(i))* & (ni(i)*nij(i,j)-nij(i,j)*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 ! ! One-way tabulation by pedigree ! subroutine pedtab(gene, loctyp, locnotes, dataset, nwid, ndec, plevel) use outstream use locus_types use contingency_table use ped_class integer, intent(in) :: gene, loctyp character (len=40), intent(in) :: locnotes type (ped_data) :: dataset integer, intent(in) :: nwid, ndec integer, intent(in) :: plevel integer, parameter :: MISS=-9999 integer :: gen2, g1, g2, i, nmiss, ped type (table_data) :: traittable double precision, dimension(1) :: val ! functions double precision :: encgtp call setup_table(1, 30, traittable) gen2=gene+1 do ped=1, dataset%nped if (dataset%actset(ped) > 0) then nmiss=0 if (ismarker(loctyp)) 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 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 onetab(dataset%pedigree(ped), loctyp, locnotes, & 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, 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 alleles_class use statfuns integer, intent(in) :: sta, fin character (len=*), dimension(:), intent(in) :: terms 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) :: 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 double precision :: lrts, pred, tval integer :: endarg, g1, g2, i, ilev, iloc, j, k, k2, lpos, ltyp, nel, & off, off1, off2, pos, pos2, xpos ! 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=22) :: cval ! functions integer :: getnam double precision :: encgtp, 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 endarg=fin gene=MISS genemod=0 if (terms(fin) == 'all' .or. terms(fin) == 'allelic') then genemod=-1 endarg=fin-1 end if call create_form(sta, endarg, terms, nloci, loc, 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)) call setup_table(formula%neff, 100, table) ! accumulate counts person: do i=1, dataset%nobs if (dataset%actset(dataset%iped(i)) > 0) then do j=1, formula%neff iloc=formula%effects(j) lpos=locpos(iloc) ltyp=loctyp(iloc) if (ismarker(ltyp)) then if (.not.observed(i, lpos, dataset)) then nmiss=nmiss+1 cycle person else call get_geno(i, lpos, lpos+1, dataset, g1, g2) val(j)=encgtp(g1, g2) end if else if (dataset%plocus(i,lpos) == MISS) then nmiss=nmiss+1 cycle person else val(j)=dataset%plocus(i,lpos) end if end if end do call insert_table(formula%neff, val, table, 1) end if end do person ! ! 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 else formula%nlev(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), clev, & loctyp(iloc), locnotes(iloc), nwid, ndec) write(outstr,'(a6,a10,1x,i6)') cval, clev, martable(j)%icount(k) 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) ! ! 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%nlev(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) 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)=dfloat(table%icount(i)) ! 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), 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), 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,'(a26,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=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,'(a26,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 call wrtrait(table%categories(pos,j), clev, & loctyp(formula%effects(j)), locnotes(formula%effects(j)), & 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(30, 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, & ' (', dfloat(100*table%ntot)/dfloat(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 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 ! 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))) then nord=nord+1 locord(nord)=j end if end do do j=trait+1, nloci if (isactive(loctyp(j))) then nord=nord+1 locord(nord)=j end if end do else nord=0 do j=1, trait-1 nord=nord+1 locord(nord)=j end do do j=trait+1, nloci nord=nord+1 locord(nord)=j 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 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 pos=findlev(dataset%plocus(i,tpos), traittable) typed(jj,pos)=typed(jj,pos)+1 end if else if (dataset%plocus(i,locpos(j)) /= MISS) then pos=findlev(dataset%plocus(i,tpos), traittable) typed(jj,pos)=typed(jj,pos)+1 end if end if end if end do end if end do 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,9x)', advance='no') 'Locus' do k=1, traitlevels pos=traittable%idx(k) call wrtrait(traittable%categories(pos,1), cval, & loctyp(trait), locnotes(trait), 9, 4) write(outstr,'(a,2x)',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(k)) end do locstat(j)=dfloat(typlev) if (traitlevels < 5) then write(outstr,'(1x,a)') trim(locnotes(j)(1:(66-14*traitlevels))) else write(outstr,*) end if 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(k) end do write(outstr,'(i5,i14)') & traittable%icount(traitlevels), traittable%ntot write(outstr,'(/14x)', advance='no') do k=1, traitlevels pos=traittable%idx(k) call wrtrait(traittable%categories(pos,1), cval, & loctyp(trait), locnotes(trait), 9, 4) write(outstr,'(a,2x)',advance='no') cval end do write(outstr,'(/a14)', advance='no') 'Mean typed ' do k=1, traitlevels write(outstr,'(f7.1,7x)', advance='no') & dfloat(tottyped(k))/max(1.0d0,dfloat(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)=dfloat(typlev) end do end if end subroutine strattyp ! ! Monte-Carlo test for HWE ! subroutine dohwe(locnam, gene, loctyp, iter, mincnt, hwefnd, norder, & dataset, outp, plevel) use outstream use alleles_class use ped_class use rngs use statfuns 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) :: 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) :: histo character (len=7) :: gtp logical :: xmale ! ! 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 dsort(n, dx) integer, intent(in) :: n double precision, dimension(:) :: dx end subroutine dsort 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)) 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 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=dfloat(tot-totmal)/dfloat(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=dfloat(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), ' (', dfloat(gcount(i,1))/dfloat(tot-totmal), ') ', & expf, ftdev(dfloat(gcount(i,1)),expf) end do end do if (totmal > 0) then invden=dfloat(totmal)/dfloat(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=dfloat(gcount(j,2)) * invden write(outstr,'(8x,a7,3x,i8,a,f5.3,a,f10.1,1x,f8.1)') & gtp, gcount(j,3), ' (', dfloat(gcount(j,3))/dfloat(totmal), ') ', & expf, ftdev(dfloat(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) 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/dfloat(max(1,it-1)) if (topvals(ntopvals) >= ochisq) then pval=dfloat(tailp)/dfloat(it) else pval=evdtailp(it, ntopvals, topvals, ochisq) end if 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 else if (plevel > -2) then if (exactp/=-1.0d0) asyp=exactp call phist(asyp, pval, histo) write(outstr,'(a14,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 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*dfloat(gcount(i,2))/dfloat(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/dfloat(tot) else totall=2*tot-totmal c=dfloat(tot-totmal)/dfloat(totall*totall) end if hwechi=0.0d0 i=0 do j=1, numal do k=1, j i=i+1 o=dfloat(gcount(i,1)) e=c*dfloat(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=dfloat(totmal)/dfloat(totall) do j=1, numal o=dfloat(gcount(j,3)) e=c*dfloat(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=dfloat(n1)/dfloat(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)*dfloat(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*dfloat(2*tab(3)+tab(2))/dfloat(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=dfloat(nmat)*f(i) obsn=dfloat(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/dfloat(max(nmat,1)) write(outstr,'(2(/21x,a),2(/a,3f8.1))') & 'IBS Sharing', '2/2 1/2 0/2', 'Observed sharing', & q*dfloat(tab(3)), q*dfloat(tab(2)), q*dfloat(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 ! ! 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.5*(1.0-exp(-0.02*abs(x))) else if (mapf == 2) then invmap=0.5*(exp(0.04*abs(x))-1)/(exp(0.04*abs(x))+1) else invmap=x end if if (invmap < 0.001) invmap=0.001 end function invmap ! ! 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 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 #if IFORT || SUN ! functions character (len=24) :: fdate #endif style='circle' title='Sib-pair plot (' // fdate() // ')' if (pedfil /= 'inline.ped') then title='Data from ' // trim(pedfil) // ' (' // fdate() // ')' 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, 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 allocate(xvals(histcat+1), yvals(histcat+1)) i=max(nwid, 13) call wrform('f', i, ndec, fdec) 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)- & table%categories(table%idx(1),cat))/dfloat(histcat) histcnt=0 cum=0 oldcum=0 n=0 ncat=0 i=1 upper=table%categories(table%idx(1),cat)+histwidth write(outstr,'(/a/a)') & ' Intvl Midpt Count Histogram', & ' ---------------------------------------------------------' do while (i <= table%ncells) if (table%categories(table%idx(i),cat) <= upper) then histcnt=histcnt+table%icount(i) n=n+1 i=i+1 else cum=cum+histcnt if (n == 1) then midval=table%categories(table%idx(i-1),cat) 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) else midval=upper-0.5*histwidth end if write(outstr, fdec, advance='no') midval write(outstr,'(1x,i6,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 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=anint(1.0d6*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 locus_data integer, intent(in) :: plevel integer, parameter :: MISS=-9999 integer :: i, idx, nvar, pos, cumsum, texponent, typ double precision :: den, maxstat, trget character(len=7) :: cbin if (nloci == 0) return write(outstr,'(/3a//a/a)') & 'Test: "', trim(whichstat), '".', & 'Bin Count Percent', & '------- ----- -------' nvar=nloci call rankstat(nvar) den=1.0d2/dfloat(nvar) maxstat=locstat(wloc(nvar)) typ=2 pos=0 cumsum=0 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 write(outstr,'(i7,a1,i5,a1,2x,f5.1)') & 0, tabsep, cumsum, tabsep, den*dfloat(cumsum) end if if (typ == 2) then trget=1.0d0 cumsum=0 do while (pos <= nvar) idx=wloc(i) if (locstat(idx) > trget) then write(outstr,'(i7,a1,i5,a1,2x,f5.1)') & int(trget), tabsep, cumsum, tabsep, den*dfloat(cumsum) 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,i5,a1,2x,f5.1)') & int(trget), tabsep, cumsum, tabsep, den*dfloat(cumsum) else texponent=nint(log10(locstat(idx))) trget=10.0d0**texponent cumsum=0 do while (pos <= nvar) idx=wloc(pos) if (locstat(idx) > trget) then if (cumsum > 0 .or. trget > 1e-8) then write(cbin,'(i7)') texponent cbin='10^' // trim(adjustl(cbin)) write(outstr,'(a7,a1,i5,a1,2x,f5.1)') & cbin, tabsep, cumsum, tabsep, den*dfloat(cumsum) 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 end if end do write(cbin,'(i7)') texponent cbin='10^' // trim(adjustl(cbin)) write(outstr,'(a7,a1,i5,a1,2x,f5.1)') & cbin, tabsep, cumsum, tabsep, den*dfloat(cumsum) end if end subroutine tabstat ! ! Show ranked test statistics ! subroutine sumstat(numval, plevel) use interrupt use outstream use locus_data integer, intent(in) :: numval integer, intent(in) :: plevel integer, parameter :: MISS=-9999 integer :: i, idx, nvar character (len=10) :: cpos character (len=6) :: pstring if (nloci == 0) return write(outstr,'(/3a)') 'Test: "', trim(whichstat), '".' call rankstat(nvar) write(outstr,'(/a,i0)') 'Total number of tests = ', nvar if (plevel < 1) nvar=min(numval, nvar) write(outstr, '(/a/a)') & 'Locus Position P-value -log10(P)', & '------------------ ---------- ------- ----------' do i=1, nvar idx=wloc(i) if (map(idx) == MISS) then write(cpos, '(i10)') idx cpos='(' // trim(adjustl(cpos)) // ')' call juststr('r',cpos,10) else write(cpos, '(f10.2)') map(idx) end if write(outstr, '(a18,a1,a10,a1,1x,a,a1,1x,f10.3,a1,1x,a)') & loc(idx), tabsep, cpos, tabsep, pstring(locstat(idx)), tabsep, & min(1000.0d0,-log10(locstat(idx))), tabsep, & trim(locnotes(idx)) if (irupt /= 0) exit end do end subroutine sumstat ! ! Rank the test statistics (nvar=no. nonmissing values) ! subroutine rankstat(nvar) use locus_data integer, intent(out) :: nvar interface subroutine ascend(n, ia) integer, intent(in) :: n integer, dimension(:), intent(inout) :: ia end subroutine subroutine srank(n, dx, iy) integer, intent(inout) :: n double precision, dimension(:) :: dx integer, dimension(:) :: iy end subroutine srank end interface nvar=nloci if (nvar == 0) return call ascend(nvar, wloc) call srank(nvar, locstat, wloc) end subroutine rankstat ! ! Produce a plot of P-values ! subroutine sumplot(fil) use outstream 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 IFORT || SUN ! functions character (len=24) :: fdate #endif if (nloci == 0) return style='mountain' title='Summary of test results (' // fdate() // ')' 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)=dfloat(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 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 IFORT || SUN ! functions character (len=24) :: fdate #endif if (nloci == 0) return style=' ' title='Quantile-Quantile plot of test results (' // fdate() // ')' 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(dfloat(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(dfloat(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 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 #if IFORT || SUN ! functions character (len=24) :: fdate #endif style='mountain' title='Sib-pair MCMC Trace (' // fdate() // ')' 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)=dfloat(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) use outstream use contingency_table use statfuns type (table_data) :: table ! local variables integer :: i, n double precision, dimension(3) :: cov(3) double precision, dimension(2) :: mean(2), x(2) double precision :: den, dn, p, r ! functions ! ppnd, zp mean(1)=0.0d0 mean(2)=0.0d0 cov(1)=0.0d0 cov(2)=0.0d0 cov(3)=0.0d0 n=table%icount(1) dn=dfloat(table%ntot) x(1)=ppnd(1.0d0-0.5d0**(1.0d0/dn)) x(2)=table%categories(1,1) call dssp(2, n, table%icount(1), x, mean, cov) den=1.0d0/(0.365d0+dn) do i=2, table%ncells-1 n=n+table%icount(i) x(1)=ppnd(den*(dfloat(i) - 0.3175d0)) x(2)=table%categories(i,1) call dssp(2, n, table%icount(i), x, mean, cov) end do n=n+table%icount(table%ncells) x(1)=ppnd(0.5d0**(1.0d0/dn)) x(2)=table%categories(table%ncells,1) call dssp(2, n, table%icount(table%ncells), x, mean, cov) r=cov(2)/sqrt(cov(1))/sqrt(cov(3)) ! ! Approximate P-value modelled on that for Royston 1993 for W' ! p=log(1.0d0-r)+1.99196d0+1.0402d0*(log(dn)-log(log(dn))) p=zp(p/(0.31239d0+0.788392d0/log(dn))) write(outstr,'(/a,f13.4,a,f5.3,a)') 'Filliben correlation = ', r, ' (P=',p,')' ! Poissonness test r=sqrt(0.5d0*dfloat(n-1))*(cov(1)/mean(1)-1.0d0) p=zp(r) write(outstr,'(/a,f13.4,a,f5.3,a)') 'Poissonness test Z = ', r, ' (P=', p, ')' 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) use outstream use contingency_table use statfuns type (table_data) :: table ! local variables integer, parameter :: MISS=-9999 integer :: i, n, ns1, ns2, pos(6,2) double precision :: dn, j02, x(6,2), q(5) ! functions ! zp q(1)=0.02d0 q(2)=0.25d0 q(3)=0.5d0 q(4)=0.75d0 q(5)=0.98d0 dn=dfloat(table%ntot-1) do i=1, 5 x(i,1)=MISS x(i,2)=MISS q(i)=q(i)*dn+1.0d0 pos(i,1)=nint(q(i)-0.5d0) pos(i,2)=nint(q(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(i) 100 continue if (n >= pos(ns1,1) .and. x(ns1,1) == MISS) then x(ns1,1)=table%categories(i,1) ns1=ns1+1 goto 100 end if if (n >= pos(ns2,2) .and. x(ns2,2) == MISS) then x(ns2,2)=table%categories(i,1) ns2=ns2+1 ! break if all quantiles found if (ns2 > 5) exit tabloop goto 100 end if end do tabloop do i=1, 5 x(i,1)=x(i,1)+(x(i,2)-x(i,1))*(q(i)-dfloat(pos(i,1))) end do j02=(0.5d0*(x(1,1)+x(5,1))-x(3,1))/(x(4,1)-x(2,1)) 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 subroutine symtest ! ! 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) use outstream integer, intent(in) :: num double precision, dimension(:), intent(inout) :: xvals double precision, intent(out) :: xmode integer, intent(in) :: plevel ! 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, xn, sl double precision :: d1, d2 interface subroutine dsort(n, dx) integer, intent(in) :: n double precision, dimension(:) :: dx end subroutine dsort end interface call dsort(num, xvals) n = num - 1 x(0:n)=xvals(1:num) xn = dfloat(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 = dfloat(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 = (dfloat(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) = dfloat(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) <s (u)) then do i=u, v s(i) = dfloat(v-u+1) / (xn * gam * (x(v) - x(u-1))) end do v = v + 1 else v = u u = u - 1 end if end do ! figure out likelihood for this mode: xllh = 0.d0 do i=1, n xllh = xllh + log(s(i)) end do if (xllh > 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 (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 ! ! 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. ! function evdtailp(n, mm, xvals, xnew) double precision :: evdtailp integer, intent(in) :: n, mm double precision, intent(in) :: xvals(mm) double precision, intent(in) :: xnew integer :: i, m double precision :: a, b m=mm-2 evdtailp=1.0d0 if (m >= n .or. xnew <= xvals(mm)) return b = xvals(2) a = 0.0d0 do i=mm, 3, -1 a=a+log(xvals(i)) end do a=a/dfloat(m)-log(b) evdtailp=dfloat(m)/dfloat(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=dfloat((b-c)*(b-c))/dfloat(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=(dfloat(x)-dfloat(n)*e)/ sqrt(e*(1.0d0-e)*dfloat(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 ! ! 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/dfloat(n-1)+2.0d0/dfloat((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=dfloat(n1)/dfloat(n1+n2) p2=dfloat(n2)/dfloat(n1+n2) d=inht(r1)-inht(r2) res=dfloat(n2)*log(sech(p1*d)) + dfloat(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,g12.6,1x,a,1x,i2,a,g12.6,a,g12.6)') & '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/dfloat(den) phat=dfloat(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 ! ! Binomial probabilities for x,n-x with p=0.5 ! function binp(np,nq) use statfuns double precision binp double precision, intent(in) :: np double precision, intent(in) :: nq integer :: i double precision :: a,b,bt ! Functions ! double precision :: alngam, betacf 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 ! ! 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/dfloat(n) ss=ss+dev*dev*dfloat(n-1)/dfloat(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=dfloat(iwt)/dfloat(nobs) c=dfloat(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/dfloat(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 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 ! ! 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) call filltri(nter, ncov, r, -1.0d0, 0.0d0) 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)*dfloat(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 ! ! Use AS164 to evaluate quadratic y' S~ y where S not necessarily full rank ! subroutine iquadmult(n, y, s, res) 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 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) ! 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, 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) covi(l)=covi(l)+(sx*cov(l)-ww(j)*ww(k))/(sx*sx) ! 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 write(*,'(a,i0,a,i0,a)') & 'NOTE: Problem inverting covariance matrix. DGEFA info=', & ifault, ' at iteration ', its, '.' ifault=2 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 ! ! 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,p(n2) logical :: done 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 ! ! 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 = int(anint(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 = dfloat(date) end function tojulian ! ! from Julian to Gregorian ! function togreg(jdate) double precision togreg double precision, intent(in) :: jdate integer :: date, dy, i, j, l, mo, n, yr integer :: a, b, c, d, e date = int(anint(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 = dfloat(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 ! functions double precision :: tojulian date = int(anint(gdate)) yr = date/10000 d1 = tojulian(dfloat(10000*yr)+101.0d0) yrlen = tojulian(dfloat(10000*(yr+1))+101.0d0) - d1 getyear=dfloat(yr)+(tojulian(gdate)-d1)/yrlen end function getyear ! ! 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 logical :: ismzpair, last, sibshp ! functions double precision :: tetcor 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)=dfloat(aff(i))/dfloat(den(i)) end do prev=segr(4) write(outstr,'(a/a)') & 'Total sample All Fndrs Nonfndrs', & '-----------------------------------------------' write(outstr,'(3x,a8,3(1x,i5,a1,i5)/3x,a8,3(7x,f5.3)/3x,a8,3(7x,i5))') & '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,3i12/3x,a8,3(1x,i5,a1,i5)/3x,a8,3(7x,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', & '----------------------------------------------- -------------' if ((pocon+podis) > 0) then porec=dfloat(2*pocon)/dfloat(2*pocon+podis) potet=tetcor(prev, porec/prev) end if if ((mzcon+mzdis) > 0) then mzrec=dfloat(2*mzcon)/dfloat(2*mzcon+mzdis) mztet=tetcor(prev, mzrec/prev) end if if ((sscon+ssdis) > 0) then ssrec=dfloat(2*sscon)/dfloat(2*sscon+ssdis) sstet=tetcor(prev, ssrec/prev) end if if ((hscon+hsdis) > 0) then hsrec=dfloat(2*hscon)/dfloat(2*hscon+hsdis) hstet=tetcor(prev, hsrec/prev) end if if ((gpcon+gpdis) > 0) then gprec=dfloat(2*gpcon)/dfloat(2*gpcon+gpdis) gptet=tetcor(prev, gprec/prev) end if if ((mat(2)+mat(3)) > 0) then marrec=dfloat(2*mat(3))/dfloat(2*mat(3)+mat(2)) martet=tetcor(prev, marrec/prev) end if write(outstr,'(3x,a,7x,f5.3,2(7x,i5),7x,f6.3,5(/3x,a,7x,f5.3,2(7x,i5),7x,f6.3))') & 'Marital ',marrec, mat(3), mat(2), martet, & 'Gparent ', gprec, gpcon, gpdis, gptet, & 'Halfsib ', hsrec, hscon, hsdis, hstet, & 'Par-Off ', porec, pocon, podis, potet, & 'Fullsib ', ssrec, sscon, ssdis, sstet, & 'MZ twin ', mzrec, mzcon, mzdis, mztet end subroutine segrat ! ! 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=dfloat(dzxcon(4)+dzxcon(3))/dfloat(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=dfloat(dzxcon(4)+dzxcon(2))/dfloat(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=dfloat(ncases)/dfloat(npairs+npairs) if (ncases>0) then con=dfloat(2*concord(group,3))/dfloat(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/dfloat(a+b+c+d) e(1)=den*dfloat((a+b)*(a+c)) e(2)=den*dfloat((a+b)*(b+d)) e(3)=den*dfloat((a+c)*(c+d)) e(4)=den*dfloat((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, ' (', dfloat(aff)/dfloat(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=dfloat(totaff)/dfloat(totnum) aff2=0.0d0 sum1=0.0d0 sum2=0.0d0 siz2=0.0d0 do ped=1, iped dn=dfloat(afftab(ped,2)) dev=dfloat(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+dfloat(afftab(ped,1)**2)/dn siz2=siz2+dn*dn end do dn=dfloat(totnum) sum1=sum1-dn chit=sum1*sum1/2/sum2 msa=(aff2-dfloat(totaff*totaff)/dn)/dfloat(max(1,iped-1)) msw=(dfloat(totaff)-aff2)/dfloat(totnum-iped) k=(dn-siz2/dn)/dfloat(max(1,iped-1)) icr=(msa-msw)/(msa+(k-1.0d0)*msw) 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 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 subroutine tarone ! ! Segregation ratios using Davie 1976 ! subroutine davie(loc1, trait, loc2, proband, dataset, plevel) use outstream use ped_class implicit none character (len=10), intent(in) :: loc1 integer, intent(in) :: trait character (len=10), 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=dfloat(t(i)-j(i)) if (den > 0.0d0) then phat(i)=dfloat(r(i)-j(i))/den se(i)=dfloat((r(i)-j(i))*(t(i)-r(i)))/den**3.0d0 + & dfloat(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,4i9/3x,a8,4(1x,i3,a1,i4),2(/3x,a8,4(4x,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 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)/dfloat(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/dfloat(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 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, parameter :: NCLASS=18 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 integer :: i, j, js, pedoffset, ped, pos, sta, currf, currm, nships, nsibs 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 ! totpairs=0 do i=1, 6 totpairs=totpairs+npairs(i) end do do i=16, 18 totpairs=totpairs+npairs(i) end do dojack=(iter > 0 .and. totpairs > 2 .and. (totpairs < 10000 .or. plevel > 0)) 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=(dfloat(nobserved)-dfloat(drawsize))/dfloat(drawsize)/dfloat(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', & '--------------------------------------------------------------', & ' --------------' write(outstr,'(a,3(1x,f12.4),2x,i7,1x,f7.4,1x,f7.4)') & 'Husband Wife ', cvar(REL_MAR,1), cvar(REL_MAR,2), & cov(REL_MAR), npairs(REL_MAR), & jcov(REL_MAR), jsecov(REL_MAR) write(outstr,'(a,3(4x,f9.4),2x,i7,1x,f7.4,1x,f7.4)') & 'Gparent Gchild', cvar(REL_GRAND,1), cvar(REL_GRAND,2), & cov(REL_GRAND), npairs(REL_GRAND), & jcov(REL_GRAND), jsecov(REL_GRAND) write(outstr,'(a,4x,f9.4,17x,f9.4,2x,i7,1x,f7.4,1x,f7.4)') & 'Halfsib Hsib ', cvar(REL_HALF,1), & cov(REL_HALF), npairs(REL_HALF)/2, & jcov(REL_HALF), jsecov(REL_HALF) if (npairs(REL_AVUNC) > 0) then write(outstr,'(a,3(1x,f12.4),2x,i7,1x,f7.4,1x,f7.4)') & 'Avuncular ', cvar(REL_AVUNC,1), cvar(REL_AVUNC,2), & cov(REL_AVUNC), npairs(REL_AVUNC), & jcov(REL_AVUNC), jsecov(REL_AVUNC) end if if (npairs(REL_COZ) > 0) then write(outstr,'(a,4x,f9.4,17x,f9.4,2x,i7,1x,f7.4,1x,f7.4)') & 'Full Cousins ', cvar(REL_COZ,1), & cov(REL_COZ), npairs(REL_COZ)/2, & jcov(REL_COZ), jsecov(REL_COZ) end if if (npairs(REL_DCOZ) > 0) then write(outstr,'(a,4x,f9.4,17x,f9.4,2x,i7,1x,f7.4,1x,f7.4)') & 'Double Cousins', cvar(REL_DCOZ,1), & cov(REL_DCOZ), npairs(REL_DCOZ)/2, & jcov(REL_DCOZ), jsecov(REL_DCOZ) end if write(outstr,'(a,3(4x,f9.4),2x,i7,1x,f7.4,1x,f7.4)') & 'Parent Off ', cvar(REL_PO,1), cvar(REL_PO,2), & cov(REL_PO), npairs(REL_PO), & jcov(REL_PO), jsecov(REL_PO) write(outstr,'(a,4x,f9.4,17x,f9.4,2x,i7,1x,f7.4,1x,f7.4)') & 'Fullsib Fsib ', cvar(REL_FS,1), & cov(REL_FS), npairs(REL_FS)/2, & jcov(REL_FS), jsecov(REL_FS) if (npairs(REL_MZ) > 0) then write(outstr,'(a,4x,f9.4,17x,f9.4,2x,i7,1x,f7.4,1x,f7.4)') & 'MZ Twins ', cvar(REL_MZ,1), & cov(REL_MZ), npairs(REL_MZ)/2, & jcov(REL_MZ), jsecov(REL_MZ) end if if (npairs(REL_PO) > 0) then write(outstr,'(4(/a,3(4x,f9.4),2x,i7,1x,f7.4,1x,f7.4))') & 'Father Son ', cvar(7,1),cvar(7,2),cov(7), & npairs(7), jcov(7), jsecov(7), & 'Father Dau ', cvar(8,1),cvar(8,2),cov(8), & npairs(8), jcov(8), jsecov(8), & 'Mother Son ', cvar(9,1),cvar(9,2),cov(9), & npairs(9), jcov(9), jsecov(9), & 'Mother Dau ', 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))') & 'Brothers ', cvar(11,1), cov(11), & npairs(11)/2, jcov(11), jsecov(11), & 'Sisters ', 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)') & 'Brother-Sister', 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))') & 'MZ Males ', cvar(14,1), cov(14), & npairs(14)/2, jcov(14), jsecov(14), & 'MZ Females ', 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 > 10000.', & '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) ! 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)/dfloat(max(1,tnum(1)-1)) tvar(2)=tvar(2)/dfloat(max(1,tnum(2)-1)) tvar(3)=tvar(3)/dfloat(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 correlations ! subroutine famcovar(trait, dataset, npairs, mu, cvar, cov) use ped_class implicit none integer, parameter :: KNOWN=0, MISS=-9999 integer, parameter :: NCLASS=18 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 integer, intent(in) :: trait type (ped_data) :: dataset integer, dimension(NCLASS) :: npairs double precision, dimension(NCLASS) :: cov(NCLASS) double precision, dimension(NCLASS,2) :: mu(NCLASS,2), cvar(NCLASS,2) ! 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=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 end do 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 (.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(16,x1,x2,NCLASS,npairs,mu,cvar,cov) call corr(16,x2,x1,NCLASS,npairs,mu,cvar,cov) else if (parsibs == 2) then x2=dataset%plocus(j,trait) call corr(17,x1,x2,NCLASS,npairs,mu,cvar,cov) call corr(17,x2,x1,NCLASS,npairs,mu,cvar,cov) else if (avunc > 0) then x2=dataset%plocus(j,trait) call corr(18,x1,x2,NCLASS,npairs,mu,cvar,cov) end if end if end do end if end do 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 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/dfloat(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,i5,2(/a,f10.4,a,f10.4,a)/a,f10.4,a,i3,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 ! ! 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=dfloat(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)/dfloat(max(1,npairs(i)-1))) var(i,2)=sqrt(var(i,2)/dfloat(max(1,npairs(i)-1))) if (var(i,1) > 0.0d0 .and. var(i,2) > 0.0d0) then cov(i)=cov(i)/dfloat(max(1,npairs(i)-1))/var(i,1) /var(i,2) else cov(i)=0.0d0 end if end do end subroutine corrstd ! ! Means and covariances for multiple trait ! typ=1 means and covariances ! 2 plus PCA ! subroutine docov(typ, nterms, terms, loc, loctyp, locpos, dataset) use outstream use covariate_data implicit none integer, intent(in) :: typ integer, intent(in) :: nterms integer, dimension(:), intent(inout) :: terms 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 ! 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, nobs, ncov, ntot, ped 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(nterms*nterms), 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*dfloat(g1+g2) else if (loctyp(terms(j)) == LOC_AFF) then x(j)=dataset%plocus(i,locpos(terms(j)))-1.0d0 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 call covcor(nterms, nobs, cov) write(outstr,'(/a/a)') & 'Variable Mean Stand Dev Correlations', & '---------- ------------ ------------ ---------------------' ii=0 do i=1,nterms ii=ii+i write(outstr,'(a10,1x,f12.4,1x,f12.4,12(1x,f4.2))') & loc(terms(i)),mean(i),sqrt(cov(ii)), (cov(ii-i+j),j=1,i-1), 1.0D0 cov(ii)=1.0d0 end do write(outstr,'(2(/a,i7),a,f5.1,a)') & 'Number of variables =',nterms, & 'No. usable observations =',nobs, ' ( ', & float(100*nobs)/float(ntot),'%)' if (typ == 2) 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, intent(out) :: logl integer, intent(out) :: df integer, intent(in) :: plevel integer, intent(in) :: nwid, ndec ! integer, parameter :: MAXMIX=5 integer, parameter :: MISS=-9999 ! Quantitative trait values type (table_data) :: table integer :: ncells, ntot integer, dimension(:), allocatable :: counts double precision, dimension(:), allocatable :: vals ! Parameter estimates double precision :: alpha(MAXMIX), mean(MAXMIX), sd(MAXMIX) ! Likelihood contributions double precision, dimension(:,:), allocatable :: prob double precision, dimension(:), allocatable :: den ! local variables integer :: i, ifail, j, ped, pedoffset real :: inita, initsd character (len=10), dimension(4) :: dist=(/ & ' Normal ','Norm: 1 SD','Exponentl ',' Poisson '/) ! 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 ! ! Produce a histogram with HISTCAT intervals ! call sort_table(1, table) call dohist(locnam, min(table%ncells, histcat), 1, table, nwid, ndec, outfil) call filliben(table) call symtest(table) ! ! starting values for mixture ! ifail=0 inita=1.0/float(nmix) initsd=sqrt(table%categories(3*table%ncells/4,1)-table%categories(table%ncells/4,1)) do i=1, nmix alpha(i)=inita mean(i)=table%categories(i*table%ncells/(nmix+1),1) sd(i)=initsd end do ! allocate(prob(table%ncells, MAXMIX)) allocate(den(table%ncells)) call mixture(typ, nmix, table%ncells, table%categories(1:table%ncells, 1), 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 > 0) 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, table%categories(j,1), table%icount(j), (alpha(i)*prob(j,i)/den(j), i=1, nmix) end do end if if (ifail /= 0) then write(outstr,'(/a/)') 'ERROR: Problem encountered in estimation.' end if 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 subroutine domix ! ! 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 integer, parameter :: MAXMIX=5 ! ! a=distribution type Nor(k sd) Nor(1 sd) Exp Poi ! 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(MAXMIX) double precision, intent(inout) :: mean(MAXMIX) double precision, intent(inout) :: sd(MAXMIX) ! ! Likelihood contributions ! double precision, intent(out) :: f(m,MAXMIX) 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 double precision, parameter :: tol=1.0D-6 logical :: test integer :: counter double precision :: oldlogl, part, poolv, poolsd, sumalpha ! Updated estimates double precision :: nalpha(MAXMIX), nmean(MAXMIX), nsd(MAXMIX), & dt(MAXMIX), nt(MAXMIX), vt(MAXMIX) 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 do j=1,k if ((alpha(j) > 1).or.(alpha(j) <= 0)) then ifail=2 return end if if ((mean(j) >= x(m)).or.(mean(j) <= x(1))) then ifail=3 return end if if (a < 3 .and. sd(j) <= 0) then ifail=4 return 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 ! logl=0.0d0 do i=1,m g(i)=0.0d0 do j=1,k if (a == 3) then f(i,j)=exp(-x(i)/mean(j))/mean(j) else if (a == 4) then if (i == 1) then f(i,j)=exp(-mean(j))*mean(j)**x(i) else f(i,j)=f(i-1,j)*mean(j)**(x(i)-x(i-1)) end if else f(i,j)=exp(-0.5*((x(i)-mean(j))/sd(j))**2)/sd(j) 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.0 ! 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)/dfloat(nobs) sumalpha=sumalpha+nalpha(j) else nalpha(k)=1.0-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/dfloat(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 end if end subroutine mixture ! ! linear regression analysis of quantitative trait ! subroutine regress(typ, nterms, terms, loc, loctyp, locpos, & gene, genemod, allele_buffer, dataset, mlik, mpar, plevel) use outstream use AS164_class use alleles_class use ped_class use locus_types use covariate_data use statfuns implicit none integer, intent(in) :: typ ! position of y and x variables integer, intent(in) :: nterms integer, dimension(:), intent(inout) :: terms 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 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 double precision, 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, ypos, vpos logical :: comp, fussy ! 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 double precision :: ln 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 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*dfloat(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 values(1)=dataset%plocus(i,locpos(pos)) ii=search_table(1, values, covariates%martable(icat))-1 if (ii > 0) x(vpos+ii)=x(vpos+ii) + 1 vpos=vpos+ncat 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)/dfloat(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)) aic=zp(tval) call phist(aic, 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+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 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 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=dfloat(nobs) * (ln(mss+rss)-ln(rss)) mpar=idf if (typ >= 0) then rsq=1.0d0-rss/(rss+mss) mss=mss/dfloat(mdf) rss=rss/dfloat(idf) aic=log(rss)+2.0d0*dfloat(mdf)/dfloat(nobs) write(outstr,'(/a,i7,a,f5.1,a,2(/a,f12.4,a,i4,a),2(/a,f12.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 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 (j == 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*dfloat(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)) 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,locpos(ypos)) /= MISS) then nchange=nchange+1 dataset%plocus(i,locpos(ypos))=dataset%plocus(i,locpos(ypos))-pred else if (ityp == 3 .or. & (ityp == 2 .and. dataset%plocus(i,ypos) == MISS)) then nchange=nchange+1 dataset%plocus(i,locpos(ypos))=pred end if else if (ityp == 1) then dataset%plocus(i,locpos(ypos))=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, 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_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 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, nterms, terms, & loctyp, locpos, covariates, dataset, x) 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=dfloat(naff)/dfloat(nobs) base=dfloat(naff)*log(base)+ dfloat(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 =', dfloat(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 =', dfloat(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/dfloat(max(1,itused-1)) pval=dfloat(tailp)/dfloat(itused) statval(3)=vbeta/dfloat(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 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/dfloat(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)/dfloat(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 ! subroutine rcp(nr, nc, iter) use outstream integer, intent(in) :: nr integer, intent(in) :: nc integer, intent(in) :: iter ! local variables integer, dimension(nr*nc) :: tble double precision, dimension(nr*nc) :: e integer :: i, j, idx, ncells idx=0 ncells=nr*nc 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 write(outstr,'(3x, 100(1x,i6):)') (j, j=1,nc) write(outstr,*) idx=0 do i=1, nr write(outstr,'(i3, 100(1x,i6):)') i, (tble(j), j=idx+1, idx+nc) idx=idx+nc end do write(outstr,*) call rctest(nr, nc, tble, e, iter) return ! input error 100 write(outstr,'(a,i3,a)') 'ERROR: expected ',ncells,' counts!' end subroutine rcp ! ! 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+dfloat(i-1)*tble(idx) mc=mc+dfloat(j-1)*tble(idx) end do end do dtot=1.0d0/dfloat(tot) mc=mc*dtot mr=mr*dtot idx=0 do i=1, nr do j=1, nc idx=idx+1 e(idx)=dfloat(rows(i))*dfloat(cols(j))*dtot cov=cov+tble(idx)*(dfloat(i-1)-mr)*(dfloat(j-1)-mc) sr=sr+tble(idx)*(dfloat(i-1)-mr)*(dfloat(i-1)-mr); sc=sc+tble(idx)*(dfloat(j-1)-mc)*(dfloat(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=dfloat(tot-1)*cov*cov/sr/sc df=(nr-1)*(nc-1) pval=chip(obschi,df) write(outstr,'(/a,i0/a,f7.2/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=dfloat(ncon)*dtot t2=dfloat(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,dfloat(tble(isub(1))*tble(isub(4)))/ & dfloat((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,dfloat(tble(isub(2))*tble(isub(3)))/ & dfloat((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=dfloat(ip)/dfloat(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+dfloat(icount)*log(dfloat(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/dfloat(tot) idx=0 do i=1, nr do j=1, nc idx=idx+1 e(idx)=dfloat(rows(i))*dfloat(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,i5,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 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 real :: telapsed, ttaken(2) ! functions double precision :: dataset_uses, isaff #if SUN real :: dtime telapsed=dtime(ttaken) #else call dtime(ttaken, telapsed) #endif 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) 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, loc, loctyp, plevel) use outstream 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) :: loc, loctyp integer, dimension(dataset%maxsiz) :: key ! integer, parameter :: MISS=-9999 integer :: cfa, cmo, eop, i, idx, ii, ndesc, nmat, nmh, noff, nph, nsibs integer :: num, ped, pedoffset ! functions ! logical strfind interface subroutine prrel(iclass, ped, dataset, key, eop, loc, loctyp) use ped_class implicit none integer, intent(in) :: iclass integer, intent(in) :: ped type (ped_data) :: dataset integer, dimension(:), intent(in) :: key integer, intent(in) :: eop integer, intent(in) :: loc, loctyp 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 ndesc=0 nmh=0 noff=0 nph=0 nsibs=0 cfa=dataset%fa(idx) cmo=dataset%mo(idx) pedoffset=dataset%num(ped-1) num=dataset%num(ped)-pedoffset 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, loc, loctyp, 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, loc, loctyp, dataset) write(outstr,'(1x,3a)', advance='no') & trim(dataset%pedigree(ped)), '-', trim(dataset%id(cmo)) call appval(cmo, loc, loctyp, dataset) write(outstr,*) end if write(outstr,'(a,4x,i3,$)') 'Siblings', nsibs call prrel(-1, ped, dataset, key, eop, loc, loctyp) if (nph > 0) then write(outstr,'(a,i3,$)') 'Pat halfsibs', nph call prrel(-2, ped, dataset, key, eop, loc, loctyp) end if if (nmh > 0) then write(outstr,'(a,i3,$)') 'Mat halfsibs', nph call prrel(-3, ped, dataset, key, eop, loc, loctyp) end if write(outstr,'(a,3x,i3,$)') 'Offspring', noff call prrel(2, ped, dataset, key, eop, loc, loctyp) write(outstr,'(a,i3,$)') 'Descendants ', ndesc call prrel(3, ped, dataset, key, eop, loc, loctyp) ! 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, dataset, key, eop, loc, loctyp) 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, dataset, key, eop, loc, loctyp) use outstream use ped_class implicit none integer, intent(in) :: iclass integer, intent(in) :: ped type (ped_data) :: dataset integer, dimension(:), intent(in) :: key integer, intent(in) :: eop integer, intent(in) :: loc, loctyp ! 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, loc, loctyp, dataset) end if end do write(outstr,*) end subroutine prrel ! ! append locus value if asked ! subroutine appval(idx, loc, loctyp, dataset) use outstream use ped_class use locus_types implicit none integer, intent(in) :: idx, loc, loctyp type (ped_data) :: dataset integer, parameter :: KNOWN=0, MISS=-9999 integer :: g1, g2 character (len=1) :: ch character (len=11) :: gtp if (loc /= MISS) then if (loctyp == LOC_AFF) then ch='x' if (dataset%plocus(idx,loc)==MISS) then call wraff(dataset%plocus(idx,loc), ch, 2) end if write(outstr,'(3a)', advance='no') ' (', ch ,')' else if (same_loctyp(loctyp, LOC_CAT) .or. & same_loctyp(loctyp, LOC_QUA)) then if (dataset%plocus(idx,loc)==MISS) then write(outstr,'(a)', advance='no') ' (x)' else write(gtp, '(g11.4)') dataset%plocus(idx,loc) write(outstr,'(3a)', advance='no') ' (', trim(adjustl(gtp)) ,')' end if else if (isactdip(loctyp)) then call get_geno(idx, loc, loc+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(loctyp, LOC_HAP)) then call get_geno(idx, loc, loc+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 of all pairs 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 :: 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)) ! 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 individuals with information for a criterion trait ! subroutine wricas(wrk, wrk2, trait, dataset) use outstream use ped_class implicit none 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, 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 do i=1, dataset%nfound(ped) ii=ii+1 if (dataset%plocus(ii,trait) /= MISS) then aff(i)=2 else aff(i)=1 end if end do do i=dataset%nfound(ped)+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 ! 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 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, ios) 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 ! subroutine joinped(wrk, wrk2, typ, farg, larg, words, & nloci, loc, locpos, loctyp, locnotes, & dataset, chek, droperr, plevel) use outstream use ped_class use locus_types 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 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 csort(n, cx, iy) integer, intent(in) :: n character (len=*), intent(inout) :: cx(*) integer, intent(in out) :: iy(*) end subroutine csort subroutine check(checkall, nloci, loc, loctyp, locpos, locnotes, & dataset, droperr, ndiscard, inconsist, plevel) use ped_class 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=*), dimension(:), intent(in) :: locnotes 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=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.' 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, 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 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, 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 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 dsort(n, dx) ! integer, intent(in) :: n ! double precision, dimension(:) :: dx ! end subroutine dsort 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 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) n=dataset%num(ped) if (assfnd) then n=pedoffset+dataset%nfound(ped) end if if (typ == 1) then do i=pedoffset+1, n dataset%untyped(i)=.false. if (.not.observed(i, gene, dataset)) then dataset%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 dataset%untyped(i)=.false. if (.not.observed(i, gene, dataset)) then dataset%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=dfloat(nobs) * (ln(bss)-ln(orss)) asyp=chip(lrts, max(1, mdf-1)) mss=mss/dfloat(max(1, mdf)) orss=orss/dfloat(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+dfloat(counts(i))*(b(i)-mu)**2 end do end do vg=vg/dfloat(tot) end if write(outstr,'(a/a,f12.4,3x,f12.4,1x,i7)') & ' ----------------------------------------------', & ' Total ',mu, sqrt(bss/dfloat(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) 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.dataset%untyped(i) .and. dataset%plocus(i,trait) /= MISS) then do j=1,ncats x(j)=0.0d0 end do x(nter)=dataset%plocus(i,trait) x(set(i-pedoffset,1))=x(set(i-pedoffset,1))+1 x(set(i-pedoffset,2))=x(set(i-pedoffset,2))+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.dataset%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/dfloat(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/dfloat(max(1, it-1)) pval=dfloat(tailp)/dfloat(it) ! if (topvals(ntopvals) >= 1.0d0/orss) then ! pval=dfloat(tailp)/dfloat(it) ! else ! pval=evdtailp(it, ntopvals, topvals, 1.0d0/orss) ! end if 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), ')' 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,'(a14,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 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 ! 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 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, iencgtp 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, set, xlinkd) use ped_class integer, intent(in) :: ped type (ped_data) :: dataset 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 dataset%untyped(i)=.false. if (.not.observed(i, gene, dataset)) then dataset%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 dataset%untyped(i)=.false. if (.not.observed(i, gene, dataset)) then dataset%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.dataset%untyped(dataset%fa(i)) .and. & .not.dataset%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.dataset%untyped(i) .and. & .not.dataset%untyped(dataset%fa(i)) .and. & .not.dataset%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,'(a14,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*dfloat(rdf)/dfloat(allelic_df) asyp=fp(oftest, allelic_df, rdf) orss=orss/dfloat(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/dfloat(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, 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*dfloat(max(1,rdf))/dfloat(max(1,mdf)) rss=rss/dfloat(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=dfloat(tailp)/dfloat(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,'(a14,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 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 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, set, xlinkd) use ped_class integer, intent(in) :: ped type (ped_data) :: dataset 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. dataset%untyped(i)=.false. if (.not.observed(i, gene, dataset)) then dataset%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.dataset%untyped(i) .and. & .not.dataset%untyped(dataset%fa(i)) .and. & .not.dataset%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,'(a14,2(1x,i6),1x,f10.1,2(1x,f6.4),1x,i6,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=dfloat(nobs) * (ln(bss)-ln(orss)) asyp=chip(lrts,max(1,mdf-1)) mss=mss/dfloat(max(1,mdf)) orss=orss/dfloat(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/dfloat(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) 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, 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/dfloat(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/dfloat(max(1, it-1)) pval=dfloat(tailp)/dfloat(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,'(a14,2(1x,i6),1x,f10.1,2(1x,a),1x,i8,2(1x,a))') & locnam, nobs, mdf, lrts, pstring(asyp), pstring(pval), it, 'ANOVA-CPG',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)=dfloat(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 double precision, 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) val(j)=dfloat(g1) end do hval(i)=search_table(nloc, val, haplotable) 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 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(i), '(', dfloat(counts(ii))/dfloat(max(1,nobs)), ')' call wrall(int(haplotable%categories(pos,1)), allel) write(outstr,'(5x,a)', advance='no') trim(adjustl(allel)) do j=2, nloc2 call wrall(int(haplotable%categories(pos,j)), 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 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,'(a14,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=dfloat(nobs) * (ln(bss)-ln(orss)) asyp=chip(lrts, max(1, mdf-1)) mss=mss/dfloat(max(1, mdf)) orss=orss/dfloat(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)), allel) haplo=trim(adjustl(allel)) do j=2, nloc call wrall(int(haplotable%categories(pos,j)), 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/dfloat(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/dfloat(haplotable%ntot) tot=haplotable%icount(1) cumhaps(1)=den*dfloat(tot) cumhaps(nhap)=1.0d0 do i=2, nhap-1 tot=tot+haplotable%icount(i) cumhaps(i)=den*dfloat(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/dfloat(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/dfloat(max(1, it-1)) pval=dfloat(tailp)/dfloat(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,'(a14,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, iter, mincnt, dataset, pval, plevel, typ) use interrupt use outstream use contingency_table use ped_class use locus_types use rngs use statfuns 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 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 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 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,'(a14,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, '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=pearson(1, nhap, traitlevels, nca, cntall) asyp=chip(ochisq,df) ! Gst calculation diversities=1.0d0 do k=1, traitlevels den=dfloat(max(1,nca(k))) do j=1, nhap p=dfloat(cntall(j,k))/den pt=dfloat(cntall(j,traitlevels+1))/dfloat(nobs) diversities(k)=diversities(k)-p*p ht=ht+(p-pt)**2 end do diversities(k)=dfloat(max(1,nca(k)))/dfloat(max(1,nca(k)-1)) * & diversities(k) hs=hs+diversities(k) end do ht=1.0d0+ht/(dfloat(max(1,nobs*(nobs-1)))) do j=1, nhap pt=dfloat(cntall(j,traitlevels+1))/dfloat(nobs) ht=ht-pt*pt end do hs=hs/dfloat(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), cval, & loctyp(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)), allel) haplo=trim(adjustl(allel)) do j=2, nloc call wrall(int(haplotable%categories(pos,j)), 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), '(', dfloat(cntall(i,k))/dfloat(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 Pearson chi-sq =', 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/dfloat(haplotable%ntot) tot=haplotable%icount(1) cumhaps(1)=den*dfloat(tot) cumhaps(nhap)=1.0d0 do i=2, nhap-1 tot=tot+haplotable%icount(i) cumhaps(i)=den*dfloat(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=pearson(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/dfloat(max(1,it-1)) pval=dfloat(tailp)/dfloat(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,'(a14,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, loctyp, locnotes, locnam, gene, genetyp, & iter, mincnt, norder, assfnd, gt, thresh, conibd, dataset, & freqfnd, use_fixfreq, fixfreq_buffer, allele_buffer2, & prevalence, pval, 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 statfuns implicit none integer, intent(in) :: trait integer, intent(in) :: loctyp character (len=*), intent(in) :: locnotes 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) :: 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 :: d, eh, nhom double precision :: h0, h01, hs, hs1, ht, ht1, fis, fit, fst ! other local variables integer :: df, g1, g2, gen2, geno, i, 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, & 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 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 dsort(n, dx) integer, intent(in) :: n double precision, dimension(:) :: dx end subroutine dsort 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 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 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 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 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 ntot=ntot+1 if (multcat) then aff(i)=findlev(dataset%plocus(i,trait), traittable) else aff(i)=int(isaff(dataset%plocus(i,trait), thresh, gt)) end if call get_namedgeno(i, gene, gen2, dataset, allele_buffer, g1, g2) if (allelic) then cntall(g1, aff(i))=cntall(g1, aff(i))+1 cntall(g2, aff(i))=cntall(g2, aff(i))+1 if (g1 == g2) nhom(aff(i))=nhom(aff(i))+1 else if (allele_buffer%xlinkd .and. dataset%sex(i)==1) then nmal=nmal+1 cntall(ncats+g1, aff(i))=cntall(ncats+g1, aff(i))+1 else geno=clcpos(g1,g2) cntall(geno,aff(i))=cntall(geno,aff(i))+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. .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, dfloat(nca(k)/2)) h01=1.0d0-dfloat(nhom(k))/d(k) h0=h0+h01 hs1=0.25d0*dfloat(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*dfloat(cntall(k,i)*cntall(k,j))/d(i)/d(j) end do ht=ht+ht1+ht1 end do end do h0=h0/dfloat(traitlevels) hs=hs/dfloat(traitlevels) ht=ht/dfloat(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 end if ! Calculate association statistic if ((nca(1)+nmalca(1)) > 0) then gen_nloci=gen_nloci+1 pexp=dfloat(nca(1))/dfloat(nca(1)+nca(2)) if (typ==2 .and. allele_buffer%xlinkd .and. sexlim==1) then pexp=dfloat(nmalca(1))/dfloat(nmalca(1)+nmalca(2)) end if ochisq=pearson(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, dfloat(nca(2))) conden=max(1.0d0, dfloat(nca(1))) casfrq=dfloat(cntall(testall,2))/casden confrq=dfloat(cntall(testall,1))/conden testall=cntall(testall,4) end if if (plevel > 0) then write(outstr,'(/a,a10,2a)') & ' ---- Association Analysis for "',locnam,'" ', & repeat('-', 5+max(0,traitlevels-2)*14) 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), cval, loctyp, locnotes, 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, dfloat(nca(2))) conden=max(1.0d0, dfloat(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, dfloat(nca(k))) write(outstr,'(2x,i5,1x,a1,f4.3,a1)', advance='no') & cntall(i,k), '(', dfloat(cntall(i,k))/casden, ')' end do write(outstr,'(i8)') cntall(i,traitlevels+1) end do else odds0=(dfloat(cntall(allele_buffer%topall,2))+0.5d0) / & (dfloat(cntall(allele_buffer%topall,1))+0.5d0) do i=1, ncats odds1=(dfloat(cntall(i,2))+0.5d0) / & (dfloat(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), '(', dfloat(cntall(i,2))/casden, ')', & cntall(i,1), '(', dfloat(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, dfloat(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, dfloat(nmalca(2))) conden=max(1.0d0, dfloat(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, dfloat(nmalca(k))) write(outstr,'(2x,i5,1x,a1,f4.3,a1)', advance='no') & cntall(i,k), '(', dfloat(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), '(', dfloat(cntall(i,2))/casden, ')', & cntall(i,1), '(', dfloat(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(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 + (0.5d0*va+0.25d0*vd)/prevalence/prevalence write(outstr,'(/a,3x,f6.4/a,2(3x,f6.4)/a,f9.4/a,3x,f6.4,3a)') & ' Assumed trait prevalence =', prevalence, & ' Genetic variances VA, VD =', va, vd, & ' Sib recurrence risk ratio =', prrr, & ' Attributable risk =', attrisk,' (', trim(cval), ')' end if write(outstr,'(/a,f7.2/a,i4/a,3x,a)') & ' Contingency Pearson chi-sq =', 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. 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 .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=pearson(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)') 'Pseudosample ',it,': Chisq=',chisq 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 end if end do if (tailp < mincnt) then tailp=tailp+1 it=it+1 end if vchisq=vchisq/dfloat(max(1,it-1)) if (topvals(ntopvals) >= ochisq) then pval=dfloat(tailp)/dfloat(it) else pval=evdtailp(it, ntopvals, topvals, ochisq) end if 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,'(a14,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 goodall=1 if (typ == 13) then ! tabulate minor allele (in controls) do i=2, ncats if (cntall(i,1) < cntall(goodall,1)) goodall=i end do else if (typ == 14) then ! tabulate risk allele do i=2, ncats if (cntall(i,2)*cntall(goodall,1) > cntall(goodall,2)*cntall(i,1)) goodall=i end do end if call wrall(testall, allel) write(outstr,'(a14,a1,i6,a1,a6,2(a1,f6.4),a1,f10.1,2(a1,a),a1,i6,a1,2a,a1,a)') & locnam, tabsep, ntot, tabsep, allel, & tabsep, casfrq, tabsep, confrq, & tabsep, ochisq, tabsep, pstring(asyp), & tabsep, pstring(pval), tabsep, it, tabsep, & 'AssX2-', ana, tabsep, histo else write(outstr,'(a14,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 (iter == 0) pval=asyp end subroutine doassoc ! ! 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*dfloat(cntall(i,3)) den1=dfloat(cntall(i,3))-den2 num2=dfloat(cntall(i,2))-den2 num1=dfloat(cntall(i,1))-den1 twobyk=twobyk+(num1*num1)/den1+(num2*num2)/den2 end if end do return end function twobyk ! ! 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/dfloat(tot) do i=sta, fin if (cntall(i,nlev+1) > 0) then numer=dfloat(cntall(i, nlev+1)) do j=1, nlev nexp=dfloat(nca(j))*numer*denom dev=dfloat(cntall(i,j))-nexp if (nexp > 0.0d0) pearson=pearson+dev*dev/nexp end do end if end do return end function pearson ! ! 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)/dfloat(max(1,it-1)) end do ! ! Sequential P-value simulation ! ochisq=0.0D0 pos=0 do j=1, allele_buffer%numal obs=dfloat(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=dfloat(tailp)/dfloat(it) end if vchisq=vchisq/dfloat(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)=(dfloat(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,'(a14,2(a1,i6),a1,f10.1,2(a1,a),a1,i6,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,f7.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, locnam, gt, thresh, gene, allele_buffer, & stratvar, strattyp, stratlabels, & dataset, pval, plevel) use outstream use alleles_class use ped_class use contingency_table use statfuns implicit none integer, intent(in) :: trait character (len=*), intent(in) :: locnam integer, intent(in) :: gt double precision, intent(in) :: thresh integer, intent(in) :: gene type (allele_data), intent(in) :: allele_buffer integer, intent(in) :: stratvar integer, intent(in) :: strattyp character (len=*), intent(in) :: stratlabels type (ped_data) :: dataset double precision, intent(out) :: pval integer, intent(in) :: plevel ! local variables integer, parameter :: KNOWN=0, MISS=-9999 ! table of strata type (table_data) :: 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 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, tausq double precision :: adjwt, adjsw, ase, dev, num, sumwt, w2 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 (allele_buffer%numal /= 2) return if (plevel > 0) then write(outstr,'(/2a/)') 'Results for: ', locnam end if gen2=gene+1 ! 3 genotypes for a SNP nlevels=3 nobs=0 adju=0.0d0 pval=1.0d0 call setup_table(1, 30, strata) 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) call insert_table(1, val, strata, 1) dataset%untyped(i)=.false. end if end do end if end do nobs=strata%ntot nstrata=strata%ncells if (nobs == 0) then if (plevel > 0) then write(outstr,'(a)') 'No complete 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)) call get_namedgeno(i, gene, gen2, dataset, allele_buffer, g1, g2) gtp=g1+g2-1 counts(is,gtp,iaff)=counts(is,gtp,iaff)+1 end if end do end if end do ! do i=1, nstrata totc=0.0d0 tote=0.0d0 do j=1, nlevels tote=tote+dfloat(counts(i,j,1)) totc=totc+dfloat(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=dfloat(counts(i,j,1)) nc=dfloat(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 num=0.0d0 adju=0.0d0 adjsw=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-dfloat(max(1,nstrata-1)))/(sumwt-w2/sumwt) if (tausq < 0.0d0) tausq=0.0d0 end if do i=1, nstrata adjwt=0.0d0 if (w(i) > 0.0d0) adjwt=1.0d0/(1.0d0/w(i)+tausq) 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 df=nstrata-1 pval=chip(u,1) if (adju > 0.0d0) pval=chip(adju, 1) if (plevel > 0) then write(outstr,'(a/a)') 'Stratum N theta ASE Het', & '--------- ------ ------- ------- -------' do i=1, nstrata pos=strata%idx(i) call wrtrait(strata%categories(pos,1), cval1, strattyp, stratlabels, 9, 4) ase=0.0d0 if (w(i) > 0.0d0) ase=1.0d0/sqrt(w(i)) write(outstr,'(a,i8,3(1x,f7.2))') & cval1, strata%icount(i), theta(i), ase, het(i) 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 = ', chip(q, df) 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)') & ' Asymptotic P-value = ', pval else write(outstr,'(a,g9.4)') & ' Asymptotic P-value = ', pval 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)') & ' Pooled Odds Ratio =', exp(amu), & ' (', trim(adjustl(cval1)), ' -- ', trim(adjustl(cval2)), ')' 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, nobs, tabsep, nstrata, tabsep, adju, tabsep, & pstring(pval), tabsep, 'WhiX2', tabsep, histo end if end subroutine whitehead ! ! 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, set, xlinkd) use ped_class integer, intent(in) :: ped type (ped_data) :: dataset 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.dataset%untyped(dataset%fa(i)) .and. & .not.dataset%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.dataset%untyped(dataset%fa(i)) .and. & .not.dataset%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 person ', & 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*(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*dfloat(par2)/dfloat(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*dfloat(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*dfloat(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*dfloat(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 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 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 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 do j=1, num write(outstr,*) trim(pedigree), j, fa(j), mo(j), set(j,1), & set(j,2), sibd(j,1), sibd(j,2) end do end if else fin=.false. end if end if end do if (fin) 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,*) 'In pedigree ', trim(pedigree),', index person #', 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/dfloat(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*dfloat(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*dfloat(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/dfloat(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, topfrq, 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/dfloat(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/dfloat(2*tfound) ! ! EM iterations ! do i=1, allele_buffer%numal allele_buffer%allele_freqs(i)=1.0d0/dfloat(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=dfloat(emit+1)/dfloat(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,*) topfrq=0.0d0 do i=1, allele_buffer%numal if (allele_buffer%allele_freqs(i) > topfrq) then topfrq=allele_buffer%allele_freqs(i) allele_buffer%topall=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), & dfloat(proprate(i))/dfloat(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(3-allele_buffer%topall) 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)=dfloat(icounts(1)) counts(2)=0.5*dfloat(icounts(2)) counts(3)=counts(2) counts(4)=0.5*dfloat(icounts(3)) counts(5)=counts(4) counts(6)=0.5*dfloat(icounts(4)) counts(7)=counts(6) counts(8)=dfloat(icounts(5)) counts(9)=0.5*dfloat(icounts(6)) counts(10)=counts(9) counts(11)=dfloat(icounts(7)) counts(12)=0.5*dfloat(icounts(8)) counts(13)=counts(12) counts(14)=0.5*dfloat(icounts(9)) counts(15)=counts(14) counts(16)=dfloat(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*dfloat(naff) e2=4*p0*q0*p0*p0*dfloat(naff) e3=2*p0*p0*q0*q0*dfloat(naff) e4=4*p0*q0*p0*q0*dfloat(naff) e5=4*p0*q0*q0*q0*dfloat(naff) e6=q*q*q*q*dfloat(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/6x,a,9x,a,3(1x,a)/a)') & '------------------------------------------------------------', & '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)=dfloat(icounts(2)) counts(2)=dfloat(icounts(3)) counts(3)=dfloat(icounts(5)) counts(4)=0.5*dfloat(icounts(6)) counts(5)=counts(4) counts(6)=dfloat(icounts(7)) counts(7)=dfloat(icounts(8)) counts(8)=dfloat(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 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 dsort(n, dx) integer, intent(in) :: n double precision, dimension(:) :: dx end subroutine dsort 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/dfloat(nca) obs=den*dfloat(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*dfloat(ehomoz)-expp)/(1.0d0-expp)) 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,i5)') 'Pseudosample ',it,': No. homoz=',ehomoz end if topvals(1)=chisq call dsort(ntopvals,topvals) end do if (tailp < mincnt) then tailp=tailp+1 it=it+1 end if if (topvals(ntopvals) >= ochisq) then pval=dfloat(tailp)/dfloat(it) else pval=evdtailp(it, ntopvals, topvals, ochisq) end if 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 call phist(pval,pval,histo) write(outstr,'(a14,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 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 implicit none character(len=10), 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/dfloat(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/dfloat(sibs))) rdp=rdpnum/sqrt(rdpden*(0.25d0-pivar/dfloat(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,f12.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/dfloat(max(1,it-1))) pval=dfloat(tailp)/dfloat(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,f10.4,a,f10.4,a/a,f10.4,a,f10.4,a)') & 'Intercept (f-s) = ',oalpha,' (ase=', sea,')', & 'Slope = ',obeta, ' (ase=', seb,')' write(outstr,'(a,f10.4,a,i4,3a)') & 't value = ',tvalb,' (df=',df, ', P=', trim(pstring(asyp)) ,')' 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 Beta=',mub,' (',sdb,')' ! Score and RDP test write(outstr,'(/a,f10.4,3a)') & 'Score test (f-s) = ',ascore,' (P=', trim(pstring(zp(ascore))) ,')' write(outstr,'(a,f10.4,3a)') & 'Robust Disc Pair t = ',rdp,' (P=', trim(pstring(zp(rdp))),')' else call phist(asyp,pval,histo) if (mappos /= MISS) then write(cmap,'(f10.3)') mappos end if write(outstr,'(a14,2(1x,i6),1x,f10.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/dfloat(max(1,sibs-1))/vay rh=rh/dfloat(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* dfloat(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*dfloat(d)/dfloat(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 double precision :: binp 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*dfloat(2*tabf(3)+tabf(2))/dfloat(nfs) if (nhs > 0) muh=0.5D0*dfloat(2*tabh(3)+tabh(2))/dfloat(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=dfloat(nfs)*f(i) obs=dfloat(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,dfloat(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/dfloat(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/dfloat(nfs), pstring(pval), 'ASP', histo end if end if if (nhs > 0) then chih=0.0D0 do i=1,3 ex=dfloat(nhs)*h(i) obs=dfloat(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=10), 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, 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=dfloat(iter) gen2=gene+1 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 if (plevel > 0) then write(outstr,'(a,a10//a,/)') & 'Pedigree ', dataset%pedigree(ped), ' Insufficient persons 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)/dfloat(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)/dfloat(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(dfloat(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,i5,a,i5,a)') & 'Total of ',nt,' affecteds and ',ut,' unaffecteds used.' else call phist(zp(t(1,2)), zsum(1,2), histo) write(outstr,'(a14,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,'(a14,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(dfloat(nfam(1)))) zsum(5,1)=zp(zsum(5,1)/sqrt(dfloat(nfam(1)))) end if if (nfam(2) > 0) zsum(2,1)=zp(zsum(2,1)/sqrt(dfloat(nfam(2)))) if (nfam(4) > 0) zsum(4,1)=zp(zsum(4,1)/sqrt(dfloat(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,i5,a,i5,a)') & 'Total of ', nt, ' affecteds and ', ut, ' unaffecteds used.' else call phist(zp(t(1,1)), logp(1), histo) write(outstr,'(a14,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,'(a14,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(dfloat(naff-1))/sqrt(var) else if (typ == 3 .and. unaff > 1) then makewt=sqrt(dfloat(unaff-1))/sqrt(var) else if (typ == 2 .and.(naff+unaff) > 1) then makewt=sqrt(dfloat(naff+unaff-1))/sqrt(var) else if (typ == 4 .and.(naff+unaff) > 1) then makewt=dfloat(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 pre