Ignore:
Timestamp:
Nov 8, 2012 1:42:25 PM (8 years ago)
Author:
toby
Message:

update to latest, with Fourier & f'/f

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/export_drawxtl.tcl

    r930 r1225  
    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"
     8set ::DXTL(bonds) 0
     9set ::DXTL(coords) 1
     10set ::DXTL(blackarrow) Green
     11set ::DXTL(redarrow) Red
     12foreach a {X Y Z} {
     13    set ::DXTL(${a}dispMin) 0.0
     14    set ::DXTL(${a}dispMax) 1.0
     15}
     16set ::DXTL(mtype) ""
     17set ::DXTL(mfil) ""
     18set ::DXTL(FourierRange) ""
     19
    720proc export_drawxtl {} {
    821    global expmap expgui
     
    1427        return
    1528    }
    16     foreach t [trace vinfo expgui(export_phase)] {
    17         eval trace vdelete expgui(export_phase) $t
    18     }
    19      MakeExportBox .export "Export coordinates to program DRAWXTL" ""
     29    foreach t [trace vinfo ::expgui(export_phase)] {
     30        eval trace vdelete ::expgui(export_phase) $t
     31    }
     32    MakeExportBox .export "Export coordinates to program DRAWXTL" ""
    2033#           "MakeWWWHelp expgui.html export"
    2134
    22     # force the window to stay on top
    23     putontop .export
    2435    # trigger a quit on window delete
    2536    wm protocol .export WM_DELETE_WINDOW {set expgui(export_phase) 0; destroy .export }
    2637    set bx .export.special
    27     global DXTL
    28     if {[info global DXTL] == ""} {
    29         set DXTL(bonds) 0
    30         set DXTL(coords) 1
    31         set DXTL(blackarrow) Green
    32         set DXTL(redarrow) Red
    33     }
    3438    set row 1
    3539    grid [label $bx.1 -text "Title:"] -column 1 -row $row -sticky e
    36     grid [entry $bx.2 -textvariable DXTL(title) -width 40] \
     40    grid [entry $bx.2 -textvariable ::DXTL(title) -width 40] \
    3741        -row $row -column 2 -columnspan 5 -sticky w
    38     set DXTL(title) [expinfo title]
     42    set ::DXTL(title) [expinfo title]
    3943    incr row
    4044    grid [checkbutton $bx.3 -text "Include coordinates in .str file" \
    41               -variable DXTL(coords)] \
     45              -variable ::DXTL(coords)] \
    4246        -row $row -column 1 -columnspan 5 -sticky w
    4347    incr row
    44     set DXTL(arrowbox) $bx.4
     48    set ::DXTL(arrowbox) $bx.4
    4549    grid [checkbutton $bx.4 -text "Display arrows for magnetic atoms" \
    46               -variable DXTL(genarrows) -state disabled] \
     50              -variable ::DXTL(genarrows) -state disabled] \
    4751        -row $row -column 1 -columnspan 5 -sticky w
    4852    incr row
    49     set colorlist "White Red Green Blue Yellow Cyan Magenta Black Orange Brown Grey Silver White"
    50     set DXTL(arrowcolorbox) $bx.4a
    51     set DXTL(arrowcolorbox_row) $row
    52     grid [frame $bx.4a] -sticky ew -row $DXTL(arrowcolorbox_row) \
     53    set ::DXTL(arrowcolorbox) $bx.4a
     54    set ::DXTL(arrowcolorbox_row) $row
     55    grid [frame $bx.4a] -sticky ew -row $::DXTL(arrowcolorbox_row) \
    5356        -column 1 -columnspan 5
    5457    grid [label $bx.4a.h -text "Arrow colors: "] -column 0 -row 1 -sticky w
    5558    grid [label $bx.4a.bll -text "   generated by Black operator "] -column 0 -row 2
    56     eval tk_optionMenu $bx.4a.bl DXTL(blackarrow) $colorlist
     59    eval tk_optionMenu $bx.4a.bl ::DXTL(blackarrow) $::DXTLcolorlist
    5760    grid $bx.4a.bl -column 2 -row 2
    5861    grid [label $bx.4a.redl -text "  generated by Red operator "] -column 0 -row 3
    59     eval tk_optionMenu $bx.4a.red DXTL(redarrow) $colorlist
     62    eval tk_optionMenu $bx.4a.red ::DXTL(redarrow) $::DXTLcolorlist
    6063    grid $bx.4a.red -column 2 -row 3
    6164    incr row
     
    7477    if {$app != ""} {
    7578        set show normal
    76         set DXTL(app) $appname
    77         set DXTL(launch) 1
     79        set ::DXTL(app) $appname
     80        set ::DXTL(launch) 1
    7881    } else {
    7982        set show disabled
    80         set DXTL(launch) 0
     83        set ::DXTL(launch) 0
    8184    }
    8285    grid [checkbutton $bx.l -text "Launch DRAWxtl" \
    83               -variable DXTL(launch) -state $show] \
     86              -variable ::DXTL(launch) -state $show] \
    8487        -row $row -column 1 -columnspan 5 -sticky w
    8588    incr row
     
    9093        incr row
    9194        grid [label $bx.c.${v}1 -text "${V} min:"] -column 1 -row $row
    92         grid [entry $bx.c.${v}2 -textvariable DXTL(${v}min) -width 4] -column 2 -row $row
    93         grid [scale $bx.c.${v}3 -resolution 0.1 -variable DXTL(${v}min) \
     95        grid [entry $bx.c.${v}2 -textvariable ::DXTL(${v}min) -width 4] -column 2 -row $row
     96        grid [scale $bx.c.${v}3 -resolution 0.1 -variable ::DXTL(${v}min) \
    9497                  -showvalue 0 -orient h -from -2 -to 1] -column 3 -row $row
    95         set DXTL(${v}min) -0.1
     98        set ::DXTL(${v}min) -0.1
    9699        grid [label $bx.c.${v}4 -text " max:"] -column 4 -row $row
    97         grid [entry $bx.c.${v}5 -textvariable DXTL(${v}max) -width 4] -column 5 -row $row
    98         grid [scale $bx.c.${v}6 -resolution 0.1 -variable DXTL(${v}max) \
     100        grid [entry $bx.c.${v}5 -textvariable ::DXTL(${v}max) -width 4] -column 5 -row $row
     101        grid [scale $bx.c.${v}6 -resolution 0.1 -variable ::DXTL(${v}max) \
    99102                  -showvalue 0 -orient h -from 0 -to 3] -column 6 -row $row
    100         set DXTL(${v}max) 1.1
     103        set ::DXTL(${v}max) 1.1
    101104    }
    102105    # atom type box
    103106    grid [frame $bx.s -relief groove -bd 4] -row $row -column 0 -columnspan 5 -sticky nsew
     107    grid rowconfigure $bx $row -weight 1
    104108    grid [label $bx.s.0 -text "Atom representation" \
    105109              -anchor w] -row 0 -column 0 -sticky w
     
    108112              -yscrollcommand "$bx.s.scroll set" ] \
    109113        -column 0 -row [incr row] -sticky nsew
     114    grid rowconfigure $bx.s $row -weight 1
    110115    grid columnconfig $bx.s 0 -weight 1
    111     frame [set DXTL(lb) $bx.s.canvas.fr]
    112     $bx.s.canvas create window 0 0 -anchor nw -window $DXTL(lb)
     116    frame [set ::DXTL(lb) $bx.s.canvas.fr]
     117    $bx.s.canvas create window 0 0 -anchor nw -window $::DXTL(lb)
    113118    grid [scrollbar $bx.s.scroll \
    114119              -command "$bx.s.canvas yview"] -sticky ns -row $row -column 1
     
    116121    incr row
    117122    grid [frame $bx.b -relief groove -bd 4] -row $row -column 0 -columnspan 5 -sticky ew
     123    grid rowconfigure $bx $row -weight 1
    118124    grid [frame $bx.b.0] -row 0 -column 0 -columnspan 7 -sticky ew
    119125    grid [label $bx.b.0.1 -text "Bond List" \
     
    126132              -yscrollcommand "$bx.b.scroll set" ] \
    127133        -column 0 -row [incr row] -sticky nsew
     134    grid rowconfigure $bx.b $row -weight 1
    128135    grid columnconfig $bx.b 0 -weight 1
    129     frame [set DXTL(Blst) $bx.b.canvas.fr]
    130     $bx.b.canvas create window 0 0 -anchor nw -window $DXTL(Blst)
     136    frame [set ::DXTL(Blst) $bx.b.canvas.fr]
     137    $bx.b.canvas create window 0 0 -anchor nw -window $::DXTL(Blst)
    131138    grid [scrollbar $bx.b.scroll \
    132139              -command "$bx.b.canvas yview"] -sticky ns -row $row -column 1
    133 
    134     trace variable expgui(export_phase) w SetDXTLatoms
    135     SetDXTLatoms
     140    # Fourier Box
     141    incr row
     142    grid [frame $bx.f -relief groove -bd 4] -row $row -column 0 -columnspan 5 -sticky nsew
     143    grid [frame $bx.f.0] -column 0 -columnspan 3 -row 0 -sticky news
     144    grid columnconfig $bx.f.0 0 -weight 1
     145    grid [label $bx.f.0.l1 -text "Fourier display" \
     146              -anchor w] -row 0 -column 0 -sticky w
     147    set ::DXTL(FourierRange) "Range: unknown"
     148    grid [label $bx.f.0.l2 -textvariable ::DXTL(FourierRange) \
     149              -anchor w] -row 0 -column 1 -sticky e
     150    grid [frame $bx.f.1] -column 0 -columnspan 3 -row 1 -sticky news
     151    grid [frame $bx.f.2] -column 0 -columnspan 3 -row 2 -sticky news
     152    grid [canvas $bx.f.canvas -relief sunk -bd 2 \
     153              -scrollregion {0 0 5000 500} -width 250 -height 70 \
     154              -yscrollcommand "$bx.f.scroll set" ] \
     155        -column 0 -row 3 -sticky nsew
     156    grid rowconfigure $bx $row -weight 1
     157    grid rowconfigure $bx.f 3 -weight 1
     158    grid columnconfig $bx.f 0 -weight 1
     159    frame [set ::DXTL(fb) $bx.f.canvas.fr]
     160    $bx.f.canvas create window 0 0 -anchor nw -window $::DXTL(fb)
     161    grid [scrollbar $bx.f.scroll \
     162              -command "$bx.f.canvas yview"] -sticky ns -row 3 -column 2
     163    grid [button $bx.f.1.1 -text "Setup\nFourier" \
     164              -command {EditFourier $::expgui(export_phase); SetupFourierButtons} \
     165             ] -column 0 -row 0
     166    grid [button [set ::DXTL(FourCompute) $bx.f.1.2] -text "Compute\nFourier" \
     167              -command {DXTLwritegrd $expgui(export_phase)}] -column 1 -row 0
     168    grid [label $bx.f.1.3 -text "Select\nMap"] -column 3 -row 0
     169    set ::DXTL(fmenu) [tk_optionMenu $bx.f.1.4 ::DXTL(mtype) test]
     170    grid $bx.f.1.4 -column 4 -row 0
     171    grid [button [set ::DXTL(AddContour) $bx.f.1.5] -text "Add\nContour" \
     172              -command AddContour] -column 5 -row 0
     173    grid [frame $bx.f.1.f] -column 0 -columnspan 9 -row 1
     174    grid [label $bx.f.1.f.0 -text "display\nlimits"] -column 0 -row 0
     175    set col 0
     176    foreach a {X Y Z} {
     177        incr col
     178        grid [label $bx.f.1.f.$col -text $a] -column $col -row 0
     179        incr col
     180        grid [entry $bx.f.1.f.$col -textvariable ::DXTL(${a}dispMin) \
     181                  -width 6] -column $col -row 0
     182        incr col
     183        grid [entry $bx.f.1.f.$col -textvariable ::DXTL(${a}dispMax) \
     184                  -width 6] -column $col -row 0
     185    }
     186    set ::DXTL(contours) 0
     187    trace variable ::expgui(export_phase) w OnNewFourierPhase
     188    OnNewFourierPhase
    136189    # this appears to be needed by OSX
    137190    ResizeWin .export
     191    # force the window to stay on top
     192    putontop .export
     193    SetDXTLatoms
    138194
    139195    # Wait for the Write or Quit button to be pressed
     
    161217        # title info from GSAS title & phase title
    162218        puts $fp "REM  created by EXPGUI from $expgui(expfile) on [clock format [clock seconds]]"
    163         puts $fp "title \"$DXTL(title)\""
    164         puts $fp "pack $DXTL(xmin) $DXTL(xmax) $DXTL(ymin) $DXTL(ymax) $DXTL(zmin) $DXTL(zmax)"
     219        puts $fp "title \"$::DXTL(title)\""
     220        puts $fp "pack $::DXTL(xmin) $::DXTL(xmax) $::DXTL(ymin) $::DXTL(ymax) $::DXTL(zmin) $::DXTL(zmax)"
    165221        puts $fp "edges 0.02 Black"
    166222        puts $fp "phong 1.0 30."
    167223        foreach type [array names typelist] {
    168             if {$DXTL(display_$type) == "sphere"} {
    169                 puts $fp "sphere $type $DXTL(radius_$type) $DXTL(color_$type)"
    170             } elseif {$DXTL(display_$type) == "polyhedron"} {
    171                 puts $fp "polysz $type $DXTL(radius_$type) $DXTL(color_$type)"
    172             } elseif {$DXTL(display_$type) == "ellipsoid"} {
    173                 puts $fp "ellipcolor $type * $DXTL(color_$type)"
     224            if {$::DXTL(display_$type) == "sphere"} {
     225                puts $fp "sphere $type $::DXTL(radius_$type) $::DXTL(color_$type)"
     226            } elseif {$::DXTL(display_$type) == "polyhedron"} {
     227                puts $fp "polysz $type $::DXTL(radius_$type) $::DXTL(color_$type)"
     228            } elseif {$::DXTL(display_$type) == "ellipsoid"} {
     229                puts $fp "ellipcolor $type * $::DXTL(color_$type)"
    174230            }
    175231        }
    176         if {$DXTL(coords)} {
     232        if {$::DXTL(coords)} {
    177233            # write out cell parameters
    178234            puts -nonewline $fp "cell"
     
    204260            puts $fp "import gsas [file tail $expgui(expfile)] $phase"
    205261        }
    206         for {set i 1} {$i <= $DXTL(bonds)} {incr i} {
    207             puts $fp "bond $DXTL(ba_$i) $DXTL(bb_$i) $DXTL(bw_$i) $DXTL(bmin_$i) $DXTL(bmax_$i) $DXTL(bc_$i)"
     262        for {set i 1} {$i <= $::DXTL(bonds)} {incr i} {
     263            puts $fp "bond $::DXTL(ba_$i) $::DXTL(bb_$i) $::DXTL(bw_$i) $::DXTL(bmin_$i) $::DXTL(bmax_$i) $::DXTL(bc_$i)"
    208264        }
    209265        # list arrows, when requested
    210266        if {[lindex $expmap(phasetype) [expr {$phase - 1}]] != 1 && \
    211                 $DXTL(genarrows)} {
     267                $::DXTL(genarrows)} {
    212268            DXTLwriteArrows $fp $phase
    213269        }
     270        DXTLwriteFourierCommands $fp
    214271        puts $fp "END"
    215272        close $fp
    216         if {$DXTL(launch)} {
    217             exec $DXTL(app) $filnam &
     273        if {$::DXTL(launch)} {
     274            exec $::DXTL(app) $filnam &
    218275        }
    219276    } errmsg] {
     
    224281                -message "File [file tail $filnam] was written"
    225282    }
    226     catch {unset DXTL}
     283    #catch {unset DXTL}
    227284    foreach t [trace vinfo expgui(export_phase)] {
    228285        eval trace vdelete expgui(export_phase) $t
     
    245302# add atoms to atom representation list
    246303proc SetDXTLatoms {args} {
    247     global DXTL expgui expmap
    248     set colorlist "White Red Green Blue Yellow Cyan Magenta Black Orange Brown Grey Silver White"
    249     eval destroy [winfo children $DXTL(lb)]
    250     eval destroy [winfo children $DXTL(Blst)]
    251     set DXTL(bonds) 0
     304    global expgui expmap
     305    eval destroy [winfo children $::DXTL(lb)]
     306    eval destroy [winfo children $::DXTL(Blst)]
     307    set ::DXTL(bonds) 0
    252308    if {$expgui(export_phase) == 0} {return}
    253309    set phase $expgui(export_phase)
     
    259315    }
    260316    if {[lindex $expmap(phasetype) [expr {$phase - 1}]] == 1} {
    261         set DXTL(genarrows) 0
    262         $DXTL(arrowbox) configure -state disabled
    263         grid forget $DXTL(arrowcolorbox)
     317        set ::DXTL(genarrows) 0
     318        $::DXTL(arrowbox) configure -state disabled
     319        grid forget $::DXTL(arrowcolorbox)
    264320    } else {
    265         set DXTL(genarrows) 1
    266         $DXTL(arrowbox) configure -state normal
    267         grid $DXTL(arrowcolorbox) -sticky ew -row $DXTL(arrowcolorbox_row) \
     321        set ::DXTL(genarrows) 1
     322        $::DXTL(arrowbox) configure -state normal
     323        grid $::DXTL(arrowcolorbox) -sticky ew -row $::DXTL(arrowcolorbox_row) \
    268324            -column 1 -columnspan 5
    269325    }
    270326    catch {unset typelist}
    271     set DXTL(title)  [phaseinfo $phase name]
     327    set ::DXTL(title)  [phaseinfo $phase name]
    272328    foreach atom $expmap(atomlist_$phase) {
    273329        set typelist([atominfo $phase $atom type]) 1
    274330    }
    275     set DXTL(typelist) [array names typelist]
     331    set ::DXTL(typelist) [array names typelist]
    276332    set row 0
    277     grid [label $DXTL(lb).l$row -text "type " -bg yellow\
     333    grid [label $::DXTL(lb).l$row -text "type " -bg yellow\
    278334             ] -column 0 -row $row  -sticky ew
    279     grid [label $DXTL(lb).d$row -text " representation " -bg yellow
     335    grid [label $::DXTL(lb).d$row -text " representation " -bg yellow
    280336         ] -column 1 -row $row -sticky ew
    281     grid [label $DXTL(lb).e$row -text " radius " -bg yellow\
     337    grid [label $::DXTL(lb).e$row -text " radius " -bg yellow\
    282338             ] -column 2 -row $row -sticky ew
    283     grid [label $DXTL(lb).c$row -text " color " -bg yellow\
     339    grid [label $::DXTL(lb).c$row -text " color " -bg yellow\
    284340             ] -column 3 -row $row -sticky ew
    285341    foreach type [array names typelist] {
    286342        incr row
    287         grid [label $DXTL(lb).l$row -text $type] -column 0 -row $row
    288         tk_optionMenu $DXTL(lb).d$row DXTL(display_$type) sphere polyhedron ellipsoid none
    289         grid $DXTL(lb).d$row -column 1 -row $row
    290         grid [entry $DXTL(lb).e$row -textvariable DXTL(radius_$type) \
     343        grid [label $::DXTL(lb).l$row -text $type] -column 0 -row $row
     344        tk_optionMenu $::DXTL(lb).d$row ::DXTL(display_$type) sphere polyhedron ellipsoid none
     345        grid $::DXTL(lb).d$row -column 1 -row $row
     346        grid [entry $::DXTL(lb).e$row -textvariable ::DXTL(radius_$type) \
    291347                -width 5] -column 2 -row $row
    292         eval tk_optionMenu $DXTL(lb).c$row DXTL(color_$type) $colorlist
    293         grid $DXTL(lb).c$row -column 3 -row $row
    294         set DXTL(display_$type) sphere
    295         set DXTL(radius_$type) 0.2
    296         set DXTL(color_$type) [lindex $colorlist $row]
    297     }
     348        eval tk_optionMenu $::DXTL(lb).c$row ::DXTL(color_$type) $::DXTLcolorlist
     349        grid $::DXTL(lb).c$row -column 3 -row $row
     350        set ::DXTL(display_$type) sphere
     351        set ::DXTL(radius_$type) 0.2
     352        set ::DXTL(color_$type) [lindex $::DXTLcolorlist $row]
     353    }
     354    # Resize the list
     355    update idletasks
     356    foreach i {lb Blst fb} {
     357        set sizes [grid bbox $::DXTL($i)]
     358        [winfo parent $::DXTL($i)] config -scrollregion $sizes  \
     359            -width [lindex $sizes 2]
     360    }
     361    wm geom [winfo toplevel $::DXTL(Blst)] {}
     362}
     363
     364# add bonds to bond list
     365proc DXTLaddBond {} {
     366    if {$::DXTL(bonds) == 0} {
     367        # insert header
     368        set row 0
     369        grid [label $::DXTL(Blst).a$row -text "from " -bg yellow\
     370                 ] -column 1 -row $row  -sticky ew
     371        grid [label $::DXTL(Blst).b$row -text " to " -bg yellow\
     372                 ] -column 2 -row $row  -sticky ew
     373        grid [label $::DXTL(Blst).c$row -text " width " -bg yellow\
     374                 ] -column 3 -row $row  -sticky ew
     375        grid [label $::DXTL(Blst).d$row -text " min " -bg yellow\
     376             ] -column 4 -row $row  -sticky ew
     377        grid [label $::DXTL(Blst).e$row -text " max " -bg yellow\
     378                 ] -column 5 -row $row  -sticky ew
     379        grid [label $::DXTL(Blst).f$row -text " color " -bg yellow\
     380                 ] -column 6 -row $row  -sticky ew
     381    }
     382    set row [incr ::DXTL(bonds)]
     383    eval tk_optionMenu $::DXTL(Blst).ta$row ::DXTL(ba_$row) $::DXTL(typelist)
     384    grid $::DXTL(Blst).ta$row -column 1 -row $row
     385    eval tk_optionMenu $::DXTL(Blst).tb$row ::DXTL(bb_$row) $::DXTL(typelist)
     386    grid $::DXTL(Blst).tb$row -column 2 -row $row
     387    grid [entry $::DXTL(Blst).w$row -textvariable ::DXTL(bw_$row) \
     388              -width 5] -column 3 -row $row
     389    grid [entry $::DXTL(Blst).mi$row -textvariable ::DXTL(bmin_$row) \
     390              -width 5] -column 4 -row $row
     391    grid [entry $::DXTL(Blst).mx$row -textvariable ::DXTL(bmax_$row) \
     392              -width 5] -column 5 -row $row
     393    eval tk_optionMenu $::DXTL(Blst).c$row ::DXTL(bc_$row) $::DXTLcolorlist
     394    grid $::DXTL(Blst).c$row -column 6 -row $row
     395    set ::DXTL(bw_$row) 0.02
     396    set ::DXTL(bmin_$row) 1.0
     397    set ::DXTL(bmax_$row) 2.0
     398    set ::DXTL(bc_$row) [lindex $::DXTLcolorlist $row]
    298399    # Resize the list
    299400    update
    300     set sizes [grid bbox $DXTL(lb)]
    301     [winfo parent $DXTL(lb)] config -scrollregion $sizes \
     401    set sizes [grid bbox $::DXTL(Blst)]
     402    [winfo parent $::DXTL(Blst)] config -scrollregion $sizes \
    302403        -width [lindex $sizes 2]
    303     set sizes [grid bbox $DXTL(Blst)]
    304     [winfo parent $DXTL(Blst)] config -scrollregion $sizes \
    305         -width [lindex $sizes 2]
    306     wm geom [winfo toplevel $DXTL(Blst)] {}
    307 }
    308 
    309 # add bonds to bond list
    310 proc DXTLaddBond {} {
    311     global DXTL
    312     set colorlist "White Red Green Blue Yellow Cyan Magenta Black Orange Brown Grey Silver White"
    313 
    314     if {$DXTL(bonds) == 0} {
    315         # insert header
    316         set row 0
    317         grid [label $DXTL(Blst).a$row -text "from " -bg yellow\
    318                  ] -column 1 -row $row  -sticky ew
    319         grid [label $DXTL(Blst).b$row -text " to " -bg yellow\
    320                  ] -column 2 -row $row  -sticky ew
    321         grid [label $DXTL(Blst).c$row -text " width " -bg yellow\
    322                  ] -column 3 -row $row  -sticky ew
    323         grid [label $DXTL(Blst).d$row -text " min " -bg yellow\
    324              ] -column 4 -row $row  -sticky ew
    325         grid [label $DXTL(Blst).e$row -text " max " -bg yellow\
    326                  ] -column 5 -row $row  -sticky ew
    327         grid [label $DXTL(Blst).f$row -text " color " -bg yellow\
    328                  ] -column 6 -row $row  -sticky ew
    329     }
    330     set row [incr DXTL(bonds)]
    331     eval tk_optionMenu $DXTL(Blst).ta$row DXTL(ba_$row) $DXTL(typelist)
    332     grid $DXTL(Blst).ta$row -column 1 -row $row
    333     eval tk_optionMenu $DXTL(Blst).tb$row DXTL(bb_$row) $DXTL(typelist)
    334     grid $DXTL(Blst).tb$row -column 2 -row $row
    335     grid [entry $DXTL(Blst).w$row -textvariable DXTL(bw_$row) \
    336               -width 5] -column 3 -row $row
    337     grid [entry $DXTL(Blst).mi$row -textvariable DXTL(bmin_$row) \
    338               -width 5] -column 4 -row $row
    339     grid [entry $DXTL(Blst).mx$row -textvariable DXTL(bmax_$row) \
    340               -width 5] -column 5 -row $row
    341     eval tk_optionMenu $DXTL(Blst).c$row DXTL(bc_$row) $colorlist
    342     grid $DXTL(Blst).c$row -column 6 -row $row
    343     set DXTL(bw_$row) 0.02
    344     set DXTL(bmin_$row) 1.0
    345     set DXTL(bmax_$row) 2.0
    346     set DXTL(bc_$row) [lindex $colorlist $row]
    347     # Resize the list
    348     update
    349     set sizes [grid bbox $DXTL(Blst)]
    350     [winfo parent $DXTL(Blst)] config -scrollregion $sizes \
    351         -width [lindex $sizes 2]
     404    #set can [winfo parent $::DXTL($i)]
     405    #set scroll [winfo parent $can].scroll
     406    #[winfo parent $::DXTL($i)] config -scrollregion $sizes
    352407}
    353408
    354409proc DXTLwriteArrows {out phase} {
    355     global expgui expmap DXTL
     410    global expgui expmap
    356411    set fp [open geom.in w]
    357412    puts $fp "N"
     
    399454                puts $out "rem spin for atom $name # $k ($spin)"
    400455                if {$spin == "Red"} {
    401                     puts $out "arrow $pos     $vec    1. 0.15 $DXTL(redarrow)"
     456                    puts $out "arrow $pos     $vec    1. 0.15 $::DXTL(redarrow)"
    402457                } else {
    403                     puts $out "arrow $pos     $vec    1. 0.15 $DXTL(blackarrow)"
     458                    puts $out "arrow $pos     $vec    1. 0.15 $::DXTL(blackarrow)"
    404459                }
    405460            } elseif {$i == 6} {
     
    412467    puts $out "mag_trans 1. 0 0  0 1. 0  0 0 1."
    413468}
     469
     470# Computes a Fourier map(s) and converts the maps from binary to ascii
     471#   returns a list of Fourier map types
     472proc DXTLwritegrd {phase} {
     473    global expgui expmap
     474    set lst [listFourier]
     475    if {[llength $lst] < 1} {
     476        MyMessageBox -parent . -title "No Fourier" \
     477            -message "You have not set up to compute a Fourier map." \
     478            -icon warning
     479        return
     480    }
     481    set typelist {}
     482    foreach l $lst {
     483        lappend typelist [Fourierinfo $l type]
     484    }
     485    set hists [FourierHists $phase]
     486    # make sure we have default limits
     487    getFourierLimits $phase
     488    if {[llength $hists] < 1} {
     489        MyMessageBox -parent . -title "No Fourier" \
     490            -message "You have not set up to compute a Fourier map for phase $phase." \
     491            -icon warning
     492        return
     493    }
     494    if {$::tcl_platform(platform) == "windows"} {
     495        set map [file join $expgui(gsasexe) gsas2map.exe]
     496        set fourier [file join $expgui(gsasexe) fourier.exe]
     497    } else {
     498        set map [file join $expgui(gsasexe) gsas2map]
     499        set fourier [file join $expgui(gsasexe) fourier]
     500    }
     501    if {![file exists $map]} {
     502        MyMessageBox -parent . -title "No Map Converter prog" \
     503            -message "Error Fourier map converter program ($map) not found." \
     504            -icon warning
     505        return
     506    }
     507    if {![file exists $fourier]} {
     508        MyMessageBox -parent . -title "No Fourier prog" \
     509            -message "Error Fourier program ($fourier) not found." \
     510            -icon warning
     511        return
     512    }
     513    set fp [open f.in w]
     514    if {[OutputFourierType]} {
     515        puts $fp [lindex $typelist 0]
     516    }
     517    puts $fp "E"
     518    foreach t [lrange $typelist 1 end] {
     519        puts $fp "F $t"
     520        puts $fp "E"
     521    }
     522    puts $fp "q"
     523    close $fp
     524    # delete any old grd files
     525    foreach f [glob -nocomplain "[file root $expgui(expfile)]*.grd"] {
     526        catch {file delete -force $f}
     527    }
     528    set deleteerror 0
     529    if {[llength [glob -nocomplain "[file root $expgui(expfile)]*.grd"]] >0} {
     530        MyMessageBox -parent . -title "Old grd files?" \
     531            -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." \
     532            -icon warning
     533        set deleteerror 1
     534    }
     535    # Save the current exp file
     536    savearchiveexp
     537    # disable the file changed monitor
     538    set expgui(expModifiedLast) 0
     539    catch {
     540        exec $fourier [file root $expgui(expfile)] >& f.out
     541        exec $map [file root $expgui(expfile)] < f.in >>& f.out
     542    }
     543    # reset the file changed monitor
     544    #loadexp $expgui(expfile)
     545    set expgui(expModifiedLast) [file mtime $expgui(expfile)]
     546
     547    if {[llength [glob -nocomplain "[file root $expgui(expfile)]*.grd"]] == 0} {
     548        set fp [open f.out r]
     549        set lines {}
     550        while {[gets $fp line] >= 0} {
     551            append lines $line "\n"
     552        }
     553        close $fp
     554        MyMessageBox -parent . -title "No grd files" \
     555            -message "Error: no .grd files were created. See log file below\n\n$lines" \
     556            -icon error
     557        return {}
     558    } else {
     559        catch {close $fp}
     560        catch {file delete -force f.in f.out}
     561        SetupFourierButtons
     562        return $typelist
     563    }
     564}
     565
     566# called when the phase # is set or changed
     567# clean up old Fourier maps
     568proc OnNewFourierPhase {args} {
     569    SetDXTLatoms
     570    if {[llength $::expmap(phaselist)] > 1} {
     571        # there is more than one phase; delete any .grd files to make sure
     572        # generate ones for the current phase
     573        foreach f [glob -nocomplain "[file root $::expgui(expfile)]*.grd"] {
     574            catch {file delete -force $f}
     575        }
     576    }
     577    SetupFourierButtons
     578    eval destroy [winfo children $::DXTL(fb)]
     579    set ::DXTL(contours) 0
     580}
     581
     582# this enables/disables Fourier buttons based on the Fourier setup
     583# and the files that are present
     584proc SetupFourierButtons {} {
     585    if {[catch {
     586        set phase $::expgui(export_phase)
     587        $::DXTL(FourCompute) config -state disabled
     588        $::DXTL(AddContour) config -state disabled
     589        $::DXTL(fmenu) delete 0 end
     590    }]} return
     591    set ::DXTL(mtype) ""
     592    set ::DXTL(mfil) ""
     593    set ::DXTL(FourierRange) ""
     594    # if the Fourier is not set up; return here
     595    if {[llength [set nF [listFourier]]] < 1} return
     596    # check that all phases are set to current phase
     597    foreach i $nF {
     598        set ph [Fourierinfo $i phase]
     599        if {$ph != $phase} return
     600    }
     601    if {[llength [FourierHists $phase]] < 1} return
     602    # make sure we have default limits
     603    getFourierLimits $phase
     604    $::DXTL(FourCompute) config -state normal
     605    # if there are no maps, return now
     606    set maps [glob -nocomplain "[file root $::expgui(expfile)]*.grd"]
     607    if {[llength $maps] < 1} return
     608    set types {}
     609    foreach fil $maps {
     610        lappend types [lindex [split [file root [file tail $fil]] "_"] end]
     611    }
     612    set i 0
     613    foreach fil $maps lbl $types {
     614        $::DXTL(fmenu) add command -label $lbl \
     615            -command "set DXTL(mtype) $lbl; set DXTL(mfil) $fil; GetFourierRange"
     616        if {$i == 0} {
     617            $::DXTL(fmenu) invoke 0
     618            $::DXTL(AddContour) config -state normal
     619        }
     620        incr i
     621    }
     622}
     623
     624proc AddContour {} {
     625    # set a header
     626    if {$::DXTL(contours) == 0} {
     627        set row 0
     628        grid [label $::DXTL(fb).a$row -text "Type" -bg yellow \
     629                 ] -column 1 -row $row  -sticky ew
     630        grid [label $::DXTL(fb).b$row -text "Contour Level" -bg yellow \
     631                 ] -column 2 -row $row  -sticky ew
     632        grid [label $::DXTL(fb).c$row -text "Color" -bg yellow \
     633                 -anchor center] -column 3 -row $row  -sticky ew
     634    }
     635    set row [incr ::DXTL(contours)]
     636    eval tk_optionMenu $::DXTL(fb).ta$row ::DXTL(fb_type_$row) {mesh solid}
     637    grid $::DXTL(fb).ta$row -column 1 -row $row
     638    grid [entry $::DXTL(fb).w$row -width 10 -textvariable ::DXTL(fb_val_$row) \
     639         ] -column 2 -row $row
     640    set menu [eval tk_optionMenu $::DXTL(fb).tb$row \
     641                  ::DXTL(fb_color_$row) $::DXTLcolorlist]
     642    $menu invoke $row
     643    grid $::DXTL(fb).tb$row -column 3 -row $row
     644    grid [button $::DXTL(fb).del$row -text "Delete"\
     645             -command "DeleteFourierContour $row"] -column 4 -row $row
     646    update idletasks
     647    set sizes [grid bbox $::DXTL(fb)]
     648    [winfo parent $::DXTL(fb)] config -scrollregion $sizes \
     649        -width [lindex $sizes 2]
     650}
     651
     652proc DeleteFourierContour {row} {
     653    foreach i "$::DXTL(fb).ta$row $::DXTL(fb).w$row $::DXTL(fb).tb$row \
     654$::DXTL(fb).tb$row $::DXTL(fb).del$row" {
     655        catch {destroy $i}
     656    }
     657    set ::DXTL(fb_val_$i) ""
     658    if {$::DXTL(contours) == $row} {incr ::DXTL(contours) -1}
     659}
     660
     661proc GetFourierRange {} {
     662    set fp [open f.in w]
     663    set lst [listFourier]
     664    if {[llength $lst] < 1} {
     665        MyMessageBox -parent . -title "No Fourier" \
     666            -message "You have not set up to compute a Fourier map." \
     667            -icon warning
     668        return
     669    }
     670    set typelist {}
     671    foreach l $lst {
     672        lappend typelist [Fourierinfo $l type]
     673    }
     674    if {[OutputFourierType]} {
     675        puts $fp $::DXTL(mtype)
     676    }
     677    close $fp
     678    if {$::tcl_platform(platform) == "windows"} {
     679        set map [file join $::expgui(gsasexe) forsrh.exe]
     680    } else {
     681        set map [file join $::expgui(gsasexe) forsrh]
     682    }
     683    catch {
     684        exec $map [file root $::expgui(expfile)] < f.in >& f.out
     685    }
     686    foreach {min max} {{} {}} {}
     687    catch {
     688        set fp [open "f.out" r]       
     689        while {[gets $fp line] >= 0} {
     690            if {[string first "range of map values" $line] != -1} {
     691                set off [expr 4 + [string first " is " $line]]
     692                foreach {min to max} [string trim [string range $line $off end]] {}
     693                break
     694            }
     695        }
     696    }
     697    catch {
     698        close $fp
     699    }
     700    if {$min != ""} {set ::DXTL(FourierRange) "Range: $min to $max"}
     701}
     702
     703# is output of the current Fourier map type required as input to a program?
     704# answer is yes when more than one map file is present
     705proc OutputFourierType {} {
     706    set i 0
     707    foreach ext {DEL FCL FOB PTS DPT} {
     708        if {[file exists [file root $::expgui(expfile)].$ext]} {
     709            incr i
     710        }
     711        for {set i 2} {$i <= 9} {incr i} {
     712            if {[file exists [file root $::expgui(expfile)].${i}FD]} {
     713                incr i
     714            }
     715        }
     716    }
     717    if {$i > 1} {
     718        return 1
     719    }
     720    return 0
     721}
     722
     723proc DXTLwriteFourierCommands {fp} {
     724    if {$::DXTL(mfil) == ""} return
     725    if {![file exists $::DXTL(mfil)]} {
     726        puts "file not found $::DXTL(mfil)"
     727        return
     728    }
     729    set cntlist {}
     730    for {set i 1} {$i <= $::DXTL(contours)} {incr i} {
     731        set val ""
     732        catch {set val $::DXTL(fb_val_$i)}
     733        if {[catch {set val [expr 1.*$val]}]} continue
     734        lappend cntlist [list $val $::DXTL(fb_type_$i) $::DXTL(fb_color_$i)]       }
     735    if {[llength $cntlist] <= 0} return
     736    puts $fp "mapread grd [file tail $::DXTL(mfil)] 4"
     737    foreach item $cntlist {
     738        puts $fp "mapcontour $item"
     739    }
     740    set s {}
     741    foreach a {X Y Z} {
     742        lappend s $::DXTL(${a}dispMin)
     743        lappend s $::DXTL(${a}dispMax)
     744    }
     745    puts $fp "mapregion $s"
     746}
Note: See TracChangeset for help on using the changeset viewer.