Changeset 1209 for branches/sandbox


Ignore:
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:
2 edited

Legend:

Unmodified
Added
Removed
  • branches/sandbox/export_drawxtl.tcl

    r930 r1209  
    55set label "export to DRAWXTL (.str) file"
    66set action export_drawxtl
     7set DXTLcolorlist "White Red Green Blue Yellow Cyan Magenta Black Orange Brown Grey Silver White"
    78proc export_drawxtl {} {
    89    global expmap expgui
     
    2021#           "MakeWWWHelp expgui.html export"
    2122
    22     # force the window to stay on top
    23     putontop .export
    2423    # trigger a quit on window delete
    2524    wm protocol .export WM_DELETE_WINDOW {set expgui(export_phase) 0; destroy .export }
     
    4746        -row $row -column 1 -columnspan 5 -sticky w
    4847    incr row
    49     set colorlist "White Red Green Blue Yellow Cyan Magenta Black Orange Brown Grey Silver White"
    5048    set DXTL(arrowcolorbox) $bx.4a
    5149    set DXTL(arrowcolorbox_row) $row
     
    5452    grid [label $bx.4a.h -text "Arrow colors: "] -column 0 -row 1 -sticky w
    5553    grid [label $bx.4a.bll -text "   generated by Black operator "] -column 0 -row 2
    56     eval tk_optionMenu $bx.4a.bl DXTL(blackarrow) $colorlist
     54    eval tk_optionMenu $bx.4a.bl DXTL(blackarrow) $::DXTLcolorlist
    5755    grid $bx.4a.bl -column 2 -row 2
    5856    grid [label $bx.4a.redl -text "  generated by Red operator "] -column 0 -row 3
    59     eval tk_optionMenu $bx.4a.red DXTL(redarrow) $colorlist
     57    eval tk_optionMenu $bx.4a.red DXTL(redarrow) $::DXTLcolorlist
    6058    grid $bx.4a.red -column 2 -row 3
    6159    incr row
     
    131129    grid [scrollbar $bx.b.scroll \
    132130              -command "$bx.b.canvas yview"] -sticky ns -row $row -column 1
    133 
    134     trace variable expgui(export_phase) w SetDXTLatoms
     131    # Fourier Box
     132    incr row
     133    grid [frame $bx.f -relief groove -bd 4] -row $row -column 0 -columnspan 5 -sticky nsew
     134    grid [label $bx.f.0 -text "Fourier display" \
     135              -anchor w] -row 0 -column 0 -sticky w
     136    grid [frame $bx.f.1] -column 0 -row 1 -sticky news
     137    grid [frame $bx.f.2] -column 0 -row 2 -sticky news
     138    grid [canvas $bx.f.canvas -relief sunk -bd 2 \
     139              -scrollregion {0 0 5000 500} -width 250 -height 70 \
     140              -yscrollcommand "$bx.f.scroll set" ] \
     141        -column 0 -row 3 -sticky nsew
     142    grid columnconfig $bx.f 0 -weight 1
     143    frame [set DXTL(fb) $bx.f.canvas.fr]
     144    $bx.f.canvas create window 0 0 -anchor nw -window $DXTL(fb)
     145    grid [scrollbar $bx.f.scroll \
     146              -command "$bx.f.canvas yview"] -sticky ns -row 3 -column 1
     147    grid [button $bx.f.1.1 -text "Setup\nFourier" \
     148              -command EditFourier] -column 0 -row 0
     149    grid [button [set DXTL(FourCompute) $bx.f.1.2] -text "Compute\nFourier" \
     150              -command {DXTLwritegrd $expgui(export_phase)}] -column 1 -row 0
     151    grid [label $bx.f.1.3 -text "Select\nMap"] -column 3 -row 0
     152    set DXTL(fmenu) [tk_optionMenu $bx.f.1.4 DXTL(mtype) test]
     153    grid $bx.f.1.4 -column 4 -row 0
     154    grid [button [set DXTL(AddContour) $bx.f.1.5] -text "Add\nContour" \
     155              -command AddContour] -column 5 -row 0
     156    SetupFourierButtons
     157return
     158    # force the window to stay on top
     159    putontop .export
     160    trace variable expgui(export_phase) w "SetDXTLatoms;SetupFourierButtons"
    135161    SetDXTLatoms
    136162    # this appears to be needed by OSX
     
    212238            DXTLwriteArrows $fp $phase
    213239        }
     240        DXTLwriteFourierCommands
    214241        puts $fp "END"
    215242        close $fp
     
    246273proc SetDXTLatoms {args} {
    247274    global DXTL expgui expmap
    248     set colorlist "White Red Green Blue Yellow Cyan Magenta Black Orange Brown Grey Silver White"
    249275    eval destroy [winfo children $DXTL(lb)]
    250276    eval destroy [winfo children $DXTL(Blst)]
     
    290316        grid [entry $DXTL(lb).e$row -textvariable DXTL(radius_$type) \
    291317                -width 5] -column 2 -row $row
    292         eval tk_optionMenu $DXTL(lb).c$row DXTL(color_$type) $colorlist
     318        eval tk_optionMenu $DXTL(lb).c$row DXTL(color_$type) $::DXTLcolorlist
    293319        grid $DXTL(lb).c$row -column 3 -row $row
    294320        set DXTL(display_$type) sphere
    295321        set DXTL(radius_$type) 0.2
    296         set DXTL(color_$type) [lindex $colorlist $row]
     322        set DXTL(color_$type) [lindex $::DXTLcolorlist $row]
    297323    }
    298324    # Resize the list
     
    310336proc DXTLaddBond {} {
    311337    global DXTL
    312     set colorlist "White Red Green Blue Yellow Cyan Magenta Black Orange Brown Grey Silver White"
    313 
    314338    if {$DXTL(bonds) == 0} {
    315339        # insert header
     
    339363    grid [entry $DXTL(Blst).mx$row -textvariable DXTL(bmax_$row) \
    340364              -width 5] -column 5 -row $row
    341     eval tk_optionMenu $DXTL(Blst).c$row DXTL(bc_$row) $colorlist
     365    eval tk_optionMenu $DXTL(Blst).c$row DXTL(bc_$row) $::DXTLcolorlist
    342366    grid $DXTL(Blst).c$row -column 6 -row $row
    343367    set DXTL(bw_$row) 0.02
    344368    set DXTL(bmin_$row) 1.0
    345369    set DXTL(bmax_$row) 2.0
    346     set DXTL(bc_$row) [lindex $colorlist $row]
     370    set DXTL(bc_$row) [lindex $::DXTLcolorlist $row]
    347371    # Resize the list
    348372    update
     
    412436    puts $out "mag_trans 1. 0 0  0 1. 0  0 0 1."
    413437}
     438
     439# Computes a Fourier map(s) and converts the maps from binary to ascii
     440#   returns a list of Fourier map types
     441proc DXTLwritegrd {phase} {
     442    global expgui expmap DXTL
     443    set lst [listFourier]
     444    if {$lst < 1} {
     445        MyMessageBox -parent . -title "No Fourier" \
     446            -message "You have not set up to compute a Fourier map." \
     447            -icon warning
     448        return
     449    }
     450    set typelist {}
     451    foreach l $lst {
     452        lappend typelist [Fourierinfo $l type]
     453    }
     454    set hists [FourierHists $phase]
     455    # make sure we have default limits
     456    getFourierLimits $phase
     457    if {[llength $hists] < 1} {
     458        MyMessageBox -parent . -title "No Fourier" \
     459            -message "You have not set up to compute a Fourier map for phase $phase." \
     460            -icon warning
     461        return
     462    }
     463    if {$::tcl_platform(platform) == "windows"} {
     464        set map [file join $expgui(gsasexe) gsas2map.exe]
     465        set fourier [file join $expgui(gsasexe) fourier.exe]
     466    } else {
     467        set map [file join $expgui(gsasexe) gsas2map]
     468        set fourier [file join $expgui(gsasexe) fourier]
     469    }
     470    if {![file exists $map]} {
     471        MyMessageBox -parent . -title "No Map Converter prog" \
     472            -message "Error Fourier map converter program ($map) not found." \
     473            -icon warning
     474        return
     475    }
     476    if {![file exists $fourier]} {
     477        MyMessageBox -parent . -title "No Fourier prog" \
     478            -message "Error Fourier program ($fourier) not found." \
     479            -icon warning
     480        return
     481    }
     482    set fp [open f.in w]
     483    if {[llength $typelist] > 1} {
     484        puts $fp [lindex $typelist 0]
     485    }
     486    puts $fp "E"
     487    foreach t [lrange $typelist 1 end] {
     488        puts $fp "F $t"
     489        puts $fp "E"
     490    }
     491    puts $fp "q"
     492    close $fp
     493    # delete any old grd files
     494    foreach f [glob -nocomplain "[file root $expgui(expfile)]*.grd"] {
     495        catch {file delete -force $f}
     496    }
     497    set deleteerror 0
     498    if {[llength [glob -nocomplain "[file root $expgui(expfile)]*.grd"]] >0} {
     499        MyMessageBox -parent . -title "Old grd files?" \
     500            -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." \
     501            -icon warning
     502        set deleteerror 1
     503    }
     504    catch {
     505        exec $fourier [file root $expgui(expfile)] >& f.out
     506        exec $map [file root $expgui(expfile)] < f.in >>& f.out
     507    }
     508    if {[llength [glob -nocomplain "[file root $expgui(expfile)]*.grd"]] == 0} {
     509        set fp [open f.out r]
     510        set lines {}
     511        while {[gets $fp line] >= 0} {
     512            append lines $line "\n"
     513        }
     514        close $fp
     515        MyMessageBox -parent . -title "No grd files" \
     516            -message "Error: no .grd files were created. See log file below\n\n$lines" \
     517            -icon error
     518        return {}
     519    } else {
     520        catch {close $fp}
     521        catch {file delete -force f.in f.out}
     522        return $typelist
     523    }
     524}
     525
     526proc SetupFourierButtons {} {
     527    set phase $::expgui(export_phase)
     528    $::DXTL(FourCompute) config -state disabled
     529    $::DXTL(AddContour) config -state disabled
     530    $::DXTL(fmenu) delete 0 end
     531    set ::DXTL(mtype) ""
     532    set ::DXTL(mfil) ""
     533    # if the Fourier is not set up; return here
     534    if {[listFourier] < 1} return
     535    if {[llength [FourierHists $phase]] < 1} return
     536    # make sure we have default limits
     537    getFourierLimits $phase
     538    $::DXTL(FourCompute) config -state normal
     539    # if there are no maps, return here
     540    set maps [glob -nocomplain "[file root $::expgui(expfile)]*.grd"]
     541    if {[llength $maps] < 1} return
     542    set types {}
     543    foreach fil $maps {
     544        lappend types [lindex [split [file root [file tail $fil]] "_"] end]
     545    }
     546    $::DXTL(AddContour) config -state normal
     547    set i 0
     548    foreach fil $maps lbl $types {
     549        if {$i == 1} {$::DXTL(fmenu) invoke 0}
     550        incr i
     551        $::DXTL(fmenu) add command -label $lbl \
     552            -command "set DXTL(mtype) $lbl; set DXTL(mfil) $fil"
     553    }
     554}
     555
     556proc EditFourier {} {
     557    error
     558}
     559
     560proc AddContour {} {
     561    error
     562}
     563
     564proc DXTLwriteFourierCommands {} {
     565    error
     566    #mapread grd 10CO_DELF.grd 4
     567    #mapcontour  2.000 mesh Green
     568    #mapcontour  2.500 solid Blue
     569}
  • branches/sandbox/readexp.tcl

    r1208 r1209  
    23492349#              phase-list, histogram-list, multiplier
    23502350# Note that phase-list and/or histogram-list can be ALL
     2351#
     2352#  type action
     2353#  -----------
     2354#  absorbX get number         returns a list of constraints for term X=1 or 2
     2355#                             use number=0 to get # of defined
     2356#                             constraints for term X
     2357#   "        set number value   replaces a list of constraints
     2358#                               (value is a list of constraints)
     2359#   "        add number value   inserts a new list of constraints
     2360#                               (number is ignored)
     2361#   "        delete number      deletes a set of constraint entries
     2362# Each item in the list of constraints is composed of 3 items:
     2363#              phase-list, histogram-list, multiplier
     2364# Note that phase-list and/or histogram-list can be ALL
     2365
    23512366
    23522367proc constrinfo {type action number "value {}"} {
     
    27052720            }
    27062721            set key "LEQV PF$term  $i"
     2722            # return nothing if no term exists
     2723            if {![existsexp $key]} {return 0}
     2724            # number of constraint lines
     2725           
     2726            set numline [string trim [string range [readexp ${key}] \
     2727                    [expr {($number%10)*5}] [expr {4+(($number%10)*5)}]] ]
     2728            if {$number == 0} {return $numline}
     2729            set clist {}
     2730            if {$number < 10} {
     2731                set number " $number"
     2732            }
     2733            for {set i 1} {$i <= $numline} {incr i} {
     2734                set key "LEQV PF${term}${number}$i"
     2735                set line [readexp ${key}]
     2736                foreach s {1 21 41} e {20 40 60} {
     2737                    set seg [string range $line $s $e]
     2738                    if {[string trim $seg] == ""} continue
     2739                    # parse the string segment
     2740                    set parse [regexp { *([0-9AL]+),([0-9AL]+) +([0-9.]+)} \
     2741                            $seg junk phase hist mult]
     2742                    # was parse successful
     2743                    if {!$parse} {continue}
     2744                    lappend clist [list $phase $hist $mult]
     2745                }
     2746            }
     2747            return $clist
     2748        }
     2749        absorb*-delete {
     2750            regsub absorb $type {} term
     2751            if {$term < 10} {
     2752                set term " $term"
     2753            }
     2754            set key "LEQV PF$term   "
     2755            # return nothing if no term exists
     2756            if {![existsexp $key]} {return 0}
     2757
     2758            # number of constraint terms
     2759            set nterms [string trim [string range [readexp ${key}] 0 4] ]
     2760            # don't delete a non-existing entry
     2761            if {$number > $nterms} {return 0}
     2762            set val [expr {$nterms - 1}]
     2763            validint val 5
     2764            setexp $key $val 1 5
     2765            for {set i1 $number} {$i1 < $nterms} {incr i1} {
     2766                set i2 [expr {1 + $i1}]
     2767                # move the contents of constraint #i2 -> i1
     2768                if {$i1 > 9} {
     2769                    set k1 [expr {($i1+1)/10}]
     2770                    set l1 $i1
     2771                } else {
     2772                    set k1 " "
     2773                    set l1 " $i1"
     2774                }
     2775                set key1 "LEQV PF$term  $k1"
     2776                # number of constraint lines for #i1
     2777                set n1 [string trim [string range [readexp ${key1}] \
     2778                        [expr {($i1%10)*5}] [expr {4+(($i1%10)*5)}]] ]
     2779                if {$i2 > 9} {
     2780                    set k2 [expr {($i2+1)/10}]
     2781                    set l2 $i2
     2782                } else {
     2783                    set k2 " "
     2784                    set l2 " $i2"
     2785                }
     2786                set key2 "LEQV PF$term  $k2"
     2787                # number of constraint lines for #i2
     2788                set n2 [string trim [string range [readexp ${key2}] \
     2789                        [expr {($i2%10)*5}] [expr {4+(($i2%10)*5)}]] ]
     2790                set val $n2
     2791                validint val 5
     2792                # move the # of terms
     2793                setexp $key1 $val [expr {1+(($i1%10)*5)}] 5
     2794                # move the terms
     2795                for {set j 1} {$j <= $n2} {incr j 1} {
     2796                    set key "LEQV PF${term}${l1}$j"
     2797                    makeexprec $key
     2798                    setexp $key [readexp "LEQV PF${term}${l2}$j"] 1 68
     2799                }
     2800                # delete any remaining lines
     2801                for {set j [expr {$n2+1}]} {$j <= $n1} {incr j 1} {
     2802                    delexp "LEQV PF${term}${l1}$j"
     2803                }
     2804            }
     2805
     2806            # clear the last term
     2807            if {$nterms > 9} {
     2808                set i [expr {($nterms+1)/10}]
     2809            } else {
     2810                set i " "
     2811            }
     2812            set key "LEQV PF$term  $i"
     2813            set cb [expr {($nterms%10)*5}]
     2814            set ce [expr {4+(($nterms%10)*5)}]
     2815            set n2 [string trim [string range [readexp ${key}] $cb $ce] ]
     2816            incr cb
     2817            setexp $key "     " $cb 5
     2818            # delete any remaining lines
     2819            for {set j 1} {$j <= $n2} {incr j 1} {
     2820                delexp "LEQV PF${term}${nterms}$j"
     2821            }
     2822        }
     2823        absorb*-set {
     2824            regsub absorb $type {} term
     2825            if {$term < 10} {
     2826                set term " $term"
     2827            }
     2828            set key "LEQV PF$term   "
     2829            # get number of constraint terms
     2830            set nterms [string trim [string range [readexp ${key}] 0 4] ]
     2831            # don't change a non-existing entry
     2832            if {$number > $nterms} {return 0}
     2833            if {$number > 9} {
     2834                set k1 [expr {($number+1)/10}]
     2835                set l1 $number
     2836            } else {
     2837                set k1 " "
     2838                set l1 " $number"
     2839            }
     2840            set key1 "LEQV PF$term  $k1"
     2841            # old number of constraint lines
     2842            set n1 [string trim [string range [readexp ${key1}] \
     2843                    [expr {($number%10)*5}] [expr {4+(($number%10)*5)}]] ]
     2844            # number of new constraints
     2845            set j2 [llength $value]
     2846            # number of new constraint lines
     2847            set val [set n2 [expr {($j2 + 2)/3}]]
     2848            # store the new # of lines
     2849            validint val 5
     2850            setexp $key1 $val [expr {1+(($number%10)*5)}] 5
     2851
     2852            # loop over the # of lines in the old or new, whichever is greater
     2853            set v0 0
     2854            for {set j 1} {$j <= [expr {($n1 > $n2) ? $n1 : $n2}]} {incr j 1} {
     2855                set key "LEQV PF${term}${l1}$j"
     2856                # were there more lines in the old?
     2857                if {$j > $n2} {
     2858                    # this line is not needed
     2859                    if {$j % 3 == 1} {
     2860                        delexp %key
     2861                    }
     2862                    continue
     2863                }
     2864                # are we adding new lines?
     2865                if {$j > $n1} {
     2866                    makeexprec $key
     2867                }
     2868                # add the three constraints to the line
     2869                foreach s {3 23 43} \
     2870                        item [lrange $value $v0 [expr {2+$v0}]] {
     2871                    if {$item != ""} {
     2872                        set val [format %-10s%9.3f \
     2873                                [lindex $item 0],[lindex $item 1] \
     2874                                [lindex $item 2]]
     2875                        setexp $key $val $s 19
     2876                    } else {
     2877                        setexp $key " " $s 19
     2878                    }
     2879                }
     2880                incr v0 3
     2881            }
     2882        }
     2883        absorb*-add {
     2884            regsub absorb $type {} term
     2885            if {$term < 10} {
     2886                set term " $term"
     2887            }
     2888            set key "LEQV PF$term   "
     2889            if {![existsexp $key]} {makeexprec $key}
     2890            set nterms [string trim [string range [readexp ${key}] 0 4] ]
     2891            if {$nterms == ""} {
     2892                set nterms 1
     2893            } elseif {$nterms >= 99} {
     2894                return 0
     2895            } else {
     2896                incr nterms
     2897            }
     2898            # store the new # of constraints
     2899            set val $nterms
     2900            validint val 5
     2901            setexp $key $val 1 5
     2902
     2903            if {$nterms > 9} {
     2904                set k1 [expr {($nterms+1)/10}]
     2905                set l1 $nterms
     2906            } else {
     2907                set k1 " "
     2908                set l1 " $nterms"
     2909            }
     2910            set key1 "LEQV PF$term  $k1"
     2911
     2912            # number of new constraints
     2913            set j2 [llength $value]
     2914            # number of new constraint lines
     2915            set val [set n2 [expr {($j2 + 2)/3}]]
     2916            # store the new # of lines
     2917            validint val 5
     2918            setexp $key1 $val [expr {1+(($nterms%10)*5)}] 5
     2919
     2920            # loop over the # of lines to be added
     2921            set v0 0
     2922            for {set j 1} {$j <= $n2} {incr j 1} {
     2923                set key "LEQV PF${term}${l1}$j"
     2924                makeexprec $key
     2925                # add the three constraints to the line
     2926                foreach s {3 23 43} \
     2927                        item [lrange $value $v0 [expr {2+$v0}]] {
     2928                    if {$item != ""} {
     2929                        set val [format %-10s%9.3f \
     2930                                [lindex $item 0],[lindex $item 1] \
     2931                                [lindex $item 2]]
     2932                        setexp $key $val $s 19
     2933                    } else {
     2934                        setexp $key " " $s 19
     2935                    }
     2936                }
     2937                incr v0 3
     2938            }
     2939        }
     2940        absorb*-get {
     2941            regsub absorb $type {} term
     2942            set key "LEQV ABS$term   "
     2943            if {$number == 0} {
     2944                puts [readexp ${key}]
     2945                puts [string range [readexp ${key}] 0 5]
     2946                puts [string trim [string range [readexp ${key}] 0 5]]
     2947            }
     2948            puts "**${term}**"
     2949            return
     2950            set key "LEQV ABS$term  $i"
    27072951            # return nothing if no term exists
    27082952            if {![existsexp $key]} {return 0}
     
    43514595#      type: type of map (DELF,FCLC,FOBS,NFDF,PTSN,DPTS) - default DELF
    43524596#      section: (X,Y or Z) - default Z
     4597#   returns the number of the map that is added
    43534598proc addFourier {phase {type "DELF"} {section "Z"}} {
    43544599    set num {}
     
    43914636        type-get {
    43924637            # type of map (DELF,FCLC,FOBS,NFDF,PTSN,DPTS)
    4393             return [string range [readexp $key] 2 6]
     4638            return [string trim [string range [readexp $key] 2 6]]
    43944639        }
    43954640        type-set {
     
    44234668        phase-get {
    44244669            # phase (1-9)
    4425             return [string range [readexp $key] 8 13]
     4670            return [string trim [string range [readexp $key] 8 13]]
    44264671        }
    44274672        phase-set {
     
    44314676        dmin-get {
    44324677            # DMIN (usually 0.0)
    4433             return [string range [readexp $key] 18 25]
     4678            return [string trim [string range [readexp $key] 18 25]]
    44344679        }
    44354680        dmin-set {
     
    44394684        dmax-get {
    44404685            # DMAX (usually 999.99)
    4441             return [string range [readexp $key] 30 37]
     4686            return [string trim [string range [readexp $key] 30 37]]
    44424687        }
    44434688        dmax-set {
     
    44904735    set key "CRS$phase  FMPCTL"
    44914736    if {![existsexp $key]} {
    4492         makeexprec $key
     4737        setFourierLimits $phase
    44934738    }
    44944739    set i 0
     
    45004745        foreach v {x y z} {
    45014746            set val [string trim [string range $line $i [expr $i+5]]]
    4502             if {$val = ""} {set val 0}
     4747            if {$val == ""} {set val 0}
    45034748            set ${typ}_${v} $val
    45044749            incr i 5
     
    45204765#   range_y contains {ymin ymax} : min and max y in fractional coordinates
    45214766#   range_z contains {zmin zmax} : min and max z in fractional coordinates
    4522 proc setFourierLimits {phase Asteps range_x range_y range_z} {
     4767proc setFourierLimits {phase \
     4768                           {Asteps {.2 .2 .2}} \
     4769                           {range_x {0 1}} \
     4770                           {range_y {0 1}} \
     4771                           {range_z {0 1}} } {
    45234772    set key "CRS$phase  FMPCTL"
    45244773    if {![existsexp $key]} {
     
    45264775    }
    45274776    set i 1
     4777    # steps across map
    45284778    foreach v {x y z} cell {a b c} As $Asteps {
    45294779        set s [expr {1 + int([phaseinfo $phase $cell] / $As)}]
     
    45354785        incr i 5
    45364786    }
     4787    # x,y,z min in steps
    45374788    foreach v {x y z} {
    45384789        foreach {min max} [set range_$v] {}
     
    45414792        setexp $key $s $i 5
    45424793        incr i 5
     4794    }
     4795    # x,y,z max in steps
     4796    foreach v {x y z} {
     4797        foreach {min max} [set range_$v] {}
    45434798        set s [expr {int($max * [set step_$v]+.5)}]
    45444799        validint s 5
Note: See TracChangeset for help on using the changeset viewer.