Changeset 1209

Timestamp:

Aug 15, 2012 2:27:31 PM (8 years ago)

Author:

toby

Message:

start on Fourier calc and absorption constraints

Location:

branches/sandbox

Files:

• export_drawxtl.tcl (modified) (11 diffs)
• readexp.tcl (modified) (13 diffs)

branches/sandbox/export_drawxtl.tcl

@@ -5 +5 @@
 set label "export to DRAWXTL (.str) file"
 set action export_drawxtl
+set DXTLcolorlist "White Red Green Blue Yellow Cyan Magenta Black Orange Brown Grey Silver White"
 proc export_drawxtl {} {
     global expmap expgui
@@ -20 +21 @@
 #           "MakeWWWHelp expgui.html export"
 
-    # force the window to stay on top
-    putontop .export
     # trigger a quit on window delete
     wm protocol .export WM_DELETE_WINDOW {set expgui(export_phase) 0; destroy .export }
@@ -47 +46 @@
         -row $row -column 1 -columnspan 5 -sticky w
     incr row
-    set colorlist "White Red Green Blue Yellow Cyan Magenta Black Orange Brown Grey Silver White"
     set DXTL(arrowcolorbox) $bx.4a
     set DXTL(arrowcolorbox_row) $row
@@ -54 +52 @@
     grid [label $bx.4a.h -text "Arrow colors: "] -column 0 -row 1 -sticky w
     grid [label $bx.4a.bll -text "   generated by Black operator "] -column 0 -row 2
-    eval tk_optionMenu $bx.4a.bl DXTL(blackarrow) $colorlist
+    eval tk_optionMenu $bx.4a.bl DXTL(blackarrow) $::DXTLcolorlist
     grid $bx.4a.bl -column 2 -row 2
     grid [label $bx.4a.redl -text "  generated by Red operator "] -column 0 -row 3
-    eval tk_optionMenu $bx.4a.red DXTL(redarrow) $colorlist
+    eval tk_optionMenu $bx.4a.red DXTL(redarrow) $::DXTLcolorlist
     grid $bx.4a.red -column 2 -row 3
     incr row
@@ -131 +129 @@
     grid [scrollbar $bx.b.scroll \
               -command "$bx.b.canvas yview"] -sticky ns -row $row -column 1
-
-    trace variable expgui(export_phase) w SetDXTLatoms
+    # Fourier Box
+    incr row
+    grid [frame $bx.f -relief groove -bd 4] -row $row -column 0 -columnspan 5 -sticky nsew
+    grid [label $bx.f.0 -text "Fourier display" \
+              -anchor w] -row 0 -column 0 -sticky w
+    grid [frame $bx.f.1] -column 0 -row 1 -sticky news
+    grid [frame $bx.f.2] -column 0 -row 2 -sticky news
+    grid [canvas $bx.f.canvas -relief sunk -bd 2 \
+              -scrollregion {0 0 5000 500} -width 250 -height 70 \
+              -yscrollcommand "$bx.f.scroll set" ] \
+        -column 0 -row 3 -sticky nsew
+    grid columnconfig $bx.f 0 -weight 1
+    frame [set DXTL(fb) $bx.f.canvas.fr]
+    $bx.f.canvas create window 0 0 -anchor nw -window $DXTL(fb)
+    grid [scrollbar $bx.f.scroll \
+              -command "$bx.f.canvas yview"] -sticky ns -row 3 -column 1
+    grid [button $bx.f.1.1 -text "Setup\nFourier" \
+              -command EditFourier] -column 0 -row 0
+    grid [button [set DXTL(FourCompute) $bx.f.1.2] -text "Compute\nFourier" \
+              -command {DXTLwritegrd $expgui(export_phase)}] -column 1 -row 0
+    grid [label $bx.f.1.3 -text "Select\nMap"] -column 3 -row 0
+    set DXTL(fmenu) [tk_optionMenu $bx.f.1.4 DXTL(mtype) test]
+    grid $bx.f.1.4 -column 4 -row 0
+    grid [button [set DXTL(AddContour) $bx.f.1.5] -text "Add\nContour" \
+              -command AddContour] -column 5 -row 0
+    SetupFourierButtons
+return
+    # force the window to stay on top
+    putontop .export
+    trace variable expgui(export_phase) w "SetDXTLatoms;SetupFourierButtons"
     SetDXTLatoms
     # this appears to be needed by OSX
@@ -212 +238 @@
             DXTLwriteArrows $fp $phase
         }
