API tools faq
paste
johnkris

p.pl

johnkris
Oct 9th, 2025
242
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
C 242.00 KB | Source Code | 0 0
raw download clone embed print report
  1. #!/usr/bin/env perl
  2.  
  3. ###################################
  4. # THIS PROGRAMM IS DOCUMENTED WITH INLINE PODs
  5. # There are different comments for users and programmers
  6. # Extract pod with
  7. # USERs:       sed '/=PROG/,/=cut/d' p.pl | sed 's/=USER/=/g' | pod2html
  8. # PROGRAMMERs: sed '/=USER/,/=cut/d' p.pl | sed 's/=PROG/=/g' | pod2html
  9. #
  10. # Use script
  11. # ./pray2doc
  12. # for the lazy ones
  13. ############
  14.  
  15. ###################################
  16. # Define used modules
  17. use strict;
  18. use warnings;
  19. use Tk;
  20. use Tk::Pretty;
  21. use Tk::BrowseEntry;
  22. use Tk::Balloon;
  23. use Tk::Dialog;
  24. use Tk::LabEntry;
  25. use Tk::ROText;
  26. #use lib LabOptionmenu;
  27. use lib "./lib";
  28. use lib '/opt/pray/lib';
  29. #use lib "/opt/pray/lib";
  30. use Tk::Menu;
  31. use Tk::PNG;
  32.  
  33. use FileHandle;
  34. use strict;
  35. use warnings;
  36. use Carp;
  37. use Getopt::Long;
  38.  
  39. use POSIX ('ceil', 'floor');
  40. use feature qw(switch say);
  41. use Cwd;
  42. use Cwd 'abs_path';
  43.  
  44. use Statistics::Basic qw(:all);
  45. use File::Copy;
  46. #use Imager::Screenshot 'screenshot';
  47. use Data::Dumper;
  48. use Tk::Pane;
  49. use File::Basename;
  50. use File::Compare;
  51. use File::Path;
  52.  
  53. use List::Util qw/ max min /;
  54. use List::MoreUtils qw( minmax );
  55.  
  56. #use Tk::Animation;
  57. #use Tk::Splashscreen;
  58.  
  59. # PRAY modules
  60. use lib dirname(__FILE__) . '/lib';
  61. use lib 'lib';
  62. use Model;
  63. use commons;
  64. use version;
  65. use codes;
  66.  
  67. ########################################################################
  68. # Start user documentation
  69. # - Requirements, installation, running program
  70. ########
  71.  
  72. =USERhead1 NAME
  73.  
  74. PRay - a graphical user interface for plotting and editing rayinvr models
  75.  
  76.  PRay
  77.  l
  78.  o
  79.  t
  80.  
  81. =USERhead1 README
  82.  
  83. This is the user README for PRay.
  84.  
  85. Please read status messages and command line output. I've tried to display user relevant
  86. messages in status line of main window. But not everything important goes there, so
  87. it's wise to keep an eye to the command line output, especially if something goes wrong.
  88.  
  89. =USERhead2 Installation/Preparations
  90.  
  91. PRay is written in the script language Perl with Tk for graphical features.
  92. Therefore PRay does not need to be compiled but a couple of preparations
  93. are necessary.
  94.  
  95. =USERhead3 System requirements
  96.  
  97. Because I'm a lazy person I try to make use of existing programms when possible.
  98. Required software:
  99.  
  100. =over
  101.  
  102. =item perl/Tk
  103.  
  104. Perl and Tk graphics modules are necessary. PRay does not run without them.
  105. Perl is usually available by default on Unix-like systems but Tk and some other modules
  106. need to be added. See below for installation.
  107.  
  108. =item rayinvr
  109.  
  110. Working rayinvr/xrayinvr with dmplsqr is necessary for ray tracing and inversion.
  111. A slightly modified source code is provided in this package. PRay can run
  112. without rayinvr but of course traveltimes and ray paths cannot be calculated.
  113.  
  114. =item GMT (optional)
  115.  
  116. Some features require GMT-commands. It has been tested with GMT 4.5.6. Changes
  117. may become necessary for future GMT-versions. This applies for contours, gridding and the provided
  118. external plotting scripts.
  119.  
  120. =back
  121.  
  122. =USERhead3 Installation of Perl modules
  123.  
  124. =USERhead4 Installation as root
  125.  
  126. If you have root privileges and want to install perl modules systemwide,
  127. start the cpan shell
  128.  
  129.    sudo perl -MCPAN -e shell       # Start the cpan shell
  130.  
  131. =USERhead4 Installation as user
  132.  
  133. If you only want to install it for yourself or perl tries to install modules
  134. to a folder with no write permissions (eg in /opt/local/..), you need
  135. to change the target installation directory within the cpan-shell
  136. (before installing modules):
  137.  
  138.    perl -MCPAN -e shell            # Start the cpan shell
  139.    cpan> o conf mbuildpl_arg "--install_base $HOME/perl/"
  140.    cpan> o conf makepl_arg "PREFIX=$HOME/perl/"
  141.  
  142. UPDATE: the above method works with older perl installations  (error
  143. message: C<Only one of PREFIX or INSTALL_BASE can be given.  Not both.>).
  144. If so, you need to change the environment variable (e.g. for csh) before
  145. starting the CPAN shell:
  146.  
  147.    setenv PERL_MB_OPT '--install_base "$HOME/perl5"'
  148.    setenv PERL_MM_OPT INSTALL_BASE=$HOME/perl5
  149.  
  150.    perl -MCPAN -e shell
  151.  
  152. =USERhead4 Install modules
  153.  
  154.    cpan> install modulname
  155.  
  156. e.g.:
  157.  
  158.    cpan> install Tk
  159.    cpan> install Graphics::ColorUtils
  160.    cpan> install Number::Format
  161.    cpan> install List::MoreUtils
  162.    cpan> install Statistics::Basic
  163.    cpan> install Tk::Splashscreen.pm
  164.    ..
  165.  
  166. (list might not be complete, check error output)
  167.  
  168. Experience has shown that force is needed to install those two modules. So use
  169.  
  170.    cpan> force install Tk
  171.    cpan> force install Graphics::ColorUtils
  172.  
  173.  
  174.  
  175. =USERhead3 Setting your environment
  176.  
  177. - Include C<PRay>-directory in your executable path
  178.  
  179. - Set C<PERL5LIB> to your perl module and library directorys
  180.  
  181. tcsh:
  182.  
  183.    setenv PERL5LIB /your/path/to/pm/
  184.  
  185. eg.:
  186.  
  187.    setenv PATH ${PATH}:$HOME/pray
  188.    setenv PERL5LIB $HOME/perl/lib64/perl5/
  189.    setenv PERL5LIB ${PERL5LIB}:$HOME/perl/share/perl5
  190.    setenv PERL5LIB ${PERL5LIB}:$HOME/pray
  191.  
  192. bash:
  193.  
  194. #    export PERL5LIB=/your/path/to/pm/
  195.  
  196.     export PERL5LIB=/usr/lib64/perl15/vendor_perl/Tk.pm
  197.    
  198. =USERhead3 Running C<PRay>
  199.  
  200. Use a command line and type
  201.  
  202.    p.pl
  203.  
  204. in the same directory where you keep your model C<v.in> and C<r.in>.
  205.  
  206.  
  207. =head3 Errors
  208.  
  209. Have you run into problems? The most common problem are missing modules indicated by
  210. following error message:
  211.  
  212. Can't locate Tk.pm in @INC (@INC contains: /projects//nam2011/bin/ ... )
  213.  at /projects//nam2011/bin/pray/p.pl line 15.
  214.  BEGIN failed--compilation aborted at /projects//nam2011/bin/pray/p.pl line 15.
  215.  
  216. In this case the module C<Tk.pm> is missing (first sentence) and cannot be
  217. found in the listed directories (C< @INC contains: dir1 dir2 .. >)
  218. Your either have not (successfully) installed the perl modules or the
  219. module location is not in the C<@INC> list.
  220. Use above description to install the mentioned module and make sure
  221. that the directories containing your newly installed
  222. modules and PRays module files e.g. C<model.pm> is included in this
  223. path. If not, add that directory to C<PERL5LIB> environment variable.
  224.  
  225. If you don't know, where your newly installed perl-modules are, look for
  226. them, e.g. in the cpan shell:
  227.  
  228. cpan[1]> i Tk
  229. CPAN: Storable loaded ok (v2.41)
  230. Reading '/Users/tfromm/.cpan/Metadata'
  231.  Database was generated on Wed, 19 Aug 2015 12:53:29 GMT
  232. CPAN: YAML loaded ok (v1.15)
  233. CPAN: Time::HiRes loaded ok (v1.9725)
  234. Reading 8 yaml files from /Users/tfromm/.cpan/build/
  235. .........................................................DONE
  236. Restored the state of none (in 0.4535 secs)
  237. Module id = Tk
  238.    DESCRIPTION  a graphical user interface toolkit for Perl
  239.    CPAN_USERID  TKML (The Tk Perl Mailing list <[email protected]>)
  240.    CPAN_VERSION 804.033
  241.    CPAN_FILE    S/SR/SREZIC/Tk-804.033.tar.gz
  242.    UPLOAD_DATE  2015-02-21
  243.    DSLIP_STATUS bmcOo (beta,mailing-list,C,object-oriented,open-source)
  244.    MANPAGE      Tk - a graphical user interface toolkit for Perl
  245.    INST_FILE    /Library/Perl/5.18/darwin-thread-multi-2level/Tk.pm
  246.    INST_VERSION 804.033
  247.  
  248. or with C< find / -name "Tk.pm" > or use  C< instmodsh >
  249.  
  250.  
  251. You can check the content of Perls C<@INC>-variable with following command:
  252.  
  253. perl -V
  254.  
  255. Another error message:
  256.  
  257. 1dyld: lazy symbol binding failed: Symbol not found: _Perl_sv_utf8_upgrade_flags
  258.   Referenced from: /Library//Perl/5.10.0/darwin-thread-multi-2level//auto/Tk/Tk.bundle
  259.   Expected in: flat namespace
  260.  
  261. dyld: Symbol not found: _Perl_sv_utf8_upgrade_flags
  262.   Referenced from: /Library//Perl/5.10.0/darwin-thread-multi-2level//auto/Tk/Tk.bundle
  263.   Expected in: flat namespace
  264.  
  265. Trace/BPT trap
  266.  
  267. This happens when Tk was not installed with the perl version you are using. In this case
  268. perl was version 5.12 but Tk was installed with perl 5.10. Make sure you are using the same
  269. perl version, that was used in for the Tk installation with either changing your
  270. C<$PATH>-variable or install Tk with the current perl version.
  271.  
  272. =USERhead3 rayinvr-Settings
  273.  
  274. Following parameter must be set in rayinvrs C<r.in> to create output needed by PRay:
  275.  
  276.    iplot = 0
  277.    idump = 1
  278.    itxout = 3
  279. #    ray = ivray         # Not literally, but they should have the same length
  280.    ray = 1.2, 1.3, ...
  281.    ivray = 12, 13, ...
  282.    raysl=1
  283.  
  284. PRay automatically checks iplot, idump and itxout. But you
  285. need to set the 'ray' and 'ivray' arrays yourself.  
  286.  
  287. =over
  288.  
  289. =item *
  290.  
  291. Setting 'ray' and 'ivray':
  292. Please be aware that
  293. using the same phasecode (ivray) for different rays leads to confusions
  294. in the displayed output (but it does work and might be easier for modelling).
  295. PRay uses the phases (ivray) associated with raycodes (ray) from r.in.
  296.  
  297. ray = 1.1, 2.1, 2.2, 3.2, 4.3
  298. ivray = 1,   1,   2,   3,   4
  299.  
  300. That means that rays 1.1 and 2.1 use the same phase (1). So the
  301. theoretical arrivals for 1.1 and 2.1 get the phasecode 1 in tx.out.
  302. There is no way to distinguish them without a lot of extra
  303. calculations and the picks will be displayed for only one raycode.
  304.  
  305. =item *
  306.  
  307. C<iplot> can be C<1>, but then you'll have a rayinvr display popping up
  308. every time you run rayinvr. A quick switch is include in the graphical editor
  309. for r.in
  310.  
  311. =item *
  312.  
  313. txout can be 2 or 3. Make sure, output is generated in tx.out. Sometimes
  314. you need to switch between 2 and 3 without an obvious reason.
  315.  
  316.  
  317. =back
  318.  
  319. =USERhead2 Installation done
  320.  
  321. You should now have a working PRay. You can try out the rayinvr model examples
  322. provided in the C<rayinvr/examples> directory (be aware that not all rayinvr
  323. functions are included in PRay). There's more documentation about the feature
  324. usage in C<docs/>.
  325. Need help?
  326. Improvements for the installation instruction?
  327. Interested in joining the project?
  328.  
  329. Please drop me a mail.
  330.  
  331. =cut
  332.  
  333. ######################################################################
  334. # Programmers documentation
  335. #######
  336.  
  337. =PROGhead1 NAME p.pl
  338.  
  339. PRay - programmers documentation
  340.  
  341. This is the programmers documentation. It's written as embeded POD inside the source
  342. code to simplify documentation for programmers. Unfortunately this has some drawbacks for
  343. users. First: it's not just a textfile you can simply edit and update. Second: Explainations
  344. are sorted as in source and not content related.
  345. Sorry for this inconvenience.
  346.  
  347. =PROGhead2 Subroutine naming
  348.  
  349. Name       Comment
  350. i_..       initialization routines
  351.  
  352. b_..       associated with buttons or menubar
  353.  
  354. m_..       associated with modelspace
  355. t_..       associated with timespace
  356.  
  357.  
  358. =cut
  359.  
  360.  
  361. ######################################################################
  362. # Global Variables
  363. #######
  364. GLOBAL:
  365. my $PRAYPATH = dirname(abs_path($0));
  366. my $ICONS = "$PRAYPATH/icons";
  367.  
  368. # Programmers switches
  369. my $tree      = 0;
  370. my $debug     = 0;
  371. my $dev       = 0;
  372.  
  373. # User switches
  374. my $verbose   = 0;
  375. my $quiet     = 0;
  376. my $EXPORT    = 0;
  377.  
  378. GetOptions(
  379.    'tree|t'    => \$tree,
  380.    'debug|d'   => \$debug,
  381.    'dev'       => \$dev,
  382.    'verbose|v' => \$verbose,
  383.    'quiet|q'   => \$quiet,
  384.    'export|e'  => \$EXPORT,
  385.    );
  386.    
  387. my %DEBUG = (tree => $tree, debug =>  $debug, dev => $dev,
  388.    verbose => $verbose, quiet => $quiet);
  389.  
  390. print "(I) echoing subroutines enabled\n" if $tree;
  391. print "(I) debugging infos enabled\n" if $debug;
  392. print "(I) developer infos enabled\n" if $dev;
  393. print "(I) Printing more user information\n" if $verbose;
  394. print "(I) Reduced program verbosity\n" if $quiet;
  395.  
  396. =PROGpod
  397.  
  398. Control verbosity.
  399.  
  400. GetOptions(
  401.    'tree|t'    => \$tree,
  402.    'debug|d'   => \$debug,
  403.    'dev'       => \$dev,
  404.    'verbose|v' => \$verbose,
  405.    'quiet|q'   => \$quiet,
  406.    'export|e'  => \$EXPORT,
  407.    );
  408.    
  409. my %DEBUG = (tree => $tree, debug =>  $debug, dev => $dev,
  410.    verbose => $verbose, quiet => $quiet);
  411.  
  412. There are five levels of verbosity of the program for debugging.
  413. Those variables are passed to the modules.
  414.  
  415. =cut
  416.  
  417. =USERhead3 Verbosity
  418.  
  419. Verbosity can be controlled with command line switches
  420.  
  421. -t [--tree]    print subroutine names (usefull for programmers)
  422. -d [--debug]   print debug messages (usefull for programmers)
  423.    [--dev]     print development messages (usefull for programmers)
  424. -v [--verbose] be more verbose (for users)
  425. -q [--quiet]   be quiet, only important messages are printed (for users)
  426.  
  427. =cut
  428.  
  429.  
  430. print
  431. "######################################################################\n"
  432. ."# Starting PRay                                                      #\n"
  433. ."# a Plotting programm for RAYinvr                                    #\n"
  434. ."######################################################################\n" unless $quiet;
  435.  
  436. my $DIR = cwd();
  437. my $PROG = "PRay";
  438. print "Working in directory: $DIR\n" unless $quiet;
  439.  
  440.  
  441.  
  442. my $INITMSG = "";               # Collect messages during startup and display once GUI has started
  443.  
  444. ######################################################################
  445. # DEFAULT CONFIGURATION
  446. my $file;    # File for zp2ray. This is not nice but quick and dirty. See in b_zp2ray for usage
  447. my %CONFIG;
  448. my %CONFIGDOC;
  449. my %STATUS;    # Store status information from p.status (!!! NOT COMPLETELY IMPLEMENTED !!!)
  450. $STATUS{PRayVersion} = '1970-01-01';    
  451. # Set PRayVersion to default date. That means, that update messages
  452. # for new PRay versions are displayed.
  453. # A new PRay version is set, if stored in config file.
  454.  
  455. ######################################################################
  456. # Get initial configuration from r.in and overwrite default %CONFIG
  457.  
  458. # Check if a rayinvr model is present
  459. unless (-f "r.in" ) {
  460.  
  461.     my $dw = new MainWindow();
  462.    my $text = "Can't find a rayinvr model\nCreate simple start model?";
  463.     my $title = "Create simple start model?";
  464.    my $m =   $dw->Dialog(-popover => $dw,
  465.                -title => $title,
  466.                -text => $text,
  467.                -buttons => ['Yes', 'No']
  468.                );
  469.  
  470.    if ($m->Show eq "Yes") {
  471.        i_createModel();
  472.    }
  473.    $dw->destroy;
  474. }
  475.  
  476. my $RIN = commons::readRin();
  477. #$CONFIG{rin}=$RIN;
  478. i_ConfigInit(); # Also replaces CONFIG with rin values
  479.  
  480. # Overwrite r.in and default values with user defined values
  481. my $CONFIGFILE = "p.config";
  482. i_ConfigRead($CONFIGFILE);
  483.  
  484.  
  485. =PROGhead2 Initialization process
  486.  
  487. =PROGhead2 Used subs
  488.  
  489. i_ConfigRead()
  490.  
  491. =cut
  492.  
  493. =PROGhead3 Phasecodes
  494.    
  495. Phasecodes are read from r.in
  496.  
  497. my $CODES = new codes( 'phasecodes' => $RIN->{ivray}, 'raycodes' => $RIN->{ray});
  498.  
  499. =cut
  500.  
  501. my @ADDITIONALPHASES = split /\s+/, $CONFIG{additionalPhases}  if ( $CONFIG{additionalPhases} );
  502. my @ADDITIONALCOLORS = split /\s+/, $CONFIG{additionalPhaseColors}   if ( $CONFIG{additionalPhaseColors} );
  503.  
  504. my $CODES = new codes( 'phasecodes' => $RIN->{ivray}, 'raycodes' => $RIN->{ray}, 'debug' => \%DEBUG);
  505. my %PHASECOLORS;
  506. my @REFLECTED;
  507. my @REFRACTED;
  508. my @HEAD;
  509. i_Colors();
  510. #################################
  511.  
  512. my %RAYSTATUS;     # Stores status of checkbuttons for rayphase-switching
  513. my %stationlist;        # Hash of Arrays. Used for listbox to select
  514.                        # single station used for zp or other programs
  515.                        # for only one station    
  516.                        # $stationlist{"$obs"} =
  517.                        #  ["OBS $obs", "100st$obs.h.ent.head", "zp.par",0, $km];
  518.                        # Array contains:
  519.                        #  0 Stationlabel
  520.                        #  1 zp-file
  521.                        #  2 zp-parameterfile
  522.                        #  3 flag for drawing rays and times
  523.                        #  4 Profilekm. Important for OOP
  524. my $station="136";      # Selected station to use for zp
  525.  
  526. my @DRAWNSTATIONS;
  527. my @DRAWNRAYS = ("5.1");# Save initial drawnRays for model
  528. my @DRAWNPHASES = (51); # Save initial drawnPhases for model
  529.  
  530. # DRAWNRAYS and PHASES might be unneccessary. %RAYSTATUS combines values
  531. # for both of them.
  532.  
  533. my $profilelength = $CONFIG{xmax}-$CONFIG{xmin};
  534. my $totaldepth = abs($CONFIG{zmin})+abs($CONFIG{zmax});
  535.  
  536. #print
  537.    ##"Profile is $profilelength km long. ".
  538.    #"Extending from $CONFIG{xmin} to $CONFIG{xmax}\n";
  539.  
  540.  
  541. ####################################################################################
  542. # GUI Varibles
  543. my $canvaswidth = $CONFIG{screenwidth};            # Width of cavas for time and model
  544. my $canvasheigth = ($CONFIG{screenheight}-200)/2;  # Heigth of cavas for time and model    
  545. my $box = [0, 0, $canvaswidth, $canvasheigth];     # Size of model and runtimediagram in px
  546. my $zoomRect;                   # Variables for zooming in model
  547. my $zoomRectzeit;               # and runtimediagram
  548. my @zoomRectCoords;             # Holds coordinates for zooming
  549. my $oldx = 0;                   # buffer for old node coordinates
  550. my $oldy = 0;                   # buffer for old node coordinates
  551. my $initx = 0;                  # Save initial node position
  552. my $inity = 0;                  # Save initial node position
  553. my @drawnAxes;
  554. my $yscale  = $box->[3]/($totaldepth);
  555. my $ytscale = $box->[3]/($CONFIG{tmax} - $CONFIG{tmin});    # Scalefactor for TT-diagramm
  556. #my $xscale  = $box->[2]/$CONFIG{xmax};
  557. my $xscale  = $box->[2]/$profilelength;
  558. my $zoomhistory = [];           # keep zoomboxes for later unzooming
  559. #print "Initialzoom yscales in ZoomOriginal: $yscale\n";
  560.  
  561. my $vredbutton = 1;
  562. my $allRaysButton = 0;          # Draw all available rays
  563. my $allRflButton = 0;           # Draw all reflections
  564. my $allRfrButton = 0;           # Draw all refractions
  565. my $allMulButton = 0;           # Draw all Multiples
  566. my $showBlocks = 0;             # show rayinvr blocks?
  567. my $showNodes = 1;              # Editing nodes?
  568. my $showVNodes = 0;             # Editing velocity nodes?
  569. my $annotVNodes = 1;            # Label velocity nodes?
  570. my $showGrid = -1;              # Show velocity gradient
  571. my $showTomoGrid = -1;          # Show velocity gradient
  572. my $showTomoContours = -1;      # Show velocity gradient with contourlines
  573. my $showContours = 0;           # Show contourlines
  574. my $contourcolor = 0;           # Contourlines in colors (1) or grey (0)
  575. my $showStreamer = 0;           # Show stremaer picks
  576. my $glueNodes = 0;
  577. my $PicksManButton = 1;
  578. my $PicksCalButton = 1;
  579. my $ShowRaysButton = 1;
  580. my $selectedNodes = 0;          # Flag for selecting nodes. Used in m_B1node
  581. my ($startnode, $endnode);      # Save start and end nodes for toggling
  582. my $editNode = "";              # Save type of edit you want to do to nodes
  583. my $movenode = 0;               # Flag for moving node
  584. my $RMS = 0;                    # Flag for measuring rms velocity in traveltime canvas
  585.  
  586. my $VERSION = -1;               # Historyindex for undo
  587. my @markedmodels = ();          # Save all version numbers for marked models
  588. my $depthvelocityprofiles = "10,120,300,460"; # default km for extracting velocity profiles
  589.  
  590.  
  591. my @choosePicks = ();           # Flag for choosing picks to change phase, and place to store the chosen
  592.                                # picks
  593. my %COMMENTS;                   # Save comments for model versions
  594. my $commentfile = 'comments.txt'; # filename of commentfile
  595.  
  596. =PROGpod
  597.  
  598. i_ReadStatus()
  599. i_Comments()
  600.  
  601. =cut
  602.  
  603. i_ReadStatus();
  604. i_Comments();
  605.  
  606. if ($VERSION == -1 ) {
  607.    $VERSION = 1;
  608.    _historyAdd();
  609.    $VERSION = 1;
  610. }
  611.  
  612.  
  613. #$VERSION = _GetVersionNumber();    # Historyindex for undo
  614. ###################################
  615. # Define GUI
  616. #######
  617. GUIDEFINITION:
  618. my $mw = new MainWindow();
  619. _setWindowTitle();
  620.  
  621. i_checkPRayVersion();
  622.  
  623.    
  624. my $balloon = $mw->Balloon(-background => "yellow");
  625. # Making right click popup menu.
  626. # Commands are added, when clicking on an object, so it gets information about it
  627. my $menuRightClick = $mw->Menu(-tearoff => 0);
  628.  
  629. #######
  630. # Create runtimediagram region
  631. my $lzd = $mw -> Canvas(-confine=> 1, -relief=>"sunken", -background=>"#F1F1F1",
  632.     -width=> $canvaswidth, -height => $canvasheigth, -scrollregion => $box);
  633. $lzd -> pack(-side=>'bottom');
  634. $lzd->createRectangle(0, 0, $canvaswidth, $canvasheigth, -fill => $CONFIG{ttbg}, tags=>['background']);
  635.  
  636. #######
  637. # Create model region
  638. my $cns = $mw -> Canvas(-confine=> 1, -relief=>"sunken",
  639.     -width=> $canvaswidth, -height => $canvasheigth, -scrollregion => $box);
  640. $cns -> pack( -side=>'bottom');
  641. $cns->createRectangle(0, 0, $canvaswidth, $canvasheigth, -fill => $CONFIG{modelbg}, tags=>['background','off model limits']);
  642.  
  643. i_BindSpace(); # Display info for stations, layers, .. Move nodes
  644. i_BindTime();
  645.  
  646. # Status line as Read-Only text
  647. my $stline = $mw->Scrolled ("ROText", -scrollbars => 'w')
  648.     -> pack ( -side => 'bottom', -expand => 1, -fill => 'both', -before => $lzd);
  649. $stline->insert ('end', "Status Messages");
  650. $stline->configure(-height => 2);
  651.  
  652. ##################################################
  653. # CREATE MODEL
  654. MODEL:
  655. my $model = new model('space'=> $cns, "time" => $lzd, "statusline" => $stline,
  656.             "mainwindow" => $mw, "icons" => $ICONS,
  657.             "balloon" => $balloon,
  658.             #"profilelength" => $profilelength,
  659.             "zmin" => $CONFIG{zmin}, "zmax" => $CONFIG{zmax},
  660.             "tmin" => $CONFIG{tmin}, "tmax" => $CONFIG{tmax},
  661.             "yscale" => $yscale, "ytscale" => $ytscale, "xscale" => $xscale,
  662.             "phasecolors" => \%PHASECOLORS,
  663.             "config" => \%CONFIG, "debug" => \%DEBUG, "rin" => $RIN,
  664.             "glueNodes" => $glueNodes, "contourcolor" => $contourcolor,
  665.             #"phasecodes" => $PHASECODES, "raycode" => $RAYCODES,
  666.             "drawnRays" => \@DRAWNRAYS, "drawnPhases" => \@DRAWNPHASES,
  667.             "codes" => $CODES,
  668.             "version" => $VERSION);
  669.  
  670.  
  671. =PROGpod
  672.  
  673. new Model()
  674. i_MenuBar();
  675. i_AddStations(); # Needs to stay here, until all buttons are included in model
  676.  
  677. =cut
  678.  
  679.  
  680. i_MenuBar();
  681. i_AddStations(); # Needs to stay here, until all buttons are included in model
  682.  
  683. my $r = $model->init("splash" => $CONFIG{splash}); # Reads v.in, rays and times
  684.         # Cannot be run with $model->new() because stations need to be defined
  685.  
  686. #if ($r ) {
  687. #_printStatusMessage("\n$r");
  688. #}
  689.  
  690. #$model->get('1d');
  691. #exit;
  692.  
  693. EXPORT:
  694.  if ( $EXPORT ){
  695.     print "Export rays&picks to $CONFIG{exportpath} and quit\n";
  696.     # copy r.export to r.in, run rayinvr and then export stuff
  697.     #copy ("r.in", "r.tmp");
  698.     #copy ("r.export", "r.in");
  699.     #b_rayinvr();
  700.     b_export();
  701.     #copy ("r.tmp", "r.in");
  702.     #unlink("r.tmp");    # delete temporary r.in
  703.     die;
  704. }
  705.  
  706. =PROGpod
  707.  
  708. i_DrawButtons(); # Needs to be after i_AddStations
  709. b_drawAll();
  710.  
  711. =cut
  712.  
  713.  
  714. i_DrawButtons(); # Needs to be after i_AddStations
  715. b_drawAll();
  716.  
  717. #$model->writeVin;
  718. #exit
  719. my ($id) = (q '$Id: p.pl 17 2016-10-18 13:10:13Z tafro $' );
  720.  
  721. print " $id \n";
  722.  
  723. print
  724. "
  725. #############################################
  726. # Program initialized. Using                #
  727. # $id  #
  728. # Enjoy.                                    #
  729. #############################################
  730. " unless $quiet;
  731.  
  732.  
  733. # Check rayinvr if no p.config is present
  734. unless (-f "p.status" ) {
  735.     my $t =
  736. "You seem to run PRay for the first time. Do you want me to check your
  737. r.in file and fix settings according to my needs?";
  738.  
  739.     my $m =   $mw->Dialog(-popover => $mw,
  740.                 -title => "Check r.in?",
  741.                 -text => $t,
  742.                 -buttons => ['Yes', 'No']
  743.                 );
  744.  
  745.     if ($m->Show eq "Yes") {
  746.         commons::checkRin($RIN);
  747.     }
  748. }
  749.  
  750.  
  751. #$mw->focusFollowsMouse();
  752. $cns->Tk::focus;
  753.  
  754.  
  755. #$model->_readContours;
  756.  
  757. #print "No printing to Status messages:\n $INITMSG\n";
  758. _printStatusMessage($INITMSG);
  759.  
  760. #$model->status('range' => [185, 410]);
  761. # For testing
  762. #b_resolution();
  763. #b_export();
  764. #b_igmas();
  765. #$model->exportPolygons();
  766. #exit;
  767. $mw->deiconify();
  768.  
  769.  
  770. ###########################################################################
  771. # MainLoop
  772. ###########################################################################
  773. MAINLOOP:
  774. MainLoop;
  775.  
  776.  
  777. =PROGhead2 Basic procedures
  778.  
  779. =head3 Configuration
  780.  
  781. Define configuration values in C<sub i_ConfigInit>. E.g:
  782.  
  783.  $CONFIG{exportpath} = "./data"; $CONFIGDOC{exportpath} =
  784.  'Default: ./data
  785. Outputpath for exporting rays and times in GMT format
  786. (Menu->Export rays&picks)';
  787.  
  788. Use the configured value with the global variable C<$CONFIG{parameter}>.
  789. The variable C<$CONFIGDOC> stores the text for the popup menu in the graphical
  790. editor.
  791. To include a config-parameter in the graphical editor add the new parameter name
  792. in C<sub b_configEdit>
  793.  
  794. You can call the parameter with C<< $model->getConfig('parameter') >>.
  795.  
  796.  
  797. =head3 Drawings
  798.  
  799.  b_drawAll()    # extracts current enabled phases and stations
  800.     $model->drawPhaseStationList("phases" => [@DRAWNPHASES], "stations" => [@stationlist])
  801.  
  802.  b_drawPhase    called from 'Phasebutton'
  803.  b_drawStation  called from 'Stationbutton'
  804.  
  805.  
  806. =head3 Tags
  807.  
  808. Tags are the key to interact with the drawn objects and to hand over
  809. information between the object and further processing.
  810.  
  811.  Layer:
  812.     my $msg = sprintf("B %s, average velocities: v = %6.2f km/s, v_up = %6.2f km/s, v_low %6.2f km/s",
  813.                 $self->{number}, $self->{vav}, $self->{vuav}, $self->{vlav});
  814.     'LAYER', "B$self->{number}", "$msg"
  815.  
  816.  Boundary (no interaction):
  817.     'BOUND', "BOUND$number"
  818.    
  819.  Nodes:
  820.     'NODE', "$self->{number}", "$i", "N$self->{number}"
  821.     $self->{number} = Layer number
  822.     i = index position in node array
  823.  
  824.  Station:
  825.     "STATION", "$station->{name}", "$station->{position}", "$station->{depth}"
  826.  
  827.  Ray:
  828.     'RAYS'.$station->{name}, "Ph$phase",'RAYS'
  829.  
  830.  TT caluclated/picked:
  831.     "PICK", 'RAYS'.$station->{name}, "Ph$phase","km$km t$t unc$unc offset$off", $key
  832.     when drawn as dash, cross or circle
  833.     OR:
  834.     "PICK", 'RAYS'.$station->{name}, "Ph$phase", "$key"
  835.     when drawn as line
  836.     key = txin, txout, txTomo
  837.  
  838.  AXES (no interaction):
  839.     'AXES'
  840.  
  841.  
  842. =head3 Modeling
  843.  
  844.  b_rayinvr> run rayinvr
  845.   $model->read( "vin", "rays", "times" )
  846.  b_drawAll()
  847.  
  848.  b_writeModel
  849.     _historyAdd()
  850.     $model->writeVin;
  851.     $model->set("version" => $VERSION)
  852.     b_rayinvr();
  853.     _setWindowTitle()
  854.  
  855. =cut
  856.  
  857.  
  858.  
  859. ###########################################################################
  860. # Defining subs
  861. ###########################################################################
  862.  
  863. sub i_AddStations {
  864.  
  865. =PROGhead2 C<i_AddStations()>
  866.  
  867. Reads C<$CONFIG{stationfile}> and initializes stations. Stations with
  868. zpfiles are added to C<stationlist>.
  869.  
  870. =cut
  871.  
  872.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  873.     ##############
  874.     # Add stations
  875.     my $file = $CONFIG{stationfile};
  876.    
  877.     # ADD STATIONS FROM R.IN
  878.     if (! -e $file) {
  879.         ###### OLD ->
  880.         print "(D) WARNING: Stationfile $file does not exist\n" if $debug;
  881.             #"I'm reading r.in to create one\n";
  882.             #commons::createStatxz();
  883.         ###### OLD <-
  884.  
  885.         ###### NEW
  886.         # read from r.in
  887.         for ( my $i = 0;  $i <= $#{$RIN->{xshot}}; $i++) {
  888.             my $obs = sprintf("%3d", $i);
  889.             my $name = sprintf("%3d", $i);
  890.            
  891.             # Add to stationlist:
  892.             # keys of hashes are strings, so 12.4 is not equal to 12.40
  893.             my $km = sprintf("%.3f", $RIN->{xshot}[$i]);
  894.             my $depth = 0;
  895.             $depth = $RIN->{zshot}[$i]*1000 if ($RIN->{zshot}[$i]);
  896.            
  897.             my $switch = (grep {$_ eq $km} @DRAWNSTATIONS) ? 1 : 0; # 0 ist der schalter fuer an/aus
  898.    
  899.             #$stationlist{"$obs"} = [$name, $zpfile, $zppar, $switch, $km];
  900.             $stationlist{"$obs"} = [$name, '', '', $switch, $km];
  901.            
  902.             # Add station to model:
  903.             # zpfile is needed for changing pick-files
  904.             $model->addStation("name" => $obs, "position" => $km, "depth" => $depth);
  905.             print "(D) add station $obs, km $km, depth $depth to model\n" if $debug;
  906.         } # foreach xshot
  907.         return 0;
  908.     }
  909.    
  910.    
  911.     ###
  912.     # ADD FROM STATXZ
  913.     open (STATIONS, $file) or die "Can't open $file\n";
  914.     # stationname profilekm depth
  915.     # 100st105 422.15   96.4
  916.    
  917.     print "Reading stationpositions from $file\n" unless $quiet;
  918.     while (<STATIONS>){
  919.         chomp;
  920.         s/^\s+//;               # no leading white
  921.         s/\s+$//;               # no trailing white
  922.         s/#.*//;                # no comments
  923.         next unless length;     # anything left?
  924.  
  925.         my ($name, $km, $depth, $zpfile, $zppar) = split;
  926.         #print "Add station >$name, $km, $depth<\n";
  927.         (my $obs = $name);    # Keep only the last bit of 100st136
  928.         #(my $obs = $name) =~ s/\d.*st//;    # Keep only the last bit of 100st136
  929.  
  930.         #print "HEAD: $zpfile\n" if (defined $zpfile);
  931.         $zppar = "zp.par" unless (defined $zppar);
  932.  
  933.         if ( $CONFIG{zpFileMask} ){
  934.             ($zpfile =  $CONFIG{zpFileMask}) =~ s/\$obs/${obs}/g unless (defined $zpfile);
  935.         }
  936.         #print "Add $obs: Mask $CONFIG{zpFileMask} dir:$CONFIG{zpdir} file: $zpfile, par $zppar\n";
  937.  
  938.         # Add to stationlist:                                                        
  939.         # keys of hashes are strings, so 12.4 is not equal to 12.40
  940.         $km = sprintf("%.3f",$km);
  941.         my $switch = (grep {$_ eq $km} @DRAWNSTATIONS) ? 1 : 0; # 0 ist der schalter fuer an/aus
  942.         $stationlist{"$obs"} = [$name, $zpfile, $zppar, $switch, $km];
  943.        
  944.         # Add station to model:
  945.         # zpfile is needed for changing pick-files
  946.         $model->addStation("name" => $obs, "position" => $km, "depth" => $depth, "zpfile" => $zpfile);
  947.  
  948.     }
  949.     close(STATIONS);
  950.  
  951. =USERhead3 statxz
  952.  
  953. This file contains information about stationnames, positions and zpfiles.
  954. It is necessary if you want to address your stations with stationnames.
  955. If PRay cannot find this file it will create one from your r.in. Users may change the
  956. station labels there to suit there own naming.
  957.  
  958. Additional information about C<zp> parameter can be given in this file.
  959. Columns contain:
  960.  
  961.  Stationname    profilekm shotdepth(m) [ZP-Headfile] [zp-parfile]
  962.  
  963. zp specific columns are optional if diverge from zp filemask (given in C<config>) or zp.par
  964.  
  965. You can create a statxz-file by the command C<rin.pl -statxz>. This helper-tool is included
  966. in the PRay-directory. It reads in your r.in
  967. file and writes out a statxz-file with numbered xshot and zshot.
  968. You can then manually change the names according to your stations.
  969.  
  970. All stations in this file are used by PRay when reading traced rays,
  971. creating the station selectors and zp menu. If you have a station traced
  972. that is not in your statxz-file PRay will not know what to do and where to display it.
  973.  
  974. =cut
  975.  
  976. }
  977.  
  978. sub i_BindSpace {
  979.  
  980. =PROGhead2 C<i_BindSpace>
  981.  
  982. Defines interactions with model diagram.
  983.  
  984. =cut
  985.  
  986.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  987.  
  988.     # Make Model zoomable
  989.     $cns->CanvasBind('<z><1>'                => [\&zoomCanvasInit,"m"]);
  990.     $cns->CanvasBind('<z><B1-Motion>'        => [\&zoomCanvasSize,"m"]);
  991.     $cns->CanvasBind('<z><B1-ButtonRelease>' => [\&zoomCanvasFinish,"m"]);
  992.     $cns->CanvasBind('<Double-1>'            => \&zoomOriginal);
  993.     $cns->CanvasBind('<o>'                   => \&zoomOut);
  994.     $cns->CanvasBind('<i>'                   => \&zoomIn);
  995.    
  996.     # Measure
  997.     $cns->CanvasBind('<1>'                   => [\&m_B1]);
  998.     $cns->CanvasBind('<B1-Motion>'           => [\&m_B1motion]);
  999.     $cns->CanvasBind('<B1-ButtonRelease>'    => [\&m_B1release]);
  1000.    
  1001.     # Edit Nodes
  1002.     $cns->bind('NODE'    => '<1>'            => \&m_B1node);
  1003.     $cns->bind('VNODE'   => '<1>'            => \&m_B1node);
  1004.     $cns->bind('NODE'    => '<B1-Motion>'    => \&m_B1nodemotion);
  1005.    
  1006.     # Popupmenu
  1007.     $cns->bind('LAYER'   => '<3>'            => [\&m_B3menu, Ev('x'), Ev('y')]);
  1008.     $cns->bind('BOUND'   => '<3>'            => [\&m_B3menu, Ev('x'), Ev('y')]);
  1009.     $cns->bind('NODE'    => '<3>'            => [\&m_B3menu, Ev('x'), Ev('y')]);
  1010.     $cns->bind('VNODE'   => '<3>'            => [\&m_B3menu, Ev('x'), Ev('y')]);
  1011.     $cns->bind('STATION' => '<3>'            => [\&m_B3menu, Ev('x'), Ev('y')]);
  1012.          
  1013.     # Pipi
  1014.     $cns->bind('SUN'     => '<1>'            => \&b_help);
  1015.  
  1016. =USERhead2 Features
  1017.  
  1018. =USERhead3 Interactions with model diagram
  1019.  
  1020. Several features are associated with mouse clicks on the model diagram.
  1021.  
  1022. =USERhead4 Zooming in model diagram
  1023.  
  1024. Key C<z> and left mouse click initiate a zooming rectangle. Keep keys pressed
  1025. and move mouse to select model area for zooming. Double left click in model
  1026. area resets view to original size.
  1027.  
  1028.  
  1029. =USERhead3 Pinched layers
  1030.  
  1031. Layers may be pinched together using right click menu on a boundary or layer.
  1032. To move overlaid nodes enable the 'magnet'-button. If moving nodes all other layers are check
  1033. for identical nodes so the whole program might become slower. Enable this switch only if you
  1034. need to move several identical nodes.
  1035.  
  1036. =cut
  1037.  
  1038.  
  1039. }
  1040.  
  1041. sub m_B1 {    # Draw line, display coords      
  1042.     my $canvas = shift;
  1043.     #my ($oldkm, $oldd) = @_;
  1044.    
  1045.     # Show current coordinates, give layer information, ..
  1046.     my $x = $cns->canvasx($Tk::event->x);
  1047.     my $y = $cns->canvasy($Tk::event->y);
  1048.    
  1049.     $oldx = $x;
  1050.     $oldy = $y;
  1051.  
  1052.     my ($oldkm, $oldd) = $model->screen2model([$x, $y], "space");
  1053.     #my $msg = sprintf ("\nx = %6.2fkm, z = %4.2fkm",
  1054.             #$oldkm, $oldd);
  1055.     #_printStatusMessage($msg);
  1056.     print "(DEV) Start measuring >$x,$y< from >$oldx,$oldy< = km $oldkm, $oldd\n" if $dev;
  1057.     $cns->Tk::focus;
  1058. };
  1059.  
  1060.  sub m_B1node {
  1061.  
  1062. =PROGhead2 m_B1node()
  1063.  
  1064. Function to select nodes defining a range for toggling/snapping. Called
  1065. when clicking on a node but has only effects if toggling was enabled by
  1066. node menu in m_selectNodes
  1067.  
  1068. =cut
  1069.  
  1070.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  1071.     # save old nodeposition
  1072.     #my ($x, $y) = ($Tk::event->x, $Tk::event->y);
  1073.    
  1074.      # Gives absolute screen coordinates
  1075.     my $x = $cns->canvasx($Tk::event->x);
  1076.     my $y = $cns->canvasy($Tk::event->y);
  1077.    
  1078.     $oldx = $x;
  1079.     $oldy = $y;
  1080.    
  1081.     $initx = $x;
  1082.     $inity = $y;
  1083.    
  1084.     $movenode = 1;
  1085.    
  1086.     # Moving nodes
  1087.     my $id      = $cns->find(qw/withtag current/);
  1088.     my @c = $cns->coords($id);
  1089.     my @tags = $cns->gettags($id);
  1090.     print "(DEV) Start move Node >$x,$y< from >$oldx,$oldy< tags: @tags from coords >@c<\n" if $dev;
  1091.    
  1092.     return unless ($selectedNodes !=0);  # return if no node is selected
  1093.     ############################
  1094.     # This is only needed when you want to choose nodes for toggling partial derivatives
  1095.    
  1096.     #my $id      = $cns->find(qw/withtag current/);
  1097.     #my @tags = $cns->gettags($id);
  1098.     #print "I'm >@tags<, id @$id\n" if $debug;
  1099.    
  1100.     if ($selectedNodes == 2 ) {
  1101.         # Two nodes are choosen. Now write the changes to model
  1102.        
  1103.         #print "Second node chosen\n" if $debug;
  1104.         $endnode = \@tags;
  1105.         $selectedNodes =0;
  1106.        
  1107.        
  1108.         # Check if both nodes belong to the same layer. If not return.
  1109.         if ($startnode->[1] != $endnode->[1]) {
  1110.             my $msg = "\nERROR: Start and end node belong to different layers. $startnode->[1] != $endnode->[1]. Abort operation!";
  1111.             print "$msg\n";
  1112.             _printStatusMessage($msg);
  1113.             $selectedNodes = 0;
  1114.             return;
  1115.         }
  1116.        
  1117.        
  1118.         print "Toggling between <@$startnode> and <@$endnode>\n"if $debug;
  1119.         _printStatusMessage(" to ".($endnode->[2]/2));
  1120.        
  1121.        
  1122.         # Ensure to go from smaller to larger value
  1123.         my ($start, $end);
  1124.        
  1125.         if ($tags[0] eq 'NODE') {
  1126.             $start    = $startnode->[2] < $endnode->[2] ? $startnode->[2]/2 : $endnode->[2]/2;
  1127.             $end      = $startnode->[2] > $endnode->[2] ? $startnode->[2]/2 : $endnode->[2]/2;
  1128.         } elsif ($tags[0] eq 'VNODE') {
  1129.             $start    = $startnode->[2] < $endnode->[2] ? $startnode->[2] : $endnode->[2];
  1130.             $end      = $startnode->[2] > $endnode->[2] ? $startnode->[2] : $endnode->[2];
  1131.         }
  1132.        
  1133.         #print "Edit Node = $editNode\n";
  1134.         if ( $editNode eq "toggle" ) {
  1135.             print "Toggling between nodes $start and $end\n" if $debug;
  1136.             # Loop through nodes in between start and endnode and toggle them
  1137.             for (my $i = $start; $i <= $end; $i++ ){
  1138.                 print "Toggling node $i\n" if $debug;
  1139.                 my @madetags = @$startnode;
  1140.                 if ($tags[0] eq 'NODE') {
  1141.                     $madetags[2] = $i*2;
  1142.                     $model->edit( "tags" => \@madetags , "op" => "edit");
  1143.                 } elsif ($tags[0] eq 'VNODE') {
  1144.                     print "Toggle vnode ";
  1145.                     $madetags[2] = $i;
  1146.                     $model->edit( "tags" => \@madetags , "op" => "togglePar");
  1147.                 }
  1148.             }
  1149.          # $editNode eq 'toggle'
  1150.         } elsif ($editNode =~ /snap.*/) {
  1151.             _printStatusMessage("\nSnap to $editNode");
  1152.             $model->edit( "tags" =>  $startnode, "end" => $endnode, "op" => $editNode);
  1153.         } elsif ($editNode =~ /edit/ && $tags[0] eq 'NODE') {
  1154.             # Nodes of a layer shall be edited
  1155.             # Get value of change
  1156.             my $change = 1; # Get change from user input
  1157.             my $mode = 'move';  # move or delete nodes?
  1158.            
  1159.             #########################
  1160.             # Create the dialog
  1161.             my $dia = $mw->Toplevel( #-popover => $mw,
  1162.                         -title => "$PROG: Change depth nodes",);                
  1163.        
  1164.             my $bframe    = $dia->Frame () -> pack(-side=>'left', -anchor => 'w', -fill => 'x', -expand => 'no');        
  1165.             my $modeframe = $dia->Frame () -> pack(-side=>'left', -anchor => 'n', -fill => 'none', -expand => 'no');        
  1166.  
  1167.             my $changeEntry = $bframe -> LabEntry ( -label => 'Amount of change ',
  1168.                     -labelPack    => [qw/-side left -anchor w -expand yes -fill both/],
  1169.                     -textvariable => \$change,
  1170.                     )-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
  1171.  
  1172.             my $text = $bframe -> ROText(-width => '30', -height => 4, -borderwidth => 0)
  1173.                 -> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
  1174.             $text->insert('end', "Move selected nodes or delete them");
  1175.        
  1176.             $bframe->Button(-text=>"Apply",
  1177.                 -command => sub {
  1178.  
  1179.                     #################
  1180.                     # Apply change                
  1181.                     # Get all nodes of this layer (this is necessary, because
  1182.                     # I don't know how to find the tags of a specific node)
  1183.                     # Node tags: 'NODE', '$layer', '$index*2', 'N $layer'
  1184.                     my $nodes = $tags[3];
  1185.                     print "Start moving nodes from $start to $end\n";
  1186.                     for (my $i = $start; $i <= $end; $i++ ){
  1187.                         my @ids = $cns->find('withtag', $nodes);    # Look for ids again, because
  1188.                         # nodes gets newly drawn, once the first node has been edited
  1189.                         #print "--------------------------------------\n";
  1190.                         #print "Moving node $i = $ids[$i] from @ids\n";
  1191.                         my $id      = $ids[$i];
  1192.                         my @tags = $cns->gettags($id);
  1193.                         my @coords  = $cns->coords($id);
  1194.                         @coords = $model->screen2model(\@coords, "space");
  1195.                         $coords[1]+=$change;
  1196.                         $coords[3]+=$change;
  1197.                        
  1198.                         #print "I'm here\n".
  1199.                              #"Node id $id "
  1200.                             #."with tags @tags "
  1201.                             #."wants to move to coords @coords\n";
  1202.                                                    
  1203.                         if ($mode eq 'del') {
  1204.                             @coords = ($end-$start+1);  # Gives number of nodes to delete
  1205.                             $model->edit("tags" => \@tags, "value" => \@coords, "op" => $mode);
  1206.                             $dia->destroy; return;
  1207.                         }
  1208.                         $model->edit("tags" => \@tags, "value" => \@coords, "op" => $mode);
  1209.                     }
  1210.                 }
  1211.                 , -width => 10)->pack(qw/-side left/);
  1212.             $bframe->Button(-text=>"Done", -command => sub { $dia->destroy; return}, -width => 10)->pack(qw/-side left /);
  1213.  
  1214.             $balloon->attach( $modeframe->Radiobutton(
  1215.                         -text => "move", -value => "move", -variable => \$mode,
  1216.                         )-> pack (-side=>'top', -anchor => 'w', -fill => 'none', -expand => 'no')
  1217.                 , -balloonmsg => "Move selected nodes $change");
  1218.                            
  1219.             $balloon->attach( $modeframe->Radiobutton(
  1220.                         -text => "delete", -value => "del", -variable => \$mode,                    
  1221.                         )-> pack (-side=>'top', -anchor => 'w', -fill => 'none', -expand => 'no')
  1222.                 , -balloonmsg => "Delete nodes from layer");
  1223.  
  1224.         }
  1225.     } # end of selectedNodes == 2
  1226.    
  1227.     if ($selectedNodes == 1 ) {
  1228.         print "--------------------------Node: Toggle partial derivatives\n" if $debug;
  1229.         print "First node chosen\n" if $debug;
  1230.         $startnode = \@tags;
  1231.         print "Choose second node!\n" if $debug;
  1232.         $selectedNodes =2;
  1233.         _printStatusMessage("\nToggling from ".($startnode->[2]/2));
  1234.     }
  1235.    
  1236.  
  1237.    
  1238. }
  1239.  
  1240. sub m_B1nodemotion {
  1241.     #printf "(T) %s(@_)\n", commons::whoami() if $tree;
  1242.     # Gives screen coordinates within visible window
  1243.     #my ($x, $y) = ($Tk::event->x, $Tk::event->y);
  1244.    
  1245.     # Gives absolute screen coordinates
  1246.     my ($x, $y) = ($cns->canvasx($Tk::event->x), $cns->canvasy($Tk::event->y));
  1247.    
  1248.     # Moving nodes
  1249.     my $id      = $cns->find(qw/withtag current/);
  1250.    
  1251.     print "(DEV) oldx,oldy >$oldx,$oldy<\n" if $dev;
  1252.     my @c = $cns->coords($id);
  1253.     my $newx = $x - $oldx;
  1254.     my $newy = $y - $oldy;
  1255.     $cns->move($id => $newx, $newy);
  1256.     $oldx = $x;
  1257.     $oldy = $y;
  1258.     $movenode = 1;
  1259.  
  1260.     print "(DEV) Node is moving, mouse: >$x,$y< from @c to >$newx,$newy<\n" if $dev;
  1261.     @c = $cns->coords($id);
  1262.     print "(DEV) new coords >@c<\n" if $dev;
  1263.  
  1264. }
  1265.  
  1266. sub m_B1motion {
  1267.    
  1268.     print "(DEV) B1 motion move node? >$movenode<\n" if $dev;
  1269.  
  1270.     # Draw line, display depth/length(km) of line
  1271.     # DO NOT DRAW LINE AND MEASURE if a node is mooving
  1272.     # or if we are zooming
  1273.     return if ($movenode == 1);
  1274.    
  1275.     # Look for a zoom rubber
  1276.     my $zoom = 0;
  1277.     $zoom = $cns->find('withtag','ZOOM');
  1278.     #print "(DEV) Is there a zoom rubber? $zoom\n" if $dev;
  1279.     return if ( $zoom );
  1280.    
  1281.     my @line = ($oldx, $oldy, $oldx, $oldy);
  1282.    
  1283.     $cns->createLine(@line, -fill => 'red', #-arrow => 'last',
  1284.         -tags => ['MEASURE']);
  1285.    
  1286.     my $x = $cns->canvasx($Tk::event->x);
  1287.     my $y = $cns->canvasy($Tk::event->y);
  1288.     my @coords = $cns->coords('MEASURE');
  1289.     $coords[2] = $x;
  1290.     $coords[3] = $y;
  1291.     $cns->coords('MEASURE', @coords);
  1292.     print "(DEV) Create line: @coords\n" if $dev;
  1293. }
  1294.  
  1295. sub m_B1release{
  1296.  
  1297. =PROGhead2 m_B1release()
  1298.  
  1299. Function is called if a click is released anywhere inside the model.
  1300. Function depending on what has happened before.
  1301.  
  1302. =cut
  1303.  
  1304.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  1305.     my $id      = $cns->find(qw/withtag current/);
  1306.     my @tags = $cns->gettags($id);
  1307.     #print "I'm >@tags<, id @$id\n";
  1308.    
  1309.     @tags = grep {$_ ne 'current'} @tags;
  1310.     my $msg = "";;
  1311.    
  1312.     my $x = $cns->canvasx($Tk::event->x);
  1313.     my $y = $cns->canvasy($Tk::event->y);
  1314.     my @coords = $model->screen2model([$x, $y], "space");
  1315.     $msg = sprintf("\n%s; km %6.2f, d %6.2f", "@tags", $coords[0], $coords[1]);
  1316.  
  1317.     my ($oldkm, $oldd) = $model->screen2model([$oldx, $oldy], "space");
  1318.    
  1319.     #######################
  1320.     # Model was measured
  1321.     if ($cns->find(qw/withtag MEASURE/)) {
  1322.         #print "(DEV) Measure Release Got arguments @_\n" if $dev;
  1323.         #my $canvas = shift;
  1324.         #my ($oldkm, $oldd) = @_;
  1325.         $cns->delete('MEASURE');    
  1326.         print "(DEV) Measuring depth and distance from $oldkm, $oldd to @coords\n" if $dev;
  1327.        
  1328.         my $dkm = abs($oldkm - $coords[0]);
  1329.         my $dd  = abs($oldd  - $coords[1]);
  1330.        
  1331.         if ($dd == 0 && $dkm == 0) {
  1332.             $msg = "";
  1333.         } else {
  1334.             $msg = sprintf ("\nx = %6.2fkm, z = %4.2fkm to x = %6.2fkm, z = %4.2fkm; dx = %6.2fkm, dz = %4.2fkm",
  1335.                 $oldkm, $oldd, $coords[0], $coords[1], $dkm, $dd,);
  1336.         }
  1337.     }
  1338.    
  1339.     #######################
  1340.     # NODES have moved
  1341.     if ((grep {$_ eq 'NODE'} @tags) && $movenode == 1){
  1342.         my @coords  = $cns->coords($id);
  1343.         print "(DEV) --- Node mooved to >@coords<\n" if $dev;
  1344.  
  1345.         @coords = $model->screen2model(\@coords, "space");
  1346.        
  1347.         my $x = $coords[0]+($coords[2]-$coords[0])/2;
  1348.         my $y = $coords[1]+($coords[3]-$coords[1])/2;
  1349.         ($oldx, $oldy) = $model->screen2model([$initx, $inity], "space");
  1350.         $msg = sprintf ("\nNode moved from %6.2f, %6.2f to %6.2f, %6.2f. TAGS: @tags", $oldx, $oldy, $x, $y);
  1351.         #print "Message $msg\n";
  1352.         #print "Node with tags @tags has moved to coords @coords\n";
  1353.         $model->edit("tags" => \@tags, "value" => \@coords, "op" => "move");
  1354.         $movenode = 0;
  1355.         #_printStatusMessage("\nRaised layer $tags[3]");
  1356.         $cns->raise($tags[3]);
  1357.     } elsif (grep {$_ eq 'STATION'} @tags){
  1358.         print "This is station: @tags\n" if $debug;        
  1359.  
  1360.     } elsif (grep {$_ eq 'LAYER'} @tags){
  1361.         print "This is Layer: @tags\n" if $debug;
  1362.         $msg = "\n@tags";
  1363.         my $x = $cns->canvasx($Tk::event->x);
  1364.         my $y = $cns->canvasy($Tk::event->y);
  1365.         my @coords = $model->screen2model([$x, $y], "space");
  1366.         #print "x $x, y $y, -> @coords\n";
  1367.         #$msg = "\n@tags; x,y: @coords";
  1368.         $msg = sprintf("\n%s; km %6.2f, d %6.2f", "@tags", $coords[0], $coords[1]);
  1369.        
  1370.     } elsif (grep {$_ eq 'VNODE'} @tags){
  1371.         print "This is a velocity node: @tags\n" if $debug;
  1372.         $msg = "\n@tags";
  1373.  
  1374.     } elsif (grep {$_ eq 'TOMOGRID'} @tags){
  1375.         #print "This is a velocity node: @tags\n";
  1376.         $msg = "\n@tags";
  1377.  
  1378.     } else {
  1379.         # Shouldn't happen
  1380.         #my $x = $cns->canvasx($Tk::event->x);
  1381.         #my $y = $cns->canvasy($Tk::event->y);
  1382.         print "i_BindSpace() doesn't know, what to do, <@tags>\n" if $verbose;
  1383.         #print "x $x, y $y\n";
  1384.         #my @ids = $cns->find('closest', $x, $y, 'LAYER');
  1385.         #@tags = $cns->gettags(@ids);
  1386.         #print "i_BindSpace() below current:, <@ids> <@tags>\n";
  1387.        
  1388.     }
  1389.     _printStatusMessage($msg);
  1390.     #$stline->insert ('end', "$msg");
  1391.     #$stline->see('end');
  1392.     $cns->Tk::focus;
  1393. }
  1394.  
  1395. # Called when right mouse button is clicked on the main window.
  1396. sub m_B3menu {
  1397.  
  1398. =PROGhead2 m_B3menu()
  1399.  
  1400. Function displays menu when right clicking on model area in main window.
  1401. Depending on the kind of object clicked on, the menu is different.
  1402.  
  1403. =cut
  1404.  
  1405.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  1406.     my ($self, $x, $y) = @_;
  1407.     my $cx = $cns->canvasx($Tk::event->x);
  1408.     my $cy = $cns->canvasy($Tk::event->y);
  1409.    
  1410.     my $id      = $cns->find(qw/withtag current/);
  1411.     my @tags = $cns->gettags($id);
  1412.     #print "I'm >$tags[1]<, id @$id\n";
  1413.    
  1414.     @tags = grep {$_ ne 'current'} @tags;
  1415.     my $type = $tags[0];
  1416.     my @coords = $model->screen2model([$cx, $cy], "space");
  1417.     #print "m_B3menu: Type $type, coords @coords, tags @tags\n";
  1418.    
  1419.     # Clean menu, then adding entrys for this type of object
  1420.     $menuRightClick->delete(0, 'last');
  1421.  
  1422.     if ($type eq 'LAYER' || $type eq 'BOUND') {
  1423.         $menuRightClick->add('command', -label => "Layer $tags[1]", -state => 'disabled');
  1424.         $menuRightClick->add('command', -label => 'Add depth node', -command => [\&m_addNode, \@tags, \@coords]);
  1425.         $menuRightClick->add('command', -label => 'Add velocity node', -command => [\&m_addVNode, \@tags, \@coords]);
  1426.         $menuRightClick->add('command', -label => 'Move/Remove nodes ..', -command => [\&m_selectNodes, \@tags, \@coords, "edit"]);
  1427.         #$menuRightClick->add('command', -label => 'Read nodes from file', -command => [\&m_selectNodes, \@tags, \@coords, "file"]);
  1428.         $menuRightClick->add('command', -label => 'Snap nodes to upper layer ..', -command => [\&m_selectNodes, \@tags, \@coords, "snapUp"]);
  1429.         $menuRightClick->add('command', -label => 'Snap nodes to lower layer ..', -command => [\&m_selectNodes, \@tags, \@coords, "snapDown"]);
  1430.         $menuRightClick->add('command', -label => 'Toggle partial derivatives for nodes ..', -command => [\&m_selectNodes, \@tags, \@coords, "toggle"]);
  1431.         $menuRightClick->add('command', -label => 'Unset partial derivatives for all nodes',
  1432.                 -command => [\&model::edit, $model, "tags", \@tags, "value", \@coords, "op" , "unsetPar"]);
  1433.         $menuRightClick->add('command', -label => 'Set partial derivatives for all velocity nodes',
  1434.                 -command => [\&model::edit, $model, "tags", \@tags, "value", \@coords, "op" , "setPar"]);                
  1435.         $menuRightClick->add('command', -label => 'Raise boundary', -command =>
  1436.             sub {
  1437.                   (my $n = $tags[1]) =~ s/BOUND//;
  1438.                   $cns->raise("BOUND$n");
  1439.                   $cns->raise("N$n");
  1440.                   #print "Raise boundary >$n<\n";
  1441.             }); #TODO: Put this raising/lowering function into model->order(raise, BOUND X)
  1442.         $menuRightClick->add('command', -label => 'Lower boundary', -command =>
  1443.                     sub {
  1444.                         (my $n = $tags[1]) =~ s/BOUND//;
  1445.                         $cns->lower("BOUND$n");
  1446.                         $cns->lower("N$n");
  1447.                         $cns->lower("LAYER");
  1448.                         $cns->lower("background");
  1449.                         });
  1450.                        
  1451.     } elsif ( $type eq 'NODE' ) {
  1452.         print "Its a node >@tags<\n";
  1453.         $menuRightClick->add('command', -label => "Depthnode", -state => 'disabled');
  1454.         $menuRightClick->add('command', -label => 'Toggle partial derivative value',
  1455.             -command => [\&model::edit, $model, "tags", \@tags, "value", \@coords, "op" , "edit"]);
  1456.         $menuRightClick->add('command', -label => 'Delete depth node', -command => [\&m_deleteNode, \@tags]);    
  1457.    
  1458.     } elsif ( $type eq 'VNODE' ) {
  1459.         print "m_B3menu: Edit Velocity node\n" if $debug;
  1460.         $menuRightClick->add('command', -label => "Velocity", -state => 'disabled');
  1461.         $menuRightClick->add('command', -label => 'Toggle partial derivative value',
  1462.             -command => [\&model::edit, $model, "tags", \@tags, "value", \@coords, "op" , "togglePar"]);
  1463.         $menuRightClick->add('command', -label => 'Edit velocity node',            -command => \&m_editVNode);
  1464.         $menuRightClick->add('command', -label => 'Edit velocity ALL nodes',    -command => \&m_editVNodes);
  1465.         $menuRightClick->add('command', -label => 'Delete current node',         -command => [\&m_deleteVNode, \@tags]);
  1466.        
  1467.     } elsif ( $type eq 'STATION' ) {
  1468.         $menuRightClick->add('command', -label => "Station $tags[1]\@km $tags[2],z=$tags[3]", -state => 'disabled');
  1469.         #$menuRightClick->add('command', -label => 'Edit phase',                
  1470.             #-command => [\&model::edit, $model, "tags", \@tags, "value", \@coords, "op" , "editPhase"]
  1471.             #-command => [\&mc_editPhase, \@tags]
  1472.             #);
  1473.         $menuRightClick->add('command', -label => 'Toggle left shots',
  1474.             -command => [\&model::edit, $model, "tags", \@tags, "value", \@coords, "op" , "leftShot"]
  1475.             );            
  1476.         $menuRightClick->add('command', -label => 'Toggle right shots',
  1477.             -command => [\&model::edit, $model, "tags", \@tags, "value", \@coords, "op" , "rightShot"]
  1478.             );          $menuRightClick->add('command', -label => 'Toggle station',
  1479.             -command => sub {
  1480.                 # Toggle value of selected station (to draw or not to draw)
  1481.                 if ($stationlist{$tags[1]}[3]==1) {
  1482.                     $stationlist{$tags[1]}[3]=0
  1483.                 }else{
  1484.                     $stationlist{$tags[1]}[3]=1
  1485.                 };
  1486.                 print "Station set to $tags[1]\n ";
  1487.  
  1488.                 b_drawStation($tags[1])
  1489.                 });
  1490.        
  1491.     }
  1492.     # elsif ( $type eq 'PICK' ) {
  1493.             #$menuRightClick->add('command', -label => 'Edit phase',                
  1494.             #-command => [\&model::edit, $model, "tags", \@tags, "value", \@coords, "op" , "editPhase"]
  1495.             ##-command => [\&mc_editPhase, \@tags]
  1496.             #);
  1497.     #}    
  1498.    
  1499.     $menuRightClick->Popup(qw/-popover cursor -popanchor sw/);
  1500.  
  1501.  
  1502. }
  1503.  
  1504. sub tc_editPhase {
  1505.  
  1506. =PROGhead2 tc_editPhase()
  1507.  
  1508. Draws the window with options for editing phase.
  1509. Choosing picks to change is done by tc_choosePicks.
  1510. "Select picks" set the flag for tc_choosePicks, so it knows
  1511. that PICK-items are to be selected.
  1512.  
  1513.  
  1514. =cut
  1515.  
  1516. =USERhead3 Editing phases
  1517.  
  1518. Editing phases only works if using ZP, 'zpdir' and 'zp2ray' are configured
  1519. in p.config.
  1520.  
  1521. Right click on a pick in traveltime plot and follow instructions.
  1522.  
  1523. =cut
  1524.  
  1525.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  1526.  
  1527.     my $tags = shift;
  1528.    
  1529.     print "tags @$tags\n";
  1530.     (my $st = $tags->[1]) =~ s/RAYS//;
  1531.     (my $ph = $tags->[2]) =~ s/Ph//;
  1532.     my ($km, $t, $unc) = split (/ /, $tags->[3]);
  1533.     $km  =~ s/km//;
  1534.     $t   =~ s/t//;
  1535.     $unc =~ s/unc//;
  1536.     #$ph  =~ s/\.//;    # Phases in Pickfile are without decimal ### TODO CHANGE THIS TO USE RIN MATCHES
  1537.     my $editedStation = $st;
  1538.    
  1539.     print "Raise, Sir\n";
  1540.     # Raise current station and phase to ease picking
  1541.     $lzd->raise($tags->[1]);    # raise current station
  1542.     $lzd->raise($tags->[2]);    # raise current phase
  1543.    
  1544.     @choosePicks = ($ph);       # Flag to enable pick selection
  1545.     my $phNew ;
  1546.     my $mode = "change";        # Choose operating mode. Either "change" or "copy" picks to new phase
  1547.     my $selection = "select";     # Choose selection of change. Either "all" picks of this phase will be changed
  1548.                                 # of only "select"ed picks
  1549.    
  1550.     my $start = 1;        # Mark first pick to change
  1551.     my $end = -1;        # Mark last pick to change. -1 mean all
  1552.    
  1553.    
  1554.     # Create the dialog
  1555.     my $dia = $mw->Toplevel( #-popover => $mw,
  1556.                 -title => "$PROG: Edit picked phase",);                
  1557.  
  1558.     my $bframe     = $dia->Frame (-border => 4, -background => "") -> pack(-side=>'bottom', -anchor => 'w', -fill => 'x', -expand => 'yes');
  1559.     my $entryframe = $dia->Frame (-border => 4, -background => "")  -> pack(-side=>'left', -anchor => 'n', -fill => 'x', -expand => 'yes');
  1560.     my $modeframe  = $dia->Frame (-border => 4, -background => "")   -> pack(-side=>'right', -anchor => 'n', -fill => 'x', -expand => 'yes');
  1561.  
  1562.  
  1563.     #$bframe->ROText(-height => 2, -relief => 'solid')-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'no' )
  1564.      #->insert ('end', "Change Phase");
  1565.    
  1566.     ##############
  1567.     # User entries
  1568.     # Stationnumber
  1569.     my $stationEntry = $entryframe -> LabEntry ( -label        => 'Station ',-width => '6',
  1570.                 -labelPack    => [qw/-side left -anchor w -expand yes /],
  1571.                 -textvariable => \$editedStation, -state => 'disabled'
  1572.                 )-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
  1573.  
  1574.     # Phasenumber
  1575.     my $phaseEntry = $entryframe -> LabEntry ( -label        => 'Current phase ',-width => '6',
  1576.                 -labelPack    => [qw/-side left -anchor w -expand yes /],
  1577.                 -textvariable => \$ph,  -state => 'disabled'
  1578.                 )-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
  1579.    
  1580.     # new phasenumber
  1581.     $entryframe -> LabEntry ( -label        => 'New phase ',-width => '6',
  1582.                 -labelPack    => [qw/-side left -anchor w -expand yes /],
  1583.                 -textvariable => \$phNew,
  1584.                 )-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
  1585.  
  1586.     ###############
  1587.     # Chose action:
  1588.     # copy, change or delete
  1589.     # copy
  1590.     $balloon->attach( $modeframe->Radiobutton(
  1591.                 -text => "copy to", -value => "copy", -variable => \$mode,
  1592.                 )-> pack (-side=>'top', -anchor => 'w', -fill => 'none', -expand => 'no')
  1593.         , -balloonmsg => "Copy picks of phase $ph to your new phase");
  1594.    
  1595.     # change
  1596.     $balloon->attach( $modeframe->Radiobutton(
  1597.                 -text => "change to", -value => "change", -variable => \$mode,                    
  1598.                 )-> pack (-side=>'top', -anchor => 'w', -fill => 'none', -expand => 'no')
  1599.         , -balloonmsg => "Change phasename $ph to your new phase");
  1600.  
  1601.     # delete
  1602.     $balloon->attach( $modeframe->Radiobutton(
  1603.                 -text => "delete", -value => "delete", -variable => \$mode,                    
  1604.                 )-> pack (-side=>'top', -anchor => 'w', -fill => 'none', -expand => 'no')
  1605.         , -balloonmsg => "Delete picks");
  1606.  
  1607.     ##############
  1608.     # Selector
  1609.     # all picks
  1610.     $balloon->attach( $bframe->Radiobutton(
  1611.             -text => "All picks", -value => "all", -variable => \$selection,
  1612.             -command => sub {
  1613.                 # Enable Station and Current Phase
  1614.                 $phaseEntry->configure( -state => 'normal' );
  1615.                 $stationEntry ->configure( -state => 'normal');
  1616.                 @choosePicks = ();      # Disables pick selection
  1617.             }, -state => "normal")-> pack (-side=>'top', -anchor => 'w', -expand => 'yes')
  1618.         , -balloonmsg => "Change name for all picks of phase $ph");
  1619.    
  1620.     # selected picks
  1621.     $balloon->attach( $bframe->Radiobutton(
  1622.             -text => "Select picks", -value => "select", -variable => \$selection,                    
  1623.             -command => sub {
  1624.                         $phaseEntry->configure( -state => 'disabled' );
  1625.                         $stationEntry ->configure( -state => 'disabled' );
  1626.                
  1627.                         $lzd->raise($tags->[1]);    # raise current station
  1628.                         $lzd->raise($tags->[2]);    # raise current phase
  1629.  
  1630.                         @choosePicks = ($ph);        # Resets array to a clean start
  1631.                         print "Select picks to change @choosePicks\n";
  1632.                         _printStatusMessage("\nSelect picks to change");
  1633.                         }
  1634.             )-> pack (-side=>'top', -anchor => 'w', -expand => 'yes')
  1635.         , -balloonmsg => "Select Range of picks to change name");
  1636.                    
  1637.     ##############
  1638.     # Help text
  1639.     my $text = $bframe -> ROText(-width => '30', -height => 6, -borderwidth => 0, -wrap => 'word')
  1640.         -> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
  1641.     $text->insert('end', "Select picks to change and enter new phasenumber. Station is only used when working on 'all' picks".
  1642.     " for a phase. Current phase is only used for all picks.");
  1643.     $text->configure(-state => 'disabled');
  1644.  
  1645.     ##############
  1646.     # Buttons
  1647.     $bframe->Button(-text=>"Save Changes",
  1648.         -command => sub {
  1649.             # Check if new phase has been given:
  1650.             unless ($phNew || $mode eq "delete") {
  1651.                 _printStatusMessage("\nEnter new phase");
  1652.                 return;
  1653.             }
  1654.            
  1655.             if ( $selection eq "select"){
  1656.                 # First entry is phase, second start pick, third end pick
  1657.                 # Check if two picks are choosen
  1658.                 if (@choosePicks != 3 ) {
  1659.                     _printStatusMessage("\nChoose two picks for range. Currently selected: Ph@choosePicks. Now resetted.");
  1660.                     @choosePicks = ($ph);
  1661.                     return;
  1662.                     }
  1663.                 _printStatusMessage("Save $ph as $phNew from @{$choosePicks[1]} to @{$choosePicks[2]}\n");
  1664.                
  1665.                 # Check if phase is the same for both picks
  1666.                 # Otherwise clear array and select two new picks
  1667.                 if ($choosePicks[1][1] ne $choosePicks[2][1]    # stationnumber
  1668.                  || $choosePicks[1][2] ne $choosePicks[2][2] ){ # phasenumber
  1669.                     _printStatusMessage("Stations and/or phases don't fit! Try again!!");
  1670.                     @choosePicks = ($ph);
  1671.                     return;
  1672.                 }
  1673.  
  1674.             ($editedStation = $choosePicks[1][1]) =~ s/RAYS//;
  1675.             ($ph = $choosePicks[1][2]) =~ s/Ph//;
  1676.             $choosePicks[0] = $ph;
  1677.                
  1678.                
  1679.             # Above is for "selected" picks
  1680.             } else { # For changing 'all' picks you need to give the station name
  1681.                 @choosePicks = ($ph, $editedStation);
  1682.             }
  1683.            
  1684.             #(my $st = $tags->[1]) =~ s/RAYS//;
  1685.             print "choosePicks: \n";
  1686.             print Dumper(\@choosePicks);
  1687.              
  1688.             print "Everything seems fine with the picks (@choosePicks, $mode). Do the editing ..\n";
  1689.             print "Change ph $ph to $phNew for station $editedStation\n";
  1690.             #print Dumper(\@choosePicks);
  1691.             #die;
  1692.             # How does the model now, which Station is edited?
  1693.             # @choosePicks = ( $ph, @tagsPick1, @tagsPick2 )    # for selected picks
  1694.             # @choosePicks = ( $ph, $station)                   # for all picks
  1695.            
  1696.             $model->edit("tags" => \@choosePicks, "op" => "editPhase",
  1697.                          "value" => [$ph, $phNew], "mode" => $mode);
  1698.            
  1699.             @choosePicks = ($ph);        # Reset chooseen picks
  1700.             _printStatusMessage("\nNew picks have been written");
  1701.            
  1702.             # Select station and run zp2ray
  1703.             $station = $editedStation;
  1704.             b_zp2ray();
  1705.         }
  1706.         , -width => 10)->pack(qw/-side left/);
  1707.        
  1708.     $bframe->Button(-text=>"Close", -command => sub { $dia->destroy; @choosePicks = ()}, -width => 10)->pack(qw/-side left /);    
  1709. }
  1710.  
  1711. sub tc_choosePicks {
  1712.  
  1713. =PROGhead2 tc_choosePicks()
  1714.  
  1715. Stores tags of the clicked pick in the global array @choosePicks, if the array is not
  1716. empty. The array also operates as flag. Nothing is added if the array is empty.
  1717.  
  1718. =cut
  1719.  
  1720.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  1721.  
  1722.     # Only continue when flag for choosing picks is activated
  1723.     return if (@choosePicks == 0);
  1724.     print "Choosing picks enabled\n";
  1725.    
  1726.     my $id      = $lzd->find(qw/withtag current/);
  1727.     my @tags = $lzd->gettags($id);
  1728.     print "Include >@tags<, id @$id in selectiong\n";
  1729.    
  1730.     push @choosePicks, \@tags;
  1731.     print @choosePicks." are in array \n";
  1732. }
  1733.  
  1734. sub t_rms {
  1735.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  1736.  
  1737. # Initial drawing of hyperbola
  1738. # station positon is needed
  1739. # get it from pick tags
  1740. # t_rms is activated via right click menu of drawn picks
  1741.  
  1742.     my $tags = shift;    # Pick tag
  1743.     my $x = shift;
  1744.     my $y = shift;
  1745.  
  1746.     #-tags => ["PICK", 'RAYS'.$station->{name}, "Ph$phase","km$km t$t unc$unc offset$off"]
  1747.     (my $st = $tags->[1]) =~ s/RAYS//;
  1748.     my $pos = $model->getStation($st)->{position};
  1749.    
  1750.     print "Draw rms velocity for station $st at $pos, mouse $x, $y\n";
  1751.  
  1752.     t_hyperbola('RMS',"$pos", "$x", "$y");
  1753.     $lzd->delete('ZOOM')
  1754.  
  1755. }
  1756.  
  1757. sub t_hyperbola {
  1758.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  1759.  
  1760.     # needed arguments:
  1761.     # - station position
  1762.     # - mouse position
  1763.     #
  1764.     #######
  1765.     # - (Calculate t0 depending on mouse y-position)
  1766.     # - Calculate vrms depending on mouse x-positon
  1767.     # - Draw hyperbola
  1768.    
  1769.     # TODO: make text position of rms more intelligent
  1770.    
  1771.     my ($tag, $pos, $x, $y);  
  1772.    
  1773.     if (@_ == 4 ) { # if arguments
  1774.         ($tag, $pos, $x, $y) = @_;
  1775.         #print "Get position from arguments\n";
  1776.     } else {
  1777.         #print "No arguments given, look for existing RMS\n";
  1778.         ## if no arguments and there's already a hyperbola
  1779.         if ($lzd->coords('RMS')) {
  1780.             my @tags = $lzd->gettags(($lzd->find(qw/withtag RMS/))[0]);
  1781.             $x = $lzd->canvasx($Tk::event->x);
  1782.             $y = $lzd->canvasy($Tk::event->y);
  1783.            
  1784.             ($tag, $pos) = @tags;
  1785.             #print "Found coordinates from current hyperbola\n";
  1786.         }
  1787.     }
  1788.    
  1789.     my ($s, $t) = $model->screen2model([$x, $y], "time", $pos);    # $s and $t are unreduced times!!
  1790.     my $offset = abs ($s - $pos);     # distance from station to pointer
  1791.    
  1792.     # y-position of mouse pointer is t0
  1793.     my ($x0, $t0) = $model->screen2model([$x, $y], "time");    # $s and $t are reduced times!!
  1794.  
  1795.  
  1796.     # Calculate rms velocity depending on offset of mouse pointer
  1797.     my $m = 6.5/150;    # m = v/x, velocity v at offset x determines slope
  1798.     my $v = abs ($m * $offset);
  1799.  
  1800.     my $maxX = 250;         # Line extends up to $maxX km offset from station
  1801.     my $x2;
  1802.    
  1803.     #########################################################################
  1804.     # y-position of mouse pointer can be used as part of hyperbola. Calculate
  1805.     # corresponding t0. BUT: pointer might cover the picks when lying
  1806.     # on top.
  1807.     if (abs ($offset) > 120 ) {
  1808.         #print "Use mouse pointer as anchor\n";
  1809.         $x0 = 0;
  1810.         $x2 = $offset;
  1811.         my $t2 = $t;
  1812.    
  1813.         # Test two different ways of calculating t0. Should be the same.
  1814.         my $t0test = sqrt(abs (  $t2**2 +  ($x0**2 - $x2**2)/$v**2));  
  1815.         $t0 = sqrt (  abs ( $v**2 * $t2**2 - $x2**2 + $x0)
  1816.                         / $v**2 );
  1817.         #print "t0 = $t0, v = $v, unreduced pick coord are x=$x2 km, t=$t s\n";
  1818.    
  1819.         ## Check if formula is correct and input t2 can be recovered
  1820.         my $t2test = sqrt(abs($t0**2 - (-$x2**2 + $x0**2)/$v**2));
  1821.         #print "Put in t = $t, got out t2test = $t2test\n".
  1822.               #"t0 = $t0 (commons),  my t0 = $t0test\n";
  1823.     }
  1824.     #########################################################################
  1825.    
  1826.    
  1827.     # Calculate points of hyperbola
  1828.     $x0 = 0;
  1829.     $x2 = 0;                # Calculate t2(x2) for x2 = 0 .. $maxX
  1830.     my $dx = 1;             # distance between two points of hyperbola line
  1831.     my @coords = ();
  1832.    
  1833.     # Play with a simple testing model and pure formula t = sqrt(x^2+4z^2)/v
  1834.     my @testcoords = ();
  1835.  
  1836.     while ( $x2 < $maxX ) {
  1837.         # Calculate hyperbola in model domain (unreduced times)
  1838.         my $t2 = sqrt(abs($t0**2 - (-$x2**2 + $x0**2)/$v**2));
  1839.         #print "x = $x2, t = $t2 ( x0 = $x0, t0 = $t0)\n";
  1840.        
  1841.         # Convert model coordinates in screen coordinates
  1842.         # model2screen also reduces traveltimes
  1843.         # left branch
  1844.         unshift @coords, $model->model2screen([$pos-$x2, $t2], "time", $pos);
  1845.         # right branch
  1846.         push @coords, $model->model2screen([$x2+$pos, $t2], "time", $pos);
  1847.        
  1848.        
  1849.         ## TESTING SIMPLE LAYERED MODEL
  1850.         #my $tt = sqrt($x2**2 + 4 * 28**2)/$v;
  1851.         ##print "Add test model time $tt\n";
  1852.         #unshift @testcoords, $model->model2screen([$pos-$x2, $tt], "time", $pos);
  1853.         #push @testcoords, $model->model2screen([$x2+$pos, $tt], "time", $pos);
  1854.        
  1855.        
  1856.         $x2 += $dx;
  1857.     }
  1858.    
  1859.     # Delete old hyperbola and draw new one
  1860.     $lzd->delete('RMS');
  1861.     $lzd->createLine(@coords,
  1862.         -fill => 'blue',
  1863.         -tags    => ['RMS',"$pos"],
  1864.         );
  1865.     #$lzd->createLine(@testcoords,
  1866.         #-fill => 'green',
  1867.         #-tags    => ['RMS',"$pos"],
  1868.         #);
  1869.    
  1870.     my $xpos = ($lzd->xview)[0]  * $box->[2]+200;
  1871.     my $ypos = ($lzd->yview)[0]  * $box->[3]+20;
  1872.    
  1873.     #print "Annote text to $xpos, $ypos";
  1874.     #print Dumper $box;
  1875.    
  1876.     # Annonte rms velocity
  1877.     $lzd -> createText(
  1878.             $xpos, $ypos,   # Text position
  1879.             -text => sprintf("t0 = %.2f s, v_rms = %.2f km/s", $t0, $v),
  1880.             -tags => ["RMS","$pos"],
  1881.             -fill=>"black", justify => "left");
  1882. }
  1883.  
  1884. sub m_selectNodes {
  1885.  
  1886. =PROGhead2 m_selectNodes()
  1887.  
  1888. Function enables selecting nodes for toggling of partial derivatives or snapping to upper/lower layer.
  1889. Main point is to set toggle flag and raise  nodes for this layer. Flag C<$editNode> saves
  1890. information about the type of edit
  1891.  
  1892. Called by C<m_B3menu>
  1893. Further coding is done in m_B1node, when the second node has been selected
  1894.  
  1895. =cut
  1896.  
  1897.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  1898.  
  1899.     my $tags = shift;
  1900.     my $coords = shift;
  1901.     $editNode = shift; # Global variable for type of edit (toggle or snap)
  1902.    
  1903.     #my $l = $tags->[1];
  1904.     (my $l = $tags->[1]) =~ s/BOUND //;
  1905.    
  1906.     print "Enabling choosing for layer>$l<, raising <N $l> [ @$tags ]\n";
  1907.     $selectedNodes = 1;
  1908.    
  1909.     # raising nodes to ensure clicking on the right ones if boundarys are pinched out
  1910.     $cns->raise("N $l") if ($showNodes == 1);
  1911.     $cns->raise("BOUND $l");
  1912.     $cns->raise("V $l") if ($showVNodes == 1);
  1913.  
  1914.     _printStatusMessage("\nSelect start and end node");
  1915. }
  1916.  
  1917. sub m_editModel{
  1918.    
  1919.    
  1920. }
  1921.  
  1922. sub i_createModel {
  1923.    
  1924.     # Create simple model files
  1925.    
  1926.     my $rintext =
  1927. "
  1928.  &pltpar  isep=0, itx=3, idata=1,
  1929.           imod=1, iray=2, ibnd=0, isum=2,
  1930.           xwndow=292., ywndow=175.,
  1931.           ircol=1, itcol=1,
  1932.  &end
  1933.  &axepar  xmax=300., xmm=265.,
  1934.           zmax=40.,  zmm=60.,
  1935.           tmax=10.,  tmm=60.,
  1936.           albht=3.5, orig=15., sep=10.,
  1937.  &end  
  1938.  &trapar  imodf=1, ibsmth=1, i2pt=0,
  1939.           ishot=1,-1, xshot=0.,300.,
  1940.           ray=1.1,2.1,2.2,3.2,4.3,
  1941.           nsmax=15,
  1942.           nray=20,25,25,50,1,
  1943.           space=1.,1.5,2.,2.5,1.,
  1944.           aamin=0.25, aamax=75.,
  1945.  &end
  1946.  &invpar  invr=1,
  1947.           ivray=1,1,2,3,4,
  1948.  &end
  1949. ";
  1950.    
  1951.     my $file = "r.in";
  1952.     open(FILE, ">$file") or die "Can't open $file";
  1953.     printf FILE $rintext;
  1954.     close(FILE);
  1955.  
  1956.     my $vintext =
  1957. " 1    0.00  25.00  50.00  75.00 100.00 125.0  150.00 175.00 200.00 225.00
  1958. 1    0.40   0.20  -0.50  -1.50   0.20   0.60   1.50   0.30   1.00   0.70
  1959.         0      0      0      0      0      0      0      0      0      0
  1960. 1  250.00 275.00 300.00
  1961. 0    0.00   0.50   0.50
  1962.         0      0      0
  1963. 1    0.00 150.00 300.00
  1964. 0    4.90   4.90   4.90
  1965.         1      1      1
  1966. 1    0.00 150.00 300.00
  1967. 0    5.40   5.40   5.40
  1968.         1      1      1
  1969. 2  300.00  
  1970. 0   10.00
  1971.         0
  1972. 2  300.00
  1973. 0    0.00
  1974.         0
  1975. 2    0.00 150.00 300.00
  1976. 0    5.70   5.70   5.70  
  1977.         1      1      1
  1978. 3    0.00 100.00 200.00 300.00
  1979. 0   25.00  25.00  25.00  25.00
  1980.         1      1      1      1
  1981. 3  300.00
  1982. 0    6.40
  1983.         1
  1984. 3  300.00
  1985. 0    6.73
  1986.        -1
  1987. 4    0.00 150.00 300.00
  1988. 0   34.00  34.00  34.00
  1989.         1      1      1
  1990. 4  300.00
  1991. 0    7.50
  1992.         0
  1993. 4  300.00
  1994. 0    0.00
  1995.         0
  1996. 5    0.00 150.00 300.00
  1997. 0   36.00  36.00  36.00
  1998.        -1     -1     -1
  1999. 5  300.00
  2000. 0    7.70
  2001.         1
  2002. 5  300.00
  2003. 0    0.00
  2004.         0
  2005. 6  300.00
  2006. 0   40.00
  2007. ";
  2008.    
  2009.     $file = "v.in";
  2010.     open(FILE, ">$file") or die "Can't open $file";
  2011.     printf FILE $vintext;
  2012.     close(FILE);
  2013.  
  2014.  my $txtext =
  2015.  "     0.000     1.000     0.000         0
  2016.     5.000     0.874     0.050         1
  2017.    10.000     1.771     0.050         1
  2018.    15.000     2.684     0.050         1
  2019.    20.000     3.472     0.050         1
  2020.    25.000     4.440     0.050         1
  2021.    30.000     5.375     0.050         1
  2022.    35.000     6.214     0.050         1
  2023.    40.000     7.193     0.050         1
  2024.    45.000     7.998     0.050         1
  2025.    50.000     8.961     0.050         1
  2026.    55.000     9.686     0.050         1
  2027.    60.000    10.700     0.050         1
  2028.    65.000    11.520     0.050         1
  2029.    70.000    12.496     0.050         1
  2030.    75.000    13.465     0.050         1
  2031.    80.000    14.177     0.050         1
  2032.    85.000    15.118     0.050         1
  2033.    90.000    16.022     0.050         1
  2034.    95.000    16.876     0.050         1
  2035.   100.000    17.729     0.050         1
  2036.   105.000    18.503     0.050         1
  2037.   110.000    19.377     0.050         1
  2038.   115.000    20.374     0.050         1
  2039.   120.000    21.206     0.050         1
  2040.   125.000    22.146     0.050         1
  2041.   130.000    22.958     0.050         1
  2042.   135.000    23.870     0.050         1
  2043.   140.000    24.675     0.050         1
  2044.   145.000    25.623     0.050         1
  2045.   150.000    26.519     0.050         1
  2046.   155.000    27.324     0.050         1
  2047.    15.000     7.413     0.050         2
  2048.    20.000     7.705     0.050         2
  2049.    25.000     8.185     0.050         2
  2050.    30.000     8.571     0.050         2
  2051.    35.000     9.032     0.050         2
  2052.    40.000     9.653     0.050         2
  2053.    45.000    10.169     0.050         2
  2054.    50.000    10.867     0.050         2
  2055.    55.000    11.424     0.050         2
  2056.    60.000    12.182     0.050         2
  2057.    65.000    13.038     0.050         2
  2058.    70.000    13.742     0.050         2
  2059.    75.000    14.405     0.050         2
  2060.    80.000    15.214     0.050         2
  2061.    85.000    15.819     0.050         2
  2062.    90.000    16.603     0.050         2
  2063.    95.000    17.368     0.050         2
  2064.   100.000    18.142     0.050         2
  2065.   105.000    18.965     0.050         2
  2066.   110.000    19.702     0.050         2
  2067.   115.000    20.617     0.050         2
  2068.   120.000    21.454     0.050         2
  2069.   125.000    22.316     0.050         2
  2070.   130.000    23.143     0.050         2
  2071.   135.000    23.932     0.050         2
  2072.   140.000    24.822     0.050         2
  2073.   145.000    25.619     0.050         2
  2074.   150.000    26.563     0.050         2
  2075.   155.000    27.359     0.050         2
  2076.    20.000     9.554     0.050         3
  2077.    25.000     9.884     0.050         3
  2078.    30.000    10.223     0.050         3
  2079.    35.000    10.741     0.050         3
  2080.    40.000    11.246     0.050         3
  2081.    45.000    11.728     0.050         3
  2082.    50.000    12.263     0.050         3
  2083.    55.000    12.877     0.050         3
  2084.    60.000    13.518     0.050         3
  2085.    65.000    14.215     0.050         3
  2086.    70.000    14.865     0.050         3
  2087.    75.000    15.417     0.050         3
  2088.    80.000    16.063     0.050         3
  2089.    85.000    16.698     0.050         3
  2090.    90.000    17.385     0.050         3
  2091.    95.000    17.983     0.050         3
  2092.   100.000    18.627     0.050         3
  2093.   105.000    19.292     0.050         3
  2094.   110.000    20.070     0.050         3
  2095.   115.000    20.757     0.050         3
  2096.   120.000    21.441     0.050         3
  2097.   125.000    22.166     0.050         3
  2098.   130.000    22.778     0.050         3
  2099.   135.000    23.581     0.050         3
  2100.   140.000    24.148     0.050         3
  2101.   145.000    24.871     0.050         3
  2102.   150.000    25.705     0.050         3
  2103.   155.000    26.433     0.050         3
  2104.   160.000    27.071     0.050         3
  2105.   165.000    27.955     0.050         3
  2106.   170.000    28.593     0.050         3
  2107.   175.000    29.288     0.050         3
  2108.   180.000    30.015     0.050         3
  2109.   185.000    30.708     0.050         3
  2110.   190.000    31.394     0.050         3
  2111.   195.000    32.076     0.050         3
  2112.   200.000    32.849     0.050         3
  2113.   205.000    33.511     0.050         3
  2114.    90.000    17.485     0.050         4
  2115.    95.000    18.074     0.050         4
  2116.   100.000    18.633     0.050         4
  2117.   105.000    19.286     0.050         4
  2118.   110.000    20.010     0.050         4
  2119.   115.000    20.601     0.050         4
  2120.   120.000    21.148     0.050         4
  2121.   125.000    21.807     0.050         4
  2122.   130.000    22.399     0.050         4
  2123.   135.000    23.057     0.050         4
  2124.   140.000    23.768     0.050         4
  2125.   145.000    24.320     0.050         4
  2126.   150.000    24.965     0.050         4
  2127.   155.000    25.703     0.050         4
  2128.   160.000    26.388     0.050         4
  2129.   165.000    27.068     0.050         4
  2130.   170.000    27.623     0.050         4
  2131.   175.000    28.319     0.050         4
  2132.   180.000    28.861     0.050         4
  2133.   185.000    29.577     0.050         4
  2134.   190.000    30.133     0.050         4
  2135.   195.000    30.799     0.050         4
  2136.   200.000    31.302     0.050         4
  2137.   205.000    31.873     0.050         4
  2138.   210.000    32.588     0.050         4
  2139.   215.000    33.221     0.050         4
  2140.   220.000    33.816     0.050         4
  2141.   225.000    34.497     0.050         4
  2142.   230.000    35.056     0.050         4
  2143.   235.000    35.690     0.050         4
  2144.   240.000    36.300     0.050         4
  2145.   245.000    37.027     0.050         4
  2146.   250.000    37.587     0.050         4
  2147.   255.000    38.203     0.050         4
  2148.   260.000    38.708     0.050         4
  2149.   265.000    39.381     0.050         4
  2150.   270.000    40.062     0.050         4
  2151.   275.000    40.663     0.050         4
  2152.   280.000    41.242     0.050         4
  2153.   285.000    41.814     0.050         4
  2154.   290.000    42.429     0.050         4
  2155.   300.000    -1.000     0.000         0
  2156.   145.000    27.376     0.050         1
  2157.   150.000    26.503     0.050         1
  2158.   155.000    25.613     0.050         1
  2159.   160.000    24.755     0.050         1
  2160.   165.000    23.842     0.050         1
  2161.   170.000    22.992     0.050         1
  2162.   175.000    22.079     0.050         1
  2163.   180.000    21.295     0.050         1
  2164.   185.000    20.300     0.050         1
  2165.   190.000    19.427     0.050         1
  2166.   195.000    18.528     0.050         1
  2167.   200.000    17.674     0.050         1
  2168.   205.000    16.799     0.050         1
  2169.   210.000    15.870     0.050         1
  2170.   215.000    15.089     0.050         1
  2171.   220.000    14.149     0.050         1
  2172.   225.000    13.402     0.050         1
  2173.   230.000    12.498     0.050         1
  2174.   235.000    11.481     0.050         1
  2175.   240.000    10.638     0.050         1
  2176.   245.000     9.746     0.050         1
  2177.   250.000     8.868     0.050         1
  2178.   255.000     7.983     0.050         1
  2179.   260.000     7.140     0.050         1
  2180.   265.000     6.225     0.050         1
  2181.   270.000     5.279     0.050         1
  2182.   275.000     4.392     0.050         1
  2183.   280.000     3.501     0.050         1
  2184.   285.000     2.726     0.050         1
  2185.   290.000     1.734     0.050         1
  2186.   295.000     0.872     0.050         1
  2187.   145.000    27.463     0.050         2
  2188.   150.000    26.478     0.050         2
  2189.   155.000    25.509     0.050         2
  2190.   160.000    24.736     0.050         2
  2191.   165.000    23.913     0.050         2
  2192.   170.000    23.038     0.050         2
  2193.   175.000    22.287     0.050         2
  2194.   180.000    21.435     0.050         2
  2195.   185.000    20.518     0.050         2
  2196.   190.000    19.705     0.050         2
  2197.   195.000    18.957     0.050         2
  2198.   200.000    18.048     0.050         2
  2199.   205.000    17.370     0.050         2
  2200.   210.000    16.570     0.050         2
  2201.   215.000    15.654     0.050         2
  2202.   220.000    14.864     0.050         2
  2203.   225.000    14.255     0.050         2
  2204.   230.000    13.408     0.050         2
  2205.   235.000    12.893     0.050         2
  2206.   240.000    12.136     0.050         2
  2207.   245.000    11.461     0.050         2
  2208.   250.000    10.745     0.050         2
  2209.   255.000    10.142     0.050         2
  2210.   260.000     9.510     0.050         2
  2211.   265.000     9.041     0.050         2
  2212.   270.000     8.470     0.050         2
  2213.   275.000     8.045     0.050         2
  2214.   280.000     7.609     0.050         2
  2215.   285.000     7.353     0.050         2
  2216.    75.000    36.633     0.050         3
  2217.    80.000    35.894     0.050         3
  2218.    85.000    35.160     0.050         3
  2219.    90.000    34.500     0.050         3
  2220.    95.000    33.722     0.050         3
  2221.   100.000    32.975     0.050         3
  2222.   105.000    32.295     0.050         3
  2223.   110.000    31.580     0.050         3
  2224.   115.000    30.794     0.050         3
  2225.   120.000    30.145     0.050         3
  2226.   125.000    29.491     0.050         3
  2227.   130.000    28.759     0.050         3
  2228.   135.000    27.981     0.050         3
  2229.   140.000    27.369     0.050         3
  2230.   145.000    26.626     0.050         3
  2231.   150.000    25.842     0.050         3
  2232.   155.000    25.154     0.050         3
  2233.   160.000    24.379     0.050         3
  2234.   165.000    23.749     0.050         3
  2235.   170.000    23.094     0.050         3
  2236.   175.000    22.437     0.050         3
  2237.   180.000    21.715     0.050         3
  2238.   185.000    20.947     0.050         3
  2239.   190.000    20.391     0.050         3
  2240.   195.000    19.573     0.050         3
  2241.   200.000    19.013     0.050         3
  2242.   205.000    18.353     0.050         3
  2243.   210.000    17.639     0.050         3
  2244.   215.000    17.015     0.050         3
  2245.   220.000    16.367     0.050         3
  2246.   225.000    15.863     0.050         3
  2247.   230.000    15.171     0.050         3
  2248.   235.000    14.654     0.050         3
  2249.   240.000    14.067     0.050         3
  2250.   245.000    13.585     0.050         3
  2251.   250.000    13.134     0.050         3
  2252.   255.000    12.633     0.050         3
  2253.   260.000    12.247     0.050         3
  2254.   265.000    11.669     0.050         3
  2255.   270.000    11.296     0.050         3
  2256.   275.000    11.094     0.050         3
  2257.    10.000    42.554     0.050         4
  2258.    15.000    41.819     0.050         4
  2259.    20.000    41.261     0.050         4
  2260.    25.000    40.716     0.050         4
  2261.    30.000    39.985     0.050         4
  2262.    35.000    39.534     0.050         4
  2263.    40.000    38.958     0.050         4
  2264.    45.000    38.404     0.050         4
  2265.    50.000    37.825     0.050         4
  2266.    55.000    37.269     0.050         4
  2267.    60.000    36.666     0.050         4
  2268.    65.000    36.026     0.050         4
  2269.    70.000    35.442     0.050         4
  2270.    75.000    34.829     0.050         4
  2271.    80.000    34.246     0.050         4
  2272.    85.000    33.620     0.050         4
  2273.    90.000    32.822     0.050         4
  2274.    95.000    32.332     0.050         4
  2275.   100.000    31.628     0.050         4
  2276.   105.000    31.030     0.050         4
  2277.   110.000    30.451     0.050         4
  2278.   115.000    29.890     0.050         4
  2279.   120.000    29.215     0.050         4
  2280.   125.000    28.620     0.050         4
  2281.   130.000    27.944     0.050         4
  2282.   135.000    27.275     0.050         4
  2283.   140.000    26.776     0.050         4
  2284.   145.000    26.114     0.050         4
  2285.   150.000    25.416     0.050         4
  2286.   155.000    24.812     0.050         4
  2287.   160.000    24.213     0.050         4
  2288.   165.000    23.564     0.050         4
  2289.   170.000    22.912     0.050         4
  2290.   175.000    22.353     0.050         4
  2291.   180.000    21.702     0.050         4
  2292.   185.000    21.130     0.050         4
  2293.   190.000    20.401     0.050         4
  2294.   195.000    19.745     0.050         4
  2295.   200.000    19.034     0.050         4
  2296.     0.000     0.000     0.000        -1
  2297. ";
  2298.  
  2299.     $file = "tx.in";
  2300.     open(FILE, ">$file") or die "Can't open $file";
  2301.     printf FILE $txtext;
  2302.     close(FILE);
  2303.  
  2304.        
  2305. }
  2306.  
  2307. # Called when menu items are selected.
  2308. sub m_addNode {
  2309.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  2310.     my $tags = shift;
  2311.     my $coords = shift;
  2312.     print "Add Node to @$tags at km @$coords\n";
  2313.     #$model->addNode($tags, $coords);
  2314.     $model->edit("tags" => $tags, "value" => $coords, "op" => "add" , "type" => "d");
  2315.    
  2316. }
  2317.  
  2318. sub m_deleteNode {
  2319.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  2320.     my $tags = shift;
  2321.     print "Delete Node @$tags\n";
  2322.     #$model->deleteNode($tags);
  2323.     $model->edit("tags" => $tags, "op" => "del");
  2324.  
  2325.  
  2326. }
  2327.  
  2328. sub m_addVNode {
  2329.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  2330.     #print "Adding velocity node\n";
  2331.     my $tags = shift;
  2332.     my $coords = shift;
  2333.     print "Add Velocity Node to @$tags at km @$coords\n";
  2334.     #$model->addNode($tags, $coords);
  2335.    
  2336.     my $dia = $mw->Toplevel(-title => "$PROG: Add velocity node",
  2337.                 #-text => "Current values are @$tags",
  2338.                 #-buttons => ['Done', 'Cancel']
  2339.                 );
  2340.    
  2341.     my ($v, $km) = (0, sprintf ('%d',@$coords[0]));
  2342.     my ($vu, $vl, $vupar, $vlpar);
  2343.     my $text = $dia -> ROText(-width => '30', -height => 4, -borderwidth => 0)
  2344.         -> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
  2345.     $text->insert('end', "Add a velocity node to @$tags");
  2346.    
  2347.     my $fr = $dia->Frame()-> pack (-side => 'left', -expand => 'yes', -fill => 'both');
  2348.     $fr -> LabEntry (  
  2349.                     -label        => 'Upper Velocity',
  2350.                     -labelPack    => [qw/-side left -anchor w -expand yes -fill both/],
  2351.                     -textvariable => \$vu,
  2352.                     -width => '6'
  2353.                     )-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
  2354.     $fr -> LabEntry (  
  2355.                     -label        => 'Partial derivative for upper Velocity',
  2356.                     -labelPack    => [qw/-side left -anchor w -expand yes -fill both/],
  2357.                     -textvariable => \$vupar,
  2358.                     -width => '6'
  2359.                     )-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
  2360.  
  2361.     $fr -> LabEntry (  
  2362.                     -label        => 'Lower Velocity',
  2363.                     -labelPack    => [qw/-side left -anchor w -expand yes -fill both/],
  2364.                     -textvariable => \$vl,
  2365.                     -width => '6'
  2366.                     )-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
  2367.     $fr -> LabEntry (  
  2368.                     -label        => 'Partial derivative for lower Velocity',
  2369.                     -labelPack    => [qw/-side left -anchor w -expand yes -fill both/],
  2370.                     -textvariable => \$vlpar,
  2371.                     -width => '6'
  2372.                     )-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
  2373.  
  2374.    
  2375.     $fr -> LabEntry (  
  2376.                     -label        => 'Position',
  2377.                     -labelPack    => [qw/-side left -anchor w -expand yes -fill both/],
  2378.                     -textvariable => \$km,
  2379.                     -width => '6'
  2380.                     )-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
  2381.      #my $f = $dia -> Frame() -> pack (-side=>'right', -anchor => 'w', -fill => 'x', -expand => 'yes');
  2382.      
  2383.      #my $bound = "vu";
  2384.     #$f -> Radiobutton (-text => "Upper Boundary", -value =>"vu", -variable => \$bound)-> pack (-side=>'top', -anchor => 'w');
  2385.     #$f -> Radiobutton (-text => "Lower Boundary", -value =>"vl", -variable => \$bound)-> pack (-side=>'top', -anchor => 'w');
  2386.                
  2387.     #$dia -> Entry (-textvariable => "velocity", -width => '4') -> pack (-side=>'top');
  2388.     #$dia -> Entry (-textvariable => "km", -width => '4') -> pack (-side=>'top');
  2389.    
  2390.     #my $ans = $dia->Show;
  2391.     #print "Dialog endet with $ans, $vu $vl, $km\n";
  2392.    
  2393.     #if ($ans eq "Done") {
  2394.         #$model->edit("tags" => $tags, "value" => [$km, $vu, $vl, $vupar, $vlpar], "op" => "addv", "type" => "v");
  2395.     #}
  2396.     my $bframe = $fr->Frame () -> pack(-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'no');        
  2397.  
  2398.     $bframe->Button(-text=>"Save Changes",
  2399.             -command => sub{
  2400.                 $model->edit("tags" => $tags, "value" => [$km, $vu, $vl, $vupar, $vlpar], "op" => "addv", "type" => "v");
  2401.             }, -width => 10)->pack(qw/-side left/);
  2402.    
  2403.     $bframe->Button(-text=>"Close", -command => [$dia => 'destroy'], -width => 10)->pack(qw/-side left /);
  2404.  
  2405. }
  2406.  
  2407. sub m_deleteVNode {
  2408.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  2409.     print "Deleting velocity node\n";    
  2410.     my $tags = shift;
  2411.     $model->edit("tags" => $tags, "op" => "del");
  2412. }
  2413.  
  2414. # EDIT ONLY ONE NODE
  2415. sub m_editVNode {
  2416.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  2417.     my $id      = $cns->find(qw/withtag current/);
  2418.     my @tags = $cns->gettags($id);
  2419.     #print "I'm >$tags[1]<, id @$id\n";
  2420.    
  2421.     my $dia = $mw->Toplevel( -popover => $mw,
  2422.                 -title => "$PROG: Change velocity node",
  2423.                 #-text => "Current values are @tags",
  2424.                 #-buttons => ['Done', 'Cancel']
  2425.                 );
  2426.    
  2427.     my ($km, $vu, $vl, $vupar, $vlpar) = $model->get("vnode", \@tags);
  2428.     #my ($v, $km, $vu, $vl) = (1,2,3,4);
  2429.     $dia -> LabEntry (  
  2430.                     -label        => 'Upper Velocity',
  2431.                     -labelPack    => [qw/-side left -anchor w -expand yes -fill both/],
  2432.                     -textvariable => \$vu,
  2433.                     -width => '6'
  2434.                     )-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
  2435.     $dia -> LabEntry (  
  2436.                     -label        => 'Partial derivative for upper Velocity',
  2437.                     -labelPack    => [qw/-side left -anchor w -expand yes -fill both/],
  2438.                     -textvariable => \$vupar,
  2439.                     -width => '6'
  2440.                     )-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
  2441.     $dia -> LabEntry (  
  2442.                     -label        => 'Lower Velocity',
  2443.                     -labelPack    => [qw/-side left -anchor w -expand yes -fill both/],
  2444.                     -textvariable => \$vl,
  2445.                     -width => '6'
  2446.                     )-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');                    
  2447.     $dia -> LabEntry (  
  2448.                     -label        => 'Partial derivative for lower Velocity',
  2449.                     -labelPack    => [qw/-side left -anchor w -expand yes -fill both/],
  2450.                     -textvariable => \$vlpar,
  2451.                     -width => '6'
  2452.                     )-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
  2453.     $dia -> LabEntry (  
  2454.                     -label        => 'Position',
  2455.                     -labelPack    => [qw/-side left -anchor w/],
  2456.                     -textvariable => \$km,
  2457.                     -width => '6'
  2458.                     )-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
  2459.                
  2460.     #my $ans = $dia->Show;
  2461.     #print "Dialog endet with $ans, km $km, vu $vu, vl $vl, vupar $vupar, vlpar $vlpar\n";
  2462.     #if ($ans eq "Done") {
  2463.         #$model->edit("op" => "edit", "tags" => \@tags, "value" => [$km, $vu, $vl, $vupar, $vlpar]);
  2464.     #}  
  2465.     $dia->Button(-text=>"Save Changes",
  2466.             -command => sub{
  2467.                 $model->edit("op" => "edit", "tags" => \@tags, "value" => [$km, $vu, $vl, $vupar, $vlpar]);
  2468.                 $dia->destroy;
  2469.             }, -width => 10)->pack(qw/-side left/);
  2470.    
  2471.     $dia->Button(-text=>"Close", -command => [$dia => 'destroy'], -width => 10)->pack(qw/-side left /);
  2472.  
  2473. }
  2474.  
  2475. # EDIT MULTIPLE NODES
  2476. sub m_editVNodes {
  2477.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  2478.  
  2479.     my $id; my @tags;
  2480.    
  2481.     $id      = $cns->find(qw/withtag current/);
  2482.     @tags = $cns->gettags($id);
  2483.     #print "I'm >$tags[1]<, >$tags[2]<,id @$id\n";
  2484.    
  2485.     my $dia = $mw->Toplevel( -popover => $mw,
  2486.                 -title => "$PROG: Change velocity node",);                
  2487.                
  2488.     # Get references to arrays with references to each layers information
  2489.     my ($km, $vu, $vl, $vupar, $vlpar) = $model->get("vnodes");
  2490.    
  2491.     # MAKE BUTTONS
  2492.     my $bframe = $dia->Frame () -> pack(-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'no');        
  2493.     my $sc;
  2494.    
  2495.     $bframe->Button(-text=>"Save Changes",
  2496.             -command => sub{
  2497.                 _printStatusMessage(" Write changes to model. You have to write them to v.in");
  2498.                 $model->edit("op" => "edit", "tags" => ["allV"], "value" => [$km, $vu, $vl, $vupar, $vlpar])}
  2499.             , -width => 10)->pack(qw/-side left/);
  2500.            
  2501.     #$bframe->Button(-text=>"Update", -command => sub {
  2502.         #($km, $vu, $vl, $vupar, $vlpar) = $model->get("vnodes");
  2503.         #m_editVNodesDisplay($sc, $km, $vu, $vl, $vupar, $vlpar);
  2504.         ##\&m_editVNodesDisplay, \$sc
  2505.         #}, -width => 10)->pack(qw/-side left /);
  2506.    
  2507.     $bframe->Button(-text=>"Close", -command => [$dia => 'destroy'], -width => 10)->pack(qw/-side left /);
  2508.    
  2509.     $sc = $dia -> Scrolled ('Pane', -scrollbars => 'se', -borderwidth => 1,
  2510.             -relief => 'solid', #-background => "green",
  2511.             -width => 600, -height => 400
  2512.             )     -> pack (-side=>'top', -anchor => 'w', -fill => 'both', -expand => 'yes');
  2513.     #$sc->Frame;
  2514.     m_editVNodesDisplay($sc, $km, $vu, $vl, $vupar, $vlpar, @tags);
  2515.  
  2516.     sub m_editVNodesDisplay {
  2517.         printf "(T) %s(@_)\n", commons::whoami() if $tree;
  2518.  
  2519.         my ($sc, $km, $vu, $vl, $vupar, $vlpar, @tags) = @_;
  2520.        
  2521.         # Loop through layers    
  2522.         for (my $i = 0; $i <= $#{$km}; $i++){
  2523.             my $f = $sc -> Frame (-borderwidth => 1, -relief => 'solid', #-background => "green",
  2524.                 #-foreground => "blue", -label =>"Layer B ".($i+1)
  2525.             )     -> pack (-side=>'top', -anchor => 'w', -fill => 'both', -expand => 'yes');
  2526.            
  2527.             #################################
  2528.             my $c = 'grey';
  2529.             $c = $REFRACTED[$i] if ($REFRACTED[$i]);
  2530.            
  2531.             $f -> Label(-text => "Layer B ".($i+1), -background => $c
  2532.             ) -> pack (-side=>'top', -anchor => 'w', -fill => 'both', -expand => 'yes');
  2533.            
  2534.            
  2535.             # Loop through nodes for each layer
  2536.             for (my $j = 0; $j <= $#{$km->[$i]}; $j++){
  2537.                 #print "$i,$j: $km->[$i]->[$j]\n";
  2538.                 my $options = "lightgrey";
  2539.                 if ( @tags && $i == $tags[1]-1 && $j == $tags[2]){
  2540.                     $options = 'yellow';
  2541.                 }
  2542.                 my $fr = $f -> Frame (-borderwidth => 1, -relief => 'solid')
  2543.                  -> pack (-side => 'left', -fill => 'both', -expand => 'yes');
  2544.            
  2545.                 $fr -> Entry ( -width => 6, -background => $options,
  2546.                     -textvariable => \$km->[$i]->[$j])-> pack (-side=>'top', -anchor => 'w', -fill => 'x');
  2547.                 $fr -> Entry ( -width => 4, -background => $options,
  2548.                     -textvariable => \$vu->[$i]->[$j])-> pack (-side=>'top', -anchor => 'w', -fill => 'x');
  2549.                 $fr -> Entry ( -width => 4, -background => $options,
  2550.                     -textvariable => \$vupar->[$i]->[$j])-> pack (-side=>'top', -anchor => 'w', -fill => 'x');
  2551.                 $fr -> Entry ( -width => 4, -background => $options,
  2552.                     -textvariable => \$vl->[$i]->[$j])-> pack (-side=>'top', -anchor => 'w', -fill => 'x');
  2553.                 $fr -> Entry ( -width => 4, -background => $options,
  2554.                     -textvariable => \$vlpar->[$i]->[$j])-> pack (-side=>'top', -anchor => 'w', -fill => 'x');
  2555.                     #print "Added frame $fr\n";
  2556.             } # Loop through nodes
  2557.         } # Loop through layers
  2558.         #$sc->see($fr);
  2559.         #return $fr;
  2560.     } # sub m_editVNodesDisplay
  2561.     #print "Done\n";
  2562.     #$sc->see($fr);
  2563.     #print "Done, see $fr\n";
  2564. }
  2565.  
  2566. sub i_BindTime {
  2567.  
  2568. =PROGhead2 i_BindTime()
  2569.  
  2570. Subroutine that organizes all mouse and keyboard interactions with the
  2571. traveltime diagram: zooming and selecting of picks.
  2572.  
  2573. =cut
  2574.  
  2575. =USERhead3 Mouse operations in traveltime diagram
  2576.  
  2577. =USERhead4 Measure rms-values of reflection hyperbola
  2578.  
  2579.  - Right click on a pick and choose 'Measure rms velocity'
  2580.  - First hyperbola is drawn
  2581.  - Click and hold the hyperbola. Mouse movement in x-direction changes
  2582.    the rms velocity, y-movements change the time. Y-mouse position is used
  2583.    as t0. Only for large velocities y-position is used as anchor for hyperbola
  2584.  - Right click on the hyperbola to delete it.
  2585.  
  2586. =cut
  2587.  
  2588.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  2589.     # Make Time zoomaable
  2590.     $lzd->CanvasBind('<3>'                => [\&zoomCanvasInit,"t"]);
  2591.     $lzd->CanvasBind('<B3-Motion>'        => [\&zoomCanvasSize,"t"]);
  2592.     $lzd->CanvasBind('<B3-ButtonRelease>' => \&zoomCanvasFinish);
  2593.     $lzd->CanvasBind('<2>'                => \&zoomOriginal);
  2594.    
  2595.     # Editing of picks
  2596.     $lzd->bind( 'PICK' => '<3>'     => [\&t_Menu]);
  2597.     $lzd->bind( 'PICK' => '<B3-ButtonRelease>' => sub {$lzd->delete('ZOOM')} );
  2598.     $lzd->bind( 'PICK' => '<1>'     => [\&tc_choosePicks]);
  2599.    
  2600.     # Measuring velocity, print current position
  2601.     $lzd->CanvasBind('<1>'                => \&t_B1click);
  2602.     $lzd->CanvasBind('<B1-Motion>'        => \&t_B1motion);
  2603.     $lzd->CanvasBind('<B1-ButtonRelease>' => \&t_B1release );
  2604.    
  2605.     $lzd->bind('RMS' => '<B1-Motion>' => \&t_B1clickRMS);
  2606.     $lzd->bind('RMS' => '<3>' => sub {$lzd->delete('RMS');});
  2607. }
  2608.  
  2609. sub t_B1click {
  2610.  
  2611. =PROGhead2 t_B1click()
  2612.  
  2613. Get's current coordinates, transforms them into model coordinates and displays
  2614. them in status bar
  2615.  
  2616. =cut
  2617.  
  2618.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  2619.  
  2620.    # Display current coords      
  2621.    my $oldx = $lzd->canvasx($Tk::event->x);
  2622.    my $oldy = $lzd->canvasy($Tk::event->y);
  2623.    
  2624.    print "(DEV) mouse screen coordinates: >$oldx,$oldy<\n" if $dev;
  2625.    
  2626.    my ($olds, $oldt) = $model->screen2model([$oldx, $oldy], "time");
  2627.    
  2628.    my $msg = sprintf ("\nx = %6.2fkm, t = %4.2fs",
  2629.            $olds, $oldt);
  2630.    
  2631.    _printStatusMessage($msg);
  2632.    $lzd->Tk::focus;
  2633. }
  2634.  
  2635. sub t_B1clickRMS {
  2636.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  2637.  
  2638.    # Enable global flag RMS for moving RMS-hyperbola when clicking on
  2639.    # the hyperbola
  2640.    
  2641.    $RMS = 1;
  2642.    #print "Enable moving of rms hyperbola\n";
  2643. }
  2644.  
  2645. sub t_B1motion {
  2646.  
  2647. =PROGhead2 t_B1motion()
  2648.  
  2649. Draws a line for measuring velocity or move rms hyperbola
  2650.  
  2651. =cut
  2652.  
  2653.    my $x = $lzd->canvasx($Tk::event->x);
  2654.    my $y = $lzd->canvasy($Tk::event->y);            
  2655.  
  2656.    if ($RMS) {
  2657.        t_hyperbola();
  2658.    }
  2659.     else {    # Only measure velocity if no rms velocity is ongoing
  2660.        # Is there already a line drawn?
  2661.        if ($lzd->coords('APPARENTVELOCITY')) {
  2662.            # There's already a line. Get coordinates of the line
  2663.             # and update the second point to current coordinates
  2664.             my @coords = $lzd->coords('APPARENTVELOCITY');
  2665.             $coords[2] = $x;
  2666.             $coords[3] = $y;
  2667.             $lzd->coords('APPARENTVELOCITY', @coords);
  2668.        
  2669.         } else {
  2670.             # There's no line. Draw one with current coordinates
  2671.             my @line = ($x, $y, $x, $y);
  2672.             $lzd->createLine(@line,
  2673.                -fill => 'red',
  2674.                -arrow => 'last',
  2675.                -tags    => ['APPARENTVELOCITY'],
  2676.                );
  2677.         }
  2678.     } # no 'RMS' found
  2679. }
  2680.  
  2681. sub t_B1release {
  2682.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  2683.  
  2684.     # Finish. Clean up
  2685.     my $id      = $lzd->find(qw/withtag current/);
  2686.     my @tags = $lzd->gettags($id);
  2687.     #print "(DEV) tags >@tags<, id >@$id<\n" if $dev;
  2688.     my $msg = " @tags";
  2689.    
  2690.     $lzd->delete('ZOOM');
  2691.    
  2692.     if ( $lzd->coords('APPARENTVELOCITY') ) {
  2693.         # Get coordinates of the measuring arrow
  2694.         my ($x1, $y1, $x2, $y2) = $lzd->coords('APPARENTVELOCITY');
  2695.         my ($olds, $oldt) = $model->screen2model([$x1, $y1], "time");
  2696.         $lzd->delete('APPARENTVELOCITY');    
  2697.                        
  2698.         my $x = $lzd->canvasx($Tk::event->x);
  2699.         my $y = $lzd->canvasy($Tk::event->y);
  2700.        
  2701.         my ($s, $t) = $model->screen2model([$x, $y], "time");
  2702.         my $ds = ($s-$olds);
  2703.         my $dt = ($t-$oldt);
  2704.        
  2705.         # Concatenate message about apparent velocity
  2706.         my $v;
  2707.         if ($ds == 0) {
  2708.         # Measurement was vertical
  2709.             $msg = sprintf ("; dt = %4.2fs",$dt) unless ($dt == 0);
  2710.             $v = 0;
  2711.            
  2712.         } elsif ($dt == 0) {
  2713.         # Measurement was horizontal
  2714.             $v = $CONFIG{vred};
  2715.             $msg = sprintf ("; ds = %4.2fkm , v = %4.1fkm/s", $ds, $v);
  2716.            
  2717.         } else {
  2718.         # Find apparent velocity of measurement
  2719.            
  2720.             if ($vredbutton ==1){
  2721.             # Traveltime display is reduced
  2722.                 #                      abs necessary for measurements to the left
  2723.                 $v = abs( $ds / ($dt + abs($ds)/$CONFIG{vred}) );
  2724.             } else {
  2725.                 $v = $ds/$dt;
  2726.             }
  2727.             $msg = sprintf (" to x = %6.2fkm, t = %4.2fs; ds = %6.2fkm, dt = %4.2fs,"
  2728.                  ." v = %4.1fkm/s",
  2729.                 $s, $t, $ds, $dt, $v);
  2730.        
  2731.         }
  2732.     } # Velocity has been measured
  2733.    
  2734.     if (@choosePicks > 1 ) {
  2735.         $msg = $msg." -- selected ".(@choosePicks-1);
  2736.     }
  2737.  
  2738.     $RMS = 0;   # Stop moving of rms hyperbola
  2739.     _printStatusMessage($msg);
  2740. }
  2741.  
  2742.  
  2743. sub t_Menu {
  2744.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  2745.  
  2746.     my ($self, $x, $y) = @_;
  2747.     my $cx = $lzd->canvasx($Tk::event->x);
  2748.     my $cy = $lzd->canvasy($Tk::event->y);
  2749.    
  2750.     $lzd->delete('ZOOM');
  2751.    
  2752.     my $id      = $lzd->find(qw/withtag current/);
  2753.     my @tags = $lzd->gettags($id);
  2754.     print "Open right click time menu tags >$tags[1]<, id @$id\n";
  2755.    
  2756.     @tags = grep {$_ ne 'current'} @tags;
  2757.     my $type = $tags[0];
  2758.     my @coords = $model->screen2model([$cx, $cy], "space");
  2759.     #print "Type $type, @coords\n";
  2760.    
  2761.     # Clean menu, then adding entrys for this type of object
  2762.     $menuRightClick->delete(0, 'last');
  2763.  
  2764.     if ( $type eq 'PICK' ) {
  2765.         if ( $CONFIG{zpdir} && $CONFIG{zp2ray} ){
  2766.             $menuRightClick->add('command', -label => 'Edit phase',                
  2767.                 #-command => [\&model::edit, $model, "tags", \@tags, "value", \@coords, "op" , "editPhase"]
  2768.                 -command => [\&tc_editPhase, \@tags]
  2769.                 );
  2770.         }
  2771.         $menuRightClick->add('command', -label => 'Measure rms velocity',
  2772.             -command => [\&t_rms, \@tags, $cx, $cy]
  2773.             );    
  2774.         }
  2775.     $menuRightClick->Popup(qw/-popover cursor -popanchor sw/);
  2776.     #$lzd->delete('ZOOM');
  2777. }
  2778.  
  2779.  
  2780. ########################################################################
  2781.  
  2782. sub b_drawAll{
  2783.  
  2784. =PROGhead2 b_drawAll()
  2785.  
  2786. Extracts all enabled phases and stations from C<$RAYSTATUS> and
  2787. C<stationlist> and calls
  2788. C<< $model->drawPhaseStationList("phases" => [@DRAWNPHASES], "stations" => [@stationlist]) >>.
  2789.  
  2790. =cut
  2791.  
  2792.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  2793.     # draws rays for DRAWNPHASES and stationlist
  2794.  
  2795.     @DRAWNPHASES = ();
  2796.     @DRAWNSTATIONS = ();
  2797.     foreach (keys(%RAYSTATUS)){
  2798.         #say "$_ is my phase, draw? <$RAYSTATUS{$_}>";
  2799.         if ($RAYSTATUS{$_} == 1) {push @DRAWNPHASES, "$_";}
  2800.     }
  2801.     foreach my $st (keys(%stationlist)) {
  2802.         if ($stationlist{$st}[3] == 1) {
  2803.             #print "Station >$st< is enabled ($stationlist{$st}[3])\n";
  2804.             push @DRAWNSTATIONS, $stationlist{$st}[4];
  2805.         }
  2806.     }
  2807.     #warn "WARNING!! This function is currently disabled!!\n";
  2808.     say "(DEV) b_drawAll() Draw phases @DRAWNPHASES and rays @DRAWNRAYS for @DRAWNSTATIONS" if $dev;
  2809.     $model->drawPhaseStationList("rays" => [@DRAWNPHASES], "stations" => [@DRAWNSTATIONS], "phases" => \@DRAWNPHASES);
  2810.  
  2811. }
  2812.  
  2813. sub b_drawStation{
  2814.  
  2815. =PROGhead2 b_drawStation()
  2816.  
  2817. Draw all picks and rays for a single station. Is called from station button
  2818. and right click on station.
  2819.  
  2820. =cut
  2821.  
  2822.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  2823.     my $st = shift;
  2824.     #print "p::b_drawStation $st, $stationlist{$st}[3]\n";
  2825.     $model->drawSingleStationData($st, $stationlist{$st}[3]);
  2826.     $station = $st if ($stationlist{$st}[3] == 1);
  2827. }
  2828.  
  2829. #sub b_drawPhase {
  2830.  
  2831. #=PROGhead2 b_drawPhase($rc, $ph)
  2832.  
  2833. #Called when pressing a ray button
  2834.  
  2835. #=cut
  2836.  
  2837.     ##print "Got @_\n";
  2838.     #my $rc = $_[0];
  2839.     #my $ph = $_[1];
  2840.  
  2841.     ##print "Phase @_:".
  2842.           ##" $RAYSTATUS{@_[0]} on/off\n";
  2843.    
  2844.     #$RAYSTATUS{$rc} = $RAYSTATUS{$ph} if ( $rc eq '-' );
  2845.     #$RAYSTATUS{$ph} = $RAYSTATUS{$rc} unless ( $RAYSTATUS{$ph} );
  2846.     #print "p::b_drawPhase >$rc< >$RAYSTATUS{$rc}<, >$ph< >$RAYSTATUS{$ph}<\n";
  2847.     #$model->drawPhase('ray' => [$rc, $RAYSTATUS{$rc}], 'phase' => [$ph, $RAYSTATUS{$ph}]);
  2848.    
  2849. #}
  2850.  
  2851.  
  2852. sub _set{
  2853.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  2854.     my @args = @_;
  2855.     my $var = $args[0];  # This variable shall be changed, eg, vred, picks...
  2856.     my $value = $args[1];
  2857.        
  2858.     $model->set($var => $$value);
  2859. }
  2860.  
  2861. sub b_export {
  2862.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  2863.     # This programms export currently traced phases and stations to your
  2864.     # configured export-path.
  2865.     # It also writes the current version number into a file to identify
  2866.     # the exported data to a specific model.
  2867.    
  2868.     # Check if outputdirectory exists
  2869.     unless (-d "$CONFIG{exportpath}" ) {
  2870.         print "Create output directory $CONFIG{exportpath}\n";
  2871.         mkpath($CONFIG{exportpath});
  2872.     }
  2873.    
  2874.     my $file = "$CONFIG{exportpath}/version.dat";
  2875.     my $version = $model->_get('version');
  2876.     $model->exportRays();
  2877.     print "Model is version number $version\n";
  2878.     open (FILE, ">$file") or die "Can't open $file\n";
  2879.     print FILE "$version\n";
  2880.     print FILE "vred=  $CONFIG{vred}\n";
  2881.     close(FILE);
  2882.     copy ("v.in", "$CONFIG{exportpath}");
  2883.  
  2884.     $model->writeXZV();
  2885.  
  2886. =USERhead3 Exporting rays and picks
  2887.  
  2888. You can either start PRay with the command line option C<-export> (C<p.pl -export>) to just
  2889. export rays but do not display the model and
  2890. interactive GUI or you can use the File-Menu to export picks from the living GUI.
  2891. This will write rays, calculated and manual picks to your configured export-path in
  2892. C<p.config> (or default into the current directory)
  2893. ready for GMT to plot. Format was choosen to be compatible with Tobi's C<make_rays>-script.
  2894.  
  2895. Exported times are reduced with current reduction velocity if exported from GUI or
  2896. using C<vred> in C<p.config>.
  2897.  
  2898. If exporting from GUI, data for currently traced stations is exported.
  2899.  
  2900. If exporting from command line, another C<r.in>-formated file named C<r.export>
  2901. is used to trace data. This way you can have an extra file containing all station
  2902. and phases needed for full plotting of your profile without having to manually switch on
  2903. and off all stations and phases.
  2904.  
  2905. Velocity nodes are also exported
  2906.  
  2907. =cut
  2908.  
  2909. }
  2910.  
  2911. sub b_igmas {
  2912.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  2913.    # This programms converts model to igmas format and saves it to your
  2914.    # configured export-path.
  2915.    
  2916.    # Check if outputdirectory exists
  2917.    unless (-d "$CONFIG{exportpath}" ) {
  2918.        print "Create output directory $CONFIG{exportpath}\n";
  2919.        mkpath($CONFIG{exportpath});
  2920.    }
  2921.    
  2922.    my $file = "$CONFIG{exportpath}/version.dat";
  2923.    my $version = $model->_get('version');
  2924.    $model->exportIgmas();
  2925.  
  2926.    #open (FILE, ">$file") or die "Can't open $file\n";
  2927.    #print FILE "$version\n";
  2928.    #print FILE "vred=  $CONFIG{vred}\n";
  2929.    #close(FILE);
  2930.  
  2931. =USERhead3 Convert model to igmas format
  2932.  
  2933. This function is currently in development
  2934.  
  2935. =cut
  2936.  
  2937. }
  2938.  
  2939. sub b_AllRays {
  2940.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  2941.   #say " All rays are drawn (or not)";
  2942.    foreach (sort(keys(%RAYSTATUS))) {
  2943.        $RAYSTATUS{$_} = $allRaysButton;
  2944.        #print "PHASE $_ value $RAYSTATUS{$_}\n";
  2945.        $model->drawPhase($_, $RAYSTATUS{$_});
  2946.    }
  2947. }
  2948.  
  2949. sub b_AllRfl {
  2950.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  2951.    
  2952.    foreach (sort(keys(%RAYSTATUS))) {        
  2953.        #my @t = split(/\./, $_);
  2954.        #my $p = substr($_,-1);
  2955.        
  2956.        #if ($t[1]%2 == 0 ) { # included multiples like 1.4, 1.6
  2957.        #if ($t[1] == 2 ) {    # No multiples    
  2958.        #if ($p == 2 ) {    # No multiples
  2959.        if ( $_ =~ m/.2/ ) {  
  2960.            print "Set $_ to $allRflButton\n";
  2961.            $RAYSTATUS{$_} = $allRflButton;
  2962.            
  2963.            # get phasecode and change status
  2964.            #$RAYSTATUS{$CODES->get(ray => $_)} = $allRflButton;
  2965.            
  2966.            #$model->drawPhase($_, $RAYSTATUS{$_});
  2967.            
  2968.        }
  2969.    }
  2970.    b_drawAll();    
  2971. }
  2972.  
  2973. sub b_AllRfr {
  2974.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  2975.    print "Set Refractions\n";
  2976.    foreach (sort(keys(%RAYSTATUS))) {        
  2977.        my @t = split(//, $_);
  2978.        if ($t[-1] == 1 ) {
  2979.            print "Set $_ to $allRfrButton\n";
  2980.            $RAYSTATUS{$_} = $allRfrButton;
  2981.            $model->drawPhase($_, $RAYSTATUS{$_});
  2982.        }
  2983.    }    
  2984. }
  2985.  
  2986. sub b_AllMul {
  2987.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  2988.    print "Switch on multiples\n";
  2989.    foreach (sort(keys(%RAYSTATUS))) {        
  2990.        #my @t = split(/\./, $_);
  2991.        #if ($t[1] >= 4  ) {
  2992.        my $p = substr($_,-1);
  2993.        if ($p >= 4  ) {  
  2994.            print "Set $_ to $allRfrButton\n";
  2995.            $RAYSTATUS{$_} = $allMulButton;
  2996.            $model->drawPhase($_, $RAYSTATUS{$_});
  2997.        }
  2998.    }    
  2999. }
  3000.  
  3001. sub b_getPhases {
  3002.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  3003.    my $phase = ''; # new version to go to
  3004.    
  3005.    my $dia = $mw->Toplevel( -popover => $mw,
  3006.                -title => "$PROG: Find phases",
  3007.                );
  3008.    
  3009.     $dia->LabEntry (  
  3010.                    -label        => 'Find stations with phase',
  3011.                    -labelPack    => [qw/-side left -anchor w -expand no -fill x/],
  3012.                    -textvariable => \$phase,
  3013.                    -width => '6'
  3014.                    )-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'no');
  3015.  
  3016.    my $text = $dia->ROText(-width => '30',
  3017.     #-height => 8,
  3018.    -borderwidth => 0)
  3019.        -> pack (-side=>'top', -anchor => 'w', -fill => 'both', -expand => 'yes');
  3020.  
  3021.    #my $ans = $dia->Show;
  3022.    #print "Dialog endet with $ans, km $km, vu $vu, vl $vl, vupar $vupar, vlpar $vlpar\n";
  3023.    #if ($ans eq "Done") {
  3024.        #$model->edit("op" => "edit", "tags" => \@tags, "value" => [$km, $vu, $vl, $vupar, $vlpar]);
  3025.    #}  
  3026.    $dia->Button(-text=>"Find",
  3027.            -command => sub{
  3028.                print "Get phases $phase\n";
  3029.                my $stations = $model->getPhase($phase);
  3030.                $text->configure(-state => 'normal');
  3031.                $text->delete('0.0','end');
  3032.                $text->insert('end', "Found stations: \n$stations");
  3033.                 $text->configure(-state => 'disabled');
  3034.    }, -width => 10)->pack(qw/-side left/);
  3035.    $dia->Button(-text=>"Close", -command => [$dia => 'destroy'], -width => 10)->pack(qw/-side left /);
  3036.    
  3037. }
  3038.  
  3039.  
  3040. sub b_status {
  3041.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  3042.    # Get model-status within a velocity range
  3043.    
  3044.    
  3045.    my $dia = $mw->Toplevel( -popover => $mw,
  3046.                -title => "$PROG: Get model status",
  3047.                );
  3048.    
  3049.  
  3050.  
  3051.    # Display results
  3052.    my $text = $dia->ROText(-width => '50',-state => 'disabled',
  3053.     -height => 36,
  3054.    -borderwidth => 0)
  3055.        -> pack (-side=>'top', -anchor => 'w', -fill => 'both', -expand => 'yes');
  3056.  
  3057.               my $stat = $model->status;
  3058.                $text->configure(-state => 'normal');
  3059.                $text->delete('0.0','end');
  3060.                $text->insert('end', "$stat");
  3061.                 $text->configure(-state => 'disabled');
  3062.  
  3063.    $dia->Button(-text=>"Close", -command => [$dia => 'destroy'], -width => 10)->pack(qw/-side left /);
  3064.    
  3065. }
  3066.  
  3067.  
  3068. sub b_status_range {
  3069.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  3070.    # Get model-status within a velocity range
  3071.    
  3072.    my @range = (150, 350);   # Array with specified range
  3073.    
  3074.    my $dia = $mw->Toplevel( -popover => $mw,
  3075.                -title => "$PROG: Get model status",
  3076.                );
  3077.    
  3078.     $dia->LabEntry (  
  3079.                    -label        => 'from km',
  3080.                    -labelPack    => [qw/-side left -anchor w -expand no -fill x/],
  3081.                    -textvariable => \$range[0],
  3082.                    -width => '6'
  3083.                    )-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'no');
  3084.    
  3085.     $dia->LabEntry (  
  3086.                    -label        => 'to km',
  3087.                    -labelPack    => [qw/-side left -anchor w -expand no -fill x/],
  3088.                    -textvariable => \$range[1],
  3089.                    -width => '6'
  3090.                    )-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'no');
  3091.  
  3092.  
  3093.    # Display results
  3094.    my $text = $dia->ROText(-width => '50',-state => 'disabled',
  3095.     -height => 36,
  3096.    -borderwidth => 0)
  3097.        -> pack (-side=>'top', -anchor => 'w', -fill => 'both', -expand => 'yes');
  3098.  
  3099.    #my $ans = $dia->Show;
  3100.    #print "Dialog endet with $ans, km $km, vu $vu, vl $vl, vupar $vupar, vlpar $vlpar\n";
  3101.    #if ($ans eq "Done") {
  3102.        #$model->edit("op" => "edit", "tags" => \@tags, "value" => [$km, $vu, $vl, $vupar, $vlpar]);
  3103.    #}  
  3104.    $dia->Button(-text=>"Get",
  3105.            -command => sub{
  3106.                print "Get model statistics for range @range\n";
  3107.                my $stat = $model->status('range' => \@range);
  3108.                $text->configure(-state => 'normal');
  3109.                $text->delete('0.0','end');
  3110.                $text->insert('end', "$stat");
  3111.                 $text->configure(-state => 'disabled');
  3112.    }, -width => 10)->pack(qw/-side left/);
  3113.    $dia->Button(-text=>"Close", -command => [$dia => 'destroy'], -width => 10)->pack(qw/-side left /);
  3114.    
  3115. }
  3116.  
  3117. =USERhead3 Phases, Phasenumbering
  3118.  
  3119. How to get phases into Pray?
  3120.  
  3121.  
  3122. Phase numbering is based on numbering used in rayinvr. Phasecodes are
  3123. formated in L.T or LT. With L for layer number and T for type of ray
  3124.  
  3125. 1 = refracted in layer L
  3126. 2 = reflected at bottom of layer L
  3127. 3 = head wave at bottom of layer L
  3128.  
  3129. =cut
  3130.  
  3131. sub b_changeStation {
  3132.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  3133.    print "Current station selected is using $station\n";
  3134.    ##my @list=keys(%stationlist);
  3135.    #foreach (keys(%stationlist)){
  3136.        #print "my key $_\n";
  3137.        #if ($station eq $stationlist{$_}[0]){
  3138.            #print "Found my station!! $_\n";            
  3139.            #$station=$_;
  3140.        #}
  3141.    #}
  3142.    #print "Station is now $station\n";
  3143.  
  3144. }
  3145.  
  3146. sub b_c2v {
  3147.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  3148. _printStatusMessage("\nConvert c.in to v.in");
  3149. system ("c2v << EOL
  3150.  
  3151.  
  3152. EOL" );
  3153.  
  3154. }
  3155.  
  3156. sub b_v2c {
  3157.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  3158. _printStatusMessage("\nConvert v.in to c.in");
  3159. system ("v2c << EOL
  3160.  
  3161.  
  3162. EOL" );
  3163. }
  3164.  
  3165. sub b_viewContours {
  3166.    
  3167.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  3168.    # If file does not exist, create it
  3169.    if ( ! -f "contours.ps" ) {
  3170.        $model->set("contours",1);
  3171.        $model->set("contours",0);
  3172.    }
  3173.    system("gv contours.ps &");
  3174.  
  3175. }
  3176.  
  3177. sub b_modelDifferences {
  3178.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  3179.    
  3180.    _printStatusMessage("\nCreate GMT-Difference plot between this and last version");
  3181.  
  3182.    my $v1 = $VERSION;
  3183.    my $v2 = _GetVersionNumber();
  3184.  
  3185.    my $m =   $mw->Dialog(-popover => $mw,
  3186.        -title => "Compare versions",
  3187.        -buttons => ['Done', 'Cancel']
  3188.        );
  3189.    
  3190.    my $text = $m->ROText(-width => '30', -height => 6, -wrap => 'word', -borderwidth => 0)
  3191.    -> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
  3192.  
  3193.    $text->insert('end',
  3194.                 "Please choose versions to compare:\n\n"
  3195.                ."Current version : $v1\n"
  3196.                ."Last version in history: $v2");
  3197.    
  3198.    $m->LabEntry ( -label        => 'compare version ',
  3199.                   -labelPack    => [qw/-side left -anchor w -expand yes -fill both/],
  3200.                   -textvariable => \$v1,-width => 6,
  3201.                )-> pack (-side=>'top', -anchor => 'e', -fill => 'none', -expand => 'yes');
  3202.  
  3203.    $m->LabEntry ( -label        => 'to version ',
  3204.                  -labelPack    => [qw/-side left -anchor w -expand yes -fill both/],
  3205.                  -textvariable => \$v2, -width => 6,
  3206.                  )-> pack (-side=>'top', -anchor => 'e', -fill => 'none', -expand => 'no');
  3207.  
  3208.    if ($m->Show eq "Done") {
  3209.        _printStatusMessage("\nCompare $v1 to $v2");
  3210.        #system('cd $RI/history/;'." $PRAYPATH/modeldiff.tcsh $v1 $v2 &");
  3211.        system("$PRAYPATH/scripts/modeldiff.tcsh $v1 $v2 &");
  3212.    }
  3213. }
  3214.  
  3215. sub b_resolution {
  3216.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  3217.    
  3218.  
  3219.    _printStatusMessage("\nSet all partial derivatives, write model to file, run dmplsqrt and make resolution plot");
  3220.  
  3221.    # 1. set par deriv for all layer
  3222.    #$model->editAllParDerivs();
  3223.    
  3224.    # Write model to v.in
  3225.    #b_writeModel("Set all partial derivatives for resolution calculation");
  3226.    
  3227.    ## 2. run rayinvr
  3228.    #b_rayinvr();
  3229.    
  3230.    # 3. run dmplsqrt (exports resolution)
  3231.    #b_dmpl("dmplsqrt to calculate resolution");
  3232.    
  3233.    # 4. Draw resolution plot
  3234.    my $cmd = $CONFIG{resolution};
  3235.    print "(DEV) Run >$cmd< to plot resolution grid\n" if $dev;
  3236.    system($cmd);
  3237.    
  3238. }
  3239.  
  3240. sub b_writeModel {
  3241.  
  3242. =PROGhead2 b_writeModel()
  3243.  
  3244. -_historyAdd()     # Copy for undo Button
  3245. - $model->writeVin
  3246. - b_rayinvr()
  3247.  
  3248.            _writeStatus();
  3249. - _historyAdd()    # copy current v.in
  3250. - $verion--
  3251.  
  3252. =cut
  3253.  
  3254.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  3255.    # Asks if you want to continue. Current c.in/v.in are overwritten and
  3256.    # backuped to history/v.$VERSION
  3257.    my $comment = shift;
  3258.    my $msg = "Do you want to write v.in and run rayinvr?\n\n"
  3259.             ."A backup-file called history/v.$VERSION will be created. You can read".
  3260.              " it with the undo button.\n"
  3261.              ."\n-----------------------------------\n"
  3262.              ."You can add a comment for this model version. Comments get saved to "
  3263.              ."file $commentfile when quitting PRay via menu.\n"
  3264.              ."\nComment:"
  3265.              ;
  3266.                
  3267.    my $win = $mw->Toplevel( -popover => $mw,
  3268.                -title => "$PROG: Write v.in?",
  3269.                #-text => $msg,
  3270.                #-buttons => ['Yes', 'No'] #, -default_button => 'No'
  3271.                );
  3272.    
  3273.    my $dia = $win->Frame(-borderwidth => 5, -relief => 'flat')
  3274.        -> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
  3275.    my $text = $dia->ROText(-width => '40', height => '14', -borderwidth => 3, -relief => 'flat', -wrap => 'word')
  3276.        -> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
  3277.        
  3278.    $text->insert('end', $msg);
  3279.    $text->configure(-state => 'disabled');
  3280.    
  3281.    my $entry = $dia -> Entry (  
  3282.                    #-label        => 'Add comment',
  3283.                    #-labelPack    => [qw/-side top -anchor s -expand yes -fill both/],
  3284.                    -textvariable => \$comment,
  3285.                    -width => '40',
  3286.                    )-> pack (-side=>'top', -anchor => 'n', -fill => 'x', -expand => 'yes');
  3287.    
  3288.    #my $ans = $dia->Show;
  3289.    
  3290.    my $button = $dia->Button(-text=>"Yes", -command =>
  3291.    sub {
  3292.        $win->destroy;
  3293.        _historyAdd();    # Make a copy for the undo-Button
  3294.        $model->writeVin;
  3295.        $model->set("version" => $VERSION); #TODO muss das nicht in historyAdd() ?
  3296.        b_rayinvr();
  3297.        
  3298.        _historyAdd();     # copy the current v.in
  3299.        $VERSION--;        # ???? _historyAdd increases version number.
  3300.  
  3301.            _writeStatus();
  3302.  
  3303.        if (defined $comment && $comment ne '') {
  3304.            print "Comment for version $VERSION is >$comment<\n";
  3305.            $COMMENTS{$VERSION} = $comment;
  3306.        }
  3307.        _setWindowTitle();
  3308.    }
  3309.    , -width => 10)->pack(qw/-side left  -anchor e/);
  3310.  
  3311.    $dia->Button(-text=>"No", -command => [$win => 'destroy'], -width => 10)->pack(qw/-side left -anchor e/);
  3312.    
  3313.    $entry->focus;
  3314.    
  3315.    # If routine was called with given comment, its from b_resolution
  3316.    # and should be run at once
  3317.    if ( defined $comment ){
  3318.        $button->invoke();
  3319.    }
  3320.    
  3321. }
  3322.  
  3323. sub b_rayinvr {
  3324.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  3325.    #if (defined $pid) {
  3326.        #closerayinvr();
  3327.    #}
  3328.    #$SIG{'CHLD'} = \&waiting;
  3329.    #print "Write r.in\n";
  3330.    #my $RIN = commons::readRin();
  3331.    
  3332.    #commons::writeRin($RIN);
  3333.    print("Starting $CONFIG{rayinvr} ...\n");
  3334.    _printStatusMessage("\nRunning $CONFIG{rayinvr} ...");
  3335.    $mw->update;
  3336.    #defined( my $ripid = fork ) or die "Cannot fork: $!";
  3337.    #print "Childpid:$ripid\n";
  3338.    #unless( $ripid ) {
  3339.        
  3340.        #system($CONFIG{rayinvr});
  3341.        # Removing old files before running helps to recognize segmentation faults
  3342.        system("rm r1.out r2.out; ".$CONFIG{rayinvr});
  3343.        
  3344.        #my $output = `$CONFIG{rayinvr}`;
  3345.        #print $output;
  3346.        
  3347.        #open OUTPUT, "$CONFIG{rayinvr} |";
  3348.        #while (<OUTPUT>){
  3349.            #chomp;
  3350.            #print $..": ".$_."\n";
  3351.        #}
  3352.        #print "\n *****  leaving rayinvr\n";
  3353.        #die;
  3354.        
  3355.        #CORE::exit(0);
  3356.        #print " *** EVEN MORE ***\n";
  3357.    #}
  3358.    #print "RAYINVR is running\n";
  3359.    #sub waiting {
  3360.    #print "wait a bit until finished\n";
  3361.  
  3362.    print "RAYINVR is done\n";
  3363.    # copy r1.out to history
  3364.    print "Copy r1.out to history/r1.$VERSION\n";
  3365.    copy ("r1.out", "history/r1.$VERSION");
  3366.    
  3367.    #my $tmp = `ps ax  | grep -v "grep" | grep "xrayinvr"`;
  3368.    #say "Grep-output $tmp ";
  3369.    #my @pid = split(' ',$tmp);
  3370.    #$pid = $pid[0];
  3371. #    @pid= split(/ /,`ps ax  | grep -v "grep" | grep "xrayinvr"` ) ;
  3372.    #print "PID ARRAY: @pid \n";
  3373.    #print("xrayinvr  PID: ".$pid."\n");
  3374.    #say "Rereading files and update plot now";
  3375.    $model->read("rays", "times" );
  3376.    b_drawAll();
  3377.  
  3378.    #waitpid($ripid, 0);
  3379. #}
  3380. }
  3381.  
  3382. sub b_dmpl {
  3383.  
  3384. =PROGhead2 b_dmpl('comment')
  3385.  
  3386. - _historyAdd()
  3387. - dmplsq
  3388. - model->reset; b_rayinvr
  3389.  
  3390. =cut
  3391.  
  3392.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  3393.    
  3394.    my $comment = shift;
  3395.    
  3396.    _printStatusMessage("\nRun dmplstsqr.. ");
  3397.    print "dmpl: Add history\n" if $debug;
  3398.    _historyAdd();    # Make a copy for the undo-Button
  3399.    print "run dmplsqr\n" if $debug;
  3400.    system("dmplstsqr_new2 > /dev/null");
  3401.    $model->read("vin" );
  3402.    
  3403.    # Write a resolution file
  3404.    print "Reading resolution\n" if $debug;
  3405.    _printStatusMessage(" reading resolution");
  3406.    $model->resolution();
  3407.  
  3408.    
  3409.    #print "Running rayinvr ..\n";
  3410.    #_printStatusMessage("Running rayinvr ..");
  3411.    $model->reset; # Deletes Contours
  3412.    #$model->order; # Draws contours
  3413.    #b_rayinvr;
  3414.  
  3415.    _historyAdd();     # copy the current v.in
  3416.    $VERSION--;        # ???? _historyAdd increases version number.
  3417.    
  3418.    
  3419.  
  3420.    my @t = localtime(time);
  3421.    my $t = sprintf "%02d.%02d.%4d %02d:%02d",$t[3],$t[4]+1,$t[5]+1900,$t[2],$t[1],$t[0];
  3422.  
  3423.    $COMMENTS{$VERSION} = "$t -- dmplstsqr";
  3424.    $COMMENTS{$VERSION} = "$comment" if $comment;
  3425.    
  3426.  
  3427.    # c.in still holds the model prior to inversion
  3428.    #print "You should run c2v now, if you don't like the result\n";
  3429.    #_printStatusMessage("\nYou should run v2c now, if you like the result. If not run c2v");
  3430.    ## syncronizing c.in and v.in
  3431.    #b_v2c;
  3432.  
  3433.    
  3434. }
  3435.  
  3436. sub b_undo {
  3437.  
  3438. =PROGhead2 b_undo()
  3439.  
  3440. - _gotoVersion($VERSION-1)
  3441.  
  3442. =cut
  3443.  
  3444.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  3445.    print "\n\n ----------- UNDO -------------\n";    
  3446.    _gotoVersion($VERSION-1);
  3447.    print "Leavin undo-operation with version $VERSION\n";
  3448. }
  3449.  
  3450.  
  3451. sub b_redo {
  3452.  
  3453. =PROGhead2 b_redo()
  3454.  
  3455. - _gotoVersion($VERSION+1);
  3456.  
  3457. =cut
  3458.  
  3459.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  3460.    print "\n\n +++++++++++ REDO +++++++++++++\n";    
  3461.    _gotoVersion($VERSION+1);
  3462.    print "Leavin redo-operation with version $VERSION\n";
  3463. }
  3464.  
  3465. sub b_gotoVersion {
  3466.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  3467.    my $version = ''; # new version to go to
  3468.    my $m =   $mw->Dialog(-popover => $mw,
  3469.                -title => "$PROG: Go to version",
  3470.                #-text => "Current values are @$tags",
  3471.                -buttons => ['Done', 'Cancel']
  3472.                );
  3473.                
  3474.     $m->LabEntry (  
  3475.                    -label        => 'Version',
  3476.                    -labelPack    => [qw/-side left -anchor w -expand yes -fill both/],
  3477.                    -textvariable => \$version,
  3478.                    -width => '6'
  3479.                    )-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
  3480.  
  3481.    my $text = $m->ROText(-width => '30',
  3482.     #-height => 8,
  3483.    -borderwidth => 0)
  3484.        -> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
  3485.        
  3486.    $text->insert('end', "Marked models are:\n@markedmodels\n\n".
  3487.                "Last version in history: "._GetVersionNumber());
  3488.  
  3489.  
  3490.    if ($m->Show eq "Done") {
  3491.        _printStatusMessage("\nChange to version $version");
  3492.        my $r = _gotoVersion($version);
  3493.        
  3494.        if ( $r == 1 ) { # Error in gotoVersion! No version found
  3495.            b_gotoVersion();
  3496.        }
  3497.        
  3498.   }
  3499. }
  3500.  
  3501. sub b_copytolast {
  3502.  
  3503. =PROGhead2 b_copytolast()
  3504.  
  3505. Function copys current model to last version + 1 found in history and
  3506. therefore enables you to edit without overwriting old models
  3507.  
  3508. - get last version _GetVersionNumber
  3509. - copy to last version + 1
  3510. - go to that version
  3511.  
  3512.  
  3513. =cut
  3514.  
  3515.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  3516.    my $lastVersion = _GetVersionNumber() + 1;
  3517.  
  3518.    my $comment = "= $VERSION";
  3519.    if ($COMMENTS{$VERSION} ) {
  3520.        $comment .= ": $COMMENTS{$VERSION}";
  3521.    }
  3522.    $COMMENTS{$lastVersion} = $comment;
  3523.    
  3524.    print "Copy current model (version $VERSION) to $lastVersion\n";
  3525.    copy ("v.in", "history/v.$lastVersion");
  3526.    
  3527.    _gotoVersion($lastVersion);
  3528. }
  3529.  
  3530. sub _gotoVersion {
  3531.  
  3532. =PROGhead2 _gotoVersion(newVersion, [runrayinvr?])
  3533.  
  3534. Internal routine for changing version. Checks if newVersion exists, copys
  3535. to v.in and updates Window title and global variable $VERSION.
  3536.  
  3537. Returns 0 for no errors, 1 for errors
  3538.  
  3539. =cut
  3540.  
  3541.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  3542.    my $newVersion = shift;
  3543.    my $rayinvr = shift;
  3544.    # if no second argument present, rayinvr will be run
  3545.  
  3546.  
  3547.    my $return = 0;
  3548.    
  3549.    if (-e "history/v.$newVersion" && $newVersion >= 0){
  3550.  
  3551.        _printStatusMessage("\nChange to version $newVersion");
  3552.  
  3553.        # Copy new version and run rayinvr
  3554.        copy ("history/v.$newVersion", "v.in");
  3555.        $mw->update;
  3556.        $model->set("version" => $newVersion);
  3557.        $model->reset;
  3558.        print "Run rayinvr? >$rayinvr<\n" if $debug;
  3559.        if ($rayinvr) {
  3560.            print "Yes\n" if $debug;
  3561.            _printStatusMessage(" and run rayinvr.");
  3562.            
  3563.            b_rayinvr();
  3564.        } else {
  3565.            print "No\n" if $debug;
  3566.            $model->read( "vin");
  3567.            b_drawAll();
  3568.        }
  3569.  
  3570.        $VERSION = $newVersion;
  3571.        # Update title
  3572.        _setWindowTitle();
  3573.        _writeStatus();
  3574.  
  3575.    } else {
  3576.        # No file found
  3577.        _printStatusMessage("\nERROR: There's no file >v.$newVersion<\nChoose a different version!");
  3578.        $return = 1;
  3579.  
  3580.    }
  3581.    return $return;
  3582. }
  3583.  
  3584. sub b_editMarkedmodels {
  3585.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  3586.    my $m =   $mw->Dialog(-popover => $mw,
  3587.                -title => "Edit marked models",
  3588.                #-text => "Please leave list sorted",
  3589.                -buttons => ['Done', 'Cancel']
  3590.                );
  3591.   my $edit = "@markedmodels";
  3592.   print "Edit marked models: $edit\n";
  3593.    $m->LabEntry (  
  3594.                    -label        => 'marked models',
  3595.                    -labelPack    => [qw/-side left -anchor w -expand yes -fill both/],
  3596.                    -textvariable => \$edit,
  3597.                    -width => length($edit)
  3598.                    )-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
  3599.  
  3600.    if ($m->Show eq "Done") {
  3601.        @markedmodels = sort { $a <=> $b } (split /\s+/, $edit);
  3602.        _printStatusMessage("\nChanged marked models to @markedmodels");
  3603.    }
  3604. }
  3605.  
  3606. sub b_mark {
  3607.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  3608.    # mark current $VERSION and ask user for a comment
  3609.    print "Mark model version $VERSION\n";
  3610.    
  3611.    unless ( grep $_ eq  $VERSION, @markedmodels) {
  3612.        push @markedmodels, $VERSION;
  3613.        @markedmodels = sort { $a <=> $b } @markedmodels;
  3614.    }
  3615.    
  3616.    ########
  3617.    my $comment = $COMMENTS{$VERSION};
  3618.    my $msg =
  3619.              "You can add a comment for this model version. Comments get saved to "
  3620.              ."file $commentfile when quitting PRay via menu.\n"
  3621.              ."\nComment:"
  3622.              ;
  3623.                
  3624.    my $win = $mw->Toplevel( -popover => $mw,
  3625.                -title => "$PROG: Add a comment for this model version?",
  3626.                );
  3627.    # The frame gives a nicer window look with it's border. No other function
  3628.    my $dia = $win->Frame(-borderwidth => 5, -relief => 'flat')
  3629.        -> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
  3630.    my $text = $dia->ROText(-width => '40', height => '14', -borderwidth => 3, -relief => 'flat', -wrap => 'word')
  3631.        -> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
  3632.        
  3633.    $text->insert('end', $msg);
  3634.    $text->configure(-state => 'disabled');
  3635.    
  3636.    my $entry = $dia -> Entry (  
  3637.                    -textvariable => \$comment,
  3638.                    -width => '40',
  3639.                    )-> pack (-side=>'top', -anchor => 'n', -fill => 'x', -expand => 'yes');
  3640.  
  3641.    $dia->Button(-text=>"Close", -command =>
  3642.    sub {
  3643.        $win->destroy;
  3644.  
  3645.        if (defined $comment && $comment ne '') {
  3646.            print "Comment for version $VERSION is >$comment<\n";
  3647.            $COMMENTS{$VERSION} = $comment;
  3648.        } else {
  3649.            # Delete commentkey if nothing is entered
  3650.            delete $COMMENTS{$VERSION};
  3651.        }
  3652.    }
  3653.    , -width => 10)->pack(qw/-side left  -anchor e/);
  3654.  
  3655.    $entry->focus;
  3656. ###########
  3657.    
  3658.    print "Models marked: @markedmodels\n";
  3659.    _printStatusMessage("\nModels marked: @markedmodels");
  3660.    
  3661.    # Make contours
  3662.    $model->set( "contours", \1 );
  3663.    $model->set( "contours", \$showContours );
  3664.    
  3665.    # Save r1.out and contours.ps in history
  3666.    print "Copy contours and r1 to history\n";
  3667.    copy ("contours.ps", "history/contours.$VERSION.ps");
  3668.    copy ("r1.out", "history/r1.$VERSION");
  3669. }
  3670.  
  3671. sub b_markforward {
  3672.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  3673.    print "Go to next marked model in list: @markedmodels\n";
  3674.    
  3675.    # find index for next model
  3676.    for ( my $i = 0; $i <= $#markedmodels; $i++ ) {
  3677.        if ( $markedmodels[$i] > $VERSION ) {
  3678.            print "Load version $markedmodels[$i]\n";
  3679.            _gotoVersion($markedmodels[$i]);
  3680.            return;
  3681.        }
  3682.    }
  3683.    
  3684.    print "No version found. Go to last model in history\n";
  3685.    _gotoVersion(_GetVersionNumber());
  3686. }
  3687.  
  3688. sub b_markback {
  3689.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  3690.    print "Go to last marked model. Current version: $VERSION\n";
  3691.    
  3692.    # find index for previous model
  3693.    for ( my $i = $#markedmodels; $i >= 0; $i-- ) {
  3694.        print "Check $i: $markedmodels[$i]\n";
  3695.        if ( $markedmodels[$i] < $VERSION ) {
  3696.            print "Load version $markedmodels[$i]\n";
  3697.            _gotoVersion($markedmodels[$i]);
  3698.            return;
  3699.        }
  3700.    }
  3701.    
  3702.    print "No version found. Go to end of array\n";
  3703.    _gotoVersion($markedmodels[-1]);
  3704. }
  3705.  
  3706.  
  3707. sub b_reload {
  3708.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  3709.    print "Reload v.in\n";
  3710.    
  3711.    # Copied from b_rayinvr;
  3712.    $model->read( "vin" );
  3713.    $showBlocks=0;  # Layers with block information are deleted, when
  3714.                    # reloading the model
  3715.    $model->set(  "blocks" => \$showBlocks );
  3716.    b_drawAll();
  3717. }
  3718.  
  3719.  
  3720. sub b_editRin {
  3721.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  3722.    #print "Pressed Editing R.in\n";
  3723.    my $rin = commons::readRin();
  3724.    #print Dumper($rin);
  3725.    my $stat = commons::readStatxz($CONFIG{stationfile});
  3726.    print "Stationfile: $CONFIG{stationfile}\n";
  3727.    my $dia = $mw->Toplevel(-title => "Edit r.in");
  3728.    commons::displayRin($dia,$rin, $stat);
  3729.    #_printStatusMessage("\nr.in written.");
  3730.    #$rin = b_displayRin($rin);
  3731.  
  3732.    #print Dumper($rin->{ishot});
  3733.    
  3734. }
  3735.  
  3736.  
  3737. sub b_openfiles {
  3738.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  3739.    
  3740.    my $edit = $CONFIG{editor};
  3741.    if ( ! defined $edit ) {
  3742.        _printStatusMessage("\nNo editor defined!! Please set up environment variable \$EDITOR ".
  3743.        "or insert 'editor = youreditor' in $CONFIGFILE");
  3744.        return 0;
  3745.    }
  3746.    
  3747.    defined( my $editpid = fork ) or die "Cannot fork: $!";
  3748.    unless( $editpid ) {
  3749.        my $command = $CONFIG{editor}." $CONFIG{files}\n";
  3750.        system( $command);
  3751.        print "\nStopping child $editpid '$edit'\n";  
  3752.        CORE::exit(0);
  3753.    }
  3754.  
  3755. }
  3756.  
  3757. sub b_zp{
  3758.  
  3759. =PROGhead2 b_zp()
  3760.  
  3761. Start phase picking software. Currently ZP is used. Change this subroutine for
  3762. your own software.
  3763.  
  3764. =cut
  3765.  
  3766. =USERhead3 Connection to picking software
  3767.  
  3768. PRay can start a phase-picking software and provide a station file for
  3769. the currently selected station. At the moment ZP ( C< http://www.soest.hawaii.edu/users/bzelt/ > )
  3770. is used for this purpose and started with
  3771.  
  3772. cd $CONFIG{zpdir}; zp2 $file $par
  3773.  
  3774. C<$File> and C<$par> are either taken from C<statxz>-file column 4 and 5 (see L</statxz>) or
  3775. generated using C<zpFileMask> in C<p.config> (see L</Config-File>)
  3776.  
  3777. =cut
  3778.  
  3779.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  3780.    my $file=$stationlist{$station}[1];
  3781.    my $par=$stationlist{$station}[2];
  3782.    print "Open station $stationlist{$station}[0] $file in zp\n";
  3783.  
  3784.    defined( my $zppid = fork ) or die "Cannot fork: $!";
  3785.    #print "Childpid:$zppid\n";
  3786.    unless( $zppid ) {
  3787.        print "cd $CONFIG{zpdir}; zp2 $file $par  << EOL";
  3788.        system("cd $CONFIG{zpdir}; zp2 $file $par  << EOL
  3789. x
  3790. EOL");
  3791.        warn "\nleaving child";  
  3792.        CORE::exit(0);
  3793.    }
  3794.    print "ZP is running\n";
  3795. }
  3796.  
  3797.  
  3798. sub b_zp2ray {
  3799.  
  3800. =PROGhead2 b_zp2ray
  3801.  
  3802. - Call's $CONFIG{zp2ray}
  3803. - $model->read("times")
  3804. - b_drawAll();
  3805.  
  3806. =cut
  3807.  
  3808. =USERhead3 Update picked phases
  3809.  
  3810. PRay was written with ZP used for picking. ZP needs to export picked phases, which then have
  3811. to be reformatted to C<tx.in> format for rayinvr.
  3812. A program for this task can be started using the button C<zp2ray>. You can configure this button
  3813. in C<p.config> with C<zp2ray>.
  3814.  
  3815. TODO: describe replacements
  3816.  
  3817.  
  3818. =cut
  3819.  
  3820.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  3821.    $file = $stationlist{$station}[1];
  3822.    $file =~ s/head$/pick/ if ($file);
  3823.    
  3824.    if ($station eq "str") {
  3825.        # Current station is the streamer
  3826.        $file = "str100.4.offs.head"
  3827.    } else {
  3828.        
  3829.        unless ($CONFIG{zp2ray}) {
  3830.            _printStatusMessage("\nzp2ray is NOT configured! Use your own method to export data and run rayinvr to read them");
  3831.            return 1;
  3832.        }
  3833.        
  3834.        # It's a normal station for which you can use zp2ray
  3835.        (my $command = $CONFIG{zp2ray}) =~ s/\$dir/$DIR/g;
  3836.         $command =~ s/\$file/$file/g if ($file);
  3837.        print "Export picks for station $station\n";
  3838.        print "Use command: $command\n ";
  3839.        
  3840.        #system ("/projects/nam2011/bin/zp2ray.csh $DIR $file");
  3841.        system ($command);
  3842.        $model->read( "times" );
  3843.  
  3844.        b_drawAll();
  3845.    }
  3846. }
  3847.  
  3848. sub b_reloadTx {
  3849.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  3850.    print "Reload tx.in\n";
  3851.    $model->read( "times" );
  3852.    b_drawAll();
  3853.    
  3854. }
  3855. sub b_extract {
  3856.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  3857.    
  3858.    # Show dialog to enter profile km for extracting 1D velocity profiles
  3859.  
  3860.    #my $m =   $mw->Dialog(-popover => $mw,
  3861.                #-title => "$PROG: Extract 1D velocity profiles",
  3862.                #-text => "Current values are @$tags",
  3863.                #-buttons => ['Extract', 'Cancel']
  3864.                #);
  3865.    
  3866.    my $m = $mw->Toplevel( -popover => $mw,
  3867.                -title => "$PROG: Extract 1D velocity profiles",
  3868.                );
  3869.    
  3870.  
  3871.    my $text = $m->ROText(-width => '30', -height => 3, -borderwidth => 0, -wrap => 'word')
  3872.        -> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');      
  3873.    $text->insert('end', "Enter profile km for extracting 1D velocity-depth profiles as comma seperated list");
  3874.    $text->configure(-state => 'disabled');
  3875.  
  3876.     $m->LabEntry (  
  3877.                    -label        => 'Profile km',
  3878.                    -labelPack    => [qw/-side left -anchor w/],
  3879.                    -textvariable => \$depthvelocityprofiles,
  3880.                    -width => '40'
  3881.                    )-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
  3882.  
  3883.  
  3884.    #if ($m->Show eq "Extract") {
  3885.        #_printStatusMessage("\nExtracting velocity profiles at km $depthvelocityprofiles");
  3886.        #$model->get('1d', $depthvelocityprofiles);
  3887.        #system("$PRAYPATH/vd_plots.csh");
  3888.   #}
  3889.    $m->Button(-text=>"Extract",
  3890.        -command => sub{
  3891.            _printStatusMessage("\nExtracting velocity profiles at km $depthvelocityprofiles");
  3892.            $model->get('1d', $depthvelocityprofiles);
  3893.            
  3894.            # As security measure, write status with correct version
  3895.            # in case two programs are running
  3896.            _writeStatus();
  3897.            system("$PRAYPATH/scripts/vd_plots.csh");
  3898.        }, -width => 10)->pack(qw/-side left/);
  3899.    $m->Button(-text=>"Close", -command => [$m => 'destroy'], -width => 10)->pack(qw/-side left /);
  3900.  
  3901. }
  3902.  
  3903. sub b_quit{
  3904.  
  3905. =USERhead3 Quitting PRay
  3906.  
  3907. Use the quit button in File-menu->Quit to shut PRay down. This gives PRay the
  3908. chance to save current marked model list and version number to F<p.status> and also
  3909. gives you the chance to delete version above your current version.
  3910.  
  3911. =cut
  3912.  
  3913.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  3914.    ################################
  3915.    # Write current programstatus
  3916.    ################################
  3917.    _writeStatus();
  3918.    
  3919.    # Cleaning up history directory
  3920.    my $i = _GetVersionNumber();
  3921.    unless ($i == $VERSION || $VERSION !~ /[0-9]*/ ) {
  3922.        my $yesno_button = $mw->messageBox( -popover => $mw, -title => "$PROG: Deleting history?",
  3923.            -message => "Do you want to delete versions in history directory above"
  3924.            ." current version >$VERSION<?\n"
  3925.            ."\nLast version found is >$i<.\n",
  3926.            -type => "yesnocancel", -default => "no");
  3927.        if ($yesno_button eq "Yes") {
  3928.            print "Deleting history-files\n";
  3929.            if (-d "history") {
  3930.                opendir(DIR, "history") or die $!;
  3931.                my @files = grep { /^v\./ && -f "history/$_"}  readdir(DIR);
  3932.                closedir(DIR);
  3933.                print "Delete versions above $VERSION\n";
  3934.                
  3935.                foreach (@files){
  3936.                    if ($_ =~ m/(\d+)/ && $1 > $VERSION){
  3937.                        # $1 represents the digit selected by regex (\d+)
  3938.                        print "Delete history/$_, version $1\n";
  3939.                        unlink("history/$_");   # Potential Problem if you run it on Windows!!
  3940.                        (my $v = $_) =~ s/v\.//; # remove commentes for deleted modelversion
  3941.                        delete $COMMENTS{$v};
  3942.                    }
  3943.                }
  3944.            }
  3945.        } elsif ($yesno_button eq "Cancel") {
  3946.            print "Abort shutdown\n";
  3947.            return;
  3948.        }
  3949.    }
  3950.  
  3951.    _writeComments();
  3952.  
  3953.    print "##############################################################\n" unless $quiet;
  3954.     print "# Bye bye. Have a nice day, enjoy life without geophysics    #\n" unless $quiet;
  3955.     print "# and remember to PRay                                       #\n" unless $quiet;
  3956.     print "##############################################################\n" unless $quiet;
  3957.  
  3958.     exit;
  3959. }
  3960.  
  3961. sub _writeStatus {
  3962.  
  3963. =PROGhead2 _writeStatus()
  3964.  
  3965. Writes current status of PRay to file p.status. This file may be manually
  3966. manipulated when PRay is not running and you have an idea what you are doing.
  3967. PRay can start without this file.
  3968.  
  3969. =cut
  3970.  
  3971. =USERhead3 Status file
  3972.  
  3973. PRay writes a status file C<p.status> with current program state. This file may be manually
  3974. manipulated when PRay is not running and you have an idea what you are doing.
  3975. PRay can start without this file.
  3976.  
  3977. =cut
  3978.  
  3979.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  3980.     my $file = "p.status";
  3981.  
  3982.     @DRAWNRAYS = ();
  3983.     @DRAWNSTATIONS = ();
  3984.     foreach (sort(keys(%RAYSTATUS))){
  3985.         #say "$_ is my phase, draw? <$RAYSTATUS{$_}>";
  3986.         if ($RAYSTATUS{$_} == 1) {push @DRAWNRAYS, "$_";}
  3987.     }
  3988.  
  3989.     foreach (keys(%stationlist)) {
  3990.         if ($stationlist{$_}[3] == 1) {push @DRAWNSTATIONS, $stationlist{$_}[4];}
  3991.     }
  3992.     print "Write current status to file >$file<\n" unless $quiet;
  3993.     #my $s = "markedmodels = @markedmodels\n"
  3994.     #."version = $VERSION\n"
  3995.     #."depthvelocityprofiles  = $depthvelocityprofiles\n"
  3996.     #. "DRAWNSTATIONS = @DRAWNSTATIONS\n"
  3997.     #. "DRAWNRAYS = @DRAWNRAYS\n";
  3998.    
  3999.     my $s = '';
  4000.    
  4001.     # Update STATUS variable
  4002.     $STATUS{"markedmodels"} = join(' ',@markedmodels);
  4003.     $STATUS{"version"} = $VERSION;
  4004.     $STATUS{"depthvelocityprofiles"} = $depthvelocityprofiles;
  4005.     $STATUS{ "DRAWNSTATIONS"} = join(' ',@DRAWNSTATIONS);
  4006.     $STATUS{ "DRAWNRAYS"} = join(' ',@DRAWNRAYS);
  4007.    
  4008.     #@{$STATUS{"markedmodels"}} = @markedmodels;
  4009.     #@{$STATUS{"version"}} = $VERSION;
  4010.     #@{$STATUS{"depthvelocityprofiles "}} = $depthvelocityprofiles;
  4011.     #@{$STATUS{ "DRAWNSTATIONS"}} = @DRAWNSTATIONS;
  4012.     #@{$STATUS{ "DRAWNRAYS"}} = @DRAWNRAYS;
  4013.    
  4014.     foreach my $key ( keys(%STATUS) ) {
  4015.         $s .= "$key = $STATUS{$key}\n";
  4016.     }
  4017.  
  4018.     #print Dumper(\%STATUS) if $dev;
  4019.  
  4020.     print $s unless $quiet;
  4021.     open(FILE, ">$file") or die "Can't open $file";
  4022.     printf FILE $s;
  4023.     #printf FILE "markedmodels = @markedmodels\n";
  4024.     #printf FILE "version = $VERSION\n";
  4025.     #printf FILE "depthvelocityprofiles  = $depthvelocityprofiles\n";
  4026.     #printf FILE  "DRAWNSTATIONS = @DRAWNSTATIONS\n";
  4027.     #printf FILE  "DRAWNRAYS = @DRAWNRAYS\n";
  4028.     close(FILE);
  4029.    
  4030. }
  4031.  
  4032. sub _writeComments {
  4033.  
  4034. =PROGhead2 _writeComments()
  4035.  
  4036. Writes content of global variable %COMMENTS to file $commentfile
  4037.  
  4038. =cut
  4039.  
  4040.     ################################
  4041.     # Writing comments to file
  4042.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  4043.     my $file = $commentfile;
  4044.     open(FILE, ">$file") or die "Can't open $file";
  4045.     foreach (sort { $a <=> $b } (keys(%COMMENTS))) {
  4046.         my $version = $_;
  4047.         my $comment = $COMMENTS{$version};
  4048.         #print  "$version: $comment \n";
  4049.         printf FILE  "$version: $comment \n";
  4050.     }
  4051.     close(FILE);
  4052.     print "Wrote comments to $file\n" unless $quiet;
  4053. }
  4054.  
  4055. sub b_help {
  4056.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  4057.    
  4058.     my $top = $mw->Toplevel( -popover => $mw,
  4059.                 -title => "$PROG: User documentation",);                
  4060.     my $help = $top->Scrolled ("ROText", -scrollbars => 'e')
  4061.         -> pack ( -side => 'bottom', -expand => 1, -fill => 'both');
  4062.    
  4063.     # Open PRay help file
  4064.     my $file = "$PRAYPATH/doc/p_readme.txt";
  4065.    
  4066.     open (FILE, $file) or die "Cannpt open $file";
  4067.     while (<FILE>) {
  4068.         #chomp;                  # no newline
  4069.         $help->insert ('end', "$_");  
  4070.     }
  4071.    
  4072.     close(FILE)
  4073.     #$help->insert ('end', "$file");
  4074.     #$stline->configure(-height => 2);
  4075. }
  4076.  
  4077. sub b_helpHTML {
  4078.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  4079.    
  4080.     my $file = "$PRAYPATH/p_readme.html";
  4081.     system("$CONFIG{browser} $file");
  4082.    
  4083. }
  4084.  
  4085. sub b_about {
  4086.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  4087.     my $about =
  4088.     "\n".
  4089.     "PRay-invr\n".
  4090.     "L\n".
  4091.     "O\n".
  4092.     "T\n".
  4093.     "\n".
  4094.     "http://aforge.awi.de/gf/project/pray/\n\n".
  4095.     "\n".
  4096.     "Tanja Fromm\n".
  4097.     "Alfred-Wegener-Institut fuer Polar- und Meeresforschung\n".
  4098.     "Bremerhaven, Germany\n".
  4099.     "2011-2015\n\n".
  4100.     "PRay version: $STATUS{PRayVersion}\n"
  4101.     ;
  4102.  
  4103.     my $m =   $mw->Dialog(-popover => $mw,
  4104.                 -title => "$PROG: About",
  4105.                 -buttons => ['Close']
  4106.                 );
  4107.  
  4108.     my $text = $m->Text(-width => '60', -height => 16, -borderwidth => 0)
  4109.         -> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
  4110.        
  4111.     $text->insert('end', $about);
  4112.     $text->configure(-state => 'disabled');
  4113.     $m->Show;
  4114.  
  4115. }
  4116.  
  4117. sub b_vmodel {
  4118.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  4119.     my $vmodelw = $mw->Toplevel(-title => "$PROG: vmodel");
  4120.     my $text = $vmodelw -> Scrolled('ROText' , -scrollbars => 'e', -width => 80, -height => 60, -borderwidth => 0)
  4121.         -> pack (-side=>'top', -anchor => 'w', -fill => 'both', -expand => 'yes');
  4122.    
  4123.     my $buttonframe = $vmodelw -> Frame ->
  4124.             pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'no', -before => $text);
  4125.     $buttonframe -> Button (-text=>"vmodel",    -command => [\&vmodel, $text])
  4126.         -> pack (-side=>'left', -anchor => 'w', -fill => 'x', -expand => 'no');
  4127.     $buttonframe -> Button (-text=>"Close",    -command => [$vmodelw => 'destroy'])
  4128.         -> pack (-side=>'left', -anchor => 'w', -fill => 'x', -expand => 'no');
  4129.  
  4130.     b_vmodelFill($text);
  4131.    
  4132.     # sub vmodel gets output of vmodel, marks border crossings and displays it
  4133.     sub b_vmodelFill{
  4134.         printf "(T) %s(@_)\n", commons::whoami() if $tree;
  4135.         my $text = shift;
  4136.        
  4137.         $text->tagConfigure('start');            # Create a tag named 'start'
  4138.         $text->insert('end', "\n", 'start');    # Place tag to the beginning of new output
  4139.         $text->insert('end', "##########################################################################\n".
  4140.                              "Running vmodel for version v.$VERSION\n");
  4141.         my $output = `vmodel`;                    # Get output
  4142.         $text->insert('end', $output);            # Insert output
  4143.         $text->see('end');                        # Move whole window as far down as possible    
  4144.         $text->see("start.last");                # Move window back up to our mark. This ensures
  4145.                                                 # the new output is visible from start
  4146.        
  4147.         # Mark border crossings
  4148.         $text->tagConfigure('foundtag',
  4149.                     -foreground => "white",        # Format marking
  4150.                     -background => "red");
  4151.        
  4152.         $text->FindAll(-regex, -nocase, "crosses\ boundary");
  4153.         if ($text->tagRanges('sel')) {
  4154.             my %startfinish  = $text->tagRanges('sel');
  4155.             foreach(sort keys %startfinish) {
  4156.                 $text->tagAdd("foundtag", $_, $startfinish{$_});
  4157.             }
  4158.         $text->tagRemove('sel', '1.0', 'end');
  4159.         }
  4160.        
  4161.         # Mark low-velocity zones
  4162.         $text->tagConfigure('lowvelo',
  4163.                     -foreground => "white",        # Format marking
  4164.                     -background => "blue");
  4165.        
  4166.         $text->FindAll(-regex, -nocase, "low-velocity\ zone");
  4167.         if ($text->tagRanges('sel')) {
  4168.             my %startfinish  = $text->tagRanges('sel');
  4169.             foreach(sort keys %startfinish) {
  4170.                 $text->tagAdd("lowvelo", $_, $startfinish{$_});
  4171.             }
  4172.         $text->tagRemove('sel', '1.0', 'end');
  4173.         }
  4174.     }
  4175. }
  4176.  
  4177. sub b_viewComments {
  4178.  
  4179. =PROGhead2 b_viewComments()
  4180.  
  4181. Creates window with buttons and text field for comments. Calls
  4182. C<< b_viewCommentsBindAndFill($text, $commentsw) >> to fill in comments.
  4183.  
  4184. =cut
  4185.  
  4186.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  4187.     my $commentsw = $mw->Toplevel(-title => "$PROG: View version comments");
  4188.    
  4189.     my $text = $commentsw-> Scrolled('ROText' , -scrollbars => 'e', -width => 80, -height => 20, -borderwidth => 0)
  4190.         -> pack (-side=>'top', -anchor => 'w', -fill => 'both', -expand => 'yes');
  4191.     $text->menu(undef);
  4192.     my $buttonframe = $commentsw-> Frame ->
  4193.             pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'no', -before => $text);
  4194.     $buttonframe -> Button (-text=>"Update",    -command => [\&b_viewCommentsBindAndFill, $text])
  4195.         -> pack (-side=>'left', -anchor => 'w', -fill => 'x', -expand => 'no');
  4196.     $buttonframe -> Button (-text=>"Close",    -command => [$commentsw=> 'destroy'])
  4197.         -> pack (-side=>'left', -anchor => 'w', -fill => 'x', -expand => 'no');
  4198.  
  4199.     # Make version number a link to go to the model
  4200.     b_viewCommentsBindAndFill($text, $commentsw);
  4201.     $text->tagConfigure(qw/link -foreground blue /);
  4202.     #$text->tagConfigure('bold', -foreground => 'red');
  4203.  
  4204.  
  4205.     $text->tagBind(qw/link <Enter>/ => [sub {
  4206.         $text->configure(qw/-cursor hand2/);
  4207.         #$text->tagAdd('bold',$text->index('current'));
  4208.         }]
  4209.     );
  4210.     $text->tagBind(qw/link <Leave>/ => [sub {
  4211.         #$text->tagRemove(qw/bold 1.0 end/);
  4212.         $text->configure(qw/-cursor xterm/);
  4213.         }]
  4214.     );
  4215. }
  4216.  
  4217. sub b_viewCommentsBindAndFill {
  4218.  
  4219. =PROGhead2 b_viewCommentsBindAndFill($text, $commentsw)
  4220.  
  4221. Fills given window (C<< $commentsw >> with given text and creates mouse bindings.
  4222.  
  4223. =cut
  4224.  
  4225.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  4226.         #print "Display comments\n";
  4227.         my $text = shift;
  4228.         my $commentsw = shift;
  4229.         my $textcomments = "";
  4230.         $text->delete('0.0','end');
  4231.         $text->tagBind('link',"<Button-1>", sub{
  4232.             my $i = $text->index('current');
  4233.             my @tags = $text->tagNames([ $i]);
  4234.             my $version = $tags[1];
  4235.             print "You pressed a link at $i with tags @tags\n"
  4236.             ."I'm going to this version $version\n";
  4237.            
  4238.             _gotoVersion($version);
  4239.         });
  4240.        
  4241.         $text->tagBind('comment',"<Button-3>", sub{
  4242.             my $i = $text->index('current');
  4243.             my @tags = $text->tagNames([ $i]);
  4244.             my $version = $tags[1];
  4245.             print "You pressed a link at $i with tags @tags\n"
  4246.             ."Editing version $version\n";
  4247.            
  4248.             _editComment(\$version, $text);
  4249.         });
  4250.        
  4251.         # Insert text
  4252.         foreach (sort { $a <=> $b } (keys(%COMMENTS))) {
  4253.             my $version = $_;
  4254.             my $comment = $COMMENTS{$version};
  4255.             $textcomments.="$version: $comment\n";
  4256.             $text->insert('end',$version,['link',"$version"]);
  4257.             $text->insert('end',": $comment\n",['comment',"$version"]);
  4258.         }
  4259.         $text->see('end');
  4260. }
  4261.    
  4262. sub _editComment {
  4263.  
  4264. =PROGhead2 C<_editComment($version, ($textwidget))>
  4265.  
  4266. Opens window to edit comment. Automatically updates C<$textwidget> if given
  4267. and writes comments to file
  4268.  
  4269. =cut
  4270.  
  4271.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  4272.     #print "_editComment: Arguments @_\n";
  4273.     my $v = shift;    # version to edit
  4274.     my $t = shift;          # textfield
  4275.    
  4276.     my $version = $$v;
  4277.     ########
  4278.     my $comment = $COMMENTS{$version};
  4279.     my $msg =
  4280.               "Edit comment for version $version"
  4281.               ;
  4282.                
  4283.     my $win = $mw->Toplevel(
  4284.                 -title => "$PROG: Edit comment",
  4285.                 );
  4286.     # The frame gives a nicer window look with it's border. No other function
  4287.     my $dia = $win->Frame(-borderwidth => 5, -relief => 'flat')
  4288.         -> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
  4289.        
  4290.     #my $text = $dia->ROText(-width => '40', height => '1', -borderwidth => 3, -relief => 'flat', -wrap => 'word')
  4291.         #-> pack (-side=>'left', -anchor => 'w', -fill => 'x', -expand => 'yes');
  4292.        
  4293.     #$text->insert('end', "Edit comment for version $version");
  4294.     #$text->configure(-state => 'disabled');
  4295.  
  4296.     $dia -> LabEntry ( -width => 6,
  4297.                 -label => "Version ",
  4298.                  -labelPack    => [qw/-side left -anchor w/],
  4299.                 -textvariable => \$version)-> pack (-side=>'left', -anchor => 'w', -fill => 'none');    
  4300.     my $entry = $dia -> Entry (  
  4301.                     -textvariable => \$comment,
  4302.                     -width => '40',
  4303.                     )-> pack (-side=>'left', -anchor => 'w', -fill => 'x', -expand => 'yes');
  4304.  
  4305.     $dia->Button(-text=>"Close", -command =>
  4306.     sub {
  4307.         $win->destroy;
  4308.  
  4309.         # Add comment to hash
  4310.         if (defined $comment && $comment ne '') {
  4311.             print "Comment for version $version is >$comment<\n";
  4312.             $COMMENTS{$version} = $comment;
  4313.         } else {
  4314.             # Delete commentkey if nothing is entered
  4315.             delete $COMMENTS{$version};
  4316.         }
  4317.         _setWindowTitle();
  4318.         # Update comment list if window is open
  4319.         if ( $t ) {
  4320.             b_viewCommentsBindAndFill($t);
  4321.         }
  4322.        
  4323.         # Write comments to file
  4324.         _writeComments();
  4325.     }
  4326.     , -width => 10)->pack(qw/-side bottom  -anchor e/);
  4327.  
  4328.     $entry->focus;
  4329. ###########
  4330.  
  4331. }
  4332.  
  4333. sub b_viewResults {
  4334.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  4335.     my $resultsw = $mw->Toplevel(-title => "$PROG: View tracing results");
  4336.    
  4337.     my $text = $resultsw-> Scrolled('ROText' , -scrollbars => 'e', -width => 80, -height => 60, -borderwidth => 0)
  4338.         -> pack (-side=>'top', -anchor => 'w', -fill => 'both', -expand => 'yes');
  4339.    
  4340.     my $buttonframe = $resultsw-> Frame ->
  4341.             pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'no', -before => $text);
  4342.     $buttonframe -> Button (-text=>"Update",    -command => [\&b_displayResults, $text])
  4343.         -> pack (-side=>'left', -anchor => 'w', -fill => 'x', -expand => 'no');
  4344.     $buttonframe -> Button (-text=>"Close",    -command => [$resultsw=> 'destroy'])
  4345.         -> pack (-side=>'left', -anchor => 'w', -fill => 'x', -expand => 'no');
  4346.  
  4347.     b_displayResults($text, $resultsw);
  4348.    
  4349. }
  4350.  
  4351.  
  4352. sub b_displayResults {
  4353.  
  4354.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  4355.         my $text = shift;
  4356.         my $resultsw = shift;
  4357.         my $results =("#"x80)
  4358.                      ."\n# Model version $VERSION:\n".("#"x20)
  4359.                      ."\n\n"
  4360.                      ;
  4361.        
  4362.         $results.=$model->get("results");
  4363.         $text->insert('end',$results);
  4364.         $text->see('end');
  4365. }
  4366.  
  4367.  
  4368. sub i_ReadStatus {
  4369.  
  4370. #TODO: introduce variable %STATUS for easier handling
  4371.  
  4372.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  4373.     my $file = "p.status";    
  4374.     open (FILE, $file) or (print "Cannot find $file. No status restored\n", return 0);
  4375.    
  4376.     print "Reading old program status from file >$file<\n" unless $quiet;
  4377.  
  4378.     while (<FILE>) {
  4379.         chomp;                  # no newline
  4380.         #s/#.*//;                # no comments
  4381.         s/^\s*#.*//;                # whole line is commented
  4382.         s/^#.*//;                    # whole line is commented
  4383.         s/[0-9a-zA-Z\s]#.*//;    # no comments (but keeps colors like \#A42E93
  4384.         s/^\s*#//;                # whole line is commented
  4385.         s/^\s+//;               # no leading white
  4386.         s/\s+$//;               # no trailing white    
  4387.         s/\\//g;                    # Remove escaping slash from hex-color codes    
  4388.         next unless length;     # anything left?
  4389.         my ($var, $value) = split(/\s*=\s*/, $_, 2);
  4390.        
  4391.         print "$. : $_\n" if $verbose;
  4392.        
  4393.         $STATUS{$var} = $value;
  4394.        
  4395.         if ( $var eq 'markedmodels' ) {
  4396.             @markedmodels = split /\s+/, $value;
  4397.             my $msg = "Restored marked models to @markedmodels";
  4398.             print "$msg\n" unless $quiet;
  4399.             i_Messages("\n$msg");
  4400.         }
  4401.        
  4402.         if ( $var eq 'version' ) {
  4403.             $VERSION = $value;
  4404.             my $msg = "Restored version number to: $VERSION";
  4405.             print "$msg\n" unless $quiet;
  4406.             i_Messages("\n$msg");
  4407.         }
  4408.        
  4409.         if ( $var eq 'depthvelocityprofiles' ) {
  4410.             $depthvelocityprofiles = $value;
  4411.         }
  4412.        
  4413.         if ( $var eq 'DRAWNSTATIONS' ) {
  4414.             @DRAWNSTATIONS = split(/\s/, $value);
  4415.         }
  4416.        
  4417.         if ( $var eq 'DRAWNRAYS' ) {
  4418.             @DRAWNRAYS = split(/\s/, $value);
  4419.         }
  4420.     }
  4421.     close(FILE);
  4422.  
  4423.     print "DRAWNRAYS = @DRAWNRAYS\n" if $verbose;
  4424.     print "DRAWNSTATIONS = @DRAWNSTATIONS\n" if $verbose;
  4425.  
  4426.     #print Dumper(\%STATUS) if $dev;
  4427.  
  4428. }
  4429.  
  4430. sub i_ConfigRead {
  4431.  
  4432. =PROGhead2 C<i_ConfigRead()>
  4433.  
  4434. Reads file C<<p.config>> for user specific settings into hash C<<$CONFIG{$var}>>. Values
  4435. are only set, if hashkey exists (default values).
  4436.  
  4437. =cut
  4438.  
  4439.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  4440.     my $file = shift;
  4441.  
  4442.     open (FILE, $file) or do {print "WARNING!! Cannot find $CONFIGFILE. Use default values.\n"; return 0};
  4443.     print "Read user configuration from file >$file<\n" unless $quiet;
  4444.     while (<FILE>) {
  4445.         chomp;                  # no newline
  4446.         #s/#.*//;                # no comments (be aware of hex colorcodes!)
  4447.         s/^\s*#.*//;            # whole line is commented
  4448.         s/^#.*//;               # whole line is commented
  4449.         s/[0-9a-zA-Z\s]#.*//;   # no comments (but keeps colors like \#A42E93
  4450.         s/^\s*#//;              # whole line is commented
  4451.         s/^\s+//;               # no leading white
  4452.         s/\s+$//;               # no trailing white    
  4453.         s/\\//g;                # Remove escaping slash from hex-color codes    
  4454.         next unless length;     # anything left?
  4455.        
  4456.         my ($var, $value) = split(/\s*=\s*/, $_, 2);
  4457.         #print "$file\[$.\]: <$var=$value>\n";
  4458.        
  4459.         # Do not allow adding keys, which are not defined !!
  4460.         if ( !exists($CONFIG{$var})) {
  4461.             # Variable is not defined in $CONFIG
  4462.             my @keys = sort(keys(%CONFIG));
  4463.            
  4464.             print "\n\nERROR: Unknown configuration variable '$var' in $file $.\n\n".
  4465.                 "Possible variables are:\n@keys\n\n".
  4466.                 "Note: For consistency reasons with variable naming in rayinvr\n".
  4467.                 "variable maxdepth has changed to zmax\n".
  4468.                 "and maxheight to zmin\n\n"
  4469.                 ."\nERROR: Unknown configuration variable '$var' in $file $.\n\n";
  4470.             die;
  4471.         }
  4472.        
  4473.         # Key exists, continue
  4474.        
  4475.         # Check if value is an environment variable
  4476.         if ( $value =~ m/^\$/) {
  4477.             $value =~ m/\$(.*?)\//;   # find match environment variable $var up to next /
  4478.             my $env = $1;             # save match
  4479.             #print "env = $1 - $env, value = $value\n";
  4480.            
  4481.             # Get value of environment variable
  4482.             if ( exists $ENV{$env}) {
  4483.                 my $envval = $ENV{$env};
  4484.                 # Replace variable with content
  4485.                 $value =~ s/\$$env/$envval/;
  4486.             } else {
  4487.                 die "There's no environment variable named \$$value for variable $var\n";
  4488.             }
  4489.             #die;
  4490.         }
  4491.        
  4492.         # Some parameter require special treatment
  4493.         if ($var eq 'command' ||  $var eq 'xz' ||  $var eq 'xt') {
  4494.             # Several user defined commands can be added
  4495.             #print "Add user defined >$var< as $value\n";
  4496.             push @{$CONFIG{$var}} , $value;
  4497.         } else {
  4498.             $CONFIG{$var} = $value;
  4499.             #print "Using $var = $value\n";
  4500.         }
  4501.            
  4502.        
  4503.         #elsif ($var eq 'xmax' && $value > $CONFIG{xmax}){
  4504.         ## If xmax is larger than xmax from r.in, model file v.in cannot
  4505.         ## be read
  4506.             #print "ERROR: The value 'xmax = $value' in your $CONFIGFILE is larger than".
  4507.                 #" xmax = $CONFIG{xmax} from your r.in!!!\n".
  4508.                 #"Use a value smaller than the one from r.in or omit 'xmax' to use the one from r.in\n";
  4509.                 #die;
  4510.         #} else {
  4511.         #$CONFIG{$var} = $value;
  4512.         #print "Using $var = $value\n";
  4513.    
  4514.    
  4515.     }
  4516.     close (FILE);
  4517.    
  4518.     #print Dumper(\%CONFIG);
  4519. }
  4520.  
  4521. sub i_ConfigInit{
  4522.  
  4523. =PROGhead2 i_ConfigInit()
  4524.  
  4525. Define default values and pop up help for p.config parameter. To add a
  4526. config parameter, put the default value and a comment in this hash. To
  4527. allow editing also add the new parameter to b_configEdit().
  4528.  
  4529. =cut
  4530.  
  4531.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  4532.  
  4533. CONFIGURATION:
  4534. ###
  4535. # Programms and places
  4536. $CONFIG{rayinvr} = "xrayinvr"; $CONFIGDOC{rayinvr} =
  4537. "Default: xrayinvr
  4538. Shell command bound to button 'rayinvr'. This should normally be
  4539. 'rayinvr' or 'xrayinvr'. If the \$PATH-variable is set correct, no path
  4540. is needed. It could also be a user-written script";
  4541.  
  4542.  
  4543. $CONFIG{gmt} = "GMT"; $CONFIGDOC{gmt} =
  4544. "Default: gmt
  4545. This is a switch for different GMT-versions.
  4546. If you use GMT 5, please insert  GMT; if you use GMT 4, do not insert
  4547. anything.";
  4548.  
  4549.  
  4550. $CONFIG{stationfile} = "statxz"; $CONFIGDOC{stationfile} =
  4551. 'File with a list of stationnames, their position and depth and optional
  4552. information for the pick program
  4553. Format:
  4554. name position depth [headfile] [parameterfile]
  4555.  
  4556. eg:
  4557. 01 6.640 -10
  4558. 02 10.660 -50
  4559. 03 13.260 -60
  4560.  
  4561. This file is used to draw the stationpositions in the model. If it
  4562. does not exist, it is created the r.in. The additional information is
  4563. currently needed for zp, if the headfile is not named using the
  4564. \'zpfilemask\'-parameter';
  4565.  
  4566. $CONFIG{exportpath} = "./data"; $CONFIGDOC{exportpath} =
  4567. 'Default: ./data
  4568. Outputpath for exporting rays and times in GMT format
  4569. (Menu->Export rays&picks)';
  4570.  
  4571. $CONFIG{deleteExported} = 1; $CONFIGDOC{deleteExported} =
  4572. "(0/1) Default: 1
  4573.  
  4574. 1) Delete old exported rays before exporting current rays. Exportfolder
  4575. therefore contains only stations that have just been traced for the
  4576. current model
  4577.  
  4578. 0) If set to 0 old files are kept, but may be from an old
  4579. model. Usefull if you cannot trace all stations in one go.";
  4580.  
  4581. #$CONFIG{outpos} = "relative";  $CONFIGDOC{outpos} =
  4582. #"(absolute/relative) Default: relative
  4583.  
  4584. #Defines x-positon of traveltime data.
  4585. #'absolute' for model km
  4586. #'relative' for km relative to obs";
  4587.  
  4588. $CONFIG{resolution} = "$PRAYPATH/scripts/resolution.gmt";  $CONFIGDOC{resolution} =
  4589. "User defined script to run for plotting the resolution file
  4590.  
  4591. default: scripts/resolution.gmt
  4592. ";
  4593.  
  4594. $CONFIG{editor} = $ENV{'EDITOR'}; $CONFIGDOC{editor} =
  4595. 'Default: $EDITOR
  4596. Editor for opening text files in \'Menu->Open files\'. Default is the
  4597. environment variable';
  4598.  
  4599. $CONFIG{files}  = "v.in r.in";  $CONFIGDOC{files}  =
  4600. 'Default: v.in r.in
  4601. Define files for quick opening from menu (Menu->Open files)';
  4602.  
  4603. $CONFIG{browser} = undef; $CONFIGDOC{browser} =
  4604. 'Command to open browser. This will activate the html version of
  4605. the readme file (Help->User documentation-html).
  4606. Use e.g.: \'open\' (Mac) or \'firefox\' (Unix) ';
  4607.  
  4608. ###
  4609. # Configure picking
  4610. $CONFIG{zp2ray} = undef; $CONFIGDOC{zp2ray} =
  4611. "Shell command bound to button 'zp2ray'
  4612. You may use words \$zpdir, \$dir and \$file for substitution
  4613.  
  4614. \$zpdir: your 'zpdir'-configuratio value
  4615. \$dir:    current working directory
  4616. \$file:   file build with your 'zpFileMask'-configuration or from
  4617.          4th column in 'statxz'-file";
  4618.  
  4619. $CONFIG{zpFileMask} = undef; $CONFIGDOC{zpFileMask} =
  4620. 'Rules for naming of zp .head files used if no head-file is given in
  4621. the \'station\'-file.
  4622.  
  4623. $obs obsnumbers read from stationfile
  4624. e.g. : 100st$obs.h.head -> 100st130.h.head';
  4625.  
  4626. $CONFIG{zpdir}  = undef; $CONFIGDOC{zpdir}  =
  4627. 'Directory containing the zp .head files.';
  4628.  
  4629. #$CONFIG{densityconversion}  = 'barton'; $CONFIGDOC{densityconversion}  =
  4630. #'Define density conversion. Default: barton. Alternative: funck
  4631. #Conversion uses values from
  4632. #Barton(1986) "The relationship between seismic velocity and density in the continental crust - a useful constraint?"
  4633. #or
  4634. #Ludwig(1970) "Seismic Refraction" in THE SEA
  4635. #';
  4636.  
  4637.  
  4638. ###
  4639. # Appearance
  4640. $CONFIG{screenwidth} = 1600; $CONFIGDOC{screenwidth} =
  4641. 'Default: 1600
  4642. Width of main window';
  4643.  
  4644. $CONFIG{screenheight} = 1000; $CONFIGDOC{screenheight} =
  4645. 'Default: 1000
  4646. Height of main window';
  4647.  
  4648. $CONFIG{reverseTime} = 0; $CONFIGDOC{reverseTime} =
  4649. '(0/1) Default: 0
  4650. Switch direction of time axis';
  4651.  
  4652. $CONFIG{xmin} = undef; $CONFIGDOC{xmin} =
  4653. 'Default: xmin (r.in)
  4654. Define the displayed model section. Overwrite r.in values';
  4655.  
  4656. $CONFIG{xmax} = undef; $CONFIGDOC{xmax} =
  4657. 'Default: xmax (r.in)
  4658. Define the displayed model section. Overwrite r.in values';
  4659.  
  4660. $CONFIG{zmin} = 0; $CONFIGDOC{zmin} =
  4661. 'Default: zmin (r.in) or 0
  4662. Define the top of the displayed model section. Overwrite r.in values.
  4663. Negative values are above the surface.';
  4664.  
  4665. $CONFIG{zmax} = 30; $CONFIGDOC{zmax} =
  4666. 'Default: zmax (r.in) or 30
  4667. Define the bottom of the displayed model section. Overwrite r.in values.
  4668. Positive values are below the surface.';
  4669.  
  4670. $CONFIG{tmin} = 0; $CONFIGDOC{tmin} =
  4671. 'Default: tmin (r.in) or 0
  4672. Define the top of the diplayed traveltime section. Overwrite r.in values.
  4673. Currently the y-direction of the traveltime section cannot be swapped.';
  4674.  
  4675. $CONFIG{tmax} = 15; $CONFIGDOC{tmax} =
  4676. 'Default: tmax (r.in) or 15
  4677. Define the bottom of the diplayed traveltime section. Overwrite r.in values.
  4678. Currently the y-direction of the traveltime section cannot be swapped.';
  4679.  
  4680. $CONFIG{vred} = 8; $CONFIGDOC{vred} =
  4681. 'Default: 8
  4682. Choose velocity reduction';
  4683.  
  4684. $CONFIG{stationsperline} = 30; $CONFIGDOC{stationsperline} =
  4685. "Default: 30
  4686. Number of stationbuttons in one line (currently only two lines are
  4687. supported";
  4688.  
  4689. $CONFIG{modelbg} = "grey"; $CONFIGDOC{modelbg} =
  4690. 'Default: grey
  4691. Change background color of model section';
  4692.  
  4693. $CONFIG{ttbg} = "white"; $CONFIGDOC{ttbg} =
  4694. 'Default: white
  4695. Change background color of traveltime display';
  4696.  
  4697. $CONFIG{txin} = 'dash'; $CONFIGDOC{txin} =
  4698. '(dash/circle/line) Default: dash
  4699. Set kind of drawing for traveltime arrivals (tx.in)';
  4700.  
  4701. $CONFIG{txinSize} = 2; $CONFIGDOC{txinSize} =
  4702. 'Change size of input pick symbol (txin)';
  4703.  
  4704.  
  4705. $CONFIG{txout} = 'line'; $CONFIGDOC{txout} =
  4706. '(dash/circle/line) Default: line
  4707. Set kind of drawing for traveltime arrivals (tx.out)';
  4708.  
  4709. $CONFIG{txoutSize} = 1; $CONFIGDOC{txoutSize} =
  4710. 'Change size of traced arrival symbol (txout)';
  4711.  
  4712. $CONFIG{splash} = 0; $CONFIGDOC{splash} =
  4713. '(0/1) Default: 0
  4714. Display startup-splash? The splash screen might slow down your system.';
  4715.  
  4716. $CONFIG{annotSize} = 80; $CONFIGDOC{annotSize} =
  4717. 'Change text size for annotating velocity nodes. Default 80';
  4718.  
  4719. $CONFIG{stationSize} = 10; $CONFIGDOC{stationSize} =
  4720. 'Change size for drawing the station triangle. Default 10';
  4721.  
  4722. ###
  4723. # Additional data and commands
  4724. $CONFIG{additionalPhases} = undef; $CONFIGDOC{additionalPhases} =
  4725. 'Define extra phases for phase button menu
  4726. e.g.:
  4727. 1 2 77 100';
  4728.  
  4729. $CONFIG{additionalPhaseColors} = undef; $CONFIGDOC{additionalPhaseColors} =
  4730. 'Define colors for the additional phases. You can use named colors
  4731. like \'red\', \'green\' or html hexcodes, e.g. A020F0)';
  4732.  
  4733. $CONFIG{basement} = -1; $CONFIGDOC{basement} =
  4734. 'Default: -1
  4735. Give a layer number (as in v.in) for the basement and draw a thicker
  4736. line for this layer. This layer is also used as margin for extracting
  4737. the velocity structure of the igneous crust';
  4738.  
  4739. $CONFIG{moho} = -1; $CONFIGDOC{moho} =
  4740. 'Default: -1
  4741. Give a layer number (as in v.in) for the Moho and draw a thicker
  4742. line for this layer. This layer is also used as margin for extracting
  4743. the velocity structure of the igneous crust';
  4744.  
  4745. $CONFIG{command} = undef; $CONFIGDOC{command} =
  4746. 'Insert user defined \'commands\' to command menu.
  4747. Format:
  4748. Label = script.sh
  4749.  
  4750. Use one line per command and reload the config-file to get a new line
  4751. (or write directly to the file)
  4752. ';
  4753.  
  4754. $CONFIG{xz} = undef; $CONFIGDOC{xz} =
  4755. 'Overlay xz-data in model diagram. Give file name and optional color for
  4756. the line, e.g.:
  4757.  
  4758. filename red
  4759.  
  4760. file-format:
  4761. x z';
  4762.  
  4763. $CONFIG{xt} = undef; $CONFIGDOC{xt} =
  4764. 'Overlay xt-data in traveltime diagram. Give file name and optional color for
  4765. the line, e.g.:
  4766.  
  4767. filename red
  4768.  
  4769. file-format:
  4770. x t';
  4771.  
  4772. ###
  4773. # Non-rayinvr model data
  4774. $CONFIG{tomoPhase} = undef; $CONFIGDOC{tomoPhase} =
  4775. 'Enable functions for tomo2D and associates ray data to this phase';
  4776.  
  4777. $CONFIG{tomoTimes} = "tt.dat"; $CONFIGDOC{tomoTimes} =
  4778. 'File containing traveltimedata in tx format';
  4779.  
  4780. $CONFIG{tomoRays} = 'tomo.rays'; $CONFIGDOC{tomoRays} =
  4781. 'raypathes in GMT-plotable multisegment format. '
  4782. .'Rays MUST start at the station (reverse file)';
  4783.  
  4784. $CONFIG{tomoGrid} = 'tomo.xyz'; $CONFIGDOC{tomoGrid} =
  4785. 'xyz-file read in for Tomo. Should have xinc = 1, zinc = 0.5';
  4786.  
  4787. $CONFIG{tomoRefl} = 'tomo.refl'; $CONFIGDOC{tomoRefl} =
  4788. 'reflector-file for tomo2D';
  4789.  
  4790. $CONFIG{tomoPhasePg} = undef; $CONFIGDOC{tomoPhasePg} = '
  4791. Phase number for Pg rays if rayfile is splitted';
  4792.  
  4793. $CONFIG{tomoRaysPg} = undef; $CONFIGDOC{tomoRaysPg} =
  4794. 'ray file containing ONLY Pg';
  4795.  
  4796. $CONFIG{tomoTimesPg} = undef; $CONFIGDOC{tomoTimesPg} =
  4797. 'ray file containing ONLY Pg';
  4798.  
  4799. $CONFIG{tomoPhasePmP} = undef; $CONFIGDOC{tomoPhasePmP} =
  4800. 'Phase number for PmP rays if rayfile is splitted';
  4801.  
  4802. $CONFIG{tomoRaysPmP} = undef; $CONFIGDOC{tomoRaysPmP} =
  4803. 'ray file containing ONLYPmP';
  4804.  
  4805. $CONFIG{tomoTimesPmP} = undef; $CONFIGDOC{tomoTimesPmP} =
  4806. 'ray file containing ONLY PmP';
  4807.  
  4808. $CONFIG{txTomo} = 'line'; $CONFIGDOC{txTomo} =
  4809. 'line';
  4810.  
  4811. ############
  4812.  
  4813. foreach (qw(xmin xmax zmin zmax tmin tmax)) {
  4814.     if (exists $RIN->{$_}) {
  4815.         $CONFIG{$_}=$RIN->{$_}[0];
  4816.         #print "set $_ to $RIN->{$_}[0]\n";
  4817.     }
  4818. }
  4819.  
  4820.  
  4821. =USERhead3 Config-File
  4822.  
  4823. C<p.pl> can be configured with file C<p.config> in current working directory.
  4824. All parameter have default values, but some users might want to change some
  4825. for their own model. A config-file is not necessary. There's a graphical editor
  4826. with pop up help available at C<< Menu->Edit p.config >>.
  4827.  
  4828. You can comment parameter with '#'. Spaces around '=' are not needed. You can use environment
  4829. variables (e.g. zpdir=$ZP). Dont use '~'. Use '$HOME' instead. Only one variable per line is allowed.
  4830. Lists use spaces as seperator.
  4831.  
  4832. Under Menu-Edit p.config a graphical editor with help function aids the
  4833. program setup.
  4834.  
  4835. C<p.config> is read after C<r.in> and overwrites values for xmin, xmax, zmax,
  4836. zmin, tmin and tmax from r.in
  4837.  
  4838. =cut
  4839.  
  4840.  
  4841. }
  4842.  
  4843. sub b_configEdit {
  4844.  
  4845. =PROGhead2 b_configEdit()
  4846.  
  4847. Reads config and opens window for editing and saving a new C<p.config>.
  4848. New user configurables have to be inserted here.
  4849.  
  4850. =cut
  4851.  
  4852.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  4853.  
  4854.     #> x join(' ',sort(keys(%{$model->{config}})))  
  4855.     #> additionalPhaseColors additionalPhases basement browser command
  4856.     #  deleteExported editor exportpath files modelbg
  4857.     #  moho outpos rayinvr rin
  4858.     #  screenheight screenwidth splash stationfile tmax tmin tomoGrid
  4859.     #  tomoPhase tomoPhasePg tomoPhasePmP tomoRays tomoRaysPg tomoRaysPmP
  4860.     #  tomoRefl tomoTimes tomoTimesPg tomoTimesPmP ttbg txTomo txin txout
  4861.     #  vred xmax xmin xt xz zmax zmin zp2ray zpFileMask zpdir
  4862.    
  4863.     #x join(' ',sort(map {@$_} @vars))
  4864.    
  4865.     # Reread all values from file
  4866.     i_ConfigInit();
  4867.     i_ConfigRead($CONFIGFILE);
  4868.  
  4869.     my @vars;# = sort(keys(%CONFIG));
  4870.     my @labels;
  4871.  
  4872.    
  4873.     my $cw = $mw->Toplevel(-title => "Edit $CONFIGFILE");
  4874.  
  4875.     my $buttonf = $cw->Frame(-borderwidth => 1, -background => "green")->pack(qw/-side top -anchor w -expand yes -fill x/);
  4876.     $buttonf->Button(-text=>"Save Changes", -command => [\&save, \@labels, \@vars],       -width => 10)->pack(qw/-side left -anchor n /);
  4877.     $buttonf->Button(-text=>"Close",  -command => [$cw => 'destroy'], -width => 10)->pack(qw/-side left /);
  4878.  
  4879.     my $sc = $cw -> Scrolled ('Pane', -scrollbars => 'e', -borderwidth => 1,
  4880.             -relief => 'solid', #-background => "green",
  4881.             #-width => 600,
  4882.             -sticky=>'nwse',
  4883.             -height => ($CONFIG{screenheight} - 100)
  4884.             )     -> pack (-side=>'top', -anchor => 'w', -fill => 'both', -expand => 'yes');
  4885.            
  4886.     #my $sc = $cw -> Frame ( -borderwidth => 1,
  4887.             #-relief => 'solid', #-background => "green",
  4888.             ##-width => 600, -height => 400
  4889.             #)     -> pack (-side=>'top', -anchor => 'w', -fill => 'both', -expand => 'yes');
  4890.  
  4891.  
  4892.  
  4893.     # First column frame, Second column frame
  4894.     my $fircolf = $sc->Frame(-borderwidth => 1, -background => "green")->pack(qw/-side left -anchor n -expand yes -fill x/);
  4895.     my $seccolf = $sc->Frame(-borderwidth => 1, -background => "green")->pack(qw/-side left -anchor n -expand yes -fill x/);
  4896.  
  4897.     # Display help text
  4898.     my $rotext = $fircolf->ROText(-width => '30', -height => 10, -wrap => 'word', -borderwidth => 0)
  4899.     -> pack (-side=>'top', -anchor => 'w', -fill => 'both', -expand => 'yes');
  4900.     my $text = "This is an interface to aid configuration of PRay. "
  4901.     ."It writes the p.config file which can also be edited with any "
  4902.     ."other editor. To run PRay, no special configuration is necessary, "
  4903.     ."information is extracted "
  4904.     ."from r.in, but functionality can be greatly enhanced by some simple "
  4905.     ." configurations. Specially the picking configuration. See popup-windows for help.\n"
  4906.     ."Environment variables can be used.\n"
  4907.     ."\nChanges are only applied after a restart of PRay!\n"
  4908.     ;
  4909.    
  4910.    
  4911.     $rotext->insert('end', $text);
  4912.     $rotext->configure(-state => 'disabled');
  4913.    
  4914.     ########################
  4915.     ### Create arrays with labels and config parameter
  4916.     # Only parameter entered in this arrays will appear in the user interface
  4917.     # Programms and places    
  4918.     push @vars, [qw/rayinvr gmt stationfile exportpath deleteExported editor files browser resolution densityconversion/];
  4919.     push @labels,"Programms and places";
  4920.  
  4921.     # Pick software
  4922.     push @vars, [qw/zp2ray zpFileMask zpdir/];
  4923.     push @labels, "Configure picking";
  4924.  
  4925.     # Appearance
  4926.     push @vars, [qw/screenwidth screenheight reverseTime xmin xmax zmin zmax tmin tmax vred stationsperline
  4927.         modelbg ttbg txin txinSize txout txoutSize stationSize annotSize splash /];
  4928.     push @labels, 'Appearance';
  4929.  
  4930.  
  4931.     # Model definitions
  4932.     push @vars, [qw/additionalPhaseColors additionalPhases basement moho
  4933.               command xt xz/];
  4934.     push @labels,"Additional data and commands";
  4935.  
  4936.     # Non-rayinvr data
  4937.     push @vars, [qw/tomoPhase tomoPhasePg tomoPhasePmP tomoRays tomoRaysPg
  4938.         tomoRaysPmP tomoRefl tomoTimes tomoTimesPg tomoTimesPmP txTomo tomoGrid/];
  4939.     push @labels, "Non-rayinvr model data (experimental)";
  4940.  
  4941.     # Uncategorized = To be fixed
  4942.     #push @vars, [];
  4943.     #push @labels, "Uncategorized";
  4944.  
  4945.  
  4946.     ####
  4947.     # Check for differences
  4948.     my @v = sort(map {@$_} @vars);
  4949.     my @c = sort(keys(%{$model->{config}}));
  4950.     my $s = "";
  4951.     for (my $i=0; $i<=$#c; $i++) {
  4952.         unless ($v[$i] eq $c[$i]) {
  4953.             unless ( exists $RIN->{$v[$i]}) {
  4954.                 print ">$v[$i]< is not to be configured any more. Programmer: remove it from sub b_configEdit\n";
  4955.             } else {
  4956.                 print ">$c[$i]< cannot be configured in this dialog\n"
  4957.                     ."Fix that, programmer\n";
  4958.                     #push @{$vars[-1]}, $c[$i];
  4959.             }
  4960.             last;
  4961.         }
  4962.     }
  4963.  
  4964.     ########################
  4965.     ### Fill dialog window
  4966.     my $blocks = @vars;
  4967.     my $frame = $fircolf;
  4968.     for ( my $i = 0; $i < $blocks; $i++ ) {
  4969.         $frame = $seccolf if ( $i == 3 );
  4970.  
  4971.         makeLabel($frame, $labels[$i]);
  4972.         makeLabelEntry($frame, @{$vars[$i]});
  4973.        
  4974.         ############
  4975.         # Create a print out for the user docs:
  4976.         #makeDoc($labels[$i], @{$vars[$i]});
  4977.  
  4978.     }
  4979.    
  4980.     sub makeDoc{
  4981.         printf "(T) %s(@_)\n", commons::whoami() if $tree;
  4982.  
  4983.  
  4984.         my ($label, @vars) = @_;
  4985.        
  4986.         print "$label\n";
  4987.         foreach my $element (@vars) {
  4988.             print $CONFIGDOC{$element};
  4989.            
  4990.         }
  4991.     }
  4992.  
  4993.     ################
  4994.     sub save{
  4995.         printf "(T) %s(@_)\n", commons::whoami() if $tree;
  4996.  
  4997.  
  4998.         my $file = "$CONFIGFILE";
  4999.         my $labels = shift;
  5000.         my $vars = shift;
  5001.        
  5002.         #print "p::b_configEdit($file)\n";
  5003.         open(FILE, ">$file") or die "Can't open $file";
  5004.         _printStatusMessage("\nWrite changes to >$CONFIGFILE<. You must restart to apply changes!");
  5005.         #print "Write all parameter: ".sort(keys(%CONFIG));
  5006.        
  5007.         my $blocks = @$vars;
  5008.         for ( my $i = 0; $i < $blocks; $i++ ) {
  5009.             my $s = "\n###################\n# $labels->[$i]\n###\n";
  5010.             print       $s;
  5011.             printf FILE  $s;
  5012.            
  5013.             foreach my $var ( @{$vars->[$i]} ) {
  5014.                 if ( defined $CONFIG{$var} ) {
  5015.                     if ( ref($CONFIG{$var}) eq 'ARRAY' ) {
  5016.                         $s = "";
  5017.                         foreach my $element ( @{$CONFIG{$var}} ) {
  5018.                             $s .= "$var = $element\n" if ($element);
  5019.                         }
  5020.                     }else {
  5021.                         $s = "$var = $CONFIG{$var}\n";
  5022.                     }
  5023.                     #$s =~ s/#/\#/g;
  5024.                     $s =~ s/#//g;  # Remove hash of hex codes. Otherwise they'd skipped next time as comments
  5025.                                    # I don't know, how to replace # by \#.
  5026.  
  5027.                     print       $s;
  5028.                     printf FILE $s;
  5029.                    
  5030.                 }
  5031.             }
  5032.         }
  5033.         close(FILE);
  5034.     }
  5035.    
  5036.     ################
  5037.     sub makeLabel{
  5038.         printf "(T) %s(@_)\n", commons::whoami() if $tree;
  5039.  
  5040.         my $sc = shift;
  5041.         my $label = shift;
  5042.         $sc -> Label(-text => "\n$label",
  5043.             ) -> pack (-side=>'top', -anchor => 'w', -fill => 'both', -expand => 'yes');
  5044.  
  5045.     }
  5046.    
  5047.     ################
  5048.     sub makeLabelEntry {
  5049.         printf "(T) %s(@_)\n", commons::whoami() if $tree;
  5050.  
  5051.  
  5052.         my $sc = shift;
  5053.         my @vars = @_;
  5054.         foreach my $var (@vars) {
  5055.             my $msg = $CONFIGDOC{$var};
  5056.        
  5057.             if ( ref($CONFIG{$var}) eq 'ARRAY' ){
  5058.                 print "Found array for $var \n";
  5059.                 # Add empty field for new user command
  5060.                 push @{$CONFIG{$var}}, '';
  5061.                 foreach my $element ( @{$CONFIG{$var}}) {
  5062.                     $balloon->attach(
  5063.                         $sc-> LabEntry (  
  5064.                          -label        => "$var",
  5065.                          -justify => 'left',
  5066.                          -labelAnchor => 'w',
  5067.                          -width => '50',
  5068.                          -labelWidth=>20,
  5069.                          -labelPack    => [qw/-side left -anchor e  -fill x/],
  5070.                          -textvariable => \$element,
  5071.                          )-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes')
  5072.                         , -balloonmsg => $msg);
  5073.  
  5074.                 }
  5075.                 next;
  5076.             }
  5077.  
  5078.             # Create labeled entry with help button attached
  5079.             $balloon->attach(
  5080.                 $sc-> LabEntry (  
  5081.                  -label        => "$var",
  5082.                  #-labeljustify => 'left',
  5083.                  -justify => 'left',
  5084.                  #-background => 'red',
  5085.                  -labelAnchor => 'w',
  5086.                  -width => '50',
  5087.                  -labelWidth=>20,
  5088.                  -labelPack    => [qw/-side left -anchor e  -fill x/],
  5089.                  -textvariable => \$CONFIG{$var},
  5090.                  #-width => '6'
  5091.                  )-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes')
  5092.                 , -balloonmsg => $msg);
  5093.    
  5094.         }
  5095.     }
  5096. }
  5097.  
  5098. #sub i_ReadRin {
  5099.  
  5100.     #my $rin = shift;     # Use hash to store r.in parameter
  5101.  
  5102.     #print "Reading phasecode from r.in\n";
  5103.     #my @txph = @{$rin->{ivray}};    # Get phasecodes for tx
  5104.     #my @riph = @{$rin->{ray}};      # Get raycodes for RI
  5105.    
  5106.     ##my @phasecodes = @{$rin->{ivray}};    # Get phasecodes for tx
  5107.     ##my @raycodes = @{$rin->{ray}};      # Get raycodes for RI
  5108.  
  5109.     #if (@txph != @riph) {
  5110.         #print
  5111.         #"###############################################################\n".
  5112.         #"# ATTENTION !! ATTENTION !! ATTENTION !!                      #\n".
  5113.         #"# Phasecode-arrays for rayinvr and zp have DIFFERENT length!! #\n".
  5114.         #"# Please correct parameter >ivray< and >ray< in your r.in     #\n".
  5115.         #"#                                                             #\n".
  5116.         #"# The array >ray< defines which phases are to be traced by    #\n".
  5117.         #"# rayinvr, while >ivray< defines the phasecode as in tx.in    #\n".
  5118.         #"###############################################################\n";
  5119.         ##exit;
  5120.     #}
  5121.    
  5122.     #my %phasecodes;     # Store merged codes
  5123.     #my %raycodes;       # Store merged codes
  5124.     #for (my $i=0; $i <= $#txph; $i++ ){
  5125.         #$phasecodes{$txph[$i]} = $riph[$i];
  5126.  
  5127.         ## Phasecodes for in rayinvr are not unique if using multiples
  5128.         ## Believing, you'd define direct before multiple, value is not
  5129.         ## overwritten, if one exists.
  5130.         #if  ( exists $raycodes{$riph[$i]}) {
  5131.             ##print
  5132.             ##"###############################################################\n".
  5133.             ##"# ATTENTION !! ATTENTION !! ATTENTION !!\n".
  5134.             ##"# Rayinvr code $riph[$i] matches $txph[$i] and $raycodes{$riph[$i]}\n".
  5135.             ##"# Ignoring $txph[$i]\n".
  5136.             ##"###############################################################\n";
  5137.             #i_Messages(
  5138.                 #"\nRayinvr code $riph[$i] matches  ZP codes $txph[$i] and $raycodes{$riph[$i]}.".
  5139.                 #" Ignoring $txph[$i].");
  5140.         #} else {
  5141.             #$raycodes{$riph[$i]} = $txph[$i] unless ( exists $raycodes{$riph[$i]});
  5142.         #}
  5143.     #}
  5144.     ##return \%phasecodes, \%raycodes;
  5145. #}
  5146.  
  5147. sub i_Comments {
  5148.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  5149.  
  5150.     my $file = $commentfile;
  5151.  
  5152.     open (FILE, $file) or do {print "Cannot find old comment file\n"; return 0};
  5153.     print "Reading comments from $commentfile\n" unless $quiet;
  5154.     while (<FILE>) {
  5155.         chomp;                  # no newline
  5156.         #s/#.*//;                # no comments
  5157.         s/^\s*#.*//;                # whole line is commented
  5158.         s/^#.*//;                    # whole line is commented
  5159.         s/[0-9a-zA-Z\s]#.*//;    # no comments (but keeps colors like \#A42E93
  5160.         s/^\s*#//;                # whole line is commented
  5161.         s/^\s+//;               # no leading white
  5162.         s/\s+$//;               # no trailing white    
  5163.         s/\\//g;                    # Remove escaping slash from hex-color codes    
  5164.         next unless length;     # anything left?
  5165.         my ($var, $value) = split(/\s*:\s*/, $_, 2);
  5166.        
  5167.         # Populate comment-hash with old comments
  5168.         $COMMENTS{$var} = $value;
  5169.         #print "Add comment >$var: $value<\n";
  5170.     }
  5171.     close (FILE);
  5172. }
  5173.  
  5174.  
  5175. sub i_Colors{
  5176.    
  5177.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  5178.     ######################################################################
  5179.     # Define Phase Colors
  5180.     #                           0          1      2       3       4       5       6       7       8       9       10
  5181.     #                           1.2        2.2    3.2     4.2     5.2     6.2     7.2     8.2     9.2     10.2    11.2
  5182.     #                           dunkelrot  rot   orangerot orange hellorange gelb  gruen   gruener gruenblau
  5183.     @REFLECTED = split(/\s+/, "#AA142B #F80500 #FF642A #FC8200 #FFB231 #FFDD31 #7EE000 #22AF00 #44BF70 #DEFF3A #AADA65");
  5184.     #                            1.1       2.1    3.1     4.1      5.1     6.1     7.1     8.1     9.1     10.1    11.1
  5185.     #                            hellgruen dunkelhell gruen mint
  5186.     @REFRACTED = split(/\s+/, "darkgrey #97FF4C #5BC80C #2994D0 #0033CC #27CC9C #36DDE6 #1CACB4 #1C96B4 #07CEFF #1C8DA9");
  5187.     #                         1.3     2.3     3.3     4.3     5.3     6.3     7.3     8.3     9.3     10.3    11.3
  5188.     #                         blau    lila    pink
  5189.     @HEAD =  split(/\s+/, "#284AFF #011CA8 #9276FF #912EE4 #6700BD #9E00BD #DE54F9 #EF99FF #FF99F5 #FF99F5 #B077AB");
  5190.    
  5191.     my $mult = "black";    # corrected multiple
  5192.    
  5193.     # Define Phases
  5194.     my $raycodes= $CODES->get('raycodes'); # Which phases should be visible in the Phasemenu?
  5195.    
  5196.     #push @phases, "0.0";
  5197.     # Create phaselist with number of layers
  5198.     #for (my $i = 1; $i <= 11; $i++){ # For all layers. TODO Change to variable for number of layers
  5199.         #push @phases, "$i.1";
  5200.         #push @phases, "$i.2";
  5201.         #push @phases, "$i.3";
  5202.         #push @phases, "$i.4";    
  5203.         #push @phases, "$i.5";
  5204.         #push @phases, "$i.6";
  5205.         #push @phases, "$i.7";    
  5206.     #}
  5207.    
  5208.     ## Defines phases for phasebuttons and asigns colors to them
  5209.    
  5210.     my $i = 0;
  5211.     # Bring colors and phases together into a hash %phasecolors
  5212.     foreach my $rc (@$raycodes) {
  5213.         #print "Set color for phase $ph\n";
  5214.         #( $j = $_) =~ s/\.\d//; # $j is the layer. It needs the array value $j-1 for colordefinition
  5215.         my @rc = split /\./, $rc;
  5216.        
  5217.         if (@rc == 2) {
  5218.             my $l = $rc[0];    # Layer
  5219.             my $r = $rc[1];    # raytype
  5220.             my $color;
  5221.    
  5222.             # Distinguish between raytype
  5223.             if ($r =~ m/[15]/ ) {
  5224.                 $color = \@REFRACTED;        
  5225.             } elsif ($r =~  m/[24]$/ ) {
  5226.                 $color = \@REFLECTED;        
  5227.             } elsif ($r =~ m/[367]$/ ) {
  5228.                 $color = \@HEAD;        
  5229.             }
  5230.            
  5231.             # TODO: Use a default color if there's no value in the color array
  5232.             $PHASECOLORS{$rc} = $color->[$l-1];
  5233.            
  5234.             # Color corresponding tx-code
  5235.             my $ph = $CODES->get(ray => $rc);
  5236.             if ( $ph ) {
  5237.                 # Phase is defined
  5238.                 $PHASECOLORS{$ph} = $color->[$l-1];            
  5239.                 print "Raycode $rc, phase $ph: layer $l, got color $color->[$l-1]\n" if $verbose;
  5240.             } else {
  5241.                 # Phase is not defined. What??
  5242.                 print "Warning! No phasecode is defined for ray $rc. I can't assign the calculated travel times"
  5243.                     ." to traced rays.\nPlease define 'ivray' in your r.in\n";
  5244.                
  5245.             }
  5246.         } else {
  5247.             # Phases other than 2 digits
  5248.             print "Add $rc to additional phases\n" if $verbose;
  5249.             push @ADDITIONALPHASES, $rc;
  5250.         }
  5251.         $i++;
  5252.     }
  5253.    
  5254.     #if (@ADDITIONALPHASES != @ADDITIONALCOLORS){
  5255.         #print "Your inputs for additional Phases and Colors don't have the same amount of entrys\n".
  5256.         ##"Please fix that in your configfile $CONFIGFILE\n";
  5257.         #print "Additional phases: @ADDITIONALPHASES\n".
  5258.         #"Additional colors: @ADDITIONALCOLORS\n".
  5259.         #"Use last color in array for the rest of phases\n";
  5260.         ##exit;
  5261.     #}
  5262.    
  5263.     # User added colors are tested and added to the %PHASECOLORS hash
  5264.     my $tw = new MainWindow(-title => "Colortester");
  5265.     for (my $i=0; $i <= $#ADDITIONALPHASES; $i++){
  5266.         if ($ADDITIONALCOLORS[$i]) {
  5267.             eval '$tw->configure(-background => $ADDITIONALCOLORS[$i])';
  5268.             if ( $@ ) {
  5269.                 #print "BLAH $@\n";
  5270.                 #print "Can't find color $ADDITIONALCOLORS[$i], replace it by #$ADDITIONALCOLORS[$i]\n";
  5271.                 $ADDITIONALCOLORS[$i] = "#$ADDITIONALCOLORS[$i]";
  5272.                
  5273.             }
  5274.             #print "Additional color: $ADDITIONALCOLORS[$i]\n";
  5275.         }
  5276.        
  5277.         # If no more colors available, use last one
  5278.        
  5279.         $PHASECOLORS{$ADDITIONALPHASES[$i]} = defined $ADDITIONALCOLORS[$i] ? $ADDITIONALCOLORS[$i] : $ADDITIONALCOLORS[-1];
  5280.         print "Add phase $ADDITIONALPHASES[$i] with color $PHASECOLORS{$ADDITIONALPHASES[$i]}\n" if $verbose;
  5281.     }
  5282.     $tw->destroy;
  5283.    
  5284.  
  5285. }
  5286.  
  5287. sub i_DrawButtons{
  5288.  
  5289. =PROGhead2 i_DrawButtons()
  5290.  
  5291. Draws first row of command buttons and attaches balloons.
  5292.  
  5293. =cut
  5294.  
  5295.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  5296.     #######
  5297.     # Create program-buttons
  5298.    
  5299.     # If no zpFileMask is given, PRay cannot find head-files
  5300.     if ( defined $CONFIG{zpdir} && defined $CONFIG{zpFileMask}) {
  5301.         my $zpbutton = $mw -> Button (-text=>"zp", -command => \&b_zp)
  5302.             -> pack(-side => 'left');
  5303.     }
  5304.    
  5305.     if ( defined $CONFIG{zp2ray} ) {
  5306.         my $zp2rayinvrbutton = $mw -> Button (-text=>"zp2ray", -command => \&b_zp2ray)
  5307.             -> pack(-side => 'left');
  5308.     }
  5309.     #my $cvbutton      = $mw -> Button (-text=>"c2v",             -command => \&b_c2v,  -state => 'normal')-> pack(-side => 'left');
  5310.     #my $vcbutton      = $mw -> Button (-text=>"v2c",             -command => \&b_v2c,  -state => 'normal')-> pack(-side => 'left');
  5311.     my $writebutton   = $mw -> Button (-text=>"Write v.in",    -command => \&b_writeModel, -state => 'normal')-> pack(-side => 'left');
  5312.  
  5313.     my $backmark          = $mw -> Button (
  5314.         -command => \&b_markback, -width => '23', -height => '22',
  5315.         -image => $mw->Photo(-file => "$ICONS/fastbackward.gif"), -compound => "left")-> pack(-side => 'left');
  5316.  
  5317.  
  5318.     my $undo          = $mw -> Button (
  5319.         -command => \&b_undo, -width => '23', -height => '22',
  5320.         -image => $mw->Photo(-file => "$ICONS/backward2.gif"), -compound => "left")-> pack(-side => 'left');
  5321.    
  5322.     my $reload          = $mw -> Button (
  5323.         -command => \&b_reload, -width => '23', -height => '22',
  5324.         -image => $mw->Photo(-file => "$ICONS/reload.gif"), -compound => "left")-> pack(-side => 'left');
  5325.    
  5326.     my $redo          = $mw -> Button (
  5327.         -command => \&b_redo, -width => '23', -height => '22',
  5328.         -image => $mw->Photo(-file => "$ICONS/forward2.gif"), -compound => "left")-> pack(-side => 'left');    
  5329.    
  5330.     my $forwardmark          = $mw -> Button (
  5331.         -command => \&b_markforward, -width => '23', -height => '22',
  5332.         -image => $mw->Photo(-file => "$ICONS/fastforward.gif"), -compound => "left")-> pack(-side => 'left');
  5333.    
  5334.     my $lastmodel          = $mw -> Button (
  5335.         -command => sub {
  5336.             my $v = _GetVersionNumber();
  5337.             print "Got to version $v";
  5338.             _gotoVersion($v);}
  5339.             , -width => '23', -height => '22',
  5340.         -image => $mw->Photo(-file => "$ICONS/fastforward.gif"), -compound => "left")-> pack(-side => 'left');
  5341.  
  5342.    
  5343.      my $mark          = $mw -> Button (
  5344.         -command => \&b_mark, -width => '23', -height => '22',
  5345.         -image => $mw->Photo(-file => "$ICONS/flag.gif"), -compound => "left")-> pack(-side => 'left');
  5346.      
  5347.      my $commentbutton = $mw -> Button (
  5348.         -command => [\&_editComment, \$VERSION], -width => '23', -height => '22',
  5349.         -image => $mw->Photo(-file => "$ICONS/comment.gif"), -compound => "left")-> pack(-side => 'left');
  5350.  
  5351.  
  5352.      my $goto          = $mw -> Button (
  5353.         -command => \&b_gotoVersion, -width => '23', -height => '22',
  5354.         -image => $mw->Photo(-file => "$ICONS/goto.gif"), -compound => "left")-> pack(-side => 'left');
  5355.    
  5356.      my $copytolast    = $mw -> Button (
  5357.         -command => \&b_copytolast, -width => '23', -height => '22',
  5358.         -image => $mw->Photo(-file => "$ICONS/copytolast.gif"), -compound => "left")-> pack(-side => 'left');
  5359.  
  5360.     my $vnodesbutton
  5361.      = $mw->Checkbutton( -variable =>\$showVNodes, -indicatoron => 0, -selectcolor => '', -width => '23', -height => '24',
  5362.             -command => [\&model::set, $model, "vnodes",     \$showVNodes],  
  5363.             -image => $mw->Photo(-file => "$ICONS/vnodesoff.gif"),
  5364.             -selectimage  => $mw->Photo(-file => "$ICONS/vnodes.gif"),
  5365.             -compound => "left")-> pack(-side => 'left');
  5366.    
  5367.     my $contoursbutton
  5368.          = $mw->Checkbutton( -variable =>\$showContours, -indicatoron => 0, -selectcolor => '',
  5369.             -width => '23', -height => '24',
  5370.             -command => [\&model::set, $model, "contours", \$showContours],
  5371.             -image => $mw->Photo(-file => "$ICONS/contoursOff.gif"),
  5372.             -selectimage  => $mw->Photo(-file => "$ICONS/contoursOn.gif"),
  5373.             -compound => "left")-> pack(-side => 'left');
  5374.  
  5375. =USERhead3 Contours
  5376.  
  5377. Contours can be overlayn on layers in GUI. To calculate contours GMT needs to be installed. There's
  5378. also a postscript file name contours.ps created. You can open it in gv with menu Commands->View contours.ps
  5379.  
  5380. =cut
  5381.  
  5382.    my $glueNodesbutton = $mw->Checkbutton ( -variable => \$glueNodes, -indicatoron => 0,
  5383.            -selectcolor => '',
  5384.            -width => '23', -height => '24',
  5385.            #-width => 2, -height => 1,
  5386.            -image => $mw->Photo(-file => "$ICONS/glueNodesOff.gif"),
  5387.            -selectimage  => $mw->Photo(-file => "$ICONS/glueNodes.gif"),
  5388.            -compound => "left",
  5389.            -command => [\&model::set, $model, "glueNodes", \$glueNodes])
  5390.            ->pack( -side => 'left');
  5391.  
  5392.        #$viewmenu->checkbutton(-label => 'Show Contourlines',   );
  5393.  
  5394.    my $rayinvr   = $mw -> Button (-text=>"rayinvr",   -command => \&b_rayinvr)-> pack(-side => 'left');
  5395.    my $dmpl      = $mw -> Button (-text=>"dmplstsqr", -command => \&b_dmpl)-> pack(-side => 'left');
  5396.  
  5397.  
  5398.    # Create Tomo2D button only, if this functionality is configured in $CONFIGFILE
  5399.    if (defined $CONFIG{'tomoPhase'} ||
  5400.       ( defined $CONFIG{'tomoPhasePg'} && defined $CONFIG{'tomoPhasePmP'})){
  5401.        
  5402.        print "Tomo2D functions enabled. \n" unless $quiet;
  5403.        
  5404.        if (defined $CONFIG{'tomoPhase'}){
  5405.            print "Phase number for tomo2D phases >$CONFIG{'tomoPhase'}<\n" unless $quiet;}
  5406.        
  5407.        if ( defined $CONFIG{'tomoPhasePg'} && defined $CONFIG{'tomoPhasePmP'}) {
  5408.            print "Phase number for tomo2D Pg phases >$CONFIG{'tomoPhasePg'}<\n".
  5409.                  "Phase number for tomo2D PmP phases >$CONFIG{'tomoPhasePmP'}<\n" unless $quiet;}
  5410.            
  5411.        my $tomo = $mw -> Button (-text=>"Tomo2D",    
  5412.             -command => [\&model::tomo, $model, "tomorays", \"1"]);
  5413.        $tomo-> pack(-side => 'left');
  5414.    }
  5415.    
  5416.    ###################################
  5417.    # STATION SELECTOR
  5418.    # Select station used for zp or other programms with only one option
  5419.    my $stationlb = $mw -> BrowseEntry(
  5420.        -label => "Station:", -variable =>\$station, #-labelPack => [-side => 'right'],
  5421.        -width => 10, -autolistwidth => 1, # -listwidth => 30, #-autolistwidth => 1,
  5422.        -command=>\&b_changeStation)
  5423.        -> pack (-side=>'left');
  5424.  
  5425.    ##########################
  5426.    # Enter reduction velocity
  5427.    $balloon->attach(
  5428.        $mw -> Checkbutton (-text => "vred", -variable => \$vredbutton,
  5429.        -indicatoron => 0,-selectcolor => '', -pady => '4',
  5430.        -command => [\&_set, "vredstate", \$vredbutton], -state => 'normal') -> pack (-side=>'left')
  5431.    , -balloonmsg => "Show travel times with velocity reduction");
  5432.        
  5433.    my $entry = $mw -> Entry (-textvariable => \$CONFIG{vred}, -width => '4') -> pack (-side=>'left');
  5434.    $entry -> bind ('<Return>', sub {
  5435.        if ( $CONFIG{vred} =~ /^\d+\.?\d*/ ) {
  5436.            _set("vred", \$CONFIG{vred});
  5437.        }
  5438.    });
  5439.    
  5440.  
  5441.    # Attach info balloons
  5442.    $balloon->attach($rayinvr, -balloonmsg => "Run rayinvr and update graphics",  
  5443.      -statusmsg => "Press the Button to exit the application");
  5444.    
  5445.    $balloon->attach($backmark, -balloonmsg =>
  5446.    "Go back to previous marked model version");
  5447.    
  5448.    $balloon->attach($undo, -balloonmsg =>
  5449.    "Go to previous model version");
  5450.  
  5451.    $balloon->attach($reload, -balloonmsg =>
  5452.    "Reload v.in from disk");      
  5453.  
  5454.    $balloon->attach($redo, -balloonmsg =>  
  5455.    "Go to next model version ");
  5456.  
  5457.    $balloon->attach($forwardmark, -balloonmsg =>
  5458.    "Go forward to next marked model version");      
  5459.  
  5460.    $balloon->attach($lastmodel, -balloonmsg =>
  5461.    "Go to last model version");      
  5462.  
  5463.    $balloon->attach($mark, -balloonmsg =>
  5464.    "Add mark to this version for faster navigation.\n".
  5465.    "You may edit marked models using menu File->Edit marked models");
  5466.  
  5467.    $balloon->attach($commentbutton, -balloonmsg =>
  5468.    "Add or edit a comment for this model");
  5469.  
  5470.    $balloon->attach($goto, -balloonmsg =>
  5471.    "Go to version ..");
  5472.  
  5473.    $balloon->attach($copytolast, -balloonmsg =>
  5474.    "Copy this model to latest version");
  5475.    
  5476.    $balloon->attach($glueNodesbutton, -balloonmsg =>
  5477.    "Move all nodes of pinched layers together");
  5478.    
  5479.    $balloon->attach($writebutton, -balloonmsg =>
  5480.    "This writes v.in.\n".
  5481.    "A backupfile with version number is created in history directory.\n".
  5482.    "Use buttons to the right for navigation different versions");
  5483.    
  5484.    $balloon->attach($dmpl, -balloonmsg =>
  5485.    "Run damp least square inversion. A backup file for undo is created");
  5486.  
  5487.    ##########################
  5488.    # Set type of picks to be shown (manual and/or calculated        
  5489.    
  5490.    $balloon->attach(
  5491.        $mw -> Checkbutton (-text => "Obs", -variable => \$PicksManButton,
  5492.            -indicatoron => 0,-selectcolor => '', -pady => '4',
  5493.            -command => [\&_set, "PicksMan", \$PicksManButton], -state => 'normal') -> pack (-side=>'left')
  5494.    , -balloonmsg => "Show observed arrivals");
  5495.    
  5496.    $balloon->attach(
  5497.        $mw -> Checkbutton (-text => "Calc", -variable => \$PicksCalButton,
  5498.            -indicatoron => 0,-selectcolor => '', -pady => '4',
  5499.            -command => [\&_set, "PicksCal", \$PicksCalButton], -state => 'normal') -> pack (-side=>'left')
  5500.    , -balloonmsg => "Show calculated arrivals from RAYINVR");
  5501.    
  5502.    $balloon->attach(
  5503.        $mw -> Checkbutton (-text => "Rays", -variable => \$ShowRaysButton,
  5504.            -indicatoron => 0,-selectcolor => '', -pady => '4',
  5505.            -command => [\&_set, "ShowRays", \$ShowRaysButton], -state => 'normal') -> pack (-side=>'left')
  5506.    , -balloonmsg => "Show calculated ray-paths from RAYINVR");
  5507.  
  5508. i_DrawButtonsPhases();
  5509. i_DrawButtonsStations($stationlb);
  5510.  
  5511. }
  5512.  
  5513. sub i_DrawButtonsStations{
  5514.  
  5515. =PROGhead2 i_DrawButtonsStations(stationlb)
  5516.  
  5517. Draws station buttons and station selector. Needs list as argument to
  5518. enter stations
  5519.  
  5520. =cut
  5521.  
  5522.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  5523.        
  5524.    ###############################################################
  5525.    # Buttons for selecting STATIONS for raytracing and plotting
  5526.    ###############################################################
  5527.    my $stationlb = shift;
  5528.    my $stationbuttons = $mw -> Frame(-label => "Stations:", -labelPack => [-side => "left", -anchor => 'nw'])
  5529.                                                    -> pack(-side=>'bottom', -anchor => 'w', -after => $cns);
  5530.    # Frame for first line
  5531.    my $f1 = $stationbuttons -> Frame->pack(-side=>'top', -anchor => 'w');    
  5532.    # Frame for second line
  5533.    my $f2 = $stationbuttons -> Frame->pack(-side=>'top', -anchor => 'w');    
  5534.    my $fr = $f1;     # Frame to put button to
  5535.    
  5536.    # Station are sorted after their profile position
  5537.    my @stations = sort{$a <=> $b}(keys(%{$model->{stationkm}}));
  5538.    #print "(D) Draw x stations ".@stations." = km @stations\n" if $debug;
  5539.    ####################
  5540.    # Stationbuttons
  5541.    my $i = 0;
  5542.    my $stationsperline = $CONFIG{stationsperline};
  5543.    #print "(DEV) Draw Stationbuttons\n" if $dev;
  5544.    foreach my $km ( @stations) {
  5545.        $i++;
  5546.        my $name = $model->{stationkm}{$km};
  5547.        #print "(D) Draw $i. station button $name at km $km\n" if $debug;
  5548.        
  5549.        # Define stationnames for second row
  5550.        #if ($name =~ /^[0-9]*$/ && $name > 200) {
  5551.         if ($i >= $stationsperline ) {  
  5552.            #print "Second frame\n";
  5553.            $fr = $f2;
  5554.        } else {
  5555.            $fr = $f1;
  5556.        }
  5557.        
  5558.        #if ($name !~ m/[sS]tr*/){
  5559.            # Attach shot number as given by rayinvr
  5560.            # Find all shots at given km
  5561.            my @shot = grep {$RIN->{xshot}[$_] == $km} 0 .. $#{$RIN->{xshot}};
  5562.            #print "Give km $km shotnumber @shot\n";
  5563.            if ( @shot > 1 ) {
  5564.                print "\n\nWARNING !!\n\n You have km $km ".@shot."-times in ".
  5565.                    "your r.in. This leads may lead to ugly plots\n";
  5566.            }
  5567.            
  5568.            #print "(D) Create button for station >$name< with variable >$stationlist{$name}[3]< if shot[0] $shot[0]\n" if $debug;
  5569.            $balloon-> attach (
  5570.                    $fr -> Checkbutton (-text => $name, -variable => \$stationlist{$name}[3],
  5571.                    -command => [\&b_drawStation, $name], -font => "Helvetica 8",
  5572.                    -indicatoron => 0, -selectcolor => '', -padx => '5')
  5573.                 -> pack (-side=>'left')
  5574.             , -balloonmsg=> "km $km, shot ".($shot[0]+1)) if @shot; #  Print button only, if station is in rayinvrs r.in xshot list
  5575.        #} else {
  5576.            #print "Do not draw button for this station. It matches a streamer name.\n"
  5577.            #."Call the programmer. This is a bug \n";
  5578.        #}
  5579.        
  5580.     }
  5581.  
  5582.  
  5583.    #my $stationlb  = $mw-> LabOptionmenu (
  5584.        #-label => 'Station',
  5585.        #-labelPack => [-side => 'left'],
  5586.        #-variable =>\$station, -command=>\&b_changeStation,
  5587.        #-width => "8"
  5588.        #)-> pack (-side=>'left');
  5589.  
  5590.    # Add station to station selector (for ZP)
  5591.    foreach (sort(keys(%stationlist))){
  5592.        $stationlb -> insert('end', $_);
  5593.        #$stationlb -> insert('end',$stationlist{$_}[0]);
  5594.        #print "Add Option $_ $stationlist{$_}[0]\n";
  5595.        #$stationlb -> addOptions([$stationlist{$_}[0] => $_]);
  5596.        
  5597.    }
  5598.    $station = (sort(keys(%stationlist)))[0];
  5599. }
  5600.  
  5601.  
  5602.  
  5603. sub i_DrawButtonsPhases {
  5604.  
  5605. =PROGhead2 Phasebuttons
  5606.  
  5607. Phasebuttons are drawn for each phase in the phasecolor-hash. RAYSTATUS
  5608. gets initialized
  5609.  
  5610. =cut
  5611.  
  5612.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  5613.    ######################################################################
  5614.    # GUI BUTTONS for PHASES to draw
  5615.    # Model-Region
  5616.  
  5617.    my $raybuttons = $mw -> Frame( #-label => "Raycodes"#       \nAdditionals:     "
  5618.            labelPack => [-side => 'left', -anchor=>'w']) -> pack(-side=>'bottom', -anchor => 'w', -after => $cns);
  5619.    my $raycodeButtons    = $raybuttons-> Frame() -> pack(-side=>'top', -anchor => 'w');
  5620.    my $phasecodesButtons = $raybuttons-> Frame() -> pack(-side=>'top', -anchor => 'w');
  5621.    $raycodeButtons   ->Label(-text => "Traced rays",   -width => '13', -anchor=>'nw')->pack(-side => 'left', -anchor=>'nw');
  5622.    $phasecodesButtons->Label(-text => "Picked phases", -width => '13', -anchor=>'nw')->pack(-side => 'left', -anchor=>'nw');
  5623.    
  5624.    my $frame;
  5625.  
  5626.    my $ph = -1;
  5627.    my $rcodes = $CODES->get('raycodes');
  5628.    my $phcodes = $CODES->get('phasecodes');
  5629.    
  5630.    # Check if number of phasecodes in r.in is larger than traced rays
  5631.    # Add excess phases to additional Phases
  5632.    if ( @$rcodes < @$phcodes ) {
  5633.        # More phasecodes in r.in than traced rays.
  5634.        print "i_DrawButtonsPhases() Rays and phases in r.in have different length\n";
  5635.        push @ADDITIONALPHASES, @{$phcodes}[$#$rcodes+1 .. $#$phcodes];
  5636.    }
  5637.    
  5638.    # Add raycodes
  5639.    for ( my $i = 0; $i <= $#$rcodes; $i++ ) {
  5640.        my $ray = $rcodes->[$i];
  5641.        my $ph = $phcodes->[$i];
  5642.        my $message = "Rays";
  5643.  
  5644.        my ($l, $t) = split(/\./, $ray); # layer.type
  5645.        #print "Button for ray >$ray<, split to >$l< and >$t<, phase >$ph<\n";
  5646.        $frame = $raycodeButtons;
  5647.        unless ( $ray =~ m/\./ ) {
  5648.            # This should not happen. No phasecodes should be in the raycode-hash of rayinvr
  5649.            print "WARNING!! The programm should never reach this point."
  5650.                ."Please let the programmer now and send the used r.in\n";
  5651.            $message = "Additional Phase";
  5652.            $frame = $phasecodesButtons;
  5653.        } else {
  5654.            if ($t == 1) { $message = "Refracted in layer ".($l+0);}
  5655.            if ($t == 2) { $message = "Reflected in layer ".($l);}
  5656.            if ($t == 3) { $message = "Headwave in layer ".($l+1);}
  5657.            if ($t == 4) { $message = "Water multiple of reflection in layer ".($l);}
  5658.            #print ".$model->getCode( 'phase' => $c)".$model->getCode( 'phase' => $c);
  5659.            # No phasecode defined for this ray??
  5660.            $ph = " not defined (set 'ivray' in r.in )" unless ( $ph );
  5661.            $message .= ". raycode = $ray, phasecode = $ph";
  5662.        }
  5663.        #print "@t: Layer: $t[0], Type $t\n";
  5664.        my $label;
  5665.        #print "Color for ray >$ray< $PHASECOLORS{$ray}\n";
  5666.        $balloon->attach(
  5667.            $frame -> Checkbutton (-text => $ray, -variable => \$RAYSTATUS{$ray}, -indicatoron => 0, -padx => '5',
  5668.                                          #-command => \&b_drawAll, -selectcolor=>$PHASECOLORS{$_})
  5669.                                          -font => "Helvetica 8", -width => 2,
  5670.                                          #-command => [\&b_drawPhase, $ray, $ph],
  5671.                                          -command => sub {
  5672.                                              $RAYSTATUS{$ph} = $RAYSTATUS{$ray};
  5673.                                              $model->drawPhase("ray", [$ray, $RAYSTATUS{$ray}], "phase", [$ph, $RAYSTATUS{$ray}]);
  5674.                                              },
  5675.                                          -selectcolor=>$PHASECOLORS{$ray}
  5676.                                          )
  5677.                            -> pack (-side=> 'left')
  5678.            , -balloonmsg=> "$message" )            
  5679.        ;
  5680.        
  5681.        # Reset old status for buttons read from p.status (saved in DRAWNPHASES)
  5682.        #my $phase = $_;
  5683.        my $switch = (grep {$_ eq "$ray"} @DRAWNRAYS)? 1 : 0;
  5684.        #print "grep $_ in DRAWNPHASES = @DRAWNPHASES, switch = $switch\n";
  5685.        $RAYSTATUS{$ray} = $switch;         # Initialize this buttonvariable
  5686.        $RAYSTATUS{$ph} = $RAYSTATUS{$ray};
  5687.    } # Add raycodes
  5688.    
  5689.    # Add additional phasecodes without corresponding raycodes
  5690.    foreach my $ph ( @ADDITIONALPHASES ) {
  5691.        my $message = "Phasecode without traced rays";
  5692.        my $ray = '-';
  5693.        $frame = $phasecodesButtons;
  5694.  
  5695.        $balloon->attach(
  5696.            $frame -> Checkbutton (-text => $ph, -variable => \$RAYSTATUS{$ph}, -indicatoron => 0, -padx => '5',
  5697.                                          #-command => \&b_drawAll, -selectcolor=>$PHASECOLORS{$_})
  5698.                                          -font => "Helvetica 8", -width => 2,
  5699.                                          #-command => [\&b_drawPhase, $ray, $ph],
  5700.                                          #-command => [\&b_drawPhase, $ph],
  5701.                                          -command => sub {
  5702.                                              $model->drawPhase("phase", [$ph, $RAYSTATUS{$ph}]);
  5703.                                              },
  5704.                                          -selectcolor=>$PHASECOLORS{$ph}
  5705.                                          )
  5706.                            -> pack (-side=> 'left')
  5707.            , -balloonmsg=> "$message" )            
  5708.        ;
  5709.        
  5710.        #TODO: RAYSTATUS initialization can be moved to its own sub and
  5711.        # just used here. Best init is right after reading status file
  5712.        
  5713.        # Reset old status for buttons read from p.status (saved in DRAWNPHASES)
  5714.        my $switch = (grep {$_ eq "$ph"} @DRAWNRAYS)? 1 : 0;
  5715.        #print "(DEV) grep $ph in DRAWNPHASES = @DRAWNPHASES, switch = $switch\n" if $dev;
  5716.        $RAYSTATUS{$ph} = $switch;  # Initialize this buttonvariable
  5717.    } # foreach ADDITIONALPHASES
  5718.  
  5719.    $RAYSTATUS{'-'} = 0;
  5720.    #print Dumper \%RAYSTATUS;
  5721. }
  5722.  
  5723. sub i_MenuBar {
  5724.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  5725.  
  5726.    
  5727.    # Make MENUs
  5728.    # Make menubar
  5729.    my $menubar = $mw->Menu(-type => 'menubar', -borderwidth => 1);#->pack(-side => 'top', -fill => 'x');
  5730.    $mw->configure(-menu => $menubar);
  5731.    
  5732.    #####################################3
  5733.    # FILE MENU
  5734.    my $f = $menubar->cascade(-label => '~File', -tearoff => 0);
  5735.    $f->command(-label => 'Open files ..',                -command=> \&b_openfiles,
  5736.       -image => $mw->Getimage("openfile"), -compound => "left");
  5737.    $f->command(-label => 'Edit r.in',                    -command=> \&b_editRin);  
  5738.    #$f->command(-label => 'Edit ALL velocity nodes',      -command=> \&m_editVNodes);  
  5739.    #$f->command(-label => 'Edit marked models',           -command=> \&b_editMarkedmodels);    
  5740.    $f->command(-label => 'Reload v.in',                  -command=> \&b_reload);
  5741.    $f->command(-label => 'Reload tx.in',                 -command=> \&b_reloadTx);
  5742.    #$f->command(-label => 'Go to version ..',             -command=> \&b_gotoVersion);  
  5743.    $f->command(-label => 'Export rays&picks',            -command=> \&b_export);
  5744.    $f->command(-label => 'Export velocity nodes',        -command=> [\&model::writeXZV, $model]);
  5745.    $f->command(-label => 'Export layer polygons',        -command=> [\&model::exportPolygons, $model]);
  5746.    $f->command(-label => 'Extract 1D velocity profiles', -command=> \&b_extract);
  5747.    $f->command(-label => 'Export resolution',            -command=> [\&model::resolution, $model]);
  5748.    $f->command(-label => 'Export igmas model',           -command=> \&b_igmas);
  5749.    $f->command(-label => 'Export density model',         -command=> [\&model::writeVin, $model,'file',"rho.in"]);
  5750.    $f->separator;
  5751.    $f->command(-label => 'Edit PRay configuration',      -command=> \&b_configEdit);
  5752.    $f->command(-label => 'Quit',                         -command=> \&b_quit);
  5753.    
  5754.    #####################################3
  5755.    # MODEL MENU
  5756.    
  5757.    my $edit = $menubar->cascade(-label => '~Edit model', -tearoff => 0);
  5758.     $edit->command(-label => 'Edit model setup',             -command=>
  5759.       # sub {print "Hello World\n" });  
  5760.    \&m_editModel);  
  5761.    $edit->command(-label => 'Edit ALL velocity nodes',       -command=> \&m_editVNodes);
  5762.    $edit->command(-label => 'Set partial derivatives for all v nodes',   -command => [\&model::editAllParDerivs, $model, 1]);
  5763.    $edit->command(-label => 'Unset partial derivatives for all v nodes', -command => [\&model::editAllParDerivs, $model, 0]);
  5764.    $edit->command(-label => 'Edit marked models',            -command=> \&b_editMarkedmodels);
  5765.    $edit->command(-label => 'Go to version ..',              -command=> \&b_gotoVersion);
  5766.    
  5767.    
  5768.    #####################################3
  5769.    # COMMAND MENU
  5770.    my $commandmenu = $menubar->cascade(-label => '~Commands', -tearoff => 0);
  5771.    $commandmenu->command(-label=>'vmodel',                 -command=> \&b_vmodel);
  5772.    $commandmenu->command(-label=>"c2v",                    -command=> \&b_c2v,  -state => 'normal');
  5773.    $commandmenu->command(-label=>"v2c",                    -command=> \&b_v2c,  -state => 'normal');
  5774.    $commandmenu->command(-label=>"View contours.ps ",      -command=> \&b_viewContours,-state => 'normal');
  5775.    $commandmenu->command(-label=>'View model differences', -command=> \&b_modelDifferences);
  5776.    $commandmenu->command(-label=>'Make resolution plot',   -command=> \&b_resolution);
  5777.  
  5778. =USERhead3 User defined commands
  5779.  
  5780. User defined commands/scripts can be added to 'Commands'-menu with p.conig
  5781. e.g. add script plotMyModel.csh with
  5782.  
  5783. command = Plot Model = $BIN/plotMymodel.csh
  5784.  
  5785. C<$BIN> can be an environment variable.
  5786.  
  5787. =cut
  5788.  
  5789.    # Add user defined commands from $CONFIGFILE
  5790.    if(defined $CONFIG{command} && $CONFIG{command} > 0 ){
  5791.        $commandmenu->separator;
  5792.  
  5793.        print "User defined commands added to menu\n" unless $quiet;
  5794.        foreach my $command (@{$CONFIG{command}}){
  5795.            my ($label, $cmd) = split (/=/, $command);
  5796.            print "Add '$label' and command >$cmd<\n" unless $quiet;            
  5797.            $commandmenu -> command (-label=>"$label", -state => 'normal',
  5798.            -command => sub {
  5799.                defined( my $pid = fork ) or die "Cannot fork: $!";
  5800.                unless( $pid ) {
  5801.                    system("$cmd");
  5802.                    warn "\nleaving child";  
  5803.                    CORE::exit(0);
  5804.                }
  5805.                print ">$cmd< is running\n";
  5806.            });
  5807.        }
  5808.    }
  5809.    
  5810.    #####################################3
  5811.    # PHASE MENU
  5812.    my $phasesmenu = $menubar->cascade(-label => '~Phases', -tearoff => 0);
  5813.    $phasesmenu->checkbutton(-label => "All",         -command =>\&b_AllRays, -variable => \$allRaysButton);
  5814.    $phasesmenu->checkbutton(-label => "Reflections", -command => \&b_AllRfl, -variable => \$allRflButton, -selectcolor=> "white");      
  5815.    $phasesmenu->checkbutton(-label => "Refractions", -command => \&b_AllRfr, -variable => \$allRfrButton, -selectcolor=> "white");
  5816.    $phasesmenu->checkbutton(-label => "Multiples",   -command => \&b_AllMul, -variable => \$allMulButton, -selectcolor=> "white");
  5817.    $phasesmenu->separator;
  5818.    $phasesmenu->command(-label => "Find phases", -command => \&b_getPhases,);
  5819.  
  5820.  
  5821.    #####################################3
  5822.    # VIEW MENU
  5823.    my $viewmenu = $menubar->cascade(-label => '~View', -tearoff => 0);
  5824.    $viewmenu->command    (-label => "Show comments",    -command => \&b_viewComments);
  5825.    $viewmenu->command    (-label => "Show results",     -command => \&b_viewResults);
  5826.    $viewmenu->checkbutton(-label => "Show nodes",       -command => [\&model::set, $model, "nodes",     \$showNodes],      -variable =>\$showNodes);
  5827.    $viewmenu->command    (-label => "Show model status",-command => [\&b_status]) ;
  5828.    $viewmenu->command    (-label => "Show model status in range",-command => \&b_status_range) ;
  5829.  
  5830.    $viewmenu->checkbutton(-label => 'Show blocks', -command => [\&model::set, $model, "blocks",     \$showBlocks],     -variable =>\$showBlocks);
  5831.  
  5832.    $viewmenu->checkbutton(-label => 'Show v-nodes',    -command => [\&model::set, $model, "vnodes",     \$showVNodes],  -variable =>\$showVNodes);
  5833.    $viewmenu->checkbutton(-label => 'Annotate v-nodes',-command => [\&model::set, $model, "annotvnodes",\$annotVNodes],  -variable =>\$annotVNodes);
  5834.    
  5835.    $viewmenu->checkbutton(-label => 'Show gradients',     -command => [\&model::set, $model, "vgrid",     \$showGrid],      -variable =>\$showGrid);  
  5836.    $viewmenu->checkbutton(-label => 'Show contourlines',  -command => [\&model::set, $model, "contours", \$showContours],-variable =>\$showContours);
  5837.    $viewmenu->checkbutton(-label => 'Colored contours?',  -command => [\&model::set, $model, "contourcolor", \$contourcolor],-variable =>\$contourcolor);
  5838.    
  5839.    # Tomo2D related commands    
  5840.    if (defined $CONFIG{tomoGrid} && (defined $CONFIG{tomoPhase} || defined $CONFIG{tomoPhasePg})){
  5841.        $viewmenu->checkbutton(-label => 'Show Tomo grid',
  5842.        -command => [\&model::tomo, $model, "tomoGrid", \$showTomoGrid],      
  5843.        -variable =>\$showTomoGrid);
  5844.         $viewmenu->checkbutton(-label => 'Show tomo contours',
  5845.        -command => [\&model::tomo, $model, "tomoContours", \$showTomoContours],      
  5846.        -variable =>\$showTomoContours);      
  5847.    }
  5848.    
  5849.    # Show densities
  5850.    my $showDensities = 0;
  5851.    $viewmenu->checkbutton(-label => 'Annotate densities', -command => [\&model::set, $model, "densities", \$showDensities], -variable =>\$showDensities);  
  5852.  
  5853.    # Show resolution
  5854.    my $showResolution = 0;
  5855.    $viewmenu->checkbutton(-label => 'Annotate resolution', -command => [\&model::set, $model, "resolution", \$showResolution], -variable =>\$showResolution);  
  5856.    
  5857.    # Are xz-files to be overlayn in modelspace?
  5858.    if (defined $CONFIG{xz}) {
  5859.        my $showXZButton = 1;
  5860.        $viewmenu->checkbutton(-label => 'Show xz overlay',      -command => [\&model::set, $model, "xz",     \$showXZButton],      -variable =>\$showXZButton);  
  5861.    }
  5862.    # Are xt-files to be overlayn in modelspace?
  5863.    if (defined $CONFIG{xt}) {
  5864.        my $showXTButton = 1;
  5865.        $viewmenu->checkbutton(-label => 'Show xt overlay',      -command => [\&model::set, $model, "xt",     \$showXTButton],      -variable =>\$showXTButton);  
  5866.    }
  5867.    $menubar->separator;
  5868.    
  5869.    #####################################3
  5870.    # HELP MENU
  5871.    my $help = $menubar->cascade(-label => '  ~Help',  -tearoff => 0,
  5872.     -image => $mw->Photo(-file => "$ICONS/pray2.gif", -width => 18, -height => 14)
  5873.     , -compound => "left",    
  5874.         );
  5875.    $help->command(-label => "User documentation", -command => \&b_help);
  5876.    $help->command(-label => "User documentation - html", -command => \&b_helpHTML)  if ( $CONFIG{browser} );
  5877.    $help->command(-label => "About",              -command => \&b_about);
  5878.  
  5879.    
  5880. }
  5881.  
  5882. sub i_Messages {
  5883.  
  5884. =PROGhead2 i_Messages()
  5885.  
  5886. Collects messages during initialization
  5887.  
  5888. =cut
  5889.  
  5890.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  5891.    my $msg = shift;
  5892.    $INITMSG = $INITMSG.$msg;
  5893. }
  5894.  
  5895. sub i_checkPRayVersion {
  5896.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  5897.    
  5898.    #return unless ( $STATUS{PRayVersion} );
  5899.    
  5900.    my ($PRayVersion, $msg) = version::check($STATUS{PRayVersion});
  5901.    
  5902.    # If PRayVersion is not set, do not display update news. A not set
  5903.    # PRayVersion variable means, that not p.status is present (e.g. for
  5904.    # a brand new rayinvr directory.
  5905.    if (-f "p.status" && $msg) {
  5906.  
  5907.        $mw->withdraw();
  5908.        my $m =   $mw->Dialog( #-popover => $mw,
  5909.                -title => "Update news",
  5910.                -text => $msg,
  5911.                #-width => 75,
  5912.                -wraplength => '6i',
  5913.                -buttons => ['Ok']
  5914.                );
  5915.        $m->Show;
  5916.    }
  5917.    
  5918.    $STATUS{PRayVersion} = $PRayVersion;
  5919. }
  5920.  
  5921. ###################################
  5922. # GUI subroutines
  5923. ####
  5924. sub zoomCanvasInit {
  5925.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  5926.    
  5927.    # Clean up measure stuff (if present)
  5928.    $cns->delete('MEASURE');
  5929.    
  5930.    my $type = $_[1];
  5931.    my $x = $cns->canvasx($Tk::event->x);
  5932.    my $y = $cns->canvasy($Tk::event->y);
  5933.  
  5934.    my $xt = $lzd->canvasx($Tk::event->x);
  5935.    my $yt = $lzd->canvasy($Tk::event->y);
  5936.  
  5937.    #print "zoomCanvasInit()\n";
  5938.    @zoomRectCoords = ( $x,  $y,  $x,  $y) if ($type eq 'm');
  5939.    @zoomRectCoords = ($xt, $yt, $xt, $yt) if ($type eq 't');
  5940.    
  5941.    print "(DEV) Zoom rectangle called from >$type< ".
  5942.            "model >@zoomRectCoords< lzd xt $xt yt $yt\n" if $dev;
  5943.    
  5944.    
  5945.    $zoomRect = $cns->createRectangle(
  5946.                                    zoomReverseT(@zoomRectCoords, $type, "m"),
  5947.                                    -outline => 'red',
  5948.                                   -tags    => ['ZOOM'],);
  5949.  
  5950.    $zoomRectzeit = $lzd->createRectangle(
  5951.                                    zoomReverseT(@zoomRectCoords, $type, "t"),
  5952.                                    -outline => 'red',
  5953.                                   -tags    => ['ZOOM'],);
  5954. }
  5955.  
  5956. sub zoomReverseT {
  5957.     #
  5958.    # Reverses y-coordinate for time scale, if set
  5959.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  5960.    
  5961.    # Function requires input type and output type
  5962.    # eg model or time depending on the canvas where the mouse pointer is
  5963.    my ($x, $y, $x2, $y2, $type, $out) = @_;
  5964.    my @coords = ($x, $y, $x2, $y2);
  5965.  
  5966.    unless ($out) {
  5967.        print "BUG!! The output is missing. Do something!!!\n";
  5968.        return @coords; };
  5969.    
  5970.    #print "(DEV) zoomReverseT Got coordinates >@coords<  and type >$type<, out $out " if $dev;
  5971.    
  5972.    # Reverse output y if input type and output type are not equal
  5973.    if ( $type ne $out) {
  5974.        $coords[1] = $box->[3] - $coords[1] if $CONFIG{reverseTime};
  5975.        $coords[3] = $box->[3] - $coords[3] if $CONFIG{reverseTime};
  5976.    }
  5977.  
  5978.  
  5979.    #print "(DEV) zoomReverseT return >@coords<\n" if $dev;
  5980.    
  5981.    #print " $coords[3] -= -$box->[3] " if $CONFIG{reverseTime};
  5982.  
  5983.    return @coords;
  5984.    
  5985. }
  5986.  
  5987. sub zoomCanvasSize {
  5988.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  5989.    my $type = $_[1];
  5990.    
  5991.    # Clean up measure stuff (if present)
  5992.    $cns->delete('MEASURE');
  5993.    
  5994.    @zoomRectCoords[2,3] = ($cns->canvasx($Tk::event->x),
  5995.                            $cns->canvasy($Tk::event->y)) if ($type eq 'm');
  5996.    
  5997.    @zoomRectCoords[2,3] = ($lzd->canvasx($Tk::event->x),
  5998.                            $lzd->canvasy($Tk::event->y)) if ($type eq 't');
  5999.    
  6000.    $cns->coords($zoomRect     => zoomReverseT(@zoomRectCoords,$type, "m"));
  6001.    $lzd->coords($zoomRectzeit => zoomReverseT(@zoomRectCoords,$type, "t"));
  6002.  
  6003. }
  6004.  
  6005.  
  6006. sub zoomCanvasFinish {
  6007.    printf "(T) %s(@_)\n", commons::whoami() if $tree;
  6008.    my $type = $_[1];
  6009.  
  6010.    # Get rectangle coordinats for model and time (respects reversed
  6011.    # time axis
  6012.    my @mcoords = $cns->coords($zoomRect);
  6013.    my @tcoords = $lzd->coords($zoomRectzeit);
  6014.    
  6015.    # Delete the rectangles.
  6016.    $cns->delete($zoomRect);
  6017.    $lzd->delete($zoomRectzeit);
  6018.    $lzd->delete('ZOOM');
  6019.    $cns->delete('ZOOM');
  6020.    $cns->delete('MEASURE');
  6021.    
  6022.    # Get rectangle size
  6023.    my $pxl = abs($zoomRectCoords[0] - $zoomRectCoords[2]);
  6024.    my $pyl = abs($zoomRectCoords[1] - $zoomRectCoords[3]);
  6025.    
  6026.    # Was the rectangle big enough?
  6027.    return if ( $pxl < 10 || $pyl < 10);
  6028.    
  6029.    # Let's find the zooming factor.
  6030.     my $dx = $cns->width  / $pxl;
  6031.     my $dy = $cns->height / $pyl;
  6032.    
  6033.     print "(DEV) zoom with dx $dx dy $dy\n" if $dev;
  6034.     # Make newx smaller value of both
  6035.     my $newx1 = $zoomRectCoords[0] < $zoomRectCoords[2] ? $zoomRectCoords[0] : $zoomRectCoords[2];
  6036.     my $newx2 = $zoomRectCoords[0] > $zoomRectCoords[2] ? $zoomRectCoords[0] : $zoomRectCoords[2];    
  6037.     my $newy1 = $zoomRectCoords[1] < $zoomRectCoords[3] ? $zoomRectCoords[1] : $zoomRectCoords[3];
  6038.     my $newy2 = $zoomRectCoords[1] > $zoomRectCoords[3] ? $zoomRectCoords[1] : $zoomRectCoords[3];
  6039.    
  6040.     # Sort coords
  6041.     if ($mcoords[0] > $mcoords[2]){
  6042.         @mcoords = ($mcoords[2], $mcoords[1], $mcoords[0], $mcoords[3]);
  6043.     }
  6044.     if ($mcoords[1] > $mcoords[3]){
  6045.         @mcoords = ($mcoords[0], $mcoords[3], $mcoords[2], $mcoords[1]);
  6046.     }
  6047.     if ($tcoords[0] > $tcoords[2]){
  6048.         @tcoords = ($tcoords[2], $tcoords[1], $tcoords[0], $tcoords[3]);
  6049.     }
  6050.     if ($tcoords[1] > $tcoords[3]){
  6051.         @tcoords = ($tcoords[0], $tcoords[3], $tcoords[2], $tcoords[1]);
  6052.     }
  6053.    
  6054.     # Find new limits for visible canvas (real coordinates)
  6055.     #my $kmx  = $newx1 / $xscale + $CONFIG{xmin};
  6056.     #my $kmx2 = $newx2 / $xscale + $CONFIG{xmin};
  6057.  
  6058.     #my $d1m  = $newy1 / $yscale + $CONFIG{zmin};
  6059.     #my $d2m  = $newy2 / $yscale + $CONFIG{zmin};
  6060.  
  6061.     #my $t1   = $newy1 / $ytscale;
  6062.     #my $t2   = $newy2 / $ytscale;
  6063.    
  6064.     my ( $km1, $z1,  $km2, $z2) = $model->screen2model(\@mcoords,"space");
  6065.     my ($kmt1, $t1, $kmt2, $t2) = $model->screen2model(\@tcoords,"time");
  6066.     if ( $t1 > $t2 ) {
  6067.         my $tmp = $t1;
  6068.         $t1 = $t2;
  6069.         $t2 = $tmp;
  6070.     }
  6071.     print "(DEV) new limits will be from km $km1 to $km2, depth $z1 to $z2 and time $t1 to $t2\n" if $dev;
  6072.    
  6073.     #print "(DEV) new limits will be from km $kmx to $kmx2 and".
  6074.         #"tiefe  +mx: $d1m bis $d2m \n".
  6075.         #"TIME: $t1, $t2\n" if $dev;
  6076.    
  6077.      # Scale with different scale factors
  6078.      $cns->scale('all' => 0, 0, $dx, $dy);
  6079.      $lzd->scale('all' => 0, 0, $dx, $dy);
  6080.  
  6081.     # Change/scale bounding box
  6082.     $box->[2]*=$dx;
  6083.     $box->[3]*=$dy;
  6084.      #print "Spezial $_ for @{$box}\n";
  6085.    
  6086.     # Resize the canvas (scrollregion).
  6087.     $cns->configure(-scrollregion => $box);
  6088.     $lzd->configure(-scrollregion => $box);
  6089.      
  6090.     # Now we change the view to center on correct area.
  6091.     my $xmove  = $mcoords[0] * $dx / $box->[2];
  6092.     my $ymove  = $mcoords[1] * $dy / $box->[3];
  6093.     my $ytmove = $tcoords[1] * $dy / $box->[3];
  6094.    
  6095.     # my $dx = $cns->width  / $pxl;
  6096.     # $xmove  = $mcoords[0] * $dx / $box->[2];
  6097.     # $xmove  = $mcoords[0] * ($cns->width  / $pxl) / $box->[2]
  6098.     # $pxl = abs($zoomRectCoords[0] - $zoomRectCoords[2]);
  6099.     # $xmove  = $mcoords[0] / $pxl)
  6100.  
  6101.     print "(DEV) move view to xmove $xmove ymove $ymove ytmove $ytmove\n" if $dev;
  6102.    
  6103.     $cns->xviewMoveto($xmove);
  6104.     $cns->yviewMoveto($ymove);    
  6105.     $lzd->xviewMoveto($xmove);
  6106.     $lzd->yviewMoveto($ytmove);
  6107.    
  6108.     print "(DEV)         yscales $yscale\n" if $dev;
  6109.  
  6110.     # Calculate new scale factors
  6111.     $yscale  *= $dy;
  6112.     $ytscale *= $dy;
  6113.     $xscale  *= $dx;
  6114.     print "(DEV) Updated yscales $yscale\n" if $dev;
  6115.  
  6116.     $yscale  = $box->[3]/($totaldepth);
  6117.     $ytscale = $box->[3]/($CONFIG{tmax} - $CONFIG{tmin});     # Scalefacto
  6118.     $xscale  = $box->[2]/$profilelength;
  6119.     print "(DEV) Updated yscales $yscale\n" if $dev;  
  6120.  
  6121.     $model->updateScale("yscale" => $yscale, "ytscale" => $ytscale, "xscale" => $xscale,
  6122.         "km1" => $km1, "km2" => $km2, "d1" => $z1, "d2" => $z2, "t1" => $t1, "t2" => $t2);
  6123.    
  6124.     push @$zoomhistory, \@zoomRectCoords;
  6125.     #print "Dump zoomhistory\n";
  6126.     #print Dumper $zoomhistory;
  6127. }
  6128.  
  6129. sub zoomOriginal {
  6130.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  6131.  
  6132.     $xscale = $canvaswidth/$box->[2];
  6133.     $yscale = $canvasheigth/$box->[3];
  6134.  
  6135.     $cns->scale('all' => 0, 0, $xscale, $yscale);
  6136.     $lzd->scale('all' => 0, 0, $xscale, $yscale);
  6137.     $box = [0, 0, $canvaswidth, $canvasheigth];
  6138.     $cns->configure(-scrollregion => $box);
  6139.     $lzd->configure(-scrollregion => $box);    
  6140.    
  6141.     # Update scalefactors (or reset to original)
  6142.     $yscale  = $box->[3]/($totaldepth);
  6143.     $ytscale = $box->[3]/($CONFIG{tmax} - $CONFIG{tmin});    
  6144.     $xscale  = $box->[2]/$profilelength;
  6145.     #print "Updated yscales in ZoomOriginal: $yscale\n";
  6146.    
  6147.     # Remove additional axes
  6148.     #for (my $i=0; $i <= $#drawnAxes; $i++){
  6149.         #$lzd->delete($drawnAxes[$i]);
  6150.         #undef $drawnAxes[$i];
  6151.     #}
  6152.     #print "In axes array: @drawnAxes\n";
  6153.     #$model->updateScale("yscale" => $yscale, "ytscale" => $ytscale, "xscale" => $xscale);
  6154.     $model->updateScale("yscale" => $yscale, "ytscale" => $ytscale, "xscale" => $xscale,
  6155.         "km1" => $CONFIG{xmin}, "km2" => $CONFIG{xmax}, "d1" => $CONFIG{zmin}, "d2" => $CONFIG{zmax},
  6156.         "t1" => $CONFIG{tmin}, "t2" => $CONFIG{tmax});
  6157. }
  6158.  
  6159. sub zoomIn {
  6160.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  6161.  
  6162.     print "Zooming in\n";
  6163.    
  6164.  
  6165. }
  6166.  
  6167. sub zoomOut {
  6168.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  6169.  
  6170.    print "Dump zoomhistory\n";
  6171.     print Dumper $zoomhistory;
  6172.  
  6173.     my @zoomHist = @{shift @$zoomhistory};
  6174.     print "Zoom out to @zoomHist\n";
  6175.     #return;
  6176.     #COPIED PART FROM ZOOMCANVASFINISH:
  6177.     # Was the rectangle big enough?
  6178.     return if abs($zoomHist[0] - $zoomHist[2]) < 10 ||
  6179.               abs($zoomHist[1] - $zoomHist[3]) < 10;
  6180.  
  6181.    
  6182.     # Let's find the zooming factor.
  6183.     my $dx = $cns->width  /abs($zoomHist[0] - $zoomHist[2]);
  6184.     my $dy = $cns->height /abs($zoomHist[1] - $zoomHist[3]);
  6185.    
  6186.    
  6187.     my $pyl = abs($zoomHist[1] - $zoomHist[3]);
  6188.     my $pxl = abs($zoomHist[0] - $zoomHist[2]);
  6189.     #print "------------------\nZooomrec: @zoomRectCoords\n";
  6190.     #print "Neue laenge: y? $pyl x? $pxl dx $dx  box  @$box  cns ".$cns->width." \n";
  6191.     #print "Using xscales: $xscale\n";
  6192.     #print "km start: \n";
  6193.    
  6194.     # Make newx smaller value of both
  6195.     my $newy  = $zoomHist[1] < $zoomHist[3] ? $zoomHist[1] : $zoomHist[3];
  6196.     my $newx  = $zoomHist[0] < $zoomHist[2] ? $zoomHist[0] : $zoomHist[2];
  6197.     my $newy2 = $zoomHist[1] > $zoomHist[3] ? $zoomHist[1] : $zoomHist[3];
  6198.     my $newx2 = $zoomHist[0] > $zoomHist[2] ? $zoomHist[0] : $zoomHist[2];    
  6199.  
  6200.     my $kmx = $newx/$xscale;
  6201.     my $kmx2 = $newx2/$xscale;
  6202.     my $d1m = $newy /$yscale+$CONFIG{zmin};
  6203.     my $d2m = $newy2/$yscale+$CONFIG{zmin};
  6204.     my $t1 = $newy  /$ytscale;
  6205.     my $t2 = $newy2 /$ytscale;
  6206.    
  6207.     #print "Von $kmx bis $kmx2 laenge,\n".
  6208.         #"tiefe  +mx: $d1m bis $d2m \n".
  6209.         #"TIME: $t1, $t2\n";
  6210.    
  6211.      # Scale with different scale factors
  6212.      $cns->scale('all' => 0, 0, $dx, $dy);
  6213.      $lzd->scale('all' => 0, 0, $dx, $dy);
  6214.  
  6215.     # Change bounding box
  6216.     $box->[2]*=$dx;
  6217.     $box->[3]*=$dy;
  6218.      #print "Spezial $_ for @{$box}\n";
  6219.    
  6220.     # Resize the scrollregion.
  6221.     $cns->configure(-scrollregion => $box);
  6222.     $lzd->configure(-scrollregion => $box);
  6223.      
  6224.     # Now we change the view to center on correct area.
  6225.     my $xmove = $zoomHist[0] < $zoomHist[2] ? $zoomHist[0] : $zoomHist[2];
  6226.     my $ymove = $zoomHist[1] < $zoomHist[3] ? $zoomHist[1] : $zoomHist[3];
  6227.  
  6228.      $xmove *= $dx / $box->[2];
  6229.     $ymove *= $dy / $box->[3];
  6230.    
  6231.     $cns->xviewMoveto($xmove);
  6232.     $cns->yviewMoveto($ymove);
  6233.     $lzd->xviewMoveto($xmove);
  6234.     $lzd->yviewMoveto($ymove);
  6235.    
  6236.     $yscale  = $box->[3]/($totaldepth);    
  6237.     $ytscale = $box->[3]/($CONFIG{tmax} - $CONFIG{tmin});     # Scalefacto
  6238.     $xscale  = $box->[2]/$profilelength;
  6239.     #print "Updated yscales in zoomFinish: $yscale\n";
  6240.    
  6241.     $model->updateScale("yscale" => $yscale, "ytscale" => $ytscale, "xscale" => $xscale,
  6242.         "km1" => $kmx, "km2" => $kmx2, "d1" => $d1m, "d2" => $d2m, "t1" => $t1, "t2" => $t2);
  6243.  
  6244.    
  6245. }
  6246.  
  6247. sub _printStatusMessage {
  6248.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  6249.     my $msg = shift;
  6250.     $stline->insert ('end', "$msg");
  6251.     $stline->see('end');
  6252. }
  6253.  
  6254. sub _setWindowTitle {
  6255.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  6256.    
  6257.     my $title = "$PROG: Model: $DIR - version: $VERSION";
  6258.     $title .= " $COMMENTS{$VERSION}" if ($COMMENTS{$VERSION});
  6259.     $mw->title($title)  if ($mw );
  6260.  
  6261. }
  6262.  
  6263.  
  6264. sub _historyAdd {
  6265.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  6266.     # Copys v.in with $VERSION-number into history-folder for undo-button
  6267.     # and increases $VERSION-number
  6268.    
  6269.     print "Add <$VERSION> version\n";
  6270.     _setWindowTitle();
  6271.    
  6272.     # Check for folder existence
  6273.     unless (-d "history") {
  6274.         # create subdirectory for history if it's not already there.
  6275.         print "Creating directory for history-files\n";
  6276.         mkdir 'history' or die $!;
  6277.     }
  6278.    
  6279.     # Copy v.in with $VERSION as versionnumber/historyindex into "history"-folder
  6280.     copy ("v.in", "history/v.$VERSION");
  6281.     $VERSION++;
  6282.  
  6283. =PROGhead2 _historyAdd()
  6284.  
  6285.  - Update title $VERSION
  6286.  - copy v.in v.$VERSION
  6287.  - $VERSION++
  6288.  
  6289. =cut
  6290.  
  6291. =USERhead3 Version control
  6292.  
  6293. PRay keeps track of model versions you've written with PRay (using button "C<Write v.in>").
  6294. C<v.in>-Files are stored in the subdirectory C<history>, which can be deleted if you want to restart
  6295. from version 0.
  6296.  
  6297. To navigate through your versions use arrow buttons diplayed in the toolbar or go to a special
  6298. model version using 'C<< File->Go to version .. >>'
  6299.  
  6300. Versions above current (which is shown in windowtitle) can be deleted when exiting with
  6301. PRay's File-Menu->Quit (user is asked). During start up the last
  6302. version is compared with current C<v.in> in your working directory and differences are reported.
  6303.  
  6304. You can mark special version with the 'Mark'-button and navigate between them with the fastforward
  6305.  and fastbackward buttons. This list is stored in file F<p.status> so PRay can read it back at next startup.
  6306. To remove marked models either edit this file when PRay is not running or via File-menu->Edit marked models.
  6307.  
  6308. =cut
  6309.  
  6310. }
  6311.  
  6312. sub _GetVersionNumber {
  6313.  
  6314. =PROGhead3 C<_GetVersionNumber>
  6315.  
  6316. Returns last version in history directory
  6317.  
  6318. =cut
  6319.  
  6320.     printf "(T) %s(@_)\n", commons::whoami() if $tree;
  6321.  
  6322.     opendir(DIR, "$DIR/history") or return 0; # $DIR is global and your `cwd`
  6323.     my @dots = grep { /^v\.\d+/ && -f "$DIR/history/$_"} readdir(DIR); # find all v.X-files
  6324.     closedir(DIR);
  6325.  
  6326.     my $i = 0;
  6327.     # Find highest backup-number
  6328.     foreach my $file (@dots) {
  6329.         my @a = split(/\./ , $file);
  6330.         if ($a[1] > $i) { $i = $a[1];}
  6331.         #print "F $file, $a[1]\n";      
  6332.     }
  6333.     print "Last version found in history is $i\n";
  6334.     print "Current version is $VERSION\n";
  6335.    
  6336.     # Check if v.in and v.$VERSION are different:
  6337.     if (compare("v.in","history/v.$i") == 0) {
  6338.         print "v.in is equal to history/v.$i\n";
  6339.     } else {
  6340.         print "####################################################\n".
  6341.               "#  WARNING !!                                      \n".
  6342.               "# Your v.in is not the same like your last version \n".
  6343.               "# in history/v.$i                                  \n".
  6344.               "####################################################\n";
  6345.               i_Messages("\nYour v.in is not the same like your last version in history/v.$i");
  6346.               #$i = "-1";
  6347.              
  6348.         #print "v.in is not equal to your last file in history v.$i\n";
  6349.         #print "What shall I do?\n";
  6350.         #print "[1]: Copy v.$i to v.in and start with that version\n";
  6351.         #print "[2]: Start with this v.in and copy it to history v.$i+1\n";
  6352.         #print "[3]: Die\n";
  6353.         #print "Any other answer will just continue the programm\n";
  6354.        
  6355.         #my $answer = <>;    # Get answer
  6356.         #if ($answer == 1) {
  6357.             #print "[1]: Get last version file and overwrite v.in\n";
  6358.             #copy ("history/v.$i", "v.in");
  6359.        
  6360.         #} elsif ($answer == 2 ) {
  6361.             #$i++;
  6362.             #copy ("v.in", "history/v.$i");
  6363.             #print "[2]: Copied v.in to v$i\n";
  6364.        
  6365.         #} elsif ($answer == 3 ) {
  6366.             #print "Leaving you now. I haven't touched anything\n";
  6367.             #die;
  6368.        
  6369.         #} else {
  6370.             #print "I'm doing nothing. Just continue with v.in and don't copy anything anywhere\n";
  6371.         #}
  6372.        
  6373.  
  6374.     }
  6375.  
  6376.     return $i;
  6377. }
  6378.  
  6379. my $logfile = "history/edits.log";
  6380.  
  6381. =USERhead3 Overlay xz lines in model space
  6382.  
  6383. Users can define xz files in C<<p.config>> ( C<< xz = xzfilename [color] >>, which are read and overlayn in
  6384. model space. File format is plain text with x and z columns. Several file can be configured by repeating the whole
  6385. option.
  6386. Lines can be switched in C<View>-menu. Same procedure for xt.
  6387.  
  6388. =USERhead3 Links to gravity modelling
  6389.  
  6390. PRay can annote velocity nodes with correspondig density values. Conversion table is taken from
  6391. I<Barton(1986) "The relationship between seismic velocity and density in the continental crust - a useful constraint?">
  6392.  
  6393. It has also a limited function in C<< Menu->File >> to create a starting model in IGMAS structure format. !! This function is still under development
  6394. and some stuff is hardwired for the authors model !! If you want to use it, contact the author, please.
  6395.  
  6396. =USERhead2 What else to say?
  6397.  
  6398. =head3 HOW TO ..
  6399.  
  6400. a. .. add stations to your model
  6401.  
  6402. Include them in you statxz-file. See L</statxz>
  6403.  
  6404.  
  6405. =head3 Error Messages
  6406.  
  6407.  
  6408. No r2.out? Check your rayinvr-Settings in r.in
  6409.  
  6410. Unfortunately, the programm is a bit picky about the numbers of digits used as position for xshot and obs positions in statxz. If
  6411. they don't have three digits behind the comma, it can't recognize that it's the same (sorry about that). This problem solves itself
  6412. once you have read and saved r.in via the file-menu. It read's in your complete r.in and writes it in the format it likes the numbers.
  6413.  
  6414. You'll probably have your own kind of formatting for r.in. This will be lost. But if everything goes right, you have a nice GUI for editing
  6415. and don't need to count lines any more.
  6416. None of your setting will be lost though. The type of variables is not changed. None are added or disgarted.
  6417.  
  6418. If you need more switches in the GUI let me know. I didn't want to stuff the window with things I don't need.
  6419.  
  6420. =head4 r.in - Errors
  6421.  
  6422. Following error
  6423.  
  6424.     tfromm@gsysm194:20110100/rayinvr/b> rayinvr
  6425.     > namelist read: read unexpected character
  6426.     > apparent state: unit 10 named r.in
  6427.     > last format: list io
  6428.     > lately reading direct formatted external IO
  6429.     > Abort
  6430.  
  6431. occours then arrays like (ray, ivray,..) are too long. The allowed size seems to vary with your OS and type of programm. xrayinvr can handle
  6432. more elements on a Mac than rayinvr. It doesn't make a difference on Solaris.
  6433.  
  6434. =head4 No or not all phases in tx.out?
  6435.  
  6436. check your setting for itxout in r.in. It has to be either 2 or 3. 3 should interpolate
  6437. to receiver position and can cause failure to write out
  6438. a phase to tx.out. Try itxout=2 in that case.
  6439. Also check the rayinvr manual
  6440.  
  6441. =cut
  6442.  
  6443. =head2 Changes
  6444.  
  6445. 25.01.13
  6446. - new config option r2out for format of first column of r2.out file
  6447. - new config option ttbg for color of traveltime background
  6448. - allowing PRay to start, even without the existence of r2.out
  6449. - returning status message, if no r2.out can be opened
  6450. - taking out config option for profilelength
  6451.   They were overridden by r.in anyway.
  6452.  
  6453. 26.01.13
  6454. - config options maxheight and maxdepth are replaced with zmin and zmax
  6455.   if those are defined, they overwrite values from r.in
  6456.  
  6457. 31.01.13
  6458. - PRay writes v.in directly
  6459.  
  6460. 11.02.13
  6461. - Model versions can be marked for faster navigation
  6462.  
  6463. 15.02.13
  6464. - Linien und Achsen ueber das Komplette Model beim Zoomen zeichnen
  6465.  
  6466. 17.02.13
  6467. - Pinch layers
  6468.  
  6469. 20.02.13
  6470. - Pinched nodes can be moved together
  6471.  
  6472. 22.02.13
  6473. - New config value in p.config for files to open:
  6474.     files = c.in v.in p.config ..
  6475. - tx-files may have no phasenumber in the lines starting stations
  6476.  
  6477. 06.03.13
  6478. - Marked models are saved in p.status and list is read at startup
  6479. - version is saved in p.status so PRay knows which version is used if
  6480.   it's not equal to last version in history-directory
  6481.  - Contour plot is also written to file contours.ps
  6482.  - Fixed bug: contours were not updated when writing v.in
  6483.  - If no version in marked models is found, taking first or last model in
  6484.    array. -> Circular list
  6485.  
  6486.  07.03.13
  6487.  - Marking a model writes contourplot and r1.out into history folder
  6488.  
  6489.  08.03.13
  6490.  - New button for copying current model to last version found in
  6491.    history-dir plus 1.
  6492.  
  6493.  14.03.13
  6494.  - Added splash screen for startup. Enable with splash = 1 in p.config
  6495.  
  6496.  15.03.13
  6497.  - 'Edit phases' is indepentend from station now. One window can be kept
  6498.    for changing phases of different stations.
  6499.  - Enable 'Edit phases' only if zpdir and zp2ray are configured in p.config
  6500.  
  6501.  26.03.13
  6502.  - Add function for extracting 1D velocity profiles to File-Menu->Extract ..
  6503.  
  6504.  31.03.13
  6505.  - User can add self defined commands and script to 'Commands'-Menu
  6506.    via p.config: command your Label is bla = /path/to/your/script/script.sh
  6507.  
  6508.  21.06.13
  6509.  - No p.config necesseray
  6510.  
  6511.  12.07.13
  6512.  - Remember status of station and phase button when quitting
  6513.    
  6514.  17.07.13
  6515.  - drawing of arrivals is configurable (eg: txin = dash, line)
  6516.  - Add comments to model versions (Written to file comments.txt which may
  6517.    be edited by the user when PRay is not running. Keep format!!)
  6518.    View comments via Menu->View->Show comments
  6519.  - Edit several depth nodes at once
  6520.  - Switch all stations and phases in rin-editor
  6521.  
  6522.  18.07.13
  6523.  - Edit comments when clicking them in overview
  6524.  
  6525.  25.07.13
  6526.  - View-Show Results can display rayinvrs tracing results
  6527.  - Dash width for picks reduced
  6528.  
  6529.  26.07.13
  6530.  - BugFix: Reduction time wasn't applied, when starting PRay
  6531. - Manual picks can be drawn as crosses
  6532.  
  6533. 31.07.13
  6534. - Resolution from d.out can be read and exported in v.in-format
  6535. - Added switch for overwriting exported rays
  6536.  
  6537. 01.08.13
  6538. - Resolution file is automatically written after running dmplsqr
  6539. - Quitting PRay can be canceled now
  6540.  
  6541. 02.08.13
  6542. - PRay writes comments when running dmpl
  6543. - Add export of velocity nodes to resolution
  6544.  
  6545. 07.08.13
  6546. - PRay exports reflection points
  6547. - Resulution values are checked (between 0 and 1?)
  6548.  
  6549. 13.08.13
  6550. - Added comment button
  6551.  
  6552. 01.09.13
  6553. - Added File->Reload tx.in
  6554.  
  6555. 02.09.13
  6556. - Model can start at negative km
  6557.  
  6558. 12.09.13
  6559. - Added export function for xzv file with velocity information
  6560.  
  6561. 15.09.13
  6562. - Change snap function. Now new nodes are added to the other layer at
  6563.   the position of start and end node
  6564.  
  6565. 21.09.13
  6566. - Velocity nodes can get a label
  6567.  
  6568. 06.10.13
  6569. - Measure rms velocity of reflections
  6570.  
  6571. 11.10.13
  6572. - Overlay xz file in model diagram
  6573.  
  6574. 21.10.13
  6575. - Change default export directory to data. Creates dir if necessary
  6576.  
  6577. 24.10.13
  6578. - Overlay xt file in traveltime diagram
  6579.  
  6580. 08.11.13
  6581. - Export model in IGMAS structure format (still under development!)
  6582. - Annotate velocity nodes with densities
  6583.  
  6584. 09.05.14
  6585. - Add option for html-help of p_readme in help menu
  6586.  
  6587. 16.06.14
  6588. - Switch picks for left and right shots
  6589.  
  6590. 17.05.14
  6591. - Better error messages for overflown r2.out
  6592. - xz/xt can handle comments with #
  6593.  
  6594. 18.06.14
  6595. - Config r2out not necessary any more
  6596. - Bugfix: Don't add two velocity nodes at the same position
  6597.  - Bugfix: Deal with vnodes at only one boundary
  6598.  
  6599.  24.06.14
  6600.  - Bugfix: deal with negative xmin and tmin
  6601.  
  6602.  28.06.14
  6603.  - Bugfix: Write v.in with vnodes on only one boundary
  6604.  - Remove r2out from p.config
  6605.  - Bugfix: Axes ticks corrected for negative xvalues
  6606.  - Buxfix: Take xmax from r.in to read v.in
  6607.  
  6608.  07.07.14
  6609.  - Graphically edit p.config
  6610.  
  6611.  08.07.14
  6612.  - Bug fix: Changed shebang
  6613.  
  6614.  09.07.14
  6615.  - Added phase-search to Menu Phases
  6616.  - Bugfix: comments in title
  6617.  
  6618.  10.07.14
  6619.  - Added 'stationsperline' to p.config
  6620.  
  6621.  11.07.14
  6622.  - Density and resolution models are also exported into export-directory (p.config)
  6623.  - Fixed bug in exporting densities (!! big bug )
  6624.  
  6625.  22.07.14
  6626.  - Bugfix: Deleting old 1D velocity profiles
  6627.  - Bugfix: Name vd-files with km013.. for correct sorting
  6628.  - Report statistics about velocity nodes in a special km range
  6629.  - Installation of Statistics::Basics module necessary
  6630.  
  6631.  23.07.14
  6632.  - Extract velocities become non-blocking
  6633.  
  6634.  24.07.14
  6635.  - Bugfix: 1D-vd export can handle zeros in velocities
  6636.  - Add rayinvr shotnumber in popup help for stations
  6637.  
  6638.  25.07.14
  6639.  - Add button for going to last model
  6640.  
  6641.  27.07.14
  6642.  - Added a bit buggy button for grey contourlines. +Fixed contourline labe
  6643.  
  6644.  28.07.14
  6645.  - Bugfix: Edit phases with three digits
  6646.  
  6647.  09.08.14
  6648.  - Clean up station drawing routines. Delete calculated picks, when changing
  6649.    the model, but keeping data, when rayinvr is run on the same model with
  6650.    less stations
  6651.  
  6652.  29.09.14
  6653.  - Added r.in check function if no p.status is present
  6654.  - Fixed resolution write bug
  6655.  
  6656.  30.09.14
  6657.  - Added complete resolution plotting routine
  6658.  
  6659.  22.12.14
  6660.  - Working on compatibility with rayinvr examples
  6661.   (removed zshot, add start nodes to model xmin)
  6662.  - TODO: ishot = -1
  6663.  
  6664.  04.01.15
  6665.  - Fixed ishot = -1 issue. Automatically replace it with 2. No single
  6666.    left and right selection possible
  6667.  - stationname in statxz file remains the same as in file (before, some
  6668.    digits and letters were suppressed, e.g. 100st137 -> 137)
  6669.  - statxz is not needed or created automatically andy more
  6670.  
  6671.  05.01.15
  6672.  - Added variable for PRay version and displays messages if action is
  6673.    required after an update
  6674.  - Added red color for nodes with fixed gradient/thickness
  6675.  
  6676.  06.01.15
  6677.  - BugFix: Exported tt data gets not reduces if button is not enabled
  6678.  
  6679.  09.01.15
  6680.  - Several bugfixes related to resolution
  6681.  - Added menu item for editing model
  6682.  - Changed behaviour of rayinvr and dmplstsqr button (do not do so much
  6683.    automatically)
  6684.  - Added commands for (un)setting all partial derivatives for v nodes
  6685.  
  6686.  15.01.15
  6687.  - Exporting absolute and relative position, no matter what is configured
  6688.  
  6689.  16.01.15
  6690.  - Add configuration for resolution script
  6691.  
  6692.  03.02.15
  6693.  - Sort picks before drawing line (prevents some strange look for traced
  6694.    arrivals
  6695.  - Add config for changing pick size
  6696.  
  6697.  21.02.15
  6698.  - Moved first and last vnodes more into the screen
  6699.  
  6700.  23.02.15
  6701.  - Added user config for reversed time axis
  6702.  
  6703.  04.03.15
  6704.  - Several bugs fixed
  6705.  
  6706.  16.03.15
  6707.  - Added export-function for layer polygons (gmt readable xz-format)
  6708.  
  6709.  25.03.15
  6710.  - BugFix: Picks had not been exported if no ray was traced. Export all
  6711.    picks now.
  6712.  
  6713.  26.03.15
  6714.  - Shortened text buttons
  6715.  
  6716.  13.04.15
  6717.  - Removed spaces from unit names for igmas models
  6718.  - (not updated) added coordinates for p150
  6719.  
  6720.  14.04.15
  6721.  - Fixed Bug in Exporting igmas model
  6722.  - Reduced number of nodes for igmas model
  6723.  
  6724.  16.04.15
  6725.  - Added config value for the text size of node annotations
  6726.  - Updated documentation
  6727.  
  6728.  22.04.15
  6729.  - Change velocity density conversion from Barton to Ludwig
  6730.  
  6731.  02.09.15
  6732.  - Added basic functions for floating reflectors
  6733.  
  6734.  27.05.16
  6735.  - Added routine to create a model if no rayinvr files are present
  6736.  
  6737. =cut
  6738.  
  6739. CHANGES:
  6740.  
  6741. =head2 Known bugs
  6742.  
  6743. There are some known bugs I am aware of, but had no time to fix them. If you
  6744. find bugs not listed here, please notify me.
  6745.  
  6746. =over
  6747.  
  6748. =item *
  6749.  
  6750. RMS measure on the left side of a station has problems for large offsets
  6751.  
  6752. =item *
  6753.  
  6754. Environment variables entered in the graphical p.config editor are not
  6755. accepted.
  6756.  
  6757. =for comment
  6758. Don't run rayinvr after changin model version
  6759.  
  6760. =back
  6761.  
  6762. =cut
  6763.  
  6764. =head2 Requested features (TODO-List)
  6765.  
  6766.  
  6767. =over
  6768.  
  6769. =item *
  6770.  
  6771. Add user config for number of digits of measured apparent velocity and
  6772. node annotions
  6773.  
  6774. =item *
  6775.  
  6776. Add user config for annotated text size
  6777.  
  6778. =back
  6779.  
  6780.  
  6781. =cut
  6782.  
  6783.  
  6784. # TODO
  6785. # Document, how to get phasebuttons in the programm and also change the way it works!! Make it take the
  6786. # rays >ray< array of r.in
  6787. #
  6788. # NAMING of layers?
Advertisement
Add Comment
Please, Sign In to add comment
Public Pastes
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!