.gitignore

-# ??git
-*.patch
 *~
+*.patch
+*.swp
+*.bak
+*.tmp
 *.o
 *_lex.cpp
 *_yacc.cpp
 *_yacc.h
-src/Makefile
-src/src.pro
 *.Plo
 *.Po
+*.lo
+*.la
+*.lai
+*.a
+*.so
+*.so.*
+*.pyc
+*.aux
+*.bbl
+*.blg
+*.idx
+*.ilg
+*.ind
+*.log
+*.nlo
+*.out
+*.toc
+a.out
+html/
 frida2-*/
-pub/src/frida2
-pub/config.h
-pub/config.h.in
-pub/stamp*
-Makefile
-Makefile.in
-*/Makefile
-*/Makefile.in
-aclocal.m4
-autom4te.cache/*
-autom4te.cache
-build-aux/*
-build-aux
-config.log
-config.status
-configure
-demo/.deps
-demo/.libs
+frida
+external_ci
+gcc
+clang
+build
+mybuild
+qbuild
+podstyle.css
+pub/src/xax_yacc.hpp
 demo/lm_test
-lib/.deps
-lib/liblmmin.la
-lib/lm_eval.lo
-lib/lmmin.lo
-libtool
+pub/py-binding/output
+pub/py-binding/cache.xml
+*.pypp.*
+pub/PyAPI/PythonModule.cpp
+doxygen_sqlite3.db
+CMakeLists.txt.user*

.gitlab-ci.yml

+stages:
+  - build
+
+mac_x64:
+  tags:
+  - mac_x64_cloud
+  stage: build
+  before_script:
+  # Homebrew packages are installed in a non-standard path
+  - BREWDIR="/opt/homebrew-x86/"
+  - PATH="$BREWDIR:$BREWDIR/opt/flex/bin:$BREWDIR/opt/bison/bin:$PATH"
+  - PYPLAT="/Users/qtisas/.pyenv/versions/3.11.6/"
+  - cmake --version
+  script:
+  - OPTDIR=/Users/Shared/Software/scg
+  - mkdir pub/build
+  - cd pub/build
+  - cmake -DCMAKE_PREFIX_PATH="$BREWDIR;$OPTDIR;$PYPLAT" -DCMAKE_BUILD_TYPE=Release -S ..
+  - make -j4
+  - ctest --output-on-failure --timeout 120
+  artifacts:
+    paths:
+    - build/*zip
+    expire_in: 10 days
+
+# windows:
+#   tags:
+#   - Windows
+#   stage: build
+#   script:
+#     - New-Item -ItemType "directory" -Confirm:$false -Force:$true -Name "build"
+#     - cd build
+#     - cmd.exe "C:\Program Files (x86)\Microsoft Visual Studio\2019\Community\VC\Auxiliary\Build\vcvars64.bat"
+#     - cmake -G "Visual Studio 16 2019" -A x64 -T host=x64 -DLIB_MAN=OFF -DLIB_INSTALL=OFF -B. ..
+#     - cmake --build . --config Release
+#     - Get-Location
+#     - dir
+#     - dir Release
+#     - ctest -C Release --output-on-failure
+
+native_Debian_clang:
+  tags: &native
+  - Debian
+  before_script: &debian_clang
+  - export CC=clang; export CXX=clang++
+  - cmake --version
+  - clang --version
+  stage: build
+  script: &native_scr
+  - pwd && ls
+  - mkdir pub/build
+  - cd pub/build
+  - cmake ..
+  - make -j6
+  - ctest -j6 --output-on-failure
+
+# ## Dockerized:
+#
+# debS_clang:
+#   tags: &unix
+#   - Linux
+#   image: debian:stable
+#   before_script: &debian_clang
+#     - apt-get -y update
+#     - apt-get -y upgrade
+#     - apt-get -y install cmake perl pkgconf bison flex gnuplot-x11 git
+#     - apt-get -y install libreadline-dev libgsl-dev libfftw3-dev
+#     - apt-get -y install libboost-filesystem-dev libboost-dev libyaml-dev
+#     - apt-get -y install clang
+#     - git clone https://jugit.fz-juelich.de/mlz/kww.git
+#     - git clone https://jugit.fz-juelich.de/mlz/lmfit.git
+#     - git clone https://jugit.fz-juelich.de/mlz/libcerf.git
+#   stage: build
+#   script: &scr
+#     - pwd && ls
+#     - cd kww && mkdir build && cd build
+#     - cmake -DWERROR=ON .. && make -j3 && ctest && make install && cd ../..
+#     - cd lmfit && mkdir build && cd build
+#     - cmake -DWERROR=ON .. && make -j3 && ctest && make install && cd ../..
+#     - cd libcerf && mkdir build && cd build
+#     - cmake -DWERROR=ON .. && make -j3 && ctest && make install && cd ../..
+#     - cd pub
+#     - mkdir build
+#     - cd build
+#     - cmake -DWERROR=ON ..
+#     - make -j8
+#     - ctest --output-on-failure
+#
+# debS_gcc:
+#   tags: *unix
+#   image: debian:stable
+#   before_script: &debian_gcc
+#     - apt-get -y update
+#     - apt-get -y upgrade
+#     - apt-get -y install cmake perl pkgconf bison flex gnuplot-x11 git
+#     - apt-get -y install libreadline-dev libgsl-dev libfftw3-dev
+#     - apt-get -y install libboost-filesystem-dev libboost-dev libyaml-dev
+#     - apt-get -y install g++
+#     - git clone https://jugit.fz-juelich.de/mlz/kww.git
+#     - git clone https://jugit.fz-juelich.de/mlz/lmfit.git
+#     - git clone https://jugit.fz-juelich.de/mlz/libcerf.git
+#   stage: build
+#   script: *scr
+#
+# debT_clang:
+#   tags: *unix
+#   image: debian:testing
+#   before_script: *debian_clang
+#   stage: build
+#   script: *scr
+#
+# debT_gcc:
+#   tags: *unix
+#   image: debian:testing
+#   before_script: *debian_gcc
+#   stage: build
+#   script: *scr
+#
+# debU_clang:
+#   tags: *unix
+#   image: debian:unstable
+#   before_script: *debian_clang
+#   stage: build
+#   script: *scr
+#
+# debU_gcc:
+#   tags: *unix
+#   image: debian:unstable
+#   before_script: *debian_gcc
+#   stage: build
+#   script: *scr
+#
+# suse_clang:
+#   tags: *unix
+#   image: opensuse/tumbleweed
+#   # rolling release with infinite life time
+#   before_script:
+#     - zypper -n patch || echo "do it again"
+#     - zypper -n patch
+#     - zypper -n ref
+#     - zypper -n up
+#     - zypper -n dup
+#     - zypper -n in cmake perl pkgconf bison flex gnuplot git
+#     - zypper -n in readline-devel gsl-devel fftw3-devel libyaml-devel
+#     - zypper -n in boost-devel libboost_filesystem-devel
+#     - zypper -n in clang gcc glibc-devel libstdc++-devel
+#     - export CC=/usr/bin/clang
+#     - export CXX=/usr/bin/clang++
+#     - git clone https://jugit.fz-juelich.de/mlz/kww.git
+#     - git clone https://jugit.fz-juelich.de/mlz/lmfit.git
+#     - git clone https://jugit.fz-juelich.de/mlz/libcerf.git
+#   stage: build
+#   script: *scr
+#
+# suse_gcc:
+#   tags: *unix
+#   image: opensuse/tumbleweed
+#   # rolling release with infinite life time
+#   before_script:
+#     - zypper -n patch || echo "do it again"
+#     - zypper -n patch
+#     - zypper -n ref
+#     - zypper -n up
+#     - zypper -n dup
+#     - zypper -n in cmake perl pkgconf bison flex gnuplot git
+#     - zypper -n in readline-devel gsl-devel fftw3-devel libyaml-devel
+#     - zypper -n in boost-devel libboost_filesystem-devel
+#     - zypper -n in gcc-c++
+#     - git clone https://jugit.fz-juelich.de/mlz/kww.git
+#     - git clone https://jugit.fz-juelich.de/mlz/lmfit.git
+#     - git clone https://jugit.fz-juelich.de/mlz/libcerf.git
+#   stage: build
+#   script: *scr
+#
+# # suse_stable:
+# #  opensuse:leap, unsupported here because it is at cmake 3.5, while libcerf requires 3.6
+#
+# ## Centos7 permanently disabled because it does not fully support C++11
+# ##
+# ##centos7_clang:
+# ##  tags: *unix
+# ##  image: centos:centos7
+# ##  before_script:
+# ##    - yum -y update
+# ##    - yum -y install epel-release
+# ##    - yum repolist
+# ##    - yum -y install make cmake3 pkgconf perl bison flex gnuplot git
+# ##    - yum -y install readline-devel gsl-devel fftw3-devel libboost-filesystem boost-devel libyaml-devel
+# ##    - yum -y install clang gcc glibc-devel libstdc++-devel
+# ##    - export CC=/usr/bin/clang
+# ##    - export CXX=/usr/bin/clang++
+# ##    - git clone https://jugit.fz-juelich.de/mlz/kww.git
+# ##    - git clone https://jugit.fz-juelich.de/mlz/lmfit.git
+# ##    - git clone https://jugit.fz-juelich.de/mlz/libcerf.git
+# ##    - cmake3 --version
+# ##    - ctest3 --version
+# ##    - cpack3 --version
+# ##    - ln -s /usr/bin/cmake3 /usr/bin/cmake
+# ##    - ln -s /usr/bin/ctest3 /usr/bin/ctest
+# ##    - ln -s /usr/bin/cpack3 /usr/bin/cpack
+# ##  stage: build
+# ##  script: *scr
+# ##
+# ##centos7_gcc:
+# ##  tags: *unix
+# ##  image: centos:centos7
+# ##  before_script:
+# ##    - yum -y update
+# ##    - yum -y install epel-release
+# ##    - yum repolist
+# ##    - yum -y install make cmake3 pkgconf perl bison flex gnuplot git
+# ##    - yum -y install readline-devel gsl-devel fftw3-devel libboost-filesystem boost-devel libyaml-devel
+# ##    - yum -y install gcc-c++
+# ##    - git clone https://jugit.fz-juelich.de/mlz/kww.git
+# ##    - git clone https://jugit.fz-juelich.de/mlz/lmfit.git
+# ##    - git clone https://jugit.fz-juelich.de/mlz/libcerf.git
+# ##    - cmake3 --version
+# ##    - ctest3 --version
+# ##    - cpack3 --version
+# ##    - ln -s /usr/bin/cmake3 /usr/bin/cmake
+# ##    - ln -s /usr/bin/ctest3 /usr/bin/ctest
+# ##    - ln -s /usr/bin/cpack3 /usr/bin/cpack
+# ##  stage: build
+# ##  script: *scr

CHECKS

+run regularly under: valgrind --leak-check=full frida
\ No newline at end of file

CREATE_TGZ

-# export A=frida2-
-rm -f -r $A
-cp -r pub $A
-cd $A; make maintainer-clean; cd ..
-upgit # to synchronize
-tar czv -h -f /io/$A.tgz $A/*

README.md

+Frida
+=====
+
+**Frida** (\"Fast reliable interactive data analysis\") is a versatile
+data analysis program with special routines for inelastic neutron
+scattering. It is actively maintained by [Joachim
+Wuttke](http://www.fz-juelich.de/SharedDocs/Personen/JCNS/EN/Wuttke_J.html).
+
+News
+----
+
+12may20: Bug fix release 2.4.3b.
+
+See the
+[changelog](https://jugit.fz-juelich.de/mlz/frida/-/blob/master/pub/CHANGELOG)
+for details.
+
+Documentation
+-------------
+
+-   [Introduction](wiki/introduction.md)
+-   [Installation](wiki/installation.md)
+    -   [frida.ini](wiki/frida.ini.md) (the configure file)
+-   [Tutorial](wiki/tutorial/start.md)
+    -   [Session 1](wiki/tutorial/basic_usage.md): Command-line basics, load
+        file, inspect, plot
+    -   [Session 2](wiki/tutorial/simple_manipulations.md): Select, Bin,
+        reorganize data.
+    -   [Session 3](wiki/tutorial/elementary_fitting.md): Fit.
+    -   [Session 4](wiki/tutorial/fitting_with_convolution.md): Convolute
+        theory with experimental resolution.
+-   Online manual
+    -   [Data model](wiki/data_model.md)
+    -   [Commands](wiki/commands.md)
+    -   [Overwrite or Duplicate](wiki/Overwrite or Duplicate.md)
+    -   [Expressions](wiki/expressions.md)
+    -   [Built-in functions](wiki/built-in_functions.md)
+    -   [Curves](wiki/curves.md)
+    -   [External curves](wiki/external_curves.md)
+-   Implementation notes (for developers)
+    -   [Design principles](wiki/principles.md)
+    -   [technologies and libraries used](wiki/technologies.md)
+    -   [coding conventions](wiki/coding_conventions.md)
+-   Old Versions
+    -   [historic data formats](wiki/historic_data_formats.md)
+    -   [frida1](wiki/frida1/start.md)
+-   Offline manual:
+    -   ![UserManual.pdf](doc/UserManual.pdf) (work in progress, mostly about graphics)
+
+Resources
+---------
+
+Download location:
+
+-   <https://jugit.fz-juelich.de/mlz/frida/-/tags>: latest release, file
+    frida\<version\>.tgz
+
+Or clone from
+
+-   <https://jugit.fz-juelich.de/mlz/frida/-/tree/master>: \"Clone\"
+    button on the upper right of the main window
+
+Contact
+-------
+
+### Bug reports
+
+Please send bug reports to Joachim. The git development snapshot
+contains a bug list (\~/TODO).
+
+### School on Data Analysis
+
+The first JCNS School on Data Analysis for Quasielastic Neutron
+Scattering with Frida took place on 28-29 April 2010. The next school
+will be organized as soon as a sufficient number of potential
+participants have indicated their interest.

TODO

+==== BUGS ====
+
+or+ should ask for name(unit) AND value
+
+"uninitialized variable" should also mention "unknown command"
+
+==== IMPROVE EXTANT FUNCTIONALITY ====
+
+fit does not yet use improved lmmin API (done?)
+
+'ep0', ...
+
+merge registries; prevent creation of variable with name already used by function
+
+coord name algebra
+
+handling of inf, nan
+
+dp: output for #spec>1 is obfuscated
+
+fs: for curve-calling-external-program (cc ecr or similar)
+
+mfj: remove redundant doc lines
+
+oi: wenn mehrere Files mit rank=2, automatisch in einen File packen
+
+"update plot" to replot after change of axes
+
+fn key binding: fn3-4 to scan k
+
+ft: ignore "#.."
+
+multi-oixy ?
+
+fit functions that depend on y_i (consistent? needed? how?)
+
+==== REQUESTED FUNCTIONALITY ====
+
+one-sided Fourier transform (Zach)
+
+
+==== DOCUMENTATION ====
+
+Terminology: "file" -> "workspace"
+  (surprisingly, this concerns almost only the documentation; in the code, only a few
+   output commands contain "file" in the sense of "workspace". To find them, use
+     grep -n [Ff]ile  `fs` | grep -v "\\file" | grep -v FileIter | grep -v [a-zA-Z]File
+  )
+
+Universal help/doc associated with
+  - environment variables like psdir
+  - operators and functions (now hf; separate operators and functions, reconsider sorting)
+
+refer to external documentation
+
+explain resol, conv, pconv
+
+more info on commands (in command shell and in manual?)
+
+
+==== REFACTORING ====
+
+Register all commands;
+transform within-command dialogs into command options
+
+(this replaces the following "dialog generics":)
+  - restore ask callback help for lists (prompt for list, not for string)
+  - restore help on "?" (e.g. expression help for 'md')
+  - default for plot range
+
+refactor func+op registration so that registered object can be const
+(assemble typed function list prior to registration)
+
+lmfit call-back within class, thanks to std::functional
+
+When commands have become programmable:
+- review history
+  - latest action on pX should be part of history
+  - history replay must not stop for error
+  - show commands while playing history
+  - fnc keys not in history
+
+Default file selection:
+- inform user about new file selection as result of an operation
+- inform user about renumbering after deletion?
+- keep curve references intact
+
+history:
+  -  for replaying:
+    - RETURN not stored
+  - during interactive session:
+    - store repeated commands only once
+- save every input at once (from history to logging ...)
+
+
+==== WISHLIST ====
+
+splines (e.g. to approximate measured resolution)
+
+convolution with function
+- with spline
+- with TOFTOF model
+
+
+==== WAITING FOR CLUE ====
+
+How to treat blanks in user input:
+- operators "mod", "div" suggest to allow blanks in expressions
+- "op* 1 .3 99" suggeststo split at blanks
+
+should operations have a return value?
+- code for user interrupt
+- numeric result?
+- pointer to files (replace sel_collect_begin/end mechanism)??
+
+Ctrl+C to abort fit
+
+residual plot
+
+Graphics: simplify; allow LaTeX labels -> Asymptote ? gnuplot ?
+
+distribution: do not overwrite user modifications of ini file
+
+in graph file: doc lines should be formatted such that they can be easily
+  read in as command lines
+
+script language integration
+- testing
+- support for Excel-like tables
+- towards LAMP

arch/frida-1.4/Ida.hlp

+*this$file
+  Ida.hlp
+      last change 3mar94
+      contains on-line help for IDA
+*Ida
+  IDA () main command line.
+
+      Short commands :
+          p   = plot
+          a   = add to plot
+          qui = quit IDA
+      Command groups : 
+          f*  = files (input, output, ..)
+	  d*  = directory (and modification of file headers)
+	  e*  = edit parameters
+          m*  = manipulations (delete, sum, interpolate, ..)
+          o*  = operations (arithmetics)
+          t*  = transforms (Fourier, ..)
+          _*  = incorporated programs
+	  r*  = raw data input
+          c*  = curves and fits
+          g*  = graphics
+          i*  = info
+      For lists of command groups, enter the first letter.
+    For help on specific commands, try '? ' followed by the command.
+       
+      The prompt IDA normally is followed by a list of default-files.
+    Most commands operate on these files. To operate on other files, 
+    enter a new filelist, followed by a command or not.
+*f
+  IDA> command group f* 
+          (files: input, output, creation,
+                  reorganisation in on-line-memory)
+     fl  = load from disk
+     fm  = make
+     fc  = copy
+     fdel= delete
+     fx  = exchange (fc and fdel)
+     fw  = write to disk
+*fl 
+  IDA () fl <filename> : load file(s)
+
+      Load data files into on-line memory.
+    Usage : with argument :    load one file
+            without argument : loop (reply nothing [RETURN] to exit)
+      If File names are given without extension, the program looks first
+    for ".dat", then for ".asc". 
+      File formats : ILL-CrossX, IDA-binary, or IDA-ASCII
+
+      Source : FileWrite in i2.f, colling LoadSpectrum in i1.f       
+*fw
+  IDA (file-nos) fw : write file(s)
+
+      Save internal files on external device.
+    Any files hold in IDA's on-line memory can be saved, including curves.
+    As external filename, any valid path name is accepted. If filenames
+    are given without extension, files will be saved as ".dat", except
+    if ASCII-format is chosen in which case the extension will be ".asc".
+      Recommended storage format is IDA-binary; use IDA-ASCII if data shall
+    be send to sites with different operating system.
+
+      Source : FileLoad in i2.f, calling SaveSpectrum in i1.f       
+*fdel
+  IDA (file-nos) fdel : delete files
+
+      Files are deleted from on-line memory.
+    There is no way to recover deleted files. Use "fw" to save results.
+
+      Source : FileKill in i3.f, calling FileDel in i2.f
+*fc
+  IDA (file-nos) fc : copy files
+
+      Duplicate files in on-line memory.
+
+      Source : FileCopy in i3.f
+*fx
+  IDA (file-nos) fx : exchange order of files
+
+      Files are copied to the end of the on-line memory, 
+    then deleted from their original positions. 
+
+      Source : FileCopy and FileKill in i3.f
+*fm
+  IDA () fm : make a new file
+
+      Create a new on-line file. 
+    This option is used to enter data manually, or to convert foreign formats.
+    It includes the older conversion program any2ied.
+      For converting foreign data formats, first go through the interactive 
+    questions section. Then, the program asks to enter spectra in a format
+    you have determined before. At this point, use "\ie <filename>" to read 
+    the data points from an external file.
+
+      Source : FileMake in i3.f
+*d
+  IDA> command group d* 
+          (directory of on-line memory, 
+           inspection and modification of file headers)
+     df  = list of files
+     dz  = list of spectra
+     dd  = list of data entries
+     di  = inspect integer parameters
+     dr  = inspect (and modify) real parameters
+     dt  = inspect (and modify) text parameters
+     dg  = inspect (and modify) graphic parameters
+*df
+  IDA () df : directory of on-line files
+
+      Source : FileInfo in i2.f
+*dz
+  IDA (file-nos) dz : directory of spectra
+
+      For given files, list all spectra with their z-values
+    and their x-data ranges.
+
+      Source : FileInfo in i2.f
+*dd
+  IDA (file-nos) dd : directory of data entries
+
+      For given files, ask for spectra and channels to list,
+
+      Source : FileInfo in i2.f
+*di
+  IDA (file-nos) di : inspect integer parameters
+
+      Source : FileInfo in i2.f
+*dr
+  IDA (file-nos) dr : inspect (and modify) real parameters
+
+      Source : FileRPar in i3.f
+*dt
+  IDA (file-nos) dt : inspect (and modify) text parameters
+
+      Source : FileTPar in i3.f
+*dg
+  IDA (file-nos) dg : inspect (and modify) graphics parameters
+
+      Source : FileGPar in i3.f
+*mca
+  IDA (file-nos) mca : add channels
+
+      For each spectrum of given input files, channels are grouped 
+    together : x and y will be replaced by their average values.
+      Groups are to be specified in ordered list format, e.g. if there 
+    are 12 channels, "*i3" (which is shorthand for "1,4,7,10") means that 
+    there will be four groups containing channels 1-3,4-6,7-9, and 10-12.
+      If some spectra of one file are defined on different subranges of a
+    common grid, the new groups can be set with respect to the common grid.
+    If spectra have different length and there is no common grid, groups 
+    must be specified individually for each spectrum.
+
+      Source : OrgChSum in i4.f
+*mcd
+  IDA (file-nos) mcd : delete channels
+
+      For each spectrum of given input files, some channels can be deleted.
+    The channels that shall NOT be deleted are to be specified, either by 
+    their numbers in ordered list format, or by their x- or y-values.
+    Channel specification from files is decouraged.
+      If channels are specified by numbers, all spectra of one file are
+    compared in order to decide whether there is a common x-grid; in this
+    case, numbers can be specified with respect to the common grid.
+    If spectra have different length and there is no common grid, channel
+    numbers must be given individually for each spectrum.
+
+      Source : OrgChCut in i4.f
+*mco
+  IDA (file-nos) mco : sort channels
+
+      Sort each spectrum of given input files in ascending order in x.
+    If there is more than one occurence of some x-value, the corresponding
+    channels are grouped together, taking the average y-value.
+
+      Source : OrgChSort in i4.f
+*msa
+  IDA (file-nos) msa : add spectra
+
+      For each input file, replace spectra by groups of spectra.
+    For each group, channel by channel, input y are replaced by their
+    average values. 
+      Groups are to be specified by the number of the first old spectrum
+    of each new group, in ordered list format.
+      If spectra have different x-grids but the same number of channels,
+    it is possible to proceed by channel numbers. New x-values are then 
+    set by averaging over input files. It recommended, however, to first
+    regroup the data onto a common grid (using "mgr") before using "msa".
+
+      Source : OrgSpectraSum in i4.f
+*msd
+  IDA (file-nos) msd : delete spectra
+
+      For each input file, delete some spectra. 
+    The spectra to be deleted are to be specified in ordered list format.
+    Answer "-" (empty list) to escape.
+
+      Source : OrgSpectraCut in i4.f
+*mso 
+  IDA (file-nos) mso : sort spectra
+      
+      For each input file, sort spectra by their z-value. The contents
+    of the spectra themselves is not changed.
+
+      Source : OrgSpectraSort in i4.f
+*msj
+  IDA (file-nos) msj : join spectra
+
+      For each input file, group some spectra together. Output spectra
+    are build by simply appending input spectra one after each other.
+    Optionally, channels can be sorted (same as calling "mco").
+    Groups are to be specified the same way as in "msa".
+    
+      Source : OrgSpectraJoin in i4.f
+*msx
+  IDA (file-nos) msx : exchange spectra <-> channels
+
+      For each input file, exchange x- and z-coordinate.
+    Evidently, all spectra must be defined on a common x-grid.
+
+      Source : OrgSpectraExch in i4.f
+*mfs
+  IDA (file-nos) mfs : sum spectra of different files
+
+      It supposed that the input files have commensurable z-scales.
+    Then, all spectra sharing the same z are averaged to form one
+    output spectrum (whether two z's are considered equal is controlled
+    by a "tolerance" parameter). 
+      The averaging can only be done, if the x-grids are identical.
+
+      Source : OrgFileJoin in i4.f
+*mfj
+  IDA (file-nos) mfj : append files into one file
+
+      Simply, make one file out of several input files.
+    Say, there are 2 files with 3 spectra each : (ABC) and (abc).
+    Then, the output file will contain either (ABCabc) (option "file
+    after file"), or (AaBbCc) (option "spectrum after spectrum").
+      The spectra themselves remain unchanged (except if "msj" is 
+    called at the end).
+
+      Source : OrgFileJoin in i4.f
+*mfx
+  IDA (file-nos) mfx : exchange files <-> spectra
+
+      Suppose, spectra y(x) have been measured for different values
+    of two parameters U and V. Originally, spectra with the same U
+    may have been grouped into files with a real-parameter r(n)=U,
+    and V has a z-coordinate. The operation "mfx" regroups them into
+    files with the same real-parameter r(n')=V and a z-coordinate U. 
+
+      Source : OrgFileJoin in i4.f
+*mgi
+  IDA (file-nos) mgi : new x-grid, interpolate y
+
+      Choose a new x-grid, then determine y(x) on this grid by
+    interpolation of input data.
+      Options for choosing a grid are :
+    > from a file f2
+    > > (1:1)        for each output spectrum one spectrum of f2
+                     with same z is searched for
+    > > (select one) one spectrum of f2 defines the grid for all output
+    > regular grid
+    > > (lin)        X(i) = X(1) + [X(n)-X(1)]*[(i-1)/(n-1)]
+    > > (log)        X(i) = X(1) * [X(n)/X(1)]^[(i-1)/(n-1)]
+    > > (1/2-log)    starts logarithmically at X(1)=-X(n), becomes linear
+                     around 0 (from -crossover to +crossover), then
+                     returns to logarithmic increase until X(n).
+
+      Source : OrgGrid in i4.f
+*mge
+  IDA (file-nos) mge : new x-grid, extrapolate y
+
+      Choose a new x-grid, then determine y(x) on this grid by
+    interpolation and extrapolation. 
+      Options for extrapolations include
+         > by 0
+         > by any other given value
+         > by value of nearest neighbours
+      Options for choosing a new grid are the same as for mgi (see there).
+
+      Source : OrgGrid in i4.f
+*mgr
+  IDA (file-nos) mgr : new x-grid, redistribute y
+
+      Choose a new x-grid, then determine y(x) on this grid by
+    redistributing histogram intensities of input data.
+      Options for choosing a new grid are the same as for mgi (see there).
+
+      Source : OrgGrid in i4.f
+*mgd
+  IDA (file-nos) mgd : new x-grid, reduce input
+
+      Choose a new x-grid. If there are several x on input which
+    fall into the same interval of the new grid, only one x-y pair 
+    per interval is retained, the other input data are thrown away.
+      This option is needed for producing final output, when experimental 
+    data had to be temporarily interpolated onto a finer grid.
+      Options for choosing a new grid are the same as for mgi (see there).
+
+      Source : OrgGrid in i4.f
+*ox 
+  IDA (file-nos) ox <function <2nd argument>> : operate on x
+
+      Replace x by a function of x and possibly a second argument.
+    Examples : "6-8 ox / ef" devides x by a constant which will be asked
+                             for individually for each of the input files 6-8;
+               "7 ox $ x'"   replaces x by x' of another file (the number
+                             of which will be asked for)
+
+      Source : OprPoint in i5.f
+*oy
+  IDA (file-nos) oz <function <2nd argument>> : operate on y
+
+      Replace y by a function of y and possibly a second argument.
+    Examples : "6 oy * i"    multiplies y by an argument y'(z) which
+                             will be read from another file 
+               "1-2 oy $/ d" replace y by dy/y, where dy will be taken
+                             from the same input files 1-2 as y
+
+      Source : OprPoint in i5.f
+*oz
+  IDA (file-nos) oz <function <2nd argument>> : operate on z
+
+      Replace z by a function of z and possibly a second argument.
+
+      Source : OprPoint in i5.f
+*oi
+  IDA (file-nos) oi : calculate an integral property
+
+      For a spectrum y(x), a property i[y(x)] is calculated.
+    Examples: maximum value of y,
+              x at maximum of y,
+              integral I dx y(x).
+    If there is only one input spectrum, the output is a single number.
+    If the input file contains several spectra, the output is saved
+    as a file containing the spectrum i(z).
+
+      Source : OprIntegral in i5.f
+*ot
+  IDA (file-nos) ot : clone y(x) into a tensor product y(x,z)
+
+      Suppose you have one spectrum y(x), and you want to manipulate
+    this spectrum for different values of a parameter p.
+    A convenient way to achieve this is to expand y(x) into a file y(x,z),
+    consisting of a set of identical spectra y(x) with z=p.
+      You can either read z from another file or specify a regular grid.
+
+      Source : OprTensor in i5.f
+*p 
+  IDA (file-nos) p <spectra-nos> : plot
+
+      Plot the input files.
+    When called for the first time, this command opens a graphic window;
+    on later calls, previous plots are cleared.
+      Use "a" to add more spectra into existing plot.
+      See "g*" commands for more graphic options.
+
+      Source : IdaPlot in i0.f, calling the graphic library g*.f
+*a 
+  IDA (file-nos) a <spectra-nos> : add
+
+      Add more spectra to existing plot.
+      See 'g*' commands for more graphic options.
+
+      Source : IdaPlot in i0.f, calling the graphic library g*.f
+*gp
+  IDA () gp <ps-filename> : graphic to postscript
+
+      Write the graphic actually shown in the Tektronix window
+    in a PostScript file. Works even after the Tektronix window
+    has been closed.
+      The default filename is l<n>.ps, where <n> is the lowest
+    integer for which no such file already exists.
+      The PostScript file may subsequently be modified using
+    a text editor. Search for the string "Switchboard" for the
+    most relevant commands. 
+
+      Source : GraSoftCopy in g2.f
+*g:
+  IDA () g: : list graphic setup
+
+      List setup of the chosen graphic window.
+      Use "gw" to change the window.
+
+      Source : GraChoice in g2.f
+*gw
+  IDA () gw <window-no> : select graphic window
+
+      A graphic window is here the ensemble of all parameters defining
+    a graphic setup, like coordinate bounds, symbol size, and toggles
+    between linear/logarithmic scales and so on. It is useful to switch
+    between graphic windows when functions of incommensurable coordinates
+    with completely different x- and y-bounds are to be plotted.
+      Different graphic windows do NOT correspond to different windows
+    on the X-terminal.
+
+      Source : GraChoice in g2.f
+*cc
+  IDA (file-nos) cc : create curve
+
+      Create a curve for fitting the input files. 
+    Curves are saved internally like data files; they can be written
+    to external files with "fw", they can be plotted with "p" and "a",
+    but most other operations are meaningless with curves.
+
+      Source : CuCreate in i6.f
+*i
+  IDA> command group i* (info on the state of the program)
+     ia  = array dimensions'
+*eoi
+

arch/frida-1.4/README

+--------------------------------------------------------------------------
+--------------------------------------------------------------------------
+FRIDA (fast reliable inelastic data analysis)
+<http://frida.sourceforge.net> is a program for generic spectral 
+analysis, with many specialized routines for inelastic neutron 
+scattering. The FORTRAN version Frida-1 is an updated version of 
+Joachim Wuttke's IDA, with contributions from the community. The 
+maintainer is Florian Kargl <f_kargl@users.sourceforge.net>. 
+FRIDA is released under the GNU public license.
+(C) Joachim Wuttke 1990-2001
+(C) Florian Kargl 2006
+--------------------------------------------------------------------------
+--------------------------------------------------------------------------
+
+==========================================================================
+Frida-1-4
+==========================================================================
+Version July 2007
+
+* several bug fixes
+
+  - 1619502 msa problem solved (i41.f bug)
+
+  - i60.f and i66.f severe bug for KWW fit.
+  times tau as shown by fitting routine were a factor e/hbar to large
+  -> now temporarily fixed by multiplication factor
+  -> final fix has to be new KWW tables.
+
+  - i72.f option for activated for _coq: grid chosen by hand
+     
+* Standard dimensions of program changed in i_dim.f
+  (variable Mmem=14000000) this corresponds to a program
+  size of approximately 128 MB after compilation which
+  is especially comfortable for the read in of TOFTOF data.
+  For other applications a tenth of this size might still be enough.
+  
+* some new fit routines in i66.f
+
+==========================================================================
+Frida-1-2
+==========================================================================
+Version November 2006
+
+* Bug fixes for files 
+* NeXus read in routine for PSI instrument FOCUS implemented and
+  running --> Nexus installation see comments below
+* TOFTOF frameoverlap option significantly speeded up
+  according to tracker comment of T. Unruh
+
+* output options for postscript files changed to make it
+  more user friendly.
+  gp --> gs: short version, old style only postscript with
+             graph definitions without wups**a.ps header.
+  gp (new) : append g2.ps to graph. This file is a 'cat' version
+             of wups**a.ps and g3.ps
+  ga       : postscript file without any definitions
+
+* read in routine for IRIS instrument implemented, for documentation
+  of current steps see wiki documentation
+* date and time function for ps printing works now properly
+* ida.su file containing some definitions now contained in the release
+
+==========================================================================
+Frida-1-1
+==========================================================================
+
+Version in May 2006
+
+* Bug fixes were performed in i66.f 
+* A new file was implemented i81.f allowing for the moment
+  to read in MSD Files generated by OpenGenie based on IRIS
+  data.
+  In the near future this file will contain the read in
+  routines for data of the IRIS instrument.
+
+
+==========================================================================
+Frida-1-0
+==========================================================================
+This is the first release of the program in April 2006.
+
+----------------------
+1. General Information
+----------------------
+
+The program consists of a number of modules containing subroutines
+providing the general program structure and allowing for different
+kinds of data treatment.
+
+The source code can be found on <http://sourgeforge.net/projects/frida>
+
+General information regarding the different modules can be found 
+in "i00.f". Subsequent information is found in the modules themselves.
+
+A more detailed information can be found on <http://frida.sourceforge.net>. 
+
+Details on the project status will be posted via the mailing list of the 
+project on <http://sourceforge.net/projects/frida>.
+  
+The README file contains information on persons (2.) involved in
+the project and providing different versions of the program 
+maintained in different locations. These versions have been merged 
+in this first release. 
+Details regarding the installation procedure on a Linux platform 
+are found under (3.). 
+Known problems arising during the installation are listed in
+(4.). Here, a list of not yet fully implemented read in routines
+is posted. 
+(5.) contains information regarding the printout of figures and
+their modification. 
+
+----------------------
+2. Acknowledgments
+----------------------
+
+Tobias Unruh (TOFTOF @ FRM-II) provided us with a refined version 
+of the Ida program existing at the FOCUS spectrometer at PSI.
+The original Focus Read In was written by Andreas Meyer (E13, TUM),
+and required a NeXus to Ascii converter program. To read in
+the HDF/NEXUS data directly a subroutine was written by 
+Fanni Juranyi (FOCUS @ PSI) that has been modified by T. Unruh.
+A commented version of this read in routine is provided in this
+program for details see (4.).
+
+M. M. Koza maintained a version of IDA at ILL. For the release
+of Frida-1 the latest update of this version become not 
+available to us. The backscattering read in routines adapted
+to new ILL standards will be included in the next release.
+
+There are a number of people working on the code over the past 
+13 years. Their contribution is acknowledged within the source 
+code. Details will be attached to a forthcoming version of this
+README.
+
+
+----------------------
+3. Installation
+----------------------
+
+!! Linux Absoft Compiler !!
+
+  *** pre installation instructions ***
+
+      * unzip and untar the source code 
+
+        tar -zxvf frida-1-2.tgz
+
+        will unpack the data in a new directory
+	FRIDA1. Subdirectory for/num/ contains
+        numerical tables for fitting.
+
+      * create subdirectory 'oba'
+     
+      * create subdirectory 'exa'
+
+      * Note: if MSCAT shall be executable
+        modify Makefile by including 'i94.f'
+        in compilation procedure. Change i00.f
+	removing the comment signs at '_mss'.
+      
+      * If the full mode coupling model shall
+        be used remove comment signs at '_fmm'
+        in i00.f.
+
+      * If problems arise with the ida.su file
+	change path definitions in i00.f to
+	your path.
+
+      * In the current release the NEXUS Read in 
+        (RRT_In_Foc in i80.f) is included. To make
+        the code working the latest Version of NEXUS 
+        and HDF have to be installed on the system. 
+        The napif.inc, the napif.f, the napi.f and the 
+        napi.h of the NEXUS distribution shall be copied 
+        in the source tree of the Frida-1 program. The 
+        Makefile has to be modified accordingly. See 
+        library calls in the Makefile attached to this 
+        release (LIBNAG definition and following lines). 
+        Check for missing libraries on your system.
+
+	!!! If you don't want to use the NEXUS file read in
+        comment the corresponding lines in i80.f and i00.f
+	similar to the previos release!!!
+
+      * For the IRIS read in that is contained in i81.f
+	the libget routines provided by the Computing
+	group at ISIS are necessary. The Fortran code
+	can be downloaded from there website. 
+
+      * if the NeXus read and the libget routine to
+        read in ISIS data is used simultaneously
+	then the libget routines must be modified
+        prior to compilation:
+        In io.f the TRUELINE function must be commented.
+
+      * The makefile of the libget routines has to
+        be modified in any case to make it compatible
+        with the conventions used by absoft compilation.
+	All subroutines have to be in lowercase letters
+        and with a underscore at the end.
+	f77 has to be invoked with -c -f -B108 flag.
+
+
+  *** requirements ***
+        
+      * libnag.a (NAG FORTRAN 77 library)
+   
+      * libg2c.a
+  
+      * libm.a
+
+      * for Nexus read in the following additional libraries
+        are required:
+   
+	* libNeXus.a
+ 
+ 	* libhdf5.a
+ 
+	* libhdf.a
+
+	* libdf.a
+
+ 	* libz.a
+
+	* libjpeg.a
+
+      * for IRIS data read in the libget libraries are 
+        necessary
+
+	* libget.a standard (if no Nexus read in is used)
+
+        * libget.a modified (if Nexus read in is used)
+
+
+  *** installation ***
+
+      * type 'make -f Makefile' or simply 'make'
+        in source directory
+
+      * the object files are created in the 'oba' subdirectory
+ 
+      * if the compilation is successful a 
+	executable 'frida1' is created in the 
+        'exa' subdirectory 
+ 
+
+  *** post installation instructions ***
+
+
+      * to invoke Frida-1 a x-terminal or any terminal providing 
+        Tektronix support is mandatory for full graphical capabilities. 
+	
+        Note: In a standard shell only the text base
+              part is working. No visualization is possible.
+
+      * it might be convenient to define the following 
+        alias in the '.bashrc':
+
+        alias i="xterm -title 'Frida-1 Linux Version 1.0' -sb -sl 5000 
+        -bg white -fg black -cr chartreuse -fn 13x8 -g 82x27+2+358 
+        -e /home/user/Frida1/exa/frida1 &"
+
+	modify path according to where frida1 is located on the
+        harddisk
+
+!! Linux GNU Compiler !!
+
+      * The posted version cannot be compiled with the standard 
+        GNU compiler shipped with standard Linux versions for PC.
+        A major problem is the string handling and some intrinsics.
+
+        The problem was partly solved by Christian Geisler.
+
+        However, the program (not this release) has still to be 
+        tested for some minor bugs.
+
+!! SGI workstation !!
+
+      * Compilation on a SGI workstation should in principle
+        be possible. Be aware off using the correct l0sgi.f
+        instead of l0x11.f in the Makefile.
+
+----------------------
+4. Known 'bugs'
+----------------------
+
+1. The program dumps if a wrong file number is entered
+   while reading in DCS (rdcs command) data. Please
+   be careful on using the correct numbers.
+
+2. The multiphonon correction procedure '_muc' based
+   on code of R. Reichardt is still in a cryptic 
+   state. The source code may provide you with some
+   ideas.
+
+----------------------
+5. Figure printing
+----------------------
+
+We gratefully acknowledge the work of H. P. Schildberg providing 
+together with Joachim Wuttke a PostScript header file with intriguing 
+user commands. 
+
+The latest modification of the header file 'wups05a.ps' and a 
+previous version wups97a.ps are attached to this release.
+The first file now allows also for correct printing of error
+bars in logarithmic y-axis environments. 
+
+g3.ps contains basic definitions of the linestyle and 
+general layout of a file printed from the Frida-1 program
+to the harddisk.
+
+A figure shown in the Textronix window can be printed
+by typing 'gp <file-name.ps>' at the command line.
+If <file-name.ps> is omitted a file 'l#.ps' with '#'
+being the smallest not yet existing number is created. 
+The ps-file contains the file g2.ps, axis definitions 
+and the data provided by Frida-1 plus the header file.
+
+If you want to use a short version without the header
+containing the ps-specific definitions then type
+'gs <file-name.ps> in the terminal. 
+To print or visualize the file the header 'wups05a.ps' 
+has to be attached by e. g. 'cat wups05a.ps file.ps > ~/P.ps'.
+The latter may be defined as alias 'gn' in your .bashrc.
+
+In the g2.ps and g3.ps file there are a number of switches 
+that allow to modify the ps-file. A figure containing a number of 
+different possibilities like Greek letters, annotations,
+lists for curve descriptions can be obtained upon request.
+
+======
+Update May 2006
+======
+
+i66.f function nr. 36 has been corrected
+was not implemented in previous release
+despite being available in the menu.
+
+======
\ No newline at end of file

arch/frida-1.4/g1.f

+C  ====================================================================
+C
+C     Library  WuG :  Graphics
+C     Module   G1  :  Commands to specific stations
+C
+C  ====================================================================
+
+C     J.Wuttke  -  Version Jun91
+
+C     Contents :
+C
+C        1.1.   Pericom 4014 :   Scrollmode etc.
+C                  OverlayOn/Off, GMode, Scrollarea, ClearGraphic/Screen
+C
+C        1.2.   Tektronix :      Direct graphic driver
+C                  TekBytes, ResetOldAdress, TekLinType/GoTo/DrawTo,
+C                  TekCharSize/Area/-
+C
+C        1.3.   Windows :        Routines for both Tek and PS
+C                  SetWindow, SetCoord, Coord, PS_Coord, Ticks
+C
+C        1.4.   TekGraphics :    Graphics via 1.2.
+C                  TekFrameClear, TekAxis, Ticks, TekPlotCS,
+C                  TekSetSymbol, TekPlotSymbol, TekPoint, TekCurve, TekText,
+C                  TekSetDevice
+C
+C        1.5.   PS_Graphics :    Graphics with postscript
+C                  PS_Numbers, PS_PlotCS,
+C                  PS_Point, PS_Curve, PS_Text,
+C                  OpenPS, ClosePS
+
+C     File Access :
+C        uses units 51 : out.tek
+C                   52 : out.ps
+C                   53 : in.ps
+C               ioUnit : terminal or 51 as set by TekSetDevice
+
+C     Major modifications :
+C        92/93  made work with Falco and X11 display
+C        Jun91  Postscript driver from HP.Schildberg
+C        Okt90  Library WuGra; complete revision
+C        Okt87  Version Deorie, module DeGra
+C        Aug87  Tektronix direct driver from HP.Schildberg
+
+
+C  ====================================================================
+C  g1.1.  Pericom 4014
+C  ====================================================================
+
+      SUBROUTINE OverlayOn
+C     --------------------
+         Print '(1x,5a1,$)',
+     *      Char(29),Char(27),Char(92),Char(53),Char(24) ! GS ESC B/SL 5 CAN
+         END
+
+      SUBROUTINE OverlayOff
+C     ---------------------
+         Print '(1x,5a1,$)',
+     *      Char(29),Char(27),Char(92),Char(51),Char(24) ! GS ESC B/SL 3 CAN
+         END
+
+      SUBROUTINE GMode (iWn)
+C     ----------------------
+      COMMON / GraPlus / iGraP, iEsc
+         DATA  iWo /0/ ! instead of 99=undef'd: 23jun94
+               ! renewed 22oct92
+            ! iWn = 1 : go to Graph window
+            ! iWn = 0 : go to Text window
+         IF (iWn.ne.iWo) THEN
+            IF     (iWn.eq.0) THEN ! goto Text
+               IF     (iEsc.ge.1) THEN
+                  Print '(2a1,$)', Char(27), Char(3) ! ESC ETX
+               ELSEIF (iGraP.ge.1) THEN
+                  Print '(2a1,$)', '+', Char(24)  ! CAN
+               ELSE
+                  Print '(a1,$)', Char(24)
+                  ENDIF
+            ELSEIF (iWn.eq.1) THEN
+               IF     (iEsc.ge.1) THEN
+                  Print '(2a,$)', Char(27),'[?38h'
+               ELSEIF (iGraP.ge.1) THEN
+                  Print '(2a1,$)', '+', Char(29)  ! GS
+               ELSE
+                  Print '(a1,$)', Char(2)
+                  ENDIF
+            ELSE
+               CALL Absturz ('GMode', 'iWn o.o.r.')
+               ENDIF
+            iWo = iWn
+            ENDIF
+
+         END ! GMode
+
+      SUBROUTINE ScrollArea (iAnf, iEnd)
+C     ----------------------------------
+
+      Print '(1x,a1,a)',         Char(27), '[2J'                    !erase Scree
+      Print '(1x,2a1,2(i2,a1))', Char(27), '[', iAnf, ';', iEnd, 'r'!scroll area
+      Print '(1x,2a1,i2,a)',     Char(27), '[', iAnf, ';1H'         !goto scroll
+
+      END ! ScrollArea
+
+      SUBROUTINE ClearGraphic
+C     -----------------------
+         !  clears the graphic and performs some usefull
+         ! reset operations on the terminal setup mode.
+      COMMON / GraPlus / iGraP, iEsc
+
+      IF (iEsc.ge.1) THEN ! xterm*tek 
+         print *, 'CLEAR CLEAR CLEEEEEEEAAAAAAAAr??'
+         Print '(2a)', Char(27), Char(12) ! ESC LF(10)
+      ELSE ! Pericom (HPS)
+         Print '(1x,33a1,3(a1,a1,a2),a1)',
+     *      Char(29),Char(27),Char(12), ! GS ESC NP
+     *     (Char(22),I=1,30),        ! SYN do nothing, let terminal recover
+     *      Char(27),Char(92),'E1',  ! select PERICOM 4014 GRAPHICS  ?
+     *      Char(27),Char(92),'s0',  ! select LARGE GIN CURSOR       ?
+     *      Char(27),Char(92),'t0',  ! select SOLID GIN CURSOR       ?
+     *      Char(24)                                      ! CAN
+         ENDIF
+
+      END ! ClearGraphic
+
+      SUBROUTINE ClearScreen
+C     ----------------------
+      Print '(1x,a1,a3)', Char(27),'[2J'    ! erase text
+      Print '(1x,a1,a5)', Char(27),'[1;1H'  ! goto line 1
+      END
+
+C  ====================================================================
+C  g1.2.  Tektronix
+C  ====================================================================
+C               The routines of this section are due to H.P.Schildberg
+
+C  --------------------------------------------------------------------
+C  g1.2.1.  Screen coordinates as optimized strings
+C  --------------------------------------------------------------------
+
+      SUBROUTINE TekBytes (IX,IY,OutChar,LEN)
+C     ---------------------------------------
+         ! Transforms the screen coordinates IX,IY into a string of 5 bytes,
+         ! (starting from element OutChar(9)). An outputstring optimized with
+         ! respect to length can be found starting from OutChar(1). LEN is the
+         ! length of this string. Lateron either String can be sent to the
+         ! Tektronics graphic area.
+         ! Input:  IX,IY
+         ! Output: OutChar, LEN
+
+      IMPLICIT LOGICAL (q)
+      CHARACTER*1 OutChar(*), OldChar(16)
+
+      COMMON / GraTerm / qWindow, qGTOverlay, qGToldAdr
+      COMMON / oldie   / OldChar
+
+C calculate the characters for the point adress.
+C order: highY, lsbYX, lowY, highX, lowX
+        OutChar( 9) = Char( mod(IY/128,32)+32 )
+        OutChar(10) = Char( mod(IY,4)*4+mod(IX,4)+96 )
+        OutChar(11) = Char( mod(IY/4,32)+96 )
+        OutChar(12) = Char( mod(IX/128,32)+32 )
+        OutChar(13) = Char( mod(IX/4,32)+64 )
+
+C  "abspecken" of output, doesn't work on all terminals :
+      IF (qGToldAdr) THEN
+        LEN=0
+        IF (OldChar(9) .ne. OutChar(9)) THEN
+           ! high Y needed
+           LEN=1
+           OldChar(9)=OutChar(9)
+           OutChar(1)=OutChar(9)
+           ENDIF
+        q10 = OldChar(10) .ne. OutChar(10)
+        q11 = OldChar(11) .ne. OutChar(11)
+        q12 = OldChar(12) .ne. OutChar(12)
+        IF (q10) THEN
+           ! LSBYX needed
+           LEN=LEN+1
+           OldChar(10)=OutChar(10)
+           OutChar(LEN)=OutChar(10)
+           ENDIF
+        IF (q10 .or. q11 .or. q12) THEN
+           ! LOW Y needed
+            LEN=LEN+1
+           OldChar(11)=OutChar(11)
+           OutChar(LEN)=OutChar(11)
+           ENDIF
+        IF (q12) THEN
+           ! HIGH X needed
+           LEN=LEN+1
+           OldChar(12)=OutChar(12)
+           OutChar(LEN)=OutChar(12)
+           ENDIF
+        ! take lowX in any case.
+        LEN=LEN+1
+        OldChar(13)=OutChar(13)
+        OutChar(LEN)=OutChar(13)
+C now the first LEN bytes in OutChar contain the optimized outputstring,
+C from OutChar(9)  to OutChar(13) one finds the full string.
+
+      ELSE
+         DO i = 1, 5
+            OutChar(i) = OutChar(8+i)
+            ENDDO
+         LEN = 5
+
+         ENDIF ! Abspecken or not
+
+      END ! TekBytes
+
+      SUBROUTINE ResetOldAdress
+C     ------------------------------
+         ! will load the register for the old point adress with hex. FF = 255,
+         ! namely a bit pattern, which never appears in the graphic output.
+      CHARACTER*1 OldChar(16)
+      COMMON / Oldie   / OldChar
+      DO i = 1,16
+         OldChar(i) = Char(255)
+         ENDDO
+      END ! ResetOldAdress
+
+C  --------------------------------------------------------------------
+C  g1.2.2.  Lines
+C  --------------------------------------------------------------------
+
+      SUBROUTINE TekLinPrint (LinTyp)
+C     ------------------------------
+         ! sets the linetype for the Tektronics graphic
+         !     1 : solid
+         !     2 : dotted
+         !     3 : dot-dash
+         !     4 : short dash
+         !     5 : long dash
+         !     6 : points
+
+      COMMON / GraPlus / iGraP, iEsc
+      COMMON / output  / ioUnit
+
+      iTyp = jmod(LinTyp-1,6) + 1 ! result is in 1..6 (23jun94)
+
+      IF (LinTyp.ne.6) THEN ! select linetype
+         IF (iGraP.ge.1) THEN
+            Write(ioUnit,'(4a1,$)') '+',Char(29),Char(27),Char(95+iTyp)
+         ELSE
+            Write(ioUnit,'(3a1,$)') Char(29),Char(27),Char(95+iTyp)
+            ENDIF
+      ELSE ! linetype is points
+         IF (iGraP.ge.1) THEN
+            Write(ioUnit,'(3a1,$)') '+',Char(29),Char(28)
+         ELSE
+            Write(ioUnit,'(2a1,$)') Char(29),Char(28)
+            ENDIF
+         ENDIF
+
+      END ! TekLinPrint
+
+      SUBROUTINE TekLinGoTo ( ix, iy)
+C     -------------------------------
+         ! Go to (ix, iy), and invoke the vector plot module
+
+      CHARACTER    OutChar(16)*1, OutFormat*8, cv2*2
+      COMMON / GraPlus / iGraP, iEsc
+      COMMON / output  / ioUnit
+
+      ixi = iinside (ix, 0, 4080)
+      iyi = iinside (iy, 0, 3060)
+      CALL TekBytes(ixi,iyi,OutChar,LEN)
+      IF (iGraP.ge.1) THEN
+         OutFormat = '('//cv2(2+LEN)//'a1,$)' 
+         Write(ioUnit,OutFormat) '+', Char(29), (OutChar(I),I=1,LEN)
+      ELSE
+         OutFormat = '('//cv2(1+LEN)//'a1,$)' 
+         Write(ioUnit,OutFormat) Char(29), (OutChar(I),I=1,LEN)
+         ENDIF
+
+      END ! TekLinGoTo
+
+      SUBROUTINE TekLinDrawTo ( ix, iy)
+C     ---------------------------------
+         ! Draw a line to (ix, iy).
+         ! The vector plot module has to be invoked by a preceeding
+         ! call of TekLinGoTo
+
+      CHARACTER    OutChar(16)*1, OutFormat*8, cv2*2
+      COMMON / GraPlus / iGraP, iEsc
+      COMMON / output  / ioUnit
+
+      ixi = iinside (ix, 0, 4080)
+      iyi = iinside (iy, 0, 3060)
+      CALL TekBytes(ixi,iyi,OutChar,LEN)
+      IF (iGraP.ge.1) THEN
+         OutFormat = '('//cv2(1+LEN)//'a1,$)'
+         Write(ioUnit,OutFormat) '+', (OutChar(I),I=1,LEN)
+      ELSE
+         OutFormat = '('//cv2(0+LEN)//'a1,$)'
+         Write(ioUnit,OutFormat) (OutChar(I),I=1,LEN)
+         ENDIF
+
+      END ! TekLinDrawTo
+
+      SUBROUTINE TekLin ( ixlo, iylo, ixhi, iyhi)
+C     -------------------------------------------
+         ! Draw a line  from (ixl, iyl) to (ixh, iyh).
+
+      CALL TekLinGoTo   (ixlo, iylo)
+      CALL TekLinDrawTo (ixhi, iyhi)
+
+      END ! TekLin
+
+      SUBROUTINE TekErase (ixl,iyl,ixh,iyh)
+C     -------------------------------------
+         ! performs a selective erase of the graphic area within the
+         ! rectangle defined by ixl,iyl,ixh,iyh.
+         ! This routine does only work properly, if the CEFTI-Pericom was first
+         ! put into Graphics 2 state and has been reset to PERICOM 4014 graphics
+         ! after the first graphic operation was performed by the program
+
+      Print '(3a1,$)', '+', Char(27), 'x'
+      Print '(3a1,$)', '+', Char(27), Char(2)
+      CALL TekLin (ixl, iyl, ixh, iyh)
+      Print '(3a1,$)', '+', Char(27), Char(1)
+      Print '(3a1,$)', '+', Char(27), '`'
+
+      END ! TekErase
+
+C  --------------------------------------------------------------------
+C  g1.2.3.  Character strings
+C  --------------------------------------------------------------------
+
+      SUBROUTINE TekCharSize (i)
+C     --------------------------
+         ! Select a character size in Tektronics graphic area.
+
+      CHARACTER cl6*6
+      COMMON / output  / ioUnit
+
+      IF (i.lt.1 .or. i.gt.4)
+     *    CALL Absturz ('TekCharSize', 'i[size] = '//cl6(i) )
+
+      Write(ioUnit,'(1x,4a1,$)') Char(29),Char(27),Char(55+i),Char(24)
+
+      END ! TekCharSize
+
+      BLOCK DATA TekCharArea
+C     ----------------------
+         ! JWu 5jun91, as block data 1apr93
+         ! TCAx(i)*TCAy(i) is the area of a character of size no. i
+         ! calculated from total area = 4080*3060 :
+            ! i=1:  74 Characters, 35 Lines
+            ! i=2:  81 Characters, 38 Lines
+            ! i=3: 121 Characters, 58 Lines
+            ! i=4: 133 Characters, 64 Lines
+
+      IMPLICIT REAL*8    (a-h,o-p,r-z)
+      COMMON / CharArea / TCAx(4), TCAy(4)
+      DATA     TCAx       / 55.14d0, 50.37d0, 33.72d0, 30.68d0 /,
+     *         TCAy       / 87.43d0, 80.53d0, 52.76d0, 47.81d0 /
+
+      END ! TekCharArea
+
+      SUBROUTINE TekChar (ix, iy, String)
+C     -----------------------------------
+         ! Write String starting from position (ix, iy)
+         ! The charactersize is assumed to be set by TekCharSize
+
+      CHARACTER    PosByt(16)*1, Form*20, String*(*), cv2*2
+      COMMON / output  / ioUnit
+
+      IF (ix.lt.0 .or. iy.lt.0) RETURN ! bad limits -> simply ignore the text
+
+      CALL TekBytes (ix, iy, PosByt, LPB) !create byte sequence for coordinates
+      Form = '(1x,'//cv2(LPB+2)//'a1,a)'
+      Write (ioUnit, Form) Char(29), (PosByt(i),i=1,LPB), Char(31), String
+
+      END ! TekChar
+
+C  ====================================================================
+C  g1.3.   Windows
+C  ====================================================================
+
+C  --------------------------------------------------------------------
+C  g1.3.1.  Window set up
+C  --------------------------------------------------------------------
+
+      SUBROUTINE SetWindow (iW)
+C     -------------------------
+         !  Set the viewport (ixl..ixh, iyl..iyh),
+         !  the size of ticks, numbers, and symbols,
+         !  and the size and position of text lines.
+
+         !  Units are pixels (3060*4080) for Tek. No longer called for PS.
+
+      IMPLICIT LOGICAL (q)
+
+      PARAMETER    (MW=9) ! # implemented formats
+      INTEGER      iFrame(4,MW), iSize(4,MW), iLabel(5,MW), iText(4,MW)
+
+      COMMON / Viewport/ iTOTx, iTOTy
+      COMMON / graph   / ixl, ixh, iyl, iyh,
+     *                   iTack, itick, jNumber, jSymbol
+      COMMON / InfPos /  infx(200), infy(200), infSiz(200)
+
+C  Frame co-ordinates : ixl,ixh,iyl,iyh
+      DATA  iFrame /   590, 2000, 1750, 3030, ! 1: TEK, half window on the left
+     *                2590, 4000, 1750, 3030, ! 2: TEK, half window on the right
+     *                 800, 2350,  720, 2920, ! 3: TEK, large, Hochformat
+     *                 800, 3000, 1000, 2550, ! 4: TEK, large, Querformat
+     *                 695, 4000,  940, 3060, ! 5: TEK, scroll, 20 lines
+     *                1300, 2700, 2200, 3060, ! 6: TEK, scroll, 8 lines
+     *                 500, 1000,  500, 1240, ! 7: PS, Hochformat OBSOLET
+     *                 500, 1240,  500, 1000, ! 8: PS, Querformat "
+     *                 695, 4080,  135, 3060/ ! 9: TEK, 25 lines (full screen)
+C  Lines : length of iTack, itick; size of numbers, symbols
+      DATA  iSize /  30, 12, 3, 120,   ! 1
+     *               30, 12, 3, 120,   ! 2
+     *               40,  0, 1, 300,   ! 3
+     *               40,  0, 1, 300,   ! 4
+     *               36, 20, 2, 160,   ! 5
+     *               36, 20, 2, 160,   ! 6
+     *               36, 20, 2,   0,   ! 7
+     *               36, 20, 2,   0,   ! 8
+     *               54, 18, 2, 175/   ! 9
+C  Label : position of x-,y- label; size
+      DATA  iLabel /  2000, 1610,  500, 3080, 3, ! 1
+     *                4000, 1610, 2500, 3080, 3, ! 2
+     *                2350,  600,  800, 2880, 1, ! 3
+     *                2000,  750,  800, 2620, 1, ! 4
+     *                2700, 2900, 2700, 2780, 2, ! 5  ! z.Zt. im Innern der Gr.
+     *                3000, 2880, 3000, 3000, 2, ! 6
+     *                 700,  900,  700,  780, 2, ! 7
+     *                 700,  900,  700,  780, 2, ! 8
+     *                4050, 2960, 4050, 2840, 2/ ! 9  ! z.Zt. im Innern der Gr.
+C  Text : x, y-offset, y-incr, size
+      DATA  iText /    540, 1540, 48,  4, ! 1
+     *                2540, 1540, 48,  4, ! 2
+     *                   0,    0,  0,  0, ! 3
+     *                   0,    0,  0,  0, ! 4
+     *                   0, 3080, 44,  3, ! 5
+     *                   0, 3080, 44,  3, ! 6
+     *                   0,    0,  0, 10, ! 7
+     *                   0,    0,  0, 10, ! 8
+     *                   0, 3070, 44,  3/ ! 9
+
+C  Check :
+      IF (qiOutside(iW,1,MW)) THEN
+          Print *, 'iW = ', iW
+          CALL Absturz ('SetWindow', 'iW o.o.r.')
+         ENDIF
+
+C  Set the common block / Viewport / :
+      IF (iW.le.6) THEN
+         ! TEK
+         iTOTx = 4080
+         tTOTy = 3060
+      ELSE
+         ! PS-DIN A4
+         iTOTx = 2950
+         iTOTy = 2200
+         ENDIF
+
+C  Set the common block /graph/ :
+      ixl    = iFrame (1, iW)
+      ixh    = iFrame (2, iW)
+      iyl    = iFrame (3, iW)
+      iyh    = iFrame (4, iW)
+
+      iTack  = iSize (1, iW)
+      itick  = iSize (2, iW)
+      jNumber= iSize (3, iW)
+      jSymbol= iSize (4, iW)
+
+C  Set the common block /infpos/ :
+
+      infx   (2) = iLabel (1, iW)
+      infy   (2) = iLabel (2, iW)
+      infSiz (2) = iLabel (5, iW)
+
+      infx   (3) = iLabel (3, iW)
+      infy   (3) = iLabel (4, iW)
+      infSiz (3) = iLabel (5, iW)
+
+      DO i = 11, 100
+         infx   (i) = iText (1, iW)
+         infy   (i) = iText (2, iW) - (i-11) * iText (3, iW)
+         infSiz (i) = iText (4, iW)
+         ENDDO
+
+      END ! SetWindow
+
+C  --------------------------------------------------------------------
+C  g1.3.2.  Coordinate system : points
+C  --------------------------------------------------------------------
+
+      SUBROUTINE SetCoord (mode)
+C     --------------------------
+            ! TekCoord JWu 20mar91, Coord/SetCoord 26jan94
+         ! set / gcoord / for use in Coord (..)
+
+      IMPLICIT REAL*8    (a-h,o-p,r-z)
+      CHARACTER          mode*(*)
+      
+      REAL*8             RD(2)
+      
+      COMMON / glimit  / GMM(3,2), LLG(3), nDim, GANG(3), GAREL(3)
+      COMMON / graph   / ixl, ixh, iyl, iyh, iTack, itick, jNumber, jSymbol
+      COMMON / gcoord  / R0(2), RC(3,2)
+
+C  Seize of plot RD and position of origin R0 in relative units :
+      RD(1) = 0
+      RD(2) = 0
+      R0(1) = 0
+      R0(2) = 0
+      DO j = 1, nDim
+         RD(1) = RD(1) + GAREL(j)*dabs(dcosd(GANG(j)))
+         RD(2) = RD(2) + GAREL(j)*dabs(dsind(GANG(j)))
+         R0(1) = R0(1) - dmin1 (0.d0, GAREL(j)*dcosd(GANG(j)))
+         R0(2) = R0(2) - dmin1 (0.d0, GAREL(j)*dsind(GANG(j)))
+         ENDDO 
+
+C  Dito in absolute coordonates :
+      IF     (mode.eq.'TEK') THEN 
+         RD(1) = (ixh - ixl) / RD(1)
+         RD(2) = (iyh - iyl) / RD(2)
+         R0(1) = ixl + RD(1)*R0(1)
+         R0(2) = iyl + RD(2)*R0(2)
+      ELSEIF (mode.eq.'PS' ) THEN 
+         RD(1) = 10000 / RD(1)
+         RD(2) = 10000 / RD(2)
+         R0(1) = RD(1)*R0(1)
+         R0(2) = RD(2)*R0(2)
+         ENDIF 
+            
+C  Transformation of x,y,z :
+      DO j = 1, nDim
+         IF (LLG(j).eq.0) THEN
+            RC(j,2) = GAREL(j) / (GMM(j,2)-GMM(j,1))
+         ELSE
+            RC(j,2) = GAREL(j) / dlog10(GMM(j,2)/GMM(j,1))
+            ENDIF
+         RC(j,1) = RD(1) * RC(j,2) * dcosd(GANG(j))
+         RC(j,2) = RD(2) * RC(j,2) * dsind(GANG(j))
+         ENDDO 
+         
+      END ! SetCoord
+
+      SUBROUTINE Coord (x, y, z, ix, iy)
+C     ----------------------------------
+            ! TekCoord JWu 20mar91, Coord/SetCoord 26jan94
+         ! transform real co-ordinates (x,z,y) -> graphic point (ix,iy)
+
+      IMPLICIT REAL*8    (a-h,o-p,r-z)
+      REAL*8             Pt(3)
+      COMMON / glimit  / GMM(3,2), LLG(3), nDim, GANG(3), GAREL(3)
+      COMMON / gcoord  / R0(2), RC(3,2)
+      
+      Pt(1) = x
+      Pt(2) = y
+      Pt(3) = z
+
+C  Origin of Coordonate system :
+      RX = R0(1)
+      RY = R0(2)
+
+C  Transformation of x,y,z :
+      DO j = 1, nDim
+         IF (LLG(j).eq.0) THEN
+            RX = RX + RC(j,1) * (Pt(j)-GMM(j,1))
+            RY = RY + RC(j,2) * (Pt(j)-GMM(j,1))
+         ELSE
+            IF (Pt(j).gt.0.) THEN ! zweiteinfachste Absturzsicherung
+               RX = RX + RC(j,1) * dlog10(Pt(j)/GMM(j,1))
+               RY = RY + RC(j,2) * dlog10(Pt(j)/GMM(j,1))
+               ENDIF
+            ENDIF
+         ENDDO
+
+      ix = idnint(RX)
+      iy = idnint(RY)
+
+      END ! Coord
+
+      SUBROUTINE PS_Coord (x, y, z, rx, ry)
+C     -------------------------------------
+            ! JWu 11/13jun91; reduction -> Coord 26jan94
+
+      IMPLICIT REAL*8    (a-h,o-p,r-z)
+
+      CALL Coord (x, y, z, ix, iy)
+
+      rx = dflotj(ix) / 1000          ! -> units of 0.1axis
+      ry = dflotj(iy) / 1000
+
+      END ! PS_Coord
+
+C  --------------------------------------------------------------------
+C  g1.3.3.  Frame : ticks
+C  --------------------------------------------------------------------
+
+      SUBROUTINE Ticks (lilo, rmin, rmax, rTick, MTick, nTick, rTack,
+     *                  MTack, nTack, rTLim, nTpT, Fehler)
+C     ----------------------------------------------------------------
+         !  Calculates the positions of small and large ticks
+         !  (ticks and tacks) to be drawn on the co-ordinate axes.
+         !  Now both linear and logarithmic axes are possible (lilo=0/1).
+         !  All co-ordinates are real co-ordinates.
+         !  the routine returnes rTick(1..nTick), rTack(1..nTack),
+         !  rTLim(2), and nTpT (ticks per tack).
+
+         !  JWu 15mar91, adapted from H.P.Schildberg's new version
+         !  "ticks_array" in HPSGRA3.FOR.
+
+      IMPLICIT REAL*8    (a-h,o-p,r-z)
+      IMPLICIT LOGICAL   (q)
+      DIMENSION          rTick(MTick), rTack(MTack), rTLim(2)
+      CHARACTER          Fehler*(*)
+
+         !  Int*4 <-> Real*8 conversion : dFlotJ, idNint, idInt, iPint.
+
+C  Check limits :
+      IF (rmin.ge.rmax) THEN
+         Fehler = 'PROGRAM ERROR/ Ticks/ Bad Limits'
+         RETURN
+         ENDIF
+
+C  Initialize tick counters :
+      nTick = 0
+      nTack = 0
+
+      IF (lilo.eq.0) THEN
+C  Linear scale :
+
+C  - R = logarithm to base 10 of plot range :
+         R  = dlog10 (rmax-rmin)
+         IR = idint (R)
+         IF (R.lt.0.d0) IR = idint (R-1.d0)
+
+C  - RD = fractional part of R :
+         RD = R - dflotj(IR)
+
+C  - Calculate TL = spacing between large ticks : (revised JWu 2jul92,12oct93)
+         RDR = 10.**RD
+         IF     (RDR.gt.10.-1.d-5) THEN ! allowing for eps=1d-5 (12oct93)
+            TL = 2.5* 10.0**IR
+            nTpT = 5
+         ELSEIF (RDR.gt.5+1.d-5) THEN
+            TL = 2. * 10.0**IR
+            nTpT = 4 ! Hinweis von Hanne
+         ELSEIF (RDR.gt.2.5+1.d-5) THEN
+            TL = 1. * 10.0**IR
+            nTpT = 5
+         ELSEIF (RDR.gt.1.6+1.d-5) THEN
+            TL = .5 * 10.0**IR
+            nTpT = 5
+         ELSEIF (RDR.gt.1.25+1.d-5) THEN
+            TL = .4 * 10.0**IR
+            nTpT = 4
+         ELSE
+            TL = .25* 10.0**IR
+            nTpT = 5
+            ENDIF
+C - TL0 = startposition for first TL :
+         r0 = TL * iPint (rmin/TL)  ! preceeding int, -> WuL1
+         IF ( dAbs(rmin-r0) .lt. 1.d-6 *TL) THEN
+            TL0 = r0 !  Should equal rmin
+         ELSE
+            TL0 = r0 + TL
+            ENDIF
+C - Number of large ticks, set array :
+         nTack = 1 + idInt( (rmax-TL0)/TL + .1 )
+         IF (nTack.gt.MTack) THEN
+            Print *, ' nTack, Mtack : ', nTack, MTack
+            Fehler = 'PROGRAM ERROR/ Ticks/ not enough tacks foreseen'
+            RETURN 
+            ENDIF
+         DO i = 1, nTack
+            rTack(i) = TL0 + (i-1)*TL
+            ENDDO
+         IF (rTack(nTack).gt.rmax+1.d-6*TL) nTack = nTack-1 ! reverse the + .
+         rTLim(1) = TL0 - TL
+         rTLim(2) = rTack(nTack) + TL
+
+C - The same for the small ticks :
+         TS = TL / nTpT ! usually 5, sometimes 4 (16nov93)
+         TS0 = TL0 - TS * idInt( (TL0-rmin)/TS )
+         nTick = 1 + idInt( (rmax-TS0)/TS )
+         IF (nTick.gt.MTick) THEN
+            Print *, ' nTick, Mtick : ', nTick, MTick
+            Fehler = 'PROGRAM ERROR/ Ticks/ not enough ticks foreseen'
+            RETURN 
+            ENDIF
+C - - For simplicity, at each large tick we will also have a small tick :
+         DO i = 1, nTick
+            rTick(i) = TS0 + (i-1)*TS
+            ENDDO
+
+      ELSE
+C  Logarithmic scale :
+
+C  - Check limits :
+         IF (rmin.le.0.) THEN 
+            Fehler = 'PROGRAM ERROR/ Ticks/ negative Log'
+            RETURN
+            ENDIF 
+
+C  - Determine smallest and largest exponent for large ticks :
+         rlgmin = dlog10 (rmin)
+         rlgmax = dlog10 (rmax)
+
+         rlgrel  = rlgmax - rlgmin
+         IF (rlgrel.gt.40.) THEN 
+            Fehler = 'Ticks/ Range exceeded in LOG_TICKS'
+            RETURN 
+            ENDIF
+
+         IF (dabs(dmod(rlgmin,1.d0)) .lt. 1.d-6) THEN
+            minexp = idNint (rlgmin)
+         ELSE
+            minexp = iPint (rlgmin) + 1
+            ENDIF
+         IF (dabs(dmod(rlgmax,1.d0)) .lt. 1.d-6) THEN
+            maxexp = idNint (rlgmax)
+         ELSE
+            maxexp = iPint (rlgmax)
+            ENDIF
+
+C  - Increment = number of decades per large tick :
+         Increment = 1 + rlgrel/7
+         IF (Increment.gt.1) THEN
+            minexp = minexp - jmod(minexp,Increment)
+            maxexp = maxexp - jmod(maxexp,Increment)
+            ENDIF
+
+C  - Set large ticks array :
+         eins = 1. + 1.d-6 ! Unity plus arithmetic tolerance
+         nTack = 0
+         DO i = minexp, maxexp, Increment
+            r0 = 1.d1 ** i
+            IF ( qrinside(r0,rmin/eins,rmax*eins) ) THEN
+               nTack = nTack + 1
+               rTack(nTack) = r0
+               ENDIF
+            ENDDO
+         IF (nTack.ge.1) THEN
+            rTLim(1) = rTack(1)     / 1.d1 ** Increment
+            rTLim(2) = rTack(nTack) * 1.d1 ** Increment
+         ELSE 
+            ! some lines got lost, Grenoble, may95
+            ENDIF
+
+C  - Set small ticks array (rewritten 13jan93) :
+         IF     (Increment.eq.1 .and. rlgrel.le.6.) THEN
+            nTpT = 9
+            DO i = minexp-1,maxexp+1
+               DO j = 2, 9
+                  r0 = 10.d0**i * j
+                  IF ( qrinside(r0,rmin,rmax) ) THEN
+                     nTick = nTick + 1
+                     rTick(nTick) = r0
+                     ENDIF
+                  ENDDO
+               ENDDO
+         ELSEIF (Increment.eq.1 .and. rlgrel.le.12.) THEN
+            nTpT = 3
+            ! 1-2-5-10 - Schritte : haesslich ?
+            DO i = minexp-Increment,maxexp+Increment
+               DO j = 1,3
+                  IF (j.eq.1) r0 = 10.d0**i * 1
+                  IF (j.eq.2) r0 = 10.d0**i * 2
+                  IF (j.eq.3) r0 = 10.d0**i * 5
+                  IF ( qrinside(r0,rmin,rmax) ) THEN
+                     nTick = nTick + 1
+                     rTick(nTick) = r0
+                     ENDIF
+                  ENDDO
+               ENDDO
+         ELSE
+            IF (Increment.eq.1) THEN 
+               nTpT = 1
+            ELSE 
+               nTpT = -Increment ! means 1/Increment means 1 tick per decade
+               ENDIF 
+            DO i = minexp-Increment,maxexp+Increment
+               r0 = 10.d0**i * j
+               IF ( qrinside(r0,rmin,rmax) ) THEN
+                  nTick = nTick + 1
+                  rTick(nTick) = r0
+                  ENDIF
+               ENDDO
+            ENDIF
+
+         ENDIF ! lilo
+
+      END ! Ticks
+
+C  ====================================================================
+C  g1.4.   TekGraphics
+C  ====================================================================
+
+C  --------------------------------------------------------------------
+C  g1.4.1.  Frame
+C  --------------------------------------------------------------------
+
+      SUBROUTINE TekFrameClear
+C     ------------------------
+         !  clear the box
+
+      COMMON / graph   / ixl, ixh, iyl, iyh, iTack, itick, jNumber, jSymbol
+
+      i = 1
+      CALL TekErase (ixl+i, iyl+i, ixh-i, iyh-i)
+
+      END ! TekFrameClear
+
+      SUBROUTINE TekAxis (j, x0, y0, z0, qTic, qLab, Fehler)
+C     ------------------------------------------------------
+            !  TekFrameTicks, renewed JWu 15mar91
+            !  rewritten 27jan94
+         !  Draw an axis from (x0,y0,z0) in direction j.
+         !  If qTic, draw ticks and tacks on axis.
+         !  If qLab, write labels on tacks.
+
+      IMPLICIT LOGICAL (q)
+      IMPLICIT REAL*8    (a-h,o-p,r-z)
+      PARAMETER         (MTick=100, MTack=10)
+      DIMENSION          rTick(MTick), rTack(MTack), DummyL(2), Pi(3), Pf(3)
+      CHARACTER          Fehler*(*), String*20
+
+      EXTERNAL TekCharArea
+
+      COMMON / graph   / ixl, ixh, iyl, iyh, iTack, itick, jNumber, jSymbol
+      COMMON / glimit  / GMM(3,2), LLG(3), nDim, GANG(3), GAREL(3)
+      COMMON / CharArea / TCAx(4), TCAy(4)
+
+      IF (Fehler.ne.'&ff') RETURN 
+
+C  Starting point :
+      Pi(1) = x0
+      Pi(2) = y0
+      Pi(3) = z0
+      DO jj = 1, nDim
+         Pf(jj) = Pi(jj)
+         ENDDO 
+
+C  This axis is no. j :
+      lilo = LLG(j)
+      gmi  = GMM(j,1)
+      gma  = GMM(j,2)
+
+C  Draw axis :
+      Pf(j) = GMM(j,2)
+      CALL SetCoord ('TEK')
+      CALL TekLinPrint (1)
+      CALL Coord (Pi(1), Pi(2), Pi(3), jxl, jyl)
+      CALL Coord (Pf(1), Pf(2), Pf(3), jxh, jyh)
+      CALL TekLin (jxl, jyl, jxh, jyh)
+
+      IF (.not.qTic) RETURN ! done.
+
+C  Angle of axis in drawing plane :
+      jxd = jxh - jxl
+      jyd = jyh - jyl
+      IF (jxd.eq.0 .and. jyd.eq.0) RETURN ! should not occur
+      angax = datan2d (dflotj(jyd), dflotj(jxd))
+c      write (9,*) ' j x y ang ', j, angax, jxd, jyd
+
+C  Direction of ticks :
+      IF (angax.lt.-135 .or. angax.gt.45) THEN
+         utix = -dsind(angax)
+         utiy =  dcosd(angax)
+         irl  = -1 ! ticks are on left of axis
+      ELSE 
+         utix =  dsind(angax)
+         utiy = -dcosd(angax)
+         irl  = +1 ! ticks are on right of axis
+         ENDIF 
+
+C  Get positions of ticks and tacks :
+      IF (gmi.ge.gma) THEN 
+         Fehler = 'PROGRAM ERROR/ TekAxis/ GMM(1,1)>=GMM(1,2)'
+         RETURN
+         ENDIF 
+      CALL Ticks (lilo, gmi, gma, rTick, MTick, nTick, rTack,
+     *            MTack, nTack, DummyL, nTpT, Fehler)
+      IF (Fehler.ne.'&ff') RETURN
+
+C  Draw small ticks ("ticks") :
+      jtix = idnint(utix*itick)
+      jtiy = idnint(utiy*itick)
+      DO i = 1, nTick
+         Pf(j) = rTick(i)
+         CALL Coord (Pf(1), Pf(2), Pf(3), jx, jy)
+         CALL TekLin (jx, jy, jx+jtix, jy+jtiy)
+         ENDDO
+
+C  Draw large ticks ("tacks") :
+      jtix = idnint(utix*iTack)
+      jtiy = idnint(utiy*iTack)
+      DO i = 1, nTack
+         Pf(j) = rTack(i)
+         CALL Coord (Pf(1), Pf(2), Pf(3), jx, jy)
+         CALL TekLin (jx, jy, jx+jtix, jy+jtiy)
+         ENDDO
+
+      IF (.not.qLab) RETURN ! done.
+
+C  Set character size :
+      CALL TekCharSize (jNumber)
+      rx = TCAx(jNumber)
+      ry = TCAy(jNumber)
+
+      jtix = idnint(utix*rx*0.7)
+      jtiy = idnint(utiy*ry*1.4)
+
+C  Draw Labels :
+      DO i = 1, nTack
+         Pf(j) = rTack(i)
+         CALL Coord (Pf(1), Pf(2), Pf(3), jx, jy)
+         CALL NiceNum(rTack(i), String, nNum)
+         jlabx = idnint (nNum * rx)   ! size of label
+         jlaby = idnint (ry) 
+         xl = jx+1.35*jtix-.5*jlabx        ! x-position for centered label
+         yl = jy+1.*jtiy-.33*jlaby        ! y-position 
+         IF (dabs(dsind(angax)).gt.0.03) THEN ! shift x-position
+            xfree = 0. !dabs((dabs(1.2d0*jtiy)+.5*jlaby)/dsind(angax)) + rx*.7
+            xl = xl + dsign(1.d0,utix) * dmax1(0.d0,jlabx/2.-xfree)
+            ENDIF 
+         CALL TekChar(iinside(idnint(xl),0,4080-jlabx),
+     *                iinside(idnint(yl),0,3060-jlaby),
+     *                String(1:nNum))
+         ENDDO
+
+      END ! TekAxis
+
+      SUBROUTINE TekPlotCS (LL, GG, AxCro, AxAng, AxLen, ndi, qBox, Fehler)
+C     ---------------------------------------------------------------------
+         ! Plot coordinate system (axes j=1,2,3)
+         ! LL(j)    : scale (=1,2 : lin,log)
+         ! GG(j,k)  : co-ordinates of edges (k=1,2 : min,max)
+
+      IMPLICIT REAL*8    (a-h,o-p,r-z)
+      IMPLICIT LOGICAL   (q)
+      DIMENSION          LL(3), GG(3,2), AxCro(3), AxAng(2), AxLen(3)
+      CHARACTER          Fehler*(*)
+
+      COMMON / glimit  / GMM(3,2), LLG(3), nDim, GANG(3), GAREL(3)
+      COMMON / graph   / ixl, ixh, iyl, iyh, iTack, itick, jNumber, jSymbol
+
+C  Set COMMON variables :
+      nDim = ndi
+      DO j = 1,nDim
+         IF (GG(j,1).ge.GG(j,2)) CALL Absturz ('TekPlotC', 'bad range')
+         IF (LL(j).eq.1 .and. GG(j,1).le.0.) CALL Absturz ('TekPlotCS',
+     *      'logarithmic scale incompatibel with negative lower limit')
+         IF (.not.qBox .and. qroutside(AxCro(j), GG(j,1), GG(j,2)))
+     *        CALL Absturz ('TekPlotCS', 'axes cross outside coordinate range') 
+         IF (AxLen(j).le.0) CALL Absturz ('TekPlotCS', ' axis length not > 0')
+         GMM(j,1) = GG(j,1)
+         GMM(j,2) = GG(j,2)
+         LLG(j)   = LL(j)
+         GAREL(j) = AxLen(j)
+         ENDDO 
+      IF (nDim.ge.3) THEN 
+         GANG(1) = AxAng(1)
+         GANG(2) = 90
+         GANG(3) = AxAng(2)
+      ELSE 
+         GANG(1) = 0
+         GANG(2) = 90
+         ENDIF 
+
+C  Begin to plot :
+      CALL ResetOldAdress
+      CALL SetCoord ('TEK')
+
+      IF (nDim.eq.2) THEN 
+         IF (qBox) THEN 
+            CALL TekAxis (1, GG(1,1), GG(2,1), 0.d0, .true., .true., Fehler) 
+            CALL TekAxis (1, GG(1,1), GG(2,2), 0.d0, .true., .false.,Fehler)
+            CALL TekAxis (2, GG(1,1), GG(2,1), 0.d0, .true., .true., Fehler) 
+            CALL TekAxis (2, GG(1,2), GG(2,1), 0.d0, .true., .false.,Fehler)
+         ELSE 
+            CALL TekAxis (1, GG(1,2), AxCro(2), 0.d0, .true., .true., Fehler)
+            CALL TekAxis (2, AxCro(1), GG(2,1), 0.d0, .true., .true., Fehler)
+            ENDIF 
+      ELSE 
+         CALL TekAxis (1, GG(1,1), AxCro(2), AxCro(3), .true., .true., Fehler)
+         CALL TekAxis (2, AxCro(1), GG(2,1), AxCro(3), .true., .true., Fehler)
+         CALL TekAxis (3, AxCro(1), AxCro(2), GG(3,1), .true., .true., Fehler)
+         ENDIF 
+
+      END ! TekPlotCS
+
+C  --------------------------------------------------------------------
+C  g1.4.2.  Data points
+C  --------------------------------------------------------------------
+
+      SUBROUTINE TekSetSymbol (iSymbol, rSize)
+C     ----------------------------------------                       JWu 22nov90
+         ! set relative co-ordinates to draw
+         ! symbol iSymbol with magnification rSize/100.
+         ! The symbol consists of nCurv curves, each curve
+         ! consisting of nLin straight lines.
+
+      IMPLICIT REAL*8 (a-h,o-p,r-z)
+      DIMENSION        nLines(11), nCurves(11)
+      REAL*4           Offsets(12,11), Radius(11)   ! strictly local
+
+      COMMON / TekSymbol / nCurv, nLin, iOff(12)    !  = Output
+
+      DATA  nCurves / 1,1,1,1,1,1,2,2,3,1,1 /
+     *      nLines  / 4,4,4,4,3,3,1,1,1,3,3 /
+     *      Offsets /
+     *  -1., 1.,  1., 1.,  1.,-1., -1.,-1., -1., 1.,  0., 0.,   ! square
+     *   0., 1.,  1., 0.,  0.,-1., -1., 0.,  0., 1.,  0., 0.,   ! karo
+     *  -1., 1.,  1.,-1., -1.,-1.,  1., 1., -1., 1.,  0., 0.,   ! eieruhr
+     *  -1., 1.,  1.,-1.,  1., 1., -1.,-1., -1., 1.,  0., 0.,   ! valve
+     *  -7.,-4.,  0., 8.,  7.,-4., -7.,-4.,  0., 0.,  0., 0.,   ! 3angle
+     *   7., 4.,  0.,-8., -7., 4.,  7., 4.,  0., 0.,  0., 0.,   ! cedez passage
+     *  -1., 0.,  1., 0.,  0.,-1.,  0., 1.,  0., 0.,  0., 0.,   ! +
+     *  -1., 1.,  1.,-1., -1.,-1.,  1., 1.,  0., 0.,  0., 0.,   ! x
+     *  -5., 0.,  5., 0., -4.,-3.,  4., 3., -4., 3.,  4.,-3.,   ! *
+     *  -4.,-7.,  8., 0., -4., 7., -4.,-7.,  0., 0.,  0., 0.,   ! |>
+     *   4.,-7., -8., 0.,  4., 7.,  4.,-7.,  0., 0.,  0., 0./   ! <|
+     *      Radius /
+     *   .08, .12, .09, .09, .016, .016, .1, .08, .02, .016, .016 /
+
+      CALL TekLinPrint(1)   !symbols always as solid lines
+
+      isy = mod (iSymbol-1, 11) + 1  ! Provisorischer Standort
+      nLin = nLines (isy)
+      nCurv= nCurves(isy)
+      DO j = 1, 2*nCurv*(nLin+1)
+         iOff(j) = nint(Offsets(j,isy)*Radius(isy)*rSize)
+         ENDDO
+
+      END ! TekSetSymbol
+
+      SUBROUTINE TekPlotSymbol (ixc, iyc)
+C     -----------------------------------
+         ! Plots a symbol at position ixc,iyc.
+         ! The symbol has to be selected by a preceeding
+         ! call of TekSetSymbol
+                  ! GoTo/DrawTo: JWu,28nov90
+
+      COMMON / TekSymbol / nCurv, nLin, iOff(12)
+
+      DO ic = 0, (nCurv-1) * 2*(nLin+1), 2*(nLin+1)
+            CALL TekLinGoTo   ( ixc+iOff(ic+1), iyc+iOff(ic+2) )
+         DO il = ic + 2, ic + nLin*2, 2
+            CALL TekLinDrawTo ( ixc+iOff(il+1), iyc+iOff(il+2) )
+            ENDDO
+         ENDDO
+
+      END ! TekPlotSymbol
+
+      SUBROUTINE TekPoint (X, Y, D, n, z, iSymb, rSyMag, qErr)
+C     --------------------------------------------------------
+         !  Plot Y(i) vs. X(i) as data points
+         !  Eventually error bars D(i) are added.
+
+               ! J.Wu  7.11.90 : X has no longer to be in ascending order
+               !       6. 3.91 : line drawing renewed
+               !      20. 3.91 : logarithmic scale
+               !      11.10.91 : TekPaint -> GraPaint, TekPoint, TekCurve
+
+      IMPLICIT REAL*8    (a-h,o-p,r-z)
+      IMPLICIT LOGICAL   (q)
+
+      DIMENSION          X(*),Y(*), D(*)
+
+      COMMON / output  / ioUnit
+      COMMON / graph   / ixl, ixh, iyl, iyh, iTack,
+     *                   itick, jNumber, jSymbol
+      COMMON / glimit  / GMM(3,2), LLG(3), nDim, GANG(3), GAREL(3)
+
+      IF (iSymb.le.0) CALL Absturz ('TekPoint', 'iSymb <= 0')
+
+      CALL TekSetSymbol (iSymb, jSymbol*rSyMag)
+      CALL SetCoord('TEK')
+
+      DO i = 1, n
+         IF (qrinside(X(i), GMM(1,1), GMM(1,2)) .and.
+     *       qrinside(Y(i), GMM(2,1), GMM(2,2))      ) THEN
+
+            CALL Coord (X(i), Y(i), z, ixc, iyc)
+            CALL TekPlotSymbol (ixc, iyc)
+            IF (qErr) THEN ! error bar, restricted to graph range
+               RYU   = dinside ( Y(i)+D(i), GMM(2,1), GMM(2,2) )
+               RYD   = dinside ( Y(i)-D(i), GMM(2,1), GMM(2,2) )
+               CALL Coord (X(i), RYU, z, ixc, iycU)
+               CALL Coord (X(i), RYD, z, ixc, iycD)
+               CALL TekLin ( ixc,iycD, ixc,iycU )
+               ENDIF ! qErr
+            ENDIF ! point inside
+         ENDDO ! i
+
+      END ! TekPoint
+
+      SUBROUTINE TekCurve (X, Y, n, z, iLine, rSyMag)
+C     -----------------------------------------------
+            ! JWu 11oct91 separate subroutine.
+         ! Plot Y(i) vs. X(i) as a polygon.
+         ! Lines intersecting the graphic frame must be
+         ! treated on entry.
+
+      IMPLICIT REAL*8    (a-h,o-p,r-z)
+      IMPLICIT LOGICAL   (q)
+
+      DIMENSION          X(*), Y(*)
+
+      IF (iLine.le.0) CALL Absturz ('TekCurve', 'iLine <= 0')
+
+      CALL TekLinPrint(iLine) ! rSyMag nicht waehlbar
+      CALL SetCoord ('TEK')
+
+      CALL Coord (X(1), Y(1), z, ix, iy)
+      CALL TekLinGoTo (ix, iy)
+      DO i = 2, n
+         CALL Coord (X(i), Y(i), z, ix, iy)
+         CALL TekLinDrawTo (ix, iy)
+         ENDDO
+
+      END ! TekCurve
+
+C  --------------------------------------------------------------------
+C  g1.4.3.  Text
+C  --------------------------------------------------------------------
+
+      SUBROUTINE TekText (iNr, Text)
+C     ------------------------------
+         ! write Text at position iNr
+
+      CHARACTER  Text*(*), aus*256
+
+      COMMON / Viewport / iTOTx, iTOTy
+      COMMON / InfPos /  infx(200), infy(200), infSiz(200)
+
+      IF (iNr.lt.1 .or. iNr.gt.200) RETURN  ! (9mar93) kein Grund fuer Absturz
+
+      isize = infSiz(iNr)
+      IF (isize.eq.0) RETURN
+
+      la = max0 (1, min0 (lenU(Text), 256)) ! continue in case Text=' ' (?)
+      aus = Text
+
+C  Auxiliary, for macros :
+      IF     (isize.eq.1) THEN
+         width =  55.1
+         iySh  =  60
+         jSy   = 500
+      ELSEIF (isize.eq.2) THEN
+         width =  50.4
+         iySh  =  40
+         jSy   = 360
+      ELSEIF (isize.eq.3) THEN
+         width =  33.7
+         iySh  =  20
+         jSy   = 150
+      ELSEIF (isize.eq.4) THEN
+         width =  30.7
+         iySh  =  12
+         jSy   = 100
+         ENDIF
+
+C  Determine position of first character :
+         ! JWu 3jul91
+      ix = infx(iNr)
+      iy = infy(iNr)
+
+      IF     (aus(1:6).eq.'&cent ') THEN
+         ! middle centered
+         CALL DelVonBis (aus, 1, 6)
+         zeile = width * lenU(aus)
+         ix = max0 (ix - nint(zeile/2), 0)
+      ELSEIF (aus(1:7).eq.'&right ') THEN
+         ! right centered
+         CALL DelVonBis (aus, 1, 7)
+         zeile = width * lenU(aus)
+         ix = max0 (ix - nint(zeile), 0)
+      ELSE
+         ! left centered
+         ! force into graphic range
+         zeile = width * lenU(aus)
+         ix = min0 (ix, iTOTx-nint(zeile))
+         ENDIF
+
+C  Search macros :
+      DO i = 1, la
+         IF (aus(i:i).eq.'&') THEN
+            IF     (aus(i+1:i+3).eq.'sy=') THEN
+               CALL Fi1I (aus(i+4:i+5), isy)
+               IF (aus(i+4:i+4).ne.'#') THEN
+                  CALL Gong (13)
+                  Print *, 'ERROR/ macro &sy in TekText'
+                  RETURN
+                  ENDIF
+               CALL DelVonBis (aus, i, i+4)
+               CALL Insert (aus, i, '  ')
+               CALL TekSetSymbol (isy, jSy*1.d0)
+               ixs = ix + nint (width * (i + 0.5))
+               CALL TekPlotSymbol (ixs, iy+iySh)
+            ELSEIF (aus(i+1:i+3).eq.'li=') THEN
+               CALL Fi1I (aus(i+4:i+5), ili)
+               IF (aus(i+4:i+4).ne.'#') THEN
+                  CALL Gong (13)
+                  Print *, 'ERROR/ macro &li in TekText'
+                  RETURN
+                  ENDIF
+               CALL DelVonBis (aus, i, i+4)
+               CALL Insert (aus, i, '    ')
+               CALL TekLinPrint (ili)
+               ix1 = ix + nint (width * (i + 0.))
+               ix2 = ix + nint (width * (i + 3.))
+               CALL TekLin (ix1, iy+iySh, ix2, iy+iySh)
+               ENDIF
+            ENDIF ! '&'
+         ENDDO ! i
+
+      CALL TekCharSize (isize)
+      CALL TekChar (ix, iy, aus(1:la))
+
+      END ! TekText
+
+C  --------------------------------------------------------------------
+C  g1.4.4.  Master : set unit, laserfile
+C  --------------------------------------------------------------------
+
+      SUBROUTINE TekSetDevice (mm)
+C     ----------------------------
+          !  Set the unit mm the next output will be sent to
+
+      COMMON / Output  / ioUnit
+
+      IF (mm.eq.0) CALL ClearGraphic
+      ioUnit = mm
+      IF (ioUnit.ne.0) CALL ResetOldAdress
+
+      END ! TekSetDevice
+
+C  ====================================================================
+C  g1.5.   PS: PostScript driver
+C  ====================================================================
+
+C  --------------------------------------------------------------------
+C  g1.5.1. Frame
+C  --------------------------------------------------------------------
+
+      SUBROUTINE PS_Numbers (ixy, XY, nXY)
+C     ------------------------------------
+            ! HPS. JWu 11jun91, 4dec91.
+         ! Large ticks and numbers attached to the axes:
+         ! PostScript line : 0.200 (0.5) yN
+
+      IMPLICIT REAL *8 (a-h,o-p,r-z)
+      DIMENSION         XY(*)
+      CHARACTER         num*20, pref*9
+
+      CALL SetCoord('PS')
+      z = 0
+      Write (52, '(a)') '['
+      DO i = 1,nXY
+         IF     (ixy.eq.1) THEN
+            CALL PS_Coord (XY(i), 1.d0, z, r, dummy)
+         ELSEIF (ixy.eq.2) THEN
+            CALL PS_Coord (1.d0, XY(i), z, dummy, r)
+         ELSE
+            CALL Absturz ('PS_Numbers', 'ixy o.o.r.')
+            ENDIF
+         CALL NiceNum (XY(i), num, ih)
+         Write (pref,'(f9.5)') r
+         CALL PS_Text (num(1:ih), pref, ' ')
+         ENDDO
+      Write (52, '(a)') '] SetTacVec' 
+
+      END ! PS_Numbers
+
+      SUBROUTINE PS_PlotCS (LL, GG, labelX, labelY, Fehler)
+C     -----------------------------------------------------
+            ! JWu 11jun91
+         ! Plot co-ordinate system (axes j=1,2,3)
+         ! LL(j)  = 0 : linear scale
+         !          1 : logarithmic scale
+         ! GG(j,k)    : co-ordinates of edges (k=1,2 : min,max)
+
+      IMPLICIT REAL*8    (a-h,o-p,r-z)
+      IMPLICIT LOGICAL   (q)
+
+      PARAMETER    (MTick=100, MTack=10)
+      DIMENSION     rTick(MTick), rTack(MTack), rTLim(2), GG(3,2), LL(3)
+      CHARACTER*(*) Fehler, labelX, labelY
+      CHARACTER     cllx*3, clly*3
+
+      COMMON / glimit  / GMM(3,2), LLG(3), nDim, GANG(3), GAREL(3)
+
+      CALL SetCoord('PS')
+      z = 0
+
+C  Write to file :
+      Write (52, '(a/)') '%: Coordinate system : '
+      IF (LLG(1).eq.0) THEN
+         cllx = 'Lin'
+      ELSE
+         cllx = 'Log'
+         ENDIF 
+      write (52, '(3a,g14.7,a,g14.7)') 
+     *   '%  ', cllx, ' x-axis from ', GMM(1,1), ' ', GMM(1,2)
+      IF (LLG(2).eq.0) THEN
+         clly = 'Lin'
+      ELSE
+         clly = 'Log'
+         ENDIF 
+      write (52, '(3a,g14.7,a,g14.7)') 
+     *   '%  ', clly, ' y-axis from ', GMM(2,1), ' ', GMM(2,2)
+      
+      Write (52, '(/a/)') 'Resets'
+
+      CALL Ticks (LLG(1), GMM(1,1), GMM(1,2),
+     *            rTick, MTick, nTick, rTack, MTack, nTack, rTLim, nTpT, Fehler)
+      IF (Fehler.ne.'&ff') RETURN 
+      CALL PS_Coord (rTLim(1), 1.d0, z, rTx1, dummy)
+      CALL PS_Coord (rTLim(2), 1.d0, z, rTxn, dummy)
+      Write (52, '(2(f9.5,1x),i2,1x,i2,2a)')
+     *   rTx1, rTxn, nTack+2, nTpT, ' SetTicVec', cllx
+      CALL PS_Numbers(1, rTack, nTack)
+      Write (52, '(a)')
+     *     '0 10   0  0     0  90 OneAxx Axx Tic xTacL xNumL % low x axis'
+      Write (52, '(a)')
+     *     '0 10   0 10     0 270 OneAxx Axx Tic xTacH       % top x axis'
+
+      Write (52, '(1x)')
+      CALL Ticks (LLG(2), GMM(2,1), GMM(2,2),
+     *            rTick, MTick, nTick, rTack, MTack, nTack, rTLim, nTpT, Fehler)
+      IF (Fehler.ne.'&ff') RETURN 
+      CALL PS_Coord (1.d0, rTLim(1), z, dummy, rTy1)
+      CALL PS_Coord (1.d0, rTLim(2), z, dummy, rTyn)
+      Write (52, '(2(f9.5,1x),i2,1x,i2,2a)')
+     *   rTy1, rTyn, nTack+2, nTpT, ' SetTicVec', clly
+      CALL PS_Numbers(2, rTack, nTack)
+      Write (52, '(a)')
+     *     '0 10   0  0    90   0 OneAxx Axx Tic yTacL yNumL % left y axis'
+      Write (52, '(a)')
+     *     '0 10  10  0    90 180 OneAxx Axx Tic yTacH % yNumH % right y axis'
+
+      Write (52, '(1x)')
+      CALL PS_Text (labelX, ' ', 'xCL')
+      CALL PS_Text (labelY, ' ', 'yCL')
+
+      Write (52, '(1x)')
+
+      END ! PS_PlotCS
+
+C  --------------------------------------------------------------------
+C  g1.5.2. Data
+C  --------------------------------------------------------------------
+
+      SUBROUTINE PS_Point (X, Y, D, n, z, iSymb, rSyMag, qErr)
+C     --------------------------------------------------------
+            ! HPS; JWu 11jun91, 11oct91.
+         !  Plot Y(i) vs. X(i), eventually error bars D(i) are added.
+
+      IMPLICIT REAL*8    (a-h,o-p,r-z)
+      IMPLICIT LOGICAL   (q)
+      DIMENSION           X(*),Y(*), D(*)
+      CHARACTER           h1*20, h2*20, text*80, cl2*2
+
+      COMMON / output  / ioUnit
+      COMMON / glimit  / GMM(3,2), LLG(3), nDim, GANG(3), GAREL(3)
+
+      IF (iSymb.le.0) CALL Absturz ('PS_Point', 'iSymb .le. 0')
+      CALL SetCoord('PS')
+
+      Write (52, '(a,g12.4)') '%: one spectrum / z = ', z
+      Write (52, '(i2,a)')     iSymb, ' pstyle'
+      DO i = 1, n
+         IF (qrinside(X(i), GMM(1,1), GMM(1,2)) .and.
+     *       qrinside(Y(i), GMM(2,1), GMM(2,2))      ) THEN
+c            RYU   = dinside ( Y(i)+D(i), GMM(2,1), GMM(2,2) )
+c            RYD   = dinside ( Y(i)-D(i), GMM(2,1), GMM(2,2) )
+            CALL PS_Coord (X(i), Y(i),      z, xc, yc)
+            CALL PS_Coord (X(i), Y(i)+D(i), z, xc, ycU)
+            CALL PS_Coord (X(i), Y(i)-D(i), z, xc, ycD)
+            dc = dmin1 ((ycU-ycD)/2, 99.999d0) ! prevent overflow
+            IF     (i.eq.1) THEN
+               Write (52, '(3(1x,f7.3),a)') xc, yc, dc, ' ti'
+            ELSEIF (i.eq.n) THEN
+               Write (52, '(3(1x,f7.3),a/)') xc, yc, dc, ' tf'
+            ELSE
+               Write (52, '(3(1x,f7.3),a)') xc, yc, dc, ' t'
+               ENDIF
+            ENDIF ! point
+         ENDDO ! i
+
+      END ! PS_Point
+
+
+      SUBROUTINE PS_PointLog (X, Y, D, n, z, iSymb, rSyMag, qErr)
+C     --------------------------------------------------------
+         ! FK added due to problems with correct error bars
+         ! for logarithmic plot similar to PS_Point aug05
+
+      IMPLICIT REAL*8    (a-h,o-p,r-z)
+      IMPLICIT LOGICAL   (q)
+      DIMENSION           X(*),Y(*), D(*)
+      CHARACTER           h1*20, h2*20, text*80, cl2*2
+
+      COMMON / output  / ioUnit
+      COMMON / glimit  / GMM(3,2), LLG(3), nDim, GANG(3), GAREL(3)
+
+      IF (iSymb.le.0) CALL Absturz ('PS_Point', 'iSymb .le. 0')
+      CALL SetCoord('PS')
+
+      Write (52, '(a,g12.4)') '%: one spectrum / z = ', z
+      Write (52, '(i2,a)')     iSymb, ' pstyle'
+      DO i = 1, n
+         IF (qrinside(X(i), GMM(1,1), GMM(1,2)) .and.
+     *       qrinside(Y(i), GMM(2,1), GMM(2,2))      ) THEN
+c            RYU   = dinside ( Y(i)+D(i), GMM(2,1), GMM(2,2) )
+c            RYD   = dinside ( Y(i)-D(i), GMM(2,1), GMM(2,2) )
+            CALL PS_Coord (X(i), Y(i),      z, xc, yc)
+            CALL PS_Coord (X(i), Y(i)+D(i), z, xc, ycU)
+            CALL PS_Coord (X(i), Y(i)-D(i), z, xc, ycD)
+            IF (yCD.lt.0.0) THEN
+               yCD = 0.0
+            ENDIF
+            yCU = dmin1 (ycU, 99.999d0) ! prevent overflow
+            yCD = dmin1 (yCD, 99.999d0) ! prevent overflow
+            IF     (i.eq.1) THEN
+               Write (52, '(3(1x,f7.3),a)') xc, yc, yCU, ' ti'
+               Write (52, '(3(1x,f7.3),a)') xc, yc, yCD, ' t'
+            ELSEIF (i.eq.n) THEN
+               Write (52, '(3(1x,f7.3),a/)') xc, yc, yCU, ' t'
+               Write (52, '(3(1x,f7.3),a/)') xc, yc, yCD, ' tf'
+            ELSE
+               Write (52, '(3(1x,f7.3),a)') xc, yc, yCU, ' t'
+               Write (52, '(3(1x,f7.3),a)') xc, yc, yCD, ' t'
+               ENDIF
+            ENDIF ! point
+         ENDDO ! i
+
+      END ! PS_PointLog
+
+      SUBROUTINE PS_Curve (X, Y, n, z, iLine, rSyMag)
+C     -----------------------------------------------
+            ! JWu 11oct91.
+         ! Plot Y(i) vs. X(i) as a polygon.
+         ! The points have to be already forced
+         ! into the graphic frame.
+
+      IMPLICIT REAL*8    (a-h,o-p,r-z)
+      IMPLICIT LOGICAL   (q)
+      DIMENSION           X(*),Y(*)
+      CHARACTER           h1*10, h2*10, text*80, cl2*2
+
+      COMMON / output  / ioUnit
+
+      IF (iLine.le.0) CALL Absturz ('PS_Curve', 'iLine .le. 0')
+
+      Write (52, '(a,g12.4)')  '%: one curve / z = ', z
+      Write (52, '(i2,a)')     iLine, ' cstyle'
+
+      CALL SetCoord ('PS')
+      CALL PS_Coord (X(1), Y(1), z, xc, yc)
+      Write (52, '(3(1x,f7.3),a)') xc, yc, 0., ' ti'
+      DO i = 2, n-1
+         CALL PS_Coord (X(i), Y(i), z, xc, yc)
+         Write (52, '(3(1x,f7.3),a)') xc, yc, 0., ' t'
+         ENDDO ! i
+      CALL PS_Coord (X(n), Y(n), z, xc, yc)
+      Write (52, '(3(1x,f7.3),a/)') xc, yc, 0., ' tf'
+
+      END ! PS_Curve
+
+C  --------------------------------------------------------------------
+C  g1.5.3.  Text
+C  --------------------------------------------------------------------
+
+      SUBROUTINE PS_Text (Text, Prefix, Suffix)
+C     -----------------------------------------
+            ! JWu 11jun91 dummy, 28feb92, macros activated 2jul92,
+            ! Prefix, Suffix to include PS_Label 21jul93
+         ! write a text to position no. iNr
+
+      CHARACTER  Text*(*), Prefix*(*), Suffix*(*),
+     *           aus*256, aux*256, h1*80, cl3*3, cr2*2
+
+      COMMON / Viewport / iTOTx, iTOTy
+
+      IF (Text.eq.'&start_text') THEN
+         Write (52, '(a)')  'black 0 -4 13 newlist'
+         RETURN
+         ENDIF
+
+      laus = len(aus)
+      IF (lenU(Text).gt.laus+2) THEN    
+         Print *, 'PS_Text/ the following line is too long:'
+         Print *, Text
+         CALL Compose2 (aus, '('//Text(1:laus-2), ')')
+      ELSE 
+         CALL Compose2 (aus, '('//Text, ')')
+         ENDIF
+
+C  Search macros :
+      i = 0
+      iKla = 0
+ 21   CONTINUE
+      IF (i.lt.lenU(aus) .and. i.lt.laus) THEN
+         i = i + 1
+         IF     (aus(i:i).eq.'&') THEN
+            IF     (aus(i+1:i+3).eq.'sy=') THEN
+               CALL Fi1I (aus(i+4:i+5), isy)
+               IF (aus(i+4:i+4).ne.'#') THEN
+                  CALL Gong (13)
+                  Print *, 'ERROR/ macro &sy in PS_Text'
+                  Print *, aus
+                  RETURN
+                  ENDIF
+               ! replace macro by PS command :
+               CALL DelVonBis (aus, i, i+4)
+               CALL Insert (aus, i,') 8 spce '//cr2(isy)//' pstyle pins (')
+               i = i-1
+            ELSEIF (aus(i+1:i+3).eq.'li=') THEN
+               CALL Fi1I (aus(i+4:i+5), ili)
+               IF (aus(i+4:i+4).ne.'#') THEN
+                  CALL Gong (13)
+                  Print *, 'ERROR/ macro &li in PS_Text'
+                  RETURN
+                  ENDIF
+               ! replace macro by PS command :
+               CALL DelVonBis (aus, i, i+4)
+               CALL Insert (aus, i, ') '//cr2(ili)//' cstyle cins (')
+               i = i-1
+            ELSE ! '&' means '&', nothing else 24oct96
+               ENDIF
+         ELSEIF (aus(i:i).eq.'(') THEN
+            iKla = iKla + 1
+         ELSEIF (aus(i:i).eq.')') THEN
+            iKla = iKla - 1
+            IF (iKla.lt.0) THEN
+               CALL Gong (9)
+               Print *, ' too many ''))'' in the following line:'
+               Print *, aus
+               CALL DelVonBis (aus, i, i)
+               ENDIF
+         ELSEIF (aus(i:i).eq.' ') THEN 
+            ! if there are many ' ', replace them by /spce (10jun94)
+            DO ii = i+1, lenU(aus) ! find first character <> ' '
+               IF (aus(ii:ii).ne.' ') GOTO 243
+               ENDDO
+ 243           CONTINUE
+            IF (ii-i.gt.4) THEN ! found many ' ' indeed
+               CALL DelVonBis (aus, i, ii-1)
+               CALL Compose2 (aux,  ') '//cl3(ii-i), ' spce (')
+               laux = lenU(aux)
+               CALL Insert (aus, i, aux(1:laux))
+               i = i+laux
+            ELSE 
+               i = ii-1
+               ENDIF 
+            ENDIF ! special character
+
+         GOTO 21 ! end loop i
+         ENDIF 
+
+      IF (iKla.gt.0) THEN
+         CALL Gong (9)
+         Print *, ' too many ''(('' in the following line :'
+         Print *, aus
+         laus = len(aus)
+         DO i = 1, iKla
+            IF (aus(laus:laus).ne.' ') THEN 
+               Print *, 'line not written to PostScript'
+               RETURN
+               ENDIF 
+            CALL Append (aus, ')')
+            ENDDO
+         ENDIF 
+
+      Write (52,'(5a)')  Prefix, ' {', aus(1:lenU(aus)), '} ', Suffix
+
+      END ! PS_Text
+
+C  --------------------------------------------------------------------
+C  g1.5.4.  Master : laserfile
+C  --------------------------------------------------------------------
+
+      SUBROUTINE OpenPS (FileExt, FileInt, Fehler)
+C     --------------------------------------------
+            ! JWu 11jun91
+         ! open new postscript file as station 52, with default name l#.ps
+
+      IMPLICIT LOGICAL   (q)
+
+      CHARACTER*(*) FileExt, FileInt, Fehler
+      CHARACTER*80  aus
+      CHARACTER     cl3*3, cv2*2
+
+      DATA          iPS /0/
+
+      IF (Fehler.ne.'&ff') THEN
+         CALL Gong (17)
+         Print *, ' Error on entry in OpenPS'
+         RETURN
+         ENDIF
+
+      IF (FileExt.eq.' ') THEN
+         ! create default file name :
+ 21      CONTINUE
+         Fehler = '&ff'
+         iPS = iPS+ 1
+         FileInt = 'l'//cl3(iPS)
+
+         IF (mod(iPS,50).eq.0) THEN
+            ! ask whether all right :
+            CALL Compose2 (aus, 'Already opening file '//FileInt,
+     *           ' - continue ?')
+            IF (.not.qAsk (aus)) THEN
+               Fehler = ' '
+               RETURN
+               ENDIF 
+            ENDIF
+
+         !  Try to open the file :
+         CALL OpenDatFile (52, FileInt, 'ps', 'n', 'seq', 'lis', 0, Fehler)
+         IF (Fehler.ne.'&ff') GOTO 21 ! try next
+         Print *, ' postscript file '//FileInt
+
+      ELSE
+         FileInt = FileExt
+         CALL OpenDatFile (52, FileInt, 'ps', 'n!', 'seq', 'lis', 0, Fehler)
+         IF (Fehler.ne.'&ff') RETURN 
+         ENDIF
+
+      END ! OpenPS
+
+      SUBROUTINE CopyPS (From, Fehler)
+C     --------------------------------
+            ! JWu 11jun91 in OpenPS, 13sep98 separately
+         ! include initialization file (g3.ps or other)
+
+      CHARACTER*(*) From, Fehler
+      CHARACTER*80  FileAux, aus, line, form
+      CHARACTER     cl3*3, cv2*2
+
+C  Copy the auxiliary file :
+      CALL ExeML ('\p '//From, FileAux)
+ 33   CONTINUE
+      CALL OpenFile (53, FileAux, '&noext', 'l', Fehler)
+      IF (Fehler.ne.'&ff') THEN
+         CALL Gong (3)
+         CALL Say2 (' Cannot open PostScript definition file "'//
+     *              FileAux(1:lenU(FileAux)), '"')
+         Fehler = '&ff'
+         CALL FrageC ('Try new file name ?', FileAux)
+         IF (FileAux.ne.' ') GOTO 33 
+         Fehler = ' '
+         RETURN
+         ENDIF
+
+C  loop - copy from 53 to 52 :
+      DO i = 1, 1200
+         read (53, '(a80)', end=98, err=99) line
+         ll = lenU(line)
+         IF (ll.le.0) THEN
+            write (52, '( )')
+         ELSE
+            form = '(a'//cv2(ll)//')'
+            write (52, form) line
+            ENDIF
+         ENDDO ! loop copy
+
+C  reached MaxLines :
+      Fehler = 'CopyPs/ too many lines/ something is wrong'
+      RETURN
+
+C  end-of file :
+ 98   CONTINUE
+      IF (i.le.3) THEN
+         Fehler = 'gra-su-file too short: eof in line '//cl3(i)
+         RETURN
+         ENDIF
+
+C  all right :
+      Close (53)
+      RETURN
+
+C  read error :
+ 99   CONTINUE
+      Fehler = 'SEVERE/ CopyPS/ reading the auxiliary file'
+      RETURN
+
+      END ! CopyPS
+
+      SUBROUTINE ClosePS
+C     ------------------
+            ! JWu 12jun91
+         ! close last postscript file
+
+C  Write end commands to postscript :
+      Write (52, '(/a)') 'EndFrame'
+      ! no longer needed ? Write (52, '(a1)')  char(4)
+
+C  Close the file :
+      Close (Unit=52)
+
+      END ! ClosePS

arch/frida-1.4/g2.f

+C  ====================================================================
+C
+C     Library  WuGra :  Graphics
+C     Modul    g2.f  :  Interface
+C
+C  ====================================================================
+
+C     J. Wuttke
+
+C     Contents :
+C
+C        outer shell / setup, info :
+C                 WdwPreset, GraSetup, GraDims, GraChoice, 
+C                 GraSetWdw, GraWdwList, GraSetAxs
+C        outer shell / set CS :
+C                 GraSetSca, GraInquireCS
+C        outer shell / plot :
+C                 GraQuit, GraPlotCS, GraPaint, GraText, GraSoftCopy
+C        Tektronix screen driver :
+C                 SetTek, SetScroll
+C        auxiliary / math for line drawing :
+C                 SectBoxLin, qSectLinLin
+C        auxiliary / compose labels :
+C                 GraLabel
+
+C     Major modifications :
+C        Sep98  TEK file and LIN output suppressed, restructured
+C        Jan94  3d begun        
+C        Jul93  Text register revised
+C        Apr93  Window switch
+C        Nov92  Some optimization for CCNY
+C        Oct91  Module WuG2 restructured
+C        Jun91  Option PostScript
+C        Nov90  Options TEK/ILL
+C        Okt90  Library WuGra
+
+C  ====================================================================
+C  outer shell / setup ...
+C  ====================================================================
+
+      BLOCK DATA WdwPreset
+C     --------------------
+            ! 23feb, 12apr93
+         ! Default choice for window-setups
+
+      IMPLICIT LOGICAL (q)
+      IMPLICIT REAL*8  (a-h, o-p, r-z)
+
+      INCLUDE 'g_dim.f'
+
+      COMMON / GraWdw / iGW, nGW
+      COMMON / GraCS  / iGFu(3,MGW), rGFu(3,MGW), Gmm(3,2,MGW)
+      COMMON / GraSpe / qErrBar(MGW), qStandSymb(MGW), rSyMag(MGW),
+     *                  qForce(3,MGW)
+      COMMON / GraSca / LinLog(3,MGW)
+      COMMON / GraAx  / AxCro(3,MGW), AxAng(2,MGW), AxLen(3,MGW),
+     *                  nWdim(MGW), qBox2(MGW)
+
+      DATA    iGW, nGW / 1, 0 /
+      DATA    qErrBar, qStandSymb, rSyMag / MGW*.false., MGW*.true., MGW*1.d0 /
+      DATA    qForce / MGW*.false., MGW*.true., MGW*.false. /
+      DATA    LinLog / MGW*0, MGW*0, MGW*0 /
+      DATA    Gmm    / MGW6*0.d0 /
+      DATA    AxCro, AxAng, AxLen, nWdim, qBox2 /
+     *                 MGW*0.d0, MGW*0.d0, MGW*0.d0, MGW*0.d0, MGW*0.d0,
+     *                 MGW*1.d0, MGW*1.d0, MGW*1.d0, MGW*2, MGW*.true. /
+
+      END ! WdwPreset
+
+      SUBROUTINE GraSetup ()
+C     ---------------------- 
+            ! as Block Data 23feb93, read from ML-par 1jun95
+         ! Presets for g1 :
+         !    FileAux   =  location of PostScript macros
+         !    qWindow   =  graphic has its own window
+         !    qGTOverlay=  graphic and dialog in different sections 
+         !                    of one window (Pericom)       
+         !    qGToldAdr =  reduction Bytes->Bits works
+         !    iGraP     =  0..1 : less or more '+' in graphic commands
+         !    iEsc      =  0..1 : switch between windows with ESC ?
+
+      IMPLICIT LOGICAL (q)
+      CHARACTER  FileAux*80
+
+      COMMON / GraTerm/ qWindow, qGTOverlay, qGToldAdr
+      COMMON / GraPlus/ iGraP, iEsc
+      COMMON / Scroll / iScroIst, iScroGra
+      COMMON / Format / kScrF, kLasF, kPS_F
+
+      qWindow    = qintr (iExeMLP('su-gra-window'))
+      qGTOverlay = qintr (iExeMLP('su-gra-ovrlay'))
+      qGToldAdr  = qintr (iExeMLP('su-gra-oldAdr'))
+
+      iGraP    = iExeMLP ('su-gra-iGraP')
+      iEsc     = iExeMLP ('su-gra-Escape')
+      iScroIst = iExeMLP ('su-scroll-ist')
+      iScroGra = iExeMLP ('su-scroll-gra')
+      
+      kScrF    = iExeMLP ('su-tekwdw-Scr')
+      kLasF    = iExeMLP ('su-tekwdw-Las')
+
+      END ! GraSetup
+
+      SUBROUTINE GraDims ()
+C     ---------------------
+            ! JWu 23nov92
+         ! Print current array dimensions
+
+      INCLUDE 'g_dim.f'
+
+      Print '(a)', ' Current array dimensions (graphic register) :'
+      Print '(a,i8)', ' # spectra           ', MKreg
+      Print '(a,i8)', ' # channels/spectrum ', MCgra
+      Print '(a,i8)', ' # total channels    ', MGreg
+      Print '(a,i8)', ' # text lines        ', MTreg
+      Print '(a,i8)', ' # labels            ', MSreg
+
+      END ! GraDims
+
+      SUBROUTINE GraChoice (What, Object, Fehler)
+C     -------------------------------------------
+            ! renove 9jul93
+
+      IMPLICIT LOGICAL (q)
+      IMPLICIT REAL*8  (a-h,o-p,r-z)
+
+      CHARACTER         What*(*), Object*(*), Fehler*(*), aus*80, cl3*3
+
+      INCLUDE 'g_dim.f'
+
+      EXTERNAL          WdwPreset
+
+      COMMON / Scroll / iScroIst, iScroGra
+      COMMON / GraTerm/ qWindow, qGTOverlay, qGToldAdr
+      COMMON / Format / kScrF, kLasF, kPS_F
+
+      COMMON / GraWdw / iGW, nGW
+      COMMON / GraSpe / qErrBar(MGW), qStandSymb(MGW), rSyMag(MGW), 
+     *                  qForce(3,MGW)
+      COMMON / GraSca / LinLog(3,MGW)
+      COMMON / GraCS  / iGFu(3,MGW), rGFu(3,MGW), Gmm(3,2,MGW)
+      COMMON / GraAx  / AxCro(3,MGW), AxAng(2,MGW), AxLen(3,MGW),
+     *                  nWdim(MGW), qBox2(MGW)
+
+      IF     (What.eq.' ') THEN  ! help
+         Print *, 'graphics commands :'
+           ! --- interpretation of these commands must be user-written :
+         Print *, '   [files] p [spectra]   : plot'
+         Print *, '   [files] a [spectra]   : add to plot'
+         Print *, '   gs [filename]         : copy plot to PostScript file'
+         Print *, '   gp [filename]         : copy plot to PS file inlc head'
+         Print *, '   ga [filename]         : - without definitions'
+           ! --- the following commands are implemented in this routine :
+         Print *, '   g-                    : close graphic display'
+         Print *, '   gg                    : display size' 
+         Print *, '   gw [window-no]        : set window'
+         Print *, '   g:                    : table of the following :'
+         Print *, '   glx/y/z               : logarithmic x/y/z scale ?'
+         Print *, '   gox/y/z [fu-no [arg]] : functional operation on x/y/z'
+         Print *, '   gfx/y/z               : force x/y/z into frame ?'
+         Print *, '   gd                    : default symbols ?'
+         Print *, '   ge                    : error bars ?'
+         Print *, '   gr [size]             : symbol radius'
+         Print *, '   gb                    : box ?'
+
+      ELSEIF (What.eq.'-') THEN
+         CALL SetScroll (0)
+
+      ELSEIF (What.eq.'g') THEN
+         Print '(a)',  ' modify graphic format :'
+         Print '(a,i3)', '    ( 1) # scroll lines       =', iScroGra
+         Print '(a,i3)', '    ( 2) laser format         =', kLasF
+         Print '(a,i3)', '    ( 3) PostScript format    =', kPS_F
+ 12      CONTINUE
+         iMod = iAskDuMu (' Modify option [exit] ?', 0, 0, 3)
+         IF     (iMod.eq. 0) THEN ! exit
+            RETURN
+         ELSEIF (iMod.eq. 1) THEN
+            IF (qWindow)THEN 
+               CALL Gong (2)
+               Print *, ' Not applicable for multi-window terminal'
+            ELSE
+               iScroGra = iAskDM (' Lines for graphics', iScroGra, 8, 25)
+               IF (iScroGra.ge.20) THEN
+                  kScrF = 5 ! Grossformat
+               ELSE
+                  kScrF = 6 ! Kleinformat
+                  ENDIF
+               IF (iScroGra.lt.iScroIst) CALL SetScroll (iScroGra)
+               ENDIF
+         ELSEIF (iMod.eq. 2) THEN
+            aus = ' Laser format : Einklebe(1), Hoch(2), Quer(3)'
+            kLasF = iAskMu (aus, 1, 3)
+         ELSEIF (iMod.eq. 3) THEN
+            aus = ' Postscript format : Hoch(2), Quer(3)'
+            kPS_F = iAskMu (aus, 2, 3)
+            ENDIF
+         GOTO 12
+
+      ELSEIF (What.eq.'w') THEN
+
+         CALL Fi1I (Object, iO)
+         IF     (Object.eq.' ') THEN
+            CALL GraWdwList ()
+            iO = iAskDMu (' Switch to graphic window no. ', iGW, 1, nGW+1)
+         ELSEIF (Object.ne.'#') THEN
+            Print *, ' usage : gw (window-number)'
+            RETURN
+         ELSEIF (qioutside(iO,1,MGW)) THEN
+            Fehler = ' Window number outside allowed range 1..'//cl3(MGW)
+            RETURN
+            ENDIF
+         iGW = iO
+
+      ELSEIF (What.eq.':') THEN
+         CALL Say2 (' setup of window '//cl3(iGW), ' :')
+         Print '(a,i3)',   '    (e)  error bars         =', intq(qErrBar(iGW))
+         Print '(a,i3)',   '    (d)  default symbols    =',intq(qStandSymb(iGW))
+         Print '(a,f6.3)', '    (r)  symbol radius      = ',rSyMag(iGW)
+         Print '(a,i3)',   '    (b)  box                =', intq(qBox2(iGW))
+
+         Print '(a,i3)',   '    (lx) log x scale        =', LinLog(1,iGW)
+         Print '(a,i3)',   '    (ly) log y scale        =', LinLog(2,iGW)
+         Print '(a,i3)',   '    (lz) log z scale        =', LinLog(3,iGW)
+
+         Print '(a,i3)',   '    (fx) force x into frame =', intq(qForce(1,iGW))
+         Print '(a,i3)',   '    (fy) force y into frame =', intq(qForce(2,iGW))
+         Print '(a,i3)',   '    (fz) force z into frame =', intq(qForce(3,iGW))
+
+         Print '(a,i3,2x,g9.3)','    (ox) operation on x     =', 
+     *                                  iGFu(1,iGW), rGFu(1,iGW)
+         Print '(a,i3,2x,g9.3)','    (oy) operation on y     =', 
+     *                                  iGFu(2,iGW), rGFu(2,iGW)
+         Print '(a,i3,2x,g9.3)','    (oz) operation on z     =', 
+     *                                  iGFu(3,iGW), rGFu(3,iGW)
+         
+      ELSEIF (What.eq.'e') THEN
+         qErrBar(iGW) = .not. qErrBar(iGW)
+      ELSEIF (What.eq.'d') THEN
+         qStandSymb(iGW) = .not.qStandSymb(iGW)
+      ELSEIF (What.eq.'r') THEN
+         aus = ' Symbol radius ?'
+         rSyMag(iGW) = rAskMu (aus, 0.d0, 1.d1)
+      ELSEIF (What.eq.'b') THEN
+         qBox2(iGW) = .not. qBox2(iGW)
+
+      ELSEIF (What.eq.'lx') THEN 
+         LinLog(1,iGW) = 1 - LinLog(1,iGW)
+      ELSEIF (What.eq.'ly') THEN 
+         LinLog(2,iGW) = 1 - LinLog(2,iGW)
+      ELSEIF (What.eq.'lz') THEN 
+         LinLog(3,iGW) = 1 - LinLog(3,iGW)
+
+      ELSEIF (What.eq.'fx') THEN 
+         qForce(1,iGW) = .not. qForce(1,iGW)
+      ELSEIF (What.eq.'fy') THEN 
+         qForce(2,iGW) = .not. qForce(2,iGW)
+      ELSEIF (What.eq.'fz') THEN 
+         qForce(3,iGW) = .not. qForce(3,iGW)
+
+      ELSEIF (What.eq.'ox') THEN
+         CALL FuAsk (' Function for x-scale', 
+     *               Object, iGFu(1,iGW), rGFu(1,iGW))
+      ELSEIF (What.eq.'oy') THEN
+         CALL FuAsk (' Function for y-scale', 
+     *               Object, iGFu(2,iGW), rGFu(2,iGW))
+      ELSEIF (What.eq.'oz') THEN
+         CALL FuAsk (' Function for z-scale', 
+     *               Object, iGFu(3,iGW), rGFu(3,iGW))
+
+      ELSE
+         Fehler = ' this option not accessible'
+         ENDIF
+
+      END ! GraChoice
+
+      SUBROUTINE GraSetWdw (ndim, Coor, Unit, Fehler)
+C     -----------------------------------------------
+            ! JWu 12mar96
+         ! Change window if dim has changed or if Co/Un don't fit
+
+      IMPLICIT LOGICAL (q)
+      IMPLICIT REAL*8  (a-h,o-p,r-z)
+
+      INCLUDE 'g_dim.f'
+      CHARACTER*(*)      Coor(3), Unit(3), Fehler
+      CHARACTER*40       GCoor, GUnit
+
+      COMMON / GraWdw / iGW, nGW
+      COMMON / GraCS  / iGFu(3,MGW), rGFu(3,MGW), Gmm(3,2,MGW)
+      COMMON / GraSca / LinLog(3,MGW)
+      COMMON / GraLab / GCoor(3,MGW), GUnit(3,MGW)
+      COMMON / GraAx  / AxCro(3,MGW), AxAng(2,MGW), AxLen(3,MGW),
+     *                  nWdim(MGW), qBox2(MGW)
+
+      IF (Fehler.ne.'&ff') RETURN
+      iGWold = iGW
+ 1    CONTINUE 
+      IF (iGW.gt.nGW) THEN ! open new window
+         nWdim(iGW) = ndim
+         DO idim = 1, ndim
+            GUnit(idim,iGW) = Unit(idim)
+            ENDDO 
+         nGW = min0(iGW, MGW-1)
+         IF (iGWold.ge.1) THEN ! inherit setup from previous window 
+            DO id = 1, 3
+               IF (Unit(id).eq.GUnit(id,iGWold)) THEN
+                  LinLog(id,iGW) = LinLog(id,iGWold)
+                  Gmm(id,1,iGW)  = Gmm(id,1,iGWold)
+                  Gmm(id,2,iGW)  = Gmm(id,2,iGWold)
+                  ENDIF
+               ENDDO
+            ENDIF
+      ELSE 
+         IF (ndim.ne.nWdim(iGW) .or.
+     *       Unit(1).ne.GUnit(1,iGW) .or. Unit(2).ne.GUnit(2,iGW) .or.
+     *       (ndim.eq.3 .and. Unit(3).ne.GUnit(3,iGW))) THEN 
+            ! circular search for other window :
+            iGW = iGW-1
+            IF (iGW.le.0) iGW = nGW
+            IF (iGW.eq.iGWold) iGW = nGW + 1
+            GOTO 1
+            ENDIF
+         ENDIF 
+
+      DO idim = 1, ndim
+         GCoor(idim,iGW) = Coor(idim)
+         ENDDO 
+
+      END ! GraSetWdw
+
+      SUBROUTINE GraWdwList ()
+C     ------------------------
+         ! List contents of activated graph windows (9aug93)
+
+      IMPLICIT LOGICAL (q)
+      IMPLICIT REAL*8  (a-h,o-p,r-z)
+      
+      INCLUDE 'g_dim.f'
+      CHARACTER         Activ*1, LX*1, LY*1, GCoor*40, GUnit*40
+
+      COMMON / GraWdw / iGW, nGW
+      COMMON / GraLab / GCoor(3,MGW), GUnit(3,MGW)
+      COMMON / GraCS  / iGFu(3,MGW), rGFu(3,MGW), Gmm(3,2,MGW)
+      COMMON / GraSca / LinLog(3,MGW)
+
+      DO i = 1, MGW
+         IF (Gmm(1,1,i).ne.Gmm(1,2,i)) THEN ! else the window hasn't been used
+            IF (i.eq.iGW) THEN
+               Activ = '*'
+            ELSE
+               Activ = ' '
+               ENDIF
+            IF (LinLog(1,i).eq.1) THEN
+               LX    = 'L'
+            ELSE
+               LX    = ' '
+               ENDIF
+            IF (LinLog(2,i).eq.1) THEN
+               LY    = 'L'
+            ELSE
+               LY    = ' '
+               ENDIF
+   
+            Print '(i2,a1,1x,2(a1,1x,a7,a6,1x,g10.2,g10.2,3x))', 
+     *         i, Activ, 
+     *         LX, GCoor(1,i), '('//GUnit(1,i)(1:lenU(GUnit(1,i)))//')',
+     *            Gmm(1,1,i), Gmm(1,2,i),
+     *         LY, GCoor(2,i), '('//GUnit(2,i)(1:lenU(GUnit(2,i)))//')',
+     *            Gmm(2,1,i), Gmm(2,2,i)
+   
+            ENDIF
+         ENDDO
+      
+      END ! GraWdwList
+
+      SUBROUTINE GraSetAxs (Fehler)
+C     -----------------------------
+            ! JWu 12mar96 separated from GraSetCS
+         ! Determine situation of coordinate axis in the drawing 
+
+      IMPLICIT LOGICAL (q)
+      IMPLICIT REAL*8  (a-h,o-p,r-z)
+
+      INCLUDE 'g_dim.f'
+      CHARACTER          Fehler*(*)
+      CHARACTER*40       CoUn(6)
+
+      COMMON / GraWdw / iGW, nGW
+      COMMON / GraCS  / iGFu(3,MGW), rGFu(3,MGW), Gmm(3,2,MGW)
+      COMMON / GraAx  / AxCro(3,MGW), AxAng(2,MGW), AxLen(3,MGW),
+     *                  nWdim(MGW), qBox2(MGW)
+
+ 41   CONTINUE 
+      IF (nWdim(iGW).eq.3) THEN 
+         CALL rAskTrip (' x/y/z Axes cross in point',
+     *      AxCro(1,iGW), AxCro(2,iGW), AxCro(3,iGW),
+     *      AxCro(1,iGW), AxCro(2,iGW), AxCro(3,iGW)) 
+         CALL rAskTrip (' Relative length of axes',
+     *      AxLen(1,iGW), AxLen(2,iGW), AxLen(3,iGW),
+     *      AxLen(1,iGW), AxLen(2,iGW), AxLen(3,iGW)) 
+         DO j = 1, 3
+            IF (qroutside(AxCro(j,iGW), Gmm(j,1,iGW), Gmm(j,2,iGW))) THEN
+               CALL Gong(6)
+               Print *, ' Axes cross must be within coordinate limits'
+               GOTO 41
+               ENDIF
+            ENDDO 
+         CALL rAskPair (' And x/z axes have angles',
+     *      AxAng(1,iGW), AxAng(2,iGW), AxAng(1,iGW), AxAng(2,iGW))
+      ELSEIF (.not.qBox2(iGW)) THEN
+         CALL rAskPair (' x/y Axes cross in point',
+     *      AxCro(1,iGW), AxCro(2,iGW), AxCro(1,iGW), AxCro(2,iGW))
+         DO j = 1, 2
+            IF (qroutside(AxCro(j,iGW), Gmm(j,1,iGW), Gmm(j,2,iGW))) THEN
+               CALL Gong(6)
+               Print *, ' Axes cross must be within coordinate limits'
+               GOTO 41
+               ENDIF
+            AxLen(j,iGW) = 1
+            ENDDO 
+         ENDIF
+
+      END ! GraSetAxs
+
+C  ====================================================================
+C  outer shell / set scale 
+C  ====================================================================
+
+      SUBROUTINE GraSetSca (iD, cD, si, sf, action, qLin, igf, rgf)
+C     -------------------------------------------------------------
+            ! JWu oct90. revisions 19sep/11oct91, 18jan93.
+            ! Simplified version, recursive interaction with i0: 12mar96.
+         ! Determine graphic range
+
+      IMPLICIT LOGICAL (q)
+      IMPLICIT REAL*8  (a-h,o-p,r-z)
+
+      INCLUDE 'g_dim.f'
+      CHARACTER          aus*80, ein*80, Fehler*80, what*20, cD*1, action*1
+      CHARACTER*40       CoUn(6)
+
+      COMMON / GraWdw / iGW, nGW
+      COMMON / GraCS  / iGFu(3,MGW), rGFu(3,MGW), Gmm(3,2,MGW)
+      COMMON / GraSca / LinLog(3,MGW)
+
+      Fehler = '&ff'
+
+      IF (si.ge.sf) THEN ! no default limits given => take last ones
+         si = Gmm(iD,1,iGW)
+         sf = Gmm(iD,2,iGW)
+         ENDIF 
+
+ 10   CONTINUE
+
+      ! Menu (except in some special cases) :
+      IF (si.ge.sf) THEN ! should happen only on 1st call
+         ein = 'n'
+      ELSEIF (ein.eq.'a') THEN 
+         ein = ' ' ! accept default, don't ask for confirmation
+      ELSE
+         aus = ' Rescale '//cD//' (h=help)'
+         ein = ' '
+         CALL rAskRgeTxt (aus, ein, si, sf, si, sf)
+         ENDIF
+
+ 11   CONTINUE
+      IF     (ein.eq.'h' .or. ein.eq.'?') THEN
+         Print *, ' rescale '//cD//'-range of plot :'
+         Print *, '    RETURN = accept default range'
+         Print *, '    r1 r2  = new range r1..r2'
+         Print *, '    r1,    = overwrite r1, accept other default'
+         Print *, '    ,r2    = overwrite r2, accept other default'
+         Print *, '    a      = automatic calculation'
+         Print *, '    n      = calculate new default'
+         Print *, '   <g-opt> = setup commands d,e,r,lx/y,..,'
+         Print *, '    :      = setup list'
+         IF (iD.gt.1)
+     *   Print *, '    x      = correct x-range'
+         Print *, '    -      = exit, no plot'
+         GOTO 10
+
+      ELSEIF (ein.eq.' ') THEN ! accept default
+         ! test whether new limits are consistent with log plot :
+         CALL FuVal (iGFu(iD,iGW), 
+     *               siF, dummy, si, 0.d0, rGFu(iD,iGW), 0.d0)
+         CALL FuVal (iGFu(iD,iGW), 
+     *               sfF, dummy, sf, 0.d0, rGFu(iD,iGW), 0.d0)
+         IF (LinLog(iD,iGW).eq.1 .and. 
+     *       (siF.le.0 .or. sfF.le.0)) THEN
+            Print *, ' limits inconsistent with log scale'
+            CALL Gong (3)
+            GOTO 10
+         ELSE
+            Gmm(iD,1,iGW) = si
+            Gmm(iD,2,iGW) = sf
+            action = ' '
+            ENDIF
+
+      ELSEIF (jPos1('n-x',ein(1:1)).le.3) THEN
+         action = ein(1:1)
+
+      ELSEIF (ein.eq.'a') THEN
+         action = 'n'
+
+      ELSE
+         CALL TakeVorDel (ein, what, ' ')
+         CALL GraChoice (what, ein, Fehler)
+         IF (Fehler.ne.'&ff') THEN
+            CALL FehlerGong (Fehler, 3)
+            GOTO 10
+         ELSEIF (what(1:1).eq.'l') THEN
+            IF (what(2:2).eq.cD) THEN
+               action = 'n'
+            ELSEIF (ichar(what(2:2)).lt.ichar(cD)) THEN
+               action = what(2:2)
+               ENDIF
+         ELSEIF (what(1:1).eq.'w') THEN
+            action = 'x'
+         ELSE
+            GOTO 10
+            ENDIF
+
+         ENDIF
+
+      ! the following parameters are needed for calculating new limits :
+      qLin = .not. qintr(LinLog(iD,iGW))
+      igf  = iGFu(iD,iGW)
+      rgf  = rGFu(iD,iGW)
+
+      END ! GraSetSca
+
+      SUBROUTINE GraInquireCS (cxy, rmi, rma, iFu, rFuPar, lilo)
+C     ----------------------------------------------------------
+         ! Access to COMMON / GraCS / for application program
+
+      IMPLICIT LOGICAL (q)
+      IMPLICIT REAL*8  (a-h,o-p,r-z)
+
+      INCLUDE 'g_dim.f'
+      CHARACTER         cxy*1
+
+      COMMON / GraWdw / iGW, nGW
+      COMMON / GraCS  / iGFu(3,MGW), rGFu(3,MGW), Gmm(3,2,MGW)
+      COMMON / GraSca / LinLog(3,MGW)
+
+      j = 0
+      IF (cxy.eq.'x') j=1
+      IF (cxy.eq.'y') j=2
+      IF (cxy.eq.'z') j=3
+      IF (j.eq.0) CALL Absturz ('GraInquire', 'cxy o.o.r.')
+
+      rmi    = Gmm   (j,1,iGW)
+      rma    = Gmm   (j,2,iGW)
+      iFu    = iGFu  (j,iGW)
+      rFuPar = rGFu  (j,iGW)
+      lilo   = LinLog(j,iGW)
+
+      END ! GraInquireCS
+
+C  ====================================================================
+C  outer shell / plot 
+C  ====================================================================
+
+      SUBROUTINE GraQuit ()
+C     ---------------------
+         ! Quit the graph mode to continue with text.
+
+      IMPLICIT LOGICAL (q)
+      CHARACTER  ein *80
+
+      COMMON / GraTerm/ qWindow, qGTOverlay, qGToldAdr
+
+      IF ((.not.qGTOverlay) .and. (.not.qWindow)) THEN
+         CALL FrageC (' Say something to continue', ein)
+         ENDIF
+
+      CALL GMode (0)
+
+      END ! GraQuit
+
+      SUBROUTINE GraPlotCS (Fehler)
+C     -----------------------------
+         ! Open or clear the graphics, plot scales, labels and title.
+         ! The coordinate window should be set by a previous call
+         ! to GraSetCS.
+
+      IMPLICIT LOGICAL (q)
+      IMPLICIT REAL*8  (a-h,o-p,r-z)
+      INCLUDE 'g_dim.f'
+
+      CHARACTER         RegTX*80, RegSX*80, GCoor*40, GUnit*40, Labl(3)*40,
+     *                  Fehler*(*)
+
+      COMMON / GraWdw / iGW, nGW
+      COMMON / GraLab / GCoor(3,MGW), GUnit(3,MGW)
+      COMMON / GraReg / NReg(MKreg), PReg(MGreg,3), ZReg(MKreg), iReg,
+     *                  iRLS(MKreg), RegTX(MTreg), RegSX(MSreg,6), iRTS(7)
+      COMMON / GraCS  / iGFu(3,MGW), rGFu(3,MGW), Gmm(3,2,MGW)
+      COMMON / GraSca / LinLog(3,MGW)
+      COMMON / GraAx  / AxCro(3,MGW), AxAng(2,MGW), AxLen(3,MGW),
+     *                  nWdim(MGW), qBox2(MGW)
+
+      CALL GraSetup ()
+
+      DO idim = 1, 3
+         CALL GraLabel (idim, Labl(idim), GCoor(idim,iGW), GUnit(idim,iGW))
+         ENDDO 
+
+C  Clear GraReg :
+      iReg = 0
+      DO j=1,7
+         iRTS(j) = 0
+         ENDDO
+
+C  Enregister :
+      RegSX(1,1) = ' ' ! title
+      RegSX(1,2) = Labl(1)
+      RegSX(1,3) = Labl(2)
+      iRTS(1)    = 1
+      iRTS(2)    = 1
+      iRTS(3)    = 1
+      CALL GraText ('&start_text', 3)
+
+C  Open graphics :
+      CALL SetTek ()
+      CALL GMode (1) ! added for xterm
+      CALL ClearGraphic
+
+C  Plot co-ordinate system and text :
+      CALL GMode (1)
+      qBox = (qBox2(iGW) .and. nWdim(iGW).eq.2)
+      CALL TekPlotCS (LinLog(1,iGW), Gmm(1,1,iGW),
+     *     AxCro(1,iGW), AxAng(1,iGW), AxLen(1,iGW), nWdim(iGW), qBox, Fehler)
+      CALL TekText (2, '&right '//Labl(1))
+      CALL TekText (3, '&right '//Labl(2))
+
+      END ! GraPlotCS
+
+      SUBROUTINE GraPaint (X, Y, D, n, z, iLSin, iLS)
+C     -----------------------------------------------
+         ! Choose linestyle/symbols, transform data, call ExePaint.
+
+      IMPLICIT LOGICAL (q)
+      IMPLICIT REAL*8  (a-h,o-p,r-z)
+
+      INCLUDE 'g_dim.f'
+      DIMENSION  X(*), Y(*), D(*), Xp(MCgra), Yp(MCgra), Dp(MCgra),
+     *           XS(4), YS(4) ! should be (2)
+      CHARACTER  RegTX*80, RegSX*80
+
+      COMMON / GraWdw / iGW, nGW
+      COMMON / GraCS  / iGFu(3,MGW), rGFu(3,MGW), Gmm(3,2,MGW)
+      COMMON / GraSpe / qErrBar(MGW), qStandSymb(MGW), rSyMag(MGW), 
+     *                  qForce(3,MGW)
+      COMMON / GraReg / NReg(MKreg), PReg(MGreg,3), ZReg(MKreg), iReg,
+     *                  iRLS(MKreg), RegTX(MTreg), RegSX(MSreg,6), iRTS(7)
+
+C  Checks :
+      IF (n.gt.MCgra) THEN
+         CALL GMode(0)
+         Print *, ' Graphic overflow/ too many points'
+         RETURN
+         ENDIF
+
+C  Choice of linestyle/symbol (help suppressed 28jan92) :
+      IF (qStandSymb(iGW)) THEN
+         iLS = iLSin
+      ELSE
+         ! construct default :
+         IF     (iReg.le.0) THEN
+            iLSdef = iLSin
+         ELSEIF (iLS.gt.0) THEN
+            iLSdef = iLS + 1
+         ELSE
+            iLSdef = iLS - 1
+            ENDIF
+         ! ask :     
+         CALL GMode (0)
+         iLS = iAskD (' Linestyle(>0) or plotsymbol(<0)', iLSdef)
+         ENDIF
+      IF (iLS.eq.0) RETURN ! break
+      qPoints = (iLS.lt.0)
+
+C  Loop over data points (all operations here since 6nov92) :
+      np = 0
+      qDrawing = .false. ! old point (xa,ya) is still undefined
+      DO i = 1, n
+C  - Functional transforms :
+         IF (iGFu(1,iGW).eq.0) THEN
+            xi = X(i)
+         ELSE
+            IF (iGFu(1,iGW).eq.1 .or. iGFu(1,iGW).eq.2) THEN
+               IF (X(i).le.0.) GOTO 19
+               ENDIF
+            CALL FuVal (iGFu(1,iGW), xi, dummy, X(i), 0.d0, rGFu(1,iGW), 0.d0)
+            ENDIF
+         IF (iGFu(2,iGW).eq.0) THEN
+            yi = Y(i)
+            di = D(i)
+         ELSE
+            IF (iGFu(2,iGW).eq.1 .or. iGFu(2,iGW).eq.2) THEN
+               IF (Y(i).le.0.) GOTO 19
+               ENDIF
+            CALL FuVal (iGFu(2,iGW), yi, di, Y(i), D(i), rGFu(2,iGW), 0.d0)
+            ENDIF
+
+         IF (qPoints) THEN
+C  - Force into graphic range ?
+            IF (qForce(1,iGW)) THEN
+               xi = dinside (xi, Gmm(1,1,iGW), Gmm(1,2,iGW))
+            ELSEIF (qroutside(xi, Gmm(1,1,iGW), Gmm(1,2,iGW))) THEN
+               GOTO 19
+               ENDIF
+            IF (qForce(2,iGW)) THEN
+               yi = dinside (yi, Gmm(2,1,iGW), Gmm(2,2,iGW))
+            ELSEIF (qroutside(yi, Gmm(2,1,iGW), Gmm(2,2,iGW))) THEN
+               GOTO 19
+               ENDIF
+         ELSE ! draw line
+C  - Handle intersections with frame :
+            IF (np.gt.MCgra-2) THEN
+               CALL GMode (0)
+               Print *, ' Graphic overflow/ too many points'
+               GOTO 90
+               ENDIF 
+            IF (qDrawing) THEN
+               CALL SectBoxLin (Gmm(1,1,iGW), Gmm(1,2,iGW),
+     *                          Gmm(2,1,iGW), Gmm(2,2,iGW),
+     *                          xa, ya, xi, yi,
+     *                          qIn1, qIn2, nSect, XS, YS)
+               DO jSect = 1, nSect ! ainsi simplifie le 22mai94
+                  Xp(np+jSect) = XS(jSect)
+                  Yp(np+jSect) = YS(jSect)
+                  Dp(np+jSect) = -1000-100*intq(qIn1)-10*intq(qIn2)-jSect
+                  ENDDO
+               np = np + nSect
+               IF (.not.qIn2) GOTO 18
+            ELSE 
+               IF (.not.(qrinside(xi,Gmm(1,1,iGW),Gmm(1,2,iGW)) .and.
+     *                   qrinside(yi,Gmm(2,1,iGW),Gmm(2,2,iGW)))) GOTO 18
+               ENDIF
+            ENDIF ! points/line
+C  - Retain entry :
+         np = np + 1
+         Xp(np) = xi
+         Yp(np) = yi
+         Dp(np) = di
+C  - End of loop :
+ 18      CONTINUE
+         qDrawing = .true.
+         xa = xi ! old points
+         ya = yi
+ 19      CONTINUE 
+         ENDDO
+
+C  Enregister (one-dimensional storage 29oct92) :
+      IF (iReg.eq.0) THEN
+         iOff = 0
+      ELSE
+         iOff = NReg(iReg)
+         ENDIF
+      IF     (iOff+np.gt.MGreg) THEN
+         Print *, 'GraReg overflow/ too many points'
+      ELSEIF (iReg.ge.MKreg) THEN
+         Print *, 'GraReg overflow/ too many spectra'
+      ELSE
+         iReg = iReg + 1
+         NReg(iReg) = iOff + np ! last filled line
+         iRLS(iReg) = iLS
+         DO i = 1, np
+            PReg(iOff+i,1) = Xp(i)
+            PReg(iOff+i,2) = Yp(i)
+            PReg(iOff+i,3) = Dp(i)
+            ENDDO
+         ZReg(iReg) = z
+         ENDIF
+
+C  Plot points :
+ 90   CONTINUE 
+      CALL GMode (1)
+      IF (iLS.lt.0) THEN
+         CALL TekPoint (Xp, Yp, Dp, np, z, -iLS, rSyMag(iGW), qErrBar(iGW))
+      ELSE
+         CALL TekCurve (Xp, Yp, np, z, iLS, rSyMag(iGW))
+         ENDIF
+
+      END ! GraPaint
+
+      SUBROUTINE GraText (text, idev)
+C     -------------------------------
+             ! rewritten JWu 22jul93
+         ! decode macros, enregister, call TekText.
+
+         ! idev = 1   : TEK on screen
+         !        2   : register (and later on file)
+         !        3   : both (1 and 2)
+         
+      IMPLICIT REAL*8  (a-h,o-p,r-z)
+      IMPLICIT LOGICAL (q)
+      INCLUDE 'g_dim.f'
+      CHARACTER         RegTX*80, RegSX*80, text*(*)
+      SAVE              iTEKpos
+
+      COMMON / GraReg / NReg(MKreg), PReg(MGreg,3), ZReg(MKreg), iReg,
+     *                  iRLS(MKreg), RegTX(MTreg), RegSX(MSreg,6), iRTS(7)
+
+C  Enregister :
+      IF (idev.eq.2 .or. idev.eq.3) THEN
+         iRTS(7) = iRTS(7) + 1
+         IF (iRTS(7).gt.MTreg) GOTO 19
+         RegTX(iRTS(7)) = text
+         DO ii = 81, lenU(text), 75
+            iRTS(7) = iRTS(7) + 1
+            IF (iRTS(7).gt.MTreg) GOTO 19
+            RegTX(iRTS(7)) = '... '//text(ii:min0(lenU(text),ii+74))
+            ENDDO 
+         ENDIF
+ 19   CONTINUE 
+
+C  Plot :
+      IF (idev.eq.1 .or. idev.eq.3) THEN
+         IF     (text.eq.'&start_text') THEN
+            iTEKpos = 11
+         ELSE
+            CALL TekText (iTEKpos, text)
+            iTEKpos = iTEKpos + 1
+            ENDIF
+         ENDIF
+
+      END ! GraText
+
+      SUBROUTINE GraSoftCopy (FileExt, FileIniMac, Fehler)
+C     ----------------------------------------------------
+         ! A copy of the current graphics (as saved in / GraReg / )
+         ! is written to an output file optionally given by Object.
+
+      IMPLICIT LOGICAL (q)
+      IMPLICIT REAL*8  (a-h,o-p,r-z)
+      INCLUDE 'g_dim.f'
+      CHARACTER*(*) FileExt, FileIniMac, Fehler
+      CHARACTER     FileInt*80, RegTX*80, RegSX*80, aus*240, Datum*10, 
+     *              Zeit*10,Datuma*24
+      REAL*8        X(MCgra), Y(MCgra), D(MCgra)
+
+      COMMON / GraReg / NReg(MKreg), PReg(MGreg,3), ZReg(MKreg), iReg,
+     *                  iRLS(MKreg), RegTX(MTreg), RegSX(MSreg,6), iRTS(7)
+      COMMON / GraWdw / iGW, nGW
+      COMMON / GraSpe / qErrBar(MGW), qStandSymb(MGW),
+     *                  rSyMag(MGW), qForce(3,MGW)
+      COMMON / GraCS  / iGFu(3,MGW), rGFu(3,MGW), Gmm(3,2,MGW)
+      COMMON / GraSca / LinLog(3,MGW)
+      COMMON / GraAx  / AxCro(3,MGW), AxAng(2,MGW), AxLen(3,MGW),
+     *                  nWdim(MGW), qBox2(MGW)
+
+C  Checks :
+      IF (iReg.le.0) THEN
+         Fehler = 'graphic register is empty'
+         RETURN
+         ENDIF
+
+C  Open output file :
+      CALL OpenPS (FileExt, FileInt, Fehler)
+      IF (Fehler.ne.'&ff') RETURN 
+
+      CALL CopyPS (FileIniMac, Fehler)
+      IF (Fehler.ne.'&ff') RETURN 
+      
+      CALL PS_Text (FileInt, ' ', ' /filename exch def 10 -3 18 showfilename')
+
+C  Copy plot from register :
+
+c     nDi = nWdim(iGW)                   ! unused
+c     qBox = (qBox2(iGW) .and. nDi.eq.2)
+
+      CALL PS_PlotCS (LinLog(1,iGW), Gmm(1,1,iGW),
+     *                RegSX(1,2), RegSX(1,3), Fehler)
+      IF (Fehler.ne.'&ff') RETURN 
+
+C  Data points and curves :
+     
+      DO ir = 1, iReg
+         IF (ir.eq.1) THEN
+            iOff = 0
+         ELSE
+            iOff = NReg(ir-1)
+            ENDIF
+         n = NReg(ir) - iOff
+         DO i = 1, n
+            X(i) = PReg(iOff+i,1)
+            Y(i) = PReg(iOff+i,2)
+            D(i) = PReg(iOff+i,3)
+            ENDDO
+
+         IF (iRLS(ir).lt.0.and.LinLog(2,iGW).eq.0) THEN
+            CALL PS_Point (X, Y, D, n, ZReg(ir), -iRLS(ir),
+     *                     rSyMag(iGW), qErrBar(iGW))
+         ELSEIF (iRLS(ir).lt.0.and.LinLog(2,iGW).eq.1) THEN
+            CALL PS_PointLog (X, Y, D, n, ZReg(ir), -iRLS(ir),
+     *                     rSyMag(iGW), qErrBar(iGW))
+         ELSE
+            CALL PS_Curve (X, Y, n, ZReg(ir), iRLS(ir), rSyMag(iGW))
+            ENDIF
+
+         ENDDO ! ir
+
+C  Text lines :
+      i = 0
+      iPos = 0
+ 11   CONTINUE 
+         i = i+1
+         iPos = iPos + 1
+         IF (i.gt.iRTS(7)) GOTO 19
+         aus = RegTX(i)
+ 12      IF (i.lt.iRTS(7) .and. RegTX(i+1)(1:3).eq.'&cd') THEN 
+            i = i + 1
+            CALL Append (aus, RegTX(i)(4:len(RegTX(i))))
+            GOTO 12
+            ENDIF 
+         CALL PS_Text (aus, ' ', 'infline') ! position 10+i only for TEK
+         GOTO 11
+ 19   CONTINUE   
+
+
+C Fixed date/time output (by Christian Geisler, Sep04)
+C modified by FK Oct06 now fully operational (System dependent!!)
+      CALL  fdate(Datuma)
+      CALL  Compose5 (Datum(1:10),Datuma(9:10),'-',Datuma(5:7),'-',
+     *                Datuma(23:24))
+      CALL  Compose2 (Zeit(1:9),Datuma(12:19),'-' )
+      CALL Compose3 (aus(1:21),Datum(1:10), ', ', Zeit(1:8))
+      CALL PS_Text (aus,  ' ', 'infline')
+
+C  Close output file :
+      CALL ClosePS ()
+
+      END ! GraSoftCopy
+
+C  ====================================================================
+C  Tektronix screen driver
+C  ====================================================================
+
+      SUBROUTINE SetTek ()
+C     --------------------
+         ! set device = TEKTRONIX
+
+      IMPLICIT LOGICAL (q)
+
+      COMMON / GraTerm/ qWindow, qGTOverlay, qGToldAdr
+      COMMON / Scroll / iScroIst, iScroGra
+      COMMON / Format / kScrF, kLasF, kPS_F
+
+      IF (qGTOverlay .and. iScroIst.ne.iScroGra) CALL SetScroll (iScroGra)
+      CALL TekSetDevice (6)
+      CALL SetWindow (kScrF)
+
+      END ! SetTek
+
+      SUBROUTINE SetScroll (iScroNew)
+C     -------------------------------
+         ! Set the scroll area.
+
+      IMPLICIT LOGICAL (q)
+      IMPLICIT REAL*8  (a-h,o-p,r-z)
+
+      COMMON / Scroll / iScroIst, iScroGra
+
+      IF (qioutside(iScroNew, 0, 25))
+     *    CALL Absturz ('SetScroll', 'iScroNew o.o.r.')
+
+      CALL ScrollArea (iScroNew,25)
+      IF (iScroNew.gt.0) THEN
+         CALL OverlayOn
+      ELSE
+         CALL OverlayOff
+         ENDIF
+
+      iScroIst = iScroNew
+
+      END ! SetScroll
+
+C  ====================================================================
+C  auxiliary / math for line drawing
+C  ====================================================================
+
+      SUBROUTINE SectBoxLin (xf1, xf2, yf1, yf2, xa, ya, xb, yb, 
+     *                       qIn1, qIn2, nSect, XS, YS)
+C     ----------------------------------------------------------
+            ! JWu 6mar91 in real coordinates, 20mar91 as TekFrameEdge
+            ! in graphic coordinates, 20feb92 again in real coordinates,
+            ! 30aug93 new as SectBoxLin
+         ! for use in GraPaint :
+         ! calculates the intersections (xs_,ys_) of the
+         ! line (xa,ya)-(xb,yb) with the box (xf_,yf_)
+
+      IMPLICIT LOGICAL (q) 
+      IMPLICIT REAL*8  (a-h,o-p,r-z)
+      DIMENSION         XS(4), YS(4) ! at least (3) : qSectLinLin writes
+                                     ! to XS even if there is no intersection
+
+      IF (xf1.ge.xf2 .or. yf1.ge.yf2) CALL Absturz (
+     *     'SectBoxLin', 'box ill defined')
+
+      qIn1 = qrinside(xa, xf1, xf2) .and. qrinside(ya, yf1, yf2)
+      qIn2 = qrinside(xb, xf1, xf2) .and. qrinside(yb, yf1, yf2)
+      nSect= 0 ! # intersections
+
+      IF (qIn1 .and. qIn2) RETURN ! points inside > ignore border case
+
+C  Check for intersections with all four lines limiting the box:
+      IF (qSectLinLin(xf1, yf1, xf1, yf2, xa, ya, xb, yb,
+     *                XS(nSect+1), YS(nSect+1))) nSect=nSect+1
+      ! the right order should be conserved :
+      ! if ya<yb, then look first at the lower boundary yf1, later at yf2
+      IF (ya.lt.yb) THEN 
+         IF (qSectLinLin(xf1, yf1, xf2, yf1, xa, ya, xb, yb,
+     *                   XS(nSect+1), YS(nSect+1))) nSect=nSect+1
+         IF (qSectLinLin(xf1, yf2, xf2, yf2, xa, ya, xb, yb,
+     *                   XS(nSect+1), YS(nSect+1))) nSect=nSect+1
+      ELSE 
+         IF (qSectLinLin(xf1, yf2, xf2, yf2, xa, ya, xb, yb,
+     *                   XS(nSect+1), YS(nSect+1))) nSect=nSect+1
+         IF (qSectLinLin(xf1, yf1, xf2, yf1, xa, ya, xb, yb,
+     *                   XS(nSect+1), YS(nSect+1))) nSect=nSect+1
+         ENDIF 
+      IF (qSectLinLin(xf2, yf1, xf2, yf2, xa, ya, xb, yb,
+     *                XS(nSect+1), YS(nSect+1))) nSect=nSect+1
+
+C  Security checks (to be replaced later by correct arithmetic error handling) :
+      IF (nSect.gt.2) CALL Absturz ('SectBoxLin', 'nSect>2')
+c      IF ((qIn1.ne.qIn2).and.(nSect.ne.1)) THEN  
+c    *     CALL Absturz ('SectBoxLin', 'nSect<>1')
+      IF (nSect.ge.7) THEN ! f"ur Fehlersuche - au"ser Betrieb
+         CALL GMode (0)
+         Print *, 'SectBoxLin/ qIn1, qIn2, nSect = ', qIn1, qIn2, nSect
+         Print *, ' xa ya = ', xa, ya
+         Print *, ' xb yb = ', xb, yb
+         DO i = 1, nSect
+            Print *, ' XS YS = ', XS(i), YS(i)
+            ENDDO
+         ENDIF 
+         
+      END ! SectBoxLin
+
+      LOGICAL FUNCTION qSectLinLin (xA1, yA1, xA2, yA2,
+     *                              xB1, yB1, xB2, yB2, xs, ys)
+C     ---------------------------------------------------------
+            ! JWu 31aug93
+         ! Is there an intersection (xs,ys) of two lines A, B ?
+         ! First application: (A) are the lines delimiting a Box.
+         ! A junction is not counted as an Intersection (21may94)
+
+      IMPLICIT LOGICAL (q) 
+      IMPLICIT REAL*8  (a-h,o-p,r-z)
+
+      IF     (xA1.eq.xA2) THEN  ! vertical case
+         xs = xA1 
+         IF (qrInOpen (xs, xB1, xB2)) THEN
+            CALL LinIntPol (xs, xB1, xB2, yB1, yB2, 0.d0, 0.d0, ys, dum)
+            qSectLinLin = qrInOpen (ys, yA1, yA2)
+         ELSE
+            qSectLinLin = .false.
+            ENDIF 
+      ELSEIF (yA1.eq.yA2) THEN  ! horizontal case
+         ys = yA1
+         IF (qrInOpen (ys, yB1, yB2)) THEN
+            CALL LinIntPol (ys, yB1, yB2, xB1, xB2, 0.d0, 0.d0, xs, dum)
+            qSectLinLin = qrInOpen (xs, xA1, xA2)
+         ELSE
+            qSectLinLin = .false.
+            ENDIF 
+      ELSE                      ! general case
+         CALL Absturz ('qSectLinLin', 'gen. case not yet implemented')
+         ENDIF
+
+      END ! qSectLinLin
+
+C  ====================================================================
+C  auxiliary / compose labels
+C  ====================================================================
+
+      SUBROUTINE GraLabel (j, label, var, unit)
+C     -----------------------------------------
+            ! refait pour la n-ieme fois le 11 mars 91 JWu
+         ! returns the label, composed of var and unit
+         ! according to the function chosen for axis j.
+
+      IMPLICIT LOGICAL (q)
+      IMPLICIT REAL*8 (a-h,o-p,r-z)
+
+      INCLUDE 'g_dim.f'
+      CHARACTER *(*) label, var, unit
+      CHARACTER *40  text2, hilf
+
+      COMMON / GraWdw / iGW, nGW
+      COMMON / GraCS  / iGFu(3,MGW), rGFu(3,MGW), Gmm(3,2,MGW)
+
+      IF (qioutside(j,1,3)) CALL Absturz ('GraLabel', 'axis o.o.r.')
+
+      hilf = var
+      IF (unit.ne.' ') CALL Compose4 (hilf, hilf, ' (', unit, ')')
+
+      CALL NiceNum (rGFu(j,iGW), text2, i2)
+      CALL FuTxt (iGFu(j,iGW), label, hilf, text2(1:i2))
+
+      END ! GraLabel
+
+C  ====================================================================
+C  g2.f / eof
+C  ====================================================================

arch/frida-1.4/g2.ps

+%!PS-Adobe-1.0
+
+gsave
+/WuGdict05a 400 dict def 
+WuGdict05a begin % << since 11sep95 >>
+
+%     This is the setup file for WuGra PostScript output
+%     This file must be copied to the beginning of 
+%     every PostScript file to be printed or previewed.
+    
+%     If it is already included, its end can be found by
+%     searching the word "e w u " (without blanks)
+
+%     Authors:
+%        H.P.Schildberg, BASF AG, ZAA/F, M320, Tel: 0621/6056556
+%        J.Wuttke, TU M"unchen, Physikdepartment E13, Tel: 089/32092449
+%
+%     Major modifications (from 95 onwards: date indicates closure of release):
+%        Aug05  (05a) FK asymmetric error bars for log plot
+%               (97a) deftot > defsca > defred
+%        Nov97  (95e) global err, lang.
+%        Dez95  (95d) minor improvements
+%        Jun95  (95c) minor improvements
+%        Mar95  (95b) colours
+%        Feb95  (95a) minor improvements
+%        Oct94  (94e) continuous upgrading 
+%        Jul94  (94d) axes improved, frame>Resets
+%        Jun94  (94c) blank boxes, other toys
+%        Mai94  (94b) towards movable axis 
+%        Feb94  (94a) minor improvements
+%        Dec93  (93g) programmable ticks
+%        Nov93  (93f) defsiz vs. defrel, better switchb.
+%        Oct93  (93e) sublinear scaling; wups separated
+%        Jul93  (93d) tacks and ticks for single axis
+%        Jun93  (93c) sublinear fontselection restored
+%        Jun93  (93b) /build ready for HP laser iv.
+%        Apr93  WuGdict93a. Ready to include into DVI files.
+%        Mar93  xN,yN now also with superscripts (for 10^3,..)
+%        Jun92  greek letters and sub/super-scripts
+%        Jan92  rescaling possible
+%        Dec91  more compact version
+%        Jun91  integrated into library WuGra
+%        Apr91  copied from ThMoeller
+
+%% shortwords :
+
+/np {newpath}   bind def
+/mv {moveto}    bind def
+/rm {rmoveto}   bind def
+/rl {rlineto}   bind def
+/li {lineto}    bind def
+/cp {closepath} bind def
+/st {stroke}    bind def
+/x  {exch}      bind def
+
+/L  {langSel}   bind def
+
+/g  {exch grec endgr} bind def
+/sb {exch subsc endsc} bind def
+/sp {exch supsc endsc} bind def
+/sbgr {exch grec  () subsc endsc () endgr} bind def
+/spgr {exch grec  () supsc endsc () endgr} bind def
+/u  {umlaut} bind def
+/U  {Umlaut} bind def
+
+%% constants :
+
+/pt {.018567 mul} bind def % pt ?? old relsize
+/cm {28.346456 mul} bind def
+/gyld {0.447214 mul} bind def /Gyld {0.447214 div} bind def % sqrt(5)
+/guld {0.547723 mul} bind def /Guld {0.547723 div} bind def % sqrt(3)
+/gold {0.618034 mul} bind def /Gold {0.618034 div} bind def % goldener Schnitt
+/gild {0.707107 mul} bind def /Gild {0.707107 div} bind def % sqrt(2) : DIN
+/geld {0.759836 mul} bind def /Geld {0.759836 div} bind def % sqrt(sqrt(3))
+/gald {0.817765 mul} bind def /Gald {0.817765 div} bind def % sqrt sqrt sqrt 5
+
+%% set total and relativ window :
+
+/deftot { % xtot ytot deftot - ; define total size, determine label size (ftot)
+   /ytot x def
+   /xtot x def
+   xtot dup mul ytot dup mul add sqrt % diagonal length
+   9 div 2 add % const+rel*d is simplest sublinear increase
+   9.5 mul /ftot x def
+   1 defsca % default
+   } def
+/defred { % xrel yrel frel defred - ; define xlen,ylen,xm,ym,fm
+   /fmm exch ftot mul fsca mul def /fm {fmm mul} def
+   fsca mul exch fsca mul exch defxym
+   } def
+/defsca { % fsca defsca - ; define a global scaling factor fsca
+   /fsca exch def 
+   mainscale % default
+   } def
+/mainscale { 1 1 1 defred } bind def
+/defxym { % xrel yrel defxym - ; define xlen,ylen, and the metric xm,ym :
+   /ylen x cm ytot mul def /xlen x cm xtot mul def
+   /xmm xlen 10 div def /ymm ylen 10 div def
+   /xm {xmm mul} def /ym {ymm mul} def                     % metric
+   /xym {ym x xm x} def
+   } def
+
+/cmtranslate { % x y cmtranslate - 
+   cm x cm x translate } bind def
+/EdgeDIN{ 20.3 28.3 cmtranslate } bind def
+/EdgeLeftDIN{ .6 28.3 cmtranslate } bind def
+/EdgeDINill{ 20.3 27.3 cmtranslate } bind def
+/EdgeAMI{ 18 26 cmtranslate } bind def % ????
+/offset { % x0 y0 offset -
+   ym x xm x translate } def
+/currentxy { currentpoint ymm div x xmm div x } def
+
+%% prepare font commands :
+
+/setfontandsize { % font size setfontandsize - ;
+                  % scale and set font; define fontsize, fontheight
+   dup 0 le { pop 100 } if % fontsize <= 0 not allowed ! 
+   /fontnonnil true def
+   pt fm dup /fontsize x def
+   x findfont
+   x scalefont
+   setfont
+   gsave % determine fontheight - from the cookbook :
+     np 0 0 mv (1) true charpath flattenpath
+     pathbbox  % low_left_x, low_left_y, up_right_x, up_right_y
+     x pop x pop x pop
+     /fontheight x def
+   grestore
+} def
+
+/SetNum { /Helvetica         24 setfontandsize } bind def
+/setlab { /Helvetica         24 setfontandsize } bind def
+/setown { /Helvetica          x setfontandsize } bind def % size setown -
+/setobl { /Helvetica-Oblique  x setfontandsize } bind def % size setown -
+
+%% language selection (27jul97) :
+
+/language {
+   /langMax exch def
+   /langChc exch def
+} def
+
+1 1 language % default
+
+/langSel { % T_1 .. T_M langSel T_C mit M=langMax, C=langC
+   langMax dup langChc sub 1 add roll
+   langMax 1 sub { pop } repeat
+} def
+   
+%% prepare drawing commands :
+
+/setline { pt fm setlinewidth [] 0 setdash } bind def
+
+%% coordinate system :
+
+%: new plot :
+/Resets{
+   /yNumLengthL 0 def /yNumLengthH 0 def
+   /xNumHeightL 0 def /xNumHeightH 0 def
+   /xNumHeightRel 2.4 def
+   black
+   } def
+/Finito {
+   showpage
+   end % pop dictionary from stack
+   } def
+/Basta { Finito } bind def % Basta may be overwritten, Finito not
+
+/ModFrame { % off1 off2 mod1 mod2 | - %% Voreinstellung fuer Frame-Rutsch
+   /modFrame2 exch def /modFrame1 exch def
+   /offFrame2 exch def /offFrame1 exch def
+} def
+/NewFrame {
+   offFrame1 offset
+   nFrame 1 add dup /nFrame exch def dup
+   modFrame1 mod 0 eq { modFrame1 { offFrame1 neg exch neg exch offset } repeat
+                        offFrame2 offset } if
+   modFrame2 modFrame1 mul mod 0 eq { showpage fullscale } if
+} def
+
+/nFrame 0 def
+/EndFrame { NewFrame } def
+
+%: Set tick array : internal commands (1dec93) :
+/tiputs { % rel_pos_of_tick tiputs pos_of_tick : innermost routine for /taproc
+   tastep mul taloop add 
+   } def 
+/taproclin { % (#tick/tack) taproclin - : define /taproc for use in vecset
+   1 x div /tistep x def
+   /taproc { 0 tistep .999 { tiputs } for } def
+   } def
+/taproclog { % (#ticks/tacks) taproclog - : define /taproc for use in vecset
+       dup 3 gt { pop /taproc { 1 1 9 { log tiputs } for } def 
+    }{ dup 1 gt { pop /taproc { 0 tiputs 2 log tiputs 5 log tiputs } def 
+    }{ dup 0 gt { pop /taproc { 0 tiputs } def 
+    }{            neg taproclin  
+    } ifelse } ifelse } ifelse
+} def
+/SetVec { % tafro tatoo nta /vector SetVec - : set /"vector"
+   4 1 roll 
+   /nta x def /tatoo x def /tafro x def
+   /tastep tatoo tafro sub nta 1 sub div def
+   [ 0 1 nta { 
+         tastep mul tafro add /taloop x def
+         taproc exec
+         } for
+      ] def
+   } def
+%: Set tick array : user commands :
+   % arguments are: first_tack_pos, last_tack_pos, #tacks, #ticks/tack
+/SetTicVecLin { taproclin /TicVec SetVec } def 
+/SetTicVecLog { taproclog /TicVec SetVec } def 
+
+%: Layout for ticks and axes :
+/xyTicLen {0.10 fm} def 
+/xyTacLen {0.20 fm} def 
+/SetAxx {0.7 setline} def
+/SetTic {0.7 setline} def
+/SetTac {0.7 setline} def
+{0.20 fm} dup /txllen x def /tyllen x def % oldstyle
+
+%: Draw ticks and axes. Usage: fro to pos aang tang OneAxx ( Tic | ) ( Axx | )
+     % Note on angles : 0 = x-axis, 90 = y-axis, values are 0..359.
+/OneAxx { % fro to xpos ypos aang tang OneAxx - : presets for Axx, Tic, Tac, Num
+   /tAng x def /aAng x def 
+   /yPos x def /xPos x def /aTo x def /aFro x def % save input
+   /xTicLen tAng cos xyTicLen mul def /yTicLen tAng sin xyTicLen mul def
+   /xTacLen tAng cos xyTacLen mul def /yTacLen tAng sin xyTacLen mul def
+   /xAng aAng cos def /yAng aAng sin def
+   } def
+/Axx { % - Axx - : draw axis (that's just a line) as predefined by OneAxx.
+   SetAxx np 
+   xPos yPos xym mv
+   aFro dup xAng mul x yAng mul xym rm
+   aTo aFro sub dup xAng mul x yAng mul xym rl st
+   } def
+/Tic { % - Tic - : draw ticks as predefined by OneAxx.
+   SetTic
+   TicVec { dup dup aFro lt x aTo gt or {pop} {TicProc} ifelse } forall
+   } def
+/TicProc { % aPos TicProc - : plot one tick.
+   np
+   xPos yPos xym mv 
+   dup xAng mul x yAng mul xym rm % eat argument, go to start pos.
+   xTicLen yTicLen rl st
+   } def
+
+%: Tacks and numbers on axis.
+/SetTacVec { % [ pos {label} pos {label} ... ] SetTacVec - : Preset TacVec
+   /TacVec x def
+   } def
+/TacExe { % Proc TacExe - % Execute Proc for all pairs of elements of TacVec
+                          % (but only if inside aFro..aTo)
+   /TacProc x def
+   /ispair true def % toggle: take pos, take label, take pos, take label ...
+   TacVec {
+      ispair { /aPos x def /ispair false def }
+      { aPos dup aFro lt x aTo gt or {pop} {TacProc} ifelse
+        /ispair true def} ifelse
+      } forall
+   } def
+%: General routines, governed by OneAxx :
+/Tac { %
+   SetTac
+   { pop xPos yPos xym mv 
+     aPos dup xAng mul x yAng mul xym rm
+     xTacLen yTacLen rl st } TacExe
+   } def
+/Num { % General but useless. Adjust for your apllication.
+   SetNum
+   fontheight ymm div yDisRel mul tAng sin mul /yDist x def
+   { dup textW xDisRel mul tAng cos mul /xDist x def
+     xPos aPos xAng mul add xDist sub 
+     yPos aPos yAng mul add yDist sub 3 2 roll textCM } TacExe
+   } def
+/SetNumDisRel { % xDisRel yDisRel SetNumDisRel - : adjust just a little bit
+   /yDisRel x def /xDisRel x def
+   } def
+1.2 1.2 SetNumDisRel % default setting
+
+%: Tacks and Numbers: explicit routines for rectangular case :
+/xTacL { % : tack on low x axis
+   SetTac
+   { pop aPos xm np yPos ym mv 0 txllen rl st } TacExe
+   } def
+/xTacH { % : tack on high x axis
+   SetTac
+   { pop aPos xm np yPos ym mv 0 txllen neg rl st } TacExe
+   } def
+/yTacL { % : tack on low y axis
+   SetTac
+   { pop aPos ym np xPos xm x mv tyllen 0 rl st } TacExe
+   } def
+/yTacH { % : tack on high y axis
+   SetTac
+   { pop aPos ym np xPos xm x mv tyllen neg 0 rl st } TacExe
+   } def
+/xNumL { % : numbers on low x axis 
+   SetNum
+   { fontheight ymm div % conversion -> user_scale
+     dup /xNumHeightL x def
+     -.6 mul aPos x 3 2 roll textCT } TacExe
+   } def
+/xNumH { % : numbers on high x axis 
+   SetNum
+   { fontheight ymm div % conversion -> user_scale
+     dup /xNumHeightH x def
+     .6 mul 10 add aPos x 3 2 roll textCB } TacExe
+   } def
+/yNumL { % : numbers on low y axis 
+   SetNum
+   { fontsize -.3 mul xmm div aPos 3 2 roll textRM
+     xwidth dup yNumLengthL gt {/yNumLengthL x def} {pop} ifelse
+     } TacExe
+   } def
+/yNumLD { % : calculate only yNumLength (used for adjustement)
+   SetNum
+   { textW dup yNumLengthL gt {/yNumLengthL x def} {pop} ifelse
+     } TacExe
+   } def
+/yDumL { % {(..)} yDumL : compare yNumLength with one arg (used for adjustement)
+   SetNum
+   textW dup yNumLengthL gt {/yNumLengthL x def} {pop} ifelse
+   } def
+/yNumH { % : numbers on high y axis 
+   SetNum
+   { fontsize .3 mul xmm div 10 add aPos 3 2 roll textLM
+     xwidth dup yNumLengthH gt {/yNumLengthH x def} {pop} ifelse
+     } TacExe
+   } def
+/yNumHD { % : calculate only yNumLength (used for adjustement)
+   SetNum
+   {textW dup yNumLengthH gt {/yNumLengthH x def} {pop} ifelse
+     } TacExe
+   } def
+/yDumH { % {(..)} yDumH : compare yNumLength with one arg (used for adjustement)
+   SetNum
+   textW dup yNumLengthH gt {/yNumLengthH x def} {pop} ifelse
+   } def
+
+%: Label on side of axes :
+/xCL { % xlabel xCL - ; plots coordinate name below the x-axis.
+   setlab
+   5. xNumHeightL xNumHeightRel neg mul
+   3 -1 roll textCT
+   } def
+/xCH { % xlabel xCH - ; plots coordinate name above the x-axis.
+   setlab
+   5. xNumHeightH xNumHeightRel mul 10 add
+   3 -1 roll textCB
+   } def
+/yCL { % ylabel yCL - ; plots coordinate name to the left of the y-axis.
+   gsave
+      setlab
+      yNumLengthL neg fontsize -.85 mul add % yNumLengthL calculated in yN
+      5. ym translate
+      0 0 mv
+      90 rotate
+      0 x 0 x textCB
+   grestore
+   } def
+/yCH { % ylabel yCH - ; plots coordinate name to the right of the y-axis.
+   gsave
+      setlab
+      yNumLengthH fontsize .85 mul add xlen add
+      5. ym translate
+      0 0 mv
+      90 rotate
+      0 x 0 x textCT
+   grestore
+   } def
+/yCF { % ylabel yCF - ; plots coordinate name *falling* right of the y-axis.
+   gsave
+      setlab
+      yNumLengthH fontsize .85 mul add xlen add
+      5. ym translate
+      0 0 mv
+      -90 rotate
+      0 x 0 x textCB
+   grestore
+   } def
+
+/AdjustEdge {
+   0  1   0  0     0  90 OneAxx Axx  % low x axis
+   9 10   0 10     0 270 OneAxx Axx  % top x axis
+   0  1   0  0    90   0 OneAxx Axx  % left y axis
+   9 10  10  0    90 180 OneAxx Axx  % right y axis
+} def
+
+%% string treatment :
+
+/showif { % string showif - ; increment xwidth or plot string
+   prepare
+      { stringwidth pop xwidth add /xwidth x def }
+      { show }
+   ifelse
+   } def
+/script { % matrix relpos_y script
+   /yoffset x fontheight mul def
+   currentfont x makefont setfont
+   0 yoffset rm
+   } def
+/scred .71 def
+/subsc {
+   showif
+   [scred 0 0 scred 0 0] -.2 script
+   } def
+/supsc {
+   showif
+   [scred 0 0 scred 0 0] .6 script
+   } def
+/endsc {
+   showif
+   regularfont setfont
+   0 yoffset neg rm
+   } def
+/grec {
+   showif
+   /Symbol findfont fontsize scalefont setfont
+   } def
+/endgr {
+   showif
+   regularfont setfont
+   } def
+/endall {
+   showif
+   regularfont setfont
+   } def
+/build { % string xrel yrel obj build - ; plot obj above/below string
+   /obj x def /yrelbui x def /xrelbui x def
+   dup showif
+   prepare
+      { pop }
+      { stringwidth pop xrelbui neg mul fontheight yrelbui mul % rel pos for obj
+        currentpoint 4 2 roll % save position after string
+	rm obj pop       % obj must end with () that will be pop'ed
+	mv               % back to saved position
+	}
+   ifelse
+   } def
+/gbuild { % string xrel yrel obj build - ; plot obj above/below string
+   /obj x def /yrelbui x def /xrelbui x def
+   /Symbol findfont fontsize scalefont setfont
+   dup showif 
+   prepare
+      { pop regularfont setfont }
+      { stringwidth pop xrelbui neg mul fontheight yrelbui mul % rel pos for obj
+        currentpoint 4 2 roll % save position after string
+        regularfont setfont 
+	rm obj pop       % obj must end with () that will be pop'ed
+	mv               % back to saved position
+	}
+   ifelse
+   } def
+/umlaut { % ..) (<char>) umlaut (..
+   x
+   showif
+   .79 0 {(\310) show ()} build
+   } def
+/Umlaut { % ..) (<Char>) Umlaut (..
+   x
+   showif
+   .79 .2 {(\310) show ()} build
+   } def
+/hut { % ..) (<Char>) hut (..            %%% MISERABEL PROGRAMMIERT
+   x
+   showif
+   1.4 .6 {(\136) show ()} build
+   } def
+/ghut { % ..) (<grec-Char>) hut (..      %%% BREITE PASST NUR FUER Phi(t)
+   x
+   showif
+   .8 .65 {(\136) show ()} gbuild
+   } def
+/spce { % string n spce - ; insert n times ( )
+   {showif (  )} repeat
+   } def
+/pins { % string symins - ; symbol must be selected by pset
+   showif 
+   ( ) showif ( ) .5 .5 { currentxy 0 p black ()} build ( ) showif
+   } def
+/clenins { % string len clenins - ; curve must be selected by cset
+   x showif % I suppose that pins is preceeded by 8 spaces
+   dup ( ) stringwidth pop mul 2 add /xstrich x xmm div def 
+            % length of inserted curve : 
+            % -1 space : curve begins and ends in  middle of ( )
+            % +3 spaces: pins requires 3 times ( )
+   ( ) 0 .5 { currentxy currentxy 0 ci x xstrich add x 0 cf () } build 
+   2 add {( ) showif} repeat
+   } def
+/cins { % string symins - ; curve must be selected by cset
+   showif 8 % I suppose that pins is preceeded by 8 spaces
+   dup ( ) stringwidth pop mul 2 add /xstrich x xmm div def 
+            % length of inserted curve : 
+            % -1 space : curve begins and ends in  middle of ( )
+            % +3 spaces: pins requires 3 times ( )
+   ( ) 0 .5 { currentxy currentxy 0 ci x xstrich add x 0 cf () } build 
+   2 add {( ) showif} repeat
+   } def
+/block { % x y ob xrel yrel block -
+   /yrel x def /xrel x def /blabla x def
+    /ypos x ym def /xpos x xm def
+   /regularfont currentfont def /yoffset 0 def % initialize for security
+   /prepare true def /xwidth 0 def 0 0 mv % to prevent empty-path-error
+    blabla endall % first pass : determine xwidth
+   boxif { /boxwidth  xwidth (M) stringwidth pop boxxr mul 2 mul add def
+           /boxheight fontheight 1 boxyr 2 mul add mul def
+           np xpos xwidth xrel mul sub boxwidth xwidth sub 2 div sub 
+           ypos fontheight .5 boxyr add mul sub mv 
+           boxwidth 0 rl 0 boxheight rl boxwidth neg 0 rl cp
+           boxproc 
+    } if
+    xpos xwidth xrel mul sub ypos fontheight yrel mul sub mv
+    /prepare false def
+    blabla endall % second pass : plot
+   /boxif false def
+   } def
+/rblock { % x y ang ob proc rblock -
+   5 3 roll
+   gsave
+      xym translate
+      3 2 roll rotate
+      0 0 4 2 roll exec
+   grestore
+   } def
+/Box { % x y {exe}
+   /boxif true def
+   /boxproc x def /boxyr x def /boxxr x def
+   } def
+/nBox { .6 .6 3 2 roll Box } def
+/boxif false def
+/textW { % obj textW y : calculate only length.
+   /blabla x def
+   /regularfont currentfont def /yoffset 0 def % initialize for security
+   /prepare true def /xwidth 0 def 0 0 mv % to prevent empty-path-error
+   blabla endall
+   xwidth % has been determined
+   } def
+/textw { % obj textW y : dito, in 0..10-units
+   textW xmm div 
+   } def
+
+%% text % x y ob textXY - 2 = left/cent/right Y = top/midl/bot
+/textLB { 0. 0. block } bind def
+/textCB { .5 0. block } bind def
+/textRB { 1. 0. block } bind def
+/textLM { 0. .5 block } bind def
+/textCM { .5 .5 block } bind def
+/textRM { 1. .5 block } bind def
+/textLT { 0. 1. block } bind def
+/textCT { .5 1. block } bind def
+/textRT { 1. 1. block } bind def
+
+%% rtext %  x y ang ob rtextXY
+/rtextLB { {textLB} rblock } bind def
+/rtextCM { {textCM} rblock } bind def
+
+%% OBSOLET :
+/rotLB { % txt ang x y rotLB % schraeger Eintrag : 2mar93
+   gsave
+      ym x xm x translate
+      rotate
+      0 x 0 x textLB
+   grestore
+   } bind def
+/rotCM { % txt ang x y rotCM - : rotated, centered
+   gsave
+      xym translate rotate % note : ang is not transformed with xm ym
+      0 0 3 2 roll textCM
+   grestore
+   } bind def
+
+%% list (info lines, may also contain symbols) :
+
+/NewList { % xins yins size advance NewList -
+   /advance x def setown /yins x def /xins x def
+   /xshift fontsize xmm div .9 mul def
+   /newline {
+      /yins yins fontheight ymm div advance mul sub def
+      } def
+   } def
+/newlist { 1.65 NewList } def 
+/TxLine { % text TxLine -
+   xins yins 3 -1 roll textLM newline
+   } bind def
+/TxCLine { % text TxLine -
+   xins yins 3 -1 roll textCM newline
+   } bind def
+/infline{ % text infline - : plot info-line, but only if switch oooinfo=1
+   oooinfo 1 eq { TxLine } { pop } ifelse
+   } bind def
+/symline { % styp sfill serr srad lwidth text symline - % OBSOLET
+   6 1 roll
+   pset xins yins 0 p
+   xins xshift add yins 3 2 roll textLM
+   newline
+   } bind def
+/PtTxLine { % pstyle text symline -
+   x pstyle xins yins yins p 
+   black xins xshift add yins 3 2 roll textLM
+   newline
+   } bind def
+/CvTxLine { % cstyle text symline -
+   x cstyle black 
+   xins xshift -.33 mul add yins 0 ti xins xshift 0.33 mul add yins 0 tf
+   xins xshift add yins 3 2 roll textLM
+   newline
+   } bind def
+/PtPtCvTxLine { % pstyle pstyle cstyle text symline -
+   4 3 roll pstyle xins yins 0 p 
+   3 2 roll pstyle xins xshift add yins 0 p 
+   exch cstyle black 
+   xins xshift 2 mul add 
+   dup dup xshift -.33 mul add yins 0 ti xshift 0.33 mul add yins 0 tf
+   xshift add yins 3 2 roll textLM
+   newline
+   } bind def
+/PtCvTxLine { % pstyle cstyle text symline -
+   3 2 roll pstyle xins yins 0 p 
+   exch cstyle black 
+   xins xshift 1 mul add 
+   dup dup xshift -.33 mul add yins 0 ti xshift 0.33 mul add yins 0 tf
+   xshift add yins 3 2 roll textLM
+   newline
+   } bind def
+/PtPtTxLine { % pstyle pstyle text symline -
+   3 2 roll pstyle xins yins 0 p 
+   x pstyle xins xshift add yins 0 p 
+   black xins xshift 2 mul add yins 3 2 roll textLM
+   newline
+   } bind def
+/CvTxLine { % cstyle text symline -
+   x cstyle 
+   xins fontsize xmm div -.4 mul add yins 0 ti 
+   xins fontsize xmm div  .4 mul add yins 0 tf  
+   black xins xshift add yins 3 2 roll textLM
+   newline
+   } bind def
+/CvCvTxLine { % cstyle cstyle text symline -
+   x cstyle 
+   xins xshift add fontsize xmm div -.3 mul add yins 0 ti 
+   xins xshift add fontsize xmm div  .3 mul add yins 0 tf
+   x cstyle 
+   xins fontsize xmm div -.3 mul add yins 0 ti 
+   xins fontsize xmm div  .3 mul add yins 0 tf   
+   black xins xshift 2 mul add yins 3 2 roll textLM
+   newline
+   } bind def
+/TxSyTxLine { % text1 styp sfill serr srad lwidth text2 symline - % OBSOLET
+   6 1 roll 7 6 roll % stack -> text2 styp .. lwidth text1 
+   dup xins yins 3 -1 roll textLM textw xins add xshift add /xinsa x def
+   pset xinsa yins 0 p
+   xinsa xshift add yins 3 2 roll textLM
+   newline
+   } bind def
+/showfilename { % xins yins size showfilename -
+   setown
+   ooofnam 1 eq fullpage and { filename textRB } { pop pop } ifelse
+   } def
+/InfSet { % ooofnam oooinfo InfSet - : set on(1) or off(0)
+   /oooinfo x def /ooofnam x def
+   } def
+   /oooset { InfSet } def % obsolete
+0 0 InfSet % default setting
+
+%% gray areas (mainly applied with grayval=1 for blank areas) [longtime grey..]
+/graybox { % grayval x_L y_B dx dy graybox - 
+   4 2 roll
+   np ym x xm x mv % corner Left Bottom
+   ym dup 0 x rl   % line up
+   x xm 0 rl         % line right
+   neg 0 x rl      % line down
+   cp gsave setgray fill grestore 
+   } def
+
+%% plot symbols and error bars :
+
+/SymGSet { % slinglo sradglo serrglo - : global preset
+   /serrglo x def /sradglo x def /slinglo x def 
+   } def
+
+/SymGlo { 0 SymGSet } def % OBSOLET
+
+/nopoints { % : instead of pset or cset, make t* plot nothing
+   {pop pop pop} dup dup dup dup dup dup 
+   /ti x def /t x def /tf x def /ci x def /c x def /cf x def /p x def
+   } def
+
+/pset { % styp sfill serr srad sline pset - ;
+        % defines the corresponding variables for use in p.
+   dup /sline x fm 0.8 mul pt slinglo mul def setline
+   /srad x fm 0.08 mul sradglo mul def
+   2 serrglo ne { pop serrglo } if % if (serrglo=2) use serr else use serrglo
+   1 eq serrglo 3 eq or { serrglo 1 eq {/pserr % x y d- d+ error  :  vertical error bars
+            {
+	     3 copy pop pop
+	     dup 0 gt x 10 lt and {
+             np
+             4 copy
+             x pop add 10. 2 copy gt { x } if pop ym x xm x mv
+             pop   sub 0.  2 copy lt { x } if pop ym x xm x lineto
+             st
+	     } { pop pop pop pop } ifelse
+             } def}
+            {/pserr % x y d- d+ error : vertical error bars assym
+              {
+	     3 copy pop pop
+	     dup 0 gt x 10 lt and {
+             np
+             4 copy
+             x pop x pop 10. 2 copy gt { x } if pop ym x xm x mv
+             pop  pop  0.  2 copy lt { x } if pop ym x xm x lineto
+             st
+	     } { pop pop pop pop } ifelse
+             }  def} ifelse }
+         {/pserr
+            {pop pop pop pop} def} ifelse
+   /sfill x def
+   /ps {pop pop}  def  % default : don't plot
+   dup  1 eq {/ps {square}     def} if
+   dup  2 eq {/ps {diamond}    def} if
+   dup  3 eq {/ps {circle}     def} if
+   dup  4 eq {/ps {triangle}   def} if
+   dup  5 eq {/ps {cedez}      def} if
+   dup  6 eq {/ps {eieruhr}    def} if
+   dup  7 eq {/ps {valve}      def} if
+   dup  8 eq {/ps {tfwd}       def} if
+   dup  9 eq {/ps {tbwd}       def} if
+   dup 11 eq {/ps {plus}       def} if
+   dup 12 eq {/ps {cross}      def} if
+   dup 13 eq {/ps {2 copy cross plus} def} if      % gives a "*"
+   dup 14 eq {/ps {column}     def} if
+   pop
+   sfill 0 eq {/srad srad sline 2 div sub def} if
+   /ti {p} def /t {p} def /tf {p} def % newstyle -> oldstyle
+   % the following can be overwritten by nopoints :
+   /p { % x y d p  :  plots a symbol and eventually an error bar.
+      3 copy pop ps dup pserr
+      } def
+   } def
+
+/pp { % x y d- d+ pp  : dito with asymmetric error bar.
+   4 copy pop pop ps pserr
+   } def
+
+%% plot curves :
+
+/lset { % lwidth dashes lset - :  prepares everything for ti t t ... t tf.
+   0 setdash
+   dup 0 gt {
+      pt fm setlinewidth
+      /ti {ci} def /t {c} def /tf {cf} def % newstyle -> oldstyle
+      % the following can be overwritten by nopoints :
+      /ci { % x y d ci  :  first point of curve
+   	 pop np ym x xm x mv
+   	 } def
+      /c {  % x y d c   :  point of curve
+   	 pop ym x xm x lineto
+   	 } def
+      /cf { % x y d c   :  last point of curve
+   	 c st 
+         } def
+   } { nopoints } ifelse
+   } def
+/cset { % lwidth #dash cset - :   old version of lset: some predefined dashes.
+   dup 0 eq { pop pop nopoints } {
+      dup 1 eq { [          ] lset } if
+      dup 2 eq { [1 3       ] lset } if
+      dup 3 eq { [8 6       ] lset } if
+      dup 4 eq { [8 3 1 3   ] lset } if
+      dup 5 eq { [2 2       ] lset } if
+      dup 6 eq { [1.8       ] lset } if
+      dup 7 eq { [3 1.8     ] lset } if
+      dup 8 eq { [2 2 3.5 2 ] lset } if
+      dup 9 eq { [2 2 5.5 2 ] lset } if
+      pop
+      } ifelse
+   } def
+
+%% from style arrays:
+
+/pstyle { pStyles setstyle } def
+/cstyle { cStyles setstyle } def
+/setstyle { % #style array setstyle - : set p or c as predefined in array.
+   dup length % i A n
+   3 2 roll % A n i
+   dup 0 le {pop pop pop nopoints} { % #style<=0 means : don't plot
+   1 sub x % A i-1 n
+   mod get % A(i-1)
+   exec } ifelse
+   } def
+% preset, for security :
+/pStyles [ { 1 0 0 1 1.0 pset } ] def
+
+%% data symbols : x y ps
+
+/square { /D srad 0.707 mul def
+	  np ym x xm x mv
+          D D rm
+	  0 D -2 mul rl
+	  D -2 mul 0 rl
+	  0 D 2 mul  rl
+	  cp 
+	  sfill 0 eq {st} {fill} ifelse
+        } def
+
+/diamond {/D srad def
+          np ym x xm x mv
+          0 D rm
+	  D D -1 mul rl
+	  D -1 mul D -1 mul rl
+	  D -1 mul D rl
+	  cp
+	  sfill 0 eq {st} {fill} ifelse
+        } def
+
+/cross {  /D srad 0.707 mul def
+	  np ym x xm x 2 copy mv
+          D dup rm
+	  D -2 mul dup rl st
+	  np mv
+          D dup -1 mul rm
+          D -2 mul D 2 mul rl st
+        } def
+
+/plus {   /D srad def
+          np ym x xm x 2 copy mv
+          D 0 rm
+	  D -2 mul 0 rl st         % horizontal lineelement
+          np mv
+     	  0 D rm
+	  0 D -2 mul rl st         % vertical lineelement
+        } def
+
+/triangle{/D srad 1.14 mul def
+          np ym x xm x mv
+          0 D rm                       %  + (0,1)      = (0,1)
+	  D 0.886 mul D -1.5 mul rl    %  + (.88,-1.5) = (.88,-.5)
+	  D -1.772 mul 0 rl            %  + (-1.7,0)   = (-.88,-.5)
+	  cp
+	  sfill 0 eq {st} {fill} ifelse
+        } def
+
+/cedez {  /D srad 1.14 mul def
+          np ym x xm x mv
+          0 D -1 mul rm              %  + (0,-1)    = (0,-1)
+	  D 0.886 mul D 1.5 mul rl   %  + (.88,1.5) = (.88,.5)
+          D -1.772 mul 0 rl          %  + (-1.7,0)  = (-.88,.5)
+	  cp
+	  sfill 0 eq {st} {fill} ifelse
+        } def
+
+/tfwd  {/D srad 1.14 mul def % triangle looking forward
+          np ym x xm x mv
+          D 0 rm                   
+	  D -1.5 mul D 0.886 mul rl
+	  0 D -1.772 mul rl        
+	  cp
+	  sfill 0 eq {st} {fill} ifelse
+        } def
+
+/tbwd  {/D srad 1.14 mul def % triangle looking backward
+          np ym x xm x mv
+          D neg 0 rm              
+	  D 1.5 mul D 0.886 mul rl
+	  0 D -1.772 mul rl       
+	  cp
+	  sfill 0 eq {st} {fill} ifelse
+        } def
+
+/circle { /D srad 0.86 mul def
+          np ym x xm x D 0 360 arc
+	  sfill 0 eq {st} {fill} ifelse
+        } def
+
+/eieruhr {/D srad 0.86 mul def
+	  np ym x xm x mv
+          D D rl                 % + ( 1, 1)   = ( 1, 1)
+	  D -2 mul 0 rl          % + (-2, 0)   = (-1, 1)
+	  D 2 mul D -2 mul rl    % + ( 2,-2)   = ( 1,-1)
+	  D -2 mul 0 rl          % + (-2, 0)   = (-1, 1)
+ 	  cp
+	  sfill 0 eq {st} {fill} ifelse
+        } def
+
+/valve {  /D srad 0.86 mul def
+	  np ym x xm x mv
+          D D rl                 % + ( 1, 1)   = ( 1, 1)
+	  0 D -2 mul rl          % + ( 0,-2)   = ( 1,-1)
+	  D -2 mul D 2 mul rl    % + (-2, 2)   = (-1, 1)
+	  0 D -2 mul rl          % + ( 0, 2)   = (-1,-1)
+ 	  cp
+	  sfill 0 eq {st} {fill} ifelse
+        } def
+
+/column { np ym x xm x 2 copy mv
+          pop 0 li st
+        } def
+
+%% colours
+
+% for symbols :
+/pColSet { % col ncol ColSet - : global preset
+   /npcol x def % # different colours
+   /pcol  x def % colours off/on
+   } def
+0 3 pColSet % default setting
+/ifpcol { % proc1 proc2 ifcol - : shorthand for: col 0 eq proc1 proc2 ifelse
+   pcol 0 eq { pop exec } { exec pop} ifelse % 3 1 roll ifelse
+   } def
+% for curves :
+/cColSet { % col ncol ColSet - : global preset
+   /nccol x def % # different colours
+   /ccol  x def % colours off/on
+   } def
+0 3 cColSet % default setting
+/ifccol { % proc1 proc2 ifcol - : shorthand for: col 0 eq proc1 proc2 ifelse
+   ccol 0 eq { pop exec } { exec pop} ifelse % 3 1 roll ifelse
+   } def
+/black { 0 0 0 setrgbcolor } bind def
+/white { 1 1 1 setrgbcolor } bind def
+
+% one-dimensional colour choice :
+/iCol { % n_this n_tot iCol - : starting with red, round the circle
+   1 add x 1 sub x div dup truncate sub dup 1 
+    x 360 mul 255 add cos 1 add dup mul neg .053 mul 1 add sethsbcolor
+   } def
+/ipCol { npcol iCol } def
+/icCol { nccol iCol } def
+
+%% special objects
+
+/arrowx { % Horizontal arrow. Arguments : x_tete y_tete x_length tete_size lrad.
+   setline /atete x fm def /axlen x xm def 
+   /atetx atete 3 sqrt mul axlen 0 lt {neg} if def
+   /atety atete def
+   np ym x xm x 2 copy 2 copy mv 
+   atetx atety     rl st
+   np mv
+   atetx atety neg rl st
+   np mv
+   axlen 0 rl st } def  
+
+/Arrowx { % Horizontal arrow with filled tete. 
+          % Arguments : x_tete y_tete x_length tete_einbucht tete_size lrad.
+   setline /atete x fm def /reinb x def /axlen x xm def 
+   /atetx atete 3 sqrt mul axlen 0 lt {neg} if def
+   /atety atete def
+   np ym x xm x 2 copy mv 
+   atetx atety     rl
+   atetx reinb mul neg atety neg rl 
+   atetx reinb mul     atety neg rl fill
+   np mv
+   axlen 0 rl st } def  
+
+/arrowy { % Vertical arrow. Arguments : x_tete y_tete y_length tete_size lrad.
+   setline /atete x fm def /aylen x ym def 
+   /atety atete 3 sqrt mul aylen 0 lt {neg} if def
+   /atetx atete def
+   np ym x xm x 2 copy 2 copy mv 
+   atetx     atety rl st
+   np mv
+   atetx neg atety rl st
+   np mv
+   0 aylen rl st } def  
+
+/knautschy { % x0 y0 y_knau y_tot knautschy - : insert an S in dived y-axis 
+   % the total height of the generated object is y_tot
+   % of which y_knau(.le. y_tot) is for the real knautsch,
+   % the remainder is for vertical prolongations.
+   x ym 4 div dup /tmpy x def 5 sqrt mul /tmpx x def 
+   /tmpa x ym tmpy 4 mul sub 2 div def
+   np ym x xm x mv 0 tmpa rl tmpx tmpy rl tmpx -2 mul tmpy 2 mul rl 
+   tmpx tmpy rl 0 tmpa rl st
+   } def
+/separy { % x0 y0 sep lng ang lin - : insert an // in dived y-axis 
+   setline
+   /spang x def 
+   /splng x def
+   /spsep x def
+   2 copy spsep sub gsave offset spang rotate 
+      splng -.5 mul fm 0 np mv splng fm 0 rl st grestore
+   spsep add gsave offset spang rotate 
+      splng -.5 mul fm 0 np mv splng fm 0 rl st grestore
+} def
+
+%% text macros for insertion,..
+
+/abc {abclab setown abcx abcy 3 2 roll textCM} def % usage ((a)) abc
+/abcset { % x y siz abcset - : preset for abc
+   /abclab x def /abcy x def /abcx x def } def
+
+%% text macros for neutron scattering :%
+
+/hbar {
+   showif
+   (h) 1.2 .66 {
+      currentpoint fontheight .11 mul setline np mv
+      fontheight dup .8 mul x .3 mul rl
+      st ()
+      } build
+   } bind def
+/hbarw { hbar () grec (w) endgr } bind def
+/wbar { grec (w) endgr ( / 2) grec (p) endgr } bind def
+/Sqw { showif (S \(q,) grec (w) endgr (\)) showif } bind def
+/SQw { showif (S \(Q,) grec (w) endgr (\)) showif } bind def
+/Sttw { showif (S \(2) grec (q) endgr (,) grec (w) endgr (\)) showif } bind def
+/Xw { grec (c) endgr (''\(q,) grec (w) endgr (\)) showif } bind def
+/Xqw { grec (c) endgr (''\(q,) grec (w) endgr (\)) showif } bind def
+/ueV{ grec (m) endgr (eV) showif} bind def
+/inueV { showif (\() grec (m) endgr (eV\)) showif } bind def
+/inmeVr { showif (\(meV) supsc (-1) endsc (\)) showif } bind def
+/inueVr { showif (\() grec (m) endgr (eV) 
+          supsc (-1) endsc (\)) showif } bind def
+/inGHzr { showif (\(GHz) (-1) sp (\)) showif } def
+
+/Angstr {
+   showif
+   (A) .5 1.23 {
+      currentpoint fontheight .1 mul setline np
+      fontheight .14 mul 0 360 arc st ()
+      } build } bind def
+/Angr { Angstr () supsc (-1) endsc } bind def
+/inAngr { showif (\() Angr (\)) showif } bind def
+/Angrr { Angstr () supsc (-2) endsc } bind def
+/inAngrr { showif (\() Angr (\)) showif } bind def
+/wmin {grec (w) endgr () subsc (min) endsc} def
+/winpi { grec (w) endgr ( / 2) grec (p) endgr } def
+
+
+end % pop WuGdict 
+
+/startTexFig{/psf$SavedState save N userdict
+maxlength 1000 add dict begin /magscale true def normalscale currentpoint TR
+/psf$ury psfts /psf$urx psfts /psf$lly psfts /psf$llx psfts /psf$y psfts
+/psf$x psfts currentpoint /psf$cy X /psf$cx X /psf$sx psf$x psf$urx
+psf$llx sub div N /psf$sy psf$y psf$ury psf$lly sub div N psf$sx psf$sy
+scale psf$cx psf$sx div psf$llx sub psf$cy psf$sy div psf$ury sub TR
+/showpage{}N /erasepage{}N /copypage{}N /p 3 def @MacSetUp} def
+
+%% external switches :
+/fullpage true def % this is *not* in dictionary; superseded by winc.ps
+
+% This is "ewu", the very end of the wups* setup file.
+WuGdict05a begin %% the following lines are produced by g3.ps
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%                                                                           %%
+%%                            Switchboard                                    %%
+%%                                                                           %%
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+7.8 dup gald deftot 
+/fullscale { EdgeLeftDIN   3 -10 offset 1 defsca } def
+/inclscale {             -10 -10 offset 1 defsca } def
+
+fullpage { fullscale } { inclscale } ifelse 
+
+0 -2 offset % positive offset moves it right and up.
+1 1 1 defred
+
+1 1 language
+1 1 InfSet % plot fnam, info
+1 dup 2 SymGSet % slin srad serr(2=from pset) : graph symbols, global preset
+
+% x y 24 abcset
+/EndFrame { Basta } def % comment this line out to use frame advancing
+{ 0 -18 } { 16 0 } 6 3 ModFrame
+
+0 100 pColSet % arg1: color on/off; arg2: max no. of colours
+/pStyles [
+{ {  1 1 0 1. 1. pset } { 1 1 0 1. 1. pset 10 ipCol} ifpcol } %  1
+{ {  1 0 0 1. 1. pset } { 1 1 0 1. 1. pset 20 ipCol} ifpcol } %  2
+{ {  2 1 0 1. 1. pset } { 1 1 0 1. 1. pset 30 ipCol} ifpcol } %  3
+{ {  2 0 0 1. 1. pset } { 1 1 0 1. 1. pset 40 ipCol} ifpcol } %  4
+{ {  3 1 0 1. 1. pset } { 1 1 0 1. 1. pset 50 ipCol} ifpcol } %  5
+{ {  3 0 0 1. 1. pset } { 1 1 0 1. 1. pset 60 ipCol} ifpcol } %  6
+{ {  4 1 0 1. 1. pset } { 1 1 0 1. 1. pset 70 ipCol} ifpcol } %  7
+{ {  4 0 0 1. 1. pset } { 1 1 0 1. 1. pset 80 ipCol} ifpcol } %  8
+{ {  5 1 0 1. 1. pset } { 1 1 0 1. 1. pset 90 ipCol} ifpcol } %  9
+{ {  5 0 0 1. 1. pset } { 1 1 0 1. 1. pset 90 ipCol} ifpcol } %  0
+] def
+
+0 100 cColSet % arg1: color on/off; arg2: max no. of colours
+/cStyles [
+{ { 1. [          ] lset } { 1. [] lset 10 icCol} ifccol } % 1
+{ { 1. [1 3       ] lset } { 1. [] lset 20 icCol} ifccol } % 2 
+{ { 1. [8 6       ] lset } { 1. [] lset 30 icCol} ifccol } % 3
+{ { 1. [8 3 1 3   ] lset } { 1. [] lset 40 icCol} ifccol } % 4
+{ { 1. [2 2       ] lset } { 1. [] lset 50 icCol} ifccol } % 5
+{ { 1. [1.8       ] lset } { 1. [] lset 60 icCol} ifccol } % 6
+{ { 1. [3 1.8     ] lset } { 1. [] lset 70 icCol} ifccol } % 7
+{ { 1. [2 2 3.5 2 ] lset } { 1. [] lset 80 icCol} ifccol } % 8
+{ { 1. [2 2 5.5 2 ] lset } { 1. [] lset 90 icCol} ifccol } % 9
+] def
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%                                                                           %%
+%%                   now the output produced by WuGra                        %%
+%%                                                                           %%
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

pub/share/g3.ps → arch/frida-1.4/g3.ps

-WuGdict07a begin %% the following lines are produced by g3.ps
+WuGdict05a begin %% the following lines are produced by g3.ps
 
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 %%                                                                           %%
@@ -6,38 +6,35 @@ WuGdict07a begin %% the following lines are produced by g3.ps
 %%                                                                           %%
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
-EdgeLeftDIN   
-10 dup autolabel defsiz
-1 dup dup geld 3 2 roll defred
-2.  -11 offset
+7.8 dup gald deftot 
+/fullscale { EdgeLeftDIN   3 -10 offset 1 defsca } def
+/inclscale {             -10 -10 offset 1 defsca } def
+
+fullpage { fullscale } { inclscale } ifelse 
+
+0 -2 offset % positive offset moves it right and up.
+1 1 1 defred
 
 1 1 language
-0 0 InfSet % plot fnam, info
+1 1 InfSet % plot fnam, info
 1 dup 2 SymGSet % slin srad serr(2=from pset) : graph symbols, global preset
-0 setschool
-
-/EndFrame { plotafter Basta } def
-% /setboxbackgroundcolor { 0.93 setgray } def
 
 % x y 24 abcset
-% /next{ 12 0 offset } def /nextPoints{ next } def /nextCurve{ next } def
-% 100 DDsetresolution
+/EndFrame { Basta } def % comment this line out to use frame advancing
+{ 0 -18 } { 16 0 } 6 3 ModFrame
 
-1 100 pColSet % arg1: color on/off; arg2: max no. of colours
+0 100 pColSet % arg1: color on/off; arg2: max no. of colours
 /pStyles [
-{ {  1 1 0 1. 1. pset } { 1 1 0 1. 1. pset  0 ipCol} ifpcol } %  1
-{ {  1 0 0 1. 1. pset } { 1 1 0 1. 1. pset 70 ipCol} ifpcol } %  2
+{ {  1 1 0 1. 1. pset } { 1 1 0 1. 1. pset 10 ipCol} ifpcol } %  1
+{ {  1 0 0 1. 1. pset } { 1 1 0 1. 1. pset 20 ipCol} ifpcol } %  2
 { {  2 1 0 1. 1. pset } { 1 1 0 1. 1. pset 30 ipCol} ifpcol } %  3
-{ {  2 0 0 1. 1. pset } { 1 1 0 1. 1. pset 80 ipCol} ifpcol } %  4
+{ {  2 0 0 1. 1. pset } { 1 1 0 1. 1. pset 40 ipCol} ifpcol } %  4
 { {  3 1 0 1. 1. pset } { 1 1 0 1. 1. pset 50 ipCol} ifpcol } %  5
-{ {  3 0 0 1. 1. pset } { 1 1 0 1. 1. pset 15 ipCol} ifpcol } %  6
+{ {  3 0 0 1. 1. pset } { 1 1 0 1. 1. pset 60 ipCol} ifpcol } %  6
 { {  4 1 0 1. 1. pset } { 1 1 0 1. 1. pset 70 ipCol} ifpcol } %  7
-{ {  4 0 0 1. 1. pset } { 1 1 0 1. 1. pset siemensred    } ifpcol } %  8
-{ {  4 0 0 1. 1. pset } { 1 1 0 1. 1. pset siemensblue   } ifpcol } %  8
-{ {  4 0 0 1. 1. pset } { 1 1 0 1. 1. pset siemensgreen  } ifpcol } %  8
-{ {  4 0 0 1. 1. pset } { 1 1 0 1. 1. pset siemensorange } ifpcol } %  8
-{ {  5 1 0 1. 1. pset } { 1 1 0 1. 1. pset siemensdark   } ifpcol } %  9
-{ {  5 0 0 1. 1. pset } { 1 1 0 1. 1. pset siemenspink   } ifpcol } %  0
+{ {  4 0 0 1. 1. pset } { 1 1 0 1. 1. pset 80 ipCol} ifpcol } %  8
+{ {  5 1 0 1. 1. pset } { 1 1 0 1. 1. pset 90 ipCol} ifpcol } %  9
+{ {  5 0 0 1. 1. pset } { 1 1 0 1. 1. pset 90 ipCol} ifpcol } %  0
 ] def
 
 0 100 cColSet % arg1: color on/off; arg2: max no. of colours
@@ -46,11 +43,13 @@ EdgeLeftDIN
 { { 1. [1 3       ] lset } { 1. [] lset 20 icCol} ifccol } % 2 
 { { 1. [8 6       ] lset } { 1. [] lset 30 icCol} ifccol } % 3
 { { 1. [8 3 1 3   ] lset } { 1. [] lset 40 icCol} ifccol } % 4
+{ { 1. [2 2       ] lset } { 1. [] lset 50 icCol} ifccol } % 5
+{ { 1. [1.8       ] lset } { 1. [] lset 60 icCol} ifccol } % 6
+{ { 1. [3 1.8     ] lset } { 1. [] lset 70 icCol} ifccol } % 7
+{ { 1. [2 2 3.5 2 ] lset } { 1. [] lset 80 icCol} ifccol } % 8
+{ { 1. [2 2 5.5 2 ] lset } { 1. [] lset 90 icCol} ifccol } % 9
 ] def
 
-Resets
-BoxBackground
-
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 %%                                                                           %%
 %%                   now the output produced by WuGra                        %%

old/gcode/wups-coltest.ps → arch/frida-1.4/g4.ps

-WuGdict97a begin %% the following lines are produced by g3.ps
-
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 %%                                                                           %%
 %%                            Switchboard                                    %%
 %%                                                                           %%
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
-16 dup deftot
-fullpage {EdgeLeftDIN 1.3 -12 1} {-10 -10 1} ifelse defsca offset
-
-0 0 offset % positive offset moves it right and up.
-
-1 1 language
-1 0 InfSet % plot fnam, info
-1 dup 2 SymGSet % slin srad serr(2=from pset) : graph symbols, global preset
-
-/next { dx dy offset } bind def
-
-1 100 pColSet % arg1: color on/off; arg2: max no. of colours
-
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 %%                                                                           %%
 %%                   now the output produced by WuGra                        %%
 %%                                                                           %%
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-/filename (wups-coltest) def
-
- 10 -3 18 showfilename
-
-%: Coordinate system : 
-
-%  Lin x-axis from  0.0000000E+00   38.00000    
-%  Lin y-axis from  0.0000000E+00   360.0000    
-
-Resets
-
-0 10   0  0     0  90 OneAxx Axx % Tic xTacL xNumL % low x axis
-0 10   0 10     0 270 OneAxx Axx % Tic xTacH       % top x axis
-
-0 10   0  0    90   0 OneAxx Axx % Tic yTacL yNumL % left y axis
-0 10  10  0    90 180 OneAxx Axx % Tic yTacH       % right y axis
-
-3 1 0 1.67 1. pset
-0 1 99 { 
-  dup ipCol 
-  100 div 360 mul dup cos 3.3 mul 5 add x sin 3.3 mul 5 add 0 t
-} for
-
-Basta % now plot the page (if Basta is not redefined)

arch/frida-1.4/g_dim.f

+C  ====================================================================
+C
+C      Library  WuGra :  Graphics
+C      Include  g_dim :     Array dimensions   
+C
+C  ====================================================================
+
+      INTEGER    MGreg, MKreg, MTreg, MSreg, MCgra, MGW
+      PARAMETER (MGreg=80000,MKreg=96,MCgra=40960,MTreg=300,MSreg=20)
+      PARAMETER (MGW=10, MGW6=6*MGW)

arch/frida-1.4/h.f

+
+      PROGRAM  TEST
+
+C  --------------------------------------------------------------------
+C     Declarations :
+C  --------------------------------------------------------------------
+
+      IMPLICIT NONE
+      DOUBLE PRECISION  X02AHF, X02AJF, X02AKF, X02ALF, X02AMF, X02ANF
+      INCLUDE 'l_def.f'
+
+      CHARACTER*80  Fehler
+      LOGICAL       qOv
+
+      Print *, X02AHF()
+      Print *, X02AJF()
+      Print *, X02AKF()
+      Print *, X02ALF()
+      Print *, X02AMF()
+      Print *, X02ANF()
+
+      END ! Test

arch/frida-1.4/i00.f

+C  ====================================================================
+C
+C      Library  IDA   :  Ingenious Data Analysis
+C      Modul    i00   :     main program
+C
+C  ====================================================================
+
+C  --------------------------------------------------------------------
+C  --------------------------------------------------------------------
+C      LICENSE TERMS (not to be modified except by the authors)
+C  --------------------------------------------------------------------
+C  FRIDA (fast reliable inelastic data analysis)
+C  <http://frida.sourceforge.net> is a program for generic spectral 
+C  analysis, with many specialized routines for inelastic neutron 
+C  scattering. The FORTRAN version Frida-1 is an updated version of 
+C  Joachim Wuttke's IDA, with contributions from the community. The 
+C  maintainer is Florian Kargl <f_kargl@users.sourceforge.net>. 
+C  FRIDA is released under the GNU public license.
+C  (C) Joachim Wuttke 1990-2001
+C  (C) Florian Kargl 2006    
+C  --------------------------------------------------------------------
+C
+C  The package includes the following maintained modules:
+C  i00.f - i99.f,l1.f-l6.f,g1.f,g2.f
+C  i_*.f,l_*.f,g_*.f contain definitions
+C  l0*.f contain system specific information
+C  --------------------------------------------------------------------
+C  --------------------------------------------------------------------
+
+C      General information :
+C         Link i00-i99,l0*,l1-l6,g1-g2,NAGLIB/DP
+C         Home page for detailed documentation (to be announced
+C         via sourceforge mailinglist)
+
+C      Contents of the IDA modules :
+C         i00 : main program
+C         i01 : plot
+C         i10 : input/output
+C         i20 : on-line memory
+C         i23 : directories, editing, r/z-handling
+C         i25 : file copy, delete, make
+C         i30 : file manipulations, auxiliary calculations
+C         i32 : general functions and symbolic calculation
+C         i40 : manipulations on data / per channel
+C         i41 : manipulations on data / per spectrum
+C         i42 : manipulations on data / per file
+C         i43 : special manipulations on data
+C         i50 : operations on data
+C         i60 : curves and fit
+C         i66 : collection of fit functions
+C         i67 : very special fit functions
+C         i70 : rescaling operations
+C         i71 : Fourier transforms
+C         i72 : neutron kinematics, constant-q
+C         i73 : density of states
+C         i74 : self absorption
+C         i75 : nuclear forward scattering
+C         i76 : mode coupling integration
+C         i77 : full mode coupling model             ! LINK ONLY WHEN NEEDED
+C         i80 : raw data read / neutron scattering
+C         i87 : raw data read / light scattering
+C         i94 : simulation / multiple scattering     ! LINK ONLY WHEN NEEDED
+C         i95 : simulation / optics
+
+C  ====================================================================
+C  The Main Program :
+C  ====================================================================
+
+      PROGRAM  IDA
+
+C  --------------------------------------------------------------------
+C     Declarations :
+C  --------------------------------------------------------------------
+
+      IMPLICIT NONE
+      INCLUDE 'i_dim.f'
+      INCLUDE 'l_def.f'
+
+      CHARACTER*80  Fehler, Object, Word, aus
+      CHARACTER     Stream*400
+      INTEGER       MemBlockInq, JList(MF), nJList, nF, nFold, lj, iWord
+      LOGICAL       qOv
+
+C  --------------------------------------------------------------------
+C     Initializations :
+C  --------------------------------------------------------------------
+
+      Print *
+      Print *, '*******************************************************'
+      Print *
+      Print *, 'This is FRIDA-1 (fast reliable inelastic data analysis)'
+      Print *, 'FORTRAN release by Florian Kargl and Joachim Wuttke'
+      Print *, 'Linux Version 1.2 - November 2006 '
+      Print *
+      Print *, '*******************************************************'
+      Print *
+
+      Fehler = '&ff'
+      nF = 0
+      nJList = 0
+      Stream   = ';!me'
+
+      ! search for the setup file :
+      CALL ExeML ('\i ida.su', aus)
+      IF (aus(1:4).ne.'\i +') CALL ExeML ('\i ../ida.su', aus)
+      IF (aus(1:4).ne.'\i +') CALL ExeML ('\i ../../ida.su', aus)
+      IF (aus(1:4).ne.'\i +') CALL ExeML ('\i ~/ida.su', aus)
+      IF (aus(1:4).ne.'\i +') CALL ExeML ('\i /home/fkargl/Ida/ida.su',
+     *                                    aus)
+      IF (aus(1:4).ne.'\i +') THEN
+         Print *
+         Print *, ' Could not load setup file ida.su'
+         Print *
+         ENDIF 
+
+      Object = ' '
+      CALL FileLoad  (Object, Fehler)
+      IF (Fehler.ne.'&ff') CALL FehlerGong (Fehler, 3) 
+      CALL LiGetDef  (nJList, JList)
+      Print *
+      Print *, 'You reach the IDA command level. For help, type h'
+      Print *
+
+C  --------------------------------------------------------------------
+C     Main loop : execute the commands contained in Stream
+C  --------------------------------------------------------------------
+
+ 1    CONTINUE
+
+      CALL NextCommand (Stream, Word, Object, iWord, nJList, JList, qOv)
+     
+C  --------------------------------------------------------------------
+      IF (Word.eq.'h') THEN                                     !  Help
+C  --------------------------------------------------------------------
+
+      Print *, 'help :'
+      Print *, '   hc  = commands'
+      Print *, '   hd  = array dimensions'
+
+      ELSEIF (Word.eq.'hc') THEN 
+         Print *, 'command groups / type first letter to obtain full lists:'
+         Print *, '   f*  = files in on-line-memory (load,save,make,delete)'
+         Print *, '   d*  = directories of files in on-line-memory'
+         Print *, '   e*  = edit files (in particular file headers)'
+         Print *, '   g*  = graphics'
+         Print *, '   c*  = fit curves'
+         Print *, '   m*  = manipulate data'
+         Print *, '   o*  = operate on data'
+         Print *, '   t*  = transform on data'
+         Print *, '   r*  = raw data input'
+         Print *, '   _*  = very special data treatment'
+         Print *, 'further commands:'
+         Print *, '   p   = plot'
+         Print *, '   a   = add to plot'
+         Print *, '   qui = quit IDA'
+
+      ELSEIF (Word.eq.'hd') THEN
+         CALL MemDims ()
+         Print *
+         CALL GraDims ()
+
+C  --------------------------------------------------------------------
+      ELSEIF (Word.eq.'f') THEN                                !  Files
+C  --------------------------------------------------------------------
+
+      Print *, 'files :'
+      Print *, '   fl  = load file from disk into on-line-memory'
+      Print *, '   fs  = save file from on-line-memory on disk'
+      Print *, '   fc  = copy (duplicate) on-line-file'
+      Print *, '   fx  = move file to last position in on-line-memory'
+      Print *, '   fdel= delete file from on-line-memory'
+      Print *, '   fm  = make a new file starting from nothing'
+      Print *, '   fmh = make a new histogram file from an event log'
+
+      ELSEIF (Word.eq.'fl') THEN
+         CALL FileLoad  (Object, Fehler)
+      ELSEIF (Word.eq.'fc') THEN
+         CALL FileCopy (nJList, JList, Fehler)
+      ELSEIF (Word.eq.'fdel') THEN
+         CALL FileKill (nJList, JList, Fehler)
+         CALL LiStackIO (0, nJList, JList)
+      ELSEIF (Word.eq.'fx') THEN
+         CALL FileCopy (nJList, JList, Fehler)
+            IF (Fehler.ne.'&ff') GOTO 99
+         CALL FileKill (nJList, JList, Fehler)
+         CALL LiStackIO (0, nJList, JList)
+      ELSEIF (Word.eq.'fs') THEN
+         CALL FileSave (nJList, JList, Fehler)
+      ELSEIF (Word.eq.'fm') THEN
+         CALL FileMake (Fehler)
+      ELSEIF (Word.eq.'fmh') THEN
+         CALL FileMakeHist (Fehler)
+
+C  --------------------------------------------------------------------
+      ELSEIF (Word.eq.'d') THEN                            !  Directory
+C  --------------------------------------------------------------------
+
+      Print *, 'directories :'
+      Print *, '   df  = directory of files in on-line-memory'
+      Print *, '   ds  = directory of spectra in selected files'
+      Print *, '   dz  = directory of z-values in selected files'
+      Print *, '   dp  = listing of data points in selected spectra'
+
+      ELSEIF (Word.eq.'df') THEN
+         CALL MemInfoF (Fehler)
+      ELSEIF (Word.eq.'ds') THEN
+         CALL MemInfoK (nJList, JList, Fehler)
+      ELSEIF (Word.eq.'dz') THEN
+         CALL MemInfoZ (nJList, JList, Fehler)
+      ELSEIF (Word.eq.'dp') THEN
+         CALL MemInfoY (nJList, JList, Fehler)
+
+C  --------------------------------------------------------------------
+      ELSEIF (Word.eq.'e') THEN                            !  Edit
+C  --------------------------------------------------------------------
+
+      Print *, 'edit :'
+      Print *, '   ec  = edit coordinate names and units'
+      Print *, '   ed  = edit documentation'
+      Print *, '   ez  = edit z coordinates'
+      Print *, '   er  = edit real parameters'
+      Print *, '   ei  = edit integer parameters'
+      Print *, '   eg  = edit graphics parameters'
+
+      ELSEIF (Word.eq.'ec') THEN
+         CALL EditCnu (nJList, JList, '?', Fehler)
+      ELSEIF (Word.eq.'ed') THEN
+         CALL EditDoc (nJList, JList, Fehler)
+      ELSEIF (Word.eq.'ez') THEN
+         CALL EditZ (nJList, JList, Fehler)
+      ELSEIF (Word.eq.'er') THEN
+         CALL EditRPar (nJList, JList, Fehler)
+      ELSEIF (Word.eq.'ei') THEN
+         CALL EditIPar (nJList, JList, Fehler)
+      ELSEIF (Word.eq.'eg') THEN
+         CALL EditGPar (nJList, JList, Fehler)
+
+C  --------------------------------------------------------------------
+      ELSEIF (Word(1:1).eq.'g') THEN                        !  Graphics
+C  --------------------------------------------------------------------
+
+
+         IF     (Word.eq.'gs') THEN
+            CALL GraSoftCopy (Object, 'fil-gra-def.ps', Fehler)
+         ELSEIF (Word.eq.'gp') THEN
+            CALL GraSoftCopy (Object, 'fil-gra-ful.ps', Fehler)
+         ELSEIF (Word.eq.'ga') THEN
+            CALL GraSoftCopy (Object, 'fil-gra-app.ps', Fehler)
+         ELSE 
+            CALL GraChoice (Word(2:5), Object, Fehler)
+            ENDIF
+
+      ELSEIF (Word.eq.'p' .or. Word.eq.'a' .or. Word.eq.'pp') THEN
+         CALL IdaPlot (Word, nJList, JList, Object, Fehler)
+
+C  --------------------------------------------------------------------
+      ELSEIF (Word.eq.'c') THEN                                ! Curves
+C  --------------------------------------------------------------------
+
+      Print *, 'curves :'
+      Print *, '   cc  = create'
+      Print *, '   cf  = fit'
+      Print *, '   cp  = parameters'
+      Print *, '   cpa = parameters (alt)'
+      Print *, '   ca  = auxiliary parameters'
+      Print *, '   cnn = new number (change function definition)'
+      Print *, '   cs  = setup for fitroutine'
+      Print *, '   ci  = get parameters (-> integral file)'
+      Print *, '   cg  = get data on a grid (-> full file)'
+
+      ELSEIF (Word.eq.'cc') THEN
+         CALL CuCreate (nJList, JList, .false., Fehler)
+      ELSEIF (Word.eq.'cf') THEN
+         CALL CuFitCall (nJList, JList, Fehler)
+      ELSEIF (Word.eq.'cp') THEN
+         CALL EditCPar (nJList, JList, .false., Fehler)
+      ELSEIF (Word.eq.'cpa') THEN
+         CALL CuSetPar (nJList, JList, .false., Fehler)
+      ELSEIF (Word.eq.'cnn') THEN
+         CALL CuRedef (nJList, JList, Fehler)
+      ELSEIF (Word.eq.'ca') THEN
+         CALL CuSetAux (nJList, JList, Fehler)
+      ELSEIF (Word.eq.'cs') THEN
+         CALL CuSetFit (Fehler)
+      ELSEIF (Word.eq.'ci') THEN
+         CALL CuGetPar (nJList, JList, Fehler)
+      ELSEIF (Word.eq.'cg') THEN
+         CALL GridCurve (nJList, JList, Fehler)
+
+C  --------------------------------------------------------------------
+      ELSEIF (Word.eq.'m') THEN                   !  Data manipulations
+C  --------------------------------------------------------------------
+
+      Print *, 'manipulations :'         ! systematic arrangement 5nov91
+      Print *, '   mcd = channels delete'
+      Print *, '   mca =          add'
+      Print *, '   mcaa=          add automatically'
+      Print *, '   mco =          order (sort/sum)'
+      Print *, '   mcg =          determine groups'
+      Print *, '   mcm =          y -> f(y)'
+      Print *, '   mch =          histogram binning'
+      Print *, '   mcx =          x <-> y'
+      Print *, '   mcs =          break into spectra'
+      Print *, '   mgi = grid     interpolate'
+      Print *, '   mge =          extrapolate'
+      Print *, '   mgd =          delete'
+      Print *, '   mga =          add'
+      Print *, '   mgr =          redistribute'
+      Print *, '   mgh =          points -> histogram'
+      Print *, '   msd = spectra  delete'
+      Print *, '   msa =          add'
+      Print *, '   msaw=          add (weighted)'
+      Print *, '   msj =          join'
+      Print *, '   mso =          order'
+      Print *, '   msx =          exchange <-> channels'
+      Print *, '   mfj = files    join'
+      Print *, '   mfs =          sum'
+      Print *, '   mfx =          exchange <-> spectra'
+
+      ELSEIF (Word.eq.'mca') THEN
+         CALL OrgChSum (nJList, JList, qOv, Fehler)
+      ELSEIF (Word.eq.'mcaa') THEN
+         CALL OrgChSAuto (nJList, JList, qOv, Fehler)
+      ELSEIF (Word.eq.'mcd') THEN
+         CALL OrgChCut (nJList, JList, qOv, Fehler)
+      ELSEIF (Word.eq.'mco') THEN
+         CALL OrgChSort (nJList, JList, qOv, Fehler)
+      ELSEIF (Word.eq.'mcg') THEN
+         CALL OrgChGroup (nJList, JList, qOv, Fehler)
+      ELSEIF (Word.eq.'mcg') THEN
+         CALL OrgChGroup (nJList, JList, qOv, Fehler)
+      ELSEIF (Word.eq.'mcm') THEN
+         CALL OrgChSubs (nJList, JList, qOv, Fehler)
+      ELSEIF (Word.eq.'mch') THEN
+         CALL OrgHistMake (nJList, JList, qOv, Fehler)
+      ELSEIF (Word.eq.'mcx') THEN
+         CALL OrgChExch (nJList, JList, qOv, Fehler)
+      ELSEIF (Word.eq.'mcs') THEN
+         CALL OrgChSpectra (nJList, JList, qOv, Fehler)
+
+      ELSEIF (Word.eq.'mgi') THEN
+         CALL GridIntExt (.false., nJList, JList, qOv, Fehler)
+      ELSEIF (Word.eq.'mge') THEN
+         CALL GridIntExt (.true., nJList, JList, qOv, Fehler)
+      ELSEIF (Word.eq.'mga') THEN
+         CALL GridSumCut (.true., nJList, JList, qOv, Fehler)
+      ELSEIF (Word.eq.'mgd') THEN
+         CALL GridSumCut (.false., nJList, JList, qOv, Fehler)
+      ELSEIF (Word.eq.'mgr') THEN
+         CALL GridRedis (nJList, JList, qOv, Fehler)
+      ELSEIF (Word.eq.'mgh') THEN
+         CALL GridHist (nJList, JList, qOv, Fehler)
+
+      ELSEIF (Word.eq.'msd') THEN
+         CALL OrgSpectraCut (nJList, JList, qOv, Fehler)
+      ELSEIF (Word.eq.'msa') THEN
+         CALL OrgSpectraSum ('a', .false., nJList, JList, qOv, Fehler)
+      ELSEIF (Word.eq.'msaw') THEN
+         CALL OrgSpectraSum ('a', .true.,  nJList, JList, qOv, Fehler)
+      ELSEIF (Word.eq.'msj') THEN
+         CALL OrgSpectraSum ('j', .false., nJList, JList, qOv, Fehler)
+      ELSEIF (Word.eq.'mso') THEN
+         CALL OrgSpectraSort (nJList, JList, qOv, Fehler)
+      ELSEIF (Word.eq.'msx') THEN
+         CALL OrgSpectraExch (nJList, JList, qOv, Fehler)
+      ELSEIF (Word.eq.'msf') THEN
+         CALL OrgSpectraBreak (nJList, JList, Fehler)
+
+      ELSEIF (Word.eq.'mfj') THEN
+         CALL OrgFileJoin (nJList, JList, qOv, Fehler)
+
+C  --------------------------------------------------------------------
+      ELSEIF (Word.eq.'o') THEN                   !  Operations on data
+C  --------------------------------------------------------------------
+
+      Print *, 'operations :'
+      Print *, '   oi  = integral properties'
+      Print *, '   ox  = pointwise operation on x'
+      Print *, '   oxs =   dito, selected subrange'
+      Print *, '   oy  = pointwise operation on y'
+      Print *, '   oys =   dito, selected subrange'
+      Print *, '   oz  = pointwise operation on z (also oz1, oz2, ...)'
+      Print *, '   of  = operate on y as function of x   '
+      Print *, '   ot  = form tensor product'
+
+      ELSEIF (Word.eq.'oi') THEN
+         CALL OprIntegral (nJList, JList, qOv, Fehler)
+      ELSEIF (Word.eq.'of') THEN
+         CALL OprDifferential (nJList, JList, qOv, Fehler)
+      ELSEIF (Word.eq.'ot') THEN
+         CALL OprTensor (nJList, JList, qOv, Fehler)
+
+      ELSEIF (Word.eq.'ox') THEN
+         CALL OprPointwise ('x', nJList, JList, .false., qOv, Object, Fehler)
+      ELSEIF (Word.eq.'oxs') THEN
+         CALL OprPointwise ('x', nJList, JList, .true.,  qOv, Object, Fehler)
+      ELSEIF (Word.eq.'oy') THEN
+         CALL OprPointwise ('y', nJList, JList, .false., qOv, Object, Fehler)
+      ELSEIF (Word.eq.'oys') THEN
+         CALL OprPointwise ('y', nJList, JList, .true.,  qOv, Object, Fehler)
+      ELSEIF (Word.eq.'oz') THEN
+         CALL OprPointwise ('z1', nJList, JList, .false., qOv, Object, Fehler)
+      ELSEIF (Word.eq.'oz#') THEN
+         CALL OprPointwise ('z'//ch1(iWord),
+     *                            nJList, JList, .false., qOv, Object, Fehler)
+
+C  --------------------------------------------------------------------
+      ELSEIF (Word.eq.'r') THEN
+C  --------------------------------------------------------------------
+
+      Print *, 'read raw data'
+      Print *, '   rf     = from FPI @ E13'
+      Print *, '   rr     = from Raman @ E13'
+      Print *, '   ro     = from Oke @ Lens'
+      Print *, '   re     = from NRSE @ LLB'
+      Print *, '   rec    =      NRSE/ correct (what for ?)'
+      Print *, '   r04    = from IN 4'
+      Print *, '   r05    = from IN 5'
+      Print *, '   r06    = from IN 6'
+      Print *, '   rtof   = from TOFTOF (FRM2)'
+      Print *, '   rMI    = from Mibemol'
+      Print *, '   rNE    = from NEAT (V3) @ HMI'
+      Print *, '   rfcs   = from FCS @ NIST' 
+      Print *, '   rfoc   = from Focus @ Sinq'
+      Print *, '   rfoco  = from Focus @ Sinq (not NEXUS old)'
+      Print *, '   rdcs   = from DCS @ NIST'
+      Print *, '   r10    = from IN10'
+      Print *, '   r13    = from IN13'
+      Print *, '   r16    = from IN16'
+      Print *, '   r10e   = from IN10/ elastic scans'
+      Print *, '   rhfbs  = from HFBS @ NIST'
+      Print *, '   rhfbo  = from HFBS @ NIST (pre Aug03)'
+      Print *, '   rfans  = from FANS @ NIST'
+      Print *, '   rbt2   = from BT2 @ NIST (+DMC PSI)'
+      Print *, '   r11    = from IN11'
+      Print *, '   rrs    = from IRIS @ ISIS'
+      Print *, 'read log files'
+      Print *, '   rh     = history files from light scattering'
+
+c      ELSEIF (Word.eq.'re') THEN
+c         CALL RRawNRSE (Fehler)
+c      ELSEIF (Word.eq.'rec') THEN
+c         CALL DCorrNRSE (nJList, JList, qOv, Fehler)
+      ELSEIF (Word.eq.'rf') THEN
+         CALL RRawFPI (Fehler)
+      ELSEIF (Word.eq.'rr') THEN
+         CALL RRawRam (Fehler)
+      ELSEIF (Word.eq.'ro') THEN
+         CALL RRawOke (Fehler)
+      ELSEIF (Word.eq.'rhfbs') THEN
+         CALL RRT_In_Hfbs (Fehler)
+      ELSEIF (Word.eq.'rhfbo') THEN
+         CALL RRT_In_Hfbso (Fehler)
+      ELSEIF (Word.eq.'rfans') THEN
+         CALL RRT_In_Fans (Fehler)
+      ELSEIF (Word.eq.'rbt#'.and.iWord.eq.2) THEN
+         CALL RRT_In_BT2 (Fehler)
+      ELSEIF (Word.eq.'r#' .and. iWord.eq.10) THEN
+         CALL RRawBS ('IN10', Fehler)
+      ELSEIF (Word.eq.'r#' .and. iWord.eq.13) THEN
+         CALL RRawBS ('IN13', Fehler)
+      ELSEIF (Word.eq.'r#' .and. iWord.eq.16) THEN
+         CALL RRawBS ('IN16', Fehler)
+      ELSEIF (Word.eq.'r#' .and. iWord.eq.4) THEN
+         CALL RRawTOF ('IN4', Fehler)
+      ELSEIF (Word.eq.'r#' .and. iWord.eq.5) THEN
+         CALL RRawTOF ('IN5', Fehler)
+      ELSEIF (Word.eq.'r#' .and. iWord.eq.6) THEN
+         CALL RRawTOF ('IN6', Fehler)
+      ELSEIF (Word.eq.'rtof') THEN
+         CALL RRawTOF ('TOF', Fehler)
+      ELSEIF (Word.eq.'rmi') THEN
+         CALL RRawTOF ('MIB', Fehler)
+      ELSEIF (Word.eq.'rfoc') THEN
+         CALL RRawTOF ('FOCUS', Fehler)
+      ELSEIF (Word.eq.'rfoco') THEN
+         CALL RRawTOF ('FOCUSO',Fehler)
+      ELSEIF (Word.eq.'rdcs') THEN
+         CALL RRawTOF ('DCS',Fehler)
+      ELSEIF (Word.eq.'rrs') THEN
+         CALL RRaw_IRS ('IRS',Fehler)
+      ELSEIF (Word.eq.'rfcs') THEN
+         CALL RRawTOF ('FCS', Fehler)
+      ELSEIF (Word.eq.'rne') THEN
+         CALL RRawTOF ('NEAT', Fehler)
+      ELSEIF (Word.eq.'r#e' .and. iWord.eq.10) THEN
+         CALL RRawIN10e (Fehler)
+      ELSEIF (Word.eq.'r#' .and. iWord.eq.11) THEN
+         CALL RRawIN11 (Fehler)
+      ELSEIF (Word.eq.'rh') THEN
+         CALL RRawHistory (Fehler)
+
+C  --------------------------------------------------------------------
+      ELSEIF (Word.eq.'t') THEN                           !  Transforms
+C  --------------------------------------------------------------------
+
+      Print *, 'transforms :'
+      Print *, '   tu  = conversion of units in x (and possibly in y)'
+      Print *, '   tfc = Fourier cosine transform with Filon algorithm'
+      Print *, '   tfs = Fourier sine transform with Filon algorithm'
+      Print *, '   tff = Fast Fourier cosine transform'
+      Print *, '   tfp = Fast Fourier complex transform'
+      Print *, '   tfe = Fast Fourier transform of exponential'
+      Print *, '   ts  = (anti)symmetrize'
+      Print *, '   tm  = double by adding mirror image Y(-x)'
+      Print *, '   tr  = representation of complex numbers'
+      Print *, '   td  = deconvolution'
+      Print *, '   tc  = convolution'
+
+      ELSEIF (Word.eq.'tu') THEN
+         CALL TraUnits (nJList, JList, qOv, Fehler)
+      ELSEIF (Word.eq.'tfc') THEN
+         CALL TraFilon (nJList, JList, qOv, .true., Fehler)
+      ELSEIF (Word.eq.'tfs') THEN
+         CALL TraFilon (nJList, JList, qOv, .false., Fehler)
+      ELSEIF (Word.eq.'tff') THEN
+         CALL TraFFTsingle (nJList, JList, Fehler)
+      ELSEIF (Word.eq.'tfp') THEN
+         CALL TraFFTpair   (nJList, JList, Fehler)
+      ELSEIF (Word.eq.'ts') THEN
+         CALL TraSymm (nJList, JList, Fehler)
+      ELSEIF (Word.eq.'tm') THEN
+         CALL TraDouble (nJList, JList, qOv, Fehler)
+c      ELSEIF (Word.eq.'tr') THEN
+c         CALL TraRepr (Fehler)
+c      ELSEIF (Word.eq.'td') THEN
+c         CALL TraDeconv (Fehler)
+c      ELSEIF (Word.eq.'tc') THEN
+c         CALL TraConv (Fehler)
+
+C  --------------------------------------------------------------------
+      ELSEIF (Word.eq.'_') THEN
+C  --------------------------------------------------------------------
+
+      Print *, 'incorporated data analysis programs :'
+      Print *, '   _af  = frequency axis for FPI data'
+      Print *, '   _coq = interpolation to constant q'
+      Print *, '   _mph = multiphonon correction for DOS'
+      Print *, '   _muc = DOS calculation on basis of MUPHCOR'
+      Print *, '   _pm  = +- convention for energies'
+      Print *, '   _sac = self absorption coefficients'
+      Print *, '   _sg  = conversions between S,S~,g,G,...'
+c     Print *, '   _sub = test subtraction D(x)-r*C(x-d)'
+      Print *, '   _tx  = nonlinear transformation of x axis'
+      Print *, '   _mcc = Monte-Carlo convolution'
+      Print *, '   _mss = multiple scattering simulation'
+      Print *, '   _fmm = full mode-coupling model'
+      Print *, '   _of  = Optik FPI'
+      Print *, '   _rmc = retain master curve'
+      Print *, '   _msd = MSD file generation IRIS'
+      Print *, '   __   = test'
+
+      ELSEIF (Word.eq.'_af') THEN
+         CALL NormFPI (nJList, JList, qOv, Fehler)
+      ELSEIF (Word.eq.'_coq') THEN
+         CALL CoQ (nJList, JList, Fehler)
+      ELSEIF (Word.eq.'_mph') THEN
+         CALL DOS (nJList, JList, Fehler)
+      ELSEIF (Word.eq.'_muc') THEN
+         CALL MUPHDOS (nJList, JList, Fehler)
+      ELSEIF (Word.eq.'_pm') THEN
+         CALL SEGconv (nJList, JList, Fehler)
+      ELSEIF (Word.eq.'_sac') THEN
+         CALL AbsCoeffs (nJList, JList, Fehler)
+      ELSEIF (Word.eq.'_sg') THEN
+         CALL DOSconv (nJList, JList, qOv, Fehler)
+      ELSEIF (Word.eq.'_tx') THEN
+         CALL TraAchseX (nJList, JList, qOv, Fehler)
+      ELSEIF (Word.eq.'_mcc') THEN
+         CALL MC_Conv (nJList, JList, Fehler)
+C      ELSEIF (Word.eq.'_mss') THEN                      ! LINK ONLY WHEN NEEDED
+C         CALL MScat (nJList, JList, Fehler)
+C      ELSEIF (Word.eq.'_fmm') THEN                      ! LINK ONLY WHEN NEEDED
+C         CALL FullMCT (nJList, JList, Fehler)
+      ELSEIF (Word.eq.'_of') THEN
+         CALL OptikFPI (nJList, JList, qOv, Fehler)
+      ELSEIF (Word.eq.'_rmc') THEN
+         CALL RetainMaster (nJList, JList, Fehler)
+      ELSEIF (Word.eq.'_msd') THEN
+         CALL MSDCalc (Fehler)
+      ELSEIF (Word.eq.'__') THEN
+         CALL IdaTest (nJList, JList, Fehler)
+
+C  --------------------------------------------------------------------
+      ELSEIF (Word(1:3).eq.'qui') THEN                          !  Exit
+C  --------------------------------------------------------------------
+
+      GOTO 999
+
+C  --------------------------------------------------------------------
+      ELSEIF (Word.eq.' ') THEN                           !  Do nothing
+C  --------------------------------------------------------------------
+
+C  --------------------------------------------------------------------
+      ELSE                                           !  End of commands
+C  --------------------------------------------------------------------
+
+         Fehler = 'Unknown command : '//Word
+         ENDIF
+
+C  --------------------------------------------------------------------
+ 99   CONTINUE                                         !  Error message
+C  --------------------------------------------------------------------
+
+      IF (Fehler.ne.'&ff') THEN
+         CALL FehlerGong (Fehler, 3)
+         Stream = ';!me'
+         ENDIF
+
+C  --------------------------------------------------------------------
+                                             !  Renew default file list
+C  --------------------------------------------------------------------
+
+      CALL FileClean ()
+      CALL LiGetDef (nJList, JList)
+
+      Print *
+
+C  --------------------------------------------------------------------
+      GOTO 1                                          !  End of main loop
+C  --------------------------------------------------------------------
+
+C  --------------------------------------------------------------------
+ 999  CONTINUE                                                  !  Stop
+C  --------------------------------------------------------------------
+
+      CALL GraChoice ('-', Object, Fehler)
+
+      END ! Ida_Main
+
+C      Implementation history :
+C         1990ff.  VAX / VMS                ILL Grenoble
+C         1992ff.  SUN                      LLB Saclay
+C         1992     VAX / BSD-Unix           CCNY New York
+C         1992     Macintosh                CCNY New York
+C         1993ff.  DEC-Station / Ultrix     TU Muenchen
+C         1994ff.  Alpha / OSF              TU Muenchen
+C         1995     VAX / VMS                ILL Grenoble
+C         1995     Silicon Graphics         ILL Grenoble
+
+C  ====================================================================
+C     Auxiliary routines (for menu)
+C  ====================================================================
+
+      SUBROUTINE NextCommand (Stream, Word, Object, iWord,
+     *                        nJList, JList, qOv)
+C     ----------------------------------------------------
+            ! separated (for better readability of ida$main) JWu 29dec99
+         ! Decompose Stream and find next command 
+
+      IMPLICIT NONE 
+      INCLUDE 'i_dim.f'
+      INCLUDE 'l_def.f'
+      CHARACTER*(*) Stream, Word, Object
+      CHARACTER*80  Task, ein, aus, CJList, Fehler
+      INTEGER       nJList, JList(*), iWord, niWord, i, kJLC, jB, nF,
+     *              MemBlockInq
+      LOGICAL       qOv
+
+ 1    CONTINUE 
+      Fehler = '&ff'
+
+C Extract Task from Stream :
+         ! The Stream consists of several Tasks which are separated
+         ! from each other by a ";" delimiter. The last Task in the
+         ! Stream has always to be the "me" command.
+
+      CALL StaTake (1, Stream, Task)
+      IF (Task(1:1).ne.';') THEN
+         aus = 'Stream beginnt nicht mit '';'' : Stream = '''
+     *           // Stream(1:lenU(Stream)) // '''.'
+         CALL Absturz ('IDA/main', aus)
+         ENDIF
+      CALL TakeVorKla (Stream, Task, ';', Fehler)
+      IF (Fehler.ne.'&ff') GOTO 99
+      IF (Task(1:1).eq.'!') THEN
+         CALL DelVonBis (Task, 1, 1)
+      ELSE
+         Print *, Task ! echo
+         ENDIF
+
+C  Extract Word from Task :
+         ! A Task consists of a Word and optionally an nJList, JList.
+         ! Word and nJList, JList are separated by a blank " " delimiter.
+         ! If the word contains an integer, its value is saved as iWord
+         ! and its string representation then replaced by a "#" symbol.
+
+      jB     = min0 (jPos1(Task, ' '), jPos1(Task, '=')+1)
+      Word   = Task(1:jB-1)        ! what comes before ' ' or '='
+      Object = Task(jB:len(Task))  ! what comes after
+      CALL DelLeft (Object)
+
+      IF    (jPos1('0123456789=*?/', Word(1:1)).le.14) THEN
+         CJList = Word                  ! Word seems to contain list of files
+         Task   = Object                ! therefore what comes later
+         jB     = jPos1 (Task, ' ')     !    must be divided further
+         Word   = Task(1:jB-1)         
+         IF (jB+1.le.len(Task)) THEN 
+            Object = Task(jB+1:len(Task))
+            CALL DelLeft (Object)
+         ELSE
+            Object = ' '
+            ENDIF 
+
+         IF     (CJList.eq.'?') THEN ! help demanded 
+            IF (Word.eq.' ') THEN 
+               Object = 'Ida'       ! general help
+            ELSE ! help on one command (Word)
+               Object = Word
+               ENDIF 
+            Word = 'h' 
+            nJList = 0  ! still needed ?
+         ELSEIF (CJList.eq.'=') THEN
+            ! no, no file list was given: overwrite the default files
+            qOv = .true.
+         ELSE
+            ! overwrite files or not ?
+            kJLC = lenU (CJList)
+            IF (CJList(kJLC:kJLC).eq.'=') THEN
+               qOv = .true.
+               CJList(kJLC:kJLC) = ' '
+            ELSE
+               qOv = .false.
+               ENDIF
+            ! decode list of files :
+            nF = MemBlockInq ('nF')
+            CALL DecJList (CJList, MF, nJList, JList, 1, nF, Fehler)
+            IF (Fehler.ne.'&ff') GOTO 99
+
+            ENDIF ! new file list
+
+      ELSE ! default file-list
+         qOv = .false.
+
+         ENDIF
+
+      CALL FindN (Word, 1, niWord, iWord) ! replace integer in Word 1 by #
+      CALL Minuskeln (Word)
+
+C  Execute control commands :
+      IF     (Word.eq.'me') THEN ! menue
+            ! default file-list added 1feb93.
+ 20      CONTINUE
+         CALL EncJList (nJList, JList, CJList)
+         IF (nJList.gt.0) THEN
+            CALL Compose2 (aus, 'IDA ('//CJList, ') ')
+         ELSE
+            aus = 'IDA ()'
+            ENDIF
+         CALL FrageC (aus, ein)
+   
+         IF (ein.eq.' ') THEN
+            CALL LiStackIO (-1, nJList, JList)
+            GOTO 20
+            ENDIF
+         CALL DelLeft (ein)
+         Stream = ';!' // ein(1:lenU(ein)) // ';!me' ! '!' means no echo
+         Print *
+         GOTO 1
+
+      ELSEIF (Word(1:2).eq.'#*') THEN ! n times a command (JWu 5jul91) 
+
+         CALL DelVonBis (Task, 1, 2)
+         IF (niWord.ne.1) CALL Absturz ('Main', '#* : no integer prepared')
+         DO i = 1, iWord
+            CALL Insert (Stream, 1, ';'//Task(1:lenU(Task)))
+            ENDDO
+         niWord = 0
+         GOTO 1
+
+         ENDIF 
+
+      RETURN ! regular exit
+
+ 99   CONTINUE
+      IF (Fehler.ne.'&ff') THEN
+         CALL FehlerGong (Fehler, 3)
+         Stream = ';!me'
+         GOTO 1 ! try again
+         ENDIF
+
+      END ! NextCommand
+
+      SUBROUTINE LiGetDef (nJList, JList)
+C     -----------------------------------
+         ! Get new default-file-list 
+
+      INCLUDE 'i_dim.f'
+      INTEGER JList(MF)
+
+      nFold = nF
+      nF = MemBlockInq ('nF')
+      IF     (nF.gt.nFold) THEN
+         ! save old default
+         CALL LiStackIO (+1, nJList, JList)
+         ! set new default
+         nJList = max0 (0, nF-nFold)
+         DO lj = 1, nJList
+            JList(lj) = nFold + lj
+            ENDDO
+      ELSEIF (nF.lt.nFold) THEN ! after delete
+         CALL LiStackIO (-1, nJList, JList)
+         ENDIF
+
+      END ! LiGetDef
+
+      SUBROUTINE LiStackIO (io, nJList, JList)
+C     ----------------------------------------
+            ! 11mar93
+      INCLUDE   'i_dim.f'
+      PARAMETER (MLM=8)
+      INTEGER    JList(MF), JLMem(MLM,MF), NJLMem(MLM)
+
+      IF     (io.eq.-1) THEN
+         ! get and remove a list from stack :
+         nJList = NJLMem(1)
+         DO lj = 1, NJLMem(1)
+            JList(lj) = JLMem(1,lj)
+            ENDDO
+         DO iLM = 1, MLM-1
+            NJLMem(iLM) = NJLMem(iLM+1)
+            DO lj = 1, NJLMem(iLM)
+               JLMem(iLM,lj) = JLMem(iLM+1,lj)
+               ENDDO
+            ENDDO
+
+      ELSEIF (io.eq.0) THEN
+         ! remove entries from all lists :
+         DO iLM = 1, MLM
+            DO lj = 1, nJList
+               DO ljj = 1, NJLMem(iLM)
+                  IF (JLMem(iLM,ljj).eq.JList(lj)) THEN
+                     DO ljjj = ljj, NJLMem(iLM)-1
+                        JLMem(iLM,ljjj) = JLMem(iLM,ljjj+1)
+                        ENDDO
+                     NJLMem(iLM)= NJLMem(iLM)-1
+                     ENDIF
+                  ENDDO 
+               ENDDO
+            ENDDO
+
+      ELSEIF (io.eq.+1) THEN
+         ! put onto stack :
+         DO iLM = MLM, 2, -1
+            NJLMem(iLM) = NJLMem(iLM-1)
+            DO lj = 1, NJLMem(iLM)
+               JLMem(iLM,lj) = JLMem(iLM-1,lj)
+               ENDDO
+            ENDDO
+         NJLMem(1) = nJList
+         DO lj = 1, NJLMem(1)
+            JLMem(1,lj) = JList(lj)
+            ENDDO
+
+      ELSE
+         CALL Absturz('LiStackIO', 'io o.o.r.')
+         ENDIF
+
+      END ! LiStackIO

arch/frida-1.4/i01.f

+C  ====================================================================
+C
+C      Library  IDA   :  Ingenious Data Analysis
+C      Modul    i01   :     plot (interface to g2.f)
+C
+C  ====================================================================
+
+      SUBROUTINE IdaPlot (Word, nJList, JList, Object, Fehler)
+C     --------------------------------------------------------
+         ! call plot routines to create a frame and to show data
+            ! as a subroutine JWu 30jul91.
+            ! 12mar96: clear division: first setup, then plot.
+
+      IMPLICIT REAL *8 (a-h,o-p,r-z)
+      IMPLICIT LOGICAL (q)
+
+      INCLUDE 'i_dim.f'
+      INCLUDE 'i_wrk.f'
+      INCLUDE 'l_def.f'
+
+      CHARACTER*(*)  Fehler, Object, Word
+      DIMENSION      JList(*)
+
+      INTEGER        K1K(MK), K2K(MK), K3K(MK)
+      REAL*8         Zp(MK), Z(MZ)
+
+      CHARACTER*1    action
+      CHARACTER*40   Co3(3), Un3(3), CoZ(MZ), UnZ(MZ),
+     *               CoP, UnP, Un, file, title, doc,hilf
+      CHARACTER*80   aus, lisK, lisKold, line
+      CHARACTER*240  tline0, tline1
+
+      DATA   lisK /'*'/
+
+      IF (nJList.eq.0) THEN
+         Fehler = ' '
+         RETURN
+         ENDIF
+
+C  Input commands :
+      IF     (Word.eq.'p' ) THEN
+         qPlotNew  = .true.
+         ndim      = 2
+      ELSEIF (Word.eq.'a' ) THEN
+         qPlotNew  = .false.
+      ELSEIF (Word.eq.'pp' ) THEN
+         qPlotNew  = .true.
+         ndim      = 3
+      ELSE
+         Fehler = ' Unknown command : '//Word
+         RETURN
+         ENDIF
+
+C  New coordinate system ?
+      IF (qPlotNew) THEN
+         j = JList(1)
+         nK = iOlfG (j, '#spectra', Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+
+         qCurve = qOlfGdef (j, '?cu', 0, Fehler)
+         IF (qCurve) THEN
+            ifc = iOlfG (j, 'fu#', Fehler)
+            ENDIF
+         IF (Fehler.ne.'&ff') RETURN
+   
+         ! which spectra ?
+         IF (Object.ne.' ') THEN
+            CALL DecJList (Object, MK, nK1, K1K, 1, nK, Fehler)
+            lisK = Object
+            IF (nK1.le.0 .or. Fehler.ne.'&ff') RETURN
+         ELSEIF (nK.eq.1) THEN
+            K1K(1) = 1
+            nK1 = 1
+         ELSE
+            lisKold = lisK
+            CALL Compose2 (aus, ' Plot which of the '//cl3(nK), ' spectra')
+            CALL GetJList (aus, lisK, MK, nK1, K1K, 1, nK)
+            IF (nK1.le.0) THEN
+               lisK = lisKold ! old default
+               Fehler = ' '
+               RETURN
+               ENDIF
+            ENDIF
+
+         ! get coordinate names & units > determine appropriate window
+         CALL OlfCnuG (j, 'x', Co3(1), Un3(1), Fehler)
+         CALL OlfCnuG (j, 'y', Co3(2), Un3(2), Fehler)
+         IF (ndim.ge.3) CALL OlfCnuG (j, 'z1', Co3(3), Un3(3), Fehler)
+         IF (Fehler.ne.'&ff') RETURN 
+         CALL GraSetWdw (ndim, Co3, Un3, Fehler)
+         IF (Fehler.ne.'&ff') RETURN 
+
+         ! (re)set x y (and z) scales of the chosen window 
+               ! der Ablauf ist ganz einfach : man ruft die Routine
+               ! {GraSetSca}, die ihrerseits "uber {action} eine
+               ! bestimmte Reaktion verlangt, die im folgenden
+               ! ausgef"uhrt wird und gegebenenfalls nach {GraSetSca}
+               ! zur"uckspringt.
+         xi = 0
+         xf = 0
+ 22      CALL GraSetSca (1, 'x', xi, xf, action, qLin, igfx, rgfx)
+         IF     (action.eq.'-') THEN ! escape
+            Fehler = ' '
+            RETURN 
+         ELSEIF (action.eq.'n') THEN ! calculate new defaults
+            IF (qCurve) THEN
+               IF (qLin) THEN
+                  xi = -1
+                  xf =  1
+               ELSE
+                  xi = .1
+                  xf = 10
+                  ENDIF 
+            ELSE
+               ! search for minimum and maximum 
+               xi =  1d20
+               xf = -1d20
+               ! loop spectra 
+               DO jK1 = 1, nK1
+                  K = K1K(jK1)
+                  CALL OlfGetX (j, K, n, X, Fehler)
+                  IF (Fehler.ne.'&ff') RETURN
+                  DO i = 1, n
+                     CALL FuVal (igfx, xx, dummy, X(i), 0d0, rgfx, 0d0)
+                     IF (xx.lt.xi .and. (qLin .or. xx.gt.0)) xi = xx
+                     xf = dmax1 (xf, xx)
+                     ENDDO 
+                  ENDDO
+               IF (qLin) THEN
+                  CALL RoundLin (xi, xf, .052d0, 2)
+               ELSE
+                  CALL RoundLog (xi, xf, .1d0, 1)
+                  ENDIF
+               ENDIF ! qCurve or not
+            IF (xi.ge.xf) THEN ! avoid endless loop 24mrz98
+               xi = xi - 1
+               xf = xf + 1
+               ENDIF
+            GOTO 22
+
+         ELSEIF (action.eq.'x') THEN ! revise 'x'
+            GOTO 22
+            ENDIF 
+            
+         yi = 0
+         yf = 0
+ 23      CALL GraSetSca (2, 'y', yi, yf, action, qLin, igfy, rgfy)
+         IF     (action.eq.'-') THEN ! escape
+            Fehler = ' '
+            RETURN 
+         ELSEIF (action.eq.'n') THEN ! calculate new defaults
+            yi =  1d49
+            yf = -1d49
+            ! loop spectra 
+            DO jK1 = 1, nK1
+               K = K1K(jK1)
+               IF (qCurve) THEN 
+                  ! calculate value without convolution (and without par(18))
+                  n = 2
+                  X(1) = xi
+                  X(2) = xf
+                  CALL OlfGetY (j, K, ndummy, Y1, Fehler)
+                  IF (Fehler.ne.'&ff') RETURN
+                  CALL CuFuVal (ifc, Y1, X, Y, n, Fehler)
+                  IF (Fehler.ne.'&ff') RETURN
+               ELSE
+                  CALL OlfGetXY (j, K, n, X, Y, Fehler)
+                  IF (Fehler.ne.'&ff') RETURN
+                  ENDIF
+               DO i = 1, n
+                  CALL FuVal (igfx, xx, dummy, X(i), 0d0, rgfx, 0d0)
+                  IF (xi.le.xx .and. xx.le.xf) THEN
+                     CALL FuVal (igfy, yy, dummy, Y(i), 0d0, rgfy, 0d0)
+                     IF (yy.lt.yi .and. (qLin .or. yy.gt.0)) yi = yy
+                     yf = dmax1 (yf, yy)
+                     ENDIF
+                  ENDDO 
+               ENDDO
+            IF ((.not.qLin .and. yi.le.0 .or. yf.le.yi)) THEN ! kommt vor
+               CALL Gong (2)
+               Print *, 'curve starts or ends below 0: yi yf = ', yi, yf
+               yi = 1d-10
+               yf = 1d10
+               ENDIF 
+            IF (qLin) THEN
+               CALL RoundLin (yi, yf, .052d0, 2)
+            ELSE
+               CALL RoundLog (yi, yf, .1d0, 1)
+               ENDIF
+            IF (yi.ge.yf) THEN ! avoid endless loop 12nov96
+               yi = yi - 1
+               yf = yf + 1
+               ENDIF
+            GOTO 23
+
+         ELSEIF (action.eq.'x') THEN ! revise 'x'
+            GOTO 22
+            ENDIF 
+            
+         IF (ndim.lt.3) GOTO 25
+         zi = 0
+         zf = 0
+ 24      CALL GraSetSca (3, 'z', zi, zf, action, qLin, igfz, rgfz)
+         IF     (action.eq.'-') THEN ! escape
+            Fehler = ' '
+            RETURN 
+         ELSEIF (action.eq.'n') THEN ! calculate new defaults
+            CALL OlfGet1ZofK (j, 1, nKz, Zp, Fehler)
+            IF (Fehler.ne.'&ff') RETURN
+            zi =  1d20
+            zf = -1d20
+            DO K = 1, nKz
+               CALL FuVal (igfz, z1, dummy, Zp(K), 0d0, rgfz, 0d0)
+               IF (z1.lt.zi .and. (qLin .or. z1.gt.0)) zi = z1
+               zf = dmax1 (zf, z1)
+               ENDDO
+            IF (qLin) THEN
+               CALL RoundLin (zi, zf, .052d0, 2)
+            ELSE
+               CALL RoundLog (zi, zf, .1d0, 1)
+               ENDIF
+            GOTO 24
+
+         ELSEIF (action.eq.'x') THEN ! revise 'x'
+            GOTO 22
+
+            ENDIF 
+
+ 25      CONTINUE 
+
+         ! Now install the chosen axes and proceed to plot them:
+         CALL GraSetAxs (Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+
+         CALL GraPlotCS (Fehler)
+         IF (Fehler.ne.'&ff') RETURN 
+         iK = 0
+
+         ENDIF ! qPlotNew
+
+C  Proceed to plot (loop files / spectra) :
+      DO lj = 1, nJList
+         j = JList(lj)
+         qFileNew = .true.
+
+         nK = iOlfG (j, '#spectra', Fehler)
+         CALL tOlfG (j, 'fil', file,  Fehler)
+         CALL tOlfG (j, 'tit', title, Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+
+         qCurve = qOlfGdef (j, '?cu', 0, Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+         IF (qCurve) THEN
+            ifc     = iOlfG (j, 'fu#', Fehler)
+            qConv   = qOlfG (j, '?conv', Fehler)
+            jparin  = iOlfGdef (j, 'fit-par-file#', 0, Fehler)
+            nplopts = iOlfGdef (j, 'plot-#pts', 100, Fehler)
+            ri      = rOlfGdef (j, 'plot-i', Un, 0.d0, Fehler)
+            rf      = rOlfGdef (j, 'plot-f', Un, 0.d0, Fehler)
+            doc = '96/7'
+            IF (Fehler.ne.'&ff') RETURN
+            IF (qConv) THEN ! possibly with convolution
+               CALL GraQuit ()
+               j2 = jCuConvAsk (qCurve, qConv)
+               IF (j2.ne.0) THEN
+                  CALL GetK2K (j, j2, nK, K2K, Fehler)
+                  IF (Fehler.ne.'&ff') RETURN
+                  ENDIF
+            ELSE
+               j2 = 0
+               ENDIF
+            IF (jparin.ne.0) THEN
+               jpar = iAskDMu (' Parameter file', jparin, 0, MF)
+               IF (jpar.le.0) THEN
+                  Fehler = ' '
+                  RETURN
+                  ENDIF 
+               IF (jpar.ne.jparin) THEN
+                  CALL OlfOpen (j, 1, Fehler)
+                  CALL iOlfP (j, 'fit-par-file#', jpar, Fehler)
+                  CALL OlfClos (j, nK, Fehler)
+                  ENDIF 
+               CALL GetK2K (j, jpar, nK, K3K, Fehler)
+               IF (Fehler.ne.'&ff') RETURN
+               ENDIF
+            ENDIF ! qCurve
+
+         IF (.not.qPlotNew .or. lj.gt.1) THEN
+            ! which spectra :
+            IF (Object.ne.' ') THEN
+               CALL DecJList (Object, MK, nK1, K1K, 1, nK, Fehler)
+               lisK = Object
+               IF (nK1.le.0 .or. Fehler.ne.'&ff') RETURN
+            ELSEIF (nK.eq.1) THEN
+               K1K(1) = 1
+               nK1 = 1
+            ELSE
+               lisKold = lisK
+               CALL GraQuit ()
+               CALL Compose2 (aus, ' Plot which of the '//cl3(nK), ' spectra')
+               CALL GetJList (aus, lisK, MK, nK1, K1K, 1, nK)
+               IF (nK1.le.0) THEN
+                  lisK = lisKold ! old default
+                  Fehler = ' '
+                  RETURN
+                  ENDIF
+               ENDIF
+            ENDIF
+
+         ! loop spectra :
+         isy = iOlfGdef (j, 'plot-sy#', 0, Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+         DO jK1 = 1, nK1
+            ! to avoid excessive waiting :
+            IF (isy.le.0 .and. jK1.eq.2 .and. nK1.gt.18 .and. ndim.ne.3) THEN
+               CALL GraQuit ()
+               CALL Compose2 (aus, ' Plot '//cl3(nK1-1), ' more spectra')
+               IF (.not.qAskD(aus, 1)) THEN
+                  Fehler = ' '
+                  RETURN
+                  ENDIF
+               ENDIF
+            K = K1K(jK1)
+            CALL OlfGetXYD (j, K, nC, X, Y, D, Fehler)
+            CALL OlfGetZ (j, K, nZ, Z, Fehler)
+            IF (Fehler.ne.'&ff') RETURN
+            IF (nC.eq.0) THEN
+               Fehler = ' spectrum is empty'
+               RETURN
+               ENDIF 
+   
+            IF (qCurve) THEN ! plot curve
+               ! x-range :
+               CALL GraInquireCS ('x', xmi, xma, igfx, gfpx, liloX)
+               IF (ri.ne.rf) THEN
+                  xmi = dmax1 (xmi, ri)
+                  xma = dmin1 (xma, rf)
+                  ENDIF
+               ! y-stepwidth :
+               CALL GraInquireCS ('y', ymi, yma, igfy, gfpy, liloY)
+               relY = 6.d0 / nplopts ! maximum y-step
+               ! do everything in i6.f :
+   
+               CALL CuNice (ifc, Y, j2, K2K(K), jpar, K3K(K),
+     *                      xmi, xma, igfx, gfpx, liloX,
+     *                      ymi, yma, igfy, gfpy, liloY,
+     *                      nplopts, relY,
+     *                      MC, nC1, X1, Y1, D1, Fehler)
+               IF (Fehler.ne.'&ff') RETURN 
+               CALL GraPaint (X1, Y1, D1, nC1, Z(1), isy, iLS)
+
+            ELSE ! plot data
+               iK = iK + 1
+               IF (iK.ge.100) iK = 1 ! to avoid overflow of &sy
+               IF (isy.eq.0) THEN ! default
+                  IF (ndim.eq.3) THEN
+                     iLSdef =  1   ! always straight lines
+                  ELSE
+                     iLSdef = -iK  ! incremental plot symbols
+                     ENDIF
+               ELSE ! plotsymbol is file-parameter
+                  iLSdef = isy
+                  ENDIF
+               CALL GraPaint (X, Y, D, nC, Z(1), iLSdef, iLS)
+               ENDIF
+
+            IF (iLS.eq.0) RETURN ! user's choice : draw nothing
+
+            IF (Fehler.ne.'&ff') RETURN
+            DO iZ = 1, nZ 
+               CALL OlfCnuG (j, 'z'//cl2(iZ), CoZ(iZ), UnZ(iZ), Fehler)
+               IF (Fehler.ne.'&ff') RETURN 
+               ENDDO 
+
+            ! == display some text lines on the screen == !
+            IF (qFileNew) THEN ! display name of file
+               CALL GraText (file, 1)
+               CALL GraText (' ', 1)
+               ENDIF
+            IF (ndim.eq.2) THEN ! some info for each spectrum
+               aus = cr3(j)//'#'//cl3(K)
+               IF (iLS.lt.0) THEN
+                  CALL GraText ('&sy='//cv2(-iLS)//aus, 1)
+               ELSEIF (iLS.gt.0) THEN
+                  CALL GraText ('&li='//cv2( iLS)//aus, 1)
+                  ENDIF
+               IF (nK.gt.1) THEN ! display z 
+                  DO iZ = 1, nZ
+                     CALL NiceNum (Z(iZ), hilf, ia)
+                     aus = CoZ(iZ)
+                     CALL Append (aus, ' = '//hilf(1:ia)//' '//UnZ(iZ) )
+                     CALL GraText (aus, 1)
+                     ENDDO 
+                  ENDIF
+               ENDIF 
+            CALL GraText (' ', 1) ! empty line
+ 
+            ! == text for register == !
+            ! head line : fname, doc, title
+            IF (qFileNew) THEN
+               CALL Compose3 (aus, file, ',  '//title, '    '//doc)
+               CALL GraText (aus, 2)
+               ENDIF
+            ! encode graphic symbol :
+            IF (iLS.lt.0) THEN
+               aus = '&sy='//cv2(-iLs )
+            ELSE
+               aus = '&li='//cv2( iLS )
+               ENDIF
+            ! list of spectra, z, parameters if curve :
+            IF (qCurve) THEN ! print parameters (11sep91, wurde auch Zeit) 
+               tline0 = ' ' ! head line (1/file)
+               tline1 = ' ' ! data line (1/spectrum)
+               ! First 3 columns : linestyle, K, z :
+               tline1(2:9) = aus ! linestyle
+               IF (nK.gt.1) THEN ! K, z
+                  tline1(10:12) = cl3(K)
+                  Write(tline1(13:24), '(g12.4e2)') Z(1)
+                  CALL Compose3 (aus, '# '//CoZ(1), '('//UnZ(1), ')')
+                  tline0(15:80) = aus ! (1:14) remain empty
+                  jipar = 24
+                  nCoutmax = 18
+               ELSE 
+                  jipar = 12
+                  nCoutmax = 19
+                  ENDIF 
+               ! Following columns : curve-parameters
+               nCout = min0 (nCoutmax, nC) ! # parameters that can be printed
+               DO i = 1, nCout
+                  ! could be fine-tuned (more place if nCout<5)
+                  ji = jipar + i*12-11 
+                  jf = jipar + i*12
+                  IF (qFileNew) THEN ! names of parameters
+c                     IF (qintr(i-Par(20+i))) THEN
+c                        tline0(ji:ji) = '='  ! fix
+c                     ELSE
+c                        tline0(ji:ji) = '!'  ! free
+c                        ENDIF
+                     CALL OlfCnuG (j, 'p'//cl2(i), CoP, UnP, Fehler)
+                     tline0(ji+1:jf) = CoP
+                     ENDIF
+                  Write (hilf,'(g12.4e2)') Y(i)
+                  tline1(ji:jf) = hilf
+               ENDDO
+               IF (qFileNew) CALL GraText (tline0, 2)
+               CALL GraText (tline1, 2)
+            ELSE ! no curve
+               IF (nK.gt.1) THEN ! name and value of z
+                  CALL Append (aus, '# '//cl3(K))
+                  CALL Append (aus, ' :')
+                  DO iZ = 1, nZ
+                     CALL NiceNum (Z(iZ), hilf, ia)
+                     IF (iZ.gt.1) CALL Append (aus, ',')
+                     CALL Append (aus, ' '//CoZ(iZ))
+                     CALL Append (aus, ' = '//hilf(1:ia)//' '//UnZ(iZ) )
+                     ENDDO 
+                  ENDIF
+               CALL GraText (aus, 2)
+               ENDIF ! qCurve
+            
+            qFileNew = .false.
+ 629        CONTINUE
+            ENDDO ! loop spectra
+
+            ! == file-info for register == !
+            i = 1
+ 71         CONTINUE 
+               CALL OlfComLinG (j, i, line, Fehler)
+               IF (Fehler.ne.'&ff') RETURN
+               IF (line.eq.'&eoc') GOTO 79
+               CALL GraText ('  '//line(1:lenU(line)), 2) ! comment
+               i = i + 1
+               GOTO 71
+ 79         CONTINUE    
+
+         ENDDO ! loop files
+
+      CALL GraQuit ()
+
+      END ! IdaPlot

arch/frida-1.4/i10.f

+C  ====================================================================
+C
+C      Program  IDA   :  Inelastic Data Analysis
+C      Modul    i10   :     input / output
+C
+C  ====================================================================
+
+C     Contents :
+C
+C        1.  Load / save files:
+C               FileLoad, FileReadOld, FileSave
+C
+C        2.  File access:
+C               AskPath, OpenIdaFile
+C
+C        3.  Read / write in '96 format:
+C               FileWrite96, FileRead96
+C
+C        4.  Read old data files:
+C               ['92 formats] LoadSpectrum92, i/r/tOlfPold
+C               [IED format]  ReadIED(sub)
+
+C  ====================================================================
+C  i10 / 1 :   Read / write file (interface to on-line-memory)
+C  ====================================================================
+
+      SUBROUTINE FileLoad (Object, Fehler)
+C     ------------------------------------
+         ! Read data files and store the contents
+
+      IMPLICIT REAL*8   (a-h,o-p,r-z)
+      IMPLICIT LOGICAL  (q)
+
+      CHARACTER*(*) Object, Fehler
+
+      INCLUDE 'i_dim.f'
+      INCLUDE 'l_def.f'
+
+      INTEGER       iPar(MP)
+      REAL*8        rPar(MP)
+      CHARACTER*40  tPar(MP), FilExt, DirExt, FilInt, DirInt
+      REAL*8        X(MC), Y(MC), D(MC)
+      CHARACTER*79  aus, Path
+      DATA          DirExt /' '/
+
+      IF (Fehler.ne.'&ff') THEN
+         Print *, 'FileLoad/ error on entry'
+         RETURN
+         ENDIF
+
+C  Loop files :
+      qLoop = .false. 
+      iProtect = 0
+ 1    CONTINUE
+         IF     (Object.eq.' ') THEN ! interactive loop
+            aus = ' Load file'
+            FilExt= ' '
+            qLoop = .true.
+         ELSEIF (Object(1:5).eq.'&int ') THEN ! internal (e.g. for numtab)
+            aus = '&noq'
+            DirExt = ' '
+            FilExt = Object(6:lenU(Object))
+            iProtect = 4
+         ELSE 
+            aus = '&noq'
+            FilExt = Object
+            ENDIF
+ 2       CALL AskPath (aus, FilExt, DirExt, Path, Fehler)
+         IF (Path.eq.' ') RETURN
+
+         CALL OpenIdaFile (31, Path, iFormat, Fehler)
+         IF (Fehler.eq.'&fnf') THEN
+            CALL Gong(1)
+            Print *, 'Cannot find data file '//Path
+            Fehler = '&ff'
+            aus = ' Load file'
+            GOTO 2
+            ENDIF
+         IF (Fehler.ne.'&ff') RETURN
+
+         CALL OlfCreate (jout, Kout, '&noask', '&noask', Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+
+         IF (iFormat.eq.960) THEN
+            CALL FileRead96 (31, jout, nK, Fehler)
+         ELSE
+            CALL FileReadOld (31, iFormat, Path, jout, nK, Fehler)
+            ENDIF
+         IF (Fehler.ne.'&ff') RETURN
+
+         ! update internal file name and directory :
+         CALL tOlfG (jout, 'fil', FilInt, Fehler)
+         CALL tOlfG (jout, 'dir', DirInt, Fehler)
+         IF (Fehler.ne.'&ff') THEN
+            Fehler = '&ff' ! no file or dir name given -> na und ?
+         ELSE
+            ! c96/7 add a comment
+            ENDIF
+         CALL tOlfP (jout, 'fil', FilExt, Fehler)
+         CALL tOlfP (jout, 'dir', DirExt, Fehler)
+
+         CALL OlfClos (jout, nK, Fehler)
+         CALL MemFileStatP (jout, iProtect, Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+
+C  End of loop - next file ?
+      IF (qLoop) GOTO 1
+
+      END ! FileLoad
+
+      SUBROUTINE FileReadOld (NU, iFormat, Path, jout, Kout, Fehler)
+C     --------------------------------------------------------------
+         ! Read data files and store the contents
+
+      IMPLICIT REAL*8   (a-h,o-p,r-z)
+      IMPLICIT LOGICAL  (q)
+      INCLUDE 'i_dim.f'
+      INCLUDE 'l_def.f'
+      CHARACTER*(*) Path, Fehler
+      INTEGER       iPar(MP)
+      REAL*8        rPar(MP)
+      CHARACTER*40  tPar(MP), null
+      REAL*8        X(MC), Y(MC), D(MC)
+      CHARACTER*79  aus
+
+C  Loop spectra :
+      nK = 0
+      DO K = 1, MK+1
+         CALL LoadSpectrum92 (NU, Path, iFormat, K, nK, iPar, rPar, tPar,
+     *                         z, MC, n, X, Y, D, Fehler)
+         IF (Fehler.ne.'&ff') THEN
+            RETURN
+         ELSEIF (nK.gt.0) THEN
+            RETURN ! eof - regular exit
+         ELSEIF (K.gt.MK) THEN
+            Fehler = 'File contains more than '//cr3(MK)//' spectra'
+            RETURN
+            ENDIF
+
+         IF (K.eq.1) THEN
+            CALL iOlfPold (jout, iPar, Fehler)
+            CALL rOlfPold (jout, rPar, Fehler)
+            CALL tOlfPold (jout, tPar, Fehler)
+            IF (Fehler.ne.'&ff') RETURN
+            DO ip = 11, iPar(11)
+               IF (tPar(ip).ne.' ' .and. tPar(ip).ne.null)
+     *             CALL OlfComAddFull (jout, ' ', tPar(ip), 0, Fehler)
+               ENDDO 
+            ENDIF
+         CALL OlfPutSpe (jout, K, 1, z, n, X, Y, D, Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+         ENDDO
+
+      Fehler = 'FileReadOld/ unexpectedly K>MK'
+
+      END ! FileReadOld
+
+      SUBROUTINE FileSave (nJList, JList, Fehler)
+C     -------------------------------------------
+         ! Completely new 11-nov96
+      
+      IMPLICIT NONE
+      INCLUDE      'l_def.f'
+      CHARACTER*(*) Fehler*(*)
+      CHARACTER*40  FilInt, DirInt, FilExt, DirExt, FilJ, DirJ
+      CHARACTER*80  Path
+      CHARACTER     stat*2
+      INTEGER       nJList, JList(*), lj, j, jj, MemBlockInq
+      LOGICAL       qOvFD, qOvKWTD
+      DATA          stat /'n!'/
+
+      IF (nJList.le.0) THEN
+         Fehler = ' '
+         RETURN
+         ENDIF
+
+      qOvKWTD = .false. ! overwrite: know-what-to-do
+      DO lj = 1, nJList
+         j = JList(lj)
+
+         CALL tOlfG (j, 'fil', FilInt, Fehler)
+         CALL tOlfG (j, 'dir', DirInt, Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+
+         ! default :
+         FilExt = FilInt
+         DirExt = DirInt
+
+         CALL AskOpenDatFile (' Write to file ', 32, FilExt, DirExt, 'i96',
+     *                        stat, 'seq', 'for', 0)
+         IF (FilExt.eq.' ') THEN ! legal emergency exit
+            Fehler = ' '
+            RETURN
+            ENDIF
+
+         IF (FilExt.ne.FilInt .or. DirExt.ne.DirInt) THEN
+            IF (.not.qOvKWTD) qOvFD = .true.
+c ausser Betrieb : = qAskD (' Overwrite internal file/dir', intq(qOvFD))
+            qOvKWTD = .true.
+            IF (qOvFD) THEN
+               CALL tOlfP (j, 'fil', FilExt, Fehler)
+               CALL tOlfP (j, 'dir', DirExt, Fehler)
+               ENDIF
+            ENDIF
+
+         ! here a switch between data formats ?
+         CALL FileWrite96 (32, j, Fehler)
+         Close (32) ! close the file also in case of write-out error (feb99)
+         IF (Fehler.ne.'&ff') RETURN
+
+         ! Update status bit (4mar98) :
+         CALL MemFileBitP (j, 1, 0, Fehler)
+         IF (Fehler.ne.'&ff') RETURN 
+         DO jj = 1, MemBlockInq ('nF')
+            IF (jj.ne.j) THEN 
+               CALL tOlfG (jj, 'fil', FilJ, Fehler)
+               CALL tOlfG (jj, 'dir', DirJ, Fehler)
+               IF (Fehler.ne.'&ff') RETURN 
+               IF (FilJ.eq.FilExt .and. DirJ.eq.DirExt)
+     *            CALL MemFileBitP (jj, 1, 1, Fehler)
+               ENDIF 
+            ENDDO
+
+         ENDDO ! lj
+
+      END ! FileWrite
+
+C  ====================================================================
+C  i10 / 2 :   File access
+C  ====================================================================
+            ! old LoadSpectrum splitted in subroutines 10nov96
+
+      SUBROUTINE AskPath (Quest, File, Dir, Path, Fehler)
+C     ---------------------------------------------------
+         ! ask for File, optionally change Dir, construct Path=Dir/File
+
+      CHARACTER*(*) Quest, File, Dir, Path, Fehler
+      CHARACTER*80  aus
+
+      IF (Quest.ne.'&noq') THEN
+ 21      CONTINUE 
+         IF (Dir.ne.' ' .and. Dir.ne.'&nod') THEN 
+            CALL Compose2 (aus, Quest,
+     *         ' (dir=' // Dir(1:lenU(Dir)) // ') ?')
+         ELSE 
+            CALL Compose2 (aus, Quest, ' ?')
+            ENDIF
+         CALL FrageC (aus, File)
+         ! directory command given ?
+         IF (File(1:3).eq.'cd ' .and. Dir.ne.'&nod') THEN
+            Dir = File(4:len(File))
+            CALL DelLeft (Dir)
+            GOTO 21
+            ENDIF 
+         ENDIF
+      IF (File.eq.' ') THEN
+         Path = ' ' ! no file wanted
+         RETURN
+         ENDIF
+      ! construct full path name (2sep93, 3dec93 here) :
+      IF (Dir.ne.' ' .and. Dir.ne.'&nod') THEN
+         CALL Compose2 (Path, Dir, '/'//File)
+      ELSE 
+         Path = File
+         ENDIF 
+
+      END ! AskPath
+
+      SUBROUTINE OpenIdaFile (NU, Path, iFormat, Fehler)
+C     --------------------------------------------------
+         ! try to open ida file and determine its format
+            ! from 1996 on, a new format means always a new extension,
+            ! which simplifies this routine as well as file maintenance.
+
+      CHARACTER*(*) Path, Fehler
+      CHARACTER     Code*8
+
+      IF (Fehler.ne.'&ff') RETURN
+      Code = '&eof'
+
+      ! first attempt: try extension .i96 (must be ASCII-96)
+      CALL OpenFile (NU, Path, 'i96', 'a', Fehler)
+      IF (Fehler.eq.'&ff') THEN
+         Read (NU,  '(a8)', err=20) Code
+         IF (Code.eq.'ASCII-96') THEN ! successfully opened
+            iFormat = 960
+            RETURN ! success
+            ENDIF
+ 20      Close (NU)
+         Fehler = ' .i96-file has illegal format code '//Code
+         RETURN
+         ENDIF
+      Fehler = '&ff'
+
+      ! second attempt: try extension .dat, code binary92
+      CALL OpenDatFile (NU, Path, 'dat', 'l', 'seq', '-cc', -1, Fehler)
+      IF (Fehler.eq.'&ff') THEN
+         Read (NU, err=30) Code
+         IF (Code.eq.'binary92') THEN ! successfully opened
+            iFormat = 921
+            RETURN ! success
+            ENDIF
+ 30      Close (NU) ! .dat, but not binary92
+         ! in that case, .dat is a very old ascii file
+         CALL OpenFile (NU, Path, 'dat', 'a', Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+         GOTO 80
+         ENDIF
+      Fehler = '&ff'
+            
+      ! last attempt : extension .asc
+      CALL OpenFile (NU, Path, 'asc', 'a', Fehler)
+      IF (Fehler.ne.'&ff') THEN
+         Fehler = '&fnf' ! file-not-found
+         RETURN
+         ENDIF
+
+ 80   CONTINUE ! now an ascii-file is open: 
+      Read (NU, '(a8)', err=1012) Code
+      IF (Code.eq.'ASCII-92') THEN
+         iFormat = 922
+         RETURN
+      ELSE
+         Print *, ' Code = ', Code
+         ENDIF
+ 1012 CONTINUE  ! 21jul92 : error 1011 occured in some old files
+      iFormat = 890 ! or 893 or ...
+      Close(NU) ! there is no code : rewind, and reopen later (must be .dat)
+      RETURN
+
+      END ! OpenIdaFile
+
+C  ====================================================================
+C  i10 / 3 :   Write / read files in '96 format
+C  ====================================================================
+
+      SUBROUTINE FileWrite96 (NU, j, Fehler)
+C     --------------------------------------
+            ! Completely new 11-nov96
+         ! Write internal file j to external unit 32
+      
+      IMPLICIT NONE
+      INCLUDE      'i_dim.f'
+      INCLUDE      'l_def.f'
+      CHARACTER*(*) Fehler*(*)
+      CHARACTER     co*24, un*24, lab*12, line*80,
+     *              format*24, format2*24, format3*24
+      INTEGER       NU, j, np, n, i, ival, iOlfG, nK, K, nZ
+      REAL*8        rval, rOlfG, Z(MZ), z1, X(MC), Y(MC), D(MC)
+
+      Write (NU, '(a8)', err=90) 'ASCII-96'
+
+      ! block 2: t-par's
+      format = '(a24,a56)'
+      Write (NU, '(a)', err=91) format
+      np = 0
+ 21   CONTINUE 
+         co   = '&pbn '//cv3(np+1)
+         CALL tOlfG (j, co, line, Fehler)
+         IF (Fehler.ne.'&ff') RETURN 
+         IF (co.eq.'&eop') GOTO 29
+         np = np + 1
+         IF (co.eq.'&empty') GOTO 21
+         Write (NU, format, err=91) co, line
+         GOTO 21
+ 29   CONTINUE 
+      Write (NU, '(a),err=91') '&eob 2 (end of block)  ------------------------'
+      
+      ! block 3: i-par's
+      format = '(a24,i16)'
+      Write (NU, '(a)', err=91) format
+      np = 0
+ 31   CONTINUE 
+         co   = '&pbn '//cv3(np+1)
+         ival = iOlfG (j, co, Fehler)
+         IF (Fehler.ne.'&ff') RETURN 
+         IF (co.eq.'&eop') GOTO 39
+         np = np + 1
+         IF (co.eq.'&empty') GOTO 31
+         Write (NU, format,err=91) co, ival
+         GOTO 31
+ 39   CONTINUE 
+      Write (NU, '(a)') '&eob 3 (end of block)  ------------------------'
+      
+      ! block 4: r-par's
+      format = '(a24,a24,g20.10)'
+      Write (NU, '(a)',err=91) format
+      np = 0
+ 41   CONTINUE 
+         co   = '&pbn '//cv3(np+1)
+         rval = rOlfG (j, co, un, Fehler)
+         IF (Fehler.ne.'&ff') RETURN 
+         IF (co.eq.'&eop') GOTO 49
+         np = np + 1
+         IF (co.eq.'&empty') GOTO 41
+         Write (NU, format,err=91) co, un, rval
+         GOTO 41
+ 49   CONTINUE 
+      Write (NU, '(a)') '&eob 4 (end of block)  ------------------------'
+      
+      ! block 5: coord's
+      format = '(a4,a24,a24)'
+      Write (NU, '(a)',err=91) format
+      np = 0
+ 51   CONTINUE 
+         lab   = '&pbn '//cv3(np+1)
+         CALL OlfCnuG (j, lab, co, un, Fehler)
+         IF (Fehler.ne.'&ff') RETURN 
+         IF (lab.eq.'&eop') GOTO 59
+         np = np + 1
+         IF (lab.eq.'&empty') GOTO 51
+         Write (NU, format,err=91) lab, co, un
+         GOTO 51
+ 59   CONTINUE 
+      Write (NU, '(a)',err=91) '&eob 5 (end of block)  ------------------------'
+
+      ! block 6: long-doc
+      format = '(a80)'
+      Write (NU, '(a)',err=91) format
+      np = 1
+ 61   CONTINUE 
+         CALL OlfComLinG (j, np, line, Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+         IF (line.eq.'&eoc') GOTO 69
+         Write (NU, format,err=91) line
+         np = np + 1
+         GOTO 61
+ 69   CONTINUE    
+      Write (NU, '(a)',err=91) '&eob 6 (end of block)  ------------------------'
+
+      ! data blocks
+      nK = iOlfG (j, '#spectra', Fehler)
+      nZ = iOlfG (j, '#Z', Fehler)
+      format = '(2i8)'
+      format2= '(i16,4g16.8/5g16.8)'
+      format3= '(3(2x,g16.8))'
+      Write (NU, '(a)',err=91) format
+      Write (NU, '(a)',err=91) format2
+      Write (NU, '(a)',err=91) format3
+      Write (NU, format,err=91) nK, nZ
+      DO K = 1, nK
+         Write (NU, '(a,i3)',err=91) '&spectrum ', K
+         CALL OlfGetSpe (j, K, nZ, Z, n, X, Y, D, Fehler)
+         Write (NU, format2, err=91) n, (Z(i), i=1,nZ)
+         Write (NU, format3, err=91) (X(i),Y(i),D(i), i=1,n)
+         ENDDO 
+
+      RETURN 
+
+ 90   Fehler = 'write error in 1st line (disk full or something worse ??)'
+      RETURN 
+ 91   Fehler = 'write error (disk full ?)'
+      RETURN 
+
+      END ! FileWrite96  
+
+      SUBROUTINE FileRead96 (NU, j, nK, Fehler)
+C     -----------------------------------------
+            ! Completely new 11-nov96
+         ! Get internal file j from external unit 32
+      
+      IMPLICIT NONE
+      INCLUDE      'i_dim.f'
+      INCLUDE      'l_def.f'
+      CHARACTER*(*) Fehler*(*)
+      CHARACTER     co*24, un*24, lab*12, line*80, 
+     *              format*24, format2*24, format3*24
+      INTEGER       NU, j, n, i, np, nK, K, nZ, nZlab, ival, iOlfG
+      REAL*8        rval, rOlfG, Z(MZ), z1, X(MC), Y(MC), D(MC)
+
+      ! block 2: t-par's
+      Read (NU, '(a)', err=921) format
+      np = 0
+ 21   CONTINUE 
+         Read (NU, format, err=922) co, line
+         IF (co(1:4).eq.'&eob') GOTO 29
+         CALL tOlfP (j, co, line, Fehler)
+         IF (Fehler.ne.'&ff') RETURN 
+         GOTO 21
+ 29   CONTINUE 
+      
+      ! block 3: i-par's
+      Read (NU, '(a)', err=931) format
+ 31   CONTINUE 
+         Read (NU, '(a)', err=932) line
+         IF (line(1:4).eq.'&eob') GOTO 39
+         read (line, format, err=933) co, ival
+         CALL iOlfP (j, co, ival, Fehler)
+         IF (Fehler.ne.'&ff') RETURN 
+         GOTO 31
+ 39   CONTINUE 
+      
+      ! block 4: r-par's
+      Read (NU, '(a)', err=941) format
+ 41   CONTINUE 
+         Read (NU, '(a)', err=942) line
+         IF (line(1:4).eq.'&eob') GOTO 49
+         read (line, format, err=943) co, un, rval
+         CALL rOlfP (j, co, un, rval, Fehler)
+         IF (Fehler.ne.'&ff') RETURN 
+         GOTO 41
+ 49   CONTINUE 
+      
+      ! block 5: coord's
+      Read (NU, '(a)', err=951) format
+      nZlab = -2
+ 51   CONTINUE 
+         Read (NU, format, err=952) lab, co, un
+         IF (lab(1:4).eq.'&eob') GOTO 59
+         IF (lab.eq.'z') lab = 'z1'
+         IF (co.eq.' ') THEN 
+            co = '? [empty coordinate name in ASCII-96 file]'
+            ENDIF 
+         CALL OlfCnuP (j, lab, co, un, Fehler)
+         nZlab = nZlab + 1
+         IF (Fehler.ne.'&ff') RETURN 
+         GOTO 51
+ 59   CONTINUE 
+
+      ! block 6: long-doc
+      Read (NU, '(a)', err=961) format
+ 61   CONTINUE 
+         Read (NU, format, err=962) line
+         IF (line(1:4).eq.'&eob') GOTO 69
+         CALL OlfComAddFull (j, ' ', line, 0, Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+         GOTO 61
+ 69   CONTINUE    
+
+      ! data blocks
+      Read (NU, '(a)',err=971) format
+      Read (NU, '(a)',err=971) format2
+      Read (NU, '(a)',err=971) format3
+      Read (NU, format,err=972) nK, nZ
+      IF (nZ.gt.nZlab) THEN 
+         Print *, 'incorrect data format: adding name(s) for z coordinate(s)'
+         DO i = nZlab+1, nZ
+            CALL OlfCnuP (j, 'z'//cl2(i),
+     *           '? [unlabelled coordinate in ASCII-96 file]', ' ', Fehler)
+            IF (Fehler.ne.'&ff') RETURN
+            ENDDO 
+      ELSEIF (nZ.lt.nZlab) THEN
+         Print *, 'WARNING/ unused z-labels in input file/ nZ nZlab ', nZ, nZlab
+         ENDIF 
+      DO K = 1, nK
+         Read (NU, '(a)',err=973) line
+         IF (line(1:9).ne.'&spectrum') THEN
+            Fehler = 'missed beginning of spectrum'
+            RETURN 
+            ENDIF 
+         Read (NU, format2, err=975) n, (Z(i), i=1,nZ)
+         IF (n.gt.MC) THEN
+            Print *, ' nC, MC: ', n, MC
+            Fehler = ' too many channels/ recompile with bigger MC'
+            RETURN 
+            ENDIF
+         Read (NU, format3, err=976) (X(i),Y(i),D(i), i=1,n)
+         CALL OlfPutSpe (j, K, nZ, Z, n, X, Y, D, Fehler)
+         IF (Fehler.ne.'&ff') THEN 
+            Print *, Fehler
+            Fehler = 'FileRead: cannot save spectrum '//cl6(K)
+            RETURN 
+            ENDIF 
+         ENDDO 
+
+      Close(NU)
+
+      RETURN 
+
+ 921  Fehler = 'read err 921'
+      RETURN 
+ 922  Fehler = 'read err 922'
+      RETURN 
+ 931  Fehler = 'read err 931'
+      RETURN 
+ 932  Fehler = 'read err 932'
+      RETURN 
+ 933  Fehler = 'read err 933'
+      RETURN 
+ 941  Fehler = 'read err 941'
+      RETURN 
+ 942  Fehler = 'read err 942'
+      RETURN 
+ 943  Fehler = 'read err 943'
+      RETURN 
+ 951  Fehler = 'read err 951'
+      RETURN 
+ 952  Fehler = 'read err 952'
+      RETURN 
+ 961  Fehler = 'read err 961'
+      RETURN 
+ 962  Fehler = 'read err 962'
+      RETURN 
+ 971  Fehler = 'read err 971'
+      RETURN 
+ 972  Fehler = 'read err 972'
+      RETURN 
+ 973  Fehler = 'read err 973'
+      RETURN 
+ 975  Fehler = 'read err 975'
+      RETURN 
+ 976  Fehler = 'read err 976'
+      RETURN 
+
+      END ! FileRead96  
+
+C  ====================================================================
+C  i10 / 4 :   Read spectra from old data files
+C  ====================================================================
+
+C  --------------------------------------------------------------------
+C     read 92' formats
+C  --------------------------------------------------------------------
+
+      SUBROUTINE LoadSpectrum92 (NU, Path, iForm, K, nK, 
+     *                           iPar, rPar, tPar, 
+     *                           z, M, n, X, Y, D, Fehler)
+C     ----------------------------------------------------
+            ! JWu 4may92
+         ! Read one spectrum from a file in the old formats
+         !    921 = binary92
+         !    922 = ASCII-92
+         !    890 = IED / SQW
+         ! If K = 1 then open the file
+         !   (if Quest<>'&noq' then ask for its name),
+         ! if eof then close the file, and return nK>0.
+
+      IMPLICIT REAL*8   (a-h,o-p,r-z)
+      IMPLICIT LOGICAL  (q)
+
+      INCLUDE 'i_dim.f'
+      CHARACTER*40  tPar(MP)
+      DIMENSION     iPar(MP), rPar(MP), X(*), Y(*), D(*)
+      CHARACTER*(*) Path, Fehler
+      CHARACTER     aus*80, cl3*3, cl6*6
+
+C  Open File :
+      IF (K.eq.1) THEN
+
+C  Read header ?
+         IF     (iForm.eq.921) THEN
+            Read (NU, err=102) niP, (iPar(i), i=1, niP)
+            Read (NU, err=102) nrP, (rPar(i), i=1, nrP)
+            Read (NU, err=102) ntP, (tPar(i), i=1, ntP)
+         ELSEIF (iForm.eq.922) THEN
+            Read (NU, '(3(i4,2x))', err=1120) niP, nrP, ntP
+            DO i = 1, niP
+               Read (NU, '(i10)',  err=1121) iPar(i)
+               ENDDO
+            DO i = 1, nrP
+               Read (NU, '(g16.8)',err=1122) rPar(i)
+               ENDDO
+            DO i = 1, ntP
+               Read (NU, '(a40)',  err=1123) tPar(i)
+               ENDDO
+            ENDIF
+
+         ENDIF ! K=1
+
+      IF (nK.ne.0) CALL Absturz ('LoadSpectrum', 'someone manipulated nK')
+
+C  Read one spectrum :
+      IF (iForm.eq.921 .or. iForm.eq.922) THEN
+         IF (iForm.eq.921) THEN
+            Read (NU, err=103) n
+         ELSE
+            Read (NU, '(i8)', err=1131) n
+            ENDIF
+         IF (n.eq.-1) THEN
+            Close (NU)
+            GOTO 100 ! eof
+         ELSEIF (n.le.0) THEN
+            Fehler = 'Wrong entry : n<-2 or n=0 in spectrum '//cl3(K)
+            Close (NU)
+            RETURN
+         ELSEIF (n.gt.M) THEN ! variable M since 30oct92
+            Fehler = 'Spectrum too long : n = '//cl6(n)
+            Close (NU)
+            RETURN
+            ENDIF
+
+         IF (iForm.eq.921) THEN
+            Read (NU, err=103) z
+            Read (NU, err=104) (X(i), i=1, n)
+            Read (NU, err=105) (Y(i), i=1, n)
+            Read (NU, err=106) (D(i), i=1, n)
+         ELSE
+            Read (NU, '(g16.8)',      err=1132)  z
+            Read (NU, '(3(2x,g16.8))',err=1133) (X(i),Y(i),D(i), i=1,n)
+            ENDIF
+
+      ELSEIF (iForm.eq.890) THEN
+         CALL ReadIED (Path, K, iPar, rPar, tPar, z, M, n, X, Y, D, Fehler)
+         IF (Fehler.eq.'&eof') THEN
+            Fehler = '&ff'
+            GOTO 100
+         ELSEIF (Fehler.ne.'&ff') THEN
+            RETURN
+            ENDIF
+
+      ELSE
+         Fehler = ' LoadSpectrum92 with invalid format '//cl3(iForm)
+         RETURN
+         ENDIF
+
+      IF (tPar(7).eq.' ' .and. tPar(10).eq.' ') z = 0 ! to prevent z=..E-312
+      RETURN
+C  Regular exit.
+
+C  EOF condition :
+ 100  CONTINUE
+      nK = K-1
+      IF (nK.le.0) CALL Absturz (
+     *   'LoadSpectrum', 'eof in first spectrum')
+      RETURN
+
+C  Errors :
+c 101  CONTINUE    ! ausser Betrieb -- zur Zeit keine Fehlermeldung
+c      Fehler = ' File code could not be read'
+c      Close (NU)
+c      RETURN
+ 102  CONTINUE
+      Fehler = ' Error in header of binary file'
+      Close (NU)
+      RETURN
+ 103  CONTINUE
+      CALL Compose2 (Fehler,
+     *    ' Error while reading z in spectrum '//cl3(K),
+     *    ' of binary file')
+      Close (NU)
+      RETURN
+ 104  CONTINUE
+      CALL Compose2 (Fehler,
+     *    ' Error while reading X in spectrum '//cl3(K),
+     *    ' of binary file')
+      Close (NU)
+      RETURN
+ 105  CONTINUE
+      CALL Compose2 (Fehler,
+     *    ' Error while reading Y in spectrum '//cl3(K),
+     *    ' of binary file')
+      Close (NU)
+      RETURN
+ 106  CONTINUE
+      CALL Compose2 (Fehler,
+     *    ' Error while reading D in spectrum '//cl3(K),
+     *    ' of binary file')
+      RETURN
+ 1120 CONTINUE
+      Fehler = ' Error in parameter block header of ASCII file'
+      Close (NU)
+      RETURN
+ 1121 CONTINUE
+      Fehler = ' Error in integer parameter block of ASCII file'
+      Close (NU)
+      RETURN
+ 1122 CONTINUE
+      Fehler = ' Error in real parameter block of ASCII file'
+      Close (NU)
+      RETURN
+ 1123 CONTINUE
+      Fehler = ' Error in text parameter block of ASCII file'
+      Close (NU)
+      RETURN
+ 1131 CONTINUE
+      CALL Compose2 (Fehler,
+     * ' Error while reading n in spectrum '//cl3(K), ' of ASCII file')
+      Close (NU)
+      RETURN
+ 1132 CONTINUE
+      CALL Compose2 (Fehler,
+     * ' Error while reading z in spectrum '//cl3(K), ' of ASCII file')
+      Close (NU)
+      RETURN
+ 1133 CONTINUE
+      CALL Compose2 (Fehler,
+     * ' Error while reading X Y D in spectrum '//cl3(K),
+     * ' of ASCII file')
+      Close (NU)
+      RETURN
+
+      END ! LoadSpectrumOld
+
+C  --------------------------------------------------------------------
+C     translation <-> old data format
+C  --------------------------------------------------------------------
+
+      SUBROUTINE iOlfPold (j, iPar, Fehler)
+C     -------------------------------------
+
+      IMPLICIT NONE
+      INCLUDE      'i_dim.f'
+      CHARACTER*(*) Fehler
+      INTEGER       j, iPar(MP)
+
+      IF (Fehler.ne.'&ff') RETURN 
+                         CALL iOlfP (j, '?cu', iPar(3), Fehler)
+      IF (iPar( 4).ne.0) CALL iOlfP (j, 'fu#', iPar(4), Fehler)
+      IF (iPar( 5).ne.0) CALL iOlfP (j, '#fit-par', iPar(5), Fehler)
+      IF (iPar( 6).ne.0) CALL iOlfP (j, '?weight-stp-x', iPar(6), Fehler)
+      IF (iPar( 7).ne.0) CALL iOlfP (j, '?weight-err-y', iPar(7), Fehler)
+      IF (iPar( 8).ne.0) CALL iOlfP (j, 'fit-dat-file#', iPar(8), Fehler)
+      IF (iPar( 9).ne.0) CALL iOlfP (j, '@fixed', iPar(9), Fehler)
+      IF (iPar(12).ne.0) CALL iOlfP (j, '?det-bal-sym', iPar(12), Fehler)
+      IF (iPar(13).ne.0) CALL iOlfP (j, '@sam-erg-gain', iPar(13), Fehler)
+      IF (iPar(14).ne.0) CALL iOlfP (j, 'plot-#pts', iPar(14), Fehler)
+      IF (iPar(15).ne.0) CALL iOlfP (j, 'plot-sy#', iPar(15), Fehler)
+      IF (iPar(16).ne.0) CALL iOlfP (j, '?weight-log-y', iPar(16), Fehler)
+      IF (iPar(17).ne.0) CALL iOlfP (j, '?conv', iPar(17), Fehler)
+      IF (iPar(18).ne.0) CALL iOlfP (j, 'fit-par-file#', iPar(18), Fehler)
+
+      END ! iOlfPold
+
+      SUBROUTINE rOlfPold (j, rPar, Fehler)
+C     -------------------------------------
+      IMPLICIT NONE
+      INCLUDE      'i_dim.f'
+      CHARACTER*(*) Fehler
+      INTEGER       j
+      REAL*8        rPar(MP)
+
+      IF (Fehler.ne.'&ff') RETURN
+      IF (rPar( 1).ne.0) CALL rOlfP (j, '2th', ' ', rPar(1), Fehler)
+      IF (rPar( 2).ne.0) CALL rOlfP (j, 'E0', 'meV', rPar(2), Fehler)
+      IF (rPar( 3).ne.0) CALL rOlfP (j, 'q', 'A-1', rPar(3), Fehler)
+      IF (rPar( 4).ne.0) CALL rOlfP (j, 'L[fpi1]', 'mm', rPar(4), Fehler)
+      IF (rPar( 6).ne.0) CALL rOlfP (j, 'P', 'kbar', rPar(6), Fehler)
+      IF (rPar( 7).ne.0) CALL rOlfP (j, 'T', 'K', rPar(7), Fehler)
+      IF (rPar( 8).ne.0) CALL rOlfP (j, 'at-mass', 'amu', rPar(8), Fehler)
+      IF (rPar( 9).ne.0) CALL rOlfP (j, 'cts[mon]', ' ', rPar(9), Fehler)
+      IF (rPar(10).ne.0) CALL rOlfP (j, 't[scan]', 'sec/10 ?', rPar(10),Fehler) 
+      IF (rPar(14).ne.0) CALL rOlfP (j, 'plot-i', ' ', rPar(14), Fehler)
+      IF (rPar(15).ne.0) CALL rOlfP (j, 'plot-f', ' ', rPar(15), Fehler)
+      IF (rPar(16).ne.0) CALL rOlfP (j, 'fit-i', ' ', rPar(16), Fehler)
+      IF (rPar(17).ne.0) CALL rOlfP (j, 'fit-f', ' ', rPar(17), Fehler)
+
+      END ! rOlfPold
+
+      SUBROUTINE tOlfPold (j, tPar, Fehler)
+C     -------------------------------------
+
+      IMPLICIT NONE
+      INCLUDE 'i_dim.f'
+      CHARACTER*(*) Fehler
+      CHARACTER     tPar(MP)*40
+      INTEGER       j
+
+      CALL tOlfP (j, 'fil', tPar(1), Fehler)
+      CALL tOlfP (j, 'tit', tPar(2), Fehler)
+      CALL tOlfP (j, 'doc', tPar(3), Fehler)
+      CALL tOlfP (j, 'dir', tPar(4), Fehler)
+      CALL OlfCnuP (j, 'x', tPar(5), tPar( 8), Fehler)
+      CALL OlfCnuP (j, 'y', tPar(6), tPar( 9), Fehler)
+      IF (tPar(7).ne.' ') CALL OlfCnuP (j, 'z1', tPar(7), tPar(10), Fehler)
+      IF (Fehler.ne.'&ff') RETURN 
+
+      END ! tOlfPold
+
+C  --------------------------------------------------------------------
+C  read old IED format 
+C  --------------------------------------------------------------------
+            ! The IED format was used until May 92. 
+            ! It extended the ILL's SQW format (R.Gosh) to
+            ! which it was kept two-way-compatible.
+
+      SUBROUTINE ReadIED (File, K, iPar, rPar, tPar, 
+     *                    z, M, n, X, Y, D, Fehler)
+C     ----------------------------------------------
+            ! (JWu)15.1.91, 13.2.91 as ReadSpectrum (-> ReadCompact)
+            ! abbreviated nov96
+         ! If K=1, the parameter arrays will be set;
+         ! if K>1, they will be checked for consistency.
+         ! The reading of the data blocks is done in ReadIEDsub
+
+      IMPLICIT REAL*8   (a-h,o-p,r-z)
+      IMPLICIT LOGICAL  (q)
+      INCLUDE      'i_dim.f'
+      INTEGER       iPar(MP), iParIn(MP)
+      REAL*8        rPar(MP), rParIn(MP)
+      CHARACTER*40  tPar(MP), tParIn(MP)
+      REAL*8        X(*), Y(*), D(*)
+      CHARACTER*(*) File, Fehler
+      CHARACTER     cr2*2, cl2*2
+
+      IF (Fehler.ne.'&ff') CALL Absturz ('ReadSpectrum', 'err on entry')
+
+      IF (K.lt.1) CALL Absturz ('ReadSpectrum', 'K < 1 on entry')
+      qSet = (K.eq.1)
+
+      IF (qSet) THEN
+C  Open file :
+         CALL OpenFile (31, File, 'dat', 'l', Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+C  Set Par to 0 :
+         DO i = 1, MP
+            iParIn(i) = 0
+            rParIn(i) = 0.
+            tParIn(i) = '&-'
+            ENDDO
+         ENDIF
+      
+      tPar(1) = File
+      CALL ReadIEDsub  (31, iParIn(9), iParIn(1), iParIn(11), iParIn(12),
+     *                  rParIn(1), rParIn(2), rParIn(3), rParIn(9),
+     *                  rParIn(4), rParIn(5), rParIn(6), rParIn(7), rParIn(8),
+     *                  tParIn(2), tParIn(3), tParIn(5), tParIn(6), tParIn(7),
+     *                  tParIn(8), tParIn(9), tParIn(10),
+     *                  tPar(11), M, X, Y, D, Fehler)
+
+      IF (Fehler.eq.'&eof') THEN
+         IF (qSet) THEN
+            CALL Insert (Fehler, 1, 'file is completely empty')
+         ELSE
+            Close (31) ! Reached end of file
+            ENDIF
+         RETURN
+      ELSEIF (Fehler.ne.'&ff') THEN
+         ! Error occured :
+         CALL Insert (Fehler, 1, 'spectrum '//cr2(K)//' ')
+         RETURN
+         ENDIF
+
+      n = iParIn(1)
+
+      IF (qSet) THEN
+c96/7         iz = iParNumber(tParIn(7))
+c      ELSE
+         iz = iPar(10)
+         ENDIF
+      iParIn(10) = iz
+      z = rParIn(iz)
+      rParIn(iz) = 0.0
+
+      IF (qSet) THEN
+         DO i = 1, MP
+            iPar (i) = iParIn (i)
+            rPar (i) = rParIn (i)
+            tPar (i) = tParIn (i)
+            ENDDO
+      ELSE
+         IF (iParIn(1).ne.iPar(1)) iPar(1) = 0  ! nC
+         DO i = 3,MP
+            IF (iParIn(i).ne.iPar(i)) THEN
+               Print *, 'irregularity in iPar at i,K = ',
+     *                   i, K, ' : value = ', iParIn(i)
+               ENDIF
+            ENDDO
+         DO i = 1,MP
+            IF (rParIn(i).ne.rPar(i)) THEN
+               Print *, 'irregularity in rPar '//cl2(i)//
+     *               ' at K ='//cr2(K)//', value = ', rParIn(i)
+               rPar(i) = 0.
+               ENDIF
+            ENDDO
+         ENDIF
+
+      iPar ( 2) = K
+      iPar (10) = iz
+
+      END ! ReadIED
+
+      SUBROUTINE ReadIEDsub (NR, qToF, nC, ntpar, iSym,
+     *                       angle, E0, Q0, z, deltaE, deltaTau, deltaK,
+     *                       Temp, AMasse, HeadLine, Doc,
+     *                       xCoord, yCoord, zCoord, xUnit, yUnit, zUnit,
+     *                       Comment, M, X, Y, D, Fehler )
+C     -------------------------------------------------------------------
+            ! renewed 6.1.91, error messages 21.1.91
+
+      IMPLICIT REAL *8 (a-h,o-p,r-z)
+      IMPLICIT LOGICAL (q)
+
+      CHARACTER     muell*40, Fehler*(*), cr3*3
+      CHARACTER*40  xUnit, yUnit, zUnit, xCoord, yCoord, zCoord,
+     *              Headline, Doc, Comment(15)
+      REAL *8       X(*), Y(*), D(*), Q0
+      INTEGER       nKopf(8)
+
+      nTrial = 0
+ 11   CONTINUE
+      nTrial = nTrial + 1
+      IF (nTrial.gt.2) THEN
+         Fehler = 'ReadIED/ trapped in ToF-BS bubble'
+         RETURN
+         ENDIF
+
+C     Zone 0 :
+      Read (NR,'(8i5)', end=80, err=90)  nKopf
+
+C     Zone 1 :
+      Read (NR,'(1x,a39)', err=91)  Headline
+      IF (nKopf(2).gt.1) THEN
+      Read (NR,'(1x,a39)', err=91)  Doc
+      ELSE
+         Doc = ' '
+         ENDIF
+
+C     Zone 2 :
+      z = 0.0
+      Read (NR,'(1x,f6.2,f8.3,f8.4,f9.3,f6.1,i2,/'//
+     *          '3x,e13.5,3f8.4)', err=92)
+     *                   angle, E0, Q0, Temp, AMasse, iSym,
+     *                   z, DeltaE, DeltaTau, DeltaK
+
+C     Zone 3 :
+      IF     (nKopf(4).eq.0) THEN
+C        Special procedure for SQW/CrossX data :
+         xCoord = 'w'
+         xUnit  = 'meV'
+         yCoord = 'S(q,w)'
+         yUnit  = 'meV-1'
+         zCoord = '2Th'
+         zUnit  = ' '
+      ELSEIF (nKopf(4).eq.3) THEN
+C        For all other data : JWu-format :
+         Read (NR,'(1x,a27,a12)', err=93)  xCoord, xUnit
+         Read (NR,'(1x,a27,a12)', err=93)  yCoord, yUnit
+         Read (NR,'(1x,a27,a12)', err=93)  zCoord, zUnit
+      ELSE
+         GOTO 934
+         ENDIF
+
+C     Zone 4 :
+      DO i = 1, nKopf(5)
+         IF (i.le.10) THEN
+            Read (NR,'(1x,a39)', err=94)  Comment(i)
+         ELSE
+            Read (NR,'(1x,a39)', err=94)  muell
+            ENDIF
+         ENDDO
+      ntpar = 10 + min0 (nKopf(5), 15)
+
+C     Zone 5, 6 :
+      DO i = 1, nKopf(6)
+         Read (NR,'(1x,a39)', err=95)  muell
+         ENDDO
+      DO i = 1, nKopf(7)
+         Read (NR,'(1x,a39)', err=96)  muell
+         ENDDO
+
+C     Zone 7 :
+      nC = nKopf(8)
+      IF (nC.gt.M) GOTO 970
+
+         ! for standard SQW/CrossX as well as for own data :
+         ! by order of mufti :
+
+         ! qToF      <=> X /   1 <=> 'f9.5' <=> descending X
+         ! .not.qToF <=> X /1000 <=> 'f9.6' <=> ascending X
+
+C   DIVISION / 1000 NICHT PROGRAMMIERT !
+
+      IF (.not.qTOF) THEN
+ 103        FORMAT(6X,F9.6,E13.5,E12.4)
+         Read (NR,103, err=971) X(1),Y(1),D(1)
+         IF (nC.gt.1) THEN
+            Read (NR,103, err=972) X(2),Y(2),D(2)
+            qUpwards=(X(1).LE.X(2))
+            IF (.NOT.qUpwards) THEN
+               qTOF = .true.
+c               Print *, ' apparently reading TOF-data'
+               Rewind (NR)
+               GOTO 11
+               ENDIF
+            ENDIF
+      ELSE
+ 104        FORMAT(6X,F9.5,E13.5,E12.4)
+         Read (NR,104, err=971) X(1),Y(1),D(1)
+         IF (nC.gt.1) THEN
+            Read (NR,104, err=972) X(2),Y(2),D(2)
+            qUpwards=(X(1).LE.X(2))
+            IF (qUpwards) THEN
+               qTOF = .false.
+c               Print *, ' apparently reading backscattering-data'
+               Rewind (NR)
+               GOTO 11
+               ENDIF
+            ENDIF
+         ENDIF
+
+      IF (.not.qUpwards .and. nC.gt.1) THEN
+         X (nC+1-1)=X (1)
+         Y (nC+1-1)=Y (1)
+         D(nC+1-1)=D(1)
+         X (nC+1-2)=X (2)
+         Y (nC+1-2)=Y (2)
+         D(nC+1-2)=D(2)
+         ENDIF
+
+      DO iCh=3,nC
+         IF (qUpwards) THEN
+            i=iCh
+         ELSE
+            i=nC+1-iCh
+            ENDIF
+
+         IF (qTOF) THEN
+            Read (NR,104, err=97) X(i), Y(i), D(i)
+         ELSE
+            Read (NR,103, err=97) X(i), Y(i), D(i)
+            ENDIF
+
+         ENDDO
+
+C  For some units restoration of factor 100 or 1000 :
+      IF (xUnit.eq.'hK') THEN
+         xUnit = 'K'
+         DO i = 1, nC
+            X(i) = X(i) * 100
+            ENDDO
+         ENDIF
+      IF (xCoord.eq.'2Th/100') THEN
+         xCoord = '2Th'
+         DO i = 1, nC
+            X(i) = X(i) * 100
+            ENDDO
+         ENDIF
+
+      DO i = 1, nC
+         IF (D(i).lt.0.) THEN
+            D(i) = 0.
+            IF (.not.qWarn) THEN
+               Print *, ' data have negative error bars'
+               Print *, ' minderwertige Software benutzt ?'
+               CALL Gong (7)
+               ENDIF
+            qWarn = .true.
+         ENDIF
+      ENDDO
+      RETURN
+
+ 80   CONTINUE
+      Fehler = '&eof'
+      RETURN
+ 90   CONTINUE ! check whether format<>8i5 or file empty
+      Read (NR, '(a)', err=901) muell
+      Fehler = ' is no IED file (bad format in zone 0)'
+      RETURN
+ 901  Fehler = ' is empty'
+      RETURN
+ 91   Fehler = ' bad format in zone 1'
+      RETURN
+ 92   Fehler = ' bad format in zone 2'
+      RETURN
+ 93   Fehler = ' bad format in zone 3'
+      RETURN
+ 934  Fehler = ' has bad format : #lines (zone 3) <> 0,3'
+      RETURN
+ 94   Fehler = ' bad format in zone 4'
+      RETURN
+ 95   Fehler = ' bad format in zone 5'
+      RETURN
+ 96   Fehler = ' bad format in zone 6'
+      RETURN
+ 970  Fehler = ' spectrum too long'
+      RETURN
+ 971  Fehler = ' bad format in first data line'
+      RETURN
+ 972  Fehler = ' bad format in 2nd data line'
+      RETURN
+ 97   Fehler = ' bad format in zone 7 (data line'//cr3(iCh)//')'
+      RETURN
+      END ! ReadIEDsub

arch/frida-1.4/i20.f

+C  ====================================================================
+C
+C      Library  IDA   :  Inelastic Data Analysis
+C      Modul    i20   :     on-line memory
+C
+C  ====================================================================
+
+C     General information :
+C        Module written by J.Wuttke, jan/feb91
+C        Here I have reinvented the use of pointers and the dynamical
+C        allocation of memory. A little bit complicated, but it works.
+
+C        Completely new data format; almost everything rewritten mar/may95.
+
+C     Contents :
+C        1.  On-line memory / block level :
+C               MemBlockPut/Get/Inq/Num/Siz, 
+C               MemBlSubAdd/Del/Get/Put, MemRestInfo,
+C               MemDims, qMemFill, MemFileDel
+C                  ! these routines just handle a number of files consisting
+C                  ! of different blocks; they ignore everything about the
+C                  ! contents of the blocks.
+C        2.  On-line memory / status shell :
+C               MemFileStatP/G, MemFileBitP, MemBlockOvr
+C                  ! block(1) contains the status bits; the routines of this
+C                  ! level provide protected access to on-line files
+C        3.  On-line memory / data translation :
+C        4.  On-line memory / user shell :
+C               OlfOpen/Clos, OlfParP/G, OlfSpeP/G, OlfGet.., OlfPtrG, FileClean
+
+C     Aenderungsverzeichnis :
+C        JWu  6feb97 : Restructured in view of poly-z
+C        JWu 24nov96 : *Par replaced by direct labelling
+C        JWu  9nov96 : OlfParG/P in outer routines replaced by i/r/tOlfG/P
+C        JWu 17may95 : New structure has old functionality
+C        JWu 15mar95 : Block structure (preparations for major revision)
+C        JWu 25jan95 : Status bits (since feb91 only minor changes)
+C        JWu 26nov91 : Parameter qOpen [now iPar(20)(1)
+C        JWu 16sep91 : MemGet.. to replace SpectrumTake
+C        JWu 31jul91 : Interactive manipulations -> IDA3
+C        JWu 19jun91 : iOnext(0:MF)
+C        JWu   apr91 : Modulaufteilung
+C        JWu   feb91 : FileModif, SpectrumModif
+C        JWu   jan91 : on-line memory
+
+C  ====================================================================
+C     1.  On-line memory / low-level : access blocks
+C  ====================================================================
+
+      BLOCK DATA MemBlockPreset
+C     -------------------------
+
+      IMPLICIT NONE 
+      INCLUDE       'i_dim.f'
+      INTEGER        nF, nFB, nFA
+      REAL*8         FMem
+
+      COMMON / OLM / FMem(Mmem), nFA(0:MB*MF), nFB(0:MF), nF
+
+      DATA           nF / 0 /, nFB(0) / 0 /, nFA(0) / 0 /
+
+      END ! MemBlockPreset
+
+      SUBROUTINE MemBlockPut (j, k, n, R, Fehler)
+C     -------------------------------------------
+            ! JWu 15-17mar95 (reusing OlfOpen 23.1.91, 12.2.91)
+         ! Save R(1..n) as block k of file j in on-line memory
+
+      IMPLICIT NONE 
+      INCLUDE 'i_dim.f'
+      INCLUDE 'l_def.f'
+
+C  Parameters :
+      INTEGER       j, k, n
+      REAL*8        R(*)
+      CHARACTER     Fehler*(*)
+
+C  Internals :
+      INTEGER       jj, kk, kmx, kdel, i, ndel, nold
+
+C  Data / on-line memory / :
+      INTEGER       nF, nFB, nFA
+      REAL*8        FMem
+      COMMON / OLM / FMem(Mmem), nFA(0:MB*MF), nFB(0:MF), nF
+      
+C  Checks :
+      IF     (Fehler.ne.'&ff') THEN
+         CALL Gong (3)
+         Print *, 'error on entry in MemBlockPut'
+         RETURN 
+         ENDIF 
+
+c      Print '(15x,15i4)', (nFA(i), i=1,15) ! <<< DEBUG
+c      Print '(a,3i4,2f12.2)', 'MBP: ', j, k, n, R(1), R(n) ! <<< DEBUG
+         
+C  New File ?
+      IF (j.lt.0 .or. j.gt.MF) THEN
+         Fehler = 'PROG ERR/ MemBlockPut/ j oor'
+         RETURN 
+      ELSEIF (j.gt.nF) THEN
+         Fehler = 'file not load'
+         RETURN
+      ELSEIF (j.le.0 .and. nF.eq.MF) THEN
+         Fehler = 'too many files in memory - new file cannot be saved'
+         RETURN
+      ELSEIF (j.eq.0) THEN
+         nF = nF + 1
+         j = nF
+         ! New file is empty :
+         nFB(j) = nFB(j-1)
+         ENDIF 
+
+C  New Block ?
+c      Print '(40x,a,2i5)', '-> ', nFB(j-1)+k, nFA(nFB(j-1)+k-1) ! <<< DEBUG
+      kmx = nFB(j) - nFB(j-1)
+      IF (k.le.0 .or. k.gt.kmx+1) THEN ! delete file (k=0 or error)
+         IF (k.lt.0 .or. k.gt.MB) THEN 
+            Fehler = 'PROG ERR/ MemBlockPut/ k oor'
+         ELSEIF (k.gt.kmx+1) THEN 
+            CALL Compose2 (Fehler, 'MemBlockPut/ P-ERR/ k='//cl6(k),
+     *                     ' exceeds no. of stored blocks kmx+1='//cl6(kmx+1))
+            ENDIF 
+         ndel = nFA(nFB(j)) - nFA(nFB(j-1))
+         DO i = nFA(nFB(j))+1, nFA(nFB(nF))
+            FMem(i-ndel) = FMem(i)
+            ENDDO 
+         kdel = nFB(j) - nFB(j-1)
+         DO kk = nFB(j), nFB(nF)
+            nFA(kk-kdel) = nFA(kk) - ndel
+            ENDDO 
+         DO jj = j, nF
+            nFB(jj-1) = nFB(jj) - kdel
+            ENDDO 
+         nF = nF - 1
+         RETURN 
+      ELSEIF (k.eq.kmx+1) THEN ! insert new block
+         IF (nFA(nFB(nF))+n.gt.Mmem) THEN
+            CALL Compose3 (Fehler, 
+     *         'MBP/ not enough space to write file '//cl3(j),
+     *         ' block '//cl3(k), ' in on-line-memory')
+            RETURN
+            ENDIF
+         DO jj = nF, j, -1
+            nFB(jj) = nFB(jj) + 1
+            ENDDO 
+         DO kk = nFB(nF), nFB(j), -1 ! nachgetragen 27jul95
+            nFA(kk) = nFA(kk-1)
+            ENDDO 
+         !         nFA(nFB(j-1)+k) = nFA(nFB(j-1)+k-1) ! block is empty
+         ENDIF 
+
+C  Insert data :
+      nold = nFA(nFB(j-1)+k) - nFA(nFB(j-1)+k-1)
+      IF (n.lt.0) THEN ! delete block
+         ndel = nFA(nFB(j-1)+k) - nFA(nFB(j-1)+k-1)
+         DO i = nFA(nFB(j-1)+k)+1, nFA(nFB(nF)) ! error until 6mrz98
+            FMem(i-ndel) = FMem(i)
+            ENDDO 
+         DO kk = nFB(j-1)+k, nFB(nF)
+            nFA(kk-1) = nFA(kk) - ndel
+            ENDDO 
+         DO jj = j, nF
+            nFB(jj) = nFB(jj) - 1
+            ENDDO 
+         RETURN 
+      ELSEIF (n.eq.nold) THEN ! simply overwrite
+         DO i = 1, n
+            FMem(nFA(nFB(j-1)+k-1)+i) = R(i)
+            ENDDO
+         RETURN 
+      ELSEIF (n.lt.nold) THEN ! overwrite and compress
+         DO i = 1, n
+            FMem(nFA(nFB(j-1)+k-1)+i) = R(i)
+            ENDDO
+         ndel = nold - n
+         DO i = nFA(nFB(j-1)+k)+1, nFA(nFB(nF)) ! error until 6mrz98
+            FMem(i-ndel) = FMem(i)
+            ENDDO 
+         DO kk = nFB(j-1)+k, nFB(nF)
+            nFA(kk) = nFA(kk) - ndel
+            ENDDO 
+         RETURN 
+      ELSEIF (n.gt.nold) THEN ! expand and fill in
+         ndel = n - nold
+         IF (nFA(nFB(nF))+ndel.gt.Mmem) THEN
+            CALL Compose3 (Fehler, 
+     *         'MBP/ not enough space to write file '//cl3(j),
+     *         ' block '//cl3(k), ' in on-line-memory')
+            RETURN
+            ENDIF
+         DO i = nFA(nFB(nF)), nFA(nFB(j-1)+k)+1, -1
+            FMem(i+ndel) = FMem(i)
+            ENDDO 
+         DO i = 1, n
+            FMem(nFA(nFB(j-1)+k-1)+i) = R(i)
+            ENDDO
+         DO kk = nFB(j-1)+k, nFB(nF)
+            nFA(kk) = nFA(kk) + ndel
+cdeb            Print *, '>>  kk ndel nFA(kk)_neu = ', kk, ndel, nFA(kk)
+            ENDDO 
+         RETURN
+      ELSE 
+         Fehler = 'PROG ERR/ MemBlockPut/ case n = ??'
+         ENDIF 
+
+      END ! MemBlockPut
+
+      SUBROUTINE MemBlSubAdd (j, k, noldcheck, nadd, Fehler)
+C     ------------------------------------------------------
+            ! JWu 24nov96
+         ! extend block by nadd new entries
+      IMPLICIT NONE 
+      INCLUDE 'i_dim.f'
+      INCLUDE 'l_def.f'
+      INTEGER       j, k, noldcheck, nadd
+      CHARACTER     Fehler*(*)
+      INTEGER       jj, kk, kmx, kdel, i, ndel, nold
+
+C  Data / on-line memory / :
+      INTEGER       nF, nFB, nFA
+      REAL*8        FMem
+      COMMON / OLM / FMem(Mmem), nFA(0:MB*MF), nFB(0:MF), nF
+
+C  Checks :
+      IF     (Fehler.ne.'&ff') THEN
+         CALL Gong (3)
+         Print *, 'error on entry in MemBlSubAdd'
+         RETURN 
+         ENDIF 
+
+      IF (j.lt.1 .or. j.gt.nF) THEN
+         Fehler = 'PROG ERR/ MemBlSubAdd/ j oor'
+         RETURN 
+         ENDIF
+      kmx = nFB(j) - nFB(j-1)
+      IF (k.le.0 .or. k.gt.kmx) THEN ! delete file (k=0 or error)
+         Fehler = 'PROG ERR/ MemBlSubAdd/ k oor'
+         ENDIF 
+      ! hier k"onnte man evtl auch neuen Block erzeugen lassen
+
+C  Insert data :
+      nold = nFA(nFB(j-1)+k) - nFA(nFB(j-1)+k-1)
+      IF (nold.ne.noldcheck) THEN
+         Print *, 'j k nold[intern] nold[extern] ', j, k, nold, noldcheck
+         Fehler = 'PROG ERR/ MemBlSubAdd/ nold deviates'
+         RETURN
+         ENDIF 
+      IF (nadd.le.0) THEN
+         Fehler = 'PROG ERR/ MemBlSubAdd/ nadd<=0'
+         RETURN
+         ENDIF 
+      ! expand and fill in
+      IF (nFA(nFB(nF))+nadd.gt.Mmem) THEN
+         CALL Compose3 (Fehler, 
+     *      'MBSA/ not enough space to write file '//cl3(j),
+     *      ' block '//cl3(k), ' in on-line-memory')
+         RETURN
+         ENDIF
+      DO i = nFA(nFB(nF)), nFA(nFB(j-1)+k)+1, -1
+         FMem(i+nadd) = FMem(i)
+         ENDDO 
+      DO i = 1, nadd
+         FMem(nFA(nFB(j-1)+k-1)+nold+i) = 0
+         ENDDO
+      DO kk = nFB(j-1)+k, nFB(nF)
+         nFA(kk) = nFA(kk) + nadd
+         ENDDO 
+
+      END ! MemBlSubAdd
+
+      SUBROUTINE MemBlSubDel (j, k, npos, ndel, Fehler)
+C     -------------------------------------------------
+            ! JWu 3/4feb97
+         ! delete some lines from a block
+      IMPLICIT NONE 
+      INCLUDE 'i_dim.f'
+      INCLUDE 'l_def.f'
+      INTEGER       j, k, npos, ndel
+      CHARACTER     Fehler*(*)
+      INTEGER       kk, kmx, kdel, i, nold
+
+C  Data / on-line memory / :
+      INTEGER       nF, nFB, nFA
+      REAL*8        FMem
+      COMMON / OLM / FMem(Mmem), nFA(0:MB*MF), nFB(0:MF), nF
+
+C  Checks :
+      IF     (Fehler.ne.'&ff') THEN
+         CALL Gong (3)
+         Print *, 'error on entry in MemBlSubDel'
+         RETURN 
+         ENDIF 
+
+      IF (j.lt.1 .or. j.gt.nF) THEN
+         Fehler = 'PROG ERR/ MemBlSubDel/ j oor'
+         RETURN 
+         ENDIF
+      kmx = nFB(j) - nFB(j-1)
+      IF (k.le.0 .or. k.gt.kmx) THEN
+         Fehler = 'PROG ERR/ MemBlSubDel/ k oor'
+         RETURN 
+         ENDIF 
+
+      nold = nFA(nFB(j-1)+k) - nFA(nFB(j-1)+k-1)
+      IF (npos+ndel.gt.nold) THEN
+         Print *, 'j k nold[intern] npos ndel ', j, k, nold, npos, ndel
+         Fehler = 'PROG ERR/ MemBlSubDel/ cannot delete so many lines'
+         RETURN
+         ENDIF 
+
+C  Delete :
+      DO i = nFA(nFB(j-1)+k-1)+npos+ndel+1, nFA(nFB(nF))
+         FMem(i-ndel) = FMem(i)
+         ENDDO 
+      DO kk = nFB(j-1)+k, nFB(nF)
+         nFA(kk) = nFA(kk) - ndel
+         ENDDO 
+
+      END ! MemBlSubDel
+
+      SUBROUTINE MemBlockGet (j, k, n, nmax, R, Fehler)
+C     -------------------------------------------------
+            ! JWu 17mar95
+         ! Read R(1..n) from block k of file j in on-line memory
+
+      IMPLICIT NONE 
+      INCLUDE 'i_dim.f'
+      INCLUDE 'l_def.f'
+
+      INTEGER       j, k, n, nmax, i
+      REAL*8        R(*)
+      CHARACTER     Fehler*(*)
+
+      INTEGER       nF, nFB, nFA
+      REAL*8        FMem
+      COMMON / OLM / FMem(Mmem), nFA(0:MB*MF), nFB(0:MF), nF
+
+      IF     (j.le.0 .or. j.gt.nF) THEN
+         Fehler = 'PROG ERR/ MemBlockGet/ j oor'
+         RETURN 
+      ELSEIF (k.le.0 .or. k.gt.nFB(j)-nFB(j-1)) THEN
+         Fehler = 'PROG ERR/ MemBlockGet/ k oor'
+         RETURN 
+         ENDIF 
+
+      n = nFA(nFB(j-1)+k) - nFA(nFB(j-1)+k-1)
+      IF (n.lt.0) THEN 
+         CALL Compose2 (Fehler, 'PROG ERR/ MemBlockGet/ k='//cl3(k), 'n < 0')
+         RETURN 
+c      ELSEIF (n.eq.0) THEN 
+c         CALL Compose2 (Fehler, 'PROG ERR/ MemBlockGet/ k='//cl3(k), 'n = 0')
+c         RETURN 
+      ELSEIF (n.gt.nmax) THEN 
+         CALL Compose4 (Fehler, 'PROG ERR/ MemBlockGet/ file '//cl3(j),
+     *        '/ block '//cl4(k), '/ n='//cl4(n), ' > nmax='//cl4(nmax))
+         RETURN 
+         ENDIF 
+      DO i = 1, n
+         R(i) = FMem(nFA(nFB(j-1)+k-1)+i)
+         ENDDO
+
+      END ! MemBlockGet
+
+      SUBROUTINE MemBlSubGet (j, k, i0, nsub, R, Fehler)
+C     --------------------------------------------------
+            ! JWu 17mar95
+         ! read entries i0+1...i0+nsub from block k of on-line-file j
+         ! into R(1...nsub)
+
+      IMPLICIT NONE 
+      INCLUDE 'i_dim.f'
+      INCLUDE 'l_def.f'
+
+      INTEGER       j, k, i0, nsub, i, n
+      REAL*8        R(*)
+      CHARACTER     Fehler*(*)
+
+      INTEGER       nF, nFB, nFA
+      REAL*8        FMem
+
+      COMMON / OLM / FMem(Mmem), nFA(0:MB*MF), nFB(0:MF), nF
+
+      IF     (j.le.0 .or. j.gt.nF) THEN
+         Fehler = 'PROG ERR/ MemBlSubGet/ j oor'
+         RETURN 
+      ELSEIF (k.le.0 .or. k.gt.nFB(j)-nFB(j-1)) THEN
+         Print *, ' j, k nK ', j, k, nFB(j)-nFB(j-1) 
+         Fehler = 'PROG ERR/ MemBlSubGet/ k oor'
+         RETURN 
+         ENDIF 
+
+      n = nFA(nFB(j-1)+k) - nFA(nFB(j-1)+k-1)
+      IF     (i0.lt.0 .or. nsub.lt.1) THEN
+         CALL Compose3 (Fehler, 'PROG ERR/ MemBlSubGet/ k='//cl3(k),
+     *                  '; i0='//cl6(i0), '; nsub='//cl6(nsub))
+         RETURN
+      ELSEIF (i0+nsub.gt.n) THEN 
+         CALL Compose4 (Fehler, 'PROG ERR/ MemBlSubGet/ k='//cl3(k),
+     *         '; n='//cl6(n),  '; i0='//cl6(i0), '; nsub='//cl6(nsub))
+         RETURN 
+         ENDIF 
+
+      DO i = 1, nsub
+         R(i) = FMem(nFA(nFB(j-1)+k-1)+i0+i)
+         ENDDO
+
+      END ! MemBlSubGet
+
+      SUBROUTINE MemBlSubPut (j, k, i0, nsub, R, Fehler)
+C     --------------------------------------------------
+
+      IMPLICIT NONE 
+      INCLUDE 'i_dim.f'
+      INCLUDE 'l_def.f'
+
+      INTEGER       j, k, i0, nsub, i, n
+      REAL*8        R(*)
+      CHARACTER     Fehler*(*)
+      INTEGER       nF, nFB, nFA
+      REAL*8        FMem
+
+      COMMON / OLM / FMem(Mmem), nFA(0:MB*MF), nFB(0:MF), nF
+
+      IF     (j.le.0 .or. j.gt.nF) THEN
+         Fehler = 'PROG ERR/ MemBlSubPut/ j oor'
+         RETURN 
+      ELSEIF (k.le.0 .or. k.gt.nFB(j)-nFB(j-1)) THEN
+         Fehler = 'PROG ERR/ MemBlSubPut/ k oor'
+         RETURN 
+         ENDIF 
+
+      n = nFA(nFB(j-1)+k) - nFA(nFB(j-1)+k-1)
+      IF     (i0.lt.0 .or. nsub.lt.1) THEN
+         CALL Compose3 (Fehler, 'PROG ERR/ MemBlSubPut/ k='//cl3(k),
+     *                  '; i0='//cl6(i0), '; nsub='//cl6(nsub))
+         RETURN
+      ELSEIF (i0+nsub.gt.n) THEN 
+         CALL Compose4 (Fehler, 'PROG ERR/ MemBlSubPut/ k='//cl3(k),
+     *         '; n='//cl6(n),  '; i0='//cl6(i0), '; nsub='//cl6(nsub))
+         RETURN 
+         ENDIF 
+
+      DO i = 1, nsub
+         FMem(nFA(nFB(j-1)+k-1)+i0+i) = R(i)
+         ENDDO
+
+      END ! MemBlSubPut
+
+      INTEGER FUNCTION MemBlockInq (what)
+C     -----------------------------------
+            ! JWu 1feb93, 11mar93, 16may95
+         ! inquire memory status
+
+      IMPLICIT NONE 
+      INCLUDE 'i_dim.f'
+
+      CHARACTER     what*(*)
+
+      INTEGER       nF, nFB, nFA
+      REAL*8        FMem
+
+      COMMON / OLM / FMem(Mmem), nFA(0:MB*MF), nFB(0:MF), nF
+
+      IF     (what.eq.'nF') THEN
+         MemBlockInq = nF
+      ELSEIF (what.eq.'MF') THEN
+         MemBlockInq = MF
+      ELSEIF (what.eq.'fF') THEN ! free files
+         MemBlockInq = MF - nF
+c      ELSEIF (what.eq.'nE') THEN
+c         MemBlockInq = iOnext(nF) - 1
+      ELSEIF (what.eq.'ME') THEN
+         MemBlockInq = Mmem
+      ELSEIF (what.eq.'fE') THEN ! free entries
+         MemBlockInq = Mmem - nFA(nFB(nF)) ! ????
+      ELSE
+         CALL Absturz('MemBlockInq', 'Option not implemented :'//what)
+         ENDIF
+
+      END ! MemBlockInq
+
+      INTEGER FUNCTION MemBlockNum (j)
+C     --------------------------------
+            ! 17may95
+         ! return number of blocks of file j
+
+      IMPLICIT NONE 
+      INCLUDE 'i_dim.f'
+
+      INTEGER       nF, nFB, nFA, j
+      REAL*8        FMem
+
+      COMMON / OLM / FMem(Mmem), nFA(0:MB*MF), nFB(0:MF), nF
+
+      IF (j.lt.1 .or. j.gt.nF) THEN
+         MemBlockNum = 0 ! must be tested in the calling routing
+         RETURN
+         ENDIF
+      MemBlockNum = nFB(j) - nFB(j-1)
+
+      END ! MemBlockNum
+      
+      INTEGER FUNCTION MemBlockSiz (j, k)
+C     -----------------------------------
+            ! 17may95
+         ! return number of lines of block k of file j
+
+      IMPLICIT NONE 
+      INCLUDE 'i_dim.f'
+
+      INTEGER       nF, nFB, nFA, j, k
+      REAL*8        FMem
+
+      COMMON / OLM / FMem(Mmem), nFA(0:MB*MF), nFB(0:MF), nF
+
+      IF     (j.lt.0 .or. j.gt.nF) THEN
+         MemBlockSiz = -1
+c         type *, ' WARNUNG/ MemBlockSiz/ j oor'
+         RETURN
+      ELSEIF (k.le.0 .or. k.gt.nFB(j)-nFB(j-1)) THEN
+         MemBlockSiz = 0 ! war -1, aber warum nicht ganz normal 0 abfragen ?
+c         type *, 'UNGLAUBLICH/ MemBlockSiz/ k oor : ', k
+         RETURN 
+         ENDIF
+
+      MemBlockSiz = nFA(nFB(j-1)+k) - nFA(nFB(j-1)+k-1)
+
+      END ! MemBlockSiz
+      
+      SUBROUTINE MemRestInfo ()
+C     -------------------------
+
+      IMPLICIT NONE
+      INTEGER       iRest, iAlt, MCmem, MemBlockInq
+      CHARACTER     cl8*8
+
+      iRest = MemBlockInq ('fE')
+      MCmem = MemBlockInq ('ME')
+      IF (iRest.ne.iAlt .and. iRest.le.MCmem/7) THEN
+         CALL Say2 (' '//cl8(iRest), ' lines free in run-time memory')
+         iAlt = iRest
+         ENDIF
+
+      END ! MemRestInfo
+
+      SUBROUTINE MemDims ()
+C     ---------------------
+            ! JWu FileDims 23nov92 
+         ! Print current array dimensions
+
+      INCLUDE 'i_dim.f'
+
+      Print '(a)',
+     *   ' Current array dimensions (data files and on-line memory) :'
+      Print '(a,i8)', ' # files             ', MF
+      Print '(a,i8)', ' # spectra/file      ', MK
+      Print '(a,i8)', ' # channels/spectrum ', MC
+      Print '(a,i8)', ' # tPar/file         ', MP
+      Print '(a,i8)', ' # total channels    ', Mmem
+
+      END ! MemDims
+
+      LOGICAL FUNCTION qMemFill (newF, newE, Fehler)
+C     ----------------------------------------------
+            ! 12mar93
+         ! Is there not enough place to accomodate
+         ! newF new files with a total of newE entries ?
+
+      IMPLICIT LOGICAL (q)
+      CHARACTER         Fehler*(*), cl8*8
+
+      nF = MemBlockInq ('fF')
+      nE = MemBlockInq ('fE')
+      IF     (newF.gt.nF) THEN
+         CALL Compose3 (Fehler,
+     *      ' not enough place in memory : '//cl8(nF),
+     *      ' more files allowed, '//cl8(newF), ' required')
+         qMemFill = .true.
+      ELSEIF (newE.gt.nE) THEN
+         CALL Compose3 (Fehler,
+     *      ' not enough place in memory : '//cl8(nE),
+     *      ' lines free, '//cl8(newE), ' required')
+         qMemFill = .true.
+      ELSE
+         qMemFill = .false.
+         ENDIF
+
+      END ! qMemFill
+
+      SUBROUTINE MemFileDel (j, Fehler)
+C     ---------------------------------
+         ! 16may95, 17jan91
+
+      ! Delete one file from OLM.
+
+      IMPLICIT NONE
+      INCLUDE 'l_def.f'
+
+      CHARACTER     Fehler*(*)
+      INTEGER       j, n, iAlt, iNew, MemBlockInq
+      REAL*8        R(1) 
+      
+      iAlt = MemBlockInq ('fE')
+      CALL MemBlockPut (j, 0, n, R, Fehler)
+      iNew = MemBlockInq ('fE')
+
+      CALL Say3 ('  file '//cl3(j), ' deleted ('//cl6(iNew-iAlt), ' lines)')
+      CALL MemRestInfo ()
+
+      END ! MemFileDel
+
+      SUBROUTINE MemFileDup (jin, jout, nBdup, Fehler)
+C     ------------------------------------------------
+            ! JWu 7nov96
+         ! duplicate the first nBdup blocks of an on-line-file 
+         ! without any notion of its semantics, preserving the status bits.
+         ! nBdup=0 means: copy *all* blocks
+
+      IMPLICIT NONE
+      INCLUDE 'l_def.f'
+      INCLUDE 'i_dim.f'
+
+      CHARACTER     Fehler*(*)
+      INTEGER       jin, jout, nB, nBdup, iB, n, iAlt, iNew, 
+     *              MemBlockNum, MemBlockInq
+      REAL*8        R(MmemBlo) 
+      
+      iAlt = MemBlockInq ('fE')
+
+      nB = MemBlockNum (jin)
+      IF (nB.lt.1) THEN
+         Fehler = 'MemFileDup/ empty or nonexisting file'
+         RETURN
+         ENDIF
+      IF (nBdup.ge.1) THEN
+         IF (nB.lt.nBdup) THEN
+            Fehler = 'MemFileDup/ too many blocks required'
+            RETURN
+            ENDIF
+         nB = nBdup
+         ENDIF
+      jout = 0
+
+      DO iB = 1, nB
+         CALL MemBlockGet (jin, iB, n, MmemBlo, R, Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+         CALL MemBlockPut (jout, iB, n, R, Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+         ENDDO
+
+      iNew = MemBlockInq ('fE')
+      CALL Say4 ('  file '//cl3(jin), ' -> '//cl3(jout),
+     *           ' duplicated ('//cl6(iAlt-iNew), ' lines)')
+      CALL MemRestInfo ()
+
+      END ! MemFileDup
+
+C  ====================================================================
+C     2.  Status shell : access to files restricted by their status
+C  ====================================================================
+
+         ! The status bits (introduced 25jan95) encode in particular
+         ! information about the allowed access mode.
+
+         ! bit (0) = 0 / 1 : online / being modified 
+         ! bit (1) = 0 / 2 : as on disc / modified
+         ! bit (2) = 0 / 4 : changeable / protected
+
+      SUBROUTINE MemFileStatP (j, iStat, Fehler)
+C     ------------------------------------------
+            ! JWu 16may95 reusing OlfOpen (23jan91)
+
+      ! Open or close a file for modifications
+
+      IMPLICIT NONE
+      INCLUDE       'l_def.f'
+      
+      INTEGER        j, iStat, iR
+      REAL*8         R(1)
+      CHARACTER*(*)  Fehler
+      EQUIVALENCE   (R(1), iR)
+
+      IF (iStat.lt.0 .or. iStat.ge.8) THEN
+         Fehler = 'MFSP/ Illegal status bits'
+         RETURN
+         ENDIF 
+      
+      IF (iBitGet(iStat,0).eq.1 .and. iBitGet(iStat,2).eq.1 .and. j.ne.0) THEN
+         Fehler = 'MFSP/ Attempt to modify protected file'
+         RETURN 
+         ENDIF
+
+      iR = iStat
+      CALL MemBlockPut (j, 1, 1, R, Fehler)
+      IF (Fehler.ne.'&ff') Print *, 'error passed through MFSP'
+
+      END ! MemFileStatP
+
+      SUBROUTINE MemFileStatG (j, iStat, Fehler)
+C     ------------------------------------------
+
+      ! Get status information about file j
+
+      IMPLICIT NONE
+      INCLUDE       'l_def.f'
+      
+      INTEGER        j, iStat, iR, n
+      REAL*8         R(1)
+      CHARACTER*(*)  Fehler
+      EQUIVALENCE   (R(1), iR)
+
+      CALL MemBlockGet (j, 1, n, 1, R, Fehler)
+      IF (Fehler.ne.'&ff') THEN
+         Print *, 'error passed through MFSG'
+         RETURN
+         ENDIF
+
+      IF (n.ne.1) THEN
+         Fehler = 'MFSG/ Block 1 did not contain 1 R*8 but #elements='//cl6(n)
+         RETURN
+         ENDIF
+      iStat = iR
+
+      IF (iStat.lt.0 .or. iStat.ge.8) THEN
+         Fehler = 'MFSG/ Illegal status bits'
+         RETURN
+         ENDIF 
+      
+      END ! MemFileStatG
+
+      SUBROUTINE MemFileBitP (j, nPos, iVal, Fehler)
+C     ----------------------------------------------
+
+      IMPLICIT NONE 
+      CHARACTER*(*)  Fehler
+      INTEGER        j, nPos, iVal, iStat
+
+      CALL MemFileStatG (j, iStat, Fehler)
+      IF (Fehler.ne.'&ff') RETURN 
+
+      CALL BitSet (iStat,nPos,iVal)
+
+      CALL MemFileStatP (j, iStat, Fehler)
+      IF (Fehler.ne.'&ff') RETURN 
+
+      END ! MemFileBitP
+
+      SUBROUTINE MemBlockOvr (j, k, n, R, Fehler)
+C     -------------------------------------------
+         ! Save R(1..n) as block k of file j in on-line memory
+         ! but only if the present status of file j allows it
+
+         ! From outer levels, calls to MemBlockPut should always
+         ! pass through MemBlockOvr
+
+      IMPLICIT NONE 
+      INCLUDE 'i_dim.f'
+      INCLUDE 'l_def.f'
+
+      INTEGER       j, k, n, iStat
+      REAL*8        R(*)
+      CHARACTER     Fehler*(*)
+
+      CALL MemFileStatG (j, iStat, Fehler)
+      IF (Fehler.ne.'&ff') GOTO 99
+
+      IF (iBitGet(iStat,0).eq.0) THEN
+         CALL Compose2 (Fehler, 'MBO/ File '//cl3(j),
+     *                  ' is not open for modifications')
+         RETURN
+         ENDIF
+
+      IF (iBitGet(iStat,1).eq.0) THEN 
+         CALL BitSet(iStat,1,1) ! file will be different from version on disc
+         CALL MemFileStatP (j, iStat, Fehler)
+         IF (Fehler.ne.'&ff') GOTO 99
+         ENDIF
+      
+      CALL MemBlockPut (j, k, n, R, Fehler)
+      IF (Fehler.ne.'&ff') GOTO 99
+      
+      RETURN
+ 99   CONTINUE
+      Print *, 'error passed through MBO'
+
+      END ! MemBlockOvr
+
+C  ====================================================================
+C     3. Open, close, and copy files
+C  ====================================================================
+
+      ! Block(1)   : status      MFStat (see above)
+      ! Block(2)   : integer parameters
+      ! Block(3)   : real parameters
+      ! Block(4)   : text parameters
+      ! Block(5)   : documentation
+      ! Block(6)   : coordinate names
+      ! Block(7..) : four blocks for each spectrum (z X Y D)
+
+      ! For modifying an on-line-file, proceed as follows 
+      ! (new organisation from nov96) :
+
+      ! for creating a new file starting from nothing, start with
+      !    CALL OlfCreate (jout, Kout, FileDef, TitlDef, Fehler)              
+      ! for modifying an existing file, use
+      !    CALL OlfHeadDup (jin, qOv, jout, Kout, Fehler)
+      ! except it shall always be overwritten, in which case you use
+      !    CALL OlfOpen (j, 1, Kout)          % if j=0, new j on exit
+
+
+      ! * old procedure : *
+      !    CALL OlfOpen (j, 1, Kout)          % if j=0, new j on exit
+      !    CALL OlfParP (j, iPar, rPar, tPar) % required if file is new
+      !    Loop
+      !       CALL OlfSpeP (j, Kout,...)      % Kout+=1; overwrite spectrum
+      !       IF Fehler GOTO 1
+      !       LoopEnd
+      !  1 CALL OlfClos (j, Kout)             % Kout is new nK
+
+      SUBROUTINE OlfOpen (j, iStat, Kout, Fehler)
+C     -------------------------------------------
+               ! JWu FileModif 23.1.91, 12.2.91, OlfOpen 17may95
+
+         ! open an existing on-line-file for modification
+
+      IMPLICIT NONE
+      CHARACTER     Fehler*(*)
+      INTEGER       j, iStat, Kout
+      
+      IF (j.le.0) THEN
+         Fehler = 'PROG ERR/ OlfOpen now restricted to existing files'
+         RETURN
+         ENDIF
+      Kout  = 0 ! Counter for modified spectra
+      CALL MemFileStatP (j, iStat, Fehler)
+      IF (Fehler.ne.'&ff') CALL Insert (Fehler, 1, 'OO/ ')
+
+      END ! OlfOpen
+
+      SUBROUTINE OlfClos (j, Kout, Fehler)
+C     ------------------------------------
+
+      IMPLICIT NONE
+      INCLUDE 'l_def.f'
+      CHARACTER     Fehler*(*)
+      INTEGER       j, Kout
+
+      IF (Fehler.ne.'&ff') THEN
+         Print *, 'error on entry in OlfClos'
+         RETURN
+         ENDIF
+
+      IF     (Kout.ge.2) THEN
+         CALL Say2 ('  stored '//cl3(Kout), ' spectra as file '//cl3(j))
+      ELSEIF (Kout.ge.1) THEN
+         Print *, '  stored spectrum as file ', j
+         ENDIF
+      CALL MemRestInfo()
+
+      CALL MemFileBitP (j, 0, 0, Fehler) ! close for modif
+      IF (Fehler.ne.'&ff') Print *, 'error passed through OlfClos'
+
+      END ! OlfClos
+ 
+      SUBROUTINE OlfHeadDup (jin, qOv, jout, nK, Kout, Fehler)
+C     --------------------------------------------------------
+            ! JWu 8nov96
+         ! qOv=true:  open existing file for modification 
+         ! qOv=false: copy header blocks to new file and open 
+         !            the new file for modification
+
+      IMPLICIT NONE
+      INCLUDE      'i_dim.f'
+      CHARACTER     Fehler*(*)
+      INTEGER       jin, jout, Kout, nK, nB, MemBlockNum
+      LOGICAL       qOv
+
+      IF (Fehler.ne.'&ff') THEN
+         Print *, ' OlfHeadDup/ error on entry'
+         RETURN
+         ENDIF
+
+      nB = MemBlockNum(jin) 
+      IF (nB.lt.1) THEN
+         Print *, 'jin = ', jin
+         Fehler = 'OlfHeadDup/ input file does not exist'
+         RETURN
+      ELSEIF (nB.le.MBH) THEN
+         Fehler = 'OlfHeadDup/ input File has uncomplete header'
+         RETURN
+         ENDIF
+      nK = (nB - MBH) / 4
+      Kout = 0
+      IF (qOv) THEN
+         jout = jin
+      ELSE
+         jout = 0
+         CALL MemFileDup (jin, jout, MBH, Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+         ENDIF
+      CALL MemFileStatP (jout, 1, Fehler)
+      IF (Fehler.ne.'&ff') RETURN
+
+      END ! OlfHeadDup
+
+      SUBROUTINE OlfCreate (jout, Kout, FilDef, TitDef, Fehler)
+C     ---------------------------------------------------------
+            ! JWu 8nov96
+         ! qOv=true:  open existing file for modification 
+         ! qOv=false: copy header blocks to new file and open 
+         !            the new file for modification
+
+      IMPLICIT NONE
+      INCLUDE      'i_dim.f'
+      CHARACTER*(*) FilDef, TitDef, Fehler
+      CHARACTER*40  Fil, Tit
+      INTEGER       jout, Kout, iBH, MemBlockNum
+      REAL*8        R(1)
+      SAVE          Fil, Tit
+      DATA          Fil /' '/, Tit /' '/
+
+      IF (Fehler.ne.'&ff') THEN
+         Print *, ' OlfCreate/ error on entry'
+         RETURN
+         ENDIF
+
+      ! create the file and open it for modifications :
+      jout = 0 ! ignore input value
+      Kout = 0 ! Counter for modified spectra
+      CALL MemFileStatP (jout, 1, Fehler)
+      IF (Fehler.ne.'&ff') RETURN
+
+      ! initialize the header blocks :
+      DO iBH = 2, 6
+         CALL MemBlockPut (jout, iBH, 0, R, Fehler)
+         ENDDO
+
+      ! set filename and title :
+      IF     (FilDef.eq.'&noask') THEN
+         Fil = ' '
+      ELSEIF (FilDef.eq.'&nodef') THEN
+         CALL FrageT  ('File name', Fil)
+      ELSEIF (FilDef.eq.'&olddef') THEN ! last input -> new default
+         CALL FrageTD ('File name', Fil, Fil)
+      ELSE
+         CALL FrageTD ('File name', Fil, FilDef)
+         ENDIF
+      IF     (TitDef.eq.'&noask') THEN
+         Tit = ' '
+      ELSEIF (TitDef.eq.'&nodef') THEN
+         CALL FrageT  ('and Title', Tit)
+      ELSEIF (TitDef.eq.'&olddef') THEN ! last input -> new default
+         CALL FrageTD ('and Title', Tit, Tit)
+      ELSE
+         CALL FrageTD ('and Title', Tit, TitDef)
+         ENDIF
+      CALL tOlfP (jout, 'fil', Fil, Fehler)
+      CALL tOlfP (jout, 'tit', Tit, Fehler)
+      CALL tOlfP (jout, 'doc', ' ', Fehler)
+      CALL tOlfP (jout, 'dir', ' ', Fehler)
+
+      END ! OlfCreate
+
+C  ====================================================================
+C     4. Access to header blocks
+C  ====================================================================
+
+      SUBROUTINE OlfLabG (j, k, lab, RL, nRL, Fehler)
+C     -----------------------------------------------
+            ! JWu 23/24nov96
+         ! get any labelled parameter from block k
+      IMPLICIT NONE
+      INCLUDE 'i_dim.f'
+      INCLUDE 'l_def.f'
+      CHARACTER*(*) lab, Fehler
+      CHARACTER     name*24
+      INTEGER       j, k, nRL, MRlab, MRmax, nR, i, iP, nP, MemBlockSiz
+      PARAMETER     (MRlab=24/8, MRmax=MRlab+80/8)
+      REAL*8         R(MRmax), RL(*)
+      EQUIVALENCE   (R(1), name)
+
+      nR = nRL + MRlab
+      IF (nR.gt.MRmax) THEN
+         Fehler = 'OlfLabG/ nR>MRmax'
+         RETURN 
+         ENDIF 
+      nP = MemBlockSiz(j, k) / nR
+      IF (nP.lt.0) THEN
+         Fehler = 'OlfLabG/ block not accessible'
+         ENDIF 
+
+      IF (lab(1:4).eq.'&pbn') THEN ! parameter by number
+         CALL Fi1N (lab, iP)
+         IF (lab.ne.'&pbn #') THEN
+            Fehler = 'OlfLabG/ invalid Macro '//lab
+            RETURN
+         ELSEIF (iP.lt.1) THEN
+            Fehler = 'OlfLabG/ invalid iP<1'
+            RETURN 
+         ELSEIF (iP.eq.nP+1) THEN
+            lab = '&eop' ! end of parameters
+            RETURN 
+         ELSEIF (iP.gt.nP+1) THEN
+            Fehler = 'OlfLabG/ invalid iP>>nP'
+            RETURN 
+            ENDIF 
+         CALL MemBlSubGet (j, k, (iP-1)*nR, nR, R, Fehler)
+         IF (Fehler.ne.'&ff') RETURN 
+         lab = name
+         DO i = 1, nRL
+            RL(i) = R(MRlab+i)
+            ENDDO 
+         RETURN 
+         ENDIF 
+         
+      DO iP = 0, nP-1
+         CALL MemBlSubGet (j, k, iP*nR, nR, R, Fehler)
+         IF (Fehler.ne.'&ff') RETURN 
+         IF (name.eq.lab) THEN
+            DO i = 1, nRL
+               RL(i) = R(MRlab+i)
+               ENDDO 
+            RETURN ! success
+            ENDIF 
+         ENDDO
+
+      ! parameter-not-found :
+      CALL Compose3 (Fehler, '&pnf ('//cl2(k), ') "'//lab,
+     *   '" by OlfLabG in j='//cl3(j))
+      
+      END ! OlfLabG
+
+      SUBROUTINE OlfLabDel (j, k, lab, nRL, Fehler)
+C     ---------------------------------------------
+            ! JWu 3/4feb97
+         ! remove any labelled parameter from block k
+      IMPLICIT NONE
+      INCLUDE 'i_dim.f'
+      INCLUDE 'l_def.f'
+      CHARACTER*(*) lab, Fehler
+      CHARACTER     name*24
+      INTEGER       j, k, nRL, MRlab, MRmax, nR, i, iP, nP, MemBlockSiz
+      PARAMETER     (MRlab=24/8, MRmax=MRlab+80/8)
+      REAL*8         R(MRmax)
+      EQUIVALENCE   (R(1), name)
+
+      nR = nRL + MRlab
+      nP = MemBlockSiz(j, k) / nR
+
+      IF (nP.lt.0) THEN
+         Fehler = 'OlfLabDel/ block not accessible'
+         ENDIF 
+
+      DO iP = 0, nP-1
+         CALL MemBlSubGet (j, k, iP*nR, nR, R, Fehler)
+         IF (name.eq.lab) THEN
+            CALL MemBlSubDel (j, k, iP*nR, nR, Fehler)
+            RETURN ! success
+            ENDIF 
+         ENDDO
+
+      ! parameter-not-found :
+      CALL Compose3 (Fehler, '&pnf ('//cl2(k), ') "'//lab, '" in OlfLabDel')
+
+      END ! OlfLabDel
+
+      SUBROUTINE OlfLabP (j, k, lab, RL, nRL, Fehler)
+C     -----------------------------------------------
+      IMPLICIT NONE
+      INCLUDE 'i_dim.f'
+      INCLUDE 'l_def.f'
+      CHARACTER*(*) lab, Fehler
+      CHARACTER     name*24
+      INTEGER       j, k, nRL, MRlab, MRmax, nR, i, iP, nP, nPadd, MemBlockSiz
+      PARAMETER     (MRlab=24/8, MRmax=MRlab+80/8)
+      REAL*8         R(MRmax), RL(*)
+      EQUIVALENCE   (R(1), name)
+
+      IF (Fehler.ne.'&ff') THEN
+         Print *, 'error on entry in OlfLabP'
+         RETURN 
+         ENDIF 
+      nR = nRL + MRlab
+      IF (nR.gt.MRmax) THEN
+         Fehler = 'OlfLabP/ nR>MRmax'
+         RETURN 
+         ENDIF 
+      nP = MemBlockSiz(j, k) / nR
+      IF (nP.lt.0) THEN
+         Fehler = 'tOlfP/ block not accessible'
+         RETURN 
+         ENDIF 
+         
+      DO iP = 0, nP-1
+         CALL MemBlSubGet (j, k, iP*nR, nR, R, Fehler)
+         IF (Fehler.ne.'&ff') THEN
+            CALL Insert (Fehler, 1, 'OlfLabP (get-old)/ ')
+            RETURN 
+            ENDIF 
+         IF (name.eq.'&empty') name = lab ! take free slot
+         IF (name.eq.lab) THEN
+            DO i = 1, nRL
+               R(MRlab+i) = RL(i)
+               ENDDO 
+            CALL MemBlSubPut (j, k, iP*nR, nR, R, Fehler)
+            IF (Fehler.ne.'&ff') THEN
+               CALL Insert (Fehler, 1, 'OlfLabP (put-ovr) / ')
+               RETURN 
+               ENDIF 
+            IF (Fehler.ne.'&ff') RETURN 
+            RETURN ! overwrite
+            ENDIF 
+         ENDDO
+
+ 2    CONTINUE ! no more slots free
+
+      nPadd = nP + 8
+      CALL MemBlSubAdd (j, k, nP*nR, nPadd*nR, Fehler)
+      IF (Fehler.ne.'&ff') THEN
+         CALL Insert (Fehler, 1, 'OlfLabP (add many)/ ')
+         RETURN 
+         ENDIF 
+      name = lab
+      DO i = 1, nRL
+         R(MRlab+i) = RL(i)
+         ENDDO 
+      CALL MemBlSubPut (j, k, nP*nR, nR, R, Fehler)
+      IF (Fehler.ne.'&ff') THEN
+         CALL Insert (Fehler, 1, 'OlfLabP (put-new)/ ')
+         RETURN 
+         ENDIF 
+
+      name = '&empty'
+      DO i = 1, nRL
+         R(MRlab+i) = 0
+         ENDDO 
+      DO iP = nP+1, nP+nPadd-1
+         CALL MemBlSubPut (j, k, iP*nR, nR, R, Fehler)
+         IF (Fehler.ne.'&ff') THEN
+            CALL Insert (Fehler, 1, 'OlfLabP (put-void)/ ')
+            RETURN 
+            ENDIF 
+         ENDDO 
+
+      END ! OlfLabP
+
+      INTEGER FUNCTION iOlfG (j, lab, Fehler)
+C     ---------------------------------------
+         ! return one integer parameter from the header of file j.
+      IMPLICIT NONE
+      INCLUDE 'i_dim.f'
+      CHARACTER*(*) lab, Fehler
+      INTEGER       j, nB, ival, MemBlockNum, MemBlockSiz, nZ
+      REAL*8        R(1)
+      EQUIVALENCE  (R(1), ival)
+
+      iOlfG = 0
+
+      IF (lab.eq.'#spectra') THEN
+         nB = MemBlockNum(j) 
+         IF (nB.lt.1) THEN
+            Fehler = 'iOlfG/ File does not exist'
+            RETURN
+         ELSEIF (nB.le.MBH) THEN
+            Fehler = 'iOlfG/ File has uncomplete header'
+            RETURN
+            ENDIF
+         iOlfG = (nB - MBH) / 4 ! bei "Anderung auch lokal: nK = .. "andern
+      ELSEIF (lab.eq.'#Z') THEN
+         nZ = MemBlockSiz(j, MBH+1)
+         IF (nZ.lt.0) THEN 
+            Fehler = 'iOlfG/ PROGRAM ERROR/ MemBlockSize=-1'
+         ELSE
+            iOlfG = nZ
+            ENDIF 
+      ELSE
+         CALL OlfLabG (j, 3, lab, R, 1, Fehler)
+         iOlfG = ival
+         ENDIF 
+
+      END ! iOlfG
+
+      SUBROUTINE iOlfP (j, lab, iin, Fehler)
+C     --------------------------------------
+         ! overwrite one integer parameter in the header of file j.
+      IMPLICIT NONE
+      CHARACTER*(*) lab, Fehler
+      INTEGER       j, iin, ival, MemBlockNum
+      REAL*8        R(1)
+      EQUIVALENCE  (R(1), ival)
+
+      IF (lab.eq.'#spectra') THEN
+         Fehler = 'PROGR ERR/ cannot modify #spectra via iOlfP'
+         RETURN
+         ENDIF 
+
+      ival = iin
+      CALL OlfLabP (j, 3, lab, R, 1, Fehler)
+
+      END ! iOlfP
+
+      REAL*8 FUNCTION rOlfG (j, co, un, Fehler)
+C     -----------------------------------------
+         ! read one real parameter from the header of file j.
+      IMPLICIT NONE
+      CHARACTER*(*) co, un, Fehler
+      CHARACTER*24  uval
+      INTEGER       j
+      REAL*8        rval, R(4)
+      EQUIVALENCE  (R(1), rval)
+      EQUIVALENCE  (R(2), uval)
+
+      CALL OlfLabG (j, 4, co, R, 4, Fehler)
+      IF (Fehler.ne.'&ff') THEN 
+         rOlfG = 0
+         RETURN 
+         ENDIF 
+      rOlfG = rval
+      un    = uval
+
+      END ! rOlfG
+
+      SUBROUTINE rOlfDel (j, co, Fehler)
+C     ----------------------------------
+            ! JWu 3feb97
+         ! delete one real parameter from the header of file j.
+      IMPLICIT NONE
+      CHARACTER*(*) co, Fehler
+      INTEGER       j
+
+      CALL OlfLabDel (j, 4, co, 4, Fehler)
+
+      END ! rOlfDel
+
+      SUBROUTINE rOlfP (j, co, un, rin, Fehler)
+C     -----------------------------------------
+            ! JWu 9nov96
+         ! overwrite one real parameter in the header of file j.
+
+      IMPLICIT NONE
+      CHARACTER*(*) co, un, Fehler
+      CHARACTER*24  uval
+      INTEGER       j
+      REAL*8        rin, rval, R(4)
+      EQUIVALENCE  (R(1), rval)
+      EQUIVALENCE  (R(2), uval)
+
+      IF (Fehler.ne.'&ff') THEN 
+         Print *, 'error on entry in rOlfP'
+         RETURN 
+         ENDIF 
+
+      rval = rin
+      uval = un
+      CALL OlfLabP (j, 4, co, R, 4, Fehler)
+      IF (Fehler.ne.'&ff') THEN 
+         Print *, 'rOlfP'
+         RETURN 
+         ENDIF 
+
+      END ! rOlfP
+
+      SUBROUTINE tOlfG (j, lab, text, Fehler)
+C     ---------------------------------------
+      IMPLICIT NONE
+      CHARACTER*(*) lab, text, Fehler
+      CHARACTER     line*80
+      INTEGER       j
+      REAL*8        R(8)
+      EQUIVALENCE  (R(1), line)
+
+      CALL OlfLabG (j, 2, lab, R, 8, Fehler)
+      text = line
+
+      END ! tOlfG
+
+      SUBROUTINE tOlfP (j, lab, text, Fehler)
+C     ---------------------------------------
+      IMPLICIT NONE
+      CHARACTER*(*) lab, text, Fehler
+      CHARACTER     line*80
+      INTEGER       j
+      REAL*8        R(8)
+      EQUIVALENCE  (R(1), line)
+
+      line = text
+      CALL OlfLabP (j, 2, lab, R, 8, Fehler)
+
+      END ! tOlfP
+
+C  --------------------------------------------------------------------
+C     4.3 user interface / access to header block 5 (coordinate names)
+C  --------------------------------------------------------------------
+
+      SUBROUTINE OlfCnuG (j, lab, co, un, Fehler)
+C     -------------------------------------------
+            ! JWu  8nov96 using old tPar 
+            ! JWu 24nov96 direct access to block
+         ! search coordinate-name-and-unit
+
+      IMPLICIT NONE
+      CHARACTER*(*) lab, co, un, Fehler
+      CHARACTER*24  cval, uval
+      INTEGER       j
+      REAL*8        R(6)
+      EQUIVALENCE  (R(1),cval)
+      EQUIVALENCE  (R(4),uval)
+
+      CALL OlfLabG (j, 5, lab, R, 6, Fehler)
+      co = cval
+      un = uval
+      IF (Fehler.ne.'&ff') Print *, 'error passed through OlfCnuG ('//lab//')'
+
+      END ! OlfCnuG
+
+      SUBROUTINE OlfCnuP (j, lab, co, un, Fehler)
+C     -------------------------------------------
+      IMPLICIT NONE
+      CHARACTER*(*) lab, co, un, Fehler
+      CHARACTER*24  cval, uval
+      CHARACTER     cl2*2
+      INTEGER       j, nZ, iOlfG
+      REAL*8        R(6)
+      EQUIVALENCE  (R(1),cval)
+      EQUIVALENCE  (R(4),uval)
+
+      IF (Fehler.ne.'&ff') THEN 
+         Print *, 'BAD PROGRAMMING STYLE/ error on entry in OlfCnuP'
+         RETURN 
+         ENDIF 
+      IF (co.eq.' ') THEN
+         CALL OlfLabDel (j, 5, lab, 6, Fehler)
+         IF (Fehler.ne.'&ff') Print *, 'error passed through OlfCnuP ('' '')'
+      ELSE
+         cval = co
+         uval = un
+         IF (lab.eq.'z+') THEN 
+            nZ = iOlfG (j, '#Z', Fehler)
+            IF (Fehler.ne.'&ff') THEN 
+               Print *, 'OlfCnuP/ error in iOlfG'
+               RETURN
+               ENDIF 
+            CALL OlfLabP (j, 5, 'z'//cl2(nZ+1), R, 6, Fehler)
+            IF (Fehler.ne.'&ff') Print *, 'error passed through OlfCnuP (z+)'
+         ELSE
+            CALL OlfLabP (j, 5, lab, R, 6, Fehler)
+            IF (Fehler.ne.'&ff')
+     *           Print *, 'error passed through OlfCnuP ('//lab//')'
+            ENDIF 
+         ENDIF
+
+      END ! OlfCnuP
+
+C  --------------------------------------------------------------------
+C     4.4 user interface / access to header block 6 (comment)
+C  --------------------------------------------------------------------
+
+      SUBROUTINE OlfComAddFull (j, adoc, acom, idat, Fehler)
+C     ------------------------------------------------------
+            ! renewed JWu 8/24nov96
+      IMPLICIT NONE
+      INCLUDE 'i_dim.f'
+      INCLUDE 'l_def.f'
+      CHARACTER*(*) adoc, acom, Fehler
+      CHARACTER*80  doc, line
+      CHARACTER     sz*8, Zeit*8, sd*10, Datum*10
+      INTEGER       j, nP, MR, MemBlockSiz, idat
+      PARAMETER     (MR=80/8)
+      REAL*8         R(MR)
+      EQUIVALENCE   (R(1), line)
+
+      IF (adoc.ne.' ') THEN
+         CALL tOlfG (j, 'doc', doc, Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+         CALL Append (doc, adoc)
+         CALL tOlfP (j, 'doc', doc, Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+         ENDIF 
+
+      nP = MemBlockSiz(j, 6) / MR
+      IF (nP.lt.0) THEN
+         Fehler = 'OlfAddCom/ block not accessible'
+         ENDIF 
+
+      CALL MemBlSubAdd (j, 6, nP*MR, MR, Fehler)
+      IF (idat.ge.1) THEN
+         sd = Datum(7)
+         sz = Zeit(5)
+         line = sd(1:7)//' '//sz(1:5)//' '//acom
+      ELSE 
+         line = acom
+         ENDIF 
+      CALL MemBlSubPut (j, 6, nP*MR, MR, R, Fehler)
+
+      END ! OlfComAddFull
+
+      SUBROUTINE OlfComAdd (j, adoc, acom, Fehler)
+C     --------------------------------------------
+      CHARACTER*(*) adoc, acom, Fehler
+      CALL OlfComAddFull (j, adoc, acom, 0, Fehler)
+      END ! OlfComAdd
+
+      SUBROUTINE OlfComLinP (j, iP, lin, Fehler)
+C     -------------------------------------------
+         ! only for use in EditDoc
+      IMPLICIT NONE
+      CHARACTER*(*) Fehler, lin
+      CHARACTER     line*80
+      INTEGER       j,  nP, iP, MR, MemBlockSiz
+      PARAMETER    (MR=80/8)
+      REAL*8        R(MR)
+      EQUIVALENCE  (R(1), line)
+
+      nP = MemBlockSiz(j, 6) / MR
+      IF (nP.lt.0) THEN
+         Fehler = 'OlfComLinP/ block not accessible'
+         RETURN 
+         ENDIF 
+
+      IF (iP.lt.1 .or. iP.gt.nP+1) THEN
+         Fehler = 'OlfComLinP/ iP oor'
+      ELSE
+         IF (iP.eq.nP+1) CALL MemBlSubAdd (j, 6, nP*MR, MR, Fehler)
+         line = lin
+         CALL MemBlSubPut (j, 6, (iP-1)*MR, MR, R, Fehler)
+         ENDIF 
+
+      END ! OlfComLinP
+
+      SUBROUTINE OlfComLinG (j, iP, lout, Fehler)
+C     -------------------------------------------
+      IMPLICIT NONE
+      CHARACTER*(*) Fehler, lout
+      CHARACTER     line*80
+      INTEGER       j,  nP, iP, MR, MemBlockSiz
+      PARAMETER    (MR=80/8)
+      REAL*8        R(MR)
+      EQUIVALENCE  (R(1), line)
+
+      nP = MemBlockSiz(j, 6) / MR
+      IF (nP.lt.0) THEN
+         Fehler = 'OlfComLinG/ block not accessible'
+         RETURN 
+         ENDIF 
+
+      IF (iP.eq.nP+1) THEN
+         lout = '&eoc' ! end-of-comment
+      ELSEIF (iP.lt.1 .or. iP.gt.nP+1) THEN
+         Fehler = 'OlfComLinG/ iP oor'
+      ELSE
+         CALL MemBlSubGet (j, 6, (iP-1)*MR, MR, R, Fehler)
+         IF (Fehler.ne.'&ff') RETURN 
+         lout = line
+         ENDIF 
+
+      END ! OlfComLinG
+
+      SUBROUTINE OlfComLinDel (j, iP, Fehler)
+C     ---------------------------------------
+      IMPLICIT NONE
+      CHARACTER*(*) Fehler
+      INTEGER       j,  nP, iP, MR, MemBlockSiz
+      PARAMETER    (MR=80/8)
+
+      nP = MemBlockSiz(j, 6) / MR
+      IF (nP.lt.0) THEN
+         Fehler = 'OlfComLinDel/ block not accessible'
+         RETURN 
+         ENDIF 
+
+      IF (iP.lt.1 .or. iP.gt.nP) THEN
+         Fehler = 'OlfComLinG/ iP oor'
+      ELSE
+         CALL MemBlSubDel (j, 6, (iP-1)*MR, MR, Fehler)
+         ENDIF 
+
+      END ! OlfComLinDel
+
+      SUBROUTINE OlfComLinDelAll (j, Fehler)
+C     --------------------------------------
+      IMPLICIT NONE
+      CHARACTER*(*) Fehler
+      INTEGER       j,  nP, iP, MR, MemBlockSiz
+      PARAMETER    (MR=80/8)
+
+      nP = MemBlockSiz(j, 6) / MR
+      IF (nP.lt.0) THEN
+         Fehler = 'OlfComLinDel/ block not accessible'
+         RETURN 
+         ENDIF 
+
+      DO iP = nP, 1, -1
+         CALL MemBlSubDel (j, 6, (iP-1)*MR, MR, Fehler)
+         IF (Fehler.ne.'&ff') RETURN 
+         ENDDO
+
+      END ! OlfComLinDelAll
+
+C  --------------------------------------------------------------------
+C     4.Appendix / indirect access
+C  --------------------------------------------------------------------
+
+      SUBROUTINE pcOlfFind (j, sel, co, un, pc, no, Fehler)
+C     -----------------------------------------------------
+            ! JWu 19nov98
+         ! search for co in header (selected by sel) blocks of file j
+         ! returns un, pc, sel
+
+      IMPLICIT NONE 
+      INCLUDE    'l_def.f'
+      INTEGER     j, no, is, iZ, nZ, iOlfG
+      CHARACTER   sel*(*), co*(*), un*(*), pc*(*), Fehler*(*), coI*40, cs*1
+
+      DO is = 1, lenU(sel)
+         cs = sel(is:is)
+         IF (cs.eq.'z') THEN
+            nZ = iOlfG (j, '#Z', Fehler)
+            DO iZ = 1, nZ
+               CALL OlfCnuG (j, 'z'//cl2(iZ), coI, un, Fehler)
+               IF (Fehler.ne.'&ff') THEN 
+                  CALL Insert (Fehler, 1, 'pcOlfFind/')
+                  RETURN 
+                  ENDIF 
+               IF (coI.eq.co) THEN ! yes, it is 'z'
+                  pc = 'z'
+                  no = iZ
+                  RETURN 
+                  ENDIF
+               ENDDO 
+            
+         ELSE
+            Fehler = ' this search option not yet implemented'
+            RETURN 
+            ENDIF 
+         ENDDO
+
+      pc = '-'
+      no =  0
+      Fehler = '&pnf'
+
+      END ! pcOlfFind
+
+      LOGICAL FUNCTION qOlfG (j, lab, Fehler)
+C     ---------------------------------------
+      IMPLICIT NONE
+      CHARACTER*(*) lab, Fehler
+      LOGICAL       qintr
+      INTEGER       iOlfG, j, ival
+      
+      ival  = iOlfG(j, lab, Fehler)
+      qOlfG = qintr(ival)
+
+      END ! qOlfG
+
+      INTEGER FUNCTION iOlfGdef (j, lab, idef, Fehler)
+C     ------------------------------------------------
+      CHARACTER*(*) lab, Fehler
+      iOlfGdef = iOlfG (j, lab, Fehler)
+      IF (Fehler(1:4).eq.'&pnf') THEN
+         iOlfGdef = idef
+         Fehler = '&ff'
+         ENDIF
+      END ! iOlfGdef
+
+      LOGICAL FUNCTION qOlfGdef (j, lab, idef, Fehler)
+C     ------------------------------------------------
+      IMPLICIT NONE
+      CHARACTER*(*) lab, Fehler
+      LOGICAL       qintr
+      INTEGER       iOlfGdef, j, ival, idef
+      
+      ival = iOlfGdef (j, lab, idef, Fehler)
+      qOlfGdef = qintr(ival)
+
+      END ! qOlfGdef
+
+      REAL*8 FUNCTION rOlfGdef (j, co, un, rdef, Fehler)
+C     --------------------------------------------------
+         ! read one real parameter from the header of file j.
+      IMPLICIT NONE
+      CHARACTER*(*) co, un, Fehler
+      INTEGER       j
+      REAL*8        rdef, rOlfG
+
+      rOlfGdef = rOlfG (j, co, un, Fehler)
+      IF (Fehler(1:4).eq.'&pnf') THEN
+         rOlfGdef = rdef
+         Fehler = '&ff'
+         ENDIF
+
+      END ! rOlfGdef
+
+      REAL*8 FUNCTION rzOlfG (j, K, co, un, Fehler)
+C     ---------------------------------------------
+            ! JWu 9nov96
+         ! co is either 'z', or a parameter
+
+      IMPLICIT NONE
+      INCLUDE      'i_dim.f'
+      INCLUDE      'l_def.f'
+      CHARACTER*(*) co, un, Fehler
+      CHARACTER*40  coI
+      INTEGER       j, K, nZ, iZ, iOlfG
+      REAL*8        rval, rOlfG
+
+      rzOlfG = 0
+      nZ = iOlfG (j, '#Z', Fehler)
+      DO iZ = 1, nZ
+         CALL OlfCnuG (j, 'z'//cl2(iZ), coI, un, Fehler)
+         IF (Fehler.ne.'&ff') THEN 
+            Print *, 'rzOlfG[CnuG]'
+            RETURN 
+            ENDIF 
+         IF (coI.eq.co) THEN ! yes, it is 'z'
+            CALL OlfGet1Z (j, K, iZ, rval, Fehler)
+            IF (Fehler.ne.'&ff') THEN 
+               Print *, 'rzOlfG[1Z]'
+               RETURN 
+               ENDIF 
+            rzOlfG = rval
+            RETURN
+            ENDIF
+         ENDDO 
+      rzOlfG = rOlfG (j, co, un, Fehler) ! either it's a param, or Fehler..
+      IF (Fehler.ne.'&ff' .and. Fehler(1:4).ne.'&pnf')
+     *     Print *, 'rzOlfG -> rOlfG'
+
+      END ! rzOlfG
+
+      REAL*8 FUNCTION rzxOlfG (j, K, i, co, un, Fehler)
+C     -------------------------------------------------
+            ! JWu 9nov96
+         ! co is either 'z', or 'x', or a parameter
+
+      IMPLICIT NONE
+      INCLUDE      'i_dim.f'
+      INCLUDE      'l_def.f'
+      CHARACTER*(*) co, un, Fehler
+      CHARACTER*40  coI
+      INTEGER       j, K, i, n, nZ, iZ, iOlfG
+      REAL*8        rval, rOlfG, X(MC), Y(MC)
+
+      rzxOlfG = 0
+      CALL OlfCnuG (j, 'x', coI, un, Fehler)
+cdeb      Print *, '1/ ', coI, ":", Fehler
+      IF (Fehler.ne.'&ff') RETURN
+      IF (coI.eq.co) THEN ! yes, it is 'x'
+         CALL OlfGetXY (j, K, n, X, Y, Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+         IF (i.lt.1 .or. i.gt.n) THEN
+            Fehler = 'search for x/z/par: invalid index of x'
+            RETURN
+            ENDIF
+         rzxOlfG = X(i)
+         RETURN
+         ENDIF
+      nZ = iOlfG (j, '#Z', Fehler)
+      DO iZ = 1, nZ
+         CALL OlfCnuG (j, 'z'//cl2(iZ), coI, un, Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+         IF (coI.eq.co) THEN ! yes, it is 'z#'
+            CALL OlfGet1Z (j, K, iZ, rval, Fehler)
+            IF (Fehler.ne.'&ff') RETURN
+            rzxOlfG = rval
+            RETURN
+            ENDIF
+         ENDDO 
+      rzxOlfG = rOlfG (j, co, un, Fehler) ! either it's a param, or Fehler..
+      IF (Fehler.ne.'&ff' .and. Fehler(1:4).ne.'&pnf')
+     *     Print *, 'rzxOlfG -> rOlfG'
+
+      END ! rzxOlfG
+
+      REAL*8 FUNCTION rOlfGG (j, co, un, Fehler)
+C     ------------------------------------------
+            ! JWu 9nov96
+         ! befor returning the value of parameter (co),
+         ! check that (un) agrees with the stored unit.
+
+      IMPLICIT NONE
+      CHARACTER*(*) co, un, Fehler
+      CHARACTER*40  unI
+      INTEGER       j
+      REAL*8        rval, rOlfG 
+
+      rOlfGG = 0
+      rval = rOlfG (j, co, unI, Fehler)
+      IF (Fehler.ne.'&ff') RETURN
+      IF (un.ne.unI) THEN
+         CALL Compose3 (Fehler, 'coordinate '//co, ' has unit '//unI,
+     *                  ' instead of requested '//un)
+         RETURN
+         ENDIF
+      rOlfGG = rval
+
+      END ! rOlfGG
+
+      REAL*8 FUNCTION rOlfGGdef (j, co, un, rdef, Fehler)
+C     ---------------------------------------------------
+
+      IMPLICIT NONE
+      CHARACTER*(*) co, un, Fehler
+      CHARACTER*40  unI
+      INTEGER       j
+      REAL*8        rval, rdef, rOlfG 
+
+      rOlfGGdef = 0
+      rval = rOlfG (j, co, unI, Fehler)
+      IF (Fehler(1:4).eq.'&pnf') THEN
+         rOlfGGdef = rdef
+         Fehler = '&ff'
+         RETURN 
+         ENDIF
+      IF (Fehler.ne.'&ff') RETURN
+      IF (un.ne.unI) THEN
+         CALL Compose3 (Fehler, 'coordinate '//co, ' has unit '//unI,
+     *                  ' instead of requested '//un)
+         RETURN
+         ENDIF
+      rOlfGGdef = rval
+
+      END ! rOlfGGdef
+
+      REAL*8 FUNCTION rzOlfGG (j, K, co, un, Fehler)
+C     ----------------------------------------------
+
+      IMPLICIT NONE
+      CHARACTER*(*) co, un, Fehler
+      CHARACTER*40  unI
+      INTEGER       j, K
+      REAL*8        rval, rzOlfG
+
+      rzOlfGG = 0
+      rval = rzOlfG (j, K, co, unI, Fehler)
+      IF (Fehler.ne.'&ff') RETURN
+      IF (un.ne.unI) THEN
+         CALL Compose3 (Fehler, 'coordinate '//co, ' has unit '//unI,
+     *                  ' instead of requested '//un)
+         RETURN
+         ENDIF
+      rzOlfGG = rval
+
+      END ! rzOlfGG
+
+      REAL*8 FUNCTION rzxOlfGG (j, K, i, co, un, Fehler)
+C     --------------------------------------------------
+
+      IMPLICIT NONE
+      CHARACTER*(*) co, un, Fehler
+      CHARACTER*40  unI
+      INTEGER       j, K, i
+      REAL*8        rval, rzxOlfG
+
+      rzxOlfGG = 0
+      rval = rzxOlfG (j, K, i, co, unI, Fehler)
+      IF (Fehler.ne.'&ff') RETURN
+      IF (un.ne.unI) THEN
+         CALL Compose3 (Fehler, 'coordinate '//co, ' has unit '//unI,
+     *                  ' instead of requested '//un)
+         RETURN
+         ENDIF
+      rzxOlfGG = rval
+
+      END ! rzxOlfGG
+
+      SUBROUTINE iOlfCopy (jin, jout, what, Fehler)
+C     ---------------------------------------------
+            ! JWu 9nov96
+
+      CHARACTER*(*) what, Fehler
+
+      ival = iOlfG (jin, what, Fehler)
+      IF (Fehler.ne.'&ff') RETURN
+      CALL iOlfP (jout, what, ival, Fehler)
+
+      END ! iOlfCopy
+
+      SUBROUTINE rOlfCopy (jin, jout, Co, Fehler)
+C     -------------------------------------------
+            ! JWu 9nov96
+
+      IMPLICIT NONE
+      CHARACTER*(*) Co, Fehler
+      CHARACTER*40  Un
+      REAL*8        rval, rOlfG
+      INTEGER       jin, jout
+
+      rval = rOlfG (jin, Co, Un, Fehler)
+      IF (Fehler.ne.'&ff') RETURN
+      CALL rOlfP (jout, Co, Un, rval, Fehler)
+
+      END ! rOlfCopy
+
+      SUBROUTINE OlfCnuCheck2 (j1, j2, which, lCo, lUn, Fehler)
+C     ---------------------------------------------------------
+            ! JWu 10nov96
+         ! Check agreement between coord's of two files
+         ! Levels: 0=check nothing, 1=ask user, 2=always Fehler
+
+      IMPLICIT NONE
+      CHARACTER*(*) which, Fehler
+      INTEGER       j1, j2, lCo, lUn
+      CHARACTER*40  Co1, Un1, Co2, Un2
+      CHARACTER*80  aus
+      LOGICAL       qAsk
+
+      IF (Fehler.ne.'&ff') RETURN
+
+      CALL OlfCnuG (j1, which, Co1, Un1, Fehler)
+      IF (Fehler.ne.'&ff') RETURN
+      CALL OlfCnuG (j2, which, Co2, Un2, Fehler)
+      IF (Fehler.ne.'&ff') RETURN
+
+      IF (Co1.ne.Co2) THEN
+         IF     (lCo.ge.2) THEN
+            CALL Compose2 (Fehler, 
+     *         'files have different '//which//' coordinates '//Co1, 
+     *         ' and '//Co2)
+            RETURN
+         ELSEIF (lCo.ge.1) THEN
+            CALL Compose3 (aus, 
+     *         'files have different '//which//' coordinates '//Co1, 
+     *         ' and '//Co2, ' - continue ?')
+            IF (.not.qAsk(aus)) THEN
+               Fehler = ' '
+               RETURN
+               ENDIF
+            ENDIF
+         ENDIF
+
+      IF (Un1.ne.Un2) THEN
+         IF     (lUn.ge.2) THEN
+            CALL Compose2 (Fehler, 
+     *         'files have different '//which//' units '//Un1, ' and '//Un2)
+            RETURN
+         ELSEIF (lUn.ge.1) THEN
+            CALL Compose3 (aus, 
+     *         'files have different '//which//' units '//Un1, ' and '//Un2,
+     *         ' - continue ?')
+            IF (.not.qAsk(aus)) THEN
+               Fehler = ' '
+               RETURN
+               ENDIF
+            ENDIF
+         ENDIF
+
+      END ! OlfCnuCheck2
+
+C  ====================================================================
+C     5. Access to data blocks
+C  ====================================================================
+
+C  --------------------------------------------------------------------
+C     5.1 data put
+C  --------------------------------------------------------------------
+
+      SUBROUTINE OlfPutZ (j, K, nZ, Z, Fehler)
+C     ----------------------------------------
+         ! JWu 23.1.91 (MemGetXY), 17may95
+      ! Overwrite a spectrum in / MEM / by another one.
+
+      IMPLICIT NONE
+      INCLUDE 'i_dim.f'
+
+      INTEGER       j, K, nZ, nZ1, MemBlockNum, MemBlockSiz
+      REAL*8        Z(*)
+      CHARACTER     Fehler*(*), cr3*3
+
+      IF (Fehler.ne.'&ff') THEN 
+         Print *, 'error on entry in OlfPutZ'
+         RETURN
+      ELSEIF (MemBlockNum(j).lt.MBH) THEN
+         Print *, ' j K MBH MemBlNum(j) ', j, K, MBH, MemBlockNum(j)
+         Fehler = 'OPZ/ cannot save spectrum before header blocks are saved'
+         RETURN
+      ELSEIF (K.lt.0) THEN ! ??
+         Fehler = 'OPZ/ call with K<0'
+         RETURN
+      ELSEIF (K.gt.MK) THEN
+         Fehler = 'OPZ/ file shall not contain more than '//cr3(MK)//' spectra'
+         RETURN
+         ENDIF
+
+      IF (K.eq.1) THEN 
+         IF (nZ.lt.0) THEN
+            Fehler = 'OPZ/ call with nZ<0'
+            RETURN
+         ELSEIF (nZ.gt.MZ) THEN
+            Fehler = 'OPZ/ call with nZ>MZ'
+            RETURN
+            ENDIF 
+      ELSE
+         nZ1 = MemBlockSiz(j, MBH+1)
+         IF (nZ1.lt.0) THEN 
+            Fehler = 'OPZ/ nZ(#1) invalid'
+            RETURN 
+         ELSEIF (nZ.ne.nZ1) THEN
+            Print *, ' nZ(in) nZ1(<MemBlock) j K ', nZ, nZ1, j, K
+            Fehler = 'OPZ/ #Z different from spectrum 1'
+            RETURN 
+            ENDIF 
+         ENDIF 
+
+      CALL MemBlockOvr (j, MBH+4*(K-1)+1, nZ, Z, Fehler)
+      IF (Fehler.ne.'&ff') THEN 
+         Print *, 'OlfPutZ'
+         RETURN 
+         ENDIF 
+
+      END ! OlfPutZ
+
+      SUBROUTINE OlfPutXYD (j, K, n, X, Y, D, Fehler)
+C     -----------------------------------------------
+         ! JWu 23.1.91 (MemGetXY), 17may95
+      ! Overwrite a spectrum in / MEM / by another one.
+
+      IMPLICIT NONE
+      INCLUDE 'i_dim.f'
+
+      INTEGER       i, j, K, n, MemBlockNum
+      REAL*8        X(*), Y(*), D(*), z
+                    ! for semi-external input routines, X,Y,D may be declared
+                    ! with a size MCin < MC : therefore we use (*).
+      CHARACTER     Fehler*(*), cr3*3
+
+      IF (Fehler.ne.'&ff') THEN 
+         Print *, 'error on entry in OlfPutXYD'
+         RETURN
+      ELSEIF (MemBlockNum(j).lt.MBH) THEN
+         Fehler = 'OSP/ cannot save spectrum before header blocks are saved'
+         RETURN
+      ELSEIF (n.lt.0) THEN
+         Fehler = 'OSP/ n<0'
+         RETURN
+      ELSEIF (n.gt.MC) THEN
+         Fehler = 'OSP/ call with n>MC'
+         RETURN
+      ELSEIF (n*3+1.gt.MmemSpe) THEN
+         Fehler = 'PROGR ERR/ MmemSpe inconsistent with MC'
+         RETURN
+      ELSEIF (K.lt.0) THEN ! ??
+         Fehler = 'OSP/ call with K<0'
+         RETURN
+      ELSEIF (K.gt.MK) THEN
+         Fehler = 'OSP/ file shall not contain more than '//cr3(MK)//' spectra'
+         RETURN
+      ELSEIF (n.le.0) THEN   
+         Fehler = 'OSP/ call with n=0 replaced by OlfDelSpe'
+         RETURN 
+      ELSEIF (MemBlockNum(j).lt.MBH+4*(K-1)+1) THEN
+         Print *, ' j K MBH MemBlNum(j) ', j, K, MBH, MemBlockNum(j)
+         Fehler = 'OlfPutXYD/ cannot save X,Y,D before Z'
+         RETURN
+         ENDIF
+
+      CALL MemBlockOvr (j, MBH+4*(K-1)+2, n, X, Fehler)
+      IF (Fehler.ne.'&ff') THEN 
+         Print *, 'error passed through OlfPutXYD / X'
+         RETURN 
+         ENDIF 
+      CALL MemBlockOvr (j, MBH+4*(K-1)+3, n, Y, Fehler)
+      IF (Fehler.ne.'&ff') THEN 
+         Print *, 'error passed through OlfPutXYD / Y'
+         RETURN 
+         ENDIF 
+      CALL MemBlockOvr (j, MBH+4*(K-1)+4, n, D, Fehler)
+      IF (Fehler.ne.'&ff') THEN 
+         Print *, 'error passed through OlfPutXYD / D'
+         RETURN 
+         ENDIF 
+
+      END ! OlfPutXYD
+
+C  --------------------------------------------------------------------
+C     .. indirect calls
+C  --------------------------------------------------------------------
+
+      SUBROUTINE OlfPutXY0 (j, K, n, X, Y, Fehler)
+C     ---------------------------------------------
+         ! Overwrite z, X and Y within a spectrum, set D=0
+         ! (needed for consistency with GetXY)
+         ! Vorsicht: soll nicht dazu dienen, die Fehlerrechnung auszuhebeln ..
+
+      IMPLICIT NONE
+      INCLUDE 'i_dim.f'
+
+      INTEGER       j, K, n
+      REAL*8        X(*), Y(*), D(MC)
+      CHARACTER     Fehler*(*)
+      DATA          D / MC * 0.d0 /
+
+      CALL OlfPutXYD (j, K, n, X, Y, D, Fehler)
+
+      END ! OlfPutXY0
+
+      SUBROUTINE OlfPutSpe (j, K, nZ, Z, n, X, Y, D, Fehler)
+C     -------------------------------------------------------
+
+      IMPLICIT NONE
+      INCLUDE 'i_dim.f'
+
+      INTEGER       j, K, nZ, n
+      REAL*8        X(*), Y(*), D(*), Z(*)
+      CHARACTER     Fehler*(*)
+
+      IF (Fehler.ne.'&ff') THEN
+         Print *, 'Error on entry in OlfPutSpe'
+         RETURN
+         ENDIF
+      CALL OlfPutZ (j, K, nZ, Z, Fehler)
+      IF (Fehler.ne.'&ff') THEN
+         Print *, 'j K nZ n ', j, K, nZ, n
+         Print *, 'error passed through OPS(Z)'
+         RETURN
+         ENDIF
+      CALL OlfPutXYD (j, K, n, X, Y, D, Fehler)
+      IF (Fehler.ne.'&ff') THEN
+         Print *, 'error passed through OPS(XYD)'
+         RETURN
+         ENDIF
+
+      END ! OlfPutSpe
+
+C  --------------------------------------------------------------------
+C     5.2  data get
+C  --------------------------------------------------------------------
+
+      SUBROUTINE OlfGetZ (j, K, nZ, Z, Fehler)
+C     ----------------------------------------
+
+      IMPLICIT NONE
+      INCLUDE 'i_dim.f'
+
+      INTEGER       j, K, nZ
+      REAL*8        Z(MZ)
+      CHARACTER     Fehler*(*)
+
+      IF (Fehler.ne.'&ff') THEN 
+         Print *, 'error on entry in OlfGetZ'
+         RETURN 
+         ENDIF
+
+      CALL MemBlockGet (j, MBH+4*(K-1)+1, nZ, MZ, Z, Fehler)
+      IF (Fehler.ne.'&ff') THEN 
+         Print *, 'error passed through OlfGetZ'
+         RETURN 
+         ENDIF 
+
+      END ! OlfGetZ
+
+      SUBROUTINE OlfGetN (j, K, nC, Fehler)
+C     -------------------------------------
+            ! JWu 6feb97
+
+      IMPLICIT NONE
+      INCLUDE 'i_dim.f'
+      INTEGER       j, K, nC, nCY, nCD, MemBlockSiz
+      CHARACTER     Fehler*(*)
+
+      IF (Fehler.ne.'&ff') THEN 
+         Print *, 'error on entry in OlfGetN'
+         RETURN 
+         ENDIF
+
+      nC  =  MemBlockSiz (j, MBH+4*(K-1)+2)
+      nCY =  MemBlockSiz (j, MBH+4*(K-1)+3)
+      nCD =  MemBlockSiz (j, MBH+4*(K-1)+4)
+
+      IF (nC.ne.nCY .or. nC.ne.nCD) THEN
+         Print *, ' j K nX nY nD ', nC, nCY, nCD
+         Fehler = 'OlfGetN/ nX inconsistent with nY or nD'
+         RETURN 
+         ENDIF 
+
+      END ! OlfGetN
+
+      SUBROUTINE OlfGetXYD (j, K, nC, X, Y, D, Fehler)
+C     ------------------------------------------------
+            ! JWu 16sep91, 17/19may95
+         ! Get spectrum K of file j from memory.
+
+      IMPLICIT NONE
+      INCLUDE 'i_dim.f'
+
+      INTEGER       j, K, nC, nCY, nCD
+      REAL*8        X(MC), Y(MC), D(MC)
+      CHARACTER     Fehler*(*)
+
+      CALL MemBlockGet (j, MBH+4*(K-1)+2, nC,  MC, X, Fehler)
+        IF (Fehler.ne.'&ff') GOTO 99
+      CALL MemBlockGet (j, MBH+4*(K-1)+3, nCY, MC, Y, Fehler)
+        IF (Fehler.ne.'&ff') GOTO 99
+      CALL MemBlockGet (j, MBH+4*(K-1)+4, nCD, MC, D, Fehler)
+        IF (Fehler.ne.'&ff') GOTO 99
+
+      IF (nC.ne.nCY .or. nC.ne.nCD) THEN
+         Print *, 'j K #X #Y #D', j, K, nC, nCY, nCD
+         Fehler = 'OlfGetXYD/ nC inconsistent'
+         RETURN 
+         ENDIF 
+
+      RETURN
+ 99   CONTINUE
+      Print *, 'error passed through OlfGetXYD'
+
+      END ! OlfGetXYD
+
+      SUBROUTINE OlfGetXY (j, K, nC, X, Y, Fehler)
+C     --------------------------------------------
+
+      IMPLICIT NONE
+      INCLUDE 'i_dim.f'
+
+      INTEGER       j, K, nC, nCY
+      REAL*8        X(MC), Y(MC)
+      CHARACTER     Fehler*(*)
+
+      CALL MemBlockGet (j, MBH+4*(K-1)+2, nC,  MC, X, Fehler)
+        IF (Fehler.ne.'&ff') GOTO 99
+      CALL MemBlockGet (j, MBH+4*(K-1)+3, nCY, MC, Y, Fehler)
+        IF (Fehler.ne.'&ff') GOTO 99
+
+      IF (nC.ne.nCY) THEN
+         Print *, 'j K #X #Y ', j, K, nC, nCY
+         Fehler = 'OlfGetXY/ nC inconsistent'
+         RETURN 
+         ENDIF 
+
+      RETURN
+ 99   CONTINUE
+      Print *, 'error passed through OlfGetXY'
+
+      END ! OlfGetXY
+
+      SUBROUTINE OlfGetX (j, K, n, X, Fehler)
+C     ---------------------------------------
+
+      IMPLICIT NONE
+      INCLUDE 'i_dim.f'
+
+      INTEGER       j, K, n
+      REAL*8        X(MC)
+      CHARACTER     Fehler*(*)
+
+      CALL MemBlockGet (j, MBH+4*(K-1)+2, n, MC, X, Fehler)
+      IF (Fehler.ne.'&ff') Print *, 'error passed through OlfGetX'
+
+      END ! OlfGetX
+
+      SUBROUTINE OlfGetY (j, K, n, Y, Fehler)
+C     ---------------------------------------
+
+      IMPLICIT NONE
+      INCLUDE 'i_dim.f'
+
+      INTEGER       j, K, n
+      REAL*8        Y(MC)
+      CHARACTER     Fehler*(*)
+
+      CALL MemBlockGet (j, MBH+4*(K-1)+3, n, MC, Y, Fehler)
+      IF (Fehler.ne.'&ff') Print *, 'error passed through OlfGetY'
+
+      END ! OlfGetY
+
+C  --------------------------------------------------------------------
+C     .. indirect access
+C  --------------------------------------------------------------------
+
+      SUBROUTINE OlfGetSpe (j, K, nZ, Z, nC, X, Y, D, Fehler)
+C     -------------------------------------------------------
+      IMPLICIT NONE
+      INCLUDE 'i_dim.f'
+
+      INTEGER       i, j, K, nC, nZ, MemBlockSiz
+      REAL*8        X(MC), Y(MC), D(MC), Z(MZ)
+      CHARACTER     Fehler*(*)
+
+      CALL OlfGetZ (j, K, nZ, Z, Fehler)
+      IF (Fehler.ne.'&ff') RETURN 
+      CALL OlfGetXYD (j, K, nC, X, Y, D, Fehler)
+      IF (Fehler.ne.'&ff') RETURN 
+
+      END ! OlfGetSpe
+
+      SUBROUTINE OlfGet1Z (j, K, iZ, zout, Fehler)
+C     --------------------------------------------
+      IMPLICIT NONE
+      INCLUDE 'i_dim.f'
+      INTEGER       j, K, nZ, iZ
+      REAL*8        Z(MZ), zout
+      CHARACTER     Fehler*(*), cl4*4
+
+      IF (Fehler.ne.'&ff') THEN 
+         Print *, 'error on entry in OlfGet1Z'
+         RETURN 
+         ENDIF
+
+      CALL OlfGetZ (j, K, nZ, Z, Fehler)
+      IF (Fehler.ne.'&ff') THEN 
+         IF (Fehler.ne.'&ff') Print *, 'error passed through OlfGet1Z'
+         RETURN 
+         ENDIF 
+      
+      IF (iZ.lt.0) THEN
+         Fehler = 'OlfGet1Z/ iz<1 requested'
+         RETURN 
+      ELSEIF (iZ.gt.nZ) THEN
+         CALL Compose2 (Fehler, 'OlfGet1Z/ iz='//cl4(iZ),
+     *        ' requested while nz='//cl4(nZ))
+         RETURN
+         ENDIF 
+      zout = Z(iZ)
+
+      END ! OlfGet1Z
+
+      SUBROUTINE OlfGet1ZofK (j, iZ, nK, Z, Fehler)
+C     ---------------------------------------------
+            ! JWu 16sep91 (MemGetZ), 17may95
+         ! Get nK, and for K=1,..,nK : Z(iZ;K) from memory.
+
+      IMPLICIT NONE
+      INCLUDE 'i_dim.f'
+
+      CHARACTER     Fehler*(*)
+      INTEGER       j, nB, iZ, K, nK, MemBlockNum
+      REAL*8        Z(MK)
+
+      nB = MemBlockNum(j) 
+      IF (nB.lt.1) THEN
+         Fehler = 'OlfGet1ZofK/ File does not exist'
+         RETURN
+      ELSEIF (nB.le.MBH) THEN
+         Fehler = 'OlfGet1ZofK/ File has uncomplete header'
+         RETURN
+         ENDIF
+      nK = (nB - MBH) / 4
+      DO K = 1, nK
+         CALL OlfGet1Z (j, K, iZ, Z(K), Fehler)
+         IF (Fehler.ne.'&ff') RETURN 
+         ENDDO
+
+      END ! OlfGet1ZofK
+
+      SUBROUTINE OlfGetNofK (j, nK, Nz, Fehler)
+C     -----------------------------------------
+         ! Get nK, and for K=1,..,nK n(K) from memory.
+
+      IMPLICIT NONE
+      INCLUDE 'i_dim.f'
+
+      CHARACTER     Fehler*(*)
+      INTEGER       j, nB, K, nK, nC, Nz(MK), MemBlockNum
+
+      nB = MemBlockNum(j) 
+      IF (nB.lt.1) THEN
+         Fehler = 'OlfGetNofK/ File does not exist'
+         RETURN
+      ELSEIF (nB.le.MBH) THEN
+         Fehler = 'OlfGetNof/ File has uncomplete header'
+         RETURN
+         ENDIF
+      nK = (nB - MBH) / 4
+      DO K = 1, nK
+         CALL OlfGetN  (j, K, Nz(K), Fehler)
+         IF (Fehler.ne.'&ff') THEN
+            Print *, 'error passed through OlfGetNofK'
+            RETURN
+            ENDIF
+         ENDDO
+
+      END ! OlfGetNofK
+
+      SUBROUTINE OlfDel1Z (j, jout, iZ, Fehler)
+C     -----------------------------------------
+            ! JWu 4/6mrz98
+
+      IMPLICIT NONE
+      INCLUDE 'i_dim.f'
+      CHARACTER         Fehler*(*), Co*40, Un*40, cl2*2
+      INTEGER           j, jout, iZ, nB, MemBlockNum, nK, K, nZ, iiZ
+      REAL*8            Z(MZ)
+
+      nB = MemBlockNum(j) 
+      nK = (nB - MBH) / 4
+      DO K = 1, nK
+         CALL OlfGetZ (j, K, nZ, Z, Fehler)
+         IF (Fehler.ne.'&ff') RETURN 
+         IF (iZ.gt.nZ) THEN 
+            Fehler = ' cannot delete coordinate z'//cl2(iZ)
+            RETURN
+            ENDIF 
+         DO iiZ = iZ, nZ-1
+            Z(iiZ) = Z(iiZ+1)
+            ENDDO 
+         CALL OlfPutZ (jout, K, nZ-1, Z, Fehler)
+         ENDDO
+         CALL OlfCnuG (jout, 'y', Co, Un, Fehler)
+
+      DO iiZ = iZ, nZ-1
+         CALL OlfCnuG (j, 'z'//cl2(iiZ+1), Co, Un, Fehler)
+         CALL OlfCnuP (jout, 'z'//cl2(iiZ), Co, Un, Fehler)
+         IF (Fehler.ne.'&ff') RETURN 
+         ENDDO 
+
+      CALL OlfCnuP (jout, 'z'//cl2(nZ), ' ', ' ', Fehler)
+
+      END ! OlfDel1Z
+
+C  --------------------------------------------------------------------
+C     5.3 spectra copy
+C  --------------------------------------------------------------------
+
+      SUBROUTINE OlfCopZ (jin, jout, Kin, Kout, Fehler)
+C     -------------------------------------------------
+            ! JWu 6feb97 corr. 4mrz98
+      IMPLICIT NONE 
+      INCLUDE 'i_dim.f'
+      INTEGER        jin, jout, Kin, Kout, nZ
+      REAL*8         Z(MZ)
+      CHARACTER*(*)  Fehler
+
+      CALL OlfGetZ (jin, Kin, nZ, Z, Fehler)
+      IF (Fehler.ne.'&ff') RETURN 
+      CALL OlfPutZ (jout, Kout, nZ, Z, Fehler)
+      IF (Fehler.ne.'&ff') RETURN 
+
+      END ! OlfCopZ
+
+      SUBROUTINE OlfCopXYD (jin, jout, Kin, Kout, Fehler)
+C     ---------------------------------------------------
+            ! JWu 6feb97
+      IMPLICIT NONE 
+      INCLUDE 'i_dim.f'
+      INTEGER        jin, jout, Kin, Kout, nC
+      REAL*8         X(MC), Y(MC), D(MC)
+      CHARACTER*(*)  Fehler
+
+      CALL OlfGetXYD (jin, Kin, nC, X, Y, D, Fehler)
+      IF (Fehler.ne.'&ff') RETURN 
+      CALL OlfPutXYD (jout, Kout, nC, X, Y, D, Fehler)
+      IF (Fehler.ne.'&ff') RETURN 
+
+      END ! OlfCopXYD
+
+      SUBROUTINE OlfCopSpe (jin, jout, Kin, Kout, Fehler)
+C     ---------------------------------------------------
+            ! JWu 6feb97
+      IMPLICIT NONE 
+      INTEGER        jin, jout, Kin, Kout
+      CHARACTER*(*)  Fehler
+
+      CALL OlfCopZ   (jin, jout, Kin, Kout, Fehler)
+      IF (Fehler.ne.'&ff') RETURN 
+      CALL OlfCopXYD (jin, jout, Kin, Kout, Fehler)
+      IF (Fehler.ne.'&ff') RETURN 
+
+      END ! OlfCopSpe
+
+C  --------------------------------------------------------------------
+C     5.4 spectra delete
+C  --------------------------------------------------------------------
+
+      SUBROUTINE OlfDelSpe (j, K, Fehler)
+C     -----------------------------------
+
+      IMPLICIT NONE
+      INCLUDE 'i_dim.f'
+
+      INTEGER       i, j, K, nC, MemBlockNum
+      REAL*8        R(1) ! dummy
+      CHARACTER     Fehler*(*)
+
+      CALL MemBlockOvr (j, MBH+4*(K-1)+4, -1, R, Fehler)
+      IF (Fehler.ne.'&ff') THEN 
+         Print *, 'error passed through OlfDelSPe/ ~D'
+         RETURN
+         ENDIF 
+      CALL MemBlockOvr (j, MBH+4*(K-1)+3, -1, R, Fehler)
+      IF (Fehler.ne.'&ff') THEN 
+         Print *, 'error passed through OlfDelSPe/ ~Y'
+         RETURN
+         ENDIF 
+      CALL MemBlockOvr (j, MBH+4*(K-1)+2, -1, R, Fehler)
+      IF (Fehler.ne.'&ff') THEN 
+         Print *, 'error passed through OlfDelSPe/ ~X'
+         RETURN
+         ENDIF 
+      CALL MemBlockOvr (j, MBH+4*(K-1)+1, -1, R, Fehler)
+      IF (Fehler.ne.'&ff') THEN 
+         Print *, 'error passed through OlfDelSPe/ ~z'
+         RETURN
+         ENDIF 
+
+      END ! OlfDelSpe
+
+      SUBROUTINE FileClean ()
+C     -----------------------
+            ! JWu 26nov91
+         ! Delete files which are not closed or which are empty.
+
+      INCLUDE 'i_dim.f'
+      INCLUDE 'l_def.f'
+
+      CHARACTER*80 Fehler
+      
+      Fehler = '&ff'
+      DO j = MemBlockInq('nF'), 1, -1
+         nK = (MemBlockNum(j) - MBH) / 4
+         DO K = MemBlockNum(j), MBH+1, -4
+            IF (MemBlockSiz(j,K-2).le.0) THEN 
+               CALL Say2 (' .. cleaning up/ delete empty spectrum '//
+     *              cl4((K-MBH)/4),
+     *              ' in file '//cl3(j))
+               DO KK = K, K-3, -1
+                  CALL MemBlockPut (j, KK, -1, dummy, Fehler)
+                  IF (Fehler.ne.'&ff') CALL FehlerGong (Fehler,1)
+                  ENDDO 
+               ENDIF
+            ENDDO
+         nK = (MemBlockNum(j) - MBH) / 4
+         IF (nK.le.0) THEN 
+            Print '(a)', ' .. cleaning up/ delete empty file '//cl3(j)
+            CALL MemBlockPut (j, 0, -1, dummy, Fehler)
+            IF (Fehler.ne.'&ff') CALL FehlerGong (Fehler,1)
+            ENDIF
+         ENDDO 
+
+      END ! FileClean

arch/frida-1.4/i23.f

+C  ====================================================================
+C
+C      Library  IDA   :  Inelastic Data Analysis
+C      Modul    i23   :     directories, editing, r/z-handling
+C
+C  ====================================================================
+
+C     Contents :
+C        1.  Directories and Editing :
+C               MemInfoF/Z/K/Y
+C        2.  Editing :
+C               EditCnu, EditDoc, EditZ, EditRPar, EditIPar, EditGPar
+C        3.  Handling of z/r :
+C               ..
+
+C  ====================================================================
+C  i23 / 1 :   directories 
+C  ====================================================================
+
+      SUBROUTINE MemInfoF (Fehler)
+C     ----------------------------
+            ! JWu 16may95
+         ! directory of on-line files
+
+      IMPLICIT REAL*8   (a-h,o-p,r-z)
+      IMPLICIT LOGICAL  (q)
+
+      INCLUDE 'i_dim.f'
+      INCLUDE 'l_def.f'
+      CHARACTER   Fehler*(*), aus*80
+      CHARACTER   h1*10, cMod*1, Fil*80, Doc*40, Tit*80,
+     *            xCo*40, yCo*40, xUn*40, yUn*40
+      DIMENSION   NofK(MK)
+      
+      iRest = MemBlockInq ('fE')
+      iTot  = MemBlockInq ('ME')
+
+C  Head line :
+      write (h1, '(f5.1)') 100 * dflotj(iRest)/iTot
+      CALL DelLeft (h1)
+      CALL Say4 (' '//cl8(iRest),' lines free in run-time memory (',h1,'%)')
+
+C  Table of files :
+      DO j = 1, MemBlockInq ('nF')
+
+         CALL MemFileStatG (j, iStat, Fehler)
+         IF (Fehler.ne.'&ff') GOTO 80
+         IF (qBitGet(iStat,1)) THEN 
+            cMod = ' '
+         ELSE 
+            cMod = '='
+            ENDIF 
+
+         CALL tOlfG (j, 'fil', Fil, Fehler)
+         IF (Fehler.ne.'&ff') GOTO 80
+         CALL tOlfG (j, 'tit', Tit, Fehler)
+         IF (Fehler.ne.'&ff') GOTO 80
+         CALL tOlfG (j, 'doc', Doc, Fehler)
+         IF (Fehler.ne.'&ff') GOTO 80
+
+         CALL OlfCnuG (j, 'x', xCo, xUn, Fehler)
+         IF (Fehler.ne.'&ff') GOTO 80
+         CALL OlfCnuG (j, 'y', yCo, yUn, Fehler)
+         IF (Fehler.ne.'&ff') GOTO 80
+
+         CALL OlfGetNofK (j, nK, NofK, Fehler)
+         IF (Fehler.ne.'&ff') GOTO 80
+         n = NofK(1)
+         DO K = 2, nK
+            IF (NofK(K).ne.n) THEN
+               n = 0
+               GOTO 29
+               ENDIF
+            ENDDO
+ 29      CONTINUE
+
+         IF (qBitGet(iStat,2)) Doc = 'read-only'
+               
+         idoc = lenU(Doc)
+         IF (idoc.lt.11) THEN
+            idoc = 11
+            ENDIF
+         IF (idoc.gt.11) THEN
+            Doc(idoc-10:idoc-9) = '..'
+            ENDIF
+         aus = ' '//cr2(j)//cMod//Fil(1:15)//' '//Doc(idoc-10:idoc)//
+     *            ' '//Tit(1:26)//' '//xCo(1:3)//
+     *            ' '//yCo(1:6)//' '//cr3(nK)//'*'
+         IF (n.eq.0) THEN
+            CALL Append (aus, '  ?')
+         ELSE
+            CALL Append (aus, cr4(n))
+            ENDIF
+         GOTO 90
+
+ 80      CONTINUE ! error occured
+         aus = ' '//cr2(j)//' ILLISIBLE: '//Fehler
+         Fehler = '&ff'
+
+ 90      CONTINUE 
+         Print '(a80)', aus
+         ENDDO
+
+      END ! MemInfoF
+
+      SUBROUTINE MemInfoZ (nJlist, JList, Fehler)
+C     -------------------------------------------
+            ! JWu 17may95
+
+      IMPLICIT NONE
+      INCLUDE 'i_dim.f'
+      INCLUDE 'l_def.f'
+
+      CHARACTER      Fehler*(*), Co*40, Un*40, h1*4, h2*20, aus*80
+      INTEGER        nJList, JList(*), lj, j, nK, K, iOlfG, nZ, iZ
+      REAL*8         X(MC), Z(MZ)
+      
+      IF (nJList.le.0) THEN
+         Fehler = ' '
+         RETURN
+         ENDIF  
+
+      DO lj = 1, nJList
+      j = JList(lj)
+
+         nK = iOlfG (j, '#spectra', Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+
+         nZ = iOlfG (j, '#Z', Fehler)
+         IF (nZ.ge.1) THEN
+            ! List header :
+            Print '(a)', ' z coordinates of file '//cl3(j)         
+            IF (Fehler.ne.'&ff') RETURN 
+            aus = ' '
+            DO iZ = 1, nZ
+               CALL OlfCnuG (j, 'z'//cl2(iZ), Co, Un, Fehler)
+               IF (Fehler.ne.'&ff') RETURN 
+               CALL Compose3 (aus(4+(iZ-1)*12:4+iZ*12-1), Co, ' ['//Un, ']')
+               ENDDO 
+            Print '(a80)', aus
+   
+            ! List of spectra :
+            DO K = 1, nK
+               CALL OlfGetZ (j, K, nZ, Z, Fehler)
+               IF (Fehler.ne.'&ff') RETURN 
+               aus = cr3(K)
+               DO iZ = 1, nZ
+                  write (aus(4+(iZ-1)*12:4+iZ*12-1), '(2x,g10.4)') Z(iZ)
+                  ENDDO 
+               Print '(a80)', aus
+               ENDDO ! K
+
+         ELSE
+            IF (nK.eq.1) THEN
+               Print '(a)',
+     *  ' only 1 spectrum and no z coordinates in file '//cl3(j)
+            ELSE
+               Print '(a)',
+     *  ' WARNING/ no z coordinates though several spectra in file '//cl3(j)
+               ENDIF 
+            ENDIF 
+
+         ENDDO ! lj
+      Print *
+         
+      END ! MemInfoZ
+
+      SUBROUTINE MemInfoK (nJList, Jlist, Fehler)
+C     -------------------------------------------
+            ! JWu 17may95
+
+      IMPLICIT NONE
+      INCLUDE 'i_dim.f'
+      INCLUDE 'l_def.f'
+
+      CHARACTER      Fehler*(*), Co*40, Un*40, h1*4, h2*20, aus*80
+      INTEGER        nJList, JList(*), lj, j, nK, K, iOlfG, nZ, is, n
+      REAL*8         X(MC), Z(MZ), dx
+      LOGICAL        qed
+
+      IF (nJList.le.0) THEN
+         Fehler = ' '
+         RETURN
+         ENDIF  
+
+      DO lj = 1, nJList
+      j = JList(lj)
+
+         nK = iOlfG (j, '#spectra', Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+
+         Print '(a)', ' spectra of file '//cl3(j)         
+
+         ! List of spectra :
+         DO K = 1, nK
+
+            CALL OlfGetZ (j, K, nZ, Z, Fehler)
+            IF (Fehler.ne.'&ff') RETURN 
+            
+            CALL OlfGetX (j, K, n, X, Fehler)
+            IF (Fehler.ne.'&ff') RETURN
+
+            is = irSorted (X, n)
+            IF     (is.eq.-2) THEN
+               h1 = ' >> '
+            ELSEIF (is.eq.-1) THEN
+               h1 = ' >= '
+            ELSEIF (is.eq. 0) THEN
+               h1 = ' <> '
+            ELSEIF (is.eq. 1) THEN
+               h1 = ' <= '
+            ELSEIF (is.eq. 2) THEN
+               h1 = ' << '
+               ENDIF
+            IF (iabs(is).eq.2) THEN
+               CALL CheckScale (n, X, 1.d-2, qed, dx)
+            ELSE
+               qed = .false.
+               ENDIF
+            IF (qed) THEN
+               write (h2, '(a,g10.4)') ' dX = ', dx
+            ELSE
+               h2 = ' '
+               ENDIF
+       
+            Print '(i3,a,g10.4,a,i4,a,g10.4,a4,g10.4,a17)',
+     *             K, '#  z = ', Z(1), ' n = ', n, ' X = ', X(1), h1, X(n), h2
+
+            ENDDO ! K
+         ENDDO ! lj
+      Print *
+         
+      END ! MemInfoK
+
+      SUBROUTINE MemInfoY (nJList, JList, Fehler)
+C     -------------------------------------------
+            ! JWu 17may95
+         ! directory of on-line data points
+
+      IMPLICIT REAL*8   (a-h,o-p,r-z)
+      IMPLICIT LOGICAL  (q)
+
+      INCLUDE 'i_dim.f'
+      INCLUDE 'l_def.f'
+
+      CHARACTER*(*)  Fehler
+      INTEGER        JList(*)
+
+      CHARACTER      h1*4, h2*12, lisCh*80, lisChold*80, aus*80
+      REAL*8         X(MC), Y(MC), D(MC), Z(MZ)
+      LOGICAL        qList(MC)
+      
+      IF (nJList.le.0) THEN
+         Fehler = ' '
+         RETURN
+         ENDIF  
+
+      DO lj = 1, nJList
+      j = JList(lj)
+
+         Print '(a)', ' listing x-y for file '//cl3(j)         
+         nK = (MemBlockNum(j) - MBH) / 4
+         Kdef = Kold
+
+ 150     CONTINUE
+         IF (nK.gt.1) THEN
+            K = iAskDMu (' Spectrum no. (0=quit)', Kdef, -1, nK)
+            IF (K.eq.0) RETURN
+            Kold = K
+         ELSE
+            Print *, ' there is just one spectrum'
+            K = 1
+            ENDIF
+
+         CALL OlfGetSpe (j, K, nZ, Z, nC, X, Y, D, Fehler)
+         IF (nC.eq.0) THEN
+            Print *, '  Spectrum is empty !'
+            GOTO 150
+            ENDIF
+
+         lisCh = lisChold
+ 151     CONTINUE
+         IF (nC.gt.12) THEN
+            aus = '  Show which channels'
+            CALL GetNList (aus, lisCh, qList, nC)
+            IF (lisCh.eq.'-') GOTO 158
+            lisChold = lisCh
+         ELSE
+            ! don't bore the user with that question,
+            ! show all those few channels :
+            DO i = 1, nC
+               qList(i) = .true.
+               ENDDO
+            ENDIF
+     
+         Print '(i3,a,g10.4)', K,'#  z1 = ', Z(1)
+     
+         DO i = 1, nC
+            IF (qList(i)) THEN
+               Print '(a,i4,a,g12.6,a,g12.6,a,g10.4,a,g10.4)',
+     *      ' ch', i, '  x = ', X(i), ', y = ', Y(i), ' +-', D(i),
+     *      '; dx = ', rStepAt (X, nC, i)
+               ENDIF
+            ENDDO
+     
+         IF (nC.gt.12) THEN
+            lisCh = '-'
+            GOTO 151
+            ENDIF
+ 158     CONTINUE
+         Kdef = 0
+         IF (nK.gt.1) GOTO 150
+ 159     CONTINUE 
+         ENDDO 
+
+      END ! MemInfoY
+
+C  ====================================================================
+C  i23 / 2 :   editing 
+C  ====================================================================
+
+      INTEGER FUNCTION iLabOfCnu (Lab)
+C     --------------------------------
+            ! 14jan99
+
+      IMPLICIT NONE 
+      CHARACTER     Lab*(*), cl6*6
+      INTEGER       lenU, ichar1, il
+      
+      IF     (Lab.eq.'x') THEN 
+         iLabOfCnu = -1
+         RETURN 
+      ELSEIF (Lab.eq.'y') THEN 
+         iLabOfCnu = 0
+         RETURN 
+      ELSEIF (Lab(1:1).eq.'z') THEN 
+         IF     (lenU(Lab).gt.2) THEN
+            CALL Gong (3)
+            Print *, 'iLabOfCnu / unexpected label "', Lab(1:lenU(Lab)), '"'
+            iLabOfCnu = -2
+            RETURN 
+         ELSEIF (Lab.eq.'z') THEN
+            CALL Gong (3) 
+            Print *,
+     *        'iLabOfCnu / the use of "z" instead of "z1" is not recommended'
+            iLabOfCnu = 1
+            RETURN 
+            ENDIF 
+         il = ichar1(Lab(2:2))
+         IF (il.lt.1 .or. il.gt.9) THEN 
+            Print *, 'iLabOfCnu / unexpected label "', Lab(1:lenU(Lab)),
+     *           '", apparently no. '//cl6(il)
+            iLabOfCnu = -3
+            RETURN 
+            ENDIF
+         iLabOfCnu = il
+         RETURN 
+         ENDIF 
+         Print *, 'iLabOfCnu / unexpected label ', Lab
+         iLabOfCnu = -4
+
+      END ! iLabOfCnu
+
+      SUBROUTINE EditCnu (nJList, JList, whext, Fehler)
+C     -------------------------------------------------
+            ! JWu 3jun91, completely renewed (FileTPar) 9mar93,
+            ! new again (EditCnu) 18nov96/4mar98
+
+      IMPLICIT NONE
+      INCLUDE 'l_def.f'
+      INCLUDE 'i_dim.f'
+      CHARACTER*(*) Fehler, whext
+      CHARACTER*80  aus
+      CHARACTER*40  UnJ, CoJ, UnE, CoE
+      CHARACTER*4   which
+      INTEGER       nJList, JList(*), lj, lji, iCo, nZ, iOlfG
+
+      IF (nJList.le.0) THEN
+         Fehler = ' '
+         RETURN
+         ENDIF
+
+      ! whext z.Zt. ignoriert
+
+C  Uebersichtstabelle
+      nZ = iOlfG (JList(1), '#Z', Fehler)
+ 10   CONTINUE
+      DO iCo = -1, nZ
+         IF     (iCo.eq.-1) THEN
+            which = 'x'
+         ELSEIF (iCo.eq.0) THEN 
+            which = 'y'
+         ELSE
+            which = 'z'//cl2(iCo)
+            ENDIF
+
+         lj = 0
+ 11      CONTINUE 
+         lj = lj + 1
+         CALL OlfCnuG (JList(lj), which, CoJ, UnJ, Fehler)
+         IF (Fehler(1:4).eq.'&pnf') GOTO 19
+         IF (Fehler.ne.'&ff') RETURN
+         lji = lj
+         DO lj = lji, nJList-1
+            CALL OlfCnuG (JList(lj+1), which, CoE, UnE, Fehler)
+            IF (Fehler(1:4).eq.'&pnf') GOTO 19
+            IF (Fehler.ne.'&ff') RETURN
+            IF (CoE.ne.CoJ .or. UnE.ne.UnJ) GOTO 15
+            ENDDO
+         lj = nJList
+ 15      CONTINUE 
+
+         Print '(a2,a,a20,a,a15,a,i3,a,i3)',
+     *        which, ' is ', CoJ, ' in ', UnJ, ' for files ', lji, ' .. ', lj
+               
+         IF (lj.lt.nJList) GOTO 11
+
+ 19      CONTINUE
+         Fehler = '&ff'
+         ENDDO ! iCo / Uebersichtstabelle
+
+ 20   CONTINUE 
+      Print *
+      CALL FrageC (' Edit which coordinate (x,y,..)', which) 
+      IF (which.eq.' ') RETURN
+
+      DO lj = 1, nJList
+         CALL OlfCnuG (JList(lj), which, CoJ, UnJ, Fehler)
+         IF (Fehler(1:4).eq.'&pnf') THEN
+            Print *, ' do not use edit_coordinate to add new coordinates'
+            Fehler = '&ff'
+            GOTO 20
+            ENDIF 
+         IF (Fehler.ne.'&ff') RETURN
+
+         IF (lj.eq.1) THEN
+            CoE = CoJ
+            UnE = UnJ
+         ELSE
+            IF (CoJ.ne.CoE) CoE = '&?'
+            IF (UnJ.ne.UnE) UnE = '&?'
+            ENDIF
+         ENDDO
+            
+      IF (nJList.eq.1) THEN
+         CALL FrageTD (' Coordinate name of '//which, CoJ, CoJ)
+         CALL FrageCD (' And its unit', UnJ, UnJ)
+         CALL OlfCnuP (JList(1), which, CoJ, UnJ, Fehler)
+      ELSE
+         IF (CoE.eq.'&?') THEN
+            CALL Compose2 (aus, ' Coordinate name of '//which,
+     *                     ' [enter indivdually]')
+            CALL FrageC (aus, CoE)
+         ELSE
+            CALL Compose2 (aus, ' Coordinate name of '//which,
+     *                     ' (answer ''\ '' to enter indivdually) ')
+            CALL FrageCD (aus, CoE, CoE)
+            ENDIF
+         IF (CoE.eq.' ') THEN ! enter individually
+            DO lj = 1, nJList
+               CALL OlfCnuG (JList(lj), which, CoJ, UnJ, Fehler)
+               IF (Fehler.ne.'&ff') RETURN
+               CALL FrageTD (' Coordinate name', CoJ, CoJ)
+               CALL FrageCD (' And its unit', UnJ, UnJ)
+               CALL OlfCnuP (JList(lj), which, CoJ, UnJ, Fehler)
+               IF (Fehler.ne.'&ff') RETURN
+               ENDDO
+         ELSE
+            IF(UnE.eq.'&?') THEN
+               CALL FrageT (' And its unit', UnE)
+            ELSE
+               CALL FrageCD (' And its unit', UnE, UnE)
+               ENDIF
+            DO lj = 1, nJList
+               CALL OlfCnuP (JList(lj), which, CoE, UnE, Fehler)
+               IF (Fehler.ne.'&ff') RETURN
+               ENDDO
+            ENDIF
+         ENDIF
+
+      GOTO 10   
+c      IF (whext.eq.'?') GOTO 1
+
+      END ! EditCnu
+
+      SUBROUTINE EditDoc (nJList, JList, Fehler)
+C     ------------------------------------------
+            ! JWu 3jun91. Revised (Type as parameter, List) 2sep91.
+            ! Completely renewed (FileTPar) 9mar93.
+            ! Completely rewritten 9oct97
+
+      IMPLICIT NONE
+      INCLUDE      'l_def.f'
+      INCLUDE      'i_dim.f'
+      CHARACTER*(*) Fehler
+      CHARACTER*80  line, tit
+      CHARACTER*40  fil, doc, ein1
+      INTEGER       nJList, JList(*), lj, j,
+     *              iP, iPList(MTP), niPList, iPL, iiPL
+
+      IF (nJList.le.0) THEN
+         Fehler = ' '
+         RETURN
+         ENDIF
+
+C  Loop over files/ no attempt is made to collate doc's form different files :
+      DO lj = 1, nJList
+         j = JList(lj)
+
+         Print *, ' file '//cl3(j)
+
+C  Show doc :
+ 10      CONTINUE 
+         Print *
+         CALL tOlfG(j, 'fil', fil, Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+         CALL tOlfG(j, 'tit', tit, Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+         CALL tOlfG(j, 'doc', doc, Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+         Print '(a3,2x,a40)', 'f', fil
+         Print '(a3,2x,a72)', 't', tit
+         Print '(a3,2x,a40)', 's', doc
+         iP = 0
+ 11      CONTINUE 
+            CALL OlfComLinG (j, iP+1, line, Fehler)
+            IF (Fehler.ne.'&ff') RETURN
+            IF (line.eq.'&eoc') GOTO 19
+            iP = iP + 1
+            Print '(i3,2x,a72)', iP, line
+            GOTO 11
+ 19      CONTINUE
+         Print *
+
+C  Modify :
+ 30      CONTINUE
+         CALL FrageCD (' Modify lines (f,t,s,<list>,a,-)', ein1, '-')
+         IF (ein1.eq.'a') THEN 
+            CALL FrageC ('  Add line:', line)
+            IF (line.eq.' ') THEN 
+               CALL Gong (1)
+               GOTO 30
+               ENDIF 
+            IF (iP.ge.MTP) THEN 
+               CALL Gong (11)
+               Print *, ' too many lines'
+               GOTO 30
+               ENDIF 
+            iP = iP + 1
+            CALL OlfComLinP (j, iP, line, Fehler)
+         ELSEIF (ein1.eq.'?') THEN 
+            Print *, '    f       modify file name'
+            Print *, '    t       modify title line'
+            Print *, '    s       modify short documentation'
+            Print *, '    <list>  modify existing lines'
+            Print *, '    a       add new line'
+            Print *, '    -       quit'
+         ELSEIF (ein1.eq.'f') THEN
+            CALL FrageCD ('  File name', fil, fil)
+            CALL tOlfP (j, 'fil', fil, Fehler)
+            IF (Fehler.ne.'&ff') RETURN
+         ELSEIF (ein1.eq.'t') THEN
+            CALL FrageCD ('  Title line', tit, tit)
+            CALL tOlfP (j, 'tit', tit, Fehler)
+            IF (Fehler.ne.'&ff') RETURN
+         ELSEIF (ein1.eq.'s') THEN
+            CALL FrageCD ('  Short documentation', doc, doc)
+            CALL tOlfP (j, 'doc', doc, Fehler)
+            IF (Fehler.ne.'&ff') RETURN
+         ELSEIF (ein1.eq.'-') THEN 
+            GOTO 39
+         ELSEIF (ein1.eq.' ') THEN ! re-display
+         ELSE ! list given or bad input
+            CALL DecJList (ein1, MTP, niPList, iPList, 1, iP, Fehler)
+            IF (Fehler.ne.'&ff') THEN 
+               CALL FehlerGong (Fehler, 1)
+               GOTO 30
+               ENDIF 
+            DO iPL = 1, niPList
+               CALL OlfComLinG (j, iPList(iPL), line, Fehler)
+               CALL FrageCD ('  Line '//cl3(iPList(iPL)), line, line)
+               IF (line.eq.' ') THEN 
+                  CALL OlfComLinDel (j, iPList(iPL), Fehler)
+                  IF (Fehler.ne.'&ff') RETURN 
+                  iP = iP - 1
+                  DO iiPL = iPL+1, niPList
+                     IF (iPList(iiPL).gt.iPList(iPL))
+     *                   iPList(iiPL) = iPList(iiPL) -1
+                     ENDDO 
+               ELSE 
+                  CALL OlfComLinP (j, iPList(iPL), line, Fehler)
+                  ENDIF 
+               ENDDO 
+            ENDIF 
+         GOTO 10 ! redisplay
+
+ 39      CONTINUE 
+
+         Print *
+         ENDDO ! lj
+
+      END ! EditDoc
+
+      SUBROUTINE EditZ (nJList, JList, Fehler)
+C     ----------------------------------------
+            ! 4mar98
+
+      IMPLICIT NONE
+      INCLUDE 'i_dim.f'
+      INCLUDE 'l_def.f'
+
+      CHARACTER      Fehler*(*), Co*40, Un*40, Co2*40, Un2*40,
+     *               action*8, aus*80
+      INTEGER        nJList, JList(*), lj, j, nK, K, iOlfG, nZ, iZ, iZ2, Kdum
+      REAL*8         Z(MZ), zav, zval
+      
+ 10   CONTINUE 
+      CALL MemInfoZ (nJList, JList, Fehler)
+
+ 20   CONTINUE
+      nZ = iOlfG (JList(1), '#spectra', Fehler)
+      CALL FrageC (' Modify (a,d,r,s,x)', action)
+      IF     (action.eq.'h' .or. action.eq.'?') THEN
+         Print *, ' the following modifications are accessible:'
+         Print *, '    a  add one more z-coordinate'
+         Print *, '    d  delete one z-coordinate'
+         Print *, '    r  average one z-coordinate and save as r-param'
+         Print *, '    s  sort: leftmost columns varying most rapidly'
+         Print *, '    x  exchange order of z-coordinates'
+         GOTO 20
+      ELSEIF (action.eq.' ') THEN 
+         GOTO 99
+      ELSEIF (action.eq.'a') THEN 
+         CALL FrageC ('Add a coordinate named', Co)
+         IF (Co.eq.' ') GOTO 20
+         CALL FrageC ('And its unit', Un)
+         DO lj = 1, nJList
+            j = JList(lj)
+            CALL OlfOpen (j, 1, Kdum, Fehler)
+            nK = iOlfG (j, '#spectra', Fehler)
+            nZ = iOlfG (j, '#Z', Fehler)
+            CALL OlfCnuP (j, 'z'//cl2(nZ+1), Co, Un, Fehler)
+            IF (Fehler.ne.'&ff') RETURN 
+            Print *, ' set new z for file '//cl4(j)
+            zval = 0
+            DO K = 1, nK
+               CALL OlfGetZ (j, K, nZ, Z, Fehler)
+               IF (Fehler.ne.'&ff') GOTO 99 
+               zval = rAskD ('Value for spectrum '//cl4(K), zval)
+               Z(nZ+1) = zval
+               CALL OlfPutZ (j, K, nZ+1, Z, Fehler)
+               IF (Fehler.ne.'&ff') GOTO 99 
+               ENDDO
+            CALL OlfClos (j, 0, Fehler)
+            ENDDO 
+      ELSEIF (action.eq.'d') THEN 
+         iZ = iAskMu (' delete which z-coordinate', 0, MZ)
+         IF (iZ.le.0) GOTO 20
+         DO lj = 1, nJList
+            j = JList(lj)
+            CALL OlfOpen (j, 1, Kdum, Fehler)
+            CALL OlfDel1Z (j, j, iZ, Fehler)
+            IF (Fehler.ne.'&ff') GOTO 99 
+            CALL OlfClos (j, 0, Fehler)
+            ENDDO 
+      ELSEIF (action.eq.'r') THEN 
+         iZ = iAskMu (' average which z-coordinate', 0, MZ)
+         IF (iZ.le.0) GOTO 20
+         DO lj = 1, nJList
+            j = JList(lj)
+            CALL OlfOpen (j, 1, Kdum, Fehler)
+            nK = iOlfG (j, '#spectra', Fehler)
+            zav = 0
+            DO K = 1, nK
+               CALL OlfGet1Z (j, K, iZ, zval, Fehler)
+               zav = zav + zval
+               ENDDO
+            zav = zav / nK
+            CALL OlfCnuG (j, 'z'//cl2(iZ), Co, Un, Fehler)
+            IF (Fehler.ne.'&ff') GOTO 99 
+            CALL OlfDel1Z (j, j, iZ, Fehler)
+            IF (Fehler.ne.'&ff') GOTO 99
+            CALL rOlfP (j, Co, Un, zav, Fehler)
+            IF (Fehler.ne.'&ff') GOTO 99 
+            CALL OlfClos (j, 0, Fehler)
+            ENDDO 
+      ELSEIF (action.eq.'s') THEN 
+         CALL OrgSpectraSort (nJList, JList, .true., Fehler)
+         IF (Fehler.ne.'&ff') GOTO 99
+         GOTO 10
+      ELSEIF (action.eq.'x') THEN 
+         IF (nZ.gt.2) THEN
+            iZ = iAskMu (' move which z-coordinate', 0, MZ)
+            IF (iZ.le.0) GOTO 20
+         ELSEIF (nZ.lt.2) THEN 
+            CALL Gong (4)
+            Print *, ' nothing to move'
+            GOTO 20
+         ELSE
+            iZ = 2
+            ENDIF 
+         iZ2 = iAskDMu (' new position', 1, 0, MZ)
+         IF (iZ2.eq.0 .or. iZ2.eq.iZ) THEN 
+            CALL Gong (1)
+            GOTO 20
+            ENDIF 
+         DO lj = 1, nJList
+            j = JList(lj)
+            CALL OlfOpen (j, 1, Kdum, Fehler)
+            nK = iOlfG (j, '#spectra', Fehler)
+            DO K = 1, nK
+               CALL OlfGetZ (j, K, nZ, Z, Fehler)
+               IF (Fehler.ne.'&ff') GOTO 99 
+               zav = Z(iZ)
+               Z(iZ) = Z(iZ2)
+               Z(iZ2) = zav
+               CALL OlfPutZ (j, K, nZ, Z, Fehler)
+               IF (Fehler.ne.'&ff') GOTO 99 
+               ENDDO
+            CALL OlfCnuG (j, 'z'//cl2(iZ), Co, Un, Fehler)
+            IF (Fehler.ne.'&ff') GOTO 99 
+            CALL OlfCnuG (j, 'z'//cl2(iZ2), Co2, Un2, Fehler)
+            IF (Fehler.ne.'&ff') GOTO 99
+            CALL OlfCnuP (j, 'z'//cl2(iZ), Co2, Un2, Fehler)
+            IF (Fehler.ne.'&ff') GOTO 99
+            CALL OlfCnuP (j, 'z'//cl2(iZ2), Co, Un, Fehler)
+            IF (Fehler.ne.'&ff') GOTO 99
+            CALL OlfClos (j, 0, Fehler)
+            ENDDO
+      ELSE 
+         CALL Gong (4)
+         Print *, ' unknown option - type h for help'
+         GOTO 20
+         ENDIF 
+
+      GOTO 10
+      
+ 99   CONTINUE
+      IF (Fehler.ne.'&ff') CALL FehlerGong (Fehler, 3)
+
+      END ! EditZ
+
+      SUBROUTINE EditRPar (nJList, JList, Fehler)
+C     -------------------------------------------
+            ! JWu 10jul91, renewed 18mar92, completely new 24nov96, 8oct97
+         ! List and change rPar
+
+      IMPLICIT NONE 
+      INCLUDE      'l_def.f'
+      INCLUDE      'i_dim.f'
+      CHARACTER*(*) Fehler
+      CHARACTER*40  file, Co, Un, CoPout(MRP), UnPout(MRP), h3, ein, ein1
+      LOGICAL       qPdef(MRP), qPuni(MRP)
+      CHARACTER*16  h1, h2
+      INTEGER       nJList, JList(*), lj, j, np, iP, iPout, nPout,
+     *              niPList, iPList(MRP), Kdum, nK, K, nZ, iOlfG
+      REAL*8        rval, rvalmin, rvalmax, rvalavg, rOlfG, rOlfGG, zval,
+     *              Z(MZ)
+
+      IF (nJList.le.0) THEN
+         Fehler = ' '
+         RETURN
+         ENDIF
+
+C  Make list of r:
+ 10   CONTINUE
+      nPout = 0
+      DO lj = 1, nJList
+         DO iP = 1, MRP
+            Co   = '&pbn '//cv3(iP)
+            rval = rOlfG (JList(lj), Co, Un, Fehler)
+            IF (Fehler.ne.'&ff') RETURN 
+            IF (Co.eq.'&empty') GOTO 18
+            IF (Co.eq.'&eop') GOTO 19
+            DO iPout = 1, nPout
+               IF (CoPout(iPout).eq.Co) THEN 
+                  IF (UnPout(iPout).ne.Un) THEN 
+                     UnPout(iPout) = '&diff' ! 'different units in '//Co
+                     ENDIF 
+                  GOTO 18 ! parameter already in list
+                  ENDIF
+               ENDDO 
+            nPout = nPout + 1 ! new parameter
+            IF (nPout.gt.MRP) THEN 
+               Fehler = 'too many r-parameter for being listed here'
+               RETURN
+               ENDIF 
+            CoPout(nPout) = Co
+            UnPout(nPout) = Un
+ 18         CONTINUE 
+            ENDDO
+ 19      CONTINUE 
+         ENDDO ! lj
+
+C  Compare values of r:
+      DO iPout = 1, nPout
+         Co = CoPout(iPout)
+         Un = UnPout(iPout)
+         qPdef(iPout) = .true.
+         qPuni(iPout) = .false.
+         rval = rOlfGG (JList(1), Co, Un, Fehler)
+         IF (Fehler.ne.'&ff') THEN
+            Fehler = '&ff'
+            qPdef(iPout) = .false.
+            GOTO 228
+            ENDIF 
+         rvalmin = rval
+         rvalmax = rval
+         rvalavg = rval
+         DO lj = 2, nJList
+            rval = rOlfGG (JList(lj), Co, Un, Fehler)
+            IF (Fehler.ne.'&ff') THEN
+               Fehler = '&ff'
+               qPdef(iPout) = .false.
+               GOTO 228
+               ENDIF 
+            rvalmin = dmin1 (rvalmin, rval)
+            rvalmax = dmax1 (rvalmax, rval)
+            rvalavg = rvalavg + rval
+            ENDDO 
+         rvalavg = rvalavg / nJList
+         IF (rvalmin.ne.rvalmax) THEN 
+            write (h1, '(g16.8)') rvalmin
+            write (h2, '(g16.8)') rvalmax
+            h3 = 'varies from '//h1//' to '//h2
+         ELSE 
+            write (h3, '(g16.8)') rvalavg
+            qPuni(iPout) = .true.
+            ENDIF
+         GOTO 229
+ 228     CONTINUE ! arrived here if qPdef = false
+         h3 = 'for some files undefined'
+ 229     CONTINUE
+         Print '(i3,3x,a16,2x,a12,2x,a)', iPout, Co, Un, h3   
+         ENDDO ! r-par
+      Print *
+
+C  Menu :
+ 30      CONTINUE
+         CALL FrageCD (' Modify parameters (<list>,a,-)', ein1, '-')
+         Print *
+ 301     CONTINUE 
+         IF (ein1.eq.'a') THEN 
+            Print *, '  Add parameter:'
+            nPout = nPout + 1
+            iPout = nPout
+            CALL FrageC ('  Coordinate', CoPout(iPout))
+            CALL FrageC ('  And its unit', UnPout(iPout))
+            DO lj = 1, nJList
+               CALL rOlfP (JList(lj), CoPout(iPout), UnPout(iPout),
+     *                     0.d0, Fehler)
+               IF (Fehler.ne.'&ff') RETURN 
+               ENDDO 
+            ein1 = cl4(iPout)
+            GOTO 301 ! goto `ELSE'
+         ELSEIF (ein1.eq.'?') THEN 
+            Print *, '    <list>  modify existing parameters'
+            Print *, '    a       add new parameter'
+            Print *, '    -       quit'
+            ein1 = ' '
+         ELSEIF (ein1.eq.'-') THEN 
+            RETURN
+         ELSEIF (ein1.eq.' ') THEN ! re-display
+         ELSE ! list given or bad input
+            CALL DecJList (ein1, MRP, niPList, iPList, 1, nPout, Fehler)
+            ein1 = ' '
+            IF (Fehler.ne.'&ff') THEN 
+               CALL FehlerGong (Fehler, 1)
+               Print *
+               GOTO 10
+               ENDIF 
+            DO iP = 1, niPList
+               iPout = iPList(iP)
+ 31            CONTINUE
+               Print *, '  parameter: '//CoPout(iPout)
+               ! display current values :
+               IF (.not.qPuni(iPout)) THEN
+                  DO lj = 1, nJList
+                     rval = rOlfG (JList(lj), CoPout(iPout), Un, Fehler)
+                     IF (Fehler.ne.'&ff') THEN
+                        Fehler = '&ff'
+                        h3 = ' ** undefined'
+                     ELSE
+                        write (h3, '(g16.8,1x,a20)') rval, Un
+                        ENDIF 
+                     Print '(a,i2,a,a)', '    present value for file ',
+     *                  JList(lj), ': ', h3
+                     ENDDO 
+                  Print *
+                  ENDIF
+               CALL FrageC ('  Modification (val,f,n,u,z,d) [none]', ein)
+               CALL Fi1R (ein, rval)
+               IF (ein.eq.'#') THEN 
+                  DO lj = 1, nJList
+                     CALL rOlfP (JList(lj), CoPout(iPout), UnPout(iPout),
+     *                           rval, Fehler)
+                     IF (Fehler.ne.'&ff') RETURN 
+                     ENDDO 
+               ELSEIF (ein.eq.'f') THEN 
+                  DO lj = 1, nJList
+                     rval = rOlfG (JList(lj), CoPout(iPout), Un, Fehler)
+                     rval = rAskD ('   Value for file '//cl4(JList(lj)), rval)
+                     CALL rOlfP (JList(lj), CoPout(iPout), Un, rval, Fehler)
+                     IF (Fehler.ne.'&ff') RETURN 
+                     ENDDO 
+               ELSEIF (ein.eq.'n') THEN 
+                  CALL FrageCD ('   Coordinate', Co, CoPout(iPout))
+                  CALL FrageCD ('   And its unit', Un, UnPout(iPout))
+                  DO lj = 1, nJList
+                     rval = rOlfG (JList(lj),
+     *                             CoPout(iPout), UnPout(iPout), Fehler)
+                     IF (Fehler.ne.'&ff') RETURN 
+                     IF (CoPout(iPout).ne.Co)
+     *                  CALL rOlfDel (JList(lj), CoPout(iPout), Fehler)
+                     CALL rOlfP (JList(lj), Co, Un, rval, Fehler)
+                     IF (Fehler.ne.'&ff') RETURN 
+                     CoPout(iPout) = Co
+                     UnPout(iPout) = Un
+                     ENDDO 
+               ELSEIF (ein.eq.'u') THEN 
+                  Print *, '   unfertig '
+               ELSEIF (ein.eq.'z') THEN
+                  Print *, ' bricolage pour mfj'
+                  DO lj = 1, nJList
+                     Co = CoPout(iPout) 
+                     Un = UnPout(iPout)
+                     j = JList(lj)
+                     CALL OlfOpen (j, 1, Kdum, Fehler)
+                     nK = iOlfG (j, '#spectra', Fehler)
+                     nZ = iOlfG (j, '#Z', Fehler)
+                     CALL OlfCnuP (j, 'z'//cl2(nZ+1), Co, Un, Fehler)
+                     IF (Fehler.ne.'&ff') RETURN 
+                     zval = 0
+                     DO K = 1, nK
+                        CALL OlfGetZ (j, K, nZ, Z, Fehler)
+                        IF (Fehler.ne.'&ff') GOTO 999
+                        zval = rOlfGG(j, Co, Un, Fehler)
+                        Z(nZ+1) = zval
+                        CALL OlfPutZ (j, K, nZ+1, Z, Fehler)
+                        IF (Fehler.ne.'&ff') GOTO 999
+                     ENDDO
+                     CALL OlfClos (j, 0, Fehler)
+                     CALL rOlfDel (JList(lj), CoPout(iPout), Fehler)
+                  ENDDO 
+               ELSEIF (ein.eq.'d') THEN 
+                  DO lj = 1, nJList
+                     CALL rOlfDel (JList(lj), CoPout(iPout), Fehler)
+                     IF (Fehler.ne.'&ff') Fehler = '&ff'
+                     ENDDO 
+               ELSEIF (ein.eq.'?') THEN 
+                  Print *, '    <real value>  global parameter value'
+                  Print *, '    f             different value for each file'
+                  Print *, '    n             coordinate name and unit'
+                  Print *, '    u             unit conversion'
+                  Print *, '    d             delete'
+                  Print *, '    z             promote r to z'
+                  Print *, '    <RETURN>      no modification'
+                  GOTO 31
+               ELSEIF (ein.eq.' ') THEN 
+                  ! regular exit
+               ELSE
+                  CALL Gong (3) 
+                  GOTO 31
+                  ENDIF 
+               ENDDO ! iP
+            ENDIF 
+            Print *
+            GOTO 10
+
+ 999        CONTINUE
+            IF (Fehler.ne.'&ff') CALL FehlerGong (Fehler, 3)
+
+
+      END ! EditRPar
+
+      SUBROUTINE EditIPar (nJList, JList, Fehler)
+C     -------------------------------------------
+         ! List and change iPar
+
+      IMPLICIT NONE 
+      INCLUDE      'l_def.f'
+      CHARACTER*(*) Fehler
+      CHARACTER     co*24, un*24, file*40
+      INTEGER       nJList, JList(*), lj, j, np
+      INTEGER       ival, iOlfG
+
+      DO lj = 1, nJList
+         j = JList(lj)
+
+         CALL tOlfG(j, 'fil', file, Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+         CALL Say2 (' integer parameters of file '//cl3(j), ' : '//file)
+
+         np = 0
+ 11      CONTINUE 
+            co   = '&pbn '//cv3(np+1)
+            ival = iOlfG (j, co, Fehler)
+            IF (Fehler.ne.'&ff') RETURN 
+            IF (co.eq.'&eop') GOTO 19
+            np = np + 1
+            IF (co.eq.'&empty') GOTO 11
+            Print '(i3,2x,a16,2x,i8)', np, co, ival
+            GOTO 11
+            
+ 19      CONTINUE 
+
+         ENDDO ! lj
+
+      END ! EditIPar
+
+      SUBROUTINE EditGPar (nJList, JList, Fehler)
+C     -------------------------------------------
+            ! JWu 4-6nov91
+         ! Manipulate the iPar and rPar used for plotting
+
+      IMPLICIT NONE
+      INCLUDE      'l_def.f'
+      CHARACTER*(*) Fehler
+      INTEGER       nJList, JList(*), lj, j, icu, ips, ncp, iOlfGdef
+      REAL*8        rpi, rpf, rOlfGGdef
+
+      IF (nJList.le.0) THEN
+         Fehler = ' '
+         RETURN
+         ENDIF
+      DO lj = 1, nJList
+         j = JList(lj)
+         
+         icu = iOlfGdef (j, '?cu',      0, Fehler)
+         ips = iOlfGdef (j, 'plot-sy#', 0, Fehler)
+         IF (Fehler.ne.'&ff') RETURN 
+
+         ips = iAskD ('Linestye(>0)  or plotsymbol(<0) or automatic(0)', ips)
+         CALL iOlfP (j, 'plot-sy#', ips, Fehler) 
+
+         IF (qintr(icu)) THEN
+            ncp = iOlfGdef  (j, 'plot-#pts',   0,    Fehler)
+            rpi = rOlfGGdef (j, 'plot-i', ' ', 0.d0, Fehler)
+            rpf = rOlfGGdef (j, 'plot-f', ' ', 0.d0, Fehler)
+
+            ncp = iAskDMu ('Number of points', ncp, 2, 10000)
+            CALL rAskRgeFull ('Plot range', rpi, rpf, rpi, rpf)
+
+            CALL iOlfP (j, 'plot-#pts',   ncp, Fehler)
+            CALL rOlfP (j, 'plot-i', ' ', rpi, Fehler)
+            CALL rOlfP (j, 'plot-f', ' ', rpf, Fehler)
+            ENDIF 
+
+         IF (Fehler.ne.'&ff') RETURN
+         ENDDO
+
+      END ! EditGPar
+
+C  ====================================================================
+C  i23 / 3 :   handling of z/r 
+C  ====================================================================
+
+      SUBROUTINE AskNoZ (quest, j, iZ, cZ, qMustHaveZ, Fehler)
+C     --------------------------------------------------------
+         ! ask for number of z-parameter
+
+      IMPLICIT NONE 
+      INCLUDE 'l_def.f'
+      CHARACTER      quest*(*), cZ*(*), Fehler*(*)
+      INTEGER        j, iZ, nZ, iOlfG
+      LOGICAL        qMustHaveZ
+      
+      IF (Fehler.ne.'&ff') THEN 
+         Print *, ' Fehler on entry in AskNoZ'
+         RETURN 
+         ENDIF 
+
+      nZ = iOlfG (j, '#Z', Fehler)
+      IF (Fehler.ne.'&ff') RETURN 
+      IF (nZ.gt.1) THEN 
+         iZ = iAskDMu (quest, iZ, 1, nZ)
+      ELSEIF (nZ.gt.0) THEN 
+         iZ = 1
+      ELSE 
+         IF (qMustHaveZ) THEN 
+            Fehler = ' no z defined'
+         ELSE
+            iZ = 0
+            ENDIF 
+         cZ = 'z-'
+         RETURN 
+         ENDIF 
+         
+      cZ = 'z'//cl2(iZ)
+
+      END ! AskNoZ
+
+      SUBROUTINE TensorCheckZ (j, Fehler)
+C     -----------------------------------
+            ! 4mar98
+      
+      IMPLICIT NONE 
+      CHARACTER     Fehler*(*), Co*40, Un*40, cl2*2
+      INTEGER       j, nZ, iOlfG, iZ, K, nK
+      REAL*8        z, z2
+
+      nZ = iOlfG (j, '#Z', Fehler)
+      nK = iOlfG (j, '#spectra', Fehler)
+      IF (Fehler.ne.'&ff') GOTO 99
+
+      DO iZ = nZ, 1, -1
+
+         CALL OlfGet1Z (j, 1, iZ, z, Fehler)
+         IF (Fehler.ne.'&ff') GOTO 99
+         DO K = 2, nK
+            CALL OlfGet1Z (j, K, iZ, z2, Fehler)
+            IF (Fehler.ne.'&ff') GOTO 99
+            IF (z2.ne.z) GOTO 19 ! z remains useful
+            ENDDO
+
+         ! z is constant => becomes rPar
+         CALL OlfCnuG (j, 'z'//cl2(iZ), Co, Un, Fehler)
+         IF (Fehler.ne.'&ff') GOTO 99
+         CALL OlfDel1Z (j, j, iZ, Fehler)
+         IF (Fehler.ne.'&ff') GOTO 99
+         CALL rOlfP (j, Co, Un, z, Fehler)
+         IF (Fehler.ne.'&ff') GOTO 99
+
+ 19      CONTINUE
+         ENDDO 
+
+      RETURN
+ 99   CONTINUE 
+      Print *, 'error passed through TensorCheckZ'
+
+      END ! TensorCheckZ
+
+      SUBROUTINE TensorSaveInt (j, jout, nK, nKout, Yin, Din, Fehler)
+C     ---------------------------------------------------------------
+            ! JWu 6mrz98
+         ! save result of integral operation (used by oi and ci)
+
+      IMPLICIT NONE 
+      INCLUDE 'i_dim.f'
+      INCLUDE 'l_def.f'
+      CHARACTER      Fehler*(*), aus*80, Co*40, Un*40,
+     *               CoG*40, UnG*40       ! letzte 2 DEBUG
+      INTEGER        j, jout, nK, K, KK, nKout, KNew(MK), nZ, iZ, iZsel,
+     *               n, iOlfG
+      REAL*8         Z(MZ), ZZ(MZ), Yin(*), Din(*), Xout(MC), Yout(MC), Dout(MC)
+      LOGICAL        qMultiDim
+
+C  special case : one single data point
+      nZ = iOlfG (j, '#Z', Fehler)
+      IF (nZ.eq.0) THEN 
+         IF (nK.gt.1) THEN 
+            Fehler = 'TensorSaveInt/ nZ=0 but nK>1'
+            RETURN
+            ENDIF 
+         Xout(1) = 0
+         CALL OlfPutSpe (jout, 1, 0, Z, 1, Xout, Yin, Din, Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+         CALL OlfCnuP (jout, 'x', '&no x', ' ', Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+         RETURN
+         ENDIF
+
+C  determine groups :
+      DO K = 1, nK
+         KNew(K) = K
+         ENDDO 
+      DO K = 1, nK
+         IF (KNew(K).eq.K) THEN ! begin of new group
+            CALL OlfGetZ (j, K, nZ, Z, Fehler)
+            IF (Fehler.ne.'&ff') RETURN
+            DO KK = K+1, nK
+               IF (KNew(KK).eq.KK) THEN ! not yet regrouped
+                  CALL OlfGetZ (j, KK, nZ, ZZ, Fehler)
+                  IF (Fehler.ne.'&ff') RETURN 
+                  DO iZ = 2, nZ
+                     IF (ZZ(iZ).ne.Z(iZ)) GOTO 180
+                     ENDDO 
+                  ! Z2, Z3, ... are all equal
+                  KNew(KK) = K
+ 180              CONTINUE
+                  ENDIF 
+               ENDDO 
+            ENDIF 
+         ENDDO 
+
+C  save :
+      IF (j.eq.jout) THEN 
+         Fehler = 'TensorSaveInt/ cannot overwrite'
+         RETURN
+         ENDIF 
+
+C  user choice :
+      IF (KNew(nK).gt.1) THEN ! there are indeed several groups
+         DO iZ = 1, nZ
+            CALL OlfCnuG (j, 'z'//cl2(iZ), Co, Un, Fehler)
+            IF (Fehler(1:4).eq.'&pnf') THEN 
+               Print *, 'PROGRAM ERROR/ CnuG in TensorCheckInt'
+               RETURN 
+               ENDIF 
+            Print '(a,a,a20,a,a15)', 'z'//cl2(iZ), ' is ', Co, ' in ', Un
+            ENDDO 
+         CALL Compose2 (aus, 
+     *    'Save in several spectra (0) or retain only one z (1-'//cl2(nZ), ')')
+         iZsel = iAskDMu (aus, iZsel, 0, nZ)
+         qMultiDim = (iZsel.eq.0)
+      ELSE 
+         qMultiDim = .true. ! eigentlich Quatsch (z identisch -> ist r, nicht z)
+         ENDIF 
+
+      IF (qMultiDim) THEN 
+         nKout = 0
+         DO K = 1, nK
+            IF (KNew(K).eq.K) THEN 
+               nKout = nKout + 1
+               CALL OlfCopZ (j, jout, K, nKout, Fehler)
+               IF (Fehler.ne.'&ff') RETURN 
+               n = 0
+               DO KK = K, nK
+                  IF (KNew(KK).eq.K) THEN 
+                     n = n + 1
+                     CALL OlfGet1Z (j, KK, 1, Xout(n), Fehler)
+                     IF (Fehler.ne.'&ff') RETURN 
+                     Yout(n) = Yin(KK)
+                     Dout(n) = Din(KK)
+                     ENDIF 
+                  ENDDO 
+               CALL OlfPutXYD (jout, nKout, n, Xout, Yout, Dout, Fehler)
+               IF (Fehler.ne.'&ff') RETURN
+               ENDIF
+            ENDDO
+         ! now z1 has become useless :
+         CALL OlfCnuG (j, 'z1', Co, Un, Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+         CALL OlfCnuP (jout, 'x', Co, Un, Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+         CALL OlfDel1Z (jout, jout, 1, Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+
+      ELSE ! only one z survives: everything becomes very simple (11jan99)
+         DO K = 1, nK
+            CALL OlfGet1Z (j, K, iZsel, Xout(K), Fehler)
+            IF (Fehler.ne.'&ff') RETURN 
+            ENDDO 
+         CALL OlfPutSpe (jout, 1, 0, Z, nK, Xout, Yin, Din, Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+         
+         CALL OlfCnuG (j, 'z'//cl2(iZsel), Co, Un, Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+         CALL OlfCnuP (jout, 'x', Co, Un, Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+
+         ENDIF
+      
+      END ! TensorSaveInt
+
+      SUBROUTINE SetZXofZ (j1, j2, IZXofZ, iz2ofx, nZ2, Fehler)
+C     ---------------------------------------------------------
+            ! JWu 9mrz98
+         ! for all iZ1 of file 1:
+         !    search for corresponding iZ2 of file 2 
+         ! return results as IZXofZ(iZ1) := iZ2
+         ! `corresponding' means that Co(iZ) and Un(iZ) agree
+         ! special case: 
+         !    iZ2=0 stands for CoX instead of CoZ
+         !    i2ofx denotes the iZ1 for which this special case happens
+
+      IMPLICIT NONE
+      INCLUDE 'l_def.f'
+      CHARACTER     Fehler*(*), Co1*40, Un1*40, Co2*40, Un2*40
+      INTEGER       j1, j2, IZXofZ(*), iz2ofx, iOlfG, nZ1, nZ2, iZ1, iZ2
+
+      nZ1 = iOlfG (j1, '#Z', Fehler)
+      nZ2 = iOlfG (j2, '#Z', Fehler)
+      iz2ofx = 0
+      IF (Fehler.ne.'&ff') RETURN 
+      DO iZ1 = 1, nZ1
+         CALL OlfCnuG (j1, 'z'//cl2(iZ1), Co1, Un1, Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+         DO iZ2 = 1, nZ2
+            CALL OlfCnuG (j2, 'z'//cl2(iZ2), Co2, Un2, Fehler)
+            IF (Fehler.ne.'&ff') RETURN
+            IF (Co1.eq.Co2) GOTO 15
+            ENDDO 
+         iZ2 = 0
+         CALL OlfCnuG (j2, 'x', Co2, Un2, Fehler)
+         IF (Fehler.ne.'&ff') RETURN
+         IF (Co1.eq.Co2) GOTO 15
+
+         ! coordinate not found
+         CALL Say2 ('  GARDEZ/ coordinate '//Co1, ' not found in 2nd file')
+         iZ2 = -1
+         GOTO 18
+         RETURN 
+
+ 15      IF (Un1.ne.Un2) THEN 
+            Fehler = ' different units for '//Co1
+            RETURN 
+            ENDIF 
+
+ 18      IZXofZ(iZ1) = iZ2
+         IF (iZ2.eq.0) iz2ofx = iZ1
+
+         ENDDO 
+
+      END ! SetZXofZ
+
+      SUBROUTINE GetKofKbyZX (nZ2, nK2, Z1, nZ1, IZXofZ, K2, Fehler)
+C     --------------------------------------------------------------
+         ! 
+
+      IMPLICIT NONE 
+      INCLUDE 'l_def.f'
+      INCLUDE 'i_dim.f'
+      INCLUDE 'i_wrk.f' ! ZZofK
+      CHARACTER    Fehler*(*)
+      REAL*8       Z1(MZ)
+      INTEGER      nZ2, nK2, nZ1, K, K2, IZXofZ(MZ), iZ1, KK, iZ2, nKfound
+      LOGICAL      qK(MK)
+
+      DO KK = 1, nK2
+         qK(KK) = .true.
+         ENDDO 
+      DO iZ1 = 1, nZ1
+         iZ2 = IZXofZ(iZ1)
+         IF (iZ2.ge.1) THEN 
+            DO KK = 1, nK2
+               IF (ZZofK(KK,iZ2).ne.Z1(iZ1)) qK(KK) = .false.
+               ENDDO 
+            ENDIF
+         ENDDO 
+
+      nKfound = iqSum (qK, nK2)
+      IF (nKfound.eq.0) THEN 
+         Fehler = 'no correspondence found for spectrum '
+         RETURN 
+      ELSEIF (nKfound.gt.1) THEN 
+         Fehler = 'integral point not unique for spectrum '
+         RETURN 
+      ELSE 
+         DO K2 = 1, nK2
+            IF (qK(K2)) RETURN 
+            ENDDO 
+         ENDIF 
+
+      END ! GetKofKbyZX