sics/fcircle.tcl

#----------------------------------------------------------------------------
# fcircle is a collection of SICS-Tcl macro scripts which help with
# the running of a four circle diffractometer. The central idea is
# a data base file which can be manipulated both from SICS and from 
# external programs. The name of this database file is expected to live in
# the SICS variable dbfile. 
#
# Mark Koennecke, November 1999
#---------------------------------------------------------------------------


#----------- fcircleinit
# fcircleinit must be called from the SICS initialization script and will
# then install all necessary variables and the commands defined by this 
# script into SICS. 

proc fcircleinit {} {
   VarMake dbfile Text User
   Publish writepos  User 
   Publish writerefl User
   Publish clearrefl User
   Publish listrefl  User
   Publish updateub  User
   Publish setlambda User
   Publish fcentre   User
}

#------------fsplit
# returns the answer part of a SICS reply of the form something = something
proc fsplit {text} {
    set l [split $text =]
    set t [lindex $l 1]
    return [string trim $t] 
}

#----------- locate
# This is an internal routine and tries to locate a section in the database
# file. The database file is plain ASCII. There are sections in the file
# separated by lines starting with ####. The #### is followed by the title
# name of the section. Then follow lines of section specific data in variable
# syntax. Another complication is that we need to be able to update the data
# in the file. In order to do that the whole file is first read into an array
# before the search is started. This is feasible as we have at max a hundred
# lines.  The array receives a member nl which is the number of lines read.
# The parameters are: 
#    ar the array of lines.
#    fd   a file descriptor as created by open
#    keyword  the keyword to search for
# The function returns the line number where the keyword was found on success,
# else -1 is returned. 
 
#proc dbfile {} {
#  return "dbfile = test.db"
#}

proc locate { data keyword} {
    upvar $data ar
#--------- read file
    set ret [catch {open [fsplit [dbfile]] r} fd]
    if {$ret == 1} {
       set ar(nl) 0 
       return -1
    }
#----- read whole file
    set i 0
    while {[gets $fd line] > 0 } {
	set ar($i) $line
        incr i
    }
    set ar(nl) $i
    close $fd
#----- start search
    for {set i 0} {$i < $ar(nl)} { incr i} {
#------ look for delimiter
        set delim [string range $ar($i) 0 3]
        if {[string compare $delim ####]  == 0} {
#----------- check keyword
	    if {[string first $keyword $ar($i) ] > 0} {
               return $i
            }             
        }
    }
    return -1;
}
#--------------- writerange
# writerange writes a range of lines from an array created by locate 
# to the file specicified by fd. Ranges are automaticcaly adjusted to 
# data limits

proc writerange { data fd start end } {
    upvar $data ar
#----- adjust ranges 
    if {$start < 0} {
       set start 0
    }
    if {$start > $ar(nl) } {
         set start $ar(nl)
    }
    if { $end > $ar(nl) } {
      set end $ar(nl)
    }
#---- write!
    for {set i $start} {$i < $end} {incr i} {
       puts $fd $ar($i)
    }
} 

#----------- writepos 
# writepos writes the current positions of stt, om, ch, ph motors as a A type
# line into the reflection section of the data base file. This is used after
# centering an unindexed reflection.

proc writepos { } {
#----- get positions
       set ret [catch {fsplit [stt]} mystt]
       if {$ret == 1} {
            error $myom
       }
       set ret [catch {fsplit [om]} myom]
       if {$ret == 1} {
            error $myom
       }
       set ret [catch {fsplit [ch]} mych]
       if {$ret == 1} {
            error $myom
       }
       set ret [catch {fsplit [ph]} myph]
       if {$ret == 1} {
            error $myom
       }
#----- find position in file
       set ret [catch {locate data reflections} ind]
#----- write
	set ret [catch {open [fsplit [dbfile]] w} fd]
        if { $ret == 1} {
            error $fd
        }
        if { $ind < 0 } {
           writerange data $fd 0 $data(nl)
           puts $fd "#### reflections"
           puts $fd [format "A %8.2f %8.2f %8.2f %8.2f" \
                    $mystt $myom $mych $myph] 
        } else {
           incr ind
           writerange data $fd 0 $ind
           puts $fd [format "A %8.2f %8.2f %8.2f %8.2f" \
                    $mystt $myom $mych $myph]
           writerange data $fd $ind $data(nl)
        }
        close $fd
        return OK
}  

#------------ writerefl
# writerefl writes a reflection with indexes. This makes an I record in
# the reflections list of the database file. This is meant to be used 
# after centering a reflection after the UB-matrix is known

proc writerefl { } {
#----- get positions
       set ret [catch {fsplit [stt]} mystt]
       if {$ret == 1} {
            error $myom
       }
       set ret [catch {fsplit [om]} myom]
       if {$ret == 1} {
            error $myom
       }
       set ret [catch {fsplit [ch]} mych]
       if {$ret == 1} {
            error $myom
       }
       set ret [catch {fsplit [ph]} myph]
       if {$ret == 1} {
            error $myom
       }
#------ get hkl
       set ret [catch {hkl current} txt]
       if {$ret == 1} {
            error $txt
       }
       set l [split $txt]
       set H [lindex $txt 2]
       set K [lindex $txt 3]
       set L [lindex $txt 4]
#----- find position in file
       set ret [catch {locate data reflections} ind]
#----- write
	set ret [catch {open [fsplit [dbfile]] w} fd]
        if { $ret == 1} {
            error $fd
        }
        if { $ind < 0 } {
           writerange data $fd 0 $data(nl)
           puts $fd "#### reflections"
           puts $fd [format "I %5.2f %5.2f %5.2f %8.2f %8.2f %8.2f %8.2f" \
                    $H $K $L $mystt $myom $mych $myph] 
        } else {
           incr ind
           writerange data $fd 0 $ind
           puts $fd [format "I %5.2f %5.2f %5.2f %8.2f %8.2f %8.2f %8.2f" \
                    $H $K $L $mystt $myom $mych $myph] 
           writerange data $fd $ind $data(nl)
        }
        close $fd
        return OK
}  
 
#----------- clearrefl
# clearrefl clears the list of reflections as stored in the database file

proc clearrefl {} {
#----- find position in file
       set ret [catch {locate data reflections} ind]
#----  nothing to do if no entry 
       if {$ind < 0} {
          return "Nothing to do"
       }
#----- write
	set ret [catch {open [fsplit [dbfile]] w} fd]
        if { $ret == 1} {
            error $fd
        }
        incr ind
        writerange data $fd 0 $ind
        for {set i $ind} {$i < $data(nl)} {incr i} {
            set delim [string range $data($i) 0 3]
            if {[string compare $delim ####] == 0} {
               break
            }           
        }
        set ind [expr $ind + $i - 1]
        writerange data $fd $ind $data(nl)
        close $fd
        return OK
}

#-------- listrefl
# listrefl lists all the entries in the reflection list

proc listrefl {} {
#----- find position in file
       set ret [catch {locate data reflections} ind]
#----  nothing to do if no entry 
       if {$ind < 0} {
          return "Nothing to do"
       }
#------ list
        incr ind
        for {set i $ind} {$i < $data(nl)} {incr i} {
            set delim [string range $data($i) 0 3]
            if {[string compare $delim ####] == 0} {
               break
            } else {
              ClientPut $data($i)
            }          
        }
        return OK
}

#---------- updateub
# updateub reads a UB matrix from the file and replaces the current SICS
# UB matrix with the one from the file. To be used after another program
# created a UB matrix in the first place or after refining the UB matrix
# following a centering operation.
# WARNING: this requires that the Tcl internal scan command has been r
# renamed BEFORE loading the scan command to stscan. Otherwise there is
# as conflict with the scan routine!

proc updateub {} {
#----- find position in file
        set ret [catch {locate data UB} ind]
        if { $ind < 0} {
         error "ERROR: No UB matrix in database"
        }
        incr ind
#------ read three lines of UB
        stscan $data($ind) "%f%f%f" ub11 ub12 ub13
        ClientPut $ub11 $ub12 $ub13
        incr ind 
        stscan $data($ind) "%f%f%f" ub21 ub22 ub23
        incr ind   
        stscan $data($ind) "%f%f%f" ub31 ub32 ub33
        hkl setub $ub11 $ub12 $ub13 $ub21 $ub22 $ub23 $ub31 $ub32 $ub33
        return OK
}

#--------- setlambda 
# setlambda sets the wavelength

proc setlambda {newval} {
       set ret [catch {hkl lambda $newval} msg]
       if {$ret == 1} {
         error $msg
       }
#----- find position in file
       set ret [catch {locate data lambda} ind]
#----- write
	set ret [catch {open [fsplit [dbfile]] w} fd]
        if { $ret == 1} {
            error $fd
        }
        if { $ind < 0 } {
           writerange data $fd 0 $data(nl)
           puts $fd "#### lambda"
           puts $fd [format "   %12.6f" $newval]
        } else {
           incr ind
           writerange data $fd 0 $ind
           puts $fd [format "   %12.6f" $newval]
           incr ind
           writerange data $fd $ind $data(nl)
        }
	 close $fd
	 return OK
 }

#------- fcentre
# fcentre centers a reflection
proc fcentre {} {
#----- rough centering
   opti clear
   opti countmode monitor
   opti preset 1000
   opti threshold 30
   opti addvar om .1 25 .10
   opti addvar stt .20 25 .25
   opti addvar ch 1.0  20 1.
   set ret [catch {opti run} msg]
   if {$ret == 1} {
      error $msg
   }
#----- fine centering
   opti preset 5000
   opti threshold 50
   set ret [catch {opti run} msg]
   if {$ret != 0 } {
     error $msg
   } 
   set txt [om]
   set l [split $txt =]
   set tom [lindex $l 1]
   set txt [stt]
   set l [split $txt =]
   set tstt [lindex $l 1]
   set txt [ch]
   set l [split $txt =]
   set tch [lindex $l 1]
   set txt [ph]
   set l [split $txt =]
   set tph [lindex $l 1]
   ClientPut "Two-Theta Omega     Chi        Phi"
   ClientPut [format "%-10.2f%-10.2f%-10.2f%-10.2f" $tstt $tom $tch $tph]
   storepos
}