Changeset 1025 for trunk/readexp.tcl


Ignore:
Timestamp:
Oct 13, 2010 2:27:15 PM (10 years ago)
Author:
toby
Message:

see https://subversion.xor.aps.anl.gov/trac/EXPGUI/wiki/News20101013

Location:
trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk

  • trunk/readexp.tcl

    r997 r1025  
    8080#
    8181proc mapexp {} {
    82     global expmap exparray
     82    global expgui expmap exparray
    8383    # clear out the old array
    8484    set expmap_Revision $expmap(Revision)
     
    187187        }
    188188    }
     189    set expgui(mapstat) 1
    189190}
    190191
     
    495496    }
    496497    return {}
     498}
     499
     500proc disagldat_get {phase} {
     501    set key "  DSGL CDAT$phase"
     502    if {[existsexp $key] == 0} {return "{none} {none}"}
     503    set line [readexp $key]
     504    set i1 2
     505    # read atom-atom distance parameter
     506    set dist {}
     507    set item [string range $line $i1 [expr {$i1+3}]]
     508    if {$item == "DMAX"} {
     509        set val [string range $line [expr {$i1+4}] [expr {$i1+11}]]
     510        set dist [string trim $val]
     511        incr i1 13
     512    } else {
     513        set dist "radii"
     514        incr i1 5
     515    }
     516    # read atom-atom-atom angle parameter
     517    set ang {}
     518    set item [string range $line $i1 [expr {$i1+3}]]
     519    if {$item == "DAGL"} {
     520        set val [string range $line [expr {$i1+4}] [expr {$i1+11}]]
     521        set ang [string trim $val]
     522        incr i1 13
     523    } else {
     524        set ang "radii"
     525        incr i1 5
     526    }
     527    # note there are two more parameters, NOFO/FORA & ONCR/DFLT, but they are not being processed yet
     528    return "$dist $ang"
    497529}
    498530
     
    519551#     ODFcoefXXX -- the ODF coefficient for for ODF term XXX (*)
    520552#     ODFRefcoef -- refinement flag for ODF terms (*)
     553#     DistCalc   -- returns "radii", "none" or a number (*)
     554#                   none: no distance or angle computation for the phase
     555#                   radii: computation will be done by sums of radii
     556#                          (see AtmTypInfo and DefAtmTypInfo)
     557#                   other: a distance specifing the maximum distance
     558#     AngCalc    -- returns "radii", "none" or a number (*)
     559#                   none: no distance or angle computation for the phase
     560#                   radii: computation will be done by sums of radii
     561#                          (see AtmTypInfo and DefAtmTypInfo)
     562#                   other: a distance specifing the maximum distance
    521563#  action: get (default) or set
    522564#  value: used only with set
     
    832874            }
    833875        }
    834 
     876        DistCalc-get {
     877            set val [disagldat_get $phase]
     878            return [lindex $val 0]
     879        }
     880        DistCalc-set {
     881            set key "  DSGL CDAT$phase"
     882            # for none delete the record & thats all folks
     883            if {$value == "none"} {
     884                catch {unset ::exparray($key)}
     885                return
     886            }
     887            if {[existsexp $key] == 0} {
     888                makeexprec $key
     889            }
     890            set line [readexp $key]
     891            if {[string trim $line] == ""} {
     892                # blank set to defaults
     893                set line [string replace $line 2 15 "DRAD ARAD NOFO"]
     894            }
     895            if {$value == "radii"} {
     896                if {[string range $line 2 5] == "DMAX"} {
     897                    set line [string replace $line 2 13 "DRAD"]
     898                } else {
     899                    set line [string replace $line 2 5 "DRAD"]
     900                }
     901            } else {
     902                if ![validreal value 8 2] {return 0}
     903                if {[string range $line 2 5] == "DMAX"} {
     904                    set line [string replace $line 6 13 $value]
     905                } else {
     906                    set line [string replace $line 2 5 "DMAX"]
     907                    set line [string replace $line 6 6 "$value "]
     908                }
     909            }
     910            setexp $key $line 0 68
     911        }
     912        AngCalc-get {
     913            set val [disagldat_get $phase]
     914            return [lindex $val 1]
     915        }
     916        AngCalc-set {
     917            set key "  DSGL CDAT$phase"
     918            # for none delete the record & thats all folks
     919            if {$value == "none"} {
     920                catch {unset ::exparray($key)}
     921                return
     922            }
     923            if {[existsexp $key] == 0} {
     924                makeexprec $key
     925            }
     926            set line [readexp $key]
     927            if {[string trim $line] == ""} {
     928                # blank set to defaults
     929                set line [string replace $line 2 15 "DRAD ARAD NOFO"]
     930            }
     931            if {[string range $line 2 5] == "DMAX"} {
     932                set i2 8
     933            } else {
     934                set i2 0
     935            }
     936            if {$value == "radii"} {
     937                if {[string range $line [expr {$i2+7}] [expr {$i2+10}]] == "DAGL"} {
     938                    set line [string replace $line [expr {$i2+7}] [expr {$i2+18}] "ARAD"]
     939                } else {
     940                    set line [string replace $line [expr {$i2+7}] [expr {$i2+10}] "ARAD"]
     941                }
     942            } else {
     943                if ![validreal value 8 2] {return 0}
     944                if {[string range $line [expr {$i2+7}] [expr {$i2+10}]] == "DAGL"} {
     945                    set line [string replace $line [expr {$i2+11}] [expr {$i2+18}] $value]
     946                } else {
     947                    set line [string replace $line [expr {$i2+7}] [expr {$i2+10}] "DAGL"]
     948                    set line [string replace $line [expr {$i2+11}] [expr {$i2+11}] "$value "]
     949                }
     950            }
     951            setexp $key $line 0 68
     952        }
    835953        default {
    836954            set msg "Unsupported phaseinfo access: parm=$parm action=$action"
    837             tk_dialog .badexp "Error in readexp" $msg error 0 Exit 
     955            tk_dialog .badexp "Error in readexp" $msg error 0 Exit
    838956        }
    839957    }
    840958    return 1
    841959}
     960
    842961
    843962
     
    26482767}
    26492768
     2769# get list of defined atom types
     2770proc AtmTypList {} {
     2771    set natypes [readexp " EXPR  NATYP"]
     2772    if {$natypes == ""} return
     2773    set j 0
     2774    set typelist {}
     2775    for {set i 1} {$i <= $natypes} {incr i} {
     2776        set key {this should never be matched}
     2777        while {![existsexp $key]} {
     2778            incr j
     2779            if {$j > 99} {
     2780                return $typelist
     2781            } elseif {$j <10} {
     2782                set key " EXPR ATYP $j"
     2783            } else {
     2784                set key " EXPR ATYP$j"
     2785            }
     2786        }
     2787        lappend typelist [string trim [string range $::exparray($key) 2 9]]
     2788    }
     2789    return $typelist
     2790}
     2791
     2792# read information about atom types
     2793#     distrad    atomic distance search radius (get/set)
     2794#     angrad     atomic angle search radius (get/set)
     2795proc AtmTypInfo {parm atmtype "action get" "value {}"} {
     2796    # first, search through the records to find the record matching the type
     2797    set natypes [readexp " EXPR  NATYP"]
     2798    if {$natypes == ""} return
     2799    set j 0
     2800    set typelist {}
     2801    for {set i 1} {$i <= $natypes} {incr i} {
     2802        set key {this should never be matched}
     2803        while {![existsexp $key]} {
     2804            incr j
     2805            if {$j > 99} {
     2806                return $typelist
     2807            } elseif {$j <10} {
     2808                set key " EXPR ATYP $j"
     2809            } else {
     2810                set key " EXPR ATYP$j"
     2811            }
     2812        }
     2813        if {[string toupper $atmtype] == \
     2814                [string toupper [string trim [string range $::exparray($key) 2 9]]]} break
     2815        set key {}
     2816    }
     2817    if {$key == ""} {
     2818        # atom type not found
     2819        return {}
     2820    }
     2821    switch -glob ${parm}-$action {
     2822        distrad-get {
     2823            return [string trim [string range [readexp $key] 15 24]]
     2824        }
     2825        distrad-set {
     2826            if ![validreal value 10 2] {return 0}
     2827            setexp $key $value 16 10
     2828        }
     2829        angrad-get {
     2830            return [string trim [string range [readexp $key] 25 34]]
     2831        }
     2832        angrad-set {
     2833            if ![validreal value 10 2] {return 0}
     2834            setexp $key $value 26 10
     2835        }
     2836        default {
     2837            set msg "Unsupported AtmTypInfo access: parm=$parm action=$action"
     2838            tk_dialog .badexp "Error in readexp" $msg error 0 Exit
     2839        }
     2840    }
     2841}
     2842# read default information about atom types (records copied to the .EXP file
     2843# from the gsas/data/atomdata.dat file as AFAC ...
     2844#     distrad returns a list of atom types (one or two letters) and
     2845#                the corresponding distance
     2846# note that these values are read only (no set option)
     2847proc DefAtmTypInfo {parm} {
     2848    set keys [array names ::exparray " AFAC *_SIZ"]
     2849    set elmlist {}
     2850    if {[llength $keys] <= 0} {return ""}
     2851    foreach key $keys {
     2852        lappend elmlist [string trim [string range $key 6 7]]
     2853    }
     2854    switch -glob ${parm} {
     2855        distrad {
     2856            set out {}
     2857            foreach key $keys elm $elmlist {
     2858                set val [string range $::exparray($key) 0 9]
     2859                lappend out "$elm [string trim $val]"
     2860            }
     2861            return $out
     2862        }
     2863        angrad {
     2864            set out {}
     2865            foreach key $keys elm $elmlist {
     2866                set val [string range $::exparray($key) 10 19]
     2867                lappend out "$elm [string trim $val]"
     2868            }
     2869            return $out
     2870        }
     2871        default {
     2872            set msg "Unsupported DefAtmTypInfo access: parm=$parm"
     2873            tk_dialog .badexp "Error in readexp" $msg error 0 Exit
     2874        }
     2875    }
     2876}
    26502877# write the .EXP file
    26512878proc expwrite {expfile} {
     
    28313058}
    28323059
    2833 proc GetSoftConst {} {
    2834     set HST {}
    2835     # look for RSN record
    2836     #set n 0
    2837     for {set i 0} {$i < $::expmap(nhst)} {incr i} {
    2838         set ihist [expr {$i + 1}]
    2839         if {[expr {$i % 12}] == 0} {
    2840             incr n
    2841             set line [readexp " EXPR  HTYP$n"]
    2842             if {$line == ""} {
    2843                 set msg "No HTYP$n entry for Histogram $ihist. This is an invalid .EXP file"
    2844                 tk_dialog .badexp "Error in readexp" $msg error 0 Exit
    2845             }
    2846             set j 0
    2847         } else {
    2848             incr j
    2849         }
    2850         if {[string range $line [expr 2+5*$j] [expr 5*($j+1)]] == "RSN "} {
    2851             set HST $ihist
    2852         }
    2853     }
    2854     if {$HST == ""} {return "" ""}
    2855     if {$HST <=9} {
    2856         set key "HST  $HST"
    2857     } else {
    2858         set key "HST $HST"
    2859     }
    2860     set factr [string trim [string range [readexp "$key FACTR"] 0 14]]
    2861     set ncons [string trim [string range [readexp "$key NBNDS"] 0 4]]
    2862     set conslist {}
    2863     for {set i 1} {$i <= $ncons} {incr i} {
    2864         set fi [string toupper [format %.4x $i]]
    2865         lappend conslist [string trim [readexp "${key}BD$fi"]] 
    2866     }
    2867     return [list $factr $conslist]
    2868 }
    2869 
    2870 proc SetSoftCons {factr conslist} {
     3060# read/edit soft (distance) restraint info
     3061#  parm:
     3062#    weight -- histogram weight (factr) *
     3063#    restraintlist -- list of restraints *
     3064#  action: get (default) or set
     3065#  value: used only with set
     3066#  * =>  read+write supported
     3067proc SoftConst {parm "action get" "value {}"} {
    28713068    set HST {}
    28723069    # look for RSN record
     
    28893086        }
    28903087    }
    2891     if {$HST == ""} {
     3088    if {$HST == ""} {return "1"}
     3089    if {$HST <=9} {
     3090        set key "HST  $HST"
     3091    } else {
     3092        set key "HST $HST"
     3093    }
     3094    if {$HST == "" && $action == "set"} {
    28923095        # no RSN found need to add the soft constr. histogram
    28933096        # increment number of histograms
     
    29153118        makeexprec "$key NBNDS"
    29163119    }
    2917     # update histogram
    2918     if {$HST <=9} {
    2919         set key "HST  $HST"
    2920     } else {
    2921         set key "HST $HST"
    2922     }
    2923     # update FACTR
    2924     if ![validreal factr 15 6] {return 0}
    2925     setexp "$key FACTR" $factr 1 15
    2926     set num [llength $conslist]
    2927     if ![validint num 5] {return 0}
    2928     setexp "$key NBNDS" $num 1 5
    2929     # delete all old records
    2930     foreach i [array names ::exparray "${key}BD*"] {unset ::exparray($i)}
    2931     set i 0
    2932     foreach cons $conslist {
    2933         incr i
    2934         set fi [string toupper [format %.4x $i]]
    2935         makeexprec "${key}BD$fi"
    2936         set pos 1
    2937         foreach num $cons len {3 5 5 3 3 3 3 3 -6 -6} {
    2938             if {$len > 0} {
    2939                 validint num $len
    2940                 setexp "${key}BD$fi" $num $pos $len
    2941             } else {
    2942                 set len [expr abs($len)]
    2943                 validreal num $len 3
    2944                 setexp "${key}BD$fi" $num $pos $len
    2945             }
    2946             incr pos $len
    2947         }
    2948     }
    2949 }
     3120
     3121    switch -glob ${parm}-$action {
     3122        weight-get {
     3123            return [string trim [string range [readexp "$key FACTR"] 0 14]]
     3124        }
     3125        weight-set {
     3126            # update FACTR
     3127            if ![validreal value 15 6] {return 0}
     3128            setexp "$key FACTR" $value 1 15
     3129        }
     3130        restraintlist-get {
     3131            set ncons [string trim [string range [readexp "$key NBNDS"] 0 4]]
     3132            set conslist {}
     3133            for {set i 1} {$i <= $ncons} {incr i} {
     3134                set fi [string toupper [format %.4x $i]]
     3135                set line [readexp "${key}BD$fi"]
     3136                set const {}
     3137                foreach len {3 5 5 3 3 3 3 3 6 6} {
     3138                  set lenm1 [expr {$len - 1}]
     3139                  lappend const [string trim [string range $line 0 $lenm1]]
     3140                  set line [string range $line $len end]
     3141                }
     3142                lappend conslist $const
     3143            }
     3144            return $conslist
     3145        }
     3146        restraintlist-set {
     3147            set num [llength $value]
     3148            if ![validint num 5] {return 0}
     3149            setexp "$key NBNDS" $num 1 5
     3150            # delete all old records
     3151            foreach i [array names ::exparray "${key}BD*"] {unset ::exparray($i)}
     3152            set i 0
     3153            foreach cons $value {
     3154                incr i
     3155                set fi [string toupper [format %.4x $i]]
     3156                makeexprec "${key}BD$fi"
     3157                set pos 1
     3158                foreach num $cons len {3 5 5 3 3 3 3 3 -6 -6} {
     3159                    if {$len > 0} {
     3160                        validint num $len
     3161                        setexp "${key}BD$fi" $num $pos $len
     3162                    } else {
     3163                        set len [expr abs($len)]
     3164                        validreal num $len 3
     3165                        setexp "${key}BD$fi" $num $pos $len
     3166                    }
     3167                    incr pos $len
     3168                }
     3169            }
     3170        }
     3171        default {
     3172            set msg "Unsupported phaseinfo access: parm=$parm action=$action"
     3173            tk_dialog .badexp "Error in readexp" $msg error 0 Exit
     3174        }
     3175    return 1
     3176    }
     3177}
     3178
    29503179#======================================================================
    29513180# conversion routines
Note: See TracChangeset for help on using the changeset viewer.