! ! Fortran 95 version of Sib-pair ! ! 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) ! Main author: Martin Hierholzer ! ! 2) Interface to ZLib ! module extras character (len=60) :: version = VERSION #if !OPEN64 character (len=32), parameter :: hasextras = ' ' & #if JAPI // '(JAPI/AWT GUI) ' & #elif PILIB // '(PILIB GUI) ' & #endif #if ZLIB // '(zlib) ' & #endif #if POPEN // '(pipes) ' & #endif // ' ' #else character (len=32), parameter :: hasextras = ' ' #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 ! ! time/random number generator seeds ! module rndseed integer :: ix,iy,iz integer :: initix,initiy,initiz end module rndseed ! ! epoch for Julian dates (defaults to 2440588==1970-01-01), ! module julian_epoch double precision :: epoch = 2440588.0d0 end module julian_epoch ! ! 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 #else integer, parameter :: eofcode = -1 integer, parameter :: eolcode = -2 #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 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, 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 ! #if !OPEN64 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', form='unformatted', & status='old', iostat=ios) if (ios /= 0) then write(outstr, '(a)') 'ERROR: Cannot open "', trim(filnam), '".' return end if read(s, iostat=ios) ch1, ch2 if (ios /= 0) then write(outstr, '(a)') '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 #else function isgzipped(filnam) logical :: isgzipped character (len=*), intent(in) :: filnam integer :: eon eon=len_trim(filnam) isgzipped=(filnam(max(1,(eon-1)):eon) == 'gz') end function isgzipped #endif ! ! Open a (plain or gzipped) file or pipe for reading or writing ! subroutine open_port(filnam, port, mode, ios) 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 gzipped=isgzipped(filnam) #if POPEN apipe=((mode == 'r' .and. filnam(eon:eon) == '|') .or. & (mode == 'w' .and. filnam(1:1) == '|')) #endif 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 ! ! 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 ! 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 type (ioport) :: port integer :: ioerr, narg, newsiz, oldsiz character (len=100) :: s character (len=40), dimension(2) :: words interface 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 end subroutine end interface 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' .and. words(1)(1:1) /= 'S') 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 ! ! 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 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 integer :: hassnps ! indicate if SNP genotype data is present and storage type ! 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 ! integer (kind=1), dimension(:,:), allocatable :: 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%plocus(nobs, ipheno), stat=astat) allocate(dataset%glocus(nobs, igeno), stat=astat) if (astat /= 0) then write(*,*) 'Tried to allocate ', nobs, '*', igeno, ' storage for markers.' end if if (isnps > 0) then dataset%hassnps = snpstorage end if allocate(dataset%slocus(nobs, isnps), stat=sstat) allocate(dataset%untyped(nobs)) if (sstat /= 0) then write(*,*) 'Tried to allocate ', nobs, '*', isnps, ' storage for SNPs.' if (sstat /= 0) then astat=sstat end if end if end subroutine setup_peds ! ! copy pedigree data ! subroutine copy_peds(set1, set2) type (ped_data) :: set1, set2 integer :: i, 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 set2%slocus(1:nobs,1:isnps) = set1%slocus(1:nobs,1:isnps) 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 (allocated(dataset%slocus)) then deallocate(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 integer(kind=1), dimension(:,:), allocatable :: tmp astat=0 oldcol=0 oldloc=0 if (.not.allocated(dataset%slocus)) then allocate(dataset%slocus(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 slocus(', dataset%nobs,',', newcol,').' return end if dataset%hassnps=snpstorage dataset%slocus=0 else oldcol=dataset%numcol(SCLASS) oldloc=dataset%numloc(SCLASS) allocate(tmp(dataset%nobs,oldloc), stat=astat) if (astat /= 0) then write(*,'(a)') 'Unable to allocate work array!' return end if tmp=dataset%slocus(1:dataset%nobs,1:oldloc) deallocate(dataset%slocus) allocate(dataset%slocus(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 slocus(', dataset%nobs,',', newcol,').' return end if dataset%hassnps=snpstorage dataset%slocus(1:dataset%nobs,1:oldloc)=tmp ! bit pattern for missing dataset%slocus(1:dataset%nobs,(oldloc+1):newcol)=0 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, parameter :: MISS=-9999 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) is=2*int(ibits(dataset%slocus(idx, imaj), imin, 1)) - 1 imin=imin+1 g=int(ibits(dataset%slocus(idx, imaj), 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 else g1=dataset%slocus(idx, -gcol1) g2=dataset%slocus(idx, 1-gcol1) if (abs(g1) > 64) g1=sign(10000,g1)+g1 if (abs(g2) > 64) g2=sign(10000,g2)+g2 end if end subroutine get_geno ! ! 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, imin 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 dataset%slocus(idx, imaj)=ibclr(dataset%slocus(idx, imaj), imin-1) dataset%slocus(idx, imaj)=ibclr(dataset%slocus(idx, imaj), imin) dataset%slocus(idx, imaj)=ibclr(dataset%slocus(idx, imaj), imin+1) ! sign bit (observed or unobserved) if (g1 /= MISS) then g=g1+g2 if (0 < g .and. g < 5) then dataset%slocus(idx, imaj)=ibset(dataset%slocus(idx, imaj), imin-1) end if g=abs(g) ! genotype 01=1/1 10=1/2 11=2/2 if (g == 3) then dataset%slocus(idx, imaj)=ibclr(dataset%slocus(idx, imaj), imin) dataset%slocus(idx, imaj)=ibset(dataset%slocus(idx, imaj), imin+1) else if (g == 4) then dataset%slocus(idx, imaj)=ibset(dataset%slocus(idx, imaj), imin) dataset%slocus(idx, imaj)=ibset(dataset%slocus(idx, imaj), imin+1) else if (g == 2) then dataset%slocus(idx, imaj)=ibset(dataset%slocus(idx, imaj), imin) dataset%slocus(idx, imaj)=ibclr(dataset%slocus(idx, imaj), imin+1) end if end if else imin=g1 imaj=g2 if (abs(g1) > 10000) imin=-sign(10000,g1)+g1 if (abs(g2) > 10000) imaj=-sign(10000,g2)+g2 dataset%slocus(idx, -gcol1)=imin dataset%slocus(idx, -gcol1+1)=imaj 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 :: imaj, imin 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) observed=(ibits(dataset%slocus(idx, imaj), imin, 1) == 1) else observed = (dataset%slocus(idx, -gcol) > 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, imaj, imin 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) g=int(ibits(dataset%slocus(idx, imaj), 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 missing = (dataset%slocus(idx, -gcol) == KNOWN) end if end function missing ! subroutine show_ped_allocation(dataset) type (ped_data) :: dataset integer :: i, j, ter 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), ' (=', & size(dataset%slocus,2) + 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', allocated(dataset%slocus) if (allocated(dataset%slocus)) then write(*,'(i12,a)', advance='no') size(dataset%slocus), ' : ' do i=1, ter write(*,'(3(b8.8,a):)', advance='no') & (dataset%slocus(i,j), ' ', j=1,min(3,dataset%numloc(SCLASS)/2)) 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 if (gpos < 1 .or. idx < 1 .or. idx > dataset%nobs .or. & .not.allocated(dataset%slocus)) return call get_geno(idx, -gpos, -gpos, dataset, g1, g2) imaj=(gpos-1)/2 + 1 imin=4*mod(gpos-1, 2) write(*,'(i5,i5,1x,b8.8,1x,i1,a,i1,2(1x,a,l1),2(1x,a,i0),1x,4i1)') & idx, gpos, dataset%slocus(idx,(gpos-1)/2+1), & g1,'/',g2, & 'obs=', observed(idx, -gpos, dataset), & 'mis=', missing(idx, -gpos, dataset), & 'imaj=', imaj, 'imin=', imin, & ibits(dataset%slocus(idx, imaj), imin, 1), & ibits(dataset%slocus(idx, imaj), imin+1, 1), & ibits(dataset%slocus(idx, imaj), imin+2, 1), & ibits(dataset%slocus(idx, imaj), imin+3, 1) end subroutine show_snp end module ped_class ! ! Allele frequency data structure ! module alleles_class private public :: allele_data, copyfreq, expand_alleles, cleanup_alleles, genot, calc_gtp_freqs 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 ! ! Copy allele frequency data from one structure to another ! subroutine copyfreq(allele_buffer, allele_buffer2) type (allele_data), intent(inout) :: 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 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 ! ! Alan Miller's zp ! Normal distribution probabilities accurate to 1.e-15. ! Z = no. of standard deviations from the mean. ! Based upon algorithm 5666 for the error function, from: ! Hart, J.F. et al, 'Computer Approximations', Wiley 1968 ! function zp(z) double precision :: zp double precision :: z, p, expntl, zabs double precision, parameter :: & p0 = 220.2068679123761D0, & p1 = 221.2135961699311D0, & p2 = 112.0792914978709D0, & p3 = 33.91286607838300D0, & p4 = 6.373962203531650D0, & p5 = .7003830644436881D0, & p6 = .03526249659989109D0 double precision, parameter :: & q0 = 440.4137358247522D0, & q1 = 793.8265125199484D0, & q2 = 637.3336333788311D0, & q3 = 296.5642487796737D0, & q4 = 86.78073220294608D0, & q5 = 16.06417757920695D0, & q6 = 1.755667163182642D0, & q7 = .08838834764831844D0 double precision, parameter :: & rootpi = 2.506628274631001D0, & cutoff = 7.071067811865475D0 zabs = abs(z) ! ! |Z| > 37 ! if (zabs > 37) then p = 0 else ! ! |z| <= 37 ! expntl = exp( -zabs**2/2 ) ! ! |z| < cutoff = 10/sqrt(2) ! if (zabs < cutoff) then p = expntl*( (((((p6*zabs + p5)*zabs + p4)*zabs + p3)*zabs & + p2)*zabs + p1)*zabs + p0)/(((((((q7*zabs + q6)*zabs & + q5)*zabs + q4)*zabs + q3)*zabs + q2)*zabs + q1)*zabs & + q0 ) ! ! |z| >= cutoff. ! else p = expntl/( zabs + 1/( zabs + 2/( zabs + 3/( zabs & + 4/( zabs + 0.65d0 ) ) ) ) )/rootpi end if 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 AS 111, Appl.Statist., vol.26, 118-121, 1977. ! Produces normal deviate corresponding to lower tail area = p. ! DOUBLE PRECISION FUNCTION ppnd(p) DOUBLE PRECISION, INTENT(IN) :: p DOUBLE PRECISION :: q, r DOUBLE PRECISION :: a0, a1, a2, a3, b1, b2, b3, b4, & c0, c1, c2, c3, d1, d2, split DOUBLE PRECISION :: half, one, zero DATA split/0.42D0/ DATA a0,a1,a2,a3/2.50662823884D0,-18.61500062529D0, & 41.39119773534D0,-25.44106049637D0/, b1,b2,b3,b4/ & -8.47351093090D0,23.08336743743D0,-21.06224101826D0, & 3.13082909833D0/, c0,c1,c2,c3/-2.78718931138D0,-2.29796479134D0, & 4.85014127135D0,2.32121276858D0/, d1,d2/3.54388924762D0, 1.63706781897D0/ DATA zero/0.d0/, one/1.d0/, half/0.5D0/ q = p-half IF (ABS(q) > split) GO TO 10 ! 0.08 < p < 0.92 r = q*q ppnd = q*(((a3*r + a2)*r + a1)*r + a0)/((((b4*r + b3)*r + b2)*r + b1)*r + one) RETURN ! p < 0.08 or p > 0.92, set r = min(p,1-p) 10 r = p IF (q > zero) r = one-p IF (r <= zero) GO TO 20 r = SQRT(-LOG(r)) ppnd = (((c3*r + c2)*r + c1)*r + c0)/((d2*r + d1)*r + one) IF (q < zero) ppnd = -ppnd RETURN 20 CONTINUE ppnd = zero RETURN 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 /) ! functions ! double precision :: alngam 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 ! ! 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 ! ! Miniscm ! module scheme_lang use extras use interrupt use outstream use iobuff #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 = '00005' 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_QUOTE=11, OP_DEF0=12, OP_DEF1=13, OP_BEGIN=14, & OP_IF0=15, OP_IF1=16, OP_SET0=17, OP_SET1=18, OP_LET0=19, OP_LET1=20, & OP_LET2=21, OP_LET0AST=22, OP_LET1AST=23, OP_LET2AST=24, OP_LET0REC=25, & OP_LET1REC=26, OP_LET2REC=27, OP_COND0=28, OP_COND1=29, OP_DELAY=30, & OP_AND0=31, OP_AND1=32, OP_OR0=33, OP_OR1=34, OP_C0STREAM=35, OP_C1STREAM=36, & OP_0MACRO=37, OP_1MACRO=38, OP_CASE0=39, OP_CASE1=40, OP_CASE2=41 integer, parameter :: OP_PEVAL=42, OP_PAPPLY=43, OP_CONTINUATION=44, OP_ADD=45, & OP_SUB=46, OP_MUL=47, OP_DIV=48, OP_INTDIV=49, OP_REM=50, OP_MOD=51, & OP_CAR=52, OP_CDR=53, OP_CONS=54, OP_SETCAR=55, & OP_SETCDR=56, OP_NOT=57, OP_BOOL=58, OP_ISINT=59, OP_ISREAL=60, & OP_NULL=61, OP_ZEROP=62, OP_POSP=63, & OP_NEGP=64, OP_NUMEQ=65, OP_LESS=66, OP_GRE=67, OP_LEQ=68, OP_GEQ=69, OP_SYMBOL=70, & OP_NUMBER=71, OP_STRING=72, OP_PROC=73, OP_PAIR=74, OP_EQ=75, OP_EQV=76, & OP_FORCE=77, OP_WRITE=78, OP_DISPLAY=79, OP_NEWLINE=80, OP_ERR0=81, & OP_ERR1=82, OP_REVERSE=83, OP_APPEND=84, OP_PUT=85, OP_GET=86, OP_QUIT=87, & OP_GC=88, OP_GCVERB=89, OP_NEWSEGMENT=90 integer, parameter :: OP_RDSEXPR=91, OP_RDLIST=92, OP_RDDOT=93, OP_RDQUOTE=94, OP_RDQQUOTE=95, & OP_RDUNQUOTE=96, OP_RDUQTSP=97 integer, parameter :: OP_P0LIST=98, OP_P1LIST=99, OP_LIST_LENGTH=100, OP_ASSQ=101, OP_PRINT_WIDTH=102, & OP_P0_WIDTH=103, OP_P1_WIDTH=104, OP_GET_CLOSURE=105, OP_CLOSUREP=106, & OP_MACROP=107 integer, parameter :: OP_EXP=108, OP_LOG=109, OP_SIN=110, OP_COS=111, & OP_TAN=112, OP_ASIN=113, OP_ACOS=114, OP_ATAN=115, & OP_SQRT=116, OP_TRUNCATE=117, OP_ROUND=118, & OP_ABS=119, OP_EXPT=120 integer, parameter :: OP_MIN=121, OP_MAX=122, OP_RANDOM=123 integer, parameter :: OP_MKSTRING=124, OP_STRLEN=125, OP_STRSET=126, & OP_SUBSTR=127, OP_STRAPPEND=128, OP_STRSPLIT=129, & OP_STREQ=130, OP_STRLT=131, OP_STRGT=132, & OP_STRLE=133, OP_STRGE=134, OP_STRFIND=135, & OP_CHAR2INT=136, OP_INT2CHAR=137, & OP_STR2NUM=138, OP_NUM2STR=139, & OP_SYM2STR=140, OP_STR2SYM=141 integer, parameter :: OP_SYSTEM=142, OP_IPORT=143, OP_OPORT=144, & OP_CLPORT=145, OP_CURR_INPORT=146, & OP_CURR_OUTPORT=147, OP_RDLINE=148, OP_FORMAT=149, & OP_RUNCMD=150, OP_LSLOCI=151, OP_NLOCI=152, & OP_LOCNAM=153, OP_LOCTYP=154, OP_LOCORD=155, & OP_LOCSTAT=156, OP_SETSTAT=157, OP_LOCNOT=158, & OP_SETNOTE=159, OP_LOCRANK=160, & OP_MAPPOS=161, OP_CHROM=162, OP_STATRES=163, & OP_FDATE=164, OP_GETENV=165, OP_INQUIRE=166, & OP_APROPOS=167, OP_HELP=168, OP_VERSION=169 integer, parameter :: OP_PNORM=170, OP_QNORM=171, OP_PCHISQ=172, & OP_QCHISQ=173, OP_PFDIST=174, OP_BIVNOR=175, & OP_GAMMAD=176, OP_ALNGAM=177 #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 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 ! 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 ! ! input 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) else 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, & 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, & 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(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(*,*) 'GC recovered ', fcells, ' of ', memsiz, ' cells' write(*,*) 'nextfree=', nextfree 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' call gc(a, b, 0) ! write(*,*) 'Called GC, nextfree=', nextfree 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) 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 get_value=transfer(mem(p)%value, get_value) 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 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(nam) integer :: mk_string character (len=*), intent(in) :: nam integer :: tmp tmp=getcell(nil, nil) call set_type(tmp, ior(T_STRING, T_ATOM)) call set_string(tmp, nam) 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 ! ! 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 (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) end do reverse=p end function reverse ! ! Reverse list -- no new cell generated ! function non_alloc_rev(term, list) integer :: non_alloc_rev integer, intent(in) :: term, list integer :: i, p, res, q i=0 p=list res=term do while (p /= nil) i=i+1 q=cdr(p) call set_cdr(p, res) res=p p=q end do non_alloc_rev=res end function non_alloc_rev ! ! append list -- make new cells ! function append(a, b) integer :: append integer, intent(in) :: a, b integer :: p, q, tmp p=b tmp=a if (tmp /= nil) then tmp = reverse(tmp) do while (tmp /= nil) q = cdr(tmp) call set_cdr(tmp, p) p = tmp tmp = q end do end if append=p end function append ! ! equivalence of atoms ! function eqv(a, b) logical :: eqv integer, intent(in) :: a, b eqv=.false. if (isstring(a)) then if (isstring(b)) then eqv=streq(a, b) end if else if (isnumber(a)) then if (isnumber(b)) then eqv=(get_ivalue(a) == get_ivalue(b)) end if else eqv=(a == b) end if end function eqv ! ! 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 reslen=len(res) res=' ' pos=0 rdloop: do call inchar(ch) if (currentline > eol) exit rdloop if (scheme_delim(ch)) exit rdloop pos=pos+1 if (pos <= reslen) res(pos:pos)=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') '#' 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 ! 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) 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)) ! 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) end if if (cdr(code) /= nil) then call s_save(OP_BEGIN, nil, cdr(code)) end if code = car(code) oper=OP_EVAL ! 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 end if call s_save(OP_LET1AST, cdr(code), car(code)) code=cadaar(code) oper=OP_EVAL ! 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 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) end if oper=OP_BEGIN 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) end if call s_save(OP_AND1, nil, cdr(code)) code=car(code) oper=OP_EVAL ! 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) code = cadr(code) if (.not.issymbol(x)) then call error0('Variable is not symbol') 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 ! 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.0 do while (x /= nil) if (.not.isnumber(car(x))) then call error1('Argument 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)) 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 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 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 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 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 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 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 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 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 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 ! subroutine opexe3(op) integer :: op integer :: x integer (kind=8) :: 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_ivalue(car(scm_args)) == 0) ! positive? else if (op == OP_POSP) then call s_retbool(get_ivalue(car(scm_args)) > 0) ! negative? else if (op == OP_NEGP) then call s_retbool(get_ivalue(car(scm_args)) < 0) ! =, <, >, <=, >= else if (op >= OP_NUMEQ .and. op <= OP_GEQ) then x = cdr(scm_args) if (.not.isnumber(car(scm_args))) then call error1('Argument is not a number: ', car(scm_args)) return else v = get_ivalue(car(scm_args)) end if do while (x /= nil) if (.not.isnumber(car(x))) then call error1('Argument is not a number: ', car(x)) return else if (op == OP_NUMEQ) then comp=(v==get_ivalue(car(x))) else if (op == OP_LESS) then comp=(vget_ivalue(car(x))) else if (op == OP_LEQ) then comp=(v<=get_ivalue(car(x))) else if (op == OP_GEQ) then comp=(v>=get_ivalue(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))) ! 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 ! 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 (.not.ispair(car(scm_args))) then call error0('argument of reverse must be a pair') 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 call setup_mem(int(get_ivalue(car(scm_args)), kind=4)) 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 ! 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 ! 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)) call s_return(mk_real(rv)) ! 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) 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 ! random else if (op == OP_RANDOM) then if (isnumber(car(scm_args))) then v=get_ivalue(car(scm_args)) call s_return(mk_number(int(irandom(1, int(v, kind=4)), kind=8))) 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-set! else if (op == OP_STRSET) then i=get_ivalue(cadr(scm_args)) 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) 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(reverse(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))) ! 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 ! subroutine opexe10(op, plevel) use statresults use locus_data use locus_types integer :: op integer, intent(in) :: plevel integer, parameter :: MISS = -9999 integer :: d, i, imod, ioerr, j, l, n, 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 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') call s_return(f) 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) //'"!') call s_return(f) 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) // '"!') call s_return(f) 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!') call s_return(f) end if else call error0('Not a port!') call s_return(f) 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!') call s_return(f) end if else call error0('Not a port!') call s_return(f) 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 (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) ! run a Sib-pair command else 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) 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 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(reverse(res)) ! number of loci else if (op == OP_NLOCI) then call s_return(mk_number(int(nloci, kind=8))) ! 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!') call s_return(f) 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 !') call s_return(f) 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 ! fdate, getenv else if (op == OP_FDATE) then call s_return(mk_string(trim(fdate()))) 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) ! 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 write(outstr, '(a)') & 'Sib-pair Scheme 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.', & '(ls []) creates a list of locus names (of given type "adhmqx").', & '(nloci) returns total number of loci.', & '(loc ) returns locus at that position in the locus list.', & '(locord ) returns position of a locus in the locus list.', & '(locstat ) returns last P-value for a locus.', & '(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.', & '(stat-result ["pval|lik|npars|lrt|df|stat|var"]) returns result of last model.', & '(seq ) generate sequence.', & '(system ) passes command to shell.', & '(getenv ) returns value of environment variable.', & '(date) returns current date and time.', & '(run ...) runs a Sib-pair command.', & '(pass-command ...) stores Sib-pair commands to the buffer', & 'for evaluation once you return to the usual Sib-pair prompt.' write(outstr, '(a)') & 'Statistical procedures include:', & ' (pnorm ) (qnorm

) (fp )', & ' (pchisq []) (qchisq

)', & ' (bivnor ) (pgamma

) (lgamma )' #if JAPI write(outstr, '(a)') & 'JAPI AWT GUI procedures include:', & ' (j_start) (j_quit) (j_frame) (j_show ) (j_hide )', & ' (j_list ) (j_label ) (j_additem )', & ' (j_textarea ) (j_menu ) (j_gettext )', & ' (j_button ) (j_fileselect

)' #endif call s_return(un) else if (op == OP_VERSION) then call s_return(mk_string(trim(version))) 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 p1, p2 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 ! ! GUI library (japi) ! #if JAPI subroutine opexe12(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!') 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!') call s_return(f) 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 opexe12 #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_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_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_RANDOM, 'random') call mk_proc(OP_MKSTRING, 'make-string') call mk_proc(OP_STRLEN, 'string-length') 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_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_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_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_GETENV, 'getenv') call mk_proc(OP_INQUIRE, 'file-exists?') call mk_proc(OP_APROPOS, 'apropos') call mk_proc(OP_HELP, 'help') call mk_proc(OP_VERSION, 'version') ! statistical procedures 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 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 (map proc list) (if (pair? list) (cons (proc (car list)) (map proc (cdr list)))))' 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 (gcd a b) (let ((aa (abs a)) (bb (abs b)))' // & '(if (= bb 0) aa (gcd bb (remainder aa bb)))))' call repl_scheme(3,0) scheme_lin='(define (lcm a b) (if (or (= a 0) (= b 0)) 0 ' // & '(abs (* (quotient a (gcd a b)) b))))' 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 (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) 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') 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)) , '"' write(*,'(8x,a)') s 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_VERSION) then call opexe10(op, plevel) else if (op >= OP_PNORM .and. op <= OP_ALNGAM) then call opexe11(op) #if JAPI else if (op >= OP_JSTART .and. op <= OP_JSETFLOWLAYOUT) then call opexe12(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 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(4) = (/ 'Gaussian', 'Binomial', 'Poisson ', & 'Weibull '/) 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 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 ! ! 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 ! 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 ! ! 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,20x,a6/a14,20x,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) use outstream integer, intent(in) :: n double precision, dimension(:), intent(in) :: c integer :: i, pos pos=0 do i=1, n write(outstr,'(7x,10(1x,f6.4):)') 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 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) 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 ! functions real :: random 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 popgen_vcdata 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 statfuns use statresults use scheme_lang ! ! Pedigree storage ! type (ped_data) :: work ! ! 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 ! Hash table for IDs type (hash_table) :: hashtab 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 ! 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 :: assfnd=.false., chek=.true., & fbatimp=.true., fixshape=.false., hassex=.false., 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 ! 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, 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 = 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, typ=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, 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 integer :: aval, chfind, findwh, findword, ival, sow logical :: iscomment, iscomp, isint, isreal, strfind 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, wrk, wrk2, nloci, loc, loctyp, locpos, & group, map, locnotes, dataset, plevel) use ped_class integer, intent(in) :: typ 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, 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(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 character (len=2), dimension(:), intent(out) :: group double precision, dimension(:), intent(out) :: 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, & 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 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 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, allele_buffer, & 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 type (allele_data), intent(inout) :: allele_buffer 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, nloci, loc, loctyp, locpos, dataset) use ped_class use locus_types implicit none integer, intent(in) :: strm 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 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 args(s, narg, arg, typ) character (len=*), intent(in) :: s integer, intent(in) :: typ integer, intent(inout) :: narg character (len=*), dimension(:), intent(out) :: arg end subroutine args 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, & tabsep, 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) :: tabsep 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, & 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 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, 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 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, dataset, & mlik, mpar, 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 type (ped_data) :: dataset double precision, intent(out) :: mlik integer, intent(out) :: mpar 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, 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 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, 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 ! 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 ! 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, 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 ! 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, locnam, gene, iter, mincnt, norder, & assfnd, gt, thresh, conibd, dataset, allele_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) :: locnam integer, intent(in) :: gene 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 type (allele_data), intent(inout) :: allele_buffer type (allele_data), intent(inout) :: 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, iter, mincnt, gt, thresh, fbatimp, & dataset, allele_buffer, plevel) use alleles_class use ped_class implicit none integer, intent(in) :: trait character (len=*), intent(in) :: locnam integer, intent(in) :: gene integer, intent(in) :: iter integer, intent(in) :: mincnt integer, intent(in) :: gt double precision, intent(in) :: thresh logical, intent(in) :: fbatimp type (ped_data) :: dataset type (allele_data), intent(inout) :: allele_buffer 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, & 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_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 globhom(nloci, loc, loctyp, locpos, map, allele_buffer, dataset, plevel) use outstream use alleles_class use ped_class use locus_types implicit none 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 (allele_data) :: allele_buffer type (ped_data) :: dataset integer, intent(in) :: plevel end subroutine globhom 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(nterms, terms, loc, loctyp, locpos, & gene, allele_buffer, & nmark, mark, dataset, & mlik, mpar, pval, plevel, burnin, iter, typ, toler) use interrupt use outstream use alleles_class use ped_class use ibd_class use AS164_class use AS319 implicit none 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 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 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 preseg(nvar, fixed, loc, gene, allele_buffer) use AS164_class use alleles_class use mcmc_model integer, intent(in) :: nvar integer, dimension(MAXPAR), intent(in) :: fixed character (len=20), dimension(:), intent(in) :: loc integer, intent(inout) :: gene type (allele_data) :: allele_buffer end subroutine preseg subroutine segsim(linkf, modtyp, shap, trait, gt, thresh, offset, censor, & nfix, nvar, fixed, gene, 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) :: nfix integer, intent(in) :: nvar integer, dimension(:), intent(inout) :: fixed integer, intent(in) :: gene 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 ! allocate(allele_buffer%allele_names(100)) allocate(allele_buffer%allele_freqs(100)) allocate(allele_buffer%cum_freqs(100)) allocate(allele_buffer2%allele_names(100)) allocate(allele_buffer2%allele_freqs(100)) allocate(allele_buffer2%cum_freqs(100)) allocate(fixfreq_buffer%allele_names(10)) allocate(fixfreq_buffer%allele_freqs(10)) allocate(fixfreq_buffer%cum_freqs(10)) allocate(mcmc_buffer%allele_names(10)) allocate(mcmc_buffer%allele_freqs(10)) allocate(mcmc_buffer%cum_freqs(10)) ! ! 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-2010', & #else '|\\/| Version : ', trim(version), & '|/\\| Author : David L Duffy (c) 1995-2010', & #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 hassex=.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(5))) then map(nloci)=fval(words(5)) k=k+1 end if call annotate(k, narg, words, locnotes(nloci)) 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 else if (keyword == 'set' .and. & (keyw2 == 'dir' .or. keyw2 == 'dat')) then if (narg > 2) then call getword(lin, 3, datdir) else call fchooser(datdir, gui, plevel) call extpath(datdir) end if inquire(file=datdir, exist=filexist) if (.not.filexist) then write(outstr,'(/3a)') & 'ERROR: Directory "',trim(datdir), '" not found.' datdir=' ' end if if (plevel > -1) 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 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) 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) 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 call setup_plink(port, i, j) call rdplink(port, nloci, loc, locpos, outpos, loctyp, locnotes, & numloc, group, map) call close_port(port, ioerr) 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 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' .and. red) then i=3 do while (i <= narg) call locfmt(words(i), j, newtyp) if (ismarker(newtyp)) then write(outstr, '(a,i0,a)') & 'Increasing memory allocation to allow ', j, ' markers.' if (iscompressed(newtyp)) then call expand_sgeno(j, work, k) else call expand_geno(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 ! Pedigree file to read from 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=.false. if (keyw2 == 'lin') then link=1 else if (keyw2 == 'ppd') then link=2 else if (keyw2 == 'cas') then link=3 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 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 pedfil='inline.ped' call mknewfil(OSTR, pedfil, wrkdir, ioerr) if (ioerr == 0) then call wrinline(nlin, OSTR) close(OSTR,STATUS='keep') 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 ! numloc(1:NDATACLASS)=0 ! call cleanup_peds(work) if (pedfil /= ' ') then call extprefix(pedfil) 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, & 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 call readpeds(port, WRK, WRK2, skipline, link, unspecified, & twinning, gt, thresh, sexchek, & numloc, coltyp, work, longnam, i, nwarn, plevel) else call readcases(port, hassex, skipline, numloc, coltyp, & work, longnam, i, nwarn, plevel) end if call close_port(port, ioerr) 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, allele_buffer, & 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 (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_QUA, LOC_AFF, 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 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 (trait /= MISS) then if ((loctyp(trait) == LOC_QUA .or. loctyp(trait) == DEL_QUA) .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 to [] 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 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.' 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, work, & nwid, ndec, mlik(whlik), mpar(whlik), pval, plevel) else typ=4 nord=3 locord(2)=trait locord(3)=censor 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), trait, 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 (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) 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 Morgan parameter file: ', trim(outfil) end if write(OSTR, '(2a/a//3a/a/)') & '# Morgan type parameter file for ', trim(lin), & '# Written by Sib-pair', & 'input pedigree file "', trim(lin), '"', & 'set normalized frequencies' 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, '(a8,1x,a8)') loc(i), 'VARIABLE' else write(ostr, '(2a8)') loc(i), 'VARIABLE' 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') then typ=14 outfil=words(4) if (plevel > -2) then write(*,'(/2a)') 'Writing Eclipse type locus file: ', trim(outfil) end if open(OSTR,file=outfil, iostat=ioerr) if (ioerr /= 0) then write(outstr,'(3a)') 'ERROR: Cannot open "', trim(outfil), '"' cycle end if 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 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 call toupper(keyw2) 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) == 'fou') typ=2 if (plevel > -2) then write(outstr,'(/2a)') 'Writing Beagle 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 wrbeagle(OSTR, typ, nloci, loc, loctyp, locpos, work) close(OSTR, status='keep') elseif (words(2) == 'pap') then open(OSTR,file='trip.dat') open(OSTR2,file='phen.dat') if (plevel > -2) then write(*,'(/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 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 nord=min(nloci, nrc) j=1 if (keyword=='tai') j=max(1,nloci-nrc) 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, & 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 == '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 call listids(work, 1, plevel) else if (keyw2(1:2) == 'mz') then thresh=0.0d0 gt=16 if (twintype==2) gt=21 call countmz(locpos(twinning), gt, thresh, work, plevel+1) 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 == '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 == '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 == '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)) 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 delfile(words(i), 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 inquire(file=words(i), exist=filexist) if (filexist) then write(outstr, '(3a)') & 'File "', trim(words(i)), '" exists.' else write(outstr, '(3a)') & 'Unable to access file "', trim(words(i)), '".' end if end do else if (keyw2 == 'cat') then do i=3, narg call cat(words(i), lin) 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 head(words(n), j, lin) else do i=3, n write(outstr,'(/3a/)') '"', trim(words(i)), '":' call head(words(i), j, lin) 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') the