+        DXTLwriteFourierCommands
         puts $fp "END"
         close $fp
@@ -246 +273 @@
 proc SetDXTLatoms {args} {
     global DXTL expgui expmap
-    set colorlist "White Red Green Blue Yellow Cyan Magenta Black Orange Brown Grey Silver White"
     eval destroy [winfo children $DXTL(lb)]
     eval destroy [winfo children $DXTL(Blst)]
@@ -290 +316 @@
         grid [entry $DXTL(lb).e$row -textvariable DXTL(radius_$type) \
                 -width 5] -column 2 -row $row
-        eval tk_optionMenu $DXTL(lb).c$row DXTL(color_$type) $colorlist
+        eval tk_optionMenu $DXTL(lb).c$row DXTL(color_$type) $::DXTLcolorlist
         grid $DXTL(lb).c$row -column 3 -row $row
         set DXTL(display_$type) sphere
         set DXTL(radius_$type) 0.2
-        set DXTL(color_$type) [lindex $colorlist $row]
+        set DXTL(color_$type) [lindex $::DXTLcolorlist $row]
     }
     # Resize the list
@@ -310 +336 @@
 proc DXTLaddBond {} {
     global DXTL
-    set colorlist "White Red Green Blue Yellow Cyan Magenta Black Orange Brown Grey Silver White"
-
     if {$DXTL(bonds) == 0} {
         # insert header
@@ -339 +363 @@
     grid [entry $DXTL(Blst).mx$row -textvariable DXTL(bmax_$row) \
               -width 5] -column 5 -row $row
-    eval tk_optionMenu $DXTL(Blst).c$row DXTL(bc_$row) $colorlist
+    eval tk_optionMenu $DXTL(Blst).c$row DXTL(bc_$row) $::DXTLcolorlist
     grid $DXTL(Blst).c$row -column 6 -row $row
     set DXTL(bw_$row) 0.02
     set DXTL(bmin_$row) 1.0
     set DXTL(bmax_$row) 2.0
-    set DXTL(bc_$row) [lindex $colorlist $row]
+    set DXTL(bc_$row) [lindex $::DXTLcolorlist $row]
     # Resize the list
     update
@@ -412 +436 @@
     puts $out "mag_trans 1. 0 0  0 1. 0  0 0 1."
 }
+
+# Computes a Fourier map(s) and converts the maps from binary to ascii
+#   returns a list of Fourier map types
+proc DXTLwritegrd {phase} {
+    global expgui expmap DXTL
+    set lst [listFourier]
+    if {$lst < 1} {
+        MyMessageBox -parent . -title "No Fourier" \
+            -message "You have not set up to compute a Fourier map." \
+            -icon warning
+        return
+    }
+    set typelist {}
+    foreach l $lst {
+        lappend typelist [Fourierinfo $l type]
+    }
+    set hists [FourierHists $phase]
+    # make sure we have default limits
+    getFourierLimits $phase
+    if {[llength $hists] < 1} {
+        MyMessageBox -parent . -title "No Fourier" \
+            -message "You have not set up to compute a Fourier map for phase $phase." \
+            -icon warning
+        return
+    }
+    if {$::tcl_platform(platform) == "windows"} {
+        set map [file join $expgui(gsasexe) gsas2map.exe]
+        set fourier [file join $expgui(gsasexe) fourier.exe]
+    } else {
+        set map [file join $expgui(gsasexe) gsas2map]
+        set fourier [file join $expgui(gsasexe) fourier]
+    }
+    if {![file exists $map]} {
+        MyMessageBox -parent . -title "No Map Converter prog" \
+            -message "Error Fourier map converter program ($map) not found." \
+            -icon warning
+        return
+    }
+    if {![file exists $fourier]} {
+        MyMessageBox -parent . -title "No Fourier prog" \
+            -message "Error Fourier program ($fourier) not found." \
+            -icon warning
+        return
+    }
+    set fp [open f.in w]
+    if {[llength $typelist] > 1} {
+        puts $fp [lindex $typelist 0]
+    }
+    puts $fp "E"
+    foreach t [lrange $typelist 1 end] {
+        puts $fp "F $t"
+        puts $fp "E"
+    }
+    puts $fp "q"
+    close $fp
+    # delete any old grd files
+    foreach f [glob -nocomplain "[file root $expgui(expfile)]*.grd"] {
+        catch {file delete -force $f}
+    }
+    set deleteerror 0
+    if {[llength [glob -nocomplain "[file root $expgui(expfile)]*.grd"]] >0} {
+        MyMessageBox -parent . -title "Old grd files?" \
+            -message "Warning: Could not delete old .grd files; it will probably not be possible to overwrite them either. Be aware that map results may be out of date." \
+            -icon warning
+        set deleteerror 1
+    }
+    catch {
+        exec $fourier [file root $expgui(expfile)] >& f.out
+        exec $map [file root $expgui(expfile)] < f.in >>& f.out
+    }
+    if {[llength [glob -nocomplain "[file root $expgui(expfile)]*.grd"]] == 0} {
+        set fp [open f.out r]
+        set lines {}
+        while {[gets $fp line] >= 0} {
+            append lines $line "\n"
+        }
+        close $fp
+        MyMessageBox -parent . -title "No grd files" \
+            -message "Error: no .grd files were created. See log file below\n\n$lines" \
+            -icon error
+        return {}
+    } else {
+        catch {close $fp}
+        catch {file delete -force f.in f.out}
+        return $typelist
+    }
+}
+
+proc SetupFourierButtons {} {
+    set phase $::expgui(export_phase)
+    $::DXTL(FourCompute) config -state disabled
+    $::DXTL(AddContour) config -state disabled
+    $::DXTL(fmenu) delete 0 end
+    set ::DXTL(mtype) ""
+    set ::DXTL(mfil) ""
+    # if the Fourier is not set up; return here
+    if {[listFourier] < 1} return
+    if {[llength [FourierHists $phase]] < 1} return
+    # make sure we have default limits
+    getFourierLimits $phase
+    $::DXTL(FourCompute) config -state normal
+    # if there are no maps, return here
+    set maps [glob -nocomplain "[file root $::expgui(expfile)]*.grd"]
+    if {[llength $maps] < 1} return
+    set types {}
+    foreach fil $maps {
+        lappend types [lindex [split [file root [file tail $fil]] "_"] end]
+    }
+    $::DXTL(AddContour) config -state normal
+    set i 0
+    foreach fil $maps lbl $types {
+        if {$i == 1} {$::DXTL(fmenu) invoke 0}
+        incr i
+        $::DXTL(fmenu) add command -label $lbl \
+            -command "set DXTL(mtype) $lbl; set DXTL(mfil) $fil"
+    }
+}
+
+proc EditFourier {} {
+    error
+}
+
+proc AddContour {} {
+    error
+}
+
+proc DXTLwriteFourierCommands {} {
+    error
+    #mapread grd 10CO_DELF.grd 4
+    #mapcontour  2.000 mesh Green
+    #mapcontour  2.500 solid Blue
+}

branches/sandbox/readexp.tcl

@@ -2349 +2349 @@
 #              phase-list, histogram-list, multiplier
 # Note that phase-list and/or histogram-list can be ALL
+#
+#  type action
+#  -----------
+#  absorbX get number         returns a list of constraints for term X=1 or 2
+#                             use number=0 to get # of defined
+#                             constraints for term X
+#   "        set number value   replaces a list of constraints 
+#                               (value is a list of constraints)
+#   "        add number value   inserts a new list of constraints 
+#                               (number is ignored)
+#   "        delete number      deletes a set of constraint entries
+# Each item in the list of constraints is composed of 3 items: 
+#              phase-list, histogram-list, multiplier
+# Note that phase-list and/or histogram-list can be ALL
+
 
 proc constrinfo {type action number "value {}"} {
@@ -2705 +2720 @@
             }
             set key "LEQV PF$term  $i"
+            # return nothing if no term exists
+            if {![existsexp $key]} {return 0}
+            # number of constraint lines
+            
+            set numline [string trim [string range [readexp ${key}] \
+                    [expr {($number%10)*5}] [expr {4+(($number%10)*5)}]] ]
+            if {$number == 0} {return $numline}
+            set clist {}
+            if {$number < 10} {
+                set number " $number"
+            }
+            for {set i 1} {$i <= $numline} {incr i} {
+                set key "LEQV PF${term}${number}$i"
+                set line [readexp ${key}]
+                foreach s {1 21 41} e {20 40 60} {
+                    set seg [string range $line $s $e]
+                    if {[string trim $seg] == ""} continue
+                    # parse the string segment
+                    set parse [regexp { *([0-9AL]+),([0-9AL]+) +([0-9.]+)} \
+                            $seg junk phase hist mult]
+                    # was parse successful
+                    if {!$parse} {continue}
+                    lappend clist [list $phase $hist $mult]
+                }
+            }
+            return $clist
+        }
+        absorb*-delete {
+            regsub absorb $type {} term
+            if {$term < 10} {
+                set term " $term"
+            }
+            set key "LEQV PF$term   "
+            # return nothing if no term exists
+            if {![existsexp $key]} {return 0}
+
+            # number of constraint terms
+            set nterms [string trim [string range [readexp ${key}] 0 4] ]
+            # don't delete a non-existing entry
+            if {$number > $nterms} {return 0}
+            set val [expr {$nterms - 1}]
+            validint val 5
+            setexp $key $val 1 5
+            for {set i1 $number} {$i1 < $nterms} {incr i1} {
+                set i2 [expr {1 + $i1}]
+                # move the contents of constraint #i2 -> i1
+                if {$i1 > 9} {
+                    set k1 [expr {($i1+1)/10}]
+                    set l1 $i1
+                } else {
+                    set k1 " "
+                    set l1 " $i1"
+                }
+                set key1 "LEQV PF$term  $k1"
+                # number of constraint lines for #i1
+                set n1 [string trim [string range [readexp ${key1}] \
+                        [expr {($i1%10)*5}] [expr {4+(($i1%10)*5)}]] ]
+                if {$i2 > 9} {
+                    set k2 [expr {($i2+1)/10}]
+                    set l2 $i2
+                } else {
+                    set k2 " "
+                    set l2 " $i2"
+                }
+                set key2 "LEQV PF$term  $k2"
+                # number of constraint lines for #i2
+                set n2 [string trim [string range [readexp ${key2}] \
+                        [expr {($i2%10)*5}] [expr {4+(($i2%10)*5)}]] ]
+                set val $n2
+                validint val 5
+                # move the # of terms
+                setexp $key1 $val [expr {1+(($i1%10)*5)}] 5
+                # move the terms
+                for {set j 1} {$j <= $n2} {incr j 1} {
+                    set key "LEQV PF${term}${l1}$j"
+                    makeexprec $key
+                    setexp $key [readexp "LEQV PF${term}${l2}$j"] 1 68
+                }
+                # delete any remaining lines
+                for {set j [expr {$n2+1}]} {$j <= $n1} {incr j 1} {
+                    delexp "LEQV PF${term}${l1}$j"
+                }
+            }
+
+            # clear the last term
+            if {$nterms > 9} {
+                set i [expr {($nterms+1)/10}]
+            } else {
+                set i " "
+            }
+            set key "LEQV PF$term  $i"
+            set cb [expr {($nterms%10)*5}]
+            set ce [expr {4+(($nterms%10)*5)}]
+            set n2 [string trim [string range [readexp ${key}] $cb $ce] ]
+            incr cb
+            setexp $key "     " $cb 5
+            # delete any remaining lines
+            for {set j 1} {$j <= $n2} {incr j 1} {
+                delexp "LEQV PF${term}${nterms}$j"
+            }
+        }
+        absorb*-set {
+            regsub absorb $type {} term
+            if {$term < 10} {
+                set term " $term"
+            }
+            set key "LEQV PF$term   "
+            # get number of constraint terms
+            set nterms [string trim [string range [readexp ${key}] 0 4] ]
+            # don't change a non-existing entry
+            if {$number > $nterms} {return 0}
+            if {$number > 9} {
+                set k1 [expr {($number+1)/10}]
+                set l1 $number
+            } else {
+                set k1 " "
+                set l1 " $number"
+            }
+            set key1 "LEQV PF$term  $k1"
+            # old number of constraint lines
+            set n1 [string trim [string range [readexp ${key1}] \
+                    [expr {($number%10)*5}] [expr {4+(($number%10)*5)}]] ]
+            # number of new constraints
+            set j2 [llength $value]
+            # number of new constraint lines
+            set val [set n2 [expr {($j2 + 2)/3}]]
+            # store the new # of lines
+            validint val 5
+            setexp $key1 $val [expr {1+(($number%10)*5)}] 5
+
+            # loop over the # of lines in the old or new, whichever is greater
+            set v0 0
+            for {set j 1} {$j <= [expr {($n1 > $n2) ? $n1 : $n2}]} {incr j 1} {
+                set key "LEQV PF${term}${l1}$j"
+                # were there more lines in the old?
+                if {$j > $n2} {
+                    # this line is not needed
+                    if {$j % 3 == 1} {
+                        delexp %key
+                    }
+                    continue
+                }
+                # are we adding new lines?
+                if {$j > $n1} {
+                    makeexprec $key
+                }
+                # add the three constraints to the line
+                foreach s {3 23 43} \
+                        item [lrange $value $v0 [expr {2+$v0}]] {
+                    if {$item != ""} {
+                        set val [format %-10s%9.3f \
+                                [lindex $item 0],[lindex $item 1] \
+                                [lindex $item 2]]
+                        setexp $key $val $s 19
+                    } else {
+                        setexp $key " " $s 19
+                    }
+                }
+                incr v0 3
+            }
+        }
+        absorb*-add {
+            regsub absorb $type {} term
+            if {$term < 10} {
+                set term " $term"
+            }
+            set key "LEQV PF$term   "
+            if {![existsexp $key]} {makeexprec $key}
+            set nterms [string trim [string range [readexp ${key}] 0 4] ]
+            if {$nterms == ""} {
+                set nterms 1
+            } elseif {$nterms >= 99} {
+                return 0
+            } else {
+                incr nterms
+            }
+            # store the new # of constraints
+            set val $nterms
+            validint val 5
+            setexp $key $val 1 5
+
+            if {$nterms > 9} {
+                set k1 [expr {($nterms+1)/10}]
+                set l1 $nterms
+            } else {
+                set k1 " "
+                set l1 " $nterms"
+            }
+            set key1 "LEQV PF$term  $k1"
+
+            # number of new constraints
+            set j2 [llength $value]
+            # number of new constraint lines
+            set val [set n2 [expr {($j2 + 2)/3}]]
+            # store the new # of lines
+            validint val 5
+            setexp $key1 $val [expr {1+(($nterms%10)*5)}] 5
+
+            # loop over the # of lines to be added
+            set v0 0
+            for {set j 1} {$j <= $n2} {incr j 1} {
+                set key "LEQV PF${term}${l1}$j"
+                makeexprec $key
+                # add the three constraints to the line
+                foreach s {3 23 43} \
+                        item [lrange $value $v0 [expr {2+$v0}]] {
+                    if {$item != ""} {
+                        set val [format %-10s%9.3f \
+                                [lindex $item 0],[lindex $item 1] \
+                                [lindex $item 2]]
+                        setexp $key $val $s 19
+                    } else {
+                        setexp $key " " $s 19
+                    }
+                }
+                incr v0 3
+            }
+        }
+        absorb*-get {
+            regsub absorb $type {} term
+            set key "LEQV ABS$term   "
+            if {$number == 0} {
+                puts [readexp ${key}]
+                puts [string range [readexp ${key}] 0 5]
+                puts [string trim [string range [readexp ${key}] 0 5]]
+            }
+            puts "**${term}**"
+            return
+            set key "LEQV ABS$term  $i"
             # return nothing if no term exists
             if {![existsexp $key]} {return 0}
@@ -4351 +4595 @@
 #      type: type of map (DELF,FCLC,FOBS,NFDF,PTSN,DPTS) - default DELF
 #      section: (X,Y or Z) - default Z
+#   returns the number of the map that is added
 proc addFourier {phase {type "DELF"} {section "Z"}} {
     set num {}
@@ -4391 +4636 @@
         type-get {
             # type of map (DELF,FCLC,FOBS,NFDF,PTSN,DPTS)
-            return [string range [readexp $key] 2 6]
+            return [string trim [string range [readexp $key] 2 6]]
         }
         type-set {
@@ -4423 +4668 @@
         phase-get {
             # phase (1-9)
-            return [string range [readexp $key] 8 13]
+            return [string trim [string range [readexp $key] 8 13]]
         }
         phase-set {
@@ -4431 +4676 @@
         dmin-get {
             # DMIN (usually 0.0)
-            return [string range [readexp $key] 18 25]
+            return [string trim [string range [readexp $key] 18 25]]
         }
         dmin-set {
@@ -4439 +4684 @@
         dmax-get {
             # DMAX (usually 999.99)
-            return [string range [readexp $key] 30 37]
+            return [string trim [string range [readexp $key] 30 37]]
         }
         dmax-set {
@@ -4490 +4735 @@
     set key "CRS$phase  FMPCTL"
     if {![existsexp $key]} {
-        makeexprec $key
+        setFourierLimits $phase
     }
     set i 0
@@ -4500 +4745 @@
         foreach v {x y z} {
             set val [string trim [string range $line $i [expr $i+5]]]
-            if {$val = ""} {set val 0}
+            if {$val == ""} {set val 0}
             set ${typ}_${v} $val
             incr i 5
@@ -4520 +4765 @@
 #   range_y contains {ymin ymax} : min and max y in fractional coordinates
 #   range_z contains {zmin zmax} : min and max z in fractional coordinates
-proc setFourierLimits {phase Asteps range_x range_y range_z} {
+proc setFourierLimits {phase \
+                           {Asteps {.2 .2 .2}} \
+                           {range_x {0 1}} \
+                           {range_y {0 1}} \
+                           {range_z {0 1}} } {
     set key "CRS$phase  FMPCTL"
     if {![existsexp $key]} {
@@ -4526 +4775 @@
     }
     set i 1
+    # steps across map
     foreach v {x y z} cell {a b c} As $Asteps {
         set s [expr {1 + int([phaseinfo $phase $cell] / $As)}]
@@ -4535 +4785 @@
         incr i 5
     }
+    # x,y,z min in steps
     foreach v {x y z} {
         foreach {min max} [set range_$v] {}
@@ -4541 +4792 @@
         setexp $key $s $i 5
         incr i 5
+    }
+    # x,y,z max in steps
+    foreach v {x y z} {
+        foreach {min max} [set range_$v] {}
         set s [expr {int($max * [set step_$v]+.5)}]
         validint s 5