Home Simfit Manual sv_Manual Tutorials Gallery SVG Models Download Support

simdem logo The Simdem package


  1. Using Fortran to write Windows programs
  2. Description of the Simdem package
  3. Technical details
  4. Programs: Brief descriptions
  5. Programs: Source codes in numerical order
  6. Programs: Source codes in subject order
  7. Subroutines: Descriptions in program numerical order
  8. Subroutines: Descriptions in program subject order
  9. Subroutines: Descriptions in alphabetical order
  10. 64-bit Simdem and cross compiler complications
  11. Simfit home page

1. Using Fortran to write Windows programs

Although users of FTN95 have access to Clearwin+ to create fully featured Windows programs, such programs are not totally portable to other compiler platforms. The usual way to do this is to rely on Visual Basic, Visual C++, or similar commercial packages, which offer users forms to design menus and displays, so insulating users from having to know anything about the inner workings of the Windows operating system. This can be a restriction for programmers wishing to write Open Source number crunching programs, like Simfit, which use the enormous number of excellent public domain codes that exist specifically for this purpose. Simfit provides an Open Source package called Simdem which demonstrates how to use Simfit to bridge this gap. It has been created using the Clearwin+ system, and this would not have been possible without the help of the Salford Software expert programmers, David Bailey, Paul Laidler, Ivan Lucas, and Richard Putman. Essentially, it makes available to Fortran programmers all the necessary interface to the Windows operating system that was created in the first place for the Simfit package. From the Simfit website you can download and install the Simdem package to create your own Windows executables, using only standard Fortran programming techniques, with no direct calls to the Windows API.

Back to Menu or Simfit home page


2. Description of the Simdem package

Simdem: A Simfit package of Open Source codes, documentation and executables for demonstration programs designed to show programmers using NAGfor, Salford/Silverfrost FTN95, or other compilers, how to port Fortran programs into MS Windows.

The Simdem executables generate menus and graphics by calling input/output/graphics/file-handling routines in the public domain dynamic link libraries w_menus.dll, and w_graphics.dll. These call w_clearwin.dll which in turn calls the the Salford run-time library salflibc.dll. Using the techniques demonstrated in the simdem package you can make your own executables with Windows-type input/output, and extensive graph plotting, and data handling controls. All that is required is that the dlls are either in the same folder as your executables or on the path.

The stand alone Simdem example programs will serve as an introduction but, for more extensive controls, the source code for w_menus.dll, and w_graphics.dll should be consulted. This can be downloaded from the Simfit site at

https://simfit.org.uk

Send queries and comments to bill.bardsley@simfit.org.uk

To appreciate the full scope of Simdem graph plotting and to understand the functionality of the file selection controls, the Simfit reference manual (w_manual.pdf) should be consulted. This can be downloaded from the Simfit website.

There is also a utility for2f95 to convert fixed format *.for source into a special fixed/free format *.f95 code.

Back to Menu or Simfit home page


3. Technical details

  1. Introduction
  2. The Simfit package
  3. Salford-Software/Silverfrost Win32 compilers and Clearwin+
  4. The aim of the Smdem programs
  5. How to use the Simdem programs
  6. Printing and viewing PostScript files
  7. The Simfit calling convention
  8. Input/Output/File-access across different compilers
  9. The Simfit data file format

1) Introduction

Simdem programs are self contained items designed to show users of the Salford-Software/Silverfrost Win32 compilers how to call subroutines from the Simfit dynamic link libraries. Fortran programmers wanting to port legacy code to Windows can use the stand-alone interface for input/output and graphics from the Simfit DLLs. The program simdem.for is a driver program to explore the series.

To use the Simfit GUI from other compilers such as NAGfor the STDCALL calling convention is now used. In other words, the Simfit binaries are compiled using the /f_stdcall switch. Also, for cross-compiler use, section 8 should be noted.

2) The Simfit package

This can obtained, free of charge, from

https://simfit.org.uk

and you should download and install the package to find out the possibilities. There are seven dynamic link libraries supplied with the package as follows, where the w_ * is replaced by x64_* in the 64-bit versions:

 w_numbers.dll  :third party number crunchers (AS, blas, linpack,
                 lapack, dvode, minpack, lbfgsb, slatec, ACMTOMS)
 w_maths.dll    :numerical analysis library with calling sequences
                 and arguments similar to the NAG library
                 There is also a dummy version calling the actual
                 NAG library routines for those who have the NAG DLLs.
 w_menus.dll    :routines for input and output of data, file
                 handling and data editing
 w_graphics.dll :plotting graphs, contours, space curves, surfaces,
                 etc. and generating professional quality PostScript
 w_simfit.dll   :statistical analysis, data reduction and special
                 functions used by Simfit
 w_models.dll   :library of mathematical models and code to check
                 and interpret user defined models.
 w_clearwin.dll :interface to the Windows API via salflibc.dll

The Simdem programs will show programmers how to call some of these routines. In particular, the menu and plotting routines can greatly simplify development of Fortran programs using the Windows API. The Simfit package is compiled using FTN95, and the Windows interface was created using Clearwin+. I am very grateful to David Bailey, Paul Laidler, Ivan Lucas, and Richard Putman of Salford-Software for helping me to develop this interface.

3) Salford-Software/Silverfrost Win32 compilers and Clearwin+

The FTN77, FTN90 and FTN95 compilers can all call Clearwin+ to interact with the Windows API. Clearwin+ is a superb interface, a sort of Fortran equivalent of Visual Basic, but there are some rather formidable problems facing traditional Fortran users. Not only has the formatting convention got to be learned, but many serious problems arise due to the nonintuitive way that Clearwin+ created controls behave when embedded in subroutines, especially it seems to me in dynamic link libraries.

4) The aim of the Simdem programs

The Simdem programs each illustrate one or more Simfit subroutines which can be called from Standard Fortran programs without knowing anything about Clearwin+, or the Windows API. For instance, font size and window size are calculated internally by the routines. All call backs required for the controls are in the Simfit dlls and you can create many windows dynamically without ever needing to call the Clearwin+ function winio@ yourself.

The idea is to take each issue of input/output/graphics one at a time, starting at a very simple level, and to show you how to call some of the Simfit routines from the DLLs using standard Fortran. Once your code is running, you can always learn how to use Clearwin+ to make your own dedicated controls, or you can get the argument list for the Simfit subroutines and functions, since it is very likely that what you want is already in the Simfit libraries.

5) How to use the Simdem programs

Start by installing the whole of the Simdem package in a Simdem folder, say C:\Program Files\Simdem, and then executing simdem.exe, (or 64_simdem.exe) the driver program. You may wish to compile the code yourself, and you only need the Simdem DLLs to do this, not the Simfit package. Use the batch files supplied to compile the package, then imitate to create your own executables. However, make sure that the libraries are on the path or local to the executables, otherwise the programs will not execute.

A word of warning is required. The subroutines are very, very fussy about argument lists. Keep the originals so you can always have examples that work. It is absolutely vital that all arrays are initialised and dimensioned correctly, otherwise the windows you generate will break up and become unpredictable. Warnings are issued for some common problems. For instance, numpos(i) must be the position of the hot key in option(i), and hot keys cannot be duplicated in a given menu. However, not all errors are trapped like this particular one. Note that, if you set numdec to a particular value that will be the default option when the menu is created, e.g., in the list box routines.

6) Printing and viewing PostScript files

Some of the Simdem examples allow you to generate hardcopy, etc. If you want to print, view PostScript, transform ps to pdf, jpg, etc. you must install the GSview and Ghostscript packages and you will have to configure the folder where you execute code using the Simfit configuration file w_simfit.cfg, created from w_simfit.exe. A simdem example (simdem40) will show you how to call the configuration subroutine from your own code, but the routines will create default configuration files such as w_simfit.cfg which you can easily edit yourself if required.

7) The simfit calling convention

The example routines tend to be simple interfaces to far more comprehensive routines with more extensive argument lists. If you want more control over size, position, font, colour, etc. you will have to get the calling sequence for the comprehensive subroutines. To help you understand the way the routines are called and to help you improvise or avoid type errors just note the following rule:- (In general) Simfit routines always have the sequence, integers, doubles, characters, logicals and, within each type, the arguments are in alphabetical order. Here, for example, is the graphics call from simdem10 to the Simfit GKS interface:

  call gks004 (l1, l2, l3, l4, &        !line types  ... (integers)
               m1, m2, m3, m4, &        !symbol types... (integers)
               n1, n2, n3, n4, &        !dimensions  ... (integers)
               x1, x2, x3, x4, &        !x           ... (doubles)
               y1, y2, y3, y4, &        !y           ... (doubles)
               ptitle, xtitle, ytitle, &!legends     ... (characters)
               axes, gsave)             !controls    ... (logicals)

All variables to simfit subroutines are of standard word length. There are no short integers or short logicals, and all real-types are double precision. There are no single precision variables at all in simfit. Programmers should however note that inside the subroutines there are some truncations to short integers and single precision reals, determined by the arguments to the Salford @-type routines. For this reason you should never compile the DLL code using /dreal, /xreal or /ints, etc.

You should note that some of the routines have dummy arguments that may be switched off by the DLLs, depending on the version you are using. For example, axes and gsave in the above example have no effect in the present version, since plots always have axes and you are always given the option to save hardcopy. However, they must be set as .true. and may be activated again in a future version.

8) Input/Output/File-access across different compilers

The next information can be ignored if you use the same compiler for both your executables and also w_menus.dll and w_graphics.dll. Note that w_clearwin.dll is always compiled using FTN95 and it is designed so that it cannot cause any cross-compiler problems.

However, this is a serious problem if you compile your executables using any compiler except FTN95, but if you intend to write code that will read from or write to files using the Simfit DLLs you should observe the following details.

The fortran open, close, write, read, backspace, rewind, and inquire procedures do not work reliably between binaries compiled using different compilers. To avoid this, Simfit has code to ensure that all input/output, etc. required by executables can be called from w_menus.dll as follows.

 call opener (ios, nunit, fname) ... instead of
 open (unit = nunit, file = fname, iostat = ios)
 call closer (nunit) ... instead of
 close (unit = nunit)
 call writer (ios, nlines, nunit, text) ... instead of
 do i = 1, nlines
    write (nunit, '(a)', iostat = ios) text(i)
 enddo
 call reader (ios, nlines, nunit, text) ... instead of
 do i = 1, nlines
    read (nunit, '(a)', iostat = ios) text(i)
 enddo
 call attrib (fname, there, read_only) ... returns
 there = .true. if fname exists and read_only = .true.
 if fname exists and has the read only attribute
 op = isfcon (fname) ... instead of
 inquire (file = fname, opened = op)
 op = isucon (nunit) ... instead of
 inquire (unit = nunit, opened = op)
 Variables are:
 integer   ios, nlines, nunit
 character fname*(*), text(nlines)*(*)
 logical   op, read_only, there

If files are all expected to be local to your application you can of course use open, inquire, close, write, read, etc., as usual. However, if you want to to use the Simfit codes for file opening, etc. then you must use opener, closer, attrib, reader, etc. as files opened for reading/writing in your application may not be equivalent to the filenames and units recognised by the Simfit DLLs.

9) The Simfit data file format

Programmers may wish to use the extensive source codes in the w_menus.dll for transferring data to and from files or the clipboard and, to do this successfully, the strict Simfit data file format must be understood.

These are the rules.

  1. Data files conform to the ASCII text file convention
  2. Line 1 must be a title up to 80 characters wide
  3. Line 2 must have two integers, i.e. n rows and m columns
  4. Lines 3 to n + 2 must contain the n data values in m columns However, note that if n and m are specifed the input file can have any succession of values as long as they are in row major format. Simfit will, for instance, write using wrap round for wide matrices. As an extreme example, there are not necessarily n data lines with m columns, e.g., there can be only one column of length n*m. The program simdem66 illustrates this feature.
  5. Line n + 3 may optionally be k if k extra lines are to be used
  6. If k is greater than 0 then lines n + 4 to n + 3 + k may be added, e.g. for labels
  7. Within the data matrix, values can be in any valid format, e.g. integers, floats, scientific, etc. and spaces or commas can serve as delimiters. The Simfit package comes with a full set of test files which can be used as examples. Within w_menus.dll there are many subroutines to check for special formats such as columns in increasing order, columns nonnegative, columns as successive integers, etc. as required by the Simfit package, and there are dedicated subroutines to analyse sets of data files in library files or project archives, to facilitate the handling of data sets with multiple files, e.g., for plotting.

The only way to understand all this is to browse the Simfit source codes searching for key words. Note that data matrices are always treated as double precision arrays, not integers so, if you want integers, you will have to do real to integer conversions, etc in your code.

Back to Menu or Simfit home page


4. Programs: Brief descriptions

simdem: the driver
 The driver and individual programs are supplied as source code
 and as executables. Just run for2f95 to generate fixed/free format
 *.f95 versions of the fixed format *.for source codes.
 Run the driver to enable you to explore all the sources and
 observe the action.
 Note that the driver has an icon to aid identification, so you
 can create a desk-top shortcut.
simdem01: Output text lines
 putadv      ... put an advisory message on screen
 putcau      ... put a cautionary message on screen
 putwar      ... put a warning message on screen
 putfat      ... put a fatal error message on screen
 puttxt      ... put a text string on screen
 putmes      ... put a message text array on screen
 images      ... display typical plotting styles
 help_simdem ... provide help
 
simdem02: Input double precision values
 getr01 ... get 1 value from the user
 getr02 ... get 2 values from the user
 getr03 ... get 3 values from the user
 getrm1 ... get 1 value in the middle of two extreme values
 getd01 ... get 1 value               (must be initialised)
 getd02 ... get 2 values              (must be initialised)
 getd03 ... get 3 values              (must be initialised)
 getdge ... get 1 lower limited value (must be initialised)
 getdle ... get 1 upper limited value (must be initialised)
 getdg2 ... get x =< y                (must be initialised)
 getdg3 ... get x =< y =< z           (must be initialised)
 getdm1 ... get 1 limited value       (must be initialised)
 
simdem03: Input integer values
 geti01 ... get 1 integer from the user
 getigt ... get 1 integer greater than a lower limit from the user
 getilt ... get 1 integer less than an upper limit from the user
 getim1 ... get 1 integer in the middle of two extreme values
 getj01 ... get 1 integer           (must be initialised)
 getjge ... get j >= i              (must be initialised)
 getjle ... get j =< i              (must be initialised)
 getjm1 ... get j where i =< j =< k (must be initialised)
 
simdem04: Input text strings
 getstr ... get a text string from the user (default supplied)
 gettxt ... get a text string from the user (default = ?)
simdem05: Input a logical variable
 getl01 ... get a logical value from the user
simdem06: Dynamic creation of a list box
 listbx ... get a decision from a primitive list box (with tabbing)
simdem07: Dynamic scrolling output
 list01 ... scroll text used as arguments to list01
simdem08: Simple table in a window
 table1 ... create a table from text supplied to table1
simdem09: Create a x,y plot
 gks001 ... the plot can be printed or output as PostScript, etc.
simdem10: Create up to 4 x,y plots
 gks004 ... the plot can be printed or output as PostScript, etc.
simdem11: Double precision editing
 editd1 ... edit a double precision array
simdem12: Integer editing
 editi1 ... edit an integer array
simdem13: Text editing
 edittx ... edit a text array
simdem14: Viewing data values
 viewit ... scrolled viewing of double precision or integer arrays
simdem15: Review progress of results
 revpro ... review progress on a results file at arbitrary intervals
 gettmp ... generate a new temporary file name
 deleet ... delete a file
 opener ... open a file using w_menus.dll
 closer ... close a file opened by w_menus.dll
 writer ... write to a file opend by w_menus.dll
simdem16: Viewing text files
 viewer ... view a supplied file or view a file selected by browsing
simdem17: Create text pages
 patch1 ... display a patch of text (comprehensive interface)
 patch2 ... display a patch of text (simplified interface)
simdem18: Create a title page and menu
 title1 ... display a title and menu
simdem19: Create a question and answer window
 answer ... display text and a summary question
simdem20: Create a tabbing list box window
 tbox01 ... tab above, inside and below a list box
simdem21: Create/transform up to 4 x,y plots
 gkst04 ... plotting with interactive linearising transformations
simdem22: Plot surfaces and contours
 surd2s .. surfaces, contours, projections and skyscrapers
simdem23: Plot curves in space
 space0 .. x(t), y(t), z(t) parametric curve in 3D space
simdem24: Plot vector field
 gksvf1 ... plot a vector flow field of arrows
simdem25: Plot error bars
 gkseb4 ... up to two sets of data/error bars plus two best fit curves
simdem26: Display/file a matrix
 dsplay ... display a matrix but also write to results file if required
simdem27: Create a coloured table
 table2 ... use colours for a individual letters in a table
simdem28: Create a background window
 window ... plant code inside a background window
simdem29: Return a text string
 linein ... plant a text edit box inside a window
simdem30: Title page and tutorial
 titles ... Display a title with menu
 tutor1 ... Display a tutorial
simdem31: Get n integers
 geti0n ... input n integers then return n edited values
simdem32: Get n double precisions
 getr0n ... input n double precision variables then retrun n edited values
simdem33: Get n character strings
 gets0n ... input n character strings then return n edited values
simdem34: Get n logical valriables
 getl0n ... input n logical variables then return n edited values
simdem35: Get n variables of any types
 get00n ... input n variables of any type then return n edited values
simdem36: Button boxes
 bbox01 ... split style
 vbox01 ... vertical
 hbox01 ... horizontal
simdem37: Ganged radio/tick boxes
 rbox01 ... ganged radio or tick boxes
simdem38: Planting a function call in a window
 table4 ... interactive calculations in real time
simdem39: Wait ... calculations in progress
 waiter ... inform users when a slow process is taking place
simdem40: Configure the Simfit DLLs
 config ... show users how to configure the Simdem environment
simdem41: Use vec1in to get a vector from the user
 vec1in ... read in a vector from console, clipboard or file
simdem42: Use mattin to get a matrix from the user
 mattin ... read in a matrix from console, clipboard or file
simdem43: Get a data matrix from the clipboard
 mattin ... read in a matrix from console, clipboard or file
 attrib ... does a file exist and have the read_only attribute
 getnou ... get an unconnected unit
simdem44: The Simfit file selection control
 ofiles ... open a file for input/output
 getfil ... simple Windows file selection control
 fserch ... search for a file
 infofl ... display status of a file
simdem45: Print a text file
 fprint ... print a text file
simdem46: Plot n data sets
 smplot ... overlay n graphs
 deltmp ... delete Simfit temporary files
simdem47: Create a pie chart
 pcplot ... plot a vector as a pie chart
simdem48: Create a bar chart
 bcplot ... plot a matrix as a bar chart
simdem49: Create a box and whisker plot
 bwplot ... plot a vector as a box and whisker plot
simdem50: Plot as bars or symbols plus error bars
 ebplot ... plot a vector as a bar chart with error bars
simdem51: Retrieve current DLL signatures
 scclib ... signature for salflibc.dll
 dllmen ... signature for w_menus.dll
 dllgra ... signature for w_graphics.dll
 dllclr ... signature for w_clearwin.dll
simdem52: Retrieve a colour number from the palette
 palett ... edit or retrieve the Simfit colours
simdem53: 2D scatter plot with labels
 lbplot ... plot symbols with labels
simdem54: Plot sample cumulative and best-fit cdf
 cdplot ... display best-fit cdf on sample cumulative distribution
simdem55: Plot sample histogram and best-fit pdf
 pdplot ... display best fit pdf on sample histogram
simdem56: Plot histogram with error bars
 hist01 ... display a histogram with error bars
simdem57: Plot a dendrogram
 dgplot ... display a dendrogram with a threshold
simdem58: Scrolling check boxes
 chkbox ... toggle tick boxes
simdem59: Multiple file selection
 mfiles ... select a set of files
simdem60: Comprehensive list box
 lstbox ... list box with header and trailer
simdem61: Half normal and normal scores plots
 hnplot ... plot a vector as half or normal scores
simdem62: Bivariate normal contour ellipses
 g02cafg ... fit a straight line
 elips1  ... data and mean 95% confidence region
simdem63: Plot rows and columns from a matrix
 mtplot ... interpret rows or columns as x,y coordinates
simdem64: Plot parameteric curve r = r(theta)
 rtplot ... interpret r(theta) in x,y space
 x01aafg ... pi
simdem65: Select files for viewing or opening
 vuopen ... choose a file from a list to view or open
simdem66: Matrices ... read/write procedures
 mat2in ... read in a matrix from a Simfit data file
 isitmf ... check if a file is a Simfit matrix file
 matout ... write a matrix to a file
simdem67: Matrices ... editing and transforming
 mattrn ... input then edit and/or transform a matrix
simdem68: Matrices ... defaults of arbitrary size
 mat3in ... try to open an arbitrary data file
 mat4in ... get a matrix from a known file or return for a new matrix
simdem69: Plot a vector field with labels, e.g. a biplot
 gksvf3 ... display a vector field with arbitrary arrows and labels
simdem70: Comprehensive list of Simfit plotting styles
 Demonstrate all user-friendly front-ends to w_graphics.dll

Back to Menu or Simfit home page


5. Programs: Source codes in numerical order


simdem01: Output text lines
simdem02: Input double precision values
simdem03: Input integer values
simdem04: Input text strings
simdem05: Input a logical variable
simdem06: Dynamic creation of a list box
simdem07: Dynamic scrolling output
simdem08: Simple table in a window
simdem09: Create a x,y plot
simdem10: Create up to 4 x,y plots
simdem11: Double precision editing
simdem12: Integer editing
simdem13: Text editing
simdem14: Viewing data values
simdem15: Review progress of results
simdem16: Viewing text files
simdem17: Create text pages
simdem18: Create a title page and menu
simdem19: Create a question and answer window
simdem20: Create a tabbing list box window
simdem21: Create/transform up to 4 x,y plots
simdem22: Plot surfaces and contours
simdem23: Plot curves in space
simdem24: Plot vector field
simdem25: Plot error bars
simdem26: Display/file a matrix
simdem27: Create a coloured table
simdem28: Create a background window
simdem29: Return a text string
simdem30: Title page and tutorial
simdem31: Get n integers
simdem32: Get n double precisions
simdem33: Get n character strings
simdem34: Get n character strings
simdem35: Get n variables of any types
simdem36: Button boxes
simdem37: Ganged radio/tick boxes
simdem38: Planting a function call in a window
simdem39: Wait ... calculations in progress
simdem40: Configure the Simfit DLLs
simdem41: Use vec1in to get a vector from the user
simdem42: Use mattin to get a matrix from the user
simdem43: Get a data matrix from the clipboard
simdem44: The Simfit file selection control
simdem45: Print a text file
simdem46: Plot n data sets
simdem47: Create a pie chart
simdem48: Create a bar chart
simdem49: Create a box and whisker plot
simdem50: Plot as bars or symbols plus error bars
simdem51: Retrieve current DLL signatures
simdem52: Retrieve a colour number from the palette
simdem53: 2D scatter plot with labels
simdem54: Plot sample cumulative and best-fit cdf
simdem55: Plot sample histogram and best-fit pdf
simdem56: Plot histogram with error bars
simdem57: Plot a dendrogram
simdem58: Scrolling check boxes
simdem59: Multiple file selection
simdem60: Comprehensive list box
simdem61: Half normal and normal scores plots
simdem62: Bivariate normal contour ellipses
simdem63: Plot rows and columns from a matrix
simdem64: Plot parameteric curve r = r(theta)
simdem65: Select files for viewing or opening
simdem66: Matrices ... read/write procedures
simdem67: Matrices ... editing and transforming
simdem68: Matrices ... defaults of arbitrary size
simdem69: Plot a vector field with labels, e.g. a biplot
simdem70: Comprehensive list of Simfit plotting styles

Back to Menu


6. Programs: Source codes in subject order


simdem01: Display ... messages
simdem07: Display ... sequential calculations
simdem08: Display ... a simple table
simdem14: Display ... data values
simdem15: Display ... progress of calculations
simdem16: Display ... ASCII text files
simdem17: Display ... text pages
simdem26: Display ... or file a matrix
simdem27: Display ... a coloured table
simdem28: Display ... a background window
simdem30: Display ... title page and tutorial
simdem38: Display ... interactive calculations
simdem39: Display ... Wait ... Calculations in progress
simdem29: Get ... a text string
simdem31: Get ... n integers
simdem32: Get ... n doubles
simdem33: Get ... n strings
simdem34: Get ... n logicals
simdem35: Get ... n variables (any type)
simdem02: Get ... double precision values
simdem03: Get ... integer values
simdem04: Get ... text strings
simdem05: Get ... a logical variable
simdem41: Get ... a vector from the user
simdem42: Get ... a matrix from the user
simdem43: Get ... a matrix from the clipboard
simdem51: Get ... DLL signatures
simdem52: Get ... a colour from the palette
simdem06: Select ... from a simple list box
simdem18: Select ... from a title page and menu
simdem19: Select ... from a question and answer window
simdem20: Select ... from a tabbing list box
simdem36: Select ... from button boxes
simdem37: Select ... from ganged radio/tick boxes
simdem58: Select ... from a scrolling check box
simdem59: Select ... one or multiple files
simdem60: Select ... from a comprehensive list box
simdem65: Select ... files to view/open/copy/paste
simdem44: Select ... from simfit file selection control
simdem11: Editing ... double precision variables
simdem12: Editing ... integers
simdem13: Editing ... text
simdem09: Plot ... 1 function
simdem10: Plot ... 4 functions
simdem21: Plot ... 4 (x,y) transforms
simdem22: Plot ... surfaces and contours
simdem23: Plot ... curves in space
simdem24: Plot ... a vector field
simdem25: Plot ... error bars
simdem46: Plot ... n data sets
simdem47: Plot ... a pie chart
simdem48: Plot ... a bar chart
simdem49: Plot ... as boxes and whiskers
simdem50: Plot ... as bars/symbols plus error bars
simdem53: Plot ... a 2D scatter plus labels
simdem54: Plot ... sample cumulative plus best-fit cdf
simdem55: Plot ... sample histogram plus best-fit pdf
simdem56: Plot ... a histogram with error bars
simdem57: Plot ... a dendrogram
simdem61: Plot ... half-normal and normal scores
simdem62: Plot ... bivariate normal confidence ellipses
simdem63: Plot ... rows and columns from a matrix
simdem64: Plot ... parametric curve r = r(theta)
simdem69: Plot ... vector field with labels
simdem70: Plot ... SUMMARY of subroutines
simdem40: Configure ... the Simfit DLLs
simdem45: Print ... a text file
simdem66: Matrices ... read/write procedures
simdem67: Matrices ... editing and transforming
simdem68: Matrices ... defaults of arbitrary size

Back to Menu


!
! simdem01: using put routines for very simple text output
! ========================================================
! For details read simdem.chm or simdem.html
!
! subroutines called
! ------------------
! putadv      ... put an advisory message on screen
! putcau      ... put a cautionary message on screen
! putwar      ... put a warning message on screen
! putfat      ... put a fatal error message on screen
! puttxt      ... put a text string on screen
! putmes      ... put a message text array on screen
! images      ... display typical plotting styles
! help_simdem ... call the compiled html help file
! listbx      ... list box described in simdem06
!
! arguments
! ---------
! putadv, putcau, putwar, putfat, and puttxt take one intent (in) text
! string, while putmes takes one intent (in) n-line text array where
! n is the intent (in) number of lines supplied to putmes.
! images takes an intent (in) integer to the page required, or 0 for all pages.
! help_simdem takes an intent (in) character string for the full help
! using 'simdem' or help for the particular subroutine required.
!
      program    main
      implicit   none
      integer    n, numdec
      integer    mode, nmax, numopt
      parameter (mode = 0, nmax = 20, numopt = 10)
      character  line*100, text(nmax)*100
      logical    repeet
      external   putadv, putcau, putwar, putfat, puttxt, putmes, &
                 images, help_simdem, listbx
      repeet = .true.
      do while (repeet)
!
! create the menu
!
         write (text,1000)
         numdec = numopt - 1
!
! display the menu
!
         call listbx (numdec, numopt, &
                      text)
!
! activate the option selected
!
         if (numdec.eq.1) then
            call putadv ('This is a typical advisory message')
         elseif (numdec.eq.2) then
            call putcau ('This is a typical cautionary message')
         elseif (numdec.eq.3) then
            call putwar ('This is a typical warning message')
         elseif (numdec.eq.4) then
            call putfat ('This is a typical fatal error message')
         elseif (numdec.eq.5) then
            write (line,100) nmax
            call puttxt (line)
         elseif (numdec.eq.6) then
            write (text,200)
            n = 7
            call putmes (n, text)
         elseif (numdec.eq.7) then
            call images (mode)
         elseif (numdec.eq.8) then
            call help_simdem ('simdem01')
         elseif (numdec.eq.9) then
            call help_simdem ('simdem')
         elseif (numdec.eq.numopt) then
            repeet = .false.
         endif
      enddo
  100 format ('Maximum dimension in this program =',I4)
  200 format ( &
       'About the simdem programs' &
      / &
      /'These programs illustrate how to call SIMFIT subroutines' &
      /'and functions from your own programs written in standard' &
      /'Fortran without any direct calls to the Windows API.' &
      / &
      /'For more details read simdem.chm or simdem.html.')
 1000 format ( &
       'putadv     `display a typical advisory message' &
      /'putcau     `display a typical cautionary message' &
      /'putwar     `display a typical warning message' &
      /'putfat     `display a typical fatal error message' &
      /'puttxt     `display a character string' &
      /'putmes     `display a structured message' &
      /'images     `display examples of plotting styles' &
      /'help_simdem`provide help for a selected procedure' &
      /'help_simdem`provide help for the whole simdem package' &
      /'Cancel     `')
      end
!
!
!
Back to Menu or Programs: Brief description
!
! simdem02: using get routines for very simple double precision retrieval
! =======================================================================
! For details read simdem.chm or simdem.html
! Values can have up to 15 significant digits (not including decimal points
! and signs) and output is using the character (len = 25) function form25
! which returns left justified values with trailing zeros removed after the
! first significant decimal digit.
! Arguments for list box routine listbx are described in simdem06.
!
! subroutines
! -----------
! getr01 (x, text)       ... get 1 unrestricted value
! getr02 (x, y, text)    ... get 2 unrestricted values
! getr03 (x, y, z, text) ... get 3 unrestricted values
! getrm1 (A, x, B, text) ... get x where A =< x =< B   (A and B must be initialised)
! getd01 (x, text)       ... get 1 unrestricted value  (must be initialised)
! getd02 (x, y, text)    ... get 2 unrestricted values (must be initialised)
! getd03 (x, y, z, text  ... get 3 unrestricted values (must be initialised)
! getdge (x, A, text)    ... get x where x >= A        (must be initialised)
! getdle (x, A, text)    ... get x where x =< A        (must be initialised)
! getdg2 (x, y, text)    ... get x =< y                (must be initialised)
! getdg3 (x, y, z, text) ... get x =< y =< z           (must be initialised)
! getdm1 (A, x, B, text) ... get x where A =< x =< B   (must be initialised)
! form25 (x)             ... write x as a left justified character string
!                            with up to 15 significant figures and trailing
!                            zeros suppressed
!
! arguments (xbot =< xmid =< xtop)
! -------------------------------
!     line: intent (in) message
!  x, y, z: intent (inout)
!     xbot: intent (in) smallest value
!     xmid: intent (inout) value returned
!     xtop: intent (in) largest value
!     xlim: intent (in) arbitrary upper or lower limit
!
      program    main
      implicit   none
      integer    l1, l2, l3, l4
      parameter (l1 = 1)
      integer    numdec, numopt
      parameter (numopt = 13)
      double precision x, xbot, xlim, xmid, xtop, y, z
      double precision zero, one, ten
      parameter (zero = 0.0d+00, one = 1.0d+00, ten = 10.0d+00)
      character  line*100, text(numopt)*80
      character (len = 25) form25, x25, y25, z25, xbot25, xmid25, xtop25
      logical    repeet
      external   getr01, getr02, getr03, getrm1
      external   getd01, getd02, getd03, getdge, getdle, getdg2, getdg3, &
                 getdm1
      external   putadv, form25, listbx
      intrinsic  len_trim
!
! create the menu
!
      write (text,1000)
      repeet = .true.
      do while (repeet)
         numdec = 1
!
! display the menu
!
         call listbx (numdec, numopt, &
                      text)
!
! execute the procedure selected
!
        if (numdec.eq.1) then
!
! examples not requiring initialisation
!
            call getr01 (x, 'A real number')
            x25 = form25(x)
            write (line,100) x25
            call putadv (line)
         elseif (numdec.eq.2) then
            call getr02 (x, y, 'Two real numbers')
            x25 = form25(x)
            y25 = form25(y)
            l2 = len_trim(x25)
            l3 = len_trim(y25)
            write (line,200) x25(l1:l2), y25(l1:l3)
            call putadv (line)
         elseif (numdec.eq.3) then
            call getr03 (x, y, z, 'Three real numbers)')
            x25 = form25(x)
            y25 = form25(y)
            z25 = form25(z)
            l2 = len_trim(x25)
            l3 = len_trim(y25)
            l4 = len_trim(z25)
            write (line,300) x25(l1:l2), y25(l1:l3), z25(l1:l4)
            call putadv (line)
         elseif (numdec.eq.4) then
            write (line,400)
            xbot = zero
            xtop = ten
            call getrm1 (xbot, xmid, xtop, line)
            xbot25 = form25(xbot)
            xmid25 = form25(xmid)
            xtop25 = form25(xtop)
            l2 = len_trim(xbot25)
            l3 = len_trim(xmid25)
            l4 = len_trim(xtop25)
            write (line,500) xbot25(l1:l2), xmid25(l1:l3), xtop25(l1:l4)
            call putadv (line)
         elseif (numdec.eq.5) then
!
! examples requiring initialisation
!
            x = one
            call getd01 (x, 'A real number')
            x25 = form25(x)
            write (line,100) x25
            call putadv (line)
         elseif (numdec.eq.6) then
            x = zero
            y = one
            call getd02 (x, y, 'Two real numbers')
            x25 = form25(x)
            y25 = form25(y)
            l2 = len_trim(x25)
            l3 = len_trim(y25)
            write (line,200) x25(l1:l2), y25(l1:l3)
            call putadv (line)
         elseif (numdec.eq.7) then
            x = zero
            y = one
            z = y + one
            call getd03 (x, y, z, 'Three real numbers)')
            x25 = form25(x)
            y25 = form25(y)
            z25 = form25(z)
            l2 = len_trim(x25)
            l3 = len_trim(y25)
            l4 = len_trim(z25)
            write (line,300) x25(l1:l2), y25(l1:l3), z25(l1:l4)
            call putadv (line)
         elseif (numdec.eq.8) then
            x = one
            xlim = zero
            call getdge (x, xlim, 'Any value <= 0')
            x25 = form25(x)
            write (line,100) x25
            call putadv (line)
         elseif (numdec.eq.9) then
            x = zero
            xlim = one
            call getdle (x, xlim, 'Any value =< 1')
            x25 = form25(x)
            write (line,100) x25
            call putadv (line)
         elseif (numdec.eq.10) then
            x = zero
            y = one
            call getdg2 (x, y, 'Any values x, y such that y >= x')
            x25 = form25(x)
            y25 = form25(y)
            l2 = len_trim(x25)
            l3 = len_trim(y25)
            write (line,200) x25(l1:l2), y25(l1:l3)
            call putadv (line)
         elseif (numdec.eq.11) then
            x = zero
            y = one
            z = y + one
            call getdg3 (x, y, z, &
                        'Any values x, y, z such that z >= y >= x'
            x25 = form25(x)
            y25 = form25(y)
            z25 = form25(z)
            l2 = len_trim(x25)
            l3 = len_trim(y25)
            l4 = len_trim(z25)
            write (line,300) x25(l1:l2), y25(l1:l3), z25(l1:l4)
            call putadv (line)
         elseif (numdec.eq.12) then
            write (line,400)
            xbot = zero
            xmid = one
            xtop = ten
            call getdm1 (xbot, xmid, xtop, line)
            xbot25 = form25(xbot)
            xmid25 = form25(xmid)
            xtop25 = form25(xtop)
            l2 = len_trim(xbot25)
            l3 = len_trim(xmid25)
            l4 = len_trim(xtop25)
            write (line,500) xbot25(l1:l2), xmid25(l1:l3), xtop25(l1:l4)
            call putadv (line)
         elseif (numdec.eq.numopt) then
            repeet = .false.
         endif
      enddo
  100 format ('Value input =',1x,a)
  200 format ('Values input =',1x,a,',',1x,a)
  300 format ('Values input =',1x,a,',',1x,a,',',1x,a)
  400 format ('A real number within the assigned limits')
  500 format ('Lower limit =',1x,a,', Value =',1x,a, &
      ', Upper limit =',1x,a)
 1000 format ( &
       'getr01`get 1 unrestricted value   `not initialised' &
      /'getr02`get 2 unrestricted values  `not initialised' &
      /'getr03`get 3 unrestricted values  `not initialised' &
      /'getrm1`get x where A =< x =< B    `A and B initialised' &
      /'getd01`get 1 unrestricted value   `must be initialised' &
      /'getd02`get 2 unrestricted values  `must be initialised' &
      /'getd03`get 3 unrestricted values  `must be initialised' &
      /'getdge`get x where x >= A         `must be initialised' &
      /'getdle`get x where x =< A         `must be initialised' &
      /'getdg2`get x,y where x =< y       `must be initialised' &
      /'getdg3`get x,y,z where x =< y =< z`must be initialised' &
      /'getdm1`get x where A =< x =< B    `must be initialised' &
      /'Cancel`                           `  ')
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem03 using get routines for very simple integer input
! =========================================================
! For details read simdem.chm or simdem.html
!
! subroutines
! -----------
! geti01 ... get 1 integer i
! getigt ... get 1 integer i > A
! getilt ... get 1 integer i < A
! getim1 ... get 1 integer A =< i =< B
! getj01 ... get 1 integer i           (must be initialised)
! getjge ... get 1 integer i >= A      (must be initialised)
! getjle ... get 1 integer i =< A      (must be initialised)
! getjm1 ... get 1 integer A =< i =< B (must be initialised)
!
! arguments (ibot =< imid =< itop)
! ---------
! line: intent (in) message
! ibot: intent (in) smallest value
! imid: intent (inout) value returned
! itop: intent (in) largest value
! ilim: intent (in) arbitrary limit
!
! subroutine listbx is described in simdem06
!
      program    main
      implicit   none
      integer    ibot, ilim, imid, itop
      integer    l1, l2, l3
      parameter (l1 = 1)
      integer    numdec, numopt
      parameter (numopt = 9)
      character  line*100, text(numopt)*80
      character  word12*12, zbot*12, zmid*12, ztop*12
      logical    repeet
      external   geti01, getigt, getilt, getim1
      external   getj01, getjge, getjle, getjm1
      external   putadv, listbx
      intrinsic  adjustl, len_trim
!
! create the menu
!
      write (text,1000)
      repeet = .true.
      do while (repeet)
         numdec = 1
!
! display the menu
!
         call listbx (numdec, numopt, text)
!
! execute the procedure selected
!
         if (numdec.eq.1) then
!
! examples not requiring initialisation, blank string is displayed
!
            call geti01 (imid, 'An integer')
            write (word12,'(i12)') imid
            write (line,100) adjustl(word12)
            call putadv (line)
         elseif (numdec.eq.2) then
            ibot = 0
            write (word12,'(i12)') ibot
            write (line,200) adjustl(word12)
            call getigt (imid, ibot, line)
            write (word12,'(i12)') imid
            write (line,100) adjustl(word12)
            call putadv (line)
         elseif (numdec.eq.3) then
            itop = 100
            write (word12,'(i12)') itop
            write (line,300) adjustl(word12)
            call getilt (imid, itop, line)
            write (word12,'(i12)') imid
            write (line,100) adjustl(word12)
            call putadv (line)
         elseif (numdec.eq.4) then
            write (line,400)
            ibot = 0
            itop = 10
            call getim1 (ibot, imid, itop, line)
            write (zbot,'(i12)') ibot
            write (zmid,'(i12)') imid
            write (ztop,'(i12)') itop
            zbot = adjustl(zbot)
            zmid = adjustl(zmid)
            ztop = adjustl(ztop)
            l2 = len_trim(zbot)
            l3 = len_trim(zmid)
            write (line, 500) zbot(l1:l2), zmid(l1:l3), ztop
            call putadv (line)
         elseif (numdec.eq.5) then
!
! examples requiring initialisation, initial value is displayed
!
            imid = 1
            call getj01 (imid, 'An integer')
            write (word12,'(i12)') imid
            write (line,100) adjustl(word12)
            call putadv (line)
         elseif (numdec.eq.6) then
            ilim = 0
            write (word12,'(i12)') ilim
            write (line,200) adjustl(word12)
            imid = ilim + 1
            call getjge (imid, ilim, line)
            write (word12,'(i12)') imid
            write (line,100) adjustl(word12)
            call putadv (line)
         elseif (numdec.eq.7) then
            ilim = 0
            imid = ilim - 1
            write (word12,'(i12)') ilim
            write (line,300) adjustl(word12)
            call getjle (imid, ilim, line)
            write (word12,'(i12)') imid
            write (line,100) adjustl(word12)
            call putadv (line)
         elseif (numdec.eq.8) then
            write (line,400)
            ibot = 0
            imid = 5
            itop = 10
            call getjm1 (ibot, imid, itop, line)
            write (zbot,'(i12)') ibot
            write (zmid,'(i12)') imid
            write (ztop,'(i12)') itop
            zbot = adjustl(zbot)
            zmid = adjustl(zmid)
            ztop = adjustl(ztop)
            l2 = len_trim(zbot)
            l3 = len_trim(zmid)
            write (line, 500) zbot(l1:l2), zmid(l1:l3), ztop
            call putadv (line)
         elseif (numdec.eq.numopt) then
            repeet = .false.
         endif
      enddo
  100 format ('Value input =',1x,a)
  200 format ('An integer >',1x,a)
  300 format ('An integer <',1x,a)
  400 format ('An integer within the assigned limits')
  500 format ('Lower limit =',1x,a,', Value =',1x,a, &
      ', Upper limit =',1x,a)
 1000 format ( &
       'geti01`get 1 integer i          ` ' &
      /'getigt`get 1 integer i < A      ` ' &
      /'getilt`get 1 integer i > A      ` ' &
      /'getim1`get 1 integer A =< i =< B`A and B initialised' &
      /'getj01`get 1 integer i          `must be initialised' &
      /'getjge`get 1 integer i >= A     `must be initialised' &
      /'getjle`get 1 integer i =< A     `must be initialised' &
      /'getjm1`get 1 integer A =< i =< B`must be initialised' &
      /'Cancel`                         `  ')
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem04: using get routines for very simple text input
! =======================================================
!
! subroutines
! -----------
! getstr ... get a text string from the user (default supplied)
! gettxt ... get a text string from the user (default = ?)
!
! arguments
! ---------
! question: intent (in) request for input
!   answer: intent (inout) response
!
      program    main
      implicit   none
      character  answer*80, question*80
      external   getstr, gettxt, puttxt
      answer = 'anything'
      question = 'Please type something in'
      call gettxt (question, answer)
      call puttxt (answer)
      answer = 'Default text string supplied'
      call getstr (question, answer)
      call puttxt (answer)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem05: using get routines for very simple logical input
! ==========================================================
!
! subroutine
! ----------
! getl01 ... get a logical value from the user
!
! arguments
! ---------
! question: intent (in) request for input
!    yesno: intent (inout) response (default =  value as supplied)
!
      program    main
      implicit   none
      character  question*80
      logical    yesno
      external   getl01, putadv
      question = 'Please answer yes or no'
      yesno = .true.
      call getl01 (question, yesno)
      if (yesno) then
         call putadv ('Yes was selected')
      else
         call putadv ('No was selected')
      endif
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem06: using listbx for very simple tabbing list box selection
! =================================================================
!
! subroutine
! ----------
! listbx ... get a decision from a primitive list box (with tabbing)
!
! arguments
! ---------
! numdec: intent (inout) number of decision (initialises the list box, numdec >= 1)
! numopt: intent (in) number of options  (1 =< numdec =< numopt)
! option: intent (in) array of options
!
      program    main
      implicit   none
      integer    numdec, numopt
      integer    nmax
      parameter (nmax = 20)
      character  line*80, option(nmax)*80
      external   putadv, listbx
!
! The options required are written as a character array
!
      write (option,100)
!
! Specify the default starting option
!
      numdec = 1
!
! Specify the number of options
!
      numopt = 4
!
! Call the list box routine
!
      call listbx (numdec, numopt, option)
      write (line,200) numdec
      call putadv (line)
!
! The grave character (`) causes tabbing into columns inside the list box.
! Note: this feature may not work accurately on all displays since it
! depends in a rather complicated way on the current user font set-up scheme.
!
      write (option,300)
      numopt = 5
      numdec = numopt
      call listbx (numdec, numopt, option)
      write (line,200) numdec
      call putadv (line)
  100 format ( &
       'Apples' &
      /'Oranges' &
      /'Pears' &
      /'Grapes')
  200 format ('Item number',I3,' was selected')
  300 format ( &
       'Row 1/Col 1`Column 2 `Column 3' &
      /'Row 2      `Item(2,2)`Item(2,3)' &
      /'Row 3      `Item(3,2)`Item(3,3)' &
      /'Row 4      `Item(4,2)`Item(4,3)' &
      /'Cancel')
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem07: using list01 to output a simple scrolling list in a window (text)
! ===========================================================================
! For details read simdem.chm or simdem.html
!
! subroutine
! ----------
! list01 ... scroll text used as arguments to list01
!
! arguments
! ---------
! line: intent (inout) character string as follows:
!
! if (line = 'OPEN') then
!    ... open a window for output
! elseif (line = 'CLOSE') then
!    ... close down the window
! else
!  ... the line is displayed in the window with scrolling if required
! endif
!
! If the user closes the widow during output, line is returned as 'CLOSE'.
! For this reason line must be a intent (inout) variable, and not an
! intent (in) parameter, and the value returned must be checked to see if
! the user wants to close down the output.
!
      program   main
      implicit  none
      integer   i
      double precision delay
      parameter (delay = 0.25d+00)
      character line*80
      external  list01, putadv, sleep1
!
! Set line = 'OPEN' then call list01 to open the window
!
      line = 'OPEN'
      call list01 (line)
!
! Output the text strings until the window is closed or the loop completed
!
      do i = 1, 25
         if (line.ne.'CLOSE') then
            write (line,100) i
            call list01 (line)
            call sleep1 (delay)
         endif
      enddo
!
! Note: line must be tested on exit since, if the window output has been,
!       completed, the close down must be interrupted.
!
      if (line.ne.'CLOSE') then
         call putadv ('Output is completed')
         line = 'CLOSE'
         call list01 (line)
      endif
  100 format ('This is line number',I4)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem08: using table1 to output a simple table in a window (text)
! ==================================================================
!
! subroutine
! ----------
! table1 ... create a table from text supplied to table1
!
! arguments
! ---------
! icolor: intent (in) text or background colour as follows:
!         icolor = 0(black), 1(blue), 4(red), 15(white), etc. (VGA type)
!   line: intent (in) character string as follows:
!         if (line = 'OPEN') then
!            ... open a window,
!         elseif (line = 'CLOSE') then
!             ... close the window
!         else
!             ... the line is displayed in the window.
!         endif
!
! If the user closes the widow during output, the calculation will not be
! interrupted but there will be no further output. The subroutine will scroll
! back through the intermediate or total output.
!
      program    main
      implicit   none
      integer    i, icolor, imax
      parameter (imax = 85)
      character  line*80
      external   table1
!
! Set line = 'OPEN' to open the window and set the background colour
!
      icolor = 15
      call table1 (icolor, 'OPEN')
!
! Output the coloured text strings
!
      do i = 1, imax
         if (i.le.20) then
            icolor = 1
         elseif (i.le.50) then
            icolor = 4
         else
            icolor = 0
         endif
         write (line,100) i
         call table1 (icolor, line)
      enddo
!
! Close down the table
!
      call table1 (icolor,'CLOSE')
  100 format ('This is line number',I4)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem09: gks001, a very simple plotting subroutine
! ===================================================
!
! subroutine
! ----------
! gks001 ... the plot can be printed or output as PostScript, etc.
!
! arguments
! ---------
!      l: intent (in) line type, e.g. 0 = none, 1 = solid, 2 = dashed, 3 = dotted, etc
!      m: intent (in) symbol type, e.g. 0 = none, 5 = circle, 8 = triangle, 11 = square, etc.
!      n: intent (in) number of points plotted
!      x: intent (in) x-values
!      y: intent (in) y-values
! ptitle: intent (in) plot title
! xtitle: intent (in) x legend subtitle
! ytitle: intent (in) y legend subtitle
!
      program    main
      implicit   none
      integer    i, l, m, n
      integer    nmax
      parameter (nmax = 100)
      double precision x(nmax), y(nmax)
      character  ptitle*8, xtitle*1, ytitle*1
      external   gks001
!
! Define line and symbol types then number of points and data
!
      l = 1
      m = 5
      n = 10
      do i = 1, n
         x(i) = i
         y(i) = i
      enddo
!
! Define title and legends
!
      ptitle = 'y = f(x)'
      xtitle = 'x'
      ytitle = 'y'
!
! Plot the graph
!
      call gks001 (l, m, n, x, y, ptitle, xtitle, ytitle)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem10: gks004, a simple plotting subroutine (up to 4 graphs)
! ===============================================================
!
! subroutine
! ----------
! gks004 ... the plots can be printed or output as PostScript, etc.
!
! arguments
! ---------
!      l: intent (in) line type, e.g. 0 = none, 1 = solid, 2 = dashed, 3 = dotted, etc
!      m: intent (in) symbol type, e.g. 0 = none, 5 = circle, 8 = triangle, 11 = square, etc.
!      n: intent (in) number of points to be plotted
!      x: intent (in) x-values
!      y: intent (in) y-values
! ptitle: intent (in) plot title
! xtitle: intent (in) x legend subtitle
! ytitle: intent (in) y legend subtitle
!   axes: intent (in) = .true. (option to plot axes ... may not be referenced in this version)
!  gsave: intent (in) = .true. (option to save hard-copy ... may not be referenced in this version)
!
!
      program    main
      implicit   none
      integer    i, n
      integer    nmax
      parameter (nmax = 100)
      integer    l1, l2, l3, l4, m1, m2, m3, m4, n1, n2, n3, n4
      double precision x1(nmax), x2(nmax), x3(nmax), x4(nmax)
      double precision y1(nmax), y2(nmax), y3(nmax), y4(nmax)
      double precision cosi, delta, sini, t(nmax)
      double precision a, b, c, d, pi2, zero, one
      parameter (a = 1.0d+00, b = 2.0d+00, c = 3.0d+00, d = 4.0d+00, &
                 pi2 = 6.2831853, zero = 0.0d+00, one = 1.0d+00)
      character  ptitle*8, xtitle*1, ytitle*1
      logical    axes, gsave
      parameter (axes = .true., gsave = .true.)
      external   gks004
      intrinsic  sin, cos, dble
!
! Define line and symbol types and number of points
!
      l1 = 1
      l2 = 2
      l3 = 3
      l4 = 4
      m1 = 5
      m2 = 8
      m3 = 11
      m4 = 14
      n = nmax/2
      n1 = n
      n2 = n
      n3 = n
      n4 = n
!
! Define the data
!
      delta = pi2/(dble(n) - one)
      t(1) = zero
      do i = 2, n - 1
         t(i) = t(i - 1) + delta
      enddo
      t(n) = pi2
      do i = 1, n
         cosi = cos(t(i))
         sini = sin(t(i))
         x1(i) = a*cosi
         x2(i) = b*cosi
         x3(i) = c*cosi
         x4(i) = d*cosi
         y1(i) = a*sini
         y2(i) = b*sini
         y3(i) = c*sini
         y4(i) = d*sini
      enddo
!
! Define the title and legends
!
      ptitle = 'y = f(x)'
      xtitle = 'x'
      ytitle = 'y'
!
! Plot the graphs
!
      call gks004 (l1, l2, l3, l4, &
                   m1, m2, m3, m4, &
                   n1, n2, n3, n4, &
                   x1, x2, x3, x4, &
                   y1, y2, y3, y4, &
                   ptitle, xtitle, ytitle, &
                   axes, gsave)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem11: editd1, a simple double precision editor
! ==================================================
!
! subroutine
! ----------
! editd1 ... edit a double precision array
!
! arguments
! ---------
! isend: intent (in) flag as follows:
!        isend = 1: view but no editing
!        isend = 2: edit a full matrix
!        isend = 3: input to a blank matrix
! ncols: intent (in) number of columns
! nrmax: intent (in) leading array dimension
! nrows: intent (in) number of rows
!     a: intent (inout) matrix
! title: intent (in) title of matrix
!
!
      program    main
      implicit   none
      integer    i, isend, j, ncols, nrows
      integer    nrmax, ncmax
      parameter (nrmax = 50, ncmax = 10)
      double precision a(nrmax,ncmax)
      double precision tenth, ten
      parameter (ten = 10.0d+00)
      character  title*20
      external   editd1
      intrinsic  dble
!
! Fill in the matrix
!
      ncols = 4
      nrows = 5
      do j = 1, ncols
         tenth = dble(j)/ten
         do i = 1, nrows
            a(i,j) = dble(i) + tenth
         enddo
      enddo
!
! isend = 1: viewing mode
!
      isend = 1
      title = 'Default data'
      call editd1 (isend, ncols, nrmax, nrows, a, title)
!
! isend = 2: editing mode
!
      isend = 2
      title = 'Data for editing'
      ncols = ncols - 1
      nrows = nrows - 1
      call editd1 (isend, ncols, nrmax, nrows, a, title)
!
! isend = 3: data input mode
!
      isend = 3
      title = 'Input some data'
      ncols = ncols - 1
      nrows = nrows - 1
      call editd1 (isend, ncols, nrmax, nrows, a, title)
!
! isend = 1: confirm the data input
!
      isend = 1
      title = 'Your values'
      call editd1 (isend, ncols, nrmax, nrows, a, title)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem12: editi1, a simple integer editor
! =========================================
!
! subroutine
! ----------
! editi1 ... edit an integer array
!
! arguments
! ---------
! isend: intent (in) flag as follows:
!        isend = 1: view but no editing
!        isend = 2: edit a full matrix
!        isend = 3: input to a blank matrix
! ncols: intent (in) number of columns
! nrmax: intent (in) leading array dimension
! nrows: intent (in) number of rows
!     a: intent (inout) matrix (doubles transformed to integers on entry)
! title: intent (in) title of matrix
!
!
      program    main
      implicit   none
      integer    i, isend, j, ncols, nrows
      integer    nrmax, ncmax
      parameter (nrmax = 50, ncmax = 10)
      double precision a(nrmax,ncmax)
      double precision dj, ten
      parameter (ten = 10.0d+00)
      character  title*20
      external   editi1
      intrinsic  dble
!
! Fill in the matrix
!
      ncols = 4
      nrows = 5
      do j = 1, ncols
         dj = dble(j)
         do i = 1, nrows
            a(i,j) = ten*dble(i) + dj
         enddo
      enddo
!
! isend = 1: viewing mode
!
      isend = 1
      title = 'Default data'
      call editi1 (isend, ncols, nrmax, nrows, a, title)
!
! isend = 2: editing mode
!
      isend = 2
      title = 'Data for editing'
      ncols = ncols - 1
      nrows = nrows - 1
      call editi1 (isend, ncols, nrmax, nrows, a, title)
!
! isend = 3: data input mode
!
      isend = 3
      title = 'Input some data'
      ncols = ncols - 1
      nrows = nrows - 1
      call editi1 (isend, ncols, nrmax, nrows, a, title)
!
! isend = 1: display data matrix
!
      isend = 1
      title = 'Your values'
      call editi1 (isend, ncols, nrmax, nrows, a, title)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem13: edittx, a simple text editor
! ======================================
!
! subroutine
! ----------
! edittx ... edit a text array
!
! arguments
! ---------
!  nhigh: intent (in) number of lines in text buffer
! nlines: intent (out) length of edited buffer
!  nwide: intent (in) width of edited buffer
!   text: intent (inout) buffer
!
!
      program    main
      implicit   none
      integer    i, nlines
      integer    nhigh, nwide
      parameter (nhigh = 50, nwide = 80)
      character  text(nhigh)*(nwide)
      character  blank*1
      parameter (blank = ' ')
      external   edittx, putmes
!
! Initialise the text
!
      do i = 1, nhigh
         text(i) = blank
      enddo
!
! Edit the text
!
      text(1) = 'Demonstrating a simple text editor'
      text(3) = 'This is some arbitrary text'
      text(5) = 'Make changes and see what happens'
      call edittx (nhigh, nlines, nwide, text)
!
! Display the result
!
      call putmes (nlines, text)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem14: viewit, a simple data viewer (also copies to the clipboard)
! =====================================================================
!
! subroutine
! ----------
! viewit ... scrolled viewing of double precision or integer arrays
!
! arguments
! ---------
! ncols: intent (in) number of columns
! nrmax: intent (in) leading dimension of array
! nrows: intent (in) number of rows
! ntype: intent (in) flag as follows:
!        ntype = 1: i format (integers)
!        ntype = 2: f format (floats)
!        ntype = 3: e format (large/small)
!
      program    main
      implicit   none
      integer    i, j
      integer    ncmax, ncol, nrmax, nrow, ntype
      parameter (nrmax = 20, ncmax = 10)
      double precision a(nrmax,ncmax), dj
      double precision ten
      parameter (ten = 10.0d+00)
      character  title*20
      external   viewit
      intrinsic  dble
!
! Initialise a
!
      do j = 1, ncmax
         dj = dble(j)
         do i = 1, nrmax
            a(i,j) = ten*dble(i) + dj
         enddo
      enddo
!
! i format
!
      ncol = 9
      nrow = 9
      title = 'i format'
      ntype = 1
      call viewit (ncol, nrmax, nrow, ntype, a, title)
!
! f format
!
      ncol = ncol - 1
      nrow = nrow - 1
      do j = 1, ncol
         do i = 1, nrow
            a(i,j) = a(i,j)/ten
         enddo
      enddo
      title = 'f format'
      ntype = 2
      call viewit (ncol, nrmax, nrow, ntype, a, title)
!
! e format
!
      ncol = ncol - 1
      nrow = nrow - 1
      do j = 1, ncol
         do i = 1, nrow
            a(i,j) = a(i,j)/ten
         enddo
      enddo
      title = 'e format'
      ntype = 3
      call viewit (ncol, nrmax, nrow, ntype, a, title)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem15: revpro, review progress so far (also copies to the clipboard)
! =======================================================================
!
! subroutine
! ----------
! revpro ... review progress on a results file at arbitrary intervals
! gettmp ... generate a new temporary file name in the %TEMP% folder
! deleet ... delete a file
! opener ... open a file using w_menus.dll
! closer ... close a file opened by w_menus.dll
! writer ... write to a file opened by w_menus.dll
!
! arguments
! ---------
! revpro ... nout: intent (in) unit for file connection
! gettmp ... error_code: intent (out) flag (0 = success)
!                  temp: intent (out) temporary file name
!                        If len(temp) is large enough a file name will be
!                        created in the user %TEMP% folder but otherwise
!                        a local file name will be created
! opener ...  ios: intent (out) iostat value from open in w_menus.dll
!            nout: intent (in) unit for file opening in w_menus.dll
!            temp: intent (in) file name for opening in w_menus.dll
! writer ...    ios: intent (out) iostat value from writing
!            nlines: intent (in) number of lines to be written to temp
!              nout: intent (in) unit for file opening
!              line: intent (in) text array for writing
! closer ... nout: intent (in) unit for closing in w_menus.dll
! deleet ...  temp: intent (in) filename for deleting
!            askif: intent (in) flag to request confirm before deleting
!            there: intent (out) .true. if temp was not deleted
!
      program    main
      implicit   none
      integer    i, j
      integer    ios, nlines
      parameter (nlines = 1)
      integer    ncmax, nrmax, nout
      parameter (ncmax = 25, nrmax = 25, nout = 4)
      integer    ncr(0:nrmax,0:ncmax)
      integer    error_code
      character  line(1)*208, temp*20
      logical    askif, there, yesno
      external   revpro, getl01
      external   deleet, gettmp
      external   opener, closer, writer
!
! Initialise ncr
!
      do j = 0, ncmax
         do i = 0, nrmax
            ncr(i,j) = 1
         enddo
      enddo
!
! Connect a temporary file to unit = nout
!
      call gettmp (error_code, temp)
      call opener (ios, nout, temp)
!
! Create the table
!
      write (line(1),'(a)') 'Binomial Coefficients'
      call writer (ios, nlines, nout, line)
      line(1) = ' '
      call writer (ios, nlines, nout, line)
      do i = 0, nrmax
         if (i.gt.1) then
            do j = 1, i - 1
              ncr(i,j) = ncr(i - 1,j - 1) + ncr(i - 1, j)
            enddo
         endif
         write (line(1),'(26i8)') (ncr(i,j), j = 0, i)
         call writer (ios, nlines, nout, line)
         if (i.eq.5 .or. i.eq.10 .or. i.eq.20) then
!
! Intermediate viewing of results
!
            yesno = .true.
            call getl01 ('Review progress so far', yesno)
            if (yesno) call revpro (nout)
         endif
      enddo
!
! Final viewing of results then close down
!
      call getl01 ('View the finished table', yesno)
      if (yesno) call revpro (nout)
      call closer (nout)
!
! Delete the temporary file
!
      askif = .false.
      call deleet (temp, askif, there)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem16: viewer, view a file contents (also copies to the clipboard)
! =====================================================================
!
! subroutine
! ----------
! viewer ... view a supplied file or view a file selected by browsing
!
! arguments
! ---------
!   isend: intent (in) flag as follows:
!          isend = 1: view temp
!          isend = 2: browse, using path and pattern for wildcard
!    temp: intent (in) filename (used only if isend = 1)
!    path: intent (in) search path
! pattern: intent (in) search pattern
!
! Note: opener, closer, and writer are just being used for illustration
!
      program    main
      implicit   none
      integer    i, isend, j
      integer    ios, nlines
      parameter (nlines = 1)
      integer    ncmax, nrmax, nout
      parameter (ncmax = 10, nrmax = 10, nout = 4)
      integer    ncr(0:nrmax,0:ncmax)
      integer    error_code
      character  file*1024, pattern*1024, path*1024, temp*1024
      character  line(1)*208
      character  trim60*60
      logical    askif, there
      external   viewer
      external   deleet, gettmp, putadv, trim60
      external   opener, closer, writer
!
! Initialise ncr
!
      do j = 0, ncmax
         do i = 0, nrmax
            ncr(i,j) = 1
         enddo
      enddo
!
! Connect a temporary file to unit = nout
!
      call gettmp (error_code, temp)
      call opener (ios, nout, temp)
!
! Create the table
!
      write (line(1),'(a)') 'Binomial Coefficients'
      call writer (ios, nlines, nout, line)
      write (line(1),'(a)') ' '
      call writer (ios, nlines, nout, line)
      do i = 0, nrmax
         if (i.gt.1) then
            do j = 1, i - 1
              ncr(i,j) = ncr(i - 1,j - 1) + ncr(i - 1, j)
            enddo
         endif
         write (line(1),'(26i8)') (ncr(i,j), j = 0, i)
         call writer (ios, nlines, nout, line)
      enddo
!
! close the output unit
!
      call closer (nout)
!
! isend = 1: view temp, path and pattern not used
!
      write (line,100) trim60(temp)
      call putadv (line(1))
      isend = 1
      file = ' '
      path = ' '
      pattern = ' '
      call viewer (isend, temp, path, pattern)
!
! isend = 2: use path and pattern to browse, file not used
!
      write (line(1),200)
      call putadv (line(1))
      isend = 2
      path = 'c:\temp'
      pattern = '*.*'
      call viewer (isend, file, path, pattern)
!
! Delete temp
!
      askif = .false.
      call deleet (temp, askif, there)
  100 format ('First view the temporary file',1x,a)
  200 format ('Now view any ASCII text file')
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem17: patch1, and patch2, displaying text
! =============================================
!
! subroutines
! -----------
! patch1 ... display a patch of text (comprehensive interface)
! patch2 ... display a patch of text (simplified interface)
!
! arguments
! ---------
! icolor: intent (in) 1 = blue, 4 = red, 9 = white, o/w grey
! ix, iy: intent (in) position down from top left hand in average characters
!         may be disabled in some versions and is always disabled when ixl or iyl =< 0
! lshade: intent (in) may be disabled in some versions (0 = no shading, 1 = shading)
! numbld: intent (in) 1, 2 = Normal; 3,4 = Italic; 4,5 = Bold; 6,7 = Bold Italic
!         odd number = normal, even number = highlighted
! numtxt: intent (in) text dimension
! text  : intent (in) text array
! fixed : intent (in) .true. = Courier, .false. = Times Roman
!
! Note that a grave accent can be used for tabbing and also that
! patch2 is a cut down version using defaults for icolor, ix, iy,
! lshade, and fixed.
!
!
      program    main
      implicit   none
      integer    i, icolor, ix, iy, lshade, numtxt
      parameter (icolor = 9, ix = 4, iy = 4, lshade = 0)
      integer    numbld(20)
      character  text(20)*80
      logical    fixed
      parameter (fixed = .false.)
      external   patch1, patch2
      do i = 1, 20
         numbld(i) = 0
      enddo
!
! Typical text window
!
      write (text,100)
      numbld(1) = 1
      numbld(10) = 1
      numbld(16) = 1
      numtxt = 19
      call patch1 (icolor, ix, iy, lshade, numbld, numtxt, text, fixed)
      numbld(10) = 0
      numbld(16) = 0
!
! Illustrating grave character for tabbing
!
      write (text,200)
      numtxt = 9
      call patch2 (numbld, numtxt, text)
!
! Illustrating numbld
!
      write (text,300)
      numtxt = 10
      do i = 3, 10
         numbld(i) = i - 3
      enddo
      call patch2 (numbld, numtxt, text)
  100 format ( &
       'Demonstrating the use of subroutine patch1' &
      / &
      /'This subroutine creates a text window which you can control' &
      /'in many ways to display information.' &
      /'For instance, you can control the position and select the' &
      /'font required for each line of text, e.g. to make headings.' &
      /'You can also tab if you wish and you can tab to create' &
      /'simple tables. However table1 is better for this purpose.' &
      / &
      /'About tabbing' &
      / &
      /'A grave character is used to indicate the tabbing positions.' &
      /'The primitive version of patch1 allows one tab per line, but' &
      /'the advanced version allows multiple tabbing.' &
      / &
      /'About the font selection' &
      / &
      /'Setting fixed = .true. forces use of Courier New, otherwise' &
      /'Standard Font is used. Array numbld controls font details.')
  200 format ( &
       'Arguments for subroutine patch1' &
      / &
      /'icolor `: background colour' &
      /'ix, iy `: position (may be disabled)' &
      /'lshade `: shading (may be disabled)' &
      /'numbld `: controls text font' &
      /'numtxt `: number of text lines' &
      /'text   `: text to be displayed' &
      /'fixed  `: selects Courier or Standard Font')
  300 format ( &
       'The effect of numbld(i) = j on line i' &
      / &
      /'j = 0. Normal' &
      /'j = 1. Highlighted' &
      /'j = 2. Italic' &
      /'j = 3. Highlighted italic' &
      /'j = 4. Bold' &
      /'j = 5. Bold highlighted' &
      /'j = 6. Bold italic' &
      /'j = 7. Bold italic highlighted')
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem18: title1, display a title/selection
! ===========================================
!
! subroutine
! ----------
! title1 ... display a title and menu
!
! arguments
! ---------
! icolor: intent (in) 1 = blue, 4 = red, 9 = white, o/w grey
! numbld: intent (in) 1, 2 = Normal; 3,4 = Italic; 4,5 = Bold; 6,7 = Bold Italic
!                    odd number = normal, even number = highlighted
! numdec: intent (inout) decision (must be set on entry = default selection)
! numhdr: intent (in) number of header lines
! numopt: intent (in) number of options
! numpos: intent (in) position of hot-key in option string
! header: intent (in) header text
! option: intent (in) options text
!
! Note that a grave accent can be used for tabbing
!
!
      program    main
      implicit   none
      integer    i, icolor, numdec, numhdr, numopt
      parameter (icolor = 7)
      integer    numbld(20), numpos(20)
      character  header(20)*60, option(20)*20, line*80
      external   title1, putadv
      do i = 1, 20
         numbld(i) = 0
         numpos(i) = 1
         header(i) = ' '
         option(i) = ' '
      enddo
!
! Typical title
!
      write (header,100)
      write (option,200)
      numhdr = 9
      numopt = 5
      do i = 1, numopt
         numpos(i) =  8
      enddo
      numbld(1) = 1
      numdec = 1
      call title1 (icolor, numbld, numdec, numhdr, numopt, numpos, &
                   header, option)
      write (line,300) numdec
      call putadv (line)
  100 format ('Demonstrating subroutine title1' &
      /' ' &
      /'This subroutine creates a window' &
      /'to display the text array header.' &
      /'It then displays the text array' &
      /'option in buttons. You can tab' &
      /'using grave characters, alter text' &
      /'attributes using numbld and set hot' &
      /'keys using numpos.')
  200 format ('Option A' &
      /'Option B' &
      /'Option C' &
      /'Option D' &
      /'Option E')
  300 format ('Option',i2,' was selected')
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem19: answer, display text/yesno
! ====================================
!
! subroutine
! ----------
! answer ... display text and a summary question
!
! Meaning of the arguments
! ========================
! icolor: intent (in) 1 = blue, 4 = red, 9 = white, o/w grey
! numbld: intent (in) 1, 2 = Normal; 3,4 = Italic; 4,5 = Bold; 6,7 = Bold Italic
!                     odd number = normal, even number = highlighted
! numhdr: intent (in) number of header lines
! header: intent (in) header text
! option: intent (in) that is the question
! yesno : intent (inout) logical selected (input value sets the default)
!
! Note that a grave accent can be used for tabbing
!
!
      program    main
      implicit   none
      integer    i, icolor, numhdr
      parameter (icolor = 7)
      integer    numbld(20)
      character  header(20)*80, option*80
      logical    yesno
      external   answer, putadv
      do i = 1, 20
         numbld(i) = 0
         header(i) = ' '
      enddo
!
! Typical answer dialogue
!
      write (header,100)
      option = 'Select yes or no'
      numhdr = 8
      numbld(1) = 1
      yesno = .true.
      call answer (icolor, numbld, numhdr, header, option, yesno)
      if (yesno) then
         call putadv ('You selected Yes')
      else
         call putadv ('You selected No')
      endif
  100 format ('Demonstrating subroutine answer' &
      /' ' &
      /'This subroutine creates a window in which' &
      /'to display the text array header.' &
      /'It then displays the option on a new line,' &
      /'followed by a Y/N?. You can tab using grave' &
      /'characters, and you can set text attributes' &
      /'using integer array numbld.')
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem20: tbox01, display text/list box
! =======================================
!
! subroutine
! ----------
! tbox01 ... tab above, inside and below a list box
!
! Meaning of the arguments
! ========================
! icolor: intent (in) may be disabled
! ix, iy: intent (in) position down from top left hand in average characters
!         may be disabled and always is for ix or iy =< 0
! lshade: intent (in) may be disabled (0 = no shading, 1 = shading)
! numbld: intent (in) 1, 2 = Normal; 3,4 = Italic; 4,5 = Bold; 6,7 = Bold Italic
!                     odd number = normal, even number = highlighted
! numdec: intent (inout) decision (pre-set to default before entry)
! numopt: intent (in) number of options
! numpos: intent (in) not used in this version but must be set
! nstart: intent (in) starting line for list box in text array
! numtxt: intent (in) text dimension
!   text: intent (in) text array
! tabtop: intent (in) tab header (at grave characters)
! tabmid: intent (in) tab list box items (at grave characters)
! tabbot: intent (in) tab trailer (at grave characters)
!
!
      program    main
      implicit   none
      integer    i, icolor, ix, iy, lshade, numdec, numopt, nstart, &
                 numtxt
      parameter (icolor = 9, ix = 4, iy = 4, lshade = 1)
      integer    numbld(20), numpos(20)
      character  line*80, text(20)*80
      logical    tabtop, tabmid, tabbot
      parameter (tabtop = .true., tabmid = .true., tabbot = .true.)
      external   tbox01, putadv
      do i = 1, 20
         numbld(i) = 0
         numpos(i) = 1
      enddo
!
! Typical text/list-box window
!
      write (text,100)
      numbld(1) = 1
      numtxt = 15
      nstart = 9
      numopt = 4
      numdec = 1
      call tbox01 (icolor, ix, iy, lshade, numbld, numdec, numopt, &
                   numpos, nstart, numtxt, text, tabtop, tabmid, &
                   tabbot)
      write (line,200) numdec
      call putadv (line)
  100 format ('Demonstrating subroutine tbox01' &
      /' ' &
      /'This subroutine creates a text window to' &
      /'display information and a list box.' &
      /'You can control the position and select a' &
      /'font for each line of text for headings.' &
      /'You can tab using the grave character.' &
      /'... ' &
      /'Input `Option A `Get more data' &
      /'Graph `Option B `Plot now' &
      /'Table `Option C `Print a table' &
      /'End   `Option D `Cancel' &
      /'Note that currently`x = 4' &
      /'while we have set  `y = 7' &
      /'and used a value of`z = 3')
  200 format ('List box item number',I2,' was selected')
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem21: gkst04, a simple plotting subroutine (plus transformations)
! =====================================================================
!
! subroutine
! ----------
! gkst04 ... plotting with interactive linearising transformations
!
! transformations
! ---------------
! The data can be transformed automatically into various linearising spaces.
! Note that asymp = asymptote must be set for a Hill plot to be possible, which
! only makes sense for the Michaelis-Menten and Hill functions (Example 1).
! y-semilog space linearises the single exponential component (Example 2).
!
! arguments
! ---------
!      l: intent (in) line type, e.g. 0 = none, 1 = solid, 2 = dashed, 3 = dotted, etc
!      m: intent (in) symbol type, e.g. 0 = none,
!          5 = empty circle,    6 = half filled circle,    7 = filled circle,
!          8 = empty triangle,  9 = half filled triangle, 10 = filled triangle,
!         11 = empty square,   12 = half filled square,   13 = filled square,
!         14 = empty diamond,  15 = half filled diamond,  16 = filled diamond, etc.
!      n: intent (in) number of points to be plotted
!  asymp: positive asymptote for Hill plot
! x1..x4: intent (in) x data
! y1..y4: intent (in) y data
! ptitle: intent (in) plot title
! xtitle: intent (in) x legend subtitle
! ytitle: intent (in) y legend subtitle
!   axes: intent (in) .true.
!  gsave: intent (in) .true.
! ===========================================================================
!
!
      program    main
      implicit   none
      integer    i, n
      integer    nmax
      parameter (nmax = 100)
      integer    l1, l2, l3, l4, m1, m2, m3, m4, n1, n2, n3, n4
      double precision x1(nmax), x2(nmax), x3(nmax), x4(nmax)
      double precision y1(nmax), y2(nmax), y3(nmax), y4(nmax)
      double precision asymp, delta
      double precision one, two, ten, xbot, xtop
      parameter (one = 1.0d+00, two = 2.0d+00, ten = 10.0d+00, &
                 xbot = one/ten**2, xtop = ten)
      character  ptitle*22, xtitle*1, ytitle*1
      logical    axes, gsave
      parameter (axes = .true., gsave = .true.)
      external   gkst04, putadv
      intrinsic  exp, dble, log
!
! Define the line types (li), plotting symbols (mi), no. of points (ni)
!
      l1 = 0
      l2 = 1
      l3 = 0
      l4 = 2
      m1 = 6
      m2 = 0
      m3 = 12
      m4 = 0
      n = nmax/10
      n1 = n
      n3 = n
!
! Generate log spaced plotting points and function values
!
      x1(1) = log(xbot)
      x1(n) = log(xtop)
      delta = (x1(n) - x1(1))/(dble(n) - one)
      do i = 2, n - 1
         x1(i) = x1(i - 1) + delta
      enddo
      do i = 1, n
         x1(i) = exp(x1(i))
         x3(i) = x1(i)
         y1(i) = x1(i)/(one + x1(i))
         y3(i) = x3(i)**2/(two + x3(i)**2)
      enddo
      n = nmax
      n2 = n
      n4 = n
      x2(1) = log(xbot)
      x2(n) = log(xtop)
      delta = (x2(n) - x2(1))/(dble(n) - one)
      do i = 2, n - 1
         x2(i) = x2(i - 1) + delta
      enddo
      do i = 1, n
         x2(i) = exp(x2(i))
         x4(i) = x2(i)
         y2(i) = x2(i)/(one + x2(i))
         y4(i) = x4(i)**2/(two + x4(i)**2)
      enddo
!
! Example 1: Plot rational functions and transforms
!
      ptitle = 'Rational Functions'
      xtitle = 'x'
      ytitle = 'y'
      asymp = one
      call gkst04 (l1, l2, l3, l4, &
                   m1, m2, m3, m4, &
                   n1, n2, n3, n4, &
                   asymp, &
                   x1, x2, x3, x4, &
                   y1, y2, y3, y4, &
                   ptitle, xtitle, ytitle, &
                   axes, gsave)
!
! Generate exponential data
!
      do i = 1, n1
         y1(i) = exp(-x1(i))
         y3(i) = (exp(-x3(i)/ten) + y1(i))/two
      enddo
      do i = 1, n2
         y2(i) = exp(-x2(i))
         y4(i) = (exp(-x4(i)/ten) + y2(i))/two
      enddo
!
! Example 2: Plot exponential functions and transforms
!
      call putadv ('Now exponential functions')
      m1 = 12
      m3 = 15
      ptitle = 'Exponential Functions'
      xtitle = 'x'
      ytitle = 'y'
      asymp = - one
      call gkst04 (l1, l2, l3, l4, &
                   m1, m2, m3, m4, &
                   n1, n2, n3, n4, &
                   asymp, &
                   x1, x2, x3, x4, &
                   y1, y2, y3, y4, &
                   ptitle, xtitle, ytitle, &
                   axes, gsave)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem22: surd2s: plotting surfaces, contours and projections
! ==============================================================
!
! subroutine
! ----------
! surd2s .. surfaces, contours, projections and skyscrapers
!
! arguments
! ---------
! The arguments for surd2s$ depend on exactly how the routine is to be called.
! It can be called to plot a supplied model, to read data from a file
! (like surface.tf1, etc), to plot data generated as a vector, or to plot
! data supplied as a matrix at equally spaced coordinates.
! This example demonstrates this last (simplest) case.
!
!  isend: intent (in) flag as follows:
!         isend = 1: supply model, calculate then plot
!         isend = 2: read vector from file, then plot
!         isend = 3: supply vector, then plot
!         isend = 4: supply z(i,j), then plot
!   nmax: intent (in) leading dimension.
!         This MUST be exactly 100 in this particular version.
!     nx: intent (in) number of x divisions =< nmax
!     ny: intent (in) number of y divisions =< nmax
! vector: intent (inout) supplies data when isend = 3, not used when isend = 4
!         vector MUST have dimension at least nmax**2 + 6 in this version
!   xmax: intent (inout) range
!   xmin: intent (inout) range
!   ymax: intent (inout) range
!   xmax: intent (inout) range
!   ymin: intent (inout) range
!      z: intent (inout) data when isend = 4, not used when isend = 3
! unused: intent (inout) logical array used by the contouring routine
! ===========================================================================
!
!
      program    main
      implicit   none
      integer    i, j, nx, ny
      integer    isend, nmax
      parameter (isend = 4, nmax = 100)
      double precision x(nmax), y(nmax)
      double precision xmax, xmin, ymax, ymin
      double precision vector(nmax**2 + 6), z(nmax,nmax)
      double precision delta
      double precision one
      parameter (one = 1.0d+00)
      logical    unused(nmax,nmax)
      external   surd2s
      intrinsic  dble
!
! Define x and y
!
      nx = 20
      ny = 20
      x(1) = - one
      x(nx) = one
      delta = (x(nx) - x(1))/(dble(nx) - one)
      do i = 2, nx - 1
         x(i) = x(i - 1) + delta
      enddo
      y(1) = - one
      y(ny) = one
      delta = (y(ny) - y(1))/(dble(ny) - one)
      do j = 2, ny - 1
         y(j) = y(j - 1) + delta
      enddo
!
! Define z = f(x,y) and the ranges (xmin,xmax), (ymin,ymax)
!
      do j = 1, ny
         do i = 1, nx
            z(i,j) = x(i)**2 - y(j)**2
         enddo
      enddo
      xmax = x(nx)
      xmin = x(1)
      ymax = y(ny)
      ymin = y(1)
!
! Display the surface, contours, projection, skyscraper blocks, etc.
!
      call surd2s (isend, nmax, nx, ny, &
                   vector, xmax, xmin, ymax, ymin, z, &
                   unused)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem23: space0: plot x(t),y(t),z(t) 3D-parametric space curve
! ================================================================
!
! subroutine
! ----------
! space0 .. x(t), y(t), z(t) parametric curve in 3D space
!
! This routine simply plots points joined up by a line, but therafter the
! plot can be edited to change titles, etc.
!
! arguments
! ---------
!     n: intent (in) dimension
!  nmax: intent (in) leading dimension >= n
!     x: intent (in) x(t)
! xtemp: intent (inout) workspace
!     y: intent (in) y(t)
! ytemp: intent (inout) workspace
!     z: intent (in) z(t)
! ===========================================================================
!
!
      program    main
      implicit   none
      integer    i, n
      integer    nmax
      parameter (nmax = 200)
      double precision x(nmax), y(nmax), z(nmax)
      double precision xtemp(nmax), ytemp(nmax)
      double precision t(nmax)
      double precision delta
      double precision pi
      parameter (pi = 3.1415927d+00)
      double precision one, two, zero
      parameter (one = 1.0d+00, two = 2.0d+00, zero = 0.0d+00)
      external   space0
      intrinsic  cos, dble, sin
!
! Define t
!
      n = nmax/2
      t(1) = zero
      t(n) = two*pi
      delta = (t(n) - t(1))/(dble(n) - one)
      do i = 2, n - 1
         t(i) = t(i - 1) + delta
      enddo
!
! Define x, y, z as a helix
!
      x(1) = one
      y(1) = zero
      z(1) = one
      do i = 2, n - 1
         delta = two*t(i)
         x(i) = cos(delta)
         y(i) = sin(delta)
         z(i) = dble(i)
      enddo
      x(n) = x(1)
      y(n) = y(1)
      z(n) = dble(n)
!
! Display the space curve
!
      call space0 (n, nmax, &
                   x, xtemp, y, ytemp, z)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem24: gksvf1: plot a vector field of arrows
! ================================================
!
! subroutine
! ----------
! gksvf1 ... plot a vector flow field of arrows
!
! This routine simply plots arrows to indicate the direction in a vector
! flow field. This version has all the arrows the same modulus since,
! with differential equation portraits it can be difficult to detect
! singularities if the modulus is varied to indicate size.
!
! arguments
! ---------
! This example is taken from a Simfit routine which draws a vector field
! for an autonomous system of differential equations. So the code is over
! complicated as it stands. The original has extra code for colouring
! differing quadrants, varying ranges, changing arrow size and type,
! and so on, and it will be obvious where this has been deleted.
!
! iarrow: intent (in) arrow type, use 1
! ikolor: intent (in) arrow colour
! jarrow: intent (in) grid size
! lcolor: intent (in) background colour
!   ngks: intent (in) gks transformation number, use 0
!   head: intent (in) size of arrow head
!     x1: intent (in) head position
!     x2: intent (in) tail position
!     y1: intent (in) head position
!     y2: intent (in) tail position
! ptitle: intent (in) plot title
! xtitle: intent (in) x legend
! ytitle: intent (in) y legend
!   axes: intent (in) use .true.
!  gsave: intent (in) use .true.
! ===========================================================================
!
!
      PROGRAM    MAIN
      IMPLICIT   NONE
      INTEGER    NEQN, NMAX, NMAX2, NPMAX
      PARAMETER (NEQN = 2, NMAX = 20, NMAX2 = NMAX**2, NPMAX = 4)
      INTEGER    IARROW(NMAX2), IKOLOR(NMAX2)
      INTEGER    LCOLOR, NGRID, NGKS
      PARAMETER (LCOLOR = 15, NGKS = 0)
      INTEGER    I, J, JARROW, K
      DOUBLE PRECISION P(NPMAX)
      DOUBLE PRECISION F(NEQN), Y(NEQN), THETA
      DOUBLE PRECISION HEAD(NMAX2), X1(NMAX2), X2(NMAX2), Y1(NMAX2), &
                       Y2(NMAX2)
      DOUBLE PRECISION FACTOR, XDELTA, XSTART, XSTOP, YDELTA, &
                       YSTART, YSTOP
      DOUBLE PRECISION ZERO, ONE, TWO, HSIZE, RTOL
      PARAMETER (ZERO = 0.0D+00, ONE = 1.0D+00, &
                 TWO = 2.0D+00, HSIZE = 0.005D+00, RTOL = 1.0D-300)
      CHARACTER  PTITLE*15, XTITLE*4, YTITLE*4
      PARAMETER (PTITLE = 'Phase Portrait', &
                 XTITLE = 'y(2)', &
                 YTITLE = 'y(1)')
      LOGICAL    AXES, GSAVE
      PARAMETER (AXES = .TRUE., GSAVE = .TRUE.)
      EXTERNAL   GKSVF1
      INTRINSIC  ABS, DBLE, ATAN, SIN, COS
      DATA       NGRID / 20 /
      DATA       FACTOR / ONE /
      DATA       P / ONE, ONE, ONE, ONE /
      DATA       XSTART, XSTOP / ZERO, TWO /
      DATA       YSTART, YSTOP / ZERO, TWO /
!
! Initialise grid size and arrow colours
!
      JARROW = NGRID*NGRID
      DO I = 1, NMAX2
         IKOLOR(I) = 0
      ENDDO
!
! Initialise the arrow types (changed at singularities) and head sizes
!
      DO I = 1, JARROW
         IARROW(I) = 1
         HEAD(I) = FACTOR*HSIZE
      ENDDO
!
! Define the mesh of grid points Y(1) and Y(2)
!
      XDELTA = (XSTOP - XSTART)/(DBLE(NGRID) - ONE)
      YDELTA = (YSTOP - YSTART)/(DBLE(NGRID) - ONE)
      K = 0
      DO I = 1, NGRID
         IF (I.EQ.1) THEN
            Y(1) = YSTART
         ELSEIF (I.EQ.NMAX) THEN
            Y(1) = YSTOP
         ELSE
            Y(1) = Y(1) + YDELTA
         ENDIF
         DO J = 1, NGRID
            IF (J.EQ.1) THEN
               Y(2) = XSTART
            ELSEIF (J.EQ.NMAX) THEN
               Y(2) = XSTOP
            ELSE
               Y(2) = Y(2) + XDELTA
            ENDIF
!
! Call the differential equation routines to evaluate the RHS of dy(i)/dx = F(i)
!
            f(1) = p(1)*y(1) - p(2)*y(1)*y(2)
            f(2) = p(3)*y(2) - p(4)*y(1)*y(2)
!
! Increment K then assign angles and arrows ... First the arrow bases
!
            K = K + 1
            X2(K) = Y(2)
            Y2(K) = Y(1)
!
! Now the arrow heads depending on F(i)
!
            IF (F(1).GT.RTOL .AND. F(2).GT.RTOL) THEN
!
! 1st quadrant
!
               THETA = ATAN(F(1)/F(2))
               X1(K) = X2(K) + XDELTA*COS(THETA)/TWO
               Y1(K) = Y2(K) + YDELTA*SIN(THETA)/TWO
            ELSEIF (F(1).GT.RTOL .AND. F(2).LT. - RTOL) THEN
!
! 2nd quadrant
!
               THETA = ATAN( - F(1)/F(2))
               X1(K) = X2(K) - XDELTA*COS(THETA)/TWO
               Y1(K) = Y2(K) + YDELTA*SIN(THETA)/TWO
            ELSEIF (F(1).LT. - RTOL .AND. F(2).LT. - RTOL) THEN
!
! 3rd quadrant
!
               THETA = ATAN(F(1)/F(2))
               X1(K) = X2(K) - XDELTA*COS(THETA)/TWO
               Y1(K) = Y2(K) - YDELTA*SIN(THETA)/TWO
            ELSEIF (F(1).LT. - RTOL .AND. F(2).GT.RTOL) THEN
!
! 4th quadrant
!
               THETA = ATAN( - F(1)/F(2))
               X1(K) = X2(K) + XDELTA*COS(THETA)/TWO
               Y1(K) = Y2(K) - YDELTA*SIN(THETA)/TWO
            ELSEIF (ABS(F(1)).LE.RTOL .AND. ABS(F(2)).LE.RTOL) THEN
!
! The singular case when F(1) = F(2) = 0 so set X1 = X2, Y1 = Y2
!
               X1(K) = X2(K)
               Y1(K) = Y2(K)
            ELSEIF (ABS(F(2)).LE.RTOL) THEN
!
! Vertical
!
               X1(K) = X2(K)
               IF (F(1).GT.ZERO) THEN
                  Y1(K) = Y2(K) + YDELTA/TWO
               ELSE
                  Y1(K) = Y2(K) - YDELTA/TWO
               ENDIF
            ELSE
!
! Horizontal
!
               Y1(K) = Y2(K)
               IF (F(2).GT.ZERO) THEN
                  X1(K) = X2(K) + XDELTA/TWO
               ELSE
                  X1(K) = X2(K) - XDELTA/TWO
               ENDIF
            ENDIF
         ENDDO
      ENDDO
!
! Now call GKSVF1 to draw the vector field
!
      CALL GKSVF1 (IARROW, IKOLOR, JARROW, LCOLOR, NGKS, &
                   HEAD, X1, X2, Y1, Y2, &
                   PTITLE, XTITLE, YTITLE, &
                   AXES, GSAVE)
      END
!
!
Back to Menu or Programs: Brief description
!
! simdem25: gkseb4, a simple subroutine to plot error bars
! ========================================================
!
! subroutine
! ----------
! gkseb4 ... up to two sets of data/error bars plus two best fit curves
!
! arguments
! ---------
! The subroutine is designed to fit up to two sets of data with error bars
! and up to two best fit curves. Usually x1, y1, yh1, yl1 would be data for one
! components and x2, y2 would be the best-fit curve, etc., but actually all four
! components are independent.
!      l: intent (in) line type, e.g. 0 = none, 1 = solid, 2 = dashed, 3 = dotted, etc
!      m: intent (in) symbol type, e.g. 0 = none,
!          5 = empty circle,    6 = half filled circle,    7 = filled circle,
!          8 = empty triangle,  9 = half filled triangle, 10 = filled triangle,
!         11 = empty square,   12 = half filled square,   13 = filled square,
!         14 = empty diamond,  15 = half filled diamond,  16 = filled diamond, etc.
!      n: intent (in) number of points to be plotted
!    yh1: intent (in) upper error bar for y1
!    yl1: intent (in) lower error bar for y1
!    yh3: intent (in) upper error bar for y3
!    yl3: intent (in) lower error bar for y3
! ptitle: intent (in) plot title
! xtitle: intent (in) x legend subtitle
! ytitle: intent (in) y legend subtitle
!   axes: intent (in) .true.
!  gsave: intent (in) .true.
! ===========================================================================
!
!
      program    main
      implicit   none
      integer    i, n
      integer    nmax
      parameter (nmax = 100)
      integer    l1, l2, l3, l4, m1, m2, m3, m4, n1, n2, n3, n4
      double precision x1(nmax), x2(nmax), x3(nmax), x4(nmax)
      double precision y1(nmax), y2(nmax), y3(nmax), y4(nmax)
      double precision yh1(nmax), yh3(nmax), yl1(nmax), yl3(nmax)
      double precision delta
      double precision one, two, ten, factor, xbot, xtop
      parameter (one = 1.0d+00, two = 2.0d+00, ten = 10.0d+00, &
                 factor = 0.675d+00, xbot = one/ten**2, xtop = ten)
      character  ptitle*12, xtitle*1, ytitle*1
      logical    axes, gsave
      parameter (axes = .true., gsave = .true.)
      external   gkseb4
      intrinsic  dble
!
! Define the line types (li), plotting symbols (mi), no. of points (ni)
!
      l1 = 0
      l2 = 1
      l3 = 0
      l4 = 2
      m1 = 5
      m2 = 0
      m3 = 8
      m4 = 0
      n = nmax/10
      n1 = n
      n3 = n
!
! Generate equally spaced plotting points and function values
!
      x1(1) = xbot
      x1(n) = xtop
      delta = (x1(n) - x1(1))/(dble(n) - one)
      do i = 2, n - 1
         x1(i) = x1(i - 1) + delta
      enddo
      do i = 1, n
         x3(i) = x1(i)
         y1(i) = x1(i)/(one + x1(i))
         y3(i) = factor*x3(i)**2/(two + x3(i)**2)
         yh1(i) = y1(i) + y1(i)/ten
         yh3(i) = y3(i) + y3(i)/ten
         yl1(i) = y1(i) - y1(i)/ten
         yl3(i) = y3(i) - y3(i)/ten
      enddo
      n = nmax
      n2 = n
      n4 = n
      x2(1) = xbot
      x2(n) = xtop
      delta = (x2(n) - x2(1))/(dble(n) - one)
      do i = 2, n - 1
         x2(i) = x2(i - 1) + delta
      enddo
      do i = 1, n
         x4(i) = x2(i)
         y2(i) = x2(i)/(one + x2(i))
         y4(i) = factor*x4(i)**2/(two + x4(i)**2)
      enddo
!
! Plot rational functions and error bars
!
      ptitle = 'Error Bars'
      xtitle = 'x'
      ytitle = 'y'
      call gkseb4 (l1, l2, l3, l4, &
                   m1, m2, m3, m4, &
                   n1, n2, n3, n4, &
                   x1, x2, x3, x4, &
                   yh1, yh3, yl1, yl3, y1, y2, y3, y4, &
                   ptitle, xtitle, ytitle, &
                   axes, gsave)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem26: dsplay, a simple matrix viewer (also writes to file)
! ==============================================================
!
! subroutine
! ----------
! dsplay ... display a matrix but also write to results file if required
!
! arguments
! ---------
! dsplay is similar to viewit = simdem14 but it can also write
! the array out to a pre-connected file on unit nout
!  ncmax: intent (in) column dimension >= ncol
!   ncol: intent (in) actual number of columns
!  nrmax: intent (in) row dimension >= nrow
!   nrow: intent (in) actual number of rows
!  ntype: intent (in) flag as follows:
!                     ntype = 1: i format (integers)
!                     ntype = 2: f format (floats)
!                     ntype = 3: e format (large/small)
! fileit: intent (in) if .true. then write to file opened on unit nout
!                     where unit is opened in w_menus.dll and all input
!                     and output, etc. uses opener, closer, and writer
!                     (unless the calling program and w_menus.dll use the
!                      same run-time system, i.e. same compiler).
!
      program    main
      implicit   none
      integer    i, j
      integer    ncmax, ncol, nout, nrmax, nrow, ntype
      parameter (nrmax = 20, nout = 4, ncmax = 10)
      double precision a(nrmax,ncmax), dj
      double precision ten
      parameter (ten = 10.0d+00)
      character  title*20
      logical    fileit
      parameter (fileit = .false.)
      external   dsplay
      intrinsic  dble
!
! Initialise a
!
      do j = 1, ncmax
         dj = dble(j)
         do i = 1, nrmax
            a(i,j) = ten*dble(i) + dj
         enddo
      enddo
!
! i format
!
      ncol = 9
      nrow = 9
      title = 'i format'
      ntype = 1
      call dsplay (ncmax, ncol, nout, nrmax, nrow, ntype, a, &
                   title, fileit)
!
! f format
!
      ncol = ncol - 1
      nrow = nrow - 1
      do j = 1, ncol
         do i = 1, nrow
            a(i,j) = a(i,j)/ten
         enddo
      enddo
      title = 'f format'
      ntype = 2
      call dsplay (ncmax, ncol, nout, nrmax, nrow, ntype, a, &
                   title, fileit)
!
! e format
!
      ncol = ncol - 1
      nrow = nrow - 1
      do j = 1, ncol
         do i = 1, nrow
            a(i,j) = a(i,j)/ten
         enddo
      enddo
      title = 'e format'
      ntype = 3
      call dsplay (ncmax, ncol, nout, nrmax, nrow, ntype, a, &
                   title, fileit)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem27: using table2 to output a simple coloured table in a window (text)
! ===========================================================================
!
! subroutine
! ----------
! table2 ... use colours for a individual letters in a table
!
! arguments
! ---------
! icolor: intent (in) colour as follows:
!         icolor(i) = 0(black), 1(blue), 4(red), 14(yellow), 15(white), etc. (VGA type)
!   line: intent (in) character string as follows:
!         line = 'OPEN' then open a window,
!         line = 'CLOSE' close the window, otherwise line is displayed in the window.
!
! If the user closes the window during output, the calculation will not be
! interrupted but there will be no further output. The subroutine will scroll
! through the intermediate or total output.
! The only difference between this and table1 = simdem08 is that the colour
! of any individual letters can be set using the array icolor. This makes table2
! slower and more complicated to use but it can be very useful to set the colour
! of individual letters.
!
      program    main
      implicit   none
      integer    i, icmax, imax, j, k, l
      parameter (icmax = 30, imax = 70)
      integer    icolor(icmax)
      character  line*(icmax)
      external   table2
!
! Initialise icolor(i) = 0 (black)
!
      do i = 1, icmax
         icolor(i) = 0
      enddo
      do l = 1, 2
!
! White background first time, then change to grey background
!
         if (l.eq.1) then
            icolor(1) = 15
         else
            icolor(1) = 7
         endif
!
! Set line = 'OPEN' to open the window and set the background colour = icolor(1)
!
         call table2 (icolor, 'OPEN')
         icolor(1) = 0
!
! Output the text strings
!
         j = 0
         do i = 1, imax
            if (i.eq.11) then
               if (l.eq.1) then
                  j = 1
               else
                  j = 14
               endif
               do k = 9, 14
                  icolor(k) = j
               enddo
            elseif (i.eq.21) then
               j = 4
               do k = 9, 14
                  icolor(k) = j
               enddo
            elseif (i.eq.31) then
               j = 0
               do k = 9, 14
                  icolor(k) = j
               enddo
            endif
            write (line,100) j
            call table2 (icolor, line)
         enddo
         call table2 (icolor,'CLOSE')
      enddo
  100 format ('This is colour number',I4)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem28: creating background windows
! =====================================
!
! subroutine
! ----------
! window ... plant code inside a background window
!
! arguments
! ---------
!  isend: intent (in) number of the independent window (if several can be opened)
!          Note: currently window only opens 1 background window and
!                isend is not referenced.
!  title: intent (in) title of window
! action: intent (in) if .true. then open, o/w close the window
!
      program    main
      implicit   none
      integer    i
      integer    isend
      parameter (isend = 1)
      double precision x
      character  line*100, title*12
      parameter (title = 'simdem28.for')
      logical    action
      external   getr01, putadv, window, puttxt
!
! open background window (number = isend)
!
      action = .true.
      call window (isend, title, action)
!
! do something
!
      line = 'This shows how to plant code inside a background window'
      call puttxt (line)
      do i = 1, 2
         call getr01 (x, 'An arbitrary real number')
         write (line,100) i, x
         call putadv (line)
      enddo
!
! close background window number isend
!
      action = .false.
      call window (isend, title, action)
  100 format ('Value number',i2,' was =',1p,e11.3)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem29: linein, retrieve a line of text
! =========================================
!
! subroutine
! ----------
! linein ... plant a text edit box inside a window
!
! arguments
! ---------
! icolor: intent (in) 1 = blue, 4 = red, 9 = white, o/w grey
! ix, iy: intent (in) position down from top left hand in average characters
!                     this may be disabled and will always be so when ix or iy =< 0
!  nchar: intent (in) number of extra border characters (set this = 0)
! numbld: intent (in) font type as follows:
!                     1, 2 = Normal; 3,4 = Italic; 4,5 = Bold; 6,7 = Bold Italic
!                     odd number = normal, even number = highlighted
! numtxt: intent (in) text dimension
!   line: intent (inout) text string enetered by the user
!   text: intent (in) text array
!  fixed: intent (in) .true. = Courier, .false. = Times Roman
!
! Note that a grave accent can be used for tabbing
!
!
      program    main
      implicit   none
      integer    i, icolor, ix, iy, nchar, numtxt
      parameter (icolor = 7, ix = 4, iy = 4, nchar = 0, numtxt = 17)
      integer    numbld(numtxt)
      character  line*60, text(numtxt)*80
      logical    fixed
      parameter (fixed = .false.)
      external   linein, putadv
      do i = 1, numtxt
         numbld(i) = 0
      enddo
!
! Typical text window using line and text
!
      write (text,100)
      numbld(1) = 1
      numbld(10) = 1
      numbld(14) = 1
      line = ' '
      call linein (icolor, ix, iy, nchar, numbld, numtxt, &
                   line, text, fixed)
      if (line.eq.' ') line = 'nothing'
      call putadv ('You wrote '//line)
  100 format ( &
       'Demonstrating the use of subroutine linein' &
      / &
      /'This subroutine creates a text window which you can control' &
      /'in many ways to display information, as with patch1.' &
      /'For instance, you can control the position and select the' &
      /'font required for each line of text, e.g. to make headings.' &
      /'The routine opens a little edit box where the user can type' &
      /'in character strings.' &
      / &
      /'About tabbing' &
      / &
      /'A grave character is used to indicate the tabbing positions.' &
      / &
      /'About font selection' &
      / &
      /'Setting fixed = .true. forces use of Courier New, otherwise' &
      /'Standard Font is used. Array numbld controls font details.')
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem30: title page and tutorial
! =================================
!
! subroutines
! -----------
! titles ... Display a title with menu
! tutor1 ... Display a tutorial
!
! arguments
! ---------
! titles: similar to patch1 and linein as follows:
!         ICOLOR: intent (in) colour
!         NUMBLD: intent (in) font type
!         NUMDEC: intent (inout) default on entry and retirns the choice
!         NUMHDR: intent (in) dimension of header
!         NUMOPT: intent (in) number of options
!         NUMPOS: intent (in) hot key positions
!         HEADER: intent (in) text before menu
!         OPTION: intent (in) the menu
!
! tutor1: similar to titles except that next and updown control the
!         allowed movement forwards and backwards through the tutorial pages.
!         ICOLOR: intent (in) colour
!         NUMBLD: intent (in) font type
!         NUMHDR: intent (in) header dimensions
!         HEADER: intent (in) header
!          FRAME: intent (in) if .true. uses Courier New
!           NEXT: intent (in) if .true. move to next item (see below)
!         UPDOWN: intent (in) if .true. allow up/down scrolling (see below)
!                 The effect of next and updown depends on the version. Usually
!                 next = updown = .true. causes the buffer to fill and either
!                 of them .false. causes display. probably best to keep updown
!                 fixed and control the tutorial using next as in the example.
!
      program    main
      implicit   none
      integer    nmax
      parameter (nmax = 20)
      logical    abort, first
      parameter (first = .true.)
      external   advise
      call advise (nmax, abort, first)
      end
!
!
      SUBROUTINE ADVISE (NMAX, ABORT, FIRST)
!
! Advise user
!
      IMPLICIT   NONE
      INTEGER    NMAX
      INTEGER    ISEND
      INTEGER    ICOLOR, NUMHDR, NUMOPT
      PARAMETER (ICOLOR = 3, NUMHDR = 8, NUMOPT = 3)
      INTEGER    NUMBLD(NUMHDR), NUMPOS(NUMOPT)
      INTEGER    JCOLOR, JMAX
      PARAMETER (JCOLOR = 9, JMAX = 20)
      INTEGER    JUMBLD(JMAX), NUMTXT
      CHARACTER  HEADER(NUMHDR)*63, OPTION(NUMOPT)*15
      CHARACTER  TEXT(20)*80, LINE*80
      LOGICAL    ABORT, FIRST
      LOGICAL    FRAME, NEXT, REPEET
      LOGICAL    UPDOWN
      PARAMETER (UPDOWN = .TRUE.)
      EXTERNAL   TITLES, TUTOR1, PUTADV
      DATA       JUMBLD / JMAX*0 /
      DATA       NUMBLD / 0, 0, 0, 0, 0, 0, 0, 0 /
      DATA       NUMPOS / 1, 1, 1 /
      DATA       OPTION / &
      'Provide details', &
      'Run the program', &
      'Quit  ...  Exit' /
      ABORT = .FALSE.
      REPEET = .TRUE.
      DO WHILE (REPEET)
         IF (FIRST) THEN
            WRITE (HEADER,100) NMAX
            ISEND = 1
            CALL TITLES (ICOLOR, NUMBLD, ISEND, NUMHDR, NUMOPT, NUMPOS, &
                         HEADER, OPTION)
         ELSE
            ISEND = 1
         ENDIF
         IF (ISEND.EQ.1) THEN
            WRITE (TEXT,200)
            NUMTXT = 20
            FRAME = .FALSE.
            JUMBLD(1) = 1
            NEXT = .TRUE.
            CALL TUTOR1 (JCOLOR, JUMBLD, NUMTXT, TEXT, FRAME, NEXT, &
                         UPDOWN)
            WRITE (TEXT,300)
            CALL TUTOR1 (JCOLOR, JUMBLD, NUMTXT, TEXT, FRAME, NEXT, &
                         UPDOWN)
            WRITE (TEXT,400)
            CALL TUTOR1 (JCOLOR, JUMBLD, NUMTXT, TEXT, FRAME, NEXT, &
                         UPDOWN)
            WRITE (TEXT,500)
            NEXT = .FALSE.
            CALL TUTOR1 (JCOLOR, JUMBLD, NUMTXT, TEXT, FRAME, NEXT, &
                         UPDOWN)
            IF (FIRST) THEN
               REPEET = .TRUE.
            ELSE
               ABORT = .FALSE.
               REPEET = .FALSE.
            ENDIF
         ELSEIF (ISEND.EQ.2) THEN
            WRITE (LINE,600)
            CALL PUTADV (LINE)
         ELSEIF (ISEND.EQ.3) THEN
            ABORT = .TRUE.
            REPEET = .FALSE.
         ENDIF
      ENDDO
  100 FORMAT ( &
       'Package     `SIMFIT' &
      /'Program     `ADDERR' &
      /'Action      `Add random error to simulate experimental data.' &
      /'            `Input: file with exact data from program MAKDAT' &
      /'            `Output: file with data after adding random errors' &
      /'Version     `5.2, array dimension',I5 &
      /'Graphics    `CWP/Hershey' &
      /'Author      `W. G. Bardsley, University of Manchester, U.K.')
  200 FORMAT ('Summary'/ &
      /,'Data files are required as follows:' &
      /' x, y(x), s                 `... one variable (usual) case' &
      /'x1, x2, y(x1,x2), s         `... two variable case' &
      /'x1, x2, x3, y(x1,x2,x3), s  `... three variable case' &
      /'You can then use this program in several ways to perturb the' &
      /'y-values by adding random errors. Finally an output file can' &
      /'be produced with old x-values, new y-values and s-values set' &
      /'equal or approximately equal to the standard error of y. The' &
      /'output file is then ready for curve fitting.' &
      /'The input file must have exact values for y as a function of' &
      /'x and arbitrary s,e.g. s = 1. Such files can be generated by' &
      /'program MAKDAT or editors MAKFIL(1 var.) or MAKMAT(2/3 var.)' &
      /'and they are not altered by program ADDERR. The output files' &
      /'contain the simulated experimental data.'/ &
      /'The statistical theory of experimental error assumes that' &
      /5X,'y-perturbed = y-exact + random error' &
      /'and you have several choices for random errors.')
  300 FORMAT ('Variance models'/ &
      /'Three commonly encountered models for s^2 (i.e. V(y) the' &
      /'variance of y) are given special prominence.'/ &
      /'a) `Constant variance' &
      /'   `V(y) = sigma^2' &
      /'b) `Constant relative error' &
      /'   `V(y) = (fraction|y|)^2' &
      /'c) `Mixed power law' &
      /'   `V(y) = sigma^2 + (coefficient|y|)^power'/ &
      /'To simulate a), b) or c) normally distributed numbers with' &
      /'zero mean and appropriate variance are added to y-exact to' &
      /'give y-perturbed then s-values can be set in several ways.' &
      /'Note that variance types a) and b) are really special cases' &
      /'of c) so the distinction is only for convenience.' &
      /'This program also allows you to generate random errors from' &
      /'a variety of distributions so you can explore the effect of' &
      /'uniform, exponential, normal or Cauchy random errors.')
  400 FORMAT ('Options for s (the standard deviation of y)'/ &
      /'Weighted non linear least-squares regression analysis  needs' &
      /'s to be the exact standard deviation of the y-value but this' &
      /'can never be obtained in real life.'/ &
      /'Three situations can occur.'/ &
      /'1. `You assume a model for V(y) then substitute measured,i.e.' &
      /'   `perturbed or best-fit y in a formula for V(y). A special' &
      /'   `case would be assuming constant variance, i.e. all s = 1.' &
      /'2. `You use replicates to estimate s at each fixed x and then' &
      /'   `set s = sample estimates of standard deviations.' &
      /'3. `You perform experiments to estimate s then substitute for' &
      /'   `s = F(y), s = G(x) or smoothing, e.g. by program EDITFL.'/ &
      /'This program allows you to set exact values for s or to use' &
      /'s-values that would be typical of 1, 2 or 3.' &
      /'You can assume single measurements or replicates and you can' &
      /'generate outliers and re-calculate s if required.')
  500 FORMAT ('Outliers'/ &
      /'Outliers are y-values with errors that are improbably large' &
      /'or are not from the same distribution as the other errors.' &
      /'To avoid generating such errors in the previous options the' &
      /'normal distribution is truncated at 3 standard deviations.'/ &
      /'There are several ways you can add arbitrary errors to data' &
      /'to simulate outliers.  You can use a Cauchy distribution or' &
      /'add outliers directly to the original or perturbed data.The' &
      /'s-values can be left alone or with replicates re-calculated' &
      /'from the perturbed data set with outliers.'/ &
      /'Positions and signs of outliers can be selected randomly or' &
      /'by the user and the magnitude can be fixed in several ways.' &
      /'The outlier can be a fixed % of the exact |y|-value, it can' &
      /'be a set amount, you can input individual errors etc.'/ &
      /'The effect of outliers can be very dramatic especially when' &
      /'they occur at critical positions in small data sets.')
  600 FORMAT ('Not available ... get SIMFIT')
      END
!
!
Back to Menu or Programs: Brief description
!
! simdem31: calling geti0n to return n integers
! =============================================
!
! subroutine
! ----------
! geti0n ... input n integers then return n edited values
!
! arguments
! ---------
!      n: intent (in) number of integers required >= 1
! nvalue: intent (inout) the n integers
!   text: intent (in) the associated text array
!
      program    main
      implicit   none
      integer    nmax
      parameter (nmax = 20)
      integer    i, icolor, n, nvalue(nmax)
      character  line*100, text(nmax)*100
      external   geti0n, table1
!
! initialise n and the n values before calling geti00n
!
      n = nmax/4
      do i = 1, n
         nvalue(i) = i
         write (text(i),100) 'Before call to GETI0N', i, nvalue(i)
      enddo
!
! retrieve the n new values then display the new values
!
      call geti0n (n, nvalue, text)
      icolor = 15
      call table1 (icolor, 'open')
      icolor = 0
      do i = 1, n
         write (line,100) 'After call to GETI0N', i, nvalue(i)
         call table1 (icolor, line)
      enddo
      call table1 (icolor, 'close')
  100 format (a,', integer number',i3,' is',i10)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem32: calling getr0n to return n reals (doubles)
! ====================================================
! For details read simdem.chm or simdem.html
!
! subroutine
! ----------
! getr0n ... input n double precision variables then return n edited values
!
! arguments
! ---------
!      n: intent (in) number of double precison variables, n >= 1
! xvalue: intent (inout) the n double precision variables
!   text: intent (in) the n associated text strings
!
! character (len = 25) function form25 takes an intent (in) double precision
! value and returns the value written to a left justified string with up to
! 15 significant figures, but with trailing zeros removed.
!
      program    main
      implicit   none
      integer    nmax
      parameter (nmax = 20)
      integer    i, icolor, n
      double precision xvalue(nmax)
      character  line*100, text(nmax)*100
      character  form25*25, x25*25
      external   getr0n, table1, form25
      intrinsic  dble
      n = nmax/4
      do i = 1, n
         xvalue(i) = dble(i)
         x25 = form25(xvalue(i))
         write (text(i),100) 'Before call to GETR0N', i, x25
      enddo
      call getr0n (n, xvalue, text)
      icolor = 15
      call table1 (icolor, 'open')
      icolor = 0
      do i = 1, n
         x25 = form25(xvalue(i))
         write (line,100) 'After call to GETR0N', i, x25
         call table1 (icolor, line)
      enddo
      call table1 (icolor, 'close')
  100 format (a,', x-value(',i2,') = ',a)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem33: calling gets0n to return n text strings
! =================================================
!
! subroutine
! ----------
! gets0n ... input n text strings then return n edited values
!
! arguments
! ---------
!      n: intent (in) number of text strings >= 1
! svalue: intent (inout) the n text strings
!   text: intent (in) the associated text descriptions
!
      program    main
      implicit   none
      integer    nmax
      parameter (nmax = 20)
      integer    i, icolor, n
      character  svalue(nmax)*20
      character  line*100, text(nmax)*100
      external   gets0n, table1
      n = nmax/5
      do i = 1, n
         svalue(i) = 'unassigned'
         write (text(i),100) 'Before call to GETS0N', i, svalue(i)
      enddo
      call gets0n (n, svalue, text)
      icolor = 15
      call table1 (icolor, 'open')
      icolor = 0
      do i = 1, n
         write (line,100) 'After call to GETS0N', i, svalue(i)
         call table1 (icolor, line)
      enddo
      call table1 (icolor, 'close')
  100 format (a,', s-value',i3,' is',2x,a)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem34: calling getl0n to return n logicals
! =============================================
!
! subroutine
! ----------
! getlon ... input n logical variables then return n edited values
!
! arguments
! ---------
!      n: intent (in) number of logicals >= 1
!   text: intent (in) the n associated text strings
! lvalue: intent (inout) the n logical variables
!
      program    main
      implicit   none
      integer    nmax
      parameter (nmax = 20)
      integer    i, icolor, n
      character  line*100, result*5, text(nmax)*80
      logical    lvalue(nmax)
      external   getl0n, table1
      n = nmax/2
      result = 'false'
      do i = 1, n
         lvalue(i) = .false.
         write (text(i),100) 'Before call to GETL0N', i, result
      enddo
      call getl0n (n, text, lvalue)
      icolor = 15
      call table1 (icolor, 'open')
      icolor = 0
      do i = 1, n
         if (lvalue(i)) then
            result = 'true'
            icolor = 4
         else
            icolor = 0
            result = 'false'
         endif
         write (line,100) 'After call to GETL0N', i, result
         call table1 (icolor, line)
      enddo
      call table1 (icolor, 'close')
  100 format (a,', logical number',i3,' is',2x,a)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem35: calling get00n to return n variables
! ==============================================
!
! subroutine
! ----------
! get00n ... input 3*n variables of any type then return numopt edited values
!
! n variables of type integer, double precision, character and logical = integer
! are supplied, then a control is set up with numopt options starting
! at position (i.e. line) numsta in a character array. For each line in the
! options, numpos is set to indicate the variable to be edited. Only the
! variables of type indicated by numpos are edited. In other words, a
! total of 3*n variables are supplied of which only numopt are returned
! edited. Note the grave accents for tabbing in the header text.
!
! arguments
! ---------
!  icolor: intent (in) colour scheme       (may be disabled in some versions)
!     ixl: intent (in) window x-coordinate (may be disabled in some versions)
!     iyl: intent (in) window y-coordinate (may be disabled in some versions)
!  kvalue: intent (inout) integers or 0/1 for logical variables
!  lshade: intent (in) 1 to add a shadow   (may be disabled in some versions)
!  numbld: intent (in) font and colour scheme
!  numopt: intent (in) number of options >= 1
!  numpos: intent (in) variable type as follows:
!          numpos = 1: integers
!          numpos = 2: doubles
!          numpos = 3: strings
!          numpos = 4: logicals (i.e. corresponding kvalue as 0/1)
!  numsta: intent (in) start position for options
!  xvalue: intent (inout) double precision variables
!  svalue: intent (inout) character strings
!    text: intent (in) description of functions and associated items
! tab_bot: intent (in) .false. for Standard Font, .true. for Courier New
! tab_mid: intent (in) should be set as a .false. tabbing parameter
! tab_top: intent (in) .true. to tab at grave accents in header
!
      program    main
      implicit   none
      integer    nmax
      parameter (nmax = 20)
      integer    icolor, ixl, iyl, lshade, numopt, numsta, &
                 numtxt
      parameter (icolor = 7, ixl = 4, iyl = 4, lshade = 0)
      integer    kvalue(nmax), numbld(nmax), numpos(nmax)
      integer    i, j, k
      double precision xvalue(nmax)
      character (len = 40) svalue(nmax)
      character (len = 80) text(nmax)
      logical    tab_bot, tab_mid, tab_top
      parameter (tab_bot = .false., tab_mid = .false., tab_top = .true.)
      external   get00n, table1
      numtxt = 18
      do i = 1, numtxt
         numbld(i) = 0
      enddo
      numbld(1) = 4                                                      ! example of how to emphasize a title
      numbld(3) = 1                                                      ! example of how to colour a line
      numbld(numtxt) = 4
      numopt = 8
      numsta = 9
      do j = 1, numopt
         kvalue(j) = 0
         xvalue(j) = 0.0d+00
         svalue(j) = 'unassigned character string'
      enddo
!
! edit integers 1 and 2, double precision variables 3 and 4, character
! strings 5 and 6, and logical variables 7 and 8, i.e. integers kvalue
! 7 and 8 returned in the usual way as as 0 = .false. or 1 = .true.
!
      numpos(1) = 1
      numpos(2) = 1
      numpos(3) = 2
      numpos(4) = 2
      numpos(5) = 3
      numpos(6) = 3
      numpos(7) = 4
      numpos(8) = 4
      write (text,100)
      call get00n (icolor, ixl, iyl, kvalue, lshade, &
                   numbld, numopt, numpos, numsta, numtxt, &
                   xvalue, &
                   svalue, text, &
                   tab_bot, tab_mid, tab_top)
      text(1) = &
      'Results from editing the previous values'
      text(2) = &
      'INTEGERS       DOUBLES   CHARACTER STRINGS'// &
      '                        LOGICALS'
      do j = 1, numopt
         if (numpos(j).eq.1) then
            write (text(j + 2),200) kvalue(j)
         elseif (numpos(j).eq.2) then
            write (text(j + 2),300) xvalue(j)
         elseif (numpos(j).eq.3) then
            write (text(j + 2),400) svalue(j)
         elseif (numpos(j).eq.4) then
            if (kvalue(j).eq.0) then
               write (text(j + 2),500) '.false.'
            else
               write (text(j + 2),500) '.true.'
            endif
         endif
      enddo
      k = 15
      call table1 (k, 'OPEN')
      k = 0
      do i = 1, numopt + 2
         if (i.eq.1) then
            k = 1
         elseif (i.eq.2) then
            k = 4
         else
            k = 0
         endif
         call table1 (k, text(i))
      enddo
      call table1(k, 'CLOSE')

  100 format ('simdem35.for: demonstration of get00n' &
      / &
      /'numpos value`winio@ format (data type)' &
      /'numpos = 1  `%rd (integers)' &
      /'numpos = 2  `%rf (doubles)' &
      /'numpos = 3  `%rs (character strings)' &
      /'numpos = 4  `%rb (logicals (0/1))' &
      / &
      /'Select first integer' &
      /'Select second integer' &
      /'Select first double' &
      /'Select second double' &
      /'Select first string' &
      /'Select second string' &
      /'Select first logical' &
      /'Select second logical' &
      / &
      /'Edit the above values, character strings, and tick boxes.')
  200 format (i8,13x,'*',3x,'*',40x,'*')
  300 format (7x,'*',1p,e14.4,3x,'*',40x,'*')
  400 format (7x,'*',13x,'*',3x,a40,1x,'*')
  500 format (7x,'*',13x,'*',3x,'*',39x,a8)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem36: bbox01, vbox01, hbox01 ... display text/buttons
! =========================================================
!
! subroutines
! -----------
! bbox01 ... normal buttons
! hbox01 ... horizontal buttons
! vbox01 ... vertical buttons
! Note: The hot key as set by numpos must be consistent across buttons
!
! arguments
! ---------
! icolor: intent (in) 0 = black, 1 = blue, 4 = red, etc. as for VGA
! ix, iy: intent (in) window position             (may be disabled)
! lshade: intent (in) 0 = no shading, 1 = shading (may be disabled))
! numbld: intent (in) 1, 2 = Normal; 3,4 = Italic; 4,5 = Bold; 6,7 = Bold Italic
!                    odd number = normal, even number = highlighted
! numdec: intent (inout) decision (pre-set to default before entry)
! numopt: intent (in) number of options >= 1
! numpos: intent (in) position of hot key in button text
! nstart: intent (in) starting line for buttons in text array
! numtxt: intent (in) text dimension
!   text: intent (in) text array
!  fixed: intent (in) use Courier New if .true.
!  flash: intent (in) not used
!   high: intent (in) not used
!
!
      program    main
      implicit   none
      integer    i, icolor, ix, iy, lshade, numdec, numopt, numsta, &
                 numtxt
      parameter (lshade = 1)
      integer    numbld(20), numpos(20)
      character  line*80, text(20)*80
      character  srname(3)*6
      logical    fixed, flash, high
      parameter (fixed = .false., flash = .false., high = .true.)
      external   bbox01, vbox01, hbox01, putadv
      data       srname / 'bbox01', 'vbox01', 'hbox01' /
!
! initialise
!
      do i = 1, 20
         numbld(i) = 0
         numpos(i) = 1
      enddo
!
! Typical text/button window
!
      icolor = 9
      ix = 4
      iy = 4
      numbld(1) = 1
      numtxt = 13
      numsta = 8
      numopt = 3
      numdec = 1
      do i = 1, 3
         write (text,100) srname(i)
         if (i.eq.1) then
            call bbox01 (icolor, ix, iy, lshade, numbld, numdec, &
                         numopt, numpos, numsta, numtxt, &
                         text, &
                         fixed, flash, high)
         elseif (i.eq.2) then
            call vbox01 (icolor, ix, iy, lshade, numbld, numdec, &
                         numopt, numpos, numsta, numtxt, &
                         text, &
                         fixed, flash, high)
         elseif (i.eq.3) then
            call hbox01 (icolor, ix, iy, lshade, numbld, numdec, &
                         numopt, numpos, numsta, numtxt, &
                         text, &
                         fixed, flash, high)
         endif
         write (line,200) numdec
         call putadv (line)
      enddo
!
! One liners
!
      numtxt = 3
      numopt = 3
      numsta = 1
      numpos(3) = 8
      do i = 1, 3
         write (text,300)
         numdec = i
         ix = ix + 4
         iy = iy + 4
         if (i.eq.1) then
            icolor = 0
            call bbox01 (icolor, ix, iy, lshade, numbld, numdec, &
                         numopt, numpos, numsta, numtxt, &
                         text, &
                         fixed, flash, high)
         elseif (i.eq.2) then
            icolor = 1
            call vbox01 (icolor, ix, iy, lshade, numbld, numdec, &
                         numopt, numpos, numsta, numtxt, &
                         text, &
                         fixed, flash, high)
         elseif (i.eq.3) then
            icolor = 4
            call hbox01 (icolor, ix, iy, lshade, numbld, numdec, &
                         numopt, numpos, numsta, numtxt, &
                         text, &
                         fixed, flash, high)
         endif
         write (line,200) numdec
         call putadv (line)
      enddo
  100 format ('Demonstrating subroutine ',a &
      /' ' &
      /'This subroutine creates a text window to' &
      /'display information and buttons.' &
      /'You can control the position and select a' &
      /'font for each line of text for headings.' &
      /'You can tab using the grave character.' &
      /'Advice' &
      /'Proceed' &
      /'Stop' &
      /'Note: `bbox01 is a normal button box' &
      /'      `vbox01 has vertical buttons' &
      /'      `hbox01 has horizontal buttons')
  200 format ('Button number',I2,' was selected')
  300 format ( &
       'Yesterday' &
      /'Today' &
      /'Tomorrow')
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem37: rbox01 ... radio/tick box control
! ===========================================
!
! subroutine
! ----------
! rbox01 ... ganged radio or check boxes
!
! arguments
! ---------
! icolor: intent (in) colour scheme               (may be disabled)
! ix, iy: intent (in) window position             (may be disabled)
! lshade: intent (in) 0 = no shading, 1 = shading (may be disabled))
! numbld: intent (in) Used inside the check box item list for ganging as follows ...
!         0 implies independent
!         positive multiples of 100 imply ganged group with one true.
!         negative multiples of 100 imply ganged groups where all can be .false.
!         Only one can be .true. in a ganged group
!         Outside the check box item list, numbld determines the font type
! numdec: intent (in) sets the check box type as follows ...
!         numdec = 0 radio box
!         numdec = 1 tick box
! numopt: intent (in) number of options
! numpos: intent (inout) pseudo logical integer variables as follows:
!         0 =.false.
!         1 = .true.
! numsta: intent (in) starting line for check boxes
! numtxt: intent (in) text dimension
!   text: intent (in) text array
!  fixed: not used
!  flash: not used
!   high: not used
!
!
      program   main
      implicit  none
      integer   i, icolor, ix, iy, lshade, numdec, numopt, numsta, &
                ntext
      integer   numbld(20), numpos(20)
      character text(20)*80
      logical   fixed, full, high
      external  rbox01
!
! initialise
!
      icolor = 7
      ix = 4
      iy = 4
      lshade = 0
      do i = 1, 20
         numbld(i) = 0
         numpos(i) = 0
      enddo
      fixed = .false.
      full = .false.
      high = .false.
!
! create a full control
!
      numdec = 0
      ntext = 18
      numopt = 7
      numsta = 9
!
! set 3 initialised-type ganged groups and logical variables
!
      numbld(1) = 1            ! emphasize the title
      numbld(numsta) = 100     ! initialised ganging group 1
      numbld(numsta + 1) = 100 ! initialised ganging group 1
      numbld(numsta + 2) = 200 ! initialised ganging group 2
      numbld(numsta + 3) = 200 ! initialised ganging group 2
      numbld(numsta + 4) = 300 ! initialised ganging group 3
      numbld(numsta + 5) = 300 ! initialised ganging group 3
      numpos(1) = 1
      numpos(2) = 0
      numpos(3) = 1
      numpos(4) = 0
      numpos(5) = 1
      numpos(6) = 0
      icolor = i
      write (text,100)
      call rbox01 (icolor, ix, iy, lshade, numbld, numdec, &
                   numopt, numpos, numsta, ntext, text, &
                   fixed, full, high)
!
! now a short control with an unitialised-type ganging group
!
      numsta = 1
      ntext = 5
      numopt = 5
      numbld(1) = - 100 ! an unititialised ganging group
      numbld(2) = - 100 ! an unititialised ganging group
      numbld(3) = - 100 ! an uninitialised ganging group
      numbld(4) = 1
      numbld(5) = 1
      numpos(1) = 0
      numpos(2) = 0
      numpos(3) = 0
      numpos(4) = 0
      numpos(5) = 0
      numdec = 1
      write (text,200)
      ix = ix + 4
      iy = iy + 4
      call rbox01 (icolor, ix, iy, lshade, numbld, numdec, &
                   numopt, numpos, numsta, ntext, text, &
                   fixed, full, high)
  100 format ('Demonstrating subroutine rbox01' &
      /'...' &
      /'Logical variables are as an integer array numpos.' &
      /'Ganging is achieved by the integer array numbld.' &
      /'Check box type is set by scalar integer numdec.' &
      /'The user must interpret the selection by analysing' &
      /'the results returned in the integer array numpos.' &
      /'...' &
      /' First item' &
      /' Second item' &
      /' Third item' &
      /' Fourth item' &
      /' Fifth item' &
      /' Sixth item' &
      /' Seventh item' &
      /'...' &
      /'Extra text can be set at the bottom of' &
      /'the control if required.')
  200 format ( &
       ' One' &
      /' Two' &
      /' Three' &
      /' Four' &
      /' Five')
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem38: table4 ... planting a function call in a window
! =========================================================
!
! subroutine
! ----------
! table4 ... interactive calculations in real time
!
! arguments
! ---------
! icolor: intent (in) colour scheme
!      n: intent (inout) an integer array
!      x: intent (inout) a double precison array
!   line: intent (in) character string as follows:
!                'OPEN'  opens table4  ... n and x are ignored
!                'CLOSE' closes table4 ... n and x are ignored
!                line = name of an allowed subroutine sets up that subroutine call
!                so the next line is the declaration for the call when n and x
!                are then used by the subroutine called.
! The idea is to specify a function that can be used interactively
! and the results of the calculation can be dispayed in real time.
! The variables n and x can be simple values for editing or they can be
! limits required for the editing process, depending on the active
! subroutine being called. The following scheme illustrates the use of
! arrays n and x in several situations.
!
! Use N and X for input/output functions as follows:
! ==================================================
! GETI01: N(1) = IMID                               ! get one arbitrary integer
! GETIL1: N(1) = IBOT, N(2) = IMID, N(3) = ITOP     ! get one limited integer
! GETIM1: N(1) = IBOT, N(2) = IMID, N(3) = ITOP     ! get one integer in a range
! GETRG3: X(1) = X, X(2) = Y, X(3) = Z Z >= Y >= X  ! get three values x =< y =< z
! GETRL1: X(1) = XBOT, X(2) = XMID, X(3) = XTOP     ! get one limited value
! GETRM1: X(1) = XBOT, X(2) = XMID, X(3) = XTOP     ! get one value in a range
! GETR01: X(1) = X                                  ! get one arbitrary value
!
      program    main
      implicit   none
      integer    i
      integer    ibot, imid, itop, nmax
      parameter (ibot = 0, itop = 20, nmax = 5)
      integer   icolor, n(3)
      double precision x(3)
      character  line*80
      external   table4
!
! initialise
!
      icolor = 9
      imid = ibot
      x(1) = 0.0d+00
      x(2) = 0.0d+00
      x(3) = 0.0d+00
      n(1) = ibot
      n(2) = imid
      n(3) = itop
!
! open the table
!
      call table4 (icolor, n, x, 'OPEN')
      do i = 1, nmax
         call table4 (icolor, n, x, 'GETIM1')
         call table4 (icolor, n, x, &
                      'value required for calculation')
         imid = n(2)
         write (line,100) imid, imid**2
         call table4 (icolor, n, x, line)
      enddo
!
! close the table
!
      call table4 (icolor, n, x, 'CLOSE')
  100 format ('imid =',I2,', imid squared =',i4)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem39: waiter ...Wait ... calculations in progress
! =====================================================
! For details read simdem.chm or simdem.html
!
! subroutine
! ----------
! waiter ... inform users when a slow process is taking place
!
! argument
! --------
! action: intent (in) switch the waiting message on or off
!
      program    main
      implicit   none
      integer    i
      double precision delay, t1, t2
      character  line*80
      logical    on, off
      parameter (on = .true., off = .false.)
      external   clock1, waiter, putadv, sleep1
      intrinsic  dble
!
! record the starting time
!
      call clock1 (t1)
      do i = 1, 3
!
! open the waiting message
!
         call waiter (on)
!
! cause a delay
!
         delay = dble(i)
         call sleep1 (delay)
!
! close down the waiting message
!
         call waiter (off)
!
! record the current time then show the result
!
         call clock1 (t2)
         write (line,100) i, t2 - t1
         call putadv (line)
      enddo
  100 format ('Delay was',i3,' sec., CPU sec. so far =',1p,e10.3)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem40: config ... Configure the dlls
! =======================================
!
! subroutine
! ----------
! config
!
! arguments
! ---------
! mode: intent (in) controls action as follows:
!       mode = 0: just return arguments silently
!       mode = 1: set the arguments interactively
! nval: intent (inout) integer arguments
! cval: intent (inout) character arguments
!
! Subroutine config is used to configure the Simfit dlls. This is very important
! if you want to control paths for printers, etc.  Details are taken from and
! written to the local Simfit configuration file w_simfit.cfg. Details are in the
! documents configure.txt and linux.txt.
!
! Simdem users should press [Check] to correct the paths to auxiliaries then
! [Apply] to overwrite the installation defaults.
!
      program    main
      implicit   none
      integer    mode, nval(12)
      character  cval(12)*256
      external   config
      mode = 1
      call config (mode, nval, cval)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem41: use vec1in to get a vector from the user
! ==================================================
!
! subroutine
!-----------
! vec1in ... read in a vector from console, clipboard or file
!
! arguments
! ---------
!  isend: intent (inout) as follows:
!         isend = 1: user types in data from the console
!         isend = 2: vector is read in from a file specified by the user
!         isend = k: k < or k > then decide interactively how to input data
!    nin: intent (in) input unit
!   nmax: intent (in) maximum dimension
!   npts: intent (inout) as follows:
!         fixnpt = .false. number of points actually read in
!         fixnpt = .true. number of points expected
!      x: intent (out) the data vector
!  fname: intent (inout) file name
!  title: intent (inout) data title
!  abort: intent (out) .false. if successful
! fixnpt: intent (in) forces the input dimension to be npts
!  label: intent (in) request title from user if .true.
!
      program    main
      implicit   none
      integer    nin, nmax
      parameter (nin = 3, nmax = 20)
      integer    i, isend, n, npts
      double precision x(nmax)
      character  filex*1024, text(25)*100, title*100, trim80*80
      logical    fixnpt, label
      parameter (fixnpt = .false., label = .true.)
      logical    abort
      external   vec1in, putadv, putmes, trim80
      external   closer
!
! The user types in a vector from the console
!
      call putadv ('Now create a short vector, say 1, 2, 3, 4, 5')
      call closer (nin)
      isend = 1
      call vec1in (isend, nin, nmax, npts, x, filex, title, &
                   abort, fixnpt, label)
      call closer (nin)
!
! Echo the title and data
!
      write (text(1),100)
      do i = 1, npts
         write (text(i + 1),200) x(i)
      enddo
      n = npts + 1
      call putmes (n, text)
      write (text,300) trim80(filex)
      n = 5
      call putmes(n, text)
!
! The user reads the data back in from the temporary file
!
      isend = 2
      call closer (nin)
      call vec1in (isend, nin, nmax, npts, x, filex, title, &
                   abort, fixnpt, label)
      call closer (nin)
      if (.not.abort) then
         write (text,400) trim80(filex)
         do i = 1, npts
            write (text(i + 2),200) x(i)
         enddo
         n = npts + 2
         call putmes (n, text)
      endif
  100 format ('You have just typed in these values:')
  200 format (1p,e11.3)
  300 format ( &
       'What to do next' &
      / &
      /'These values have been written to the temporary file' &
      /a &
      /'so now read the data back in from this file')
  400 format ('You have just read in these data from the file:'/a)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem42: use mattin to get a matrix from the user
! ==================================================
!
! subroutine
! ----------
! mattin ... read in a matrix from console, clipboard or file
!
! arguments
! ---------
!  isend: intent (inout) as follows:
!         isend = 1: user types in data from the console
!         isend = 2: matrix is read in from a file specified by the user
!         isend = k: k < 1 or k > 2 then decide interactively how to input data
!  ncmax: intent (in) maximum column dimension
!   ncol: intent (inout) actual number of columns
!    nin: intent (in) input unit
!  nrmax: intent (in) maximum row dimension
!   nrow: intent (inout) actual number of rows
!      a: intent (out) the matrix
!      b: intent (inout) a workspace vector
!  fname: intent (inout) file name
!  title: intent (inout) data title
!  abort: intent (out) .false. if successful
! fixcol: intent (in) forces the input column dimension to be ncol
! fixrow: intent (in) forces the input row dimension to be nrow
!  label: intent (in) request title from user if .true.
!
      program    main
      implicit   none
      integer    nin, ncmax, nrmax
      parameter (nin = 3, ncmax = 5, nrmax = 10)
      integer    i, isend, j, n, ncol, nrow
      double precision a(nrmax,ncmax), b(nrmax)
      character  filex*1024, text(25)*100, title*100, trim80*80
      logical    fixcol, fixrow, label
      parameter (fixcol = .false., fixrow = .false., label = .true.)
      logical    abort
      external   mattin, putadv, putmes, trim80
      external   closer
!
! The user types in a matrix from the console
!
      call putadv ('Now create a small matrix, say 4 by 3')
      call closer (nin)
      isend = 1
      call mattin (isend, ncmax, ncol, nin, nrmax, nrow, &
                   a, b, &
                   filex, title, &
                   abort, fixcol, fixrow, label)
      call closer (nin)
!
! Echo the title and data
!
      write (text(1),100)
      do i = 1, nrow
         write (text(i + 1),200) (a(i,j), j = 1, ncol)
      enddo
      n = nrow + 1
      call putmes (n, text)
      write (text,300) trim80(filex)
      n = 5
      call putmes(n, text)
!
! The user reads the data back in from the temporary file
!
      isend = 2
      if (.not.abort) then
         call closer (nin)
         call mattin (isend, ncmax, ncol, nin, nrmax, nrow, a, b, &
                      filex, title, &
                      abort, fixcol, fixrow, label)
         call closer (nin)
         if (.not.abort) then
            write (text,400) trim80(filex)
            do i = 1, nrow
               write (text(i + 2),200) (a(i,j), j = 1, ncol)
            enddo
            n = nrow + 2
            call putmes (n, text)
         endif
      endif
  100 format ('You have just typed in these values:')
  200 format (1p,5e11.3)
  300 format ( &
       'What to do next' &
      / &
      /'These values have been written to the temporary file' &
      /a &
      /'so now read the data back in from this file')
  400 format ('You have just read in data from the file:'/a)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem43: get a data matrix from the clipboard
! ==============================================
!
! subroutine
! ----------
! mattin ... read in a matrix from console, clipboard or file
! attrib ... does a file exist and have the read_only attribute
! getnou ... get an unconnected unit
!
! arguments
! ---------
! For subroutine mattin ...
!
!  isend: intent (inout) as follows:
!         isend = 1: user types in data from the console
!         isend = 2: matrix is read in from a file specified by the user
!         isend = k: k < 1 or k > 2 then decide interactively how to input data
!  ncmax: intent (in) maximum column dimension
!   ncol: intent (inout) actual number of columns
!    nin: intent (in) input unit
!  nrmax: intent (in) maximum row dimension
!   nrow: intent (inout) actual number of rows
!      a: intent (out) the matrix
!      b: intent (inout) a workspace vector
!  fname: intent (inout) file name
!  title: intent (inout) data title
!  abort: intent (out) .false. if successful
! fixcol: intent (in) forces the input column dimension to be ncol
! fixrow: intent (in) forces the input row dimension to be nrow
!  label: intent (in) request title from user if .true.
!
! For subroutine attrib ...
!     fname: intent (in) file name
!     there: intent (out) does it exist
! read_only: intent (out) is it read_only
!
! For subroutine getnou ...
! nout: intent (out) unconnected unit betwwen 10 and 100
!
      program    main
      implicit   none
      integer    i, isend, j, n, nrow, ncol, nout
      integer    ncmax, nrmax
      parameter (ncmax = 5, nrmax = 25)
      integer    ios, nlines
      parameter (nlines = 1)
      integer    error_code
      double precision di, dj, a(nrmax,ncmax), b(nrmax)
      double precision ten
      parameter (ten = 10.0d+00)
      character  temp*1024, text(30)*100 , title*100
      character  line(1)*100
      logical    fixcol, fixrow, label
      parameter (fixcol = .false., fixrow = .false., label = .true.)
      logical    abort, askif, read_only, there
      external   getnou, mattin, putadv, putmes, revpro
      external   deleet, gettmp
      external   attrib, opener, closer, writer
      intrinsic  dble
!
! Initialise the matrix a
!
      nrow = 8
      ncol = 4
      do j = 1, ncol
         dj = dble(j)/ten
         do i = 1, nrow
            di = dble(i)
            a(i,j) = di + dj
         enddo
      enddo
!
! Use getnou to get an unopened unit then connect a temporary file to it
!
      call getnou (nout)
      call gettmp (error_code, temp)
      call opener (ios, nout, temp)
!
! Write the data to the temporary file
!
      do i = 1, nrow
         write (line(1),'(1p,4e11.3)') (a(i,j), j = 1, ncol)
         call writer (ios, nlines, nout, line)
      enddo
!
! Recommend user to copy data to the clipboard
!
! Note: If all the file is copied to the clipboard then the full file will be
! ===== read in for analysis, just like a simfit data file with header.
!
      call putadv ( &
      'Select All ... for the next data table and copy to clipboard')
!
! View the table so user can copy to clipboard
!
      call revpro (nout)
!
! Delete the temporary file
!
      call closer (nout)
      askif = .false.
      call deleet (temp, askif, there)
!
! The user can now read the data back in from the clipboard, just like a data file
!
      call putadv ( &
      'Select the Paste button on the next file selection control')
      isend = 2
      call getnou (nout)
      call closer (nout)
      temp = ' '
      call mattin (isend, ncmax, ncol, nout, nrmax, nrow, a, b, &
                   temp, title, &
                   abort, fixcol, fixrow, label)
      call closer (nout)
      call attrib (temp, there, read_only)
      if (there) then
         open (unit = nout, file = temp)
         read (nout,'(a)') text(1)
         read (nout,*) nrow, ncol
         write (text(2),'(2i6)') nrow, ncol
         do i = 1, nrow
            read (nout,*) (a(i,j), j = 1, ncol)
            write (text(i + 2),'(4f6.1)') (a(i,j), j = 1, ncol)
         enddo
         n = nrow + 2
         close (nout)
         call putmes (n, text)
      endif
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem44: the Simfit file selection controls
! ============================================
!
! subroutines
! -----------
! ofiles ... comprehensive Simfit file selection control
! getfil ... simple Windows file selection control
! fserch ... Simfit file searching procedure
! infofl ... identify the file located
!
! arguments
! ---------
! For subroutine ofiles ...
! isend: integer,             intent (in) as follows:
!        isend = 1: Save As (select a filename for saving data)
!        isend = 2: Save    (provide a file name as argument o/w as 1)
!        isend = 3: Open    (select an existing file for analysis)
!        isend = 4: Open    (provide a file name as argument o/w as 3)
!  nout: integer,             intent (in) unit for file connection
! fname: character (len = *), intent (inout) file name
! abort: logical,             intent (out) set to .false. if successful and
!                             nout is then returned connected
!
! For subroutine getfil ...
!
! isend: integer,             intent (in) as follows:
!        isend = 0 Save As ..
!        isend = 1 Open ...
!   ext: character (len = *), intent (in)    default file extension
! fname: character (len = *), intent (inout) filename
! type1: character (len = *), intent (in)    description of default file type
! abort: logical,             intent (out)   returned as .true. on error exit
!
!
! For subroutine fserch ...
!
!       dir: character (len = *), intent (in)  default starting directory
!     fname: character (len = *), intent (in)  default starting file name
! full_path: character (len = *), intent (out) fully qualified drive\path\filename if there = .true.
!     there: logical,             intent (out) indicates if file was located
!
! For subroutine infofl ...
!
! isend: integer,             intent (in) indicator (9 for file located)
! fname: character (len = *), intent (in) filename
!
! Advice
! ------
! The advanced simfit file selection control is very versatile. You can type in
! file names or use the Windows Browse function. Alternatively you can
! toggle backwards or forwards through the lists of recently created/analysed
! files which allows keystroke editing or you can select directly from the
! file lists. You can also set filters interactively. There are many powerful
! built in functions, e.g. try opening an exe or dll file. You cannot set
! demonstration filenames from this example so the Demo button will not work.
!
! The simple file control is just an interface to the usual Windows file
! selection control with no special Simfit features. It is initialised by
! the arguments ext and type1
!
! Note: this example does not actually open files or connect units, so existing
!       files in file store will not be altered.
!
      program    main
      implicit   none
      integer    jsend, numopt, numtxt
      parameter (jsend = 9, numopt = 5, numtxt = 23)
      integer    isend, numdec, nout
      integer    numbld(numtxt)
      character (len = 1024) dir, fname, full_path
      character (len = 80  ) sname, text(numtxt), type1
      character (len = 10  ) ext
      logical    abort, repeet, there
      external   getnou, ofiles, putadv, putfat, fserch, patch2, &
                 closer, getfil, listbx, infofl
      data       numbld / numtxt*0 /
!
! initialise
!
      dir = 'C:'
      ext = 'txt'
      fname = 'file.tmp'
      sname = 'simdem.exe'
      type1 = 'Text files'
!
! main loop
!
      repeet = .true.
      numdec = numopt - 1
      do while (repeet)
         write (text,100)
         call listbx (numdec, numopt, &
                      text)
         if (numdec.eq.1) then
!
! numdec = 1: Simfit file selection control
!
         call putadv ('Specify a new/old filename for ... Save As')
!
! Find an unconnected unit then attempt to Save As
!
         call getnou (nout)
         isend = 1
         call closer (nout)
         call ofiles (isend, nout, fname, abort)
         call closer (nout)
         if (abort) then
            call putfat ('Failure to open a file')
         else
            call infofl (jsend, fname)
         endif
         isend = 3
         call putadv ('Specify an exisiting file for ... Open')
!
! Find an unconnected unit then attempt to Open
!
         call getnou (nout)
         isend = 3
         call closer (nout)
         call ofiles (isend, nout, fname, abort)
         call closer (nout)
         if (abort) then
            call putfat ('Failure to open a file')
         else
            call infofl (jsend, fname)
         endif
      elseif (numdec.eq.2) then
!
! numdec = 2: Windows file selection control
!
         call putadv ('Specify a new/old filename for ... Save As')
!
! Attempt to Save As
!
         isend = 0
         call getfil (isend, ext, fname, type1, abort)
         isend = 0
         if (abort) then
            call putfat ('Failure to open a file')
         else
            call infofl (jsend, fname)
         endif
         isend = 3
         call putadv ('Specify an exisiting file for ... Open')
!
! Attempt to Open
!
         isend = 1
         call getfil (isend, ext, fname, type1, abort)
         if (abort) then
            call putfat ('Failure to open a file')
         else
            call infofl (jsend, fname)
         endif
         elseif (numdec.eq.3) then
!
! numdec = 3: file searching
!
            call fserch (dir, sname, full_path, &
                         there)
         elseif (numdec.eq.4) then
!
! numdec = 4: help
!
            numbld(1) = 1
            numbld(11) = 1
            numbld(14) = 1
            write (text,200)
            call patch2 (numbld, numtxt, &
                         text)
         else
!
! numdec = 5: finish
!
            repeet = .false.
         endif
      enddo
  100 format ( &
       'Comprehensive file selection' &
      /'Simple file selection' &
      /'File searching procedure' &
      /'Help' &
      /'Quit ... Exit simdem44')
  200 format ( &
       'Comprehensive file selection' &
      /'This allows you to select files for opening or saving in very' &
      /'many ways. For example:' &
      /'1.`Typing in a file name' &
      /'2.`Selecting from previously opened files' &
      /'3.`Selecting from previously saved files' &
      /'4.`Pasting in data from the clipboard' &
      /'5.`Scrolling through a user supplied list' &
      /'6.`Browsing with the standard Windows control.' &
      / &
      /'Simple file selection' &
      /'This is just a shortcut to the previous item 6.' &
      / &
      /'File searching procedure' &
      /'You start by providing a starting folder and file name and then' &
      /'have numerous options. For instance:' &
      /'a)`Search using the folder and file name supplied' &
      /'b)`Specify a fully qualified drive\path\filename' &
      /'c)`Input a new starting folder' &
      /'d)`Input a new file name' &
      /'e)`Stop the search if it proves too long.' &
      /'If the search succeeds (i.e. there = .true.) then full_path' &
      /'will be the fully qualified drive\path\filename located')
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem45: print a text file
! ===========================
! For details read simdem.chm or simdem.html
!
! subroutine
! ----------
! fprint ... print a text file
!
! arguments
! ---------
!  lpti: intent (in) parallel port, usually l
!        Note: In this version lpti is not referenced but should
!              be set equal to 1 in order to print to all types
!              of remote and local printers.
! fname: intent (in) file name of a text file
!
! The subroutine fprint opens the Windows printer dialogue and allows
! users to copy selected text files to the printer. This version will
! not attempt to print Postscript or PDF files, or any special file
! types with standard extensions, like, .bat, .com, .exe, .dll, etc.
!
!
      program    main
      implicit   none
      integer    isend, nout
      integer    lpti
      parameter (lpti = 1)
      character  fname*1024, word60*60, trim60*60
      logical    abort, repeet
      external   getl01, getnou, ofiles, putadv, putfat, fprint
      external   closer, trim60
      fname = 'file.tmp'
      repeet = .true.
      do while (repeet)
         isend = 3
         call putadv ('Select an existing text file for printing')
!
! Find an unconnected unit then attempt to Open
!
         call getnou (nout)
         isend = 3
         call ofiles (isend, nout, fname, abort)
         call closer (nout)
         word60 = trim60(fname)
         if (abort) then
            call putfat ('Failure to open: '//word60)
         else
            call putadv ('Success opening: '//word60)
            call fprint (lpti, fname)
         endif
         call getl01 ('Another go', repeet)
      enddo
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem46: create n plots using smplot
! ========
!
! subroutine
! ----------
! smplot ... overlay n graphs
!
! arguments
! ---------
!      j: intent (in) colour
!      l: intent (in) line type
!      m: intent (in) symbol type
!      n: intent (in) number of plots
!  files: intent (in) file names
! titles: intent (in) plot title and legends
!
      program    main
      implicit   none
      integer    n, nout, nplot
      parameter (n = 4, nout = 4, nplot = 10)
      integer    j(n), l(n), m(n)
      integer    i, k
      double precision one, x, y
      parameter (one = 1.0d+00)
      character  blank*1, files(n)*1024, titles(4)*40
      parameter (blank = ' ')
      external   deltmp, gettmp, smplot
      intrinsic  dble
!
! initialise arguments for n data sets
!
      do i = 1, n
!
! j = colour (0 to 71, 0 to 15 are standard VGA colours, rest from palette)
!
         j(i) = i
!
! l = line type (1 to 4, as follows: 1 = solid,  2 = dashed,
!                                    3 = dotted, 4 = dash-dotted)
!
         l(i) = i
!
! m = symbol type (0 to 19, as follows:  5 = circle,  8 = triangle,
!                                       11 = square, 14 = diamond)
!
         if (i.eq.1) then
            m(1) = 5
         else
            m(i) = m(i - 1) + 3
         endif
      enddo
!
! define the plot title and legends
!
      titles(1) = 'Demonstrating SMPLOT'
      titles(2) = 'X-values'
      titles(3) = 'Y-values'
      titles(4) = blank
!
! create the temporary Simfit plotting files
!
      do i = 1, n
         call gettmp (k, files(i))
         open (unit = nout, file = files(i))
         write (nout,'(a)') blank
         write (nout,'(2i4)') nplot, 2
         y = dble(i)
         do k = 1, nplot
            x = dble(k)
            y = y + one
            write (nout,'(1p,2e11.3)') x, y
         enddo
         close(unit = nout)
      enddo
!
! plot the data
!
      call smplot (j, l, m, n, files, titles)
!
! delete the temporary files
!
      call deltmp
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem47: create a pie chart using pcplot
! ========
!
! subroutine
! ----------
! pcplot ... plot a vector as a pie chart
!
! arguments
! ---------
!  isend: intent (in) as follows:
!         isend = 1: input a vector and use defaults
!         isend = 2: input a vector and use the arguments supplied
!  ifill: intent (in) fill style (if isend = 2)
!   ihue: intent (in) colour (if isend = 2)
!      n: intent (in) number of segments >= 2
!      d: intent (in) displacements (if isend = 2)
!      x: intent (in) values >= 0
! labels: intent (in) segment labels (if isend = 2)
!  title: intent (in) pie chart title
!
      program    main
      implicit   none
      integer    n
      parameter (n = 7)
      integer    isend, ifill(n), ihue(n)
      integer    i
      double precision d(n), x(n), zero, epsi, one
      parameter (zero = 0.0d+00, epsi = 0.075d+00, one = 1.0d+00)
      character  labels(n)*20, title*40
      external   pcplot
      intrinsic  dble
!
! example 1: use the default simfit configuration options
! ==========
!
!
! initialise essential arguments for default pie chart
!
      do i = 1, n
         x(i) = dble(i)
      enddo
      title = 'Demonstrating pcplot, isend = 1'
!
! isend = 1: call pcplot in default mode
!
      isend = 1
      call pcplot (isend, ifill, ihue, n, d, x, labels, title)
!
! example 2: set all arguments individually
! ==========
!
!
! initialise arguments for n segments for advanced pie chart
!
      do i = 1, n
!
! ifill = fill style (0 to 10)
!
         ifill(i) = i
!
! ihue = colour (0 to 71, 0 to 15 are standard VGA colours, rest from palette)
!
         ihue(i) = i
!
! d = segment displacement (0 to 1)
!
         if (i.eq.1) then
           d(i) = zero
         else
           d(i) = d(i - 1) + epsi
         endif
!
! x = segment values > 0
!
         x(i) = one
!
! labels = segment labels
!
         write (labels(i),'(a,i3)') 'Segment', i
      enddo
      title = 'Demonstrating pcplot, isend = 2'
!
! isend = 2: call pcplot with the values supplied
!
      isend = 2
      call pcplot (isend, ifill, ihue, n, d, x, labels, title)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem48: create a bar chart using bcplot
! ========
!
! subroutine
! ----------
! bcplot ... plot a matrix as a bar chart
!
! arguments
! ---------
!  isend: intent (in) as follows:
!         isend = 1: use default labels
!         isend = 2: use labels supplied
!   ncol: intent (in) number of columns to plot
!  nrmax: intent (in) leading dimension of x
!   nrow: intent (in) number of rows to plot
!      x: intent (in) data
! labels: intent (in) group labels (if isend = 2)
! titles: intent (in) title and legends
!
      program    main
      implicit   none
      integer    ncol, nrow, nrmax
      parameter (ncol = 3, nrow = 5, nrmax = 10)
      integer    isend
      integer    i, j
      double precision x(nrmax,ncol)
      character  blank*1, labels(nrow)*20, titles(4)*40
      parameter (blank = ' ')
      external   bcplot
      intrinsic  dble
!
! example 1: use the default simfit configuration options and labels
! ==========
!
!
! initialise essential arguments for default bar chart
!
      do j = 1, ncol
         do i = 1, nrow
            x(i,j) = dble(i + j)
         enddo
      enddo
      titles(1) = 'Demonstrating bcplot, isend = 1'
      titles(2) = 'Rows'
      titles(3) = 'Columns'
      titles(4) = blank
!
! isend = 1: call bcplot in default mode
!
      isend = 1
      call bcplot (isend, ncol, nrmax, nrow, x, labels, titles)
!
! example 2: set labels individually
! ==========
!
      do i = 1, nrow
!
! labels = bar chart labels
!
         write (labels(i),'(a,i3)') 'Row', i
      enddo
      titles(1) = 'Demonstrating bcplot, isend = 2'
!
! isend = 2: call bcplot with the labels supplied
!
      isend = 2
      call bcplot (isend, ncol, nrmax, nrow, x, labels, titles)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem49: create a box and whisker plot using bwplot
! ========
!
! subroutine
! ----------
! bwplot ... plot a vector as a box and whisker plot
!
! arguments
! ---------
!  isend: intent (in) as follows:
!         isend = 1: use default labels
!         isend = 2: use labels supplied
!   nobs: intent (in) number of observations per set
!   nset: intent (in) number of sets of observations
!   nvec: intent (in) total number of observations
!    vec: intent (in) the observations as ordered by nobs and nset
! labels: intent (in) labels (if isend = 2)
! titles: intent (in) title and legends
!
      program    main
      implicit   none
      integer    nmax, nset
      parameter (nmax = 500, nset = 5)
      integer    isend, nobs(nset), nvec
      integer    i, j, k
      double precision vec(nmax)
      character  blank*1, labels(nset)*20, titles(4)*40
      parameter (blank = ' ')
      external   bwplot
      intrinsic  dble
!
! example 1: use default labels
! ==========
!
!
! initialise essential arguments for box and whisker plot
! nset = number of sets, i.e. groups
! nobs = number of observations per set, nobs(i) >= 4
! nvec = total number of observations as ordered by nobs
!
      nvec = 0
      do i = 1, nset
         j = 0
         do k = 1, i + 4
            j = j + 1
            nvec = nvec + 1
            vec(nvec) = dble(k)
         enddo
         nobs(i) = j
         labels(i) = blank
      enddo
      titles(1) = 'Demonstrating bwplot, isend = 1'
      titles(2) = 'Groups'
      titles(3) = 'Values'
      titles(4) = blank
!
! isend = 1: call bwplot in default mode
!
      isend = 1
      call bwplot (isend, nobs, nset, nvec, vec, labels, titles)
!
! example 2: set labels individually
! ==========
!
      do i = 1, nset
!
! labels = box and whisker labels
!
         write (labels(i),'(a,i3)') 'Group', i
      enddo
      titles(1) = 'Demonstrating bwplot, isend = 2'
!
! isend = 2: call bwplot with the labels supplied
!
      isend = 2
      call bwplot (isend, nobs, nset, nvec, vec, labels, titles)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem50: create a bar chart with error bars using ebplot
! =========
!
! subroutine
! ----------
! ebplot ... plot a vector as a bar chart with error bars
!
! arguments
! ---------
!  isend: intent (in) as follows:
!         isend = 1: use default labels
!         isend = 2: use labels supplied
!   nobs: intent (in) number of observations per set
!   nset: intent (in) number of sets of observations
!   nvec: intent (in) total number of observations
!    vec: intent (in) the observations as ordered by nobs and nset
! labels: intent (in) labels (if isend = 2)
! titles: intent (in) title and legends
!
      program    main
      implicit   none
      integer    nmax, nset
      parameter (nmax = 500, nset = 5)
      integer    isend, nobs(nset), nvec
      integer    i, j, k
      double precision vec(nmax)
      character  blank*1, labels(nset)*20, titles(4)*40
      parameter (blank = ' ')
      external   ebplot
      intrinsic  dble
!
! initialise essential arguments for bar chart with error bars
! nset = number of sets, i.e. groups
! nobs = number of observations per set, nobs(i) >= 2
! nvec = total number of observations as ordered by nobs
!
      nvec = 0
      do i = 1, nset
         j = 0
         do k = 1, i + 4
            j = j + 1
            nvec = nvec + 1
            vec(nvec) = dble(k)
         enddo
         nobs(i) = j
         write (labels(i),'(a,i3)') 'Group', i
      enddo
      titles(1) = 'ebplot, isend = 2'
      titles(2) = 'Groups'
      titles(3) = 'Values'
      titles(4) = blank
!
! isend = 2: call ebplot with the labels supplied
!            use isend = 1 if there are no labels
!
      isend = 2
      call ebplot (isend, nobs, nset, nvec, vec, labels, titles)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem51: get the current DLL versions
! ========
!
! Important note added at 11/12/2012
! The call to scclib returns isalf from salflibc.dll in the 32-bit version
! but returns -isalf from clearwin64.dll in the 64-bit version. So a call
! to scclib identifies if the 32-bit or 64-bit version is in use.
! subroutines
! -----------
! scclib ... signature for salflibc.dll   (clearwin64.dll   in 64-bit version)
! dllmen ... signature for w_menus.dll    (x64_menus.dll    in 64-bit version)
! dllgra ... signature for w_graphics.dll (x64_graphics.dll in 64-bit version)
! dllclr ... signature for w_clearwin.dll (x64_clearwin.dll in 64-bit version)
!
! arguments
! ---------
! For scclib.dll/clearwin64.dll ...
! isalf: intent (out) version identifier
!
! For the Simfit DLLs ...
! xver: intent (out) version
! yver: intent (out) release number
! dver: intent (out) description
!
      program    main
      implicit   none
      integer    i, isalf, j, n
      double precision xver_c, xver_m, xver_g, yver_c, yver_m, yver_g
      character (len = 1  ) blank
      parameter (blank = ' ')
      character (len = 7  ) word7(3)
      character (len = 12 ) dll32, dll64, form12, word12
      parameter (dll32 = 'simdem32.dll', dll64 = 'simdem64.dll')
      character (len = 15 ) form15, word15
      character (len = 30 ) dver_c, dver_m, dver_g
      character (len = 100) text(10)
      character (len = 256) fname
      logical    x86_version, xtra
      external   dllclr, dllmen, dllgra, scclib, table1, form12
      external   dllnam, lcase1
      intrinsic  adjustr, nint, index
!
! call in the salflibc.dll/clearwin64.dll identifier isalf
!
      call scclib (isalf)
      if (isalf.gt.0) then
         x86_version = .true.
      else
         x86_version = .false.
      endif
!
! call in the simfit DLL details as follows:
! xver = version number
! yver = release number
! dver = description
!
      call dllclr (xver_c, yver_c, dver_c)
      word15 = form15(xver_c)
      word7(1) = word15(1:7)
      call dllnam (fname)
      call lcase1 (fname)
      xtra = .false.
      if (index(fname,dll32).gt.0) then
         xtra = .true.
         fname = dll32
      elseif (index(fname,dll64).gt.0) then
         xtra = .true.
         fname = dll64
      endif

      call dllmen (xver_m, yver_m, dver_m)
      word15 = form15(xver_m)
      word7(2) = word15(1:7)

      call dllgra (xver_g, yver_g, dver_g)
      word15 = form15(xver_g)
      word7(3) = word15(1:7)

      if (x86_version) then
         word12 = form12(isalf)
         write (text,100) word12, &
                          adjustr(word7(1)), nint(yver_m), dver_m, &
                          adjustr(word7(2)), nint(yver_g), dver_g, &
                          adjustr(word7(3)), nint(yver_c), dver_c
      else
         isalf = -isalf
         word12 = form12(isalf)
         write (text,200) word12, &
                          adjustr(word7(1)), nint(yver_m), dver_m, &
                          adjustr(word7(2)), nint(yver_g), dver_g, &
                          adjustr(word7(3)), nint(yver_c), dver_c

      endif
      j = 15
      call table1 (j, 'OPEN')
      n = 6
      if (xtra) then
         n = n + 1
         text(n) = blank
         n = n + 1
         text(n) = ' Note: For FTN95 versions from 7.4.0 on the three'
         n = n + 1
         text(n) = ' dlls above have been combined into the single dll'
         n = n + 1
         text(n) = blank//fname(1:12)
      endif
      do i = 1, n
         if (i.eq.1 .or. i.eq.3 .or. i.eq.10) then
            j = 4
         else
            j = 0
         endif
         call table1 (j, text(i))
      enddo
      call table1 (J, 'CLOSE')
  100 format ( &
       'Current dynamic link libraries' &
      /'  salflibc.dll: ',a &
      /'               Version  Release  Description' &
      /'   w_menus.dll:',a7,i9,2x,a &
      /'w_graphics.dll:',a7,i9,2x,a &
      /'w_clearwin.dll:',a7,i9,2x,a)
  200 format ( &
       'Current dynamic link libraries' &
      /'  salflibc64.dll: ',a &
      /'                 Version  Release  Description' &
      /'   x64_menus.dll:',a7,i9,2x,a &
      /'x64_graphics.dll:',a7,i9,2x,a &
      /'x64_clearwin.dll:',a7,i9,2x,a)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem52: retrieve a colour number for plotting
! ========
!
! subroutine
! ----------
! palett ... edit or retrieve the Simfit colours
!
! arguments
! ---------
! kolor: intent (inout) colour (sets the default on entry)
!  mode: intent (in) as follows:
!        mode = 0: just retrieve a colour
!        otherwise depends on the current version
!
      program main
      implicit   none
      integer    after, before, mode
      parameter (mode = 0)
      character  line*100
      external   palett, putadv
      before = 0
      after = before
      call palett (after, mode)
      write (line,100) before, after
      call putadv (line)
  100 format ('Colour on entry =',i3,', colour on exit =',i3)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem53: 2D plot with labels
! =========
!
! subroutine
! ----------
! lbplot ... plot symbols with labels
!
! arguments
! ---------
!      n: intent (in) number of coordinate pairs
!      x: intent (in) x-coordinates
!      y: intent (in) y-coordinates
! ptitle: intent (in) plot title
!  wordx: intent (in) labels
! xtitle: intent (in) x-legend
! ytitle: intent (in) y-legend
!
      program main
      implicit none
      integer  n
      parameter (n = 5)
      double precision x(n), y(n)
      character ptitle*19, wordx(n)*12, xtitle*8, ytitle*8
      external lbplot
      x(1) = 1.0d+00
      x(2) = x(1)
      x(3) = -1.0d+00
      x(4) = x(3)
      x(5) = 0.0d+00
      y(1) = 1.0d+00
      y(2) = -1.0d+00
      y(3) = y(2)
      y(4) = y(1)
      y(5) = 0.0d+00
      ptitle = '2D plot with labels'
      xtitle = 'X-values'
      ytitle = 'Y-values'
      write (wordx,100)
      call lbplot (n, &
                   x, y, &
                   ptitle, wordx, xtitle, ytitle)
  100 format ( &
       'Apples' &
      /'Pears' &
      /'Plums' &
      /'Oranges' &
      /'Strawberries')
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem54: plot sample cumulative distribution and best-fit cdf
! ========
!
! subroutine
! ----------
! cdplot ... display best-fit cdf on sample cumulative distribution
!
! arguments
! ---------
!   npdf: intent (in) number of pdf(t) values (>= 10 ?)
!  nrmax: intent (in) dimension of workspace (>= 2*nsamp)
!  nsamp: intent (in) size of sample (>= 20 ?)
!    pdf: intent (in) best-fit (or exact) pdf(t) as calculated elsewhere
! sample: intent (in) sample (must be in nondecreasing order)
!      t: intent (in) argument for pdf (any spacing as required)
!  x,y,z: intent (inout) workspaces for creating step curve
! ptitle: intent (in) plot title
! xtitle: intent (in) x-legend
! ytitle: intent (in) y-legend
!
! Advice
! ------
! There should be (say) >= 20 points to estimate a best-fit pdf
! in a meaningful way. Then the subroutine cdplot integrates the
! best-fit pdf by the trapezoidal method to show a smooth cdf curve,
! so there should be (say) >= 10 best-fit pdf points.
!
!
      program main
      implicit none
      integer npdf, nrmax, nsamp
      parameter (npdf = 10, nsamp = 20, nrmax = 20)
      double precision pdf(npdf), sample(nsamp), t(npdf), &
                       x(2*nrmax), y(2*nrmax), z(2*nrmax)
      character ptitle*23, xtitle*6, ytitle*21
      external  cdplot
      data sample / &
      -0.1251D+01, -0.8949D+00, -0.8082D+00, -0.7000D+00, -0.6648D+00, &
      -0.3640D+00, -0.3588D+00, -0.3125D+00, -0.3073D+00, -0.2855D+00, &
      -0.8175D-01,  0.1030D+00,  0.1130D+00,  0.1229D+00,  0.2740D+00, &
       0.4958D+00,  0.5124D+00,  0.8592D+00,  0.1301D+01,  0.1565D+01 /
      data t / &
      -0.1251D+01, -0.9381D+00, -0.6252D+00, -0.3124D+00,  0.5063D-03, &
       0.3134D+00,  0.6262D+00,  0.9391D+00,  0.1252D+01,  0.1565D+01 /
      data pdf / &
      0.1343D+00,  0.2528D+00,  0.3948D+00,  0.5116D+00,  0.5501D+00, &
      0.4909D+00,  0.3635D+00,  0.2233D+00,  0.1139D+00,  0.4819D-01 /
      ptitle = 'Sample and best-fit cdf'
      xtitle = 'Values'
      ytitle = 'CDF and step function'
      call cdplot (npdf, nrmax, nsamp, &
                   pdf, sample, t, x, y, z, &
                   ptitle, xtitle, ytitle)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem55: plot sample histogram and best-fit pdf
! ========
!
! subroutine
! ----------
! pdplot ... display best fit pdf on sample histogram
!
! arguments
! ---------
!  nbins: intent (in) number of histogram bins (say nsamp/nbins >= 5)
!   npdf: intent (in) number of pdf(t) values (>= 10 ?)
!  nrmax: intent (in) dimension of workspace (>= 4*nbins)
!  nsamp: intent (in) size of sample (>= 20 ?)
!    pdf: intent (in) best-fit (or exact) pdf(t) as calculated elsewhere
! sample: intent (in) sample (must be in nondecreasing order)
!      t: intent (in) argument for pdf (any spacing as required)
!    x,y: intent (inout) workspaces for creating histogram
! ptitle: intent (in) plot title
! xtitle: intent (in) x-legend
! ytitle: intent (in) y-legend
!
! Advice
! ------
! There should be (say) >= 40 points to plot a histogram in
! a meaningful way. Then the subroutine pdplot creates the
! histogram and plots the best-fit pdf as a smooth curve,
! so there should be (say) >= 10 best-fit pdf points.
!
      program main
      implicit none
      integer nbins, npdf, nrmax, nsamp
      parameter (nbins = 5, npdf = 20, nsamp = 40, nrmax = 4*nsamp)
      double precision pdf(npdf), sample(nsamp), t(npdf), &
                       x(nrmax), y(nrmax)
      character ptitle*26, xtitle*6, ytitle*12
      external  pdplot
      data sample / &
      -0.2117D+01, -0.1583D+01, -0.1275D+01, -0.1202D+01, -0.1018D+01, &
      -0.8655D+00, -0.8011D+00, -0.6995D+00, -0.6744D+00, -0.5887D+00, &
      -0.5654D+00, -0.4868D+00, -0.4810D+00, -0.4470D+00, -0.4403D+00, &
      -0.3938D+00, -0.3613D+00, -0.2735D+00, -0.2422D+00, -0.2067D+00, &
      -0.1680D+00, -0.1423D+00, -0.1130D+00, -0.1040D+00, -0.7391D-01, &
      -0.6547D-02,  0.1313D+00,  0.1880D+00,  0.2213D+00,  0.2657D+00, &
       0.2844D+00,  0.5517D+00,  0.5544D+00,  0.5581D+00,  0.6531D+00, &
       0.7271D+00,  0.7323D+00,  0.1018D+01,  0.1561D+01,  0.1761D+01 /
      data t / &
      -0.2117D+01, -0.1913D+01, -0.1709D+01, -0.1505D+01, -0.1301D+01, &
      -0.1097D+01, -0.8924D+00, -0.6883D+00, -0.4841D+00, -0.2800D+00, &
      -0.7582D-01,  0.1283D+00,  0.3325D+00,  0.5366D+00,  0.7407D+00, &
       0.9449D+00,  0.1149D+01,  0.1353D+01,  0.1557D+01,  0.1761D+01 /
      data pdf / &
      0.2165D-01,  0.4036D-01,  0.7028D-01,  0.1143D+00,  0.1736D+00, &
      0.2463D+00,  0.3263D+00,  0.4038D+00,  0.4668D+00,  0.5040D+00, &
      0.5082D+00,  0.4786D+00,  0.4210D+00,  0.3459D+00,  0.2654D+00, &
      0.1902D+00,  0.1273D+00,  0.7961D-01,  0.4649D-01,  0.2536D-01 /
      ptitle = 'Histogram and best-fit pdf'
      xtitle = 'Values'
      ytitle = 'Bins and pdf'
      call pdplot (nbins, npdf, nrmax, nsamp, &
                   pdf, sample, t, x, y, &
                   ptitle, xtitle, ytitle)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem56: create a histogram with error bars
! ========
!
! subroutine
! ----------
! hist01 ... display a histogram with error bars
!
! arguments
! ---------
!      n: intent (in) number of histogram centres (n >= 1)
!     nh: intent (in) maximum number of coordinates for plotting (nh >= 10*n + 1)
! number: intent (out) cells plotted (returned > 0 for stats if successful)
!      s: intent (in) error bar heights (e >= 0, e.g. t_{nu}*std.err.)
!      x: intent (in) equally spaced histogram centres in increasing order
!     xh: intent (inout) workspace
!      y: intent (in) histogram cell heights (y >= 0, e.g. number per cell)
!     yh: intent (inout) workspace
!  gsave: intent (in) unused logical (but set gsave = .true.)
!
      program main
      implicit none
      integer  n, nh, number
      parameter (n = 5, nh = 10*n + 1)
      double precision s(n), x(n), xh(nh), y(n), yh(nh)
      logical gsave
      parameter (gsave = .true.)
      external hist01
      data x / 1.0d+00, 2.0d+00, 3.0d+00, 4.0d+00, 5.0d+00 /
      data y / 1.0d+00, 2.0d+00, 3.0d+00, 2.0d+00, 1.0d+00 /
      data s / 0.1d+00, 0.1d+00, 0.2d+00, 0.1d+00, 0.1d+00 /
      call hist01 (n, nh, number, &
                   s, x, xh, y, yh, &
                   gsave)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem57: plot a dendrogram
! ========
!
! subroutine
! ----------
! dgplot ... display a dendrogram with a threshold
!
! arguments
! ---------
! Parameters are as returned from G03ECF except that
! thresh = threshold to plot horizontal line as used
! for selecting subgroups in the simfit package
!    ilc: intent (in) as G03ECF
!    iuc: intent (in) as G03ECF
!   iord: intent (in) as G03ECF
!      n: intent (in) number of observations
!   nmax: intent (in) dimension >= n
!     cd: intent (in) as G03ECF
! thresh: intent (in) dendrogram threshold for selecting subgroups
!      x: intent (inout) workspace
! ptitle: intent (in) plot title
!  wordx: intent (in) labels
! xtitle: intent (in) x-legend
! ytitle: intent (in) y-legend
!
!
      program    main
      implicit   none
      integer    n, nmax
      parameter (n = 5, nmax = 5)
      integer    ilc(n - 1), iuc(n - 1), iord(n)
      double precision cd(n - 1), thresh, x(nmax,3)
      character  ptitle*10, wordx(n)*1, xtitle*1, ytitle*1
      parameter (ptitle = 'Dendrogram', xtitle = 'X', ytitle = 'Y')
      external   dgplot
      data ilc   / 2, 1, 1, 1 /
      data iuc   / 4, 3, 5, 2 /
      data iord  / 1, 3, 5, 2, 4 /
      data cd    / 1.0d+00, 2.0d+00, 6.5d+00, 14.13d+00 /
      data wordx / 'A', 'B', 'C', 'D', 'E' /
      thresh = 5.0d+00
      call dgplot (ilc, iuc, iord, n, nmax, &
                   cd, thresh, x, &
                   ptitle, wordx, xtitle, ytitle)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem58: scrolling check boxes
! ========
!
! subroutine
! ----------
! chkbox ... toggle tick boxes
! rboxes ... select from ganged tick boxes
!
! arguments to chkbox
! -------------------
!     n: intent (in)    number of items
!  text: intent (in)    labels for items
! title: intent (in)    header information
! useit: intent (inout) .true./.false.
!
! arguments to rboxes
! -------------------
!      irb: intent (inout) number of check box selected at each row
!                          Note that 1 =< irb(i) =< n_across
! n_across: intent (in)    number of ganged check boxes across
!   n_down: intent (in)    number of rows of ganged check boxes
! n_header: intent (in)    number of lines of header information
!   header: intent (in)    lines of header information
!     text: intent (in)    captions for rows of check boxes (width =< 20)
!
      program    main
      implicit   none
      integer    i, m, n, n_across, n_down, n_header
      parameter (n = 50, n_across = 10, n_down = 30, n_header = 2)
      integer    irb(n_down), irb_sav(n_down)
      character  cipher*4, header(n_header)*80, line*100, text(n)*20, &
                 title*30
      parameter (title = 'Tick to select items required')
      logical    useit(n)
      external   chkbox, putadv, rboxes, table1
!
! Code to demonstrate subroutine chkbox
!
      do i = 1, n
         write (text(i),100) i
         useit(i) = .false.
      enddo
      call chkbox (n, text, title, useit)
      m = 0
      do i = 1, n
         if (useit(i)) m = m + 1
      enddo
      write (line,200) m
      call putadv (line)
!
! Code to demonstrate subroutine rboxes
!
      write (header,300)
      do i = 1, n_down
         irb(i) = 1
         irb_sav(i) = irb(i)
         write (text(i),400) i
      enddo
      call rboxes (irb, n_across, n_down, n_header, &
                   header, text)
      m = 15
      call table1 (m, 'OPEN')
      write (line,500)
      m = 4
      call table1 (m, line)
      m = 0
      do i = 1, n_down
         if (irb(i).eq.irb_sav(i)) then
            cipher = '    '
         else
            cipher = '****'
         endif
         write (line,600) i, irb_sav(i), irb(i), cipher
         call table1 (m, line)
      enddo
      call table1 (m, 'CLOSE')
  100 format (' .... Item number',i3)
  200 format ('Number of items selected =',i3)
  300 format ( &
       'Demonstrating the Simfit multi check box routine' &
      /'Note that the check boxes are ganged across rows')
  400 format ('Check box row',i3)
  500 format ('Row  Before   After')
  600 format (i3,2i8,2x,a)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem59: multiple file selection
! ========
!
! subroutine
! ----------
! mfiles ... select a set of files
!
! arguments
! ---------
! nfiles: intent (out) number of files selected (=< nmax)
!   nmax: intent (in) maximum number of files to be selected (nmax >= 1)
!  files: intent (out) names of the files selected (just names)
!
      program    main
      implicit   none
      integer    i, j, nfiles, nmax
      parameter (nmax = 10)
      character  files(nmax)*1024
      character  word60*60, trim60*60
      external   mfiles, trim60, table1, putadv
      call mfiles (nfiles, nmax, &
                   files)
      if (nfiles.ge.1) then
         j = 15
         call table1 (j, 'OPEN')
         j = 4
         write (word60,100) nfiles
         call table1 (j, word60)
         j = 0
         do i = 1, nfiles
            word60 = trim60(files(i))
            call table1 (j, word60)
         enddo
         call table1 (J, 'CLOSE')
      else
         write (word60,200)
         call putadv (word60)
      endif
  100 format ('Number of files selected =',i3)
  200 format ('No files were selected')
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem60: comprehensive list box
! ========
!
! subroutine
! ----------
! lstbox ... list box with header and trailer
!
! arguments
! ---------
! numbld: intent (in) 0 for black, 1 for blue, or 4 for bold
! numdec: intent (inout) as follows:
!         on entry sets the pre-selected item
!         on exit returns the item selected or
!         the default Cancel or Quit item if
!         the closure cross is used.
! numopt: intent (in) number of options available
! numsta: intent (in) number of the starting line for menu items
! numtxt: intent (in) total number of text lines
!   text: intent (in) header, menu, then trailer
!
! Advice
! ------
! 1) The subroutine will only work if all arguments
!    are initalised correctly.
! 2) Grave accents (like `) create tabbing when in the
!    header or trailer text lines.
! 3) Grave accents (like `) in the menu items invoke a
!    different tabbing procedure which may suppress
!    colours set by numbld.
! 4) If a menu item contains words like Cancel, Exit,
!    or Quit, a default closure cross option is made
!    available which will select the option containing
!    the words Cancel, Exit, or Quit. For instance,
!    note the differences in the loop when i = 2.
!
      program    main
      implicit   none
      integer    i, numdec, numopt, numsta, numtxt
      parameter (numopt = 4, numsta = 5, numtxt = 11)
      integer    numbld(numtxt)
      character  line*100, text(numtxt)*100
      external   lstbox, putadv
      data       numbld / numtxt*0 /
      write (text, 100) numsta, numopt, numtxt
      numbld(1) = 4
      numbld(numtxt) = 1
      do i = 1, 2
         if (i.eq.2) text(numopt + numsta - 1) = 'Anything`else'
         numdec = 1
         call lstbox (numbld, numdec, numopt, numsta, numtxt, &
                      text)
         write (line,200) numdec
         call putadv (line)
      enddo
  100 format ( &
       'Example of a list box' &
      /'No. of start line',i3 &
      /'No. of options',i3 &
      /'No. text lines',i3 &
      /'Apples' &
      /'Oranges' &
      /'Plums' &
      /'Cancel ... No choice' &
      /'Extra text appears here' &
      /'Grave accents`used for tabbing' &
      /'numbld       `used for colours')
  200 format ('Option',i3,1x,'was selected')
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem61: normal and half normal plots
! =========
!
! subroutine
! ----------
! hnplot ... plot a vector as half or normal scores
!
! arguments
! ---------
! isend: intent (in) as follows:
!        isend = 1: half-normal
!        isend = 2: full-normal
!     n: intent (in) number of values
!     x: intent (in) vector of values
!
      program    main
      implicit   none
      integer    isend, n
      parameter (n = 40)
      double precision x(n)
      external   hnplot
      data x / &
      -0.2117D+01, -0.1583D+01, -0.1275D+01, -0.1202D+01, -0.1018D+01, &
      -0.8655D+00, -0.8011D+00, -0.6995D+00, -0.6744D+00, -0.5887D+00, &
      -0.5654D+00, -0.4868D+00, -0.4810D+00, -0.4470D+00, -0.4403D+00, &
      -0.3938D+00, -0.3613D+00, -0.2735D+00, -0.2422D+00, -0.2067D+00, &
      -0.1680D+00, -0.1423D+00, -0.1130D+00, -0.1040D+00, -0.7391D-01, &
      -0.6547D-02,  0.1313D+00,  0.1880D+00,  0.2213D+00,  0.2657D+00, &
       0.2844D+00,  0.5517D+00,  0.5544D+00,  0.5581D+00,  0.6531D+00, &
       0.7271D+00,  0.7323D+00,  0.1018D+01,  0.1561D+01,  0.1761D+01 /
!
! isend = 1: half normal
!
      isend = 1
      call hnplot (isend, n, x)
!
! isend = 2: normal
!
      isend = 2
      call hnplot (isend, n, x)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem62: bivariate confidence ellipses
! ========
!
! subroutines
! -----------
! g02cafg ... fit a straight line
! elips1  ... data and mean 95% confidence region
!
! arguments
! ---------
! For g02cafg ... (as for G02CAF)
!      n: intent (in) number of x,y pairs
!      x: intent (in) x-values
!      y: intent (in) y-values
! params: intent (out) vector of results (as for G02CAF)
!  ifail: intent (inout) (as for G02CAF)
!
! For elips1 ...
!      n: intent (in) number of x,y pairs
! params: intent (in) (as returned from G02CAF)
!      x: intent (in) x-values
!      y: intent (in) y-values
!
      program    main
      implicit   none
      integer    ifail, n
      parameter (n = 12)
      double precision x(n), y(n)
      double precision params(20)
      external g02cafg, elips1
      data x / &
      0.100D+01, 0.800D+01, 0.300D+01, 0.900D+01, 0.700D+01, 0.200D+01, &
      0.110D+02, 0.600D+01, 0.800D+01, 0.190D+02, 0.170D+02, 0.150D+02 /
      data y / &
      0.400D+01, 0.500D+01, 0.100D+01, 0.000D+00, 0.120D+02, 0.130D+02, &
      0.700D+01, 0.300D+01, 0.210D+02, 0.140D+02, 0.180D+02, 0.210D+02 /
!
! fit a line and retrieve all necessary parameters
!
      call g02cafg(n, x, y, params, ifail)
!
! now plot confidence ellipses for either
! a) estimates means x_bar and y_bar, or
! b) region expecting next new data point.
!
      call elips1 (n, params, x, y)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem63: plot rows and columns from a matrix
! ========
!
! subroutine
! -----------
! mtplot ... interpret rows or columns as x,y coordinates
!
! arguments
! ---------
! isend: intent (in) controls the plot types as follows:
!        1: vector supplied
!        2: columns only
!        3: rows only
!        4: rows and columns
! ncmax: intent (in) maximum column dimension
!  ncol: intent (in) actual number of columns for plotting
! nrmax: intent (in) maximumm row dimension
!  nrow: intent (in) actual number of rows for plotting
!     a: intent (in) nrow by ncol matrix
!
      program    main
      implicit   none
      integer    i, isend, j, k, ncmax, ncol, nrmax, nrow
      parameter (ncmax = 10, nrmax = 10)
      double precision a(nrmax,ncmax), x(36)
      external   mtplot
      data x / &
      0.100D+01, 0.800D+01, 0.300D+01, 0.900D+01, 0.700D+01, 0.200D+01, &
      0.110D+02, 0.600D+01, 0.800D+01, 0.190D+02, 0.170D+02, 0.150D+02, &
      0.400D+01, 0.500D+01, 0.100D+01, 0.000D+00, 0.120D+02, 0.130D+02, &
      0.700D+01, 0.300D+01, 0.210D+02, 0.140D+02, 0.180D+02, 0.210D+02, &
      0.120D+01, 0.790D+01, 0.470D+01, 0.940D+01, 0.370D+02, 0.110D+02, &
      0.940D+01, 0.860D+01, 0.150D+02, 0.130D-01, 0.720D-01, 0.340D+01 /
!
! set up matrix a
!
      ncol = 6
      nrow = 6
      k = 0
      do j = 1, ncol
         do i = 1, nrow
            k = k + 1
            a(i,j) = x(k)
         enddo
      enddo
!
! 1D, 2D, or 3D plots
!
      isend = 4
      call mtplot (isend, ncmax, ncol, nrmax, nrow, &
                   a)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem64: plot r = r(theta)
! ========
!
! subroutine and function
! -----------------------
! rtplot ... interpret r(theta) in x,y space
! x01aafg ... pi
!
!
! arguments
! ---------
!     n: intent (in) number of r(theta) pairs
!     r: intent (inout) input as r ... returned as y
! theta: intent (inout) input as theta ... returned as x
!
! Note: r and theta are returned as y and x
!
      program    main
      implicit   none
      integer    i, n
      parameter (n = 250)
      double precision r(n), theta(n)
      double precision delta, pi, x01aafg
      double precision zero, two, four
      parameter (zero = 0.0d+00, two = 2.0d+00, four = 4.0d+00)
      external   x01aafg, rtplot
      intrinsic  dble, sin
!
! calculate r = sin(4*theta)
!
      pi = x01aafg(delta)
      delta = two*pi/dble(n - 1)
      theta(1) = zero
      do i = 2, n - 1
         theta(i) = theta(i - 1) + delta
      enddo
      theta(n) = two*pi
      do i = 1, n
         r(i) = sin(four*theta(i))
      enddo
!
! plot the 8 leaved rose
!
      call rtplot (n, &
                   r, theta)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem65: select a file to view or open from a list
! ========
! For details read simdem.chm or simdem.html
!
! function
! --------
! aux256 ... returns the full path to simdem auxiliaries
!
! subroutine
! ----------
! vuopen ... choose a file from a list to view or open
!
! arguments
! ---------
! numdec: intent (inout) as follows:
!         on entry sets the default list box item
!         on exit returns the list box item selected
! numtxt: intent (in) number of text lines
! source: intent (in) text array
!   view: intent (inout) returned as user selects to view or open
!
      program    main
      implicit   none
      integer    isend, numdec, numtxt
      parameter (isend = 1, numtxt = 7)
      character  aux256*1024, fname*1024, trim80*80
      character  line*100, path*1, pattern*1
      character  source(numtxt)*12
      logical    repeet, there, view
      logical    askif
      parameter (askif = .false.)
      external   putadv, vuopen, viewer, trim80, deleet, &
                 aux256
!
! build up the list of files then initialise
!
      source(1) = 'simdem.for'
      source(2) = 'runsim.for'
      source(3) = 'simdem.f95'
      source(4) = 'runsim.f95'
      source(numtxt - 2) = 'Temp_File'
      source(numtxt - 1) = 'Missing_File'
      source(numtxt) = 'Cancel'
!
! create the temp file and make sure the missing file is missing
!
      fname = aux256(source(numtxt - 2))
      open (unit = 10, file = fname)
      write (10,'(a)') 'You are now reading the file called'
      write (10,'(a)') trim80(fname)
      close (unit = 10)
      call deleet (source(numtxt - 1), &
                   askif, there)
      path = ' '
      pattern = ' '
      numdec = numtxt - 2
      repeet = .true.
      view = .true.
!
! loop to view, open, cancel
!
      do while (repeet)
         call vuopen (numdec, numtxt, &
                      source, &
                      view)
         if (numdec.lt.numtxt) then
            if (numdec.le.5) then
!
! otherwise use the name allocated
!
               fname = source(numdec)
            else
!
! otherwise just use the names allocated
!
               fname = source(numdec)
            endif
            inquire (file = fname, exist = there)
            if (there) then
               if (view) then
                  call viewer (isend, &
                               fname, path, pattern)
               else
                  write (line,100) trim80(fname)
                  call putadv (line)
               endif
            else
               write (line,200) trim80(fname)
               call putadv (line)
            endif
         else
            repeet = .false.
         endif
      enddo
!
! delete the temporary file
!
      fname = aux256(source(numtxt - 2))
      call deleet (source(numtxt - 2), &
                   askif, there)
  100 format ('File to open:',1x,a)
  200 format ('Cannot locate',1x,a)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem66: Matrices ... read/write procedures
! ========
!
! subroutines
! -----------
! mat2in ... read in a matrix from a Simfit data file
! isitmf ... check if a file is a Simfit matrix file
!
! arguments
! ---------
! For mat2in ...
!   nin: intent (in) unit for file connection
! ncmax: intent (in) maximum column dimension
!  ncol: intent (inout) actual column dimension
! nrmax: intent (in) maximum row dimension
!  nrow: intent (inout) actual row dimension
!     b: intent (out) matrix
! fname: intent (inout) file name
! title: intent (inout) data title
! abort: intent (out) error indicator
!
! For isitmf ...
!  ncol: intent (out) number of columns (or 0 if error)
!  nrow: intent (out) number of rows (or 0 if error)
! fname: intent (in) file name
!
! For matout ...
!  isend, intent (in)    if 1, user supplies filename, then open new file
!                        if 2, filename as argument, then open new file
!                        if 3, filename already opened on unit nout
!   ncol, intent (in)    column size >= 1
!   nout, intent (in)    unit that must be connected if ISEND = 3
!  nrmax, intent (in)    leading dimension
!   nrow, intent (in)    row size >= 1
!  ntext, intent (in)    text size >= 1
!      a, intent (in)    data matrix
!  fname, intent (inout) file name
!   text, intent (in)    trailing text
!  title, intent (inout) title
!  abort, intent (out)   error indicator
! header, intent (in)    if .true. add header and trailing text
!  qtext, intent (in)    if .true. ask for text, otherwise use text supplied
! qtitle, intent (in)    if .true. ask for title, otherwise use title supplied
!
! Advice
! ------
! This program demonstrates how simfit writes wide matrices
! to file with fixed wrap round at column 50 but, if the
! header correctly specifies the number of rows and columns,
! the format is irrelevent as long as the data are arranged
! in row-major sequence. In other words, hard returns and
! wrap-round are of no significance when simfit reads in a
! matrix from a data file.
!
      program    main
      implicit   none
      integer    ncmax, nrmax, nwrap
      parameter (nwrap = 50, ncmax = nwrap + 2, nrmax = 9)
      integer    isend, jsend, nin, mout, nout, ntext
      parameter (isend = 2, jsend = 1, mout = 4, nin = 3, nout = 11, &
                 ntext = 1)
      integer    i, ios, j, ncol, nrow
      double precision factor
      parameter (factor = 100.0d+00)
      double precision a(nrmax,ncmax), b(nrmax,ncmax)
      character  aux256*1024, myfile*1024
      character  dfolt*10, path*1, pattern*1
      parameter (dfolt = 'matrix.tmp', path = ' ', pattern = ' ')
      character  line*100, title*80, text(ntext)*80
      logical    askif, header, qtext, qtitle
      parameter (askif = .false., header = .true., qtext = .false., &
                 qtitle = .false.)
      logical    abort, exist, read_only, there
      external   attrib, closer, deleet, matout, mat2in, putadv, putfat, &
                 viewer, aux256
      external   abdiff, fquery
      intrinsic  dble
!
! first of all check if myfile = matrix.tmp is accidentally read only
! note: myfile should be a variable and not a parameter as some simfit routines
!       are designed to left-trim filenames, change cases, etc.
!
      myfile = aux256(dfolt)
      call attrib (myfile, &
                   exist, read_only)
      if (read_only) then
!
! if so then complain and stop until the user issues ... attrib -r matrix.tmp
!
         write (line,100)
         call putfat (line)
      else
!
! otherwise delete matrix.tmp if necessary then generate matrix a
!
         if (exist) call deleet (myfile, &
                                 askif, there)
         ncol = ncmax
         nrow = nrmax
         do j = 1, ncol
            do i = 1, nrow
               a(i,j) = dble(i) + dble(j)/factor
            enddo
         enddo
!
! Example 1:
! ==========
! use procedure matout to write the matrix to myfile in genuine simfit style
! Note: closer must be used to close unit = mout before and after calling matout
! if the DLLs and executables are created using different compilers, as closer
! closes the same unit as matout uses to write the output file. The output
! format used by matout is 1p,50e13.5. Subroutine matout provides many options
! as will be clear from browsing the subroutine in the w_menus.dll source codes.
!
         title = 'Data written by matout to the file matrix.tmp'
         text(1) = 'Arbitrary extra line for further information'
         call closer (mout)
         call matout (isend, ncol, mout, nrmax, nrow, ntext, &
                      a, &
                      myfile, text, title, &
                      abort, header, qtext, qtitle)
         call closer (mout)
         if (.not.abort) then
!
! use isitmf to make sure file created is a valid simfit matrix-type file
!
            call fquery (ncol, nrow, &
                         myfile, &
                         abort)
         endif
         if (abort) then
!
! here only if the file could not be created for some reason
!
            write (line,200)
            call putfat (line)
         else
!
! otherwise advise user about default simfit wrap-round then display the file
!
            write (line,300)
            call putadv (line)
            call viewer (jsend, &
                         myfile, path, pattern)
!
! now read matrix b off the simfit style file matrix.tmp that has just been created
! note: closer can be used to close unit = nin before and after calling mat2in
!
            call closer (nin)
            call mat2in (nin, ncmax, ncol, nrmax, nrow, &
                         b, &
                         myfile, title, &
                         abort)
            call closer (nin)
            if (abort) then
!
! here only if failure to read b from myfile for some reason
!
               write (line,400)
               call putfat (line)
            else
!
! examine a - b for any differences
!
               call abdiff (ncol, nrmax, nrow, &
                            a, b)
!
! Example 2:
! ==========
! now create a file with simfit header but arbitrary column widths
! note: open and close can be used now instead of opener and closer as
!       the write operation is going to happen locally, not in the DLLs.
!
               title = 'Now header is OK but wrap-round is arbitrary'
               call deleet (myfile, &
                            askif, there)
               close (unit = nout)
               open (unit = nout, file = myfile)
               write (nout,'(a)',iostat=ios) title
               write (nout,'(2i6)',iostat=ios) nrow, ncol
               do i = 1, nrow
                  if (i.eq.1) then
                     write (nout,'(1p,5e13.5)',iostat=ios) &
                           (a(i,j), j = 1, ncol)
                  elseif (i.eq.2) then
                     write (nout,'(1p,10e13.5)',iostat=ios) &
                           (a(i,j), j = 1, ncol)
                  elseif (i.eq.3) then
                     write (nout,'(1p,20e13.5)',iostat=ios) &
                            (a(i,j), j = 1, ncol)
                  else
                     write (nout,'(1p,51e13.5)',iostat=ios) &
                           (a(i,j), j = 1, ncol)
                  endif
               enddo
               close (unit = nout)
!
! use isitmf to make sure file created is a valid simfit matrix-type file
!
               call fquery (ncol, nrow, &
                            myfile, &
                            abort)
               if (.not.abort) then
                  write (line,500)
                  call putadv (line)
                  call viewer (jsend, &
                               myfile, path, pattern)
                  call closer (nin)
                  call mat2in (nin, ncmax, ncol, nrmax, nrow, &
                               b, &
                               myfile, title, &
                               abort)
                  call closer (nin)
                  call abdiff (ncol, nrmax, nrow, &
                               a, b)
               endif
!
! Example 3:
! ==========
! finally create a file with a correct simfit header but with data as a vector
! note: the important point is that although the simfit default is to wrap-round
!       in output files at 50 columns, files with arbitrary rows and columns will
!       be read correctly as long as the header dimensions are correct and the
!       values are in row-major order.
!
               title = 'File with correct header but just one column'
               call deleet (myfile, &
                            askif, there)
               close (unit = nout)
               open (unit = nout, file = myfile)
               write (nout,'(a)',iostat=ios) title
               write (nout,'(2i6)',iostat=ios) nrow, ncol
               do i = 1, nrow
                  do j = 1, ncol
                     write (nout,'(1p,e13.5)') a(i,j)
                  enddo
               enddo
               close (unit = nout)
!
! use isitmf to make sure file created is a valid simfit matrix-type file
!
               call fquery (ncol, nrow, &
                            myfile, &
                            abort)
               if (.not.abort) then
                  write (line,600)
                  call putadv (line)
                  call viewer (jsend, &
                               myfile, path, pattern)
                  call closer (nin)
                  call mat2in (nin, ncmax, ncol, nrmax, nrow, &
                               b, &
                               myfile, title, &
                               abort)
                  call closer (nin)
                  call abdiff (ncol, nrmax, nrow, &
                               a, b)
               endif
            endif
         endif
      endif
  100 format ('Please issue the command ... attrib -r matrix.tmp')
  200 format ('Failure to write matrix A to the file matrix.tmp')
  300 format ('Example 1: note default simfit wrap-round at column 50')
  400 format ('Failure to read matrix B from the file matrix.tmp')
  500 format ('Example 2: note the arbitrary wrap-round positions')
  600 format ('Example 3: note if header OK a row-major vector will do')
      end
!
!...................................................................
!
      subroutine abdiff (ncol, nrmax, nrow, &
                         a, b)
!
! count the number of differences between matrices a and b
! Note: the arguments are not changed by this subroutine
!
      implicit   none
!
! arguments
!
      integer    ncol, nrmax, nrow
      double precision a(nrmax,ncol), b(nrmax,ncol)
!
! locals
!
      integer    i, j, numdiff
      double precision delta
      double precision epsi
      parameter (epsi = 0.005d+00)
      character  line*100
      external   putadv, putwar
      intrinsic  abs
      numdiff = 0
      do j = 1, ncol
         do i = 1, nrow
            delta = abs(a(i,j) - b(i,j))
            if (delta.gt.epsi) numdiff = numdiff + 1
         enddo
      enddo
      if (numdiff.eq.0) then
         write (line,100)
         call putadv (line)
      else
         write (line,200) numdiff
         call putwar (line)
      endif
  100 format ('The matrix has been read correctly from the file')
  200 format ('The number of differences betweeen A and B =',i5)
      end
!
!.....................................................................
!
      subroutine fquery (ncol, nrow, &
                         myfile, &
                         abort)
!
! use isitmf to check if the file is a valid simfit matrix type file
! Note: the arguments are unchanged except that abort is an output variable
!
      implicit  none
!
! arguments
!
      integer   ncol, nrow
      character myfile*(*)
      logical   abort
!
! locals
!
      integer   ncol1, nrow1
      external  isitmf, putadv, putfat
!
! subroutine isitmf returns ncol1 > 0 and nrow1 > 0 only if the file is
! a valid simfit matrix-type data file with ncol1 columns and nrow1 rows
!
      call isitmf (ncol1, nrow1, &
                   myfile)
      if (ncol1.eq.ncol .and. nrow1.eq.nrow) then
         abort = .false.
         call putadv ('File created is a valid simfit matrix-type file')
      else
         abort = .true.
         call putfat ('File created is not a simfit matrix-type file')
      endif
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem67: Matrices ... editing and transforming
! ========
!
! subroutine
! ----------
! mattrn ... input then edit and/or transform a matrix
!
! arguments
! ---------
! isend: intent (in) as follows:
!        isend = 1 only allows column operations
!        isend = 2 only allows row operations
!        isend = 3 allows row and column operations
!        isend = 4 as 3 except that title is not altered
! ncols: intent (in) number of columns
! nrmax: intent (in) leading dimension
! nrows: intent (in) number of rows
!     a: intent (inout) matrix
! title: intent (inout) data title
!
! Advice
! ------
! Matrix a is input to subroutine mattrn but then it is edited and
! transformed interactively and returned as output, i.e. changed
!
      program    main
      implicit   none
      integer    i, isend, j, ncols, ncmax, nrows, nrmax
      parameter (nrmax = 100, ncmax = 100)
      double precision a(nrmax,ncmax)
      double precision ten
      parameter (ten = 10.0d+00)
      character  title*80
      external   mattrn
      isend = 3
      nrows = 10
      ncols = 10
      do i = 1, nrows
         do j = 1, ncols
            a(i,j) = dble(i) + dble(j)/ten
         enddo
      enddo
      title = 'test matrix'
      call mattrn (isend, ncols, nrmax, nrows, &
                   a, &
                   title)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem68: Matrices ... default matrices of arbitrary size
! ========
!
! subroutines
! -----------
! mat3in ... try to open an arbitrary data file
! mat4in ... get a matrix from a known file or return for a new matrix
!
! arguments
! ---------
! For mat3in ...
!  isend: intent (inout) as follows:
!         isend = 1: user inputs data
!         isend = 2: data from a file
!   ncol: intent (inout) number of columns
!    nin: intent (in) unit for file connection
!   nrow: intent (inout) number of rows
!  fname: intent (out) file name
!  title: intent (out) data title
!  abort: intent (out) error indicator
! fixcol: intent (in) fixed number of columns = ncol if .true.
! fixrow: intent (in) fixed number of rows = nrow if .true.
!  label: intent (in) user supplies title if no file
!
! For mat4in ...
!  ncmax: intent (in) maximum column dimension
!   ncol: intent (in) actual column dimension
!  nrmax: intent (in) maximum row dimension
!   nrow: intent (in) actual row dimension
!      a: intent (inout) matrix
!  fname: intent (in) file name
! header: intent (in) header for menu
!  title: intent (inout) data title
!  abort: intent (out) error indicator
! newdat: intent (out) request for new data
! Advice
! ------
! This program demonstrates how to input default matrices from
! files, or how to provide an automatic default data set. The
! subroutine demo creates the necessary workspace to hold the
! matrix and any workspaces required and then analyses the data.
! Note that subroutine demo can easily be edited to read in or
! provide any number of default matrices by allocating workspaces
! as necessary before calling the subsequent procedures, as
! defined by the parameter isend passed to subroutine demo.
! For an example of how to do this, browse m_matone in the
! w_simfit.dll source codes.
!
!
      program    main
      implicit   none
      integer    ncmax, nrmax, nwrap
      parameter (nwrap = 50, ncmax = nwrap + 2, nrmax = 9)
      integer    isend, jsend, nin, nout
      parameter (isend = 1, jsend = 2, nout = 4, nin = 3)
      integer    i, j, ncol, nrow
      double precision factor
      parameter (factor = 100.0d+00)
      double precision a(nrmax,ncmax)
      character  fname*1024, results*1024, title*80
      external   deltmp, putadv, viewer, gettmp
      intrinsic  dble
      external   demo
!
! Part 1: create a temporary  file containing the matrix
! ======
!
!
! first of all generate myfile
!
      call gettmp (i, &
                   myfile)
      if (i.eq.0) then
!
! generate matrix a
         ncol = ncmax
         nrow = nrmax
         do j = 1, ncol
            do i = 1, nrow
               a(i,j) = dble(i) + dble(j)/factor
            enddo
         enddo
!
! write the matrix to myfile in simfit style
! note: subroutine closer is not required as opening and closing are local
!
         title = 'Arbitrary matrix written to a temporary file'
         close (unit = nout)
         open (unit = nout, file = myfile)
         write (nout,'(a)') title
         write (nout,'(2i6)') nrow, ncol
         do i = 1, nrow
            write (nout,'(1p,50e13.5)') (a(i,j), j = 1, ncol)
         enddo
         close (unit = nout)
!
! open an output file for the results from subroutine demo
!
          call gettmp (i, &
                      results)
         open (unit = nout, file = results)
         write (nout,'(a)') 'Log file for results from analysis'
         write (nout,'(a)') ' '
!
! Part 2: call demo with a default ... ncol, nrow, and myfile are consistent
! =======
!
         call putadv (
    +'First we call demo with known data: choose Analyse then Cancel')
         call demo (isend, ncol, nin, nout, nrow,
         call demo (isend, ncol, nin, nout, nrow, &
                    myfile, title)
!
! Part 3: call demo with no default ... ncol, nrow, and fname are inconsistent
! =======
!
         ncol = 0
         nrow = 0
         fname = 'no file'
         title = 'no data'
         call putadv ( &
      'Now input your own data matrix: choose Analyse then Cancel')
         call demo (jsend, ncol, nin, nout, nrow, &
                    fname, title)
         close (unit = nout)
         call putadv ( &
      'Now we view results that have been written to the log file')
         call viewer (isend, &
                     'results, ' ', ' ')
      endif
      end
!
!......................................................................
!
      subroutine demo (isend, ncol, nin, nout, nrow, &
                       fnamea, titlea)
!
! action: install a demo matrix then call the program indicated by isend
! author: w.g.bardsley, university of manchester, u.k.
!         derived from m_matone 07/06/2006
! advice: isend dictates the action required and sets the default
!         filename and matrix. However, if a correct filename is supplied
!         and ncol and nrow supplied on that file are correct and agree
!         with ncol and nrow in the argument list, then the matrix
!         supplied in fnamea will be used as the default.
!         To see how to adapt this routine for any number of procedures
!         and workspaces browse m_matone in the w_simfit.dll source codes
!
!   isend: (input/unchanged) as follows:
!           isend = 1: do_something
!           isend = 2: do_something_else
!           isend = 3: not asigned
!           isend = 4: etc.
!           isend = 5: etc.
!    ncol: (input/output) column size
!     nin: (input/unchanged) unconnected unit for data input
!    nout: (input/unchanged) preconnected unit for results
!    nrow: (input/output) row size
!  fnamea: (input/output) data file name
!  titlea: (input/output) data title
!
      implicit   none
!
! arguments
!
      integer    isend, ncol, nin, nout, nrow
      character  fnamea*(*), titlea*(*)
!
! local allocatable array
!
      double precision, allocatable :: a(:,:)
!
! locals
!
      integer    ierr, jsend, ncmax, ncol1, nrmax, nrow1
      integer    ncadd, nradd
      integer    nitems
      parameter (nitems = 5)
      integer    ncsav(nitems), nrsav(nitems)
      double precision temp
      character  no_data*30, no_file*30, title1*80
      parameter (no_data = 'No data', &
                 no_file = 'No file')
      character  header(nitems)*80, line*100, tfiles(nitems)*256, &
                 word15*15
      logical    abort, fixcol, fixrow, label, newdat, repeet
      parameter (fixcol = .false., fixrow = .false., label = .true.)
      external   isitmf, mat2in, mat3in, mat4in, putadv, closer
      external   do_something, do_something_else
      save       ncsav, nrsav, header, tfiles
!
!  data 1: ncsav holds the column dimensions for the default demo files
!          for isend = 1, 2, ..., nitems
!
      data       ncsav / 52, 52, 52, 52, 52 /
!
! data 2: nrsav holds the row dimensions for the default demo files
!         for isend = 1, 2, ..., nitems
!
      data       nrsav /  9,  9,  9,  9,  9 /
!
! data 3: header holds the information about the procedures being called from demo
!         for isend = 1, 2, ..., nitems
!
      data       header / &
      'Do something',        !1 &
      'Do something else',   !2 &
      'Not assigned',        !3 &
      'Not assigned',        !4 &
      'etc.' /               !5
!
! data 3: tfiles holds the actual file names for the procedures called from demo
!         for isend = 1, 2, ..., nitems
!
       data      tfiles / &
      'matrix.tf1',    !1 &
      'matrix.tf1',    !2 &
      'matrix.tf1',    !3 &
      'matrix.tf1',    !4 &
      'matrix.tf1' /   !5
!
! check isend then initialise ncadd and nradd if it is necessary for
! ncmax > ncol or nrmax > nrow, e.g., bordered matrices for workspace
!
      if (isend.lt.1 .or. isend.gt.5) return
      ncadd = 2
      nradd = 2
!
!------------------------------------------------------------
! Start of code to access a matrix
!------------------------------------------------------------
!
      if (ncol.le.0 .or. nrow.le.0) then
!
! install a default if nrow or ncol =< 0
!
         fnamea = tfiles(isend)
         ncol = ncsav(isend)
         nrow = nrsav(isend)
      endif
      repeet = .true.
      do while (repeet)
!
! Step 1: if ncol > 0 and nrow > 0 check if fname supplied is a current matrix file
! ======= isitmf returns ncol1 > 0 and nrow1 > 0 if fnamea is a matrix file
!
         ncol1 = 0
         nrow1 = 0
         if (ncol.gt.0 .and. nrow.gt.0) call isitmf (ncol1, nrow1, &
                                                     fnamea)
!
! Step 2: if fnamea is not a matrix file of correct size try to open a file
! ======= mat3in selects a matrix file of size nrow1 > 0 by ncol1 > 0 if successful
!
         if (ncol1.le.0 .or. nrow1.le.0 .or. &
             ncol1.ne.ncol .or. nrow1.ne.nrow) then
            ncol = 0
            nrow = 0
            fnamea = no_file
            titlea = no_data
            jsend = 3
            call closer (nin)
            word15 = 'matrix.tf1'
            write (line,100) word15
            call putadv (line)
            call mat3in (jsend, ncol1, nin, nrow1, &
                         fnamea, titlea, &
                         abort, fixcol, fixrow, label)
            call closer (nin)
            if (abort) then
               ncol = 0
               nrow = 0
               fnamea = no_file
               titlea = no_data
               return
            endif
         endif
         if (ncol1.le.0 .or. nrow1.le.0) return
!
! Step 3: we now have a matrix file of size nrow > 0 by ncol > 0 so allocate workspaces
! ======  if there is any error then ierr is nonzero and exit happens
!
         ncol = ncol1
         nrow = nrow1
         ierr = 0
         if (allocated(a)) deallocate(a, stat = ierr)
         if (ierr.ne.0) return
         ncmax = ncol + ncadd
         nrmax = nrow + nradd
         allocate(a(nrmax,ncmax), stat = ierr)
         if (ierr.ne.0) return
!
! Step 4: read in the data consisting of nrow by ncol points from file fnamea
! ======= if an error occurs then workspaces are deallocated and exit occurs
!         otherwise fnamea and titlea are not changed from now on
!
         call closer (nin)
         call mat2in (nin, ncmax, ncol, nrmax, nrow, &
                      a, &
                      fnamea, titlea, &
                      abort)
         call closer (nin)
         if (abort) then
            deallocate (a, stat = ierr)
            ncol = 0
            nrow = 0
            fnamea = no_file
            titlea = no_data
            return
         endif
!
! Step 5: see what the user wants to do ... title may change in mat4in
! ======= mat4in is the equivalent of vecone offering as follows:
!         abort = .true. on return: deallocate workspaces then exit
!         newdat = .true. on return: try for a new data set
!         newdat = .false. on return: proceed with original or edited data
!         title1 is altered if the data are edited but title is unchanged
!
         title1 = titlea
         call mat4in (ncmax, ncol, nrmax, nrow, &
                      a, &
                      fnamea, header(isend), title1, &
                      abort, newdat)
         if (abort) then
!
! Option 1 on return from mat4in: Deallaocate then exit
! --------
!
            deallocate (a, stat = ierr)
            return
         elseif (newdat) then
!
! Option 2 on return from from mat4in: New data
! --------
!
            fnamea = no_file
            titlea = no_data
            ncol = 0
            nrow = 0
         else
!
! Option 3 on return from from mat4in: Proceed to analysis
! --------
!
            ncol1 = ncol
            nrow1 = nrow
            newdat = .true.
            if (isend.eq.1) then
               call do_something (ncmax, ncol1, nout, nrmax, nrow1, &
                                  a, &
                                  fnamea, titlea)
            elseif (isend.eq.2) then
               temp = a(1,1)
               call do_something_else (nout, &
                                       temp, &
                                       fnamea, titlea)
            else
               call putadv ('No action assigned')
            endif
            if (.not.newdat) then
               deallocate(a, stat = ierr)
               return
            endif
         endif
      enddo
!------------------------------------------------------------
! End of code to access a matrix
!------------------------------------------------------------
!
  100 format ('Now input a file formatted like',1x,a)
      end
!
!............................................................
!
      subroutine do_something (ncmax, ncol, nout, nrmax, nrow, &
                               a, &
                               fname, title)
      implicit  none
!
! arguments
!
      integer   ncmax, ncol, nout, nrmax, nrow
      double precision a(nrmax,ncmax)
      character fname*(*), title*(*)
!
! locals
!
      integer   i, j
      character chop80*80, trim80*80
      character line*100
      external  chop80, putadv, trim80
      if (ncol.lt.1 .or. ncol.gt.ncmax .or. &
          nrow.lt.1 .or. nrow.gt.nrmax) return
      write (nout,100) trim80(fname), chop80(title)
      i = 1
      j = 1
      write (line,200) i, j, a(i,j)
      write (nout,'(a)') line
      call putadv (line)
  100 format ( &
      /'Results from subroutine do_something' &
      / &
      /'File:',1x,a &
      /'Title:',1x,a &
      /a)
  200 format ('A(',i2,',',i2,') =',1pe11.3)
      end
!
!...............................................
!
      subroutine do_something_else (nout, &
                                    temp, &
                                    fname, title)
      implicit   none
!
! arguments
!
      integer    nout
      double precision temp
      character  fname*(*), title*(*)
!
! locals
!
      integer    i, j
      parameter (i = 1, j = 1)
      character  chop80*80, line*100, trim80*80
      external   chop80, putadv, trim80
      write (line,100) i, j, temp
      call putadv (line)
      write (nout,200) trim80(fname), chop80(title), line
  100 format ('A(',i2,',',i2,') =',1pe11.3)
  200 format ( &
      /'Results from subroutine do_something_else' &
      / &
      /'File:',1x,a &
      /'Title:',1x,a &
      /a)
      end
!
!
Back to Menu or Programs: Brief description
!
! simdem69: plot a vector field with labels, e.g. for a matrix biplot
! ========
!
! subroutine
! ----------
! gksvf3 ... display a vector field with arbitrary arrows and labels
!
! arguments
! ---------
! iarrow: intent (in) arrow type
! ikolor: intent (in) arrow colour
! jarrow: intent (in) number of arrows
! jcolor: intent (in) text colour
! lcolor: intent (in) background colour
!      m: intent (in) label displacement type (use 0)
!   ngks: intent (in) gks transformation to use (use 0)
!  hsize: intent (in) arrow head size
!  tsize: intent (in) label text size
! x1, y1: intent (in) arrow head position
! x2, y2: intent (in) arrow tail position
! x3, y3: intent (in) label position
! label1: intent (in) text label
! label2: intent (in) text key (for maths, superscripts, subscripts, etc.)
! ptitle: intent (in) plot title
! xtitle: intent (in) x legend
! ytitle: intent (in) y legend
!   axes: intent (in) plot axes (may be unused in this version)
!  gsave: intent (in) option to save (may be unused in this version)
!
      program    main
      implicit   none
      integer    nmax, nplots
      parameter (nmax = 16, nplots = nmax)
      integer    i
      integer    iarrow(nmax), ikolor(nmax), jarrow, jcolor, lcolor, &
                 m, ngks
      integer    black, blue, green, red, white
      parameter (black = 0, blue = 9, green = 10, red = 12, white = 15)
      double precision hsize(nmax), x1(nmax), x2(nmax), x3(nmax), &
                       y1(nmax), y2(nmax), y3(nmax)
      double precision addtox, addtoy, delta, denom, r, theta, tsize
      double precision zero, half, one, two, twopi
      parameter (zero = 0.0d+00, half = 0.5d+00, one = 1.0d+00, &
                 two = 2.0d+00, twopi = 6.2831853d+00)
      character  label1(nmax)*2, label2(nmax)*2
      character  ptitle*20, xtitle*20, ytitle*20
      parameter (ptitle = 'arrows', &
                 xtitle = 'x', &
                 ytitle = 'y')
      logical    axes, gsave
      parameter (axes = .true., gsave = .true.)
      external   gksvf3
      intrinsic  dble
!
! initialise colours and various sizes
!
      lcolor = white
      jcolor = black
      m = 0
      jarrow = nplots
      ngks = 0
      tsize = 0.75d+00
      addtox = 0.05d+00
      addtoy = 0.05d+00
      delta = twopi/dble(jarrow)
      theta = - delta
      denom = two*dble(nplots)
!
! generate the coordinates and label displacements
!
      do i = 1, nplots
         write (label1(i),'(i2)') i
         label2(i) = '00'
         theta = theta + delta
         if (i.le.5) then
            iarrow(i) = 1
            ikolor(i) = black
         elseif (i.le.9) then
            iarrow(i) = 16
            ikolor(i) = blue
         elseif (i.le.13) then
            iarrow(i) = 2
            ikolor(i) = green
         else
            iarrow(i) = 3
            ikolor(i) = red
         endif
         hsize(i) = 0.01d+00
         r = dble(i - 1)/denom
         x2(i) = r*cos(theta)
         y2(i) = r*sin(theta)
         x1(i) = cos(theta)
         y1(i) = sin(theta)
         x3(i) = x1(i)
         y3(i) = y1(i)
         if (x3(i).gt.addtox) then
            x3(i) = x3(i) + addtox
         elseif (x3(i).lt.-addtox) then
            x3(i) = x3(i) - two*addtox
         endif
         if (y3(i).gt.addtoy) then
            y3(i) = y3(i) + addtoy
         elseif (y3(i).lt.-addtoy) then
            y3(i) = y3(i) - two*addtoy
         endif
      enddo
!
! display the plot
!
      call gksvf3 (iarrow, ikolor, jarrow, jcolor, lcolor, m, ngks, &
                   hsize, tsize, x1, x2, x3, y1, y2, y3, &
                   label1, label2, &
                   ptitle, xtitle, ytitle, &
                   axes, gsave)
      end
!
!
Back to Menu or Simfit home page
!
!
! simdem70: comprehensive illustration of the simfit plotting styles
! ========
! For details read simdem.chm or simdem.html
!
! The idea behind this program is to collect together a set of calls
! to the user-friendly front ends for the Simfit plotting routines so
! that users of the Simdem package can quickly see what is available.
! The sample sizes can be altered interactively for some of these calls
! to illustrate the effects encountered with very small or very large
! data sets. More details can be found from the headers in the Simdem
! source code for the individual routines or in the w_graphics.dll
! source codes available from https://simfit.org.uk
!
      program    main
      implicit   none
      integer    ncmax, ndend, nmax, nout, npmax, nrmax, nsmax, ntheta, &
                 nwmax
      parameter (ncmax = 20, ndend = 5, nmax = 10000, nout = 4, &
                 npmax = 50, nrmax = 500, nsmax = 100, ntheta = 250, &
                 nwmax = 2000)
      integer    l0, l1, l2, m0, m5, m8
      parameter (l0 = 0, l1 = 1, l2 = 2, m0 = 0, m5 = 5, m8 = 8)
      integer    i, ifail, isend, itype, i1, i2, i3, j, k, ntemp, &
                 numbld(30), numdec, numopt, numtxt
      integer    mode
      parameter (mode = 0)
      integer    ncol, nfiles, nlab, npie, nrow
      integer    jcolor(15), l(15), m(15), n(15)
      integer    ifill(npmax), ihue(npmax)
      integer    nbins, nobs(nwmax), nset, nsur, nvec
      integer    ilc(ndend - 1), iuc(ndend - 1), iord(ndend)
      integer    iarrow(nmax), ikolor(nmax), jarrow, lcolor, ngks
      parameter (lcolor = 15, ngks = 0)
      integer    ncdf, nsamp, ncdmax
      parameter (ncdf = 10, nsamp = 20, ncdmax = 2*nsamp)
      integer    ncbins, npdf, npdmax, nsamp1
      parameter (ncbins = 5, npdf = 20, nsamp1 = 40, npdmax = 4*nsamp1)
      integer    jarrow_vf
      parameter (jarrow_vf = 16)
      integer    iarrow_vf(jarrow_vf), ikolor_vf(jarrow_vf), &
                 jcolor_vf, lcolor_vf, m_vf, ngks_vf
      integer    black, blue, green, red, white
      parameter (black = 0, blue = 9, green = 10, red = 12, white = 15)
      double precision a, atemp, btemp
      parameter (a = 20.0d+00)
      double precision e(nmax), xh(nmax), yh(nmax)
      double precision x1(nmax), x2(nmax),  x3(nmax),  x4(nmax), &
                       x5(nmax), x6(nmax),  x7(nmax),  x8(nmax), &
                       x9(nmax), x10(nmax), x11(nmax), x12(nmax)
      double precision y1(nmax), y2(nmax),  y3(nmax),  y4(nmax), &
                       y5(nmax), y6(nmax),  y7(nmax),  y8(nmax), &
                       y9(nmax), y10(nmax), y11(nmax), y12(nmax)
      double precision yh1(nmax), yh3(nmax), yl1(nmax), yl3(nmax)
      double precision xx1(nmax), xx2(nmax), yy1(nmax), yy2(nmax)
      double precision xp(nmax), xptemp(nmax), yp(nmax), yptemp(nmax)
      double precision x(nrmax,ncmax), xvec(nmax), yvec(nmax)
      double precision r(ntheta), t(ntheta)
      double precision fact(npmax)
      double precision vector(nsmax**2 + 6), xmax, xmin, ymax, ymin, &
                       z(nsmax,nsmax)
      double precision delta, r1, r2, hsize(nmax), params(20), theta, &
                       twopi
      double precision cd(ndend - 1), thresh, xdend(ndend,3)
      double precision cdf(ncdf), sample(nsamp), tcdf(ncdf), &
                       xcdf(nrmax), ycdf(nrmax), zcdf(nrmax)
      double precision pdf(npdf), sampl1(nsamp1), tpdf(npdf), &
                       xpdf(npdmax), ypdf(npdmax)
      double precision g05cafg, g05ddfg, x01aafg
      double precision error, four, head, one, two, zero
      parameter (error = 0.25d+00, four = 4.0d+00, head = 0.01d+00, &
                 one = 1.0d+00, two = 2.0d+00, zero = 0.0d+00)
      double precision addtox, addtoy, hsize_vf(jarrow_vf), tsize_vf, &
                       x1_vf(jarrow_vf), x2_vf(jarrow_vf), &
                       x3_vf(jarrow_vf), &
                       y1_vf(jarrow_vf), y2_vf(jarrow_vf), &
                       y3_vf(jarrow_vf)
      character  labels(nwmax)*4
      character  ptitle*40, xtitle*20, ytitle*20
      character  ptitl1(2)*40, xtitl1(2)*20, ytitl1(2)*20
      character  temp(20)*100, text(50)*100, titles(4)*40
      character  files(12)*1024, wordx(ndend)*1
      character  label1_vf(jarrow_vf)*2, label2_vf(jarrow_vf)*2
      character  ptitle_vf*18, xtitle_vf*1, ytitle_vf*1
      parameter (ptitle_vf = 'Arrows with Labels', xtitle_vf = 'x', &
                 ytitle_vf = 'y')
      character  blank*1
      parameter (blank = ' ')
      logical    unused(nsmax,nsmax)
      logical    axes, gsave, repeet
      parameter (axes = .true., gsave = .true.)
      external   listbx, getjm1, putfat, gettmp, deltmp, patch2, &
                 gks001, gks004, gks012, gkst04, gkst12, gkseb4, gkscb4, &
                 gkshb4, gksvf1, gksvf3, &
                 bcplot, bwplot, ebplot, hist01, hnplot, lbplot, mtplot, &
                 pcplot, tsplot, space0, surd2s, elips1, smplot, rtplot, &
                 dgplot, cdplot, pdplot, demo3d, sbplot, xfonts, resdef
      external   editps, images, double_plot, configure_plots, &
                 configure_labels, configure_symbols, configure_keys, &
                 configure_panels, configure_sizes, configure_nsteps, replay
      external   g05cafg, g05ccfg, g05ddfg, g02cafg, x01aafg
      intrinsic  dble, sin, cos, min
      data numbld / 30*0 /
      data ilc   / 2, 1, 1, 1 /
      data iuc   / 4, 3, 5, 2 /
      data iord  / 1, 3, 5, 2, 4 /
      data cd    / 1.0d+00, 2.0d+00, 6.5d+00, 14.13d+00 /
      data wordx / 'A', 'B', 'C', 'D', 'E' /
      data sample / &
      -0.1251D+01, -0.8949D+00, -0.8082D+00, -0.7000D+00, -0.6648D+00, &
      -0.3640D+00, -0.3588D+00, -0.3125D+00, -0.3073D+00, -0.2855D+00, &
      -0.8175D-01,  0.1030D+00,  0.1130D+00,  0.1229D+00,  0.2740D+00, &
       0.4958D+00,  0.5124D+00,  0.8592D+00,  0.1301D+01,  0.1565D+01 /
      data tcdf / &
      -0.1251D+01, -0.9381D+00, -0.6252D+00, -0.3124D+00,  0.5063D-03, &
       0.3134D+00,  0.6262D+00,  0.9391D+00,  0.1252D+01,  0.1565D+01 /
      data cdf / &
      0.1343D+00,  0.2528D+00,  0.3948D+00,  0.5116D+00,  0.5501D+00, &
      0.4909D+00,  0.3635D+00,  0.2233D+00,  0.1139D+00,  0.4819D-01 /
      data sampl1 / &
      -0.2117D+01, -0.1583D+01, -0.1275D+01, -0.1202D+01, -0.1018D+01, &
      -0.8655D+00, -0.8011D+00, -0.6995D+00, -0.6744D+00, -0.5887D+00, &
      -0.5654D+00, -0.4868D+00, -0.4810D+00, -0.4470D+00, -0.4403D+00, &
      -0.3938D+00, -0.3613D+00, -0.2735D+00, -0.2422D+00, -0.2067D+00, &
      -0.1680D+00, -0.1423D+00, -0.1130D+00, -0.1040D+00, -0.7391D-01, &
      -0.6547D-02,  0.1313D+00,  0.1880D+00,  0.2213D+00,  0.2657D+00, &
       0.2844D+00,  0.5517D+00,  0.5544D+00,  0.5581D+00,  0.6531D+00, &
       0.7271D+00,  0.7323D+00,  0.1018D+01,  0.1561D+01,  0.1761D+01 /
      data tpdf / &
      -0.2117D+01, -0.1913D+01, -0.1709D+01, -0.1505D+01, -0.1301D+01, &
      -0.1097D+01, -0.8924D+00, -0.6883D+00, -0.4841D+00, -0.2800D+00, &
      -0.7582D-01,  0.1283D+00,  0.3325D+00,  0.5366D+00,  0.7407D+00, &
       0.9449D+00,  0.1149D+01,  0.1353D+01,  0.1557D+01,  0.1761D+01 /
      data pdf / &
      0.2165D-01,  0.4036D-01,  0.7028D-01,  0.1143D+00,  0.1736D+00, &
      0.2463D+00,  0.3263D+00,  0.4038D+00,  0.4668D+00,  0.5040D+00, &
      0.5082D+00,  0.4786D+00,  0.4210D+00,  0.3459D+00,  0.2654D+00, &
      0.1902D+00,  0.1273D+00,  0.7961D-01,  0.4649D-01,  0.2536D-01 /
!
! initialise random number generator and starting parameters
!
      call g05ccfg
      twopi = two*x01aafg(delta)
      nbins = 5
      ncol = 4
      nfiles = 3
      nlab = 20
      npie = 8
      nrow = 5
      nset = 5
      nsur = 20
      ntemp = 20
      nvec = 20
!
! initialise values for gks routines that remain unaltered
!
      do i = 1, 12
         jcolor(i) = i
         l(i) = 0
         m(i) = i
         n(i) = ntemp
      enddo
      do i = 1, nmax
         x1(i) = dble(i)
         x2(i) = x1(i)
         x3(i) = x1(i)
         x4(i) = x1(i)
         x5(i) = x1(i)
         x6(i) = x1(i)
         x7(i) = x1(i)
         x8(i) = x1(i)
         x9(i) = x1(i)
         x10(i) = x1(i)
         x11(i) = x1(i)
         x12(i) = x1(i)
      enddo
!
! initialise yj(i) values that depend on the current value of ntemp
! note parameter a < yj(i)and yj(i) > 0 for possible transforms
!
      delta = twopi/dble(ntemp)
      do i = 1, ntemp
         y1(i) = two + sin(x1(i)*delta)
         y2(i) = y1(i) + one
         y3(i) = y2(i) + one
         y4(i) = y3(i) + one
         y5(i) = y4(i) + one
         y6(i) = y5(i) + one
         y7(i) = y6(i) + one
         y8(i) = y7(i) + one
         y9(i) = y8(i) + one
         y10(i) = y9(i) + one
         y11(i) = y10(i) + one
         y12(i) = y11(i) + one
         yh1(i) = y1(i) + error
         yh3(i) = y3(i) + error
         yl1(i) = y1(i) - error
         yl3(i) = y3(i) - error
         xp(i) = cos(two*x1(i)*delta)
         yp(i) = sin(two*x1(i)*delta)
      enddo
!
! initialise vector field data
!
      j = 0
      k = 0
      delta = twopi/50.0d+00
      r2 = error
      r1 = r2 + error
      do i = 1, nmax
         e(i) = error
         j = j + 1
         if (j.eq.51) then
            j = 1
            r1 = r1 + two*error
            r2 = r2 + two*error
            if (k.eq.14) then
               k = 0
            else
               k = k + 1
            endif
         endif
         ikolor(i) = k
         theta = dble(i)*delta
         xx1(i) = r1*cos(theta)
         yy1(i) = r1*sin(theta)
         xx2(i) = r2*cos(theta)
         yy2(i) = r2*sin(theta)
      enddo
      do i = 1, nmax
        iarrow(i) = 1
        hsize(i) = head
      enddo
!
! initialise random matrix x(i,j) >= 0 for possible bar chart
!
      atemp = zero
      btemp = one
      do j = 1, ncmax
         do i = 1, nrmax
            x(i,j) = two + g05cafg(theta) + g05ddfg(atemp, btemp)
            if (x(i,j).lt.zero) x(i,j) = zero
         enddo
      enddo
!
! initialise labels
!
      do i = 1, nwmax
         write (labels(i),'(i4)') i
      enddo
!
! end of initialisation and start of main loop
! ============================================
!
      numdec = 1
      repeet = .true.
      do while (repeet)
         write (temp,100)
         do i = 1, 19
            text(i) = temp(i)
         enddo
         write (temp,101)
         numopt = 45
         do i = 20, 38
            text(i) = temp(i - 19)
         enddo
         write (temp,102) ntemp
         do i = 39, numopt
            text(i) = temp(i - 38)
         enddo
         write (ptitle,200) ntemp
         xtitle = 'x-axis'
         ytitle = 'y-axis'
         call listbx (numdec, numopt, text)
         if (numdec.eq.1) then
!
! numdec = 1: help
!
            write (text,300)
            numtxt = 21
            numbld(1) = 1
            numbld(13) = 1
            numbld(16) = 1
            numbld(19) = 1
            call patch2 (numbld, numtxt, &
                         text)
         elseif (numdec.eq.2) then
!
! numdec = 2: single plot
!
            call gks001 (l(1), m(1), n(1), &
                         x1, &
                         y1, &
                         ptitle, xtitle, ytitle)
         elseif (numdec.eq.3) then
!
! numdec = 3: up to 4 plots
!
            call gks004 (l(1), l(2), l(3), l(4), &
                         m(1), m(2), m(3), m(4), &
                         n(1), n(2), n(3), n(4), &
                         x1, x2, x3, x4, &
                         y1, y2, y3, y4, &
                         ptitle, xtitle, ytitle, &
                         axes, gsave)
         elseif (numdec.eq.4) then
!
! numdec = 4: up to 12 plots
!
            call gks012 (l(1), l(2), l(3), l(4),  l(5),  l(6), &
                         l(7), l(8), l(9), l(10), l(11), l(12), &
                         m(1), m(2), m(3), m(4),  m(5),  m(6), &
                         m(7), m(8), m(9), m(10), m(11), m(12), &
                         n(1), n(2), n(3), n(4),  n(5),  n(6), &
                         n(7), n(8), n(9), n(10), n(11), n(12), &
                         x1, x2, x3, x4,  x5,  x6, &
                         x7, x8, x9, x10, x11, x12, &
                         y1, y2, y3, y4,  y5,  y6, &
                         y7, y8, y9, y10, y11, y12, &
                         ptitle, xtitle, ytitle, &
                         axes, gsave)
!
! numdec= 5: up to 4 transforms
!
         elseif (numdec.eq.5) then
            call gkst04 (l(1), l(2), l(3), l(4), &
                         m(1), m(2), m(3), m(4), &
                         n(1), n(2), n(3), n(4), &
                         a, &
                         x1, x2, x3, x4, &
                         y1, y2, y3, y4, &
                         ptitle, xtitle, ytitle, &
                         axes, gsave)
         elseif (numdec.eq.6) then
!
! numdec = 6: up to 12 transforms
!
            call gkst12 (l(1), l(2), l(3), l(4),  l(5),  l(6), &
                         l(7), l(8), l(9), l(10), l(11), l(12), &
                         m(1), m(2), m(3), m(4),  m(5),  m(6), &
                         m(7), m(8), m(9), m(10), m(11), m(12), &
                         n(1), n(2), n(3), n(4),  n(5),  n(6), &
                         n(7), n(8), n(9), n(10), n(11), n(12), &
                         a, &
                         x1, x2, x3, x4,  x5,  x6, &
                         x7, x8, x9, x10, x11, x12, &
                         y1, y2, y3, y4,  y5,  y6, &
                         y7, y8, y9, y10, y11, y12, &
                         ptitle, xtitle, ytitle, &
                         axes, gsave)
         elseif (numdec.eq.7) then
!
! numdec = 7: up to 2 standard error bars and best fit curves
!
            call gkseb4 (l0, l1, l0, l2, &
                         m5, m0, m8, m0, &
                         n(1), n(2), n(3), n(4), &
                         x1, x2, x3, x4, &
                         yh1, yh3, yl1, yl3, y1, y2, y3, y4, &
                         ptitle, xtitle, ytitle, &
                         axes, gsave)
         elseif (numdec.eq.8) then
!
! numdec = 8: as gkseb4 but restricted for such as bar chart use
!
            call gkscb4 (l0, l1, l0, l2, &
                         m5, m0, m8, m0, &
                         n(1), n(2), n(3), n(4), &
                         x1, x2, x3, x4, &
                         yh1, yh3, yl1, yl3, y1, y2, y3, y4, &
                         ptitle, xtitle, ytitle, &
                         axes, gsave)
         elseif (numdec.eq.9) then
!
! numdec = 9: swapped error bars for horizontal use such as log-odds
!
            itype = 1! must be 1 for log-e or 2 for log-10
            ptitl1(1) = 'Interchanged axes'!title for simple graph
            ptitl1(2) = ptitle             !true plot title (for simplot)
            xtitl1(1) = 'x'                !y legend for simple graph
            xtitl1(2) = ytitle             !true x-title (for simplot)
            if (itype.eq.1) then
               ytitl1(1) = 'log_e(y)'      !x legend for simple graph
            else
               ytitl1(1) = 'log_10(y)'     !x legend for simple graph
            endif
            ytitl1(2) = xtitle             !true y-title (for simplot)
            call gkshb4 (itype, &
                         l0, l1, l0, l2, &
                         m5, m0, m8, m0, &
                         n(1), n(2), n(3), n(4), &
                         x1, x2, x3, x4, &
                         yh1, yh3, yl1, yl3, y1, y2, y3, y4, &
                         ptitl1, xtitl1, ytitl1, &
                         axes, gsave)
         elseif (numdec.eq.10) then
!
! numdec = 10: vector field
!
            jarrow = ntemp
            call gksvf1 (iarrow, ikolor, jarrow, lcolor, ngks, &
                         hsize, xx1, xx2, yy1, yy2, &
                         ptitle, xtitle, ytitle, &
                         axes, gsave)
         elseif (numdec.eq.11) then
!
! numdec = 11: vector field with labels, e.g. for matrix bi-plot
!
            lcolor_vf = white
            jcolor_vf = black
            m_vf = 0
            ngks_vf = 0
            tsize_vf = one
            addtox = 0.05d+00
            addtoy = 0.05d+00
            delta = twopi/dble(jarrow_vf)
            theta = - delta
            do i = 1, jarrow_vf
               write (label1_vf(i),'(i2)') i
               label2_vf(i) = '00'
               theta = theta + delta
               if (i.le.5) then
                  iarrow_vf(i) = 1
                  ikolor_vf(i) = black
               elseif (i.le.9) then
                  iarrow_vf(i) = 16
                  ikolor_vf(i) = blue
               elseif (i.le.13) then
                  iarrow_vf(i) = 2
                  ikolor_vf(i) = green
               else
                  iarrow_vf(i) = 3
                  ikolor_vf(i) = red
               endif
               hsize_vf(i) = 0.01d+00
               x2_vf(i) = zero
               y2_vf(i) = zero
               x1_vf(i) = cos(theta)
               y1_vf(i) = sin(theta)
               x3_vf(i) = x1_vf(i)
               y3_vf(i) = y1_vf(i)
               if (x3_vf(i).gt.addtox) then
                  x3_vf(i) = x3_vf(i) + addtox
               elseif (x3_vf(i).lt.-addtox) then
                  x3_vf(i) = x3_vf(i) - two*addtox
               endif
               if (y3_vf(i).gt.addtoy) then
                  y3_vf(i) = y3_vf(i) + addtoy
               elseif (y3_vf(i).lt.-addtoy) then
                  y3_vf(i) = y3_vf(i) - two*addtoy
               endif
            enddo
            call gksvf3 (iarrow_vf, ikolor_vf, jarrow_vf, jcolor_vf, &
                         lcolor_vf, m_vf, ngks_vf, &
                         hsize_vf, tsize_vf, &
                         x1_vf, x2_vf, x3_vf, &
                         y1_vf, y2_vf, y3_vf, &
                         label1_vf, label2_vf, &
                         ptitle_vf, xtitle_vf, ytitle_vf, &
                         axes, gsave)
         elseif (numdec.eq.12) then
!
! numdec = 12: bar chart plot
!
            i1 = 2
            i2 = ncmax
            call getjm1 (i1, ncol, i2, 'No. of columns required')
            i2 = nrmax
            call getjm1 (i1, nrow, i2, 'No. of rows required')
            isend = 2
            titles(1) = 'Bar Chart'
            titles(2) = 'Columns'
            titles(3) = 'Rows'
            titles(4) = blank
            call bcplot (isend, ncol, nrmax, nrow, &
                         x, &
                         labels, titles)
         elseif (numdec.eq.13) then
!
! numdec = 13: stack plot
!
            i1 = 2
            i2 = ncmax
            call getjm1 (i1, ncol, i2, 'No. of columns required')
            i2 = nrmax
            call getjm1 (i1, nrow, i2, 'No. of rows required')
            isend = 2
            titles(1) = 'Stack Plot'
            titles(2) = 'Columns'
            titles(3) = 'Rows'
            titles(4) = blank
            call sbplot (isend, ncol, nrmax, nrow, &
                         x, &
                         labels, titles)
         elseif (numdec.eq.14 .or. numdec.eq.17) then
!
! numdec = 14: boxes and whiskers
! numdec = 17: bar chart with error bars
!
            i1 = 1
            i2 = nwmax/4
            if (nset.gt.i2) nset = i2
            call getjm1 (i1, nset, i2, 'No. of bars required')
            j = nwmax/nset
            nvec = 0
            atemp = zero
            btemp = one
            do i = 1, nset
               nobs(i) = j
               do k = 1, j
                  nvec = nvec + 1
                  xvec(nvec) = two + g05ddfg(atemp, btemp)
                  if (xvec(nvec).lt.zero) xvec(nvec) = zero
               enddo
            enddo
            isend = 2
            titles(2) = 'Groups'
            titles(3) = 'Values'
            titles(4) = ' '
            if (numdec.eq.14) then
               titles(1) = 'Boxes and Whiskers'
               call bwplot (isend, nobs, nset, nvec, &
                            xvec, &
                            labels, titles)
            else
               titles(1) = 'Error Bar Plot'
               call ebplot (isend, nobs, nset, nvec, &
                            xvec, &
                            labels, titles)
            endif
         elseif (numdec.eq.15) then
!
! numdec = 15: cdf plot
!
            titles(1) = 'Sample and best-fit cdf'
            titles(2) = 'Values'
            titles(3) = 'CDF and step function'
            call cdplot (ncdf, ncdmax, nsamp, &
                         cdf, sample, tcdf, xcdf, ycdf, zcdf, &
                         titles(1), titles(2), titles(3))
         elseif (numdec.eq.16) then
!
! numdec = 16: dendrogram
!
             thresh = 5.0d+00
             titles(1) = 'Dendrogram'
             titles(2) = 'Item'
             titles(3) = 'Metric'
             call dgplot (ilc, iuc, iord, ndend, ndend, &
                          cd, thresh, xdend, &
                          titles(1), wordx, titles(2), titles(3))
         elseif (numdec.eq.18) then
!
! numdec = 18: bivariate confidence ellipses
!
            atemp = zero
            btemp = two
            do i = 1, ntemp
               xvec(i) = g05ddfg(atemp, btemp)
               yvec(i) = g05ddfg(atemp, btemp)
            enddo
            ifail = 0
            call g02cafg(ntemp, xvec, yvec, params, ifail)
            if (ifail.eq.0) then
               call elips1 (ntemp, params, xvec, yvec)
            else
               call putfat ('failure in call to g02caf')
            endif
         elseif (numdec.eq.19) then
!
! numdec = 19: histograms
!
            i1 = 2
            i2 = min(ntemp,200)
            if (nbins.gt.i2) nbins = i2
            call getjm1 (i1, nbins, i2, 'No. of bins required')
            call hist01 (nbins, nmax, j, &
                         e, x1, xh, y1, yh, &
                         gsave)
         elseif (numdec.eq.20) then
!
! numdec = 20: normal or half normal plots
!
            atemp = zero
            btemp = two
            do i = 1, ntemp
               yvec(i) = g05ddfg(atemp, btemp)
            enddo
            isend = 1
            call hnplot (isend, ntemp, &
                         yvec)
            isend = 2
            call hnplot (isend, ntemp, &
                         yvec)
         elseif (numdec.eq.21) then
!
! numdec = 21: labels plot
!
            i1 = 2
            i2 = nwmax
            if (nlab.gt.i2) nlab = i2
            call getjm1 (i1, nlab, i2, 'No. of labels required')
            atemp = zero
            btemp = one
            do i = 1, nlab
               xvec(i) = g05ddfg(atemp, btemp)
               yvec(i) = g05ddfg(atemp, btemp)
            enddo
            write (ptitle,200) nlab
            call lbplot (nlab, &
                         xvec, yvec, &
                         ptitle, labels, xtitle, ytitle)
         elseif (numdec.eq.22) then
!
! numdec = 22: matrix plots
!
            i1 = 2
            i2 = ncmax
            call getjm1 (i1, ncol, i2, 'No. of columns required')
            i2 = nrmax
            call getjm1 (i1, nrow, i2, 'No. of rows required')
            isend = 4
            call mtplot (isend, ncmax, ncol, nrmax, nrow, &
                         x)
         elseif (numdec.eq.23) then
!
! numdec = 23: pie chart
!
            i1 = 2
            i2 = npmax
            if (npie.gt.i2) npie = i2
            call getjm1 (i1, npie, i2, 'No. of segments required')
            isend = 1
            call pcplot (isend, ifill, ihue, npie, &
                         fact, x1, &
                         labels, 'Pie Chart')
         elseif (numdec.eq.24) then
!
! numdec = 24: pdf
!
            titles(1) = 'Histogram and best-fit pdf'
            titles(2) = 'Values'
            titles(3) = 'Bins and pdf'
            call pdplot (ncbins, npdf, npdmax, nsamp1, &
                         pdf, sampl1, tpdf, xpdf, ypdf, &
                         titles(1), titles(2), titles(3))
         elseif (numdec.eq.25) then
!
! numdec = 25: r(theta)
!
            delta = twopi/dble(ntheta - 1)
            t(1) = zero
            do i = 2, ntheta - 1
               t(i) = t(i - 1) + delta
            enddo
            t(ntheta) = twopi
            do i = 1, ntheta
               r(i) = sin(four*t(i))
            enddo
            call rtplot (ntheta, &
                         r, t)
         elseif (numdec.eq.26) then
!
! numdec = 26: arbitrary number of plots
!
            i1 = 1
            i2 = 12
            if (nfiles.gt.i2) nfiles = i2
            call getjm1 (i1, nfiles, i2, 'No. of plots required')
            do i = 1, nfiles
               call gettmp (j, files(i))
               open (unit = nout, file = files(i))
               write (nout,'(a)') blank
               write (nout,'(2i4)') ntemp, 2
               do j = 1, ntemp
                  atemp = x1(j)
                  if (i.eq.1) then
                     btemp = y1(j)
                  elseif (i.eq.2) then
                     btemp = y2(j)
                  elseif (i.eq.3) then
                     btemp = y3(j)
                  elseif (i.eq.4) then
                     btemp = y4(j)
                  elseif (i.eq.5) then
                     btemp = y5(j)
                  elseif (i.eq.6) then
                     btemp = y6(j)
                  elseif (i.eq.7) then
                     btemp = y7(j)
                  elseif (i.eq.8) then
                     btemp = y8(j)
                  elseif (i.eq.9) then
                     btemp = y9(j)
                  elseif (i.eq.10) then
                     btemp = y10(j)
                  elseif (i.eq.11) then
                     btemp = y11(j)
                  elseif (i.eq.12) then
                     btemp = y12(j)
                  endif
                  write (nout,'(1p,2e11.3)') atemp, btemp
               enddo
               close(unit = nout)
            enddo
            write(titles(1),200) ntemp
            titles(2) = 'x'
            titles(3) = 'y'
            titles(4) = blank
            call smplot (jcolor, l, m, nfiles, files, titles)
            call deltmp
         elseif (numdec.eq.27) then
!
! numdec = 27: time series
!
            do i = 1, ntemp
               yvec(i) = y1(i) - two
            enddo
            i1 = 1
            i2 = 0
            isend = 2
            call tsplot (isend, i1, i2, ntemp, &
                         one, xvec, xvec, one, yvec, &
                         ptitle, xtitle, ytitle)
            isend = 4
            call tsplot (isend, i1, i2, ntemp, &
                         one, xvec, xvec, one, yvec, &
                         ptitle, xtitle, ytitle)
         elseif (numdec.eq.28) then
!
! numdec = 28: spiral
!
            call space0 (ntemp, nmax, &
                         xp, xptemp, yp, yptemp, x1)
         elseif (numdec.eq.29) then
!
! numdec = 29: 3D surface/bar chart/contours
!
            i1 = 10
            i2 = nsmax
            if (nsur.gt.i2) nsur = i2
            call getjm1 (i1, nsur, i2, 'No. of divisions required')
            xmin = - one
            xmax = one
            ymin = - one
            ymax = one
            delta = (xmax - xmin)/(dble(nsur - 1))
            atemp = xmin - delta
            do j = 1, nsur
               atemp = atemp + delta
               btemp = ymin - delta
               do i = 1, nsur
                  btemp = btemp + delta
                  z(i,j) = btemp**2 - atemp**2
               enddo
            enddo
            isend = 4
            call surd2s (isend, nsmax, nsur, nsur, &
                         vector, xmax, xmin, ymax, ymin, z, &
                         unused)
         elseif (numdec.eq.30) then
!
! numdec = 30: 3D curves/swarms/vectors
!
            call demo3d
         elseif (numdec.eq.31) then
!
! numdec = 31: images
!
            call images (mode)
         elseif (numdec.eq.32) then
!
! numdec = 32: PostScript procedures
!
            call editps
         elseif (numdec.eq.33) then
!
! numdec = 33: double plot
!
            call double_plot
         elseif (numdec.eq.34) then
!
! numdec = 34: configure plot styles and colours
!
            call configure_plots
         elseif (numdec.eq.35) then
!
! numdec = 35: configure lines, symbols, and colours
!
            call configure_symbols
         elseif (numdec.eq.36) then
!
! numdec = 36: configure labels
!
            call configure_labels
         elseif (numdec.eq.37) then
!
! numdec = 37: configure character keys
!
            call configure_keys
         elseif (numdec.eq.38) then
!
! numdec = 38: configure font sizes
!
            call configure_sizes
         elseif (numdec.eq.39) then
!
! numdec = 39: configure panels
!
            call configure_panels
         elseif (numdec.eq.40) then
!
! numdec = 40: configure nsteps
!
            call configure_nsteps
         elseif (numdec.eq.41) then
!
! numdec = 41: display font maps
!
            call xfonts
!
! numdec = 42: restore defaults
!
         elseif (numdec.eq.42) then
            i1 = 0
            call resdef (i1)
!
! numdec = 43: replay a metafile
!
            call replay
         elseif (numdec.eq.numopt - 1) then
!
! numdec = 44: change ntemp and re-set y1 through to y12
!
            i1 = 5
            i2 = ntemp
            i3 = nmax
            call getjm1 (i1, i2, i3, 'New value required')
            if (i2.ne.ntemp) then
               ntemp = i2
               do i = 1, 12
                  n(i) = ntemp
               enddo
               delta = twopi/dble(ntemp)
               do i = 1, ntemp
                  y1(i) = two + sin(x1(i)*delta)
                  y2(i) = y1(i) + one
                  y3(i) = y2(i) + one
                  y4(i) = y3(i) + one
                  y5(i) = y4(i) + one
                  y6(i) = y5(i) + one
                  y7(i) = y6(i) + one
                  y8(i) = y7(i) + one
                  y9(i) = y8(i) + one
                  y10(i) = y9(i) + one
                  y11(i) = y10(i) + one
                  y12(i) = y11(i) + one
                  yh1(i) = y1(i) + error
                  yh3(i) = y3(i) + error
                  yl1(i) = y1(i) - error
                  yl3(i) = y3(i) - error
                  xp(i) = cos(two*x1(i)*delta)
                  yp(i) = sin(two*x1(i)*delta)
               enddo
            endif
         elseif (numdec.eq.numopt) then
!
! numdec = numopt: exit loop
!
            repeet = .false.
         endif
      enddo
!
! delete all temporary files
!
      call deltmp
!
! format statements
!
  100 format ( &
       'Help  `Details                              ` ' &
      /'gks001`no. of plots = 1                     `*' &
      /'gks004`no. of plots =< 4                    `*' &
      /'gks012`no. of plots =< 12                   `*' &
      /'gkst04`no. of transforms =< 4               `*' &
      /'gkst12`no. of transforms =< 12              `*' &
      /'gkseb4`error bars...standard                `*' &
      /'gkscb4`error bars...restricted              `*' &
      /'gkshb4`error bars...rotated                 `*' &
      /'gksvf1`vector field                         `*' &
      /'gksvf3`vector field with labels             ` ' &
      /'bcplot`bar chart                            ` ' &
      /'sbplot`stack plot                           ` ' &
      /'bwplot`box and whisker plot                 ` ' &
      /'cdplot`cumulative and cdf                   ` ' &
      /'dgplot`dendrogram                           ` ' &
      /'ebplot`bar chart with error bars            ` ' &
      /'elips1`confidence ellipses                  `*' &
      /'hist01`histograms                           ` ')
  101 format ( &
       'hnplot`normal/half-normal plot              `*' &
      /'lbplot`plot with labels                     ` ' &
      /'mtplot`columns/rows from matrix             ` ' &
      /'pcplot`pie chart                            ` ' &
      /'pdplot`histogram and pdf                    ` ' &
      /'rtplot`parametric r = r(theta)              ` ' &
      /'smplot`n advanced plots                     `*' &
      /'tsplot`time series                          `*' &
      /'space0`parametric space curve               `*' &
      /'surd2s`surface/contour/barchart             ` ' &
      /'space6`3D curves/swarms/vectors             ` ' &
      /'images`display examples                     ` ' &
      /'editps`Postscript collages and procedures   ` ' &
      /'dbplot`one x-scale but two y-scales         ` ' &
      /'gstyle`edit/restore default plot features   ` ' &
      /'symcfg`configure symbols/lines/colours      ` ' &
      /'labcfg`configure labels/keys/fill-styles    ` ' &
      /'defkey`define maths/accents/sub/superscripts` ' &
      /'tsizes`adjust font sizes                    ` ')
  102 format ( &
       'deflab`define labels/panels/character-keys  ` ' &
      /'nsteps`create gaps between data plotted     ` ' &
      /'xfonts`display Simfit font substitution maps` ' &
      /'resdef`restore Simfit 2D plotting defaults  ` ' &
      /'mfplot`replay a metafile to resume editing  ` ' &
      /'edit n`current n =',i6,'                    `*' &
      /'Cancel`Exit program SIMDEM70                ` ')
  200 format ('Plot with n =',i6)
  300 format ('Calling the Simfit graphics routines'/ &
      /'This program provides a convenient way to explore the standard' &
      /'plotting types you can call from w_menus.dll and w_graphics.dll' &
      /'These DLLs also contain many more advanced subroutines that' &
      /'can also be called, as the DLLs are compiled with exportall.' &
      / &
      /'Many of the routines have a size parameter (n) which you can' &
      /'alter to observe the effects of different sample sizes. Such' &
      /'routines are indicated by a *, meaning that editing the value' &
      /'for n changes the sample size for all routines so indicated.' &
      / &
      /'1) The quick way to find out the calling sequences' &
      /'Look at the argument lists in the source code for this program.' &
      / &
      /'2) For some further details' &
      /'Scan the simdem sources for the program calling the routine.' &
      / &
      /'3) For comprehensive details' &
      /'Read the headers in the corresponding DLL source files, which' &
      /'can be downloaded from https://simfit.org.uk.')
      end
!
!----------------------------------------------------------------------
!
      subroutine demo3d
!
! Demonstrate how to call space6 for 3D space curves, swarms, labels,
! perpendiculars, and vectors
!
!  call space6 (nfiles, &             ... integer, number of files to be plotted
!               fnames, &            ... character, files with x,y coordinates
!               plot_arrows, &       ... logical
!               plot_labels, &       ... logical
!               plot_lines,  &       ... logical
!               plot_perpendiculars, &... logical
!               plot_symbols)        ... logical
!
      implicit   none
      integer    i, ifail, j, n, nfiles, nout, numdec
      integer    nmax, numopt, ncols
      parameter (nmax = 50, numopt = 7, ncols = 3)
      double precision zero, one, two, three, pi, stretch1, stretch2
      parameter (zero = 0.0d+00, one = 1.0d+00, two = 2.0d+00, &
                 three = 3.0d+00, pi = 3.1415927d+00, &
                 stretch1 = 0.666d+00, stretch2 = 1.50d+00)
      double precision delta
      double precision t(nmax), x(nmax), y(nmax), z(nmax)
      character  fnames(4)*1024
      character  text(numopt)*80
      character  file1*1024, file2*1024, file3*1024, file4*1024, &
                 file5*1024
      character  begin_labels*13, end_labels*11, title*25
      parameter (begin_labels = 'begin{labels}', &
                   end_labels = 'end{labels}', &
                        title = 'Temporary File for demo3D')
      logical    repeet
      logical    askif, there
      parameter (askif = .false.)
      logical    plot_arrows, plot_labels, plot_lines, &
                 plot_perpendiculars, plot_symbols
      external   listbx, space6, gettmp, deleet, getnou
      intrinsic  cos, sin, dble
!
! find an unopened unit
!
      call getnou (nout)
!
! inititialise logical varaiables
!
      plot_arrows = .false.
      plot_labels = .false.
      plot_lines = .false.
      plot_perpendiculars = .false.
      plot_symbols = .false.
!
! Define t
!
      n = nmax
      t(1) = zero
      t(n) = two*pi
      delta = (t(n) - t(1))/(dble(n) - one)
      do i = 2, n - 1
         t(i) = t(i - 1) + delta
      enddo
!
! Define x, y, z as a helix
!
      x(1) = one
      y(1) = zero
      z(1) = one
      do i = 2, n - 1
         delta = two*t(i)
         x(i) = cos(delta)
         y(i) = sin(delta)
         z(i) = dble(i)
      enddo
      x(n) = x(1)
      y(n) = y(1)
      z(n) = dble(n)
!
! file1 just contains x, y, z data
!
      call gettmp (ifail, &
                   file1)
      open (unit = nout, file = file1)
      write (nout,'(a)') title
      write (nout,'(2i6)') n, ncols
      do i = 1, n
        write (nout,'(3e12.4)') x(i), y(i), z(i)
      enddo
      close (unit = nout)
!
! file2 contains an interior helix
!
      call gettmp (ifail, &
                   file2)
      open (unit = nout, file = file2)
      write (nout,'(a)') title
      write (nout,'(2i6)') n, ncols
      do i = 1, n
        write (nout,'(3e12.4)') x(i)/two, y(i)/two, stretch1*z(i)
      enddo
      close (unit = nout)
!
! file3 contains another interior helix
!
      call gettmp (ifail, &
                   file3)
      open (unit = nout, file = file3)
      write (nout,'(a)') title
      write (nout,'(2i6)') n, ncols
      do i = 1, n
        write (nout,'(3e12.4)') x(i)/three, y(i)/three, stretch2*z(i)
      enddo
      close (unit = nout)
!
! file4 contains a subset of file1 but with labels added
!
      call gettmp (ifail, &
                   file4)
      open (unit = nout, file = file4)
      write (nout,'(a)') title
      write (nout,'(2i6)') n/2, ncols
      do i = 1, n/2
        write (nout,'(3e12.4)') x(i), y(i), z(i)
      enddo
      write (nout,'(a)') begin_labels
      do i = 1, n/2
         if (i.lt.10) then
            write (nout,'(a1,i1)') 'A', i
         elseif (i.lt.100) then
            write (nout,'(a1,i2)') 'A', i
         else
            write (nout,'(a1,i3)') 'A', i
         endif
      enddo
      write (nout,'(a)') end_labels
      close (unit = nout)
!
! file5 contains a subset of file2 but with labels added
!
      call gettmp (ifail, &
                   file5)
      open (unit = nout, file = file5)
      write (nout,'(a)') title
      write (nout,'(2i6)') n/2 - 15, ncols
      j = -1
      do i = 1, n/2 - 15
        j = j + 2
        write (nout,'(3e12.4)') x(j)/two, y(j)/two, stretch1*z(j)
      enddo
      write (nout,'(a)') begin_labels
      j = -1
      do i = 1, n/2 - 15
         j = j + 2
         if (j.lt.10) then
            write (nout,'(a1,i1)') 'B', j
         elseif (j.lt.100) then
            write (nout,'(a1,i2)') 'B', j
         else
            write (nout,'(a1,i3)') 'B', j
         endif
      enddo
      write (nout,'(a)') end_labels
      close (unit = nout)
!
! The main loop
!
      write (text,100)
      repeet = .true.
      do while (repeet)
          numdec = numopt
          call listbx (numdec, numopt, &
                       text)
          if (numdec.eq.1) then
!
! curves
!
             nfiles = 3
             fnames(1) = file1
             fnames(2) = file2
             fnames(3) = file3
             plot_lines = .true.
             call space6 (nfiles, &
                          fnames, &
                          plot_arrows, &
                          plot_labels, &
                          plot_lines, &
                          plot_perpendiculars, &
                          plot_symbols)
             plot_lines = .false.
          elseif (numdec.eq.2) then
!
! swarms
!
             nfiles = 3
             fnames(1) = file1
             fnames(2) = file2
             fnames(3) = file3
             plot_symbols = .true.
             call space6 (nfiles, &
                          fnames, &
                          plot_arrows, &
                          plot_labels, &
                          plot_lines, &
                          plot_perpendiculars, &
                          plot_symbols)
             plot_symbols = .false.
          elseif (numdec.eq.3) then
!
! swarms with perpendiculars
!
             nfiles = 2
             fnames(1) = file4
             fnames(2) = file5
             plot_symbols = .true.
             plot_perpendiculars = .true.
             call space6 (nfiles, &
                          fnames, &
                          plot_arrows, &
                          plot_labels, &
                          plot_lines, &
                          plot_perpendiculars, &
                          plot_symbols)
             plot_symbols = .false.
             plot_perpendiculars = .false.
          elseif (numdec.eq.4) then
!
! swarms with labels
!
             nfiles = 2
             fnames(1) = file4
             fnames(2) = file5
             plot_symbols = .true.
             plot_labels = .true.
             call space6 (nfiles, &
                          fnames, &
                          plot_arrows, &
                          plot_labels, &
                          plot_lines, &
                          plot_perpendiculars, &
                          plot_symbols)
             plot_symbols = .false.
             plot_labels = .false.
          elseif (numdec.eq.5) then
!
! arrows
!
             nfiles = 2
             fnames(1) = file4
             fnames(2) = file5
             plot_arrows = .true.
             call space6 (nfiles, &
                          fnames, &
                          plot_arrows, &
                          plot_labels, &
                          plot_lines, &
                          plot_perpendiculars, &
                          plot_symbols)
             plot_arrows = .false.
          elseif (numdec.eq.6) then
!
! arrows with labels
!
             nfiles = 2
             fnames(1) = file4
             fnames(2) = file5
             plot_arrows = .true.
             plot_labels = .true.
             call space6 (nfiles, &
                          fnames, &
                          plot_arrows, &
                          plot_labels, &
                          plot_lines, &
                          plot_perpendiculars, &
                          plot_symbols)
             plot_arrows = .false.
             plot_labels = .false.
          elseif (numdec.eq.numopt) then
             repeet = .false.
          endif
      enddo
!
! delete temporary files
!
      call deleet (file1, &
                   askif, there)
      call deleet (file2, &
                   askif, there)
      call deleet (file3, &
                   askif, there)
      call deleet (file4, &
                   askif, there)
      call deleet (file5, &
                   askif, there)
!
! format statement
!
  100 format ( &
       'Demonstrate 3D curves' &
      /'Demonstrate 3D swarms' &
      /'Demonstrate 3D swarms with perpendiculars' &
      /'Demonstrate 3D swarms with labels' &
      /'Demonstrate 3D vectors' &
      /'Demonstrate 3D vectors with labels' &
      /'Cancel ... No more demonstrations')
      end
!
!----------------------------------------------------------------------
!
      subroutine editps
!
! action: front end to the DLL version of the Simfit Editps program
!
! call editps_driver
!
      implicit   none
      integer    nout
      character  aux256*1024, temp*1024
      character  fname*12, title*6
      parameter (fname = 'f$simfit.tmp', &
                 title = 'editps')
      logical    askif, there
      parameter (askif = .false.)
      external   aux256, deleet, getnou, putadv
      external   editps_driver
!
! Create the editps identifier file f$simfit.tmp so the [Demo] button will work
!
      temp = aux256(fname)
      call getnou (nout)
      open (unit = nout, file = temp)
      write (nout,'(a)') title
      close (unit = nout)
!
! Inform users that the [Demo] button can be used
!
      call putadv ('Use the [Demo] file selection option for EDITPS test files')
!
! call the editps driver interface
!
      call editps_driver
!
! delete the identifier file
!
      call deleet (temp, &
                   askif, there)
      end
!
!----------------------------------------------------------------------
!
      subroutine double_plot
!
! Calling dbplot to plot data with one X-scale and two Y-scales
!
!  call dbplot (jfiles, lfiles, mfiles, nfiles,
! +             files, titles,
! +             left_axis)
!
! jfiles: intent (in) = JCOLOR vector (colours)
! lfiles: intent (in) = L vector (line types)
! mfiles: intent (in) = M vector (symbol types)
! nfiles: intent (in) = Number of files
!  files: intent (in) = FSAV (coordinate files)
! titles: intent (in) = Title, x-, y-, z-legends
!
      implicit   none
      integer    ncols, nfiles, nout
      parameter (ncols = 2, nfiles = 4, nout = 10)
      integer    jfiles(nfiles), lfiles(nfiles), mfiles(nfiles)
      integer    i, j, nrows
      double precision x(11)
      double precision ten
      parameter (ten = 10.0d+00)
      character  files(nfiles)*1024, titles(4)*80
      logical    left_axis(nfiles)
      logical    askif, there
      parameter (askif = .false.)
      external   dbplot, deleet, gettmp
      intrinsic  dble
!
! Make a vector of X-coordinates 0, 1, ..., 10
!
      do i = 1, 11
        x(i) = dble(i - 1)
      enddo
!
! Create the data files 1, 2, ..., nfiles
!
      do i = 1, nfiles
         call gettmp (j, &
                      files(i))
         open (unit = nout, file = files(i))
         write (nout,'(a)') files(i)
         if (i.eq.1) then
!
! Straight line from 0 to 5 plotted to left hand axis
!
            jfiles(i) = 0
            lfiles(i) = 1
            mfiles(i) = 5
            left_axis(i) = .true.
            nrows = 5
            write (nout,'(2i3)') nrows, ncols
            do j = 1, nrows
               write (nout,'(1p,2e13.5)') x(j), x(j)
            enddo
            close(unit = nout)
         elseif (i.eq.2) then
!
! Straight line from 6 to 10 plotted to left hand axis
!
            jfiles(i) = 4
            lfiles(i) = 2
            mfiles(i) = 8
            left_axis(i) = .true.
            nrows = 5
            write (nout,'(2i3)') nrows, ncols
            do j = 1, nrows
               write (nout,'(1p,2e13.5)') x(j + 6), x(j + 6)
            enddo
            close(unit = nout)
         elseif (i.eq.3) then
!
! Parabola plotted to right hand axis
!
            jfiles(i) = 1
            lfiles(i) = 3
            mfiles(i) = 11
            left_axis(i) = .false.
            nrows = 11
            write (nout,'(2i3)') nrows, ncols
            do j = 1, nrows
               write (nout,'(1p,2e13.5)') x(j), x(j)*(x(j) - ten)
            enddo
            close(unit = nout)
         elseif (i.eq.4) then
!
! Inverted parabola plotted to right hand axis
!
            jfiles(i) = 2
            lfiles(i) = 4
            mfiles(i) = 14
            left_axis(i) = .false.
            nrows = 11
            write (nout,'(2i3)') nrows, ncols
            do j = 1, nrows
               write (nout,'(1p,2e13.5)') x(j), - x(j)*(x(j) - ten)
            enddo
            close(unit = nout)
         endif
      enddo
!
! Create the titles
!
      titles(1) = 'Example of a Double Plot'
      titles(2) = 'X-axis'
      titles(3) = 'Left hand axis'
      titles(4) = 'Right hand axis'
!
! Call dbplot
!
      call dbplot (jfiles, lfiles, mfiles, nfiles, &
                   files, titles, &
                   left_axis)
!
! Deleet the temporary files
!
      do i = 1, nfiles
         call deleet (files(i), &
                      askif, there)
      enddo
      end
!
!----------------------------------------------------------------------
!
      subroutine configure_plots
!
! Subroutine configure_plots shows users how to alter the graphics parameters
! such as style and colour interactively from a menu, or by direct input.
! The specification for the subroutines called are now listed, but note that
! the advanced plot defaults are set by the configuration routine config.
!-----------------------------------------------------------------------------------
! call gkscol (isend, jcol, kcol, numj, numk)
!
! Re-sets colours temporarily for items displayed in the simple graphics procedures.
! isend, numj, and numk are integer intent (in), the rest are integer intent (inout)
!
! isend = 1: set colours jcol and kcol directly
! isend = 2: set colours jcol and kcol from a menu
! jcol(1) = Plot title
! jcol(2) = Plot legends
! jcol(3) = Plot labels
! jcol(4) = Plot axes
! jcol(5) = Plot background
! jcol(6) to jcol(12)  = ***Unassigned
! kcol(i) = colour for data set(i) for i = 1, 15
! numj = dimension of jcol (e.g. 15)
! numk = dimension of kcol (e.g. 15)
!-----------------------------------------------------------------------------------
!  call gkslgl (isend, nlgl,
! +             varlgl)
! Defines logical defaults for the simple graphics procedures.
! isend and nlgl are integer intent (in) the rest are logical intent (inout)
! Note: This subroutine alters default settings in w_graphs.cfg
!
! isend = 1: set default values directly
! isend = 2: set default values from a menu
! isend = 3: retrieve default values
!      nlgl: number of logical variables (7 or more, depending on version)
!    varlgl: Meaning of logical variables varlgl(nlgl) is as follows:
!  (1) Box round data plotted                  ... default = .true.
!  (2) Frame round outside of figure           ... default = .false.
!  (3) Offset X, Y axes                        ... default = .false.
!  (4) Grid at X-tic marks parallel to Y axis  ... default = .false.
!  (5) Grid at Y-tic marks parallel to X axis  ... default = .false.
!  (6) Cross hairs at 0,0 if in range          ... default = .false.
!  (7) Tick marks pointing in                  ... default = .true.
!
!-----------------------------------------------------------------------------------
!  call grflgl (isend, nlgl,
! +             varlgl)
! Exactly as for gkslgl except logical variables are for advanced graphics
! with additional options 8 to 12 as follows.
!
!  (8) Advanced only: Display a panel           ... default = .false.
!  (9) Advanced only: Panel at RHS of plot      ... default = .false.
! (10) Advanced only: Show line type in panel   ... default = .true.
! (11) Advanced only: Show symbol type in panel ... default = .true.
! (12) Advanced only: Border round plot         ... default = .false.
!----------------------------------------------------------------------------------
!  call gstyle (n,
! +            la, ls, store)
!
! Edit then store, or else retrieve current plotting styles held in w_graphs.cfg.
! Note: This subroutine alters default settings in w_graphs.cfg
!
!     n is integer intent (in) : dimension of la and ls (e.g. 12 or more depending on version)
! la(n) is logical intent (out): advanced logicals
! ls(n) is logical intent (out): simple logicals
! store is logical intent (in) : controls action i.e. edit then save, or retrieve
!-----------------------------------------------------------------------------------
! call resdef (itype)
!
! This subroutine is not usually necessary, but it makes sure that all the plotting
! parameters are initialised, and restores plot style parameters to Simfit defaults
! It over-writes current data in the graphics configuration files.
!
! itype is integer intent (in)
!
! itype = 0: choose from a menu
! itype = 1: restore simple graphics
! itype = 2: restore advanced graphics
! itype = 3: restore labels and panels
! itype = 4: restore lines and symbols
! itype = 5: restore all Simfit graphics defaults
!-----------------------------------------------------------------------------------
!
      implicit   none
      integer    isend, jsend, nfiles, njcol, nkcol, nlgl, nout
      parameter (isend = 1, jsend = 2, nfiles = 1, njcol = 5, &
                 nkcol = 12, nlgl = 12)
      integer    i, l, m, n
      integer    jcol(njcol), kcol(nkcol)
      integer    jfiles(nfiles), lfiles(nfiles), mfiles(nfiles)
      double precision x(100), y(100)
      character  files(nfiles)*1024, titles(4)*40
      logical    lglval_a(nlgl), lglval_s(nlgl)
      logical    askif, store, there
      parameter (askif = .false., store = .true.)
      external   gks001, smplot, getnou, deleet, gettmp
      external   gkslgl
      external   grflgl
      external   gkscol
      external   gstyle, resdef
!
! restore defaults for simple and advanced graphics
!
      call resdef (isend)
      call resdef (jsend)
!
! set current default plotting styles interactively
!
      call gstyle (nlgl, &
                   lglval_a, lglval_s, store)
!
! initialise data for plotting then call gks001 using defaults
!
      n = 6
      x(1) = 1.0000d+00
      x(2) = 1.0002d+00
      x(3) = 1.0004d+00
      x(4) = 1.0006d+00
      x(5) = 1.0008d+00
      x(6) = 1.0010d+00
      do i = 1, n
         y(i) = x(i) - 1.0d+00
      enddo
      l = 1
      m = 6
      titles(1) = 'Default Plot'
      titles(2) = 'X'
      titles(3) = 'Y'
      titles(4) = ' '
      call gks001 (l, m, n, &
                   x, y, &
                   titles(1), titles(2), titles(3))
!
! now alter simple graphics defaults and colours then call gks001 again
!
      lglval_s(1) = .true.  !BOXIT      ... box round data plotted
      lglval_s(2) = .false. !FRAME      ... frame round outside edge of diagram
      lglval_s(3) = .true.  !OFFSET     ... offset intersection of axes at origin
      lglval_s(4) = .true.  !XGRID      ... grid marks at X-axis tick marks
      lglval_s(5) = .true.  !YGRID      ... grid marks at Y-axis tick marks
      lglval_s(6) = .false. !XHAIRS     ... extra axes intersecting at (0,0)
      lglval_s(7) = .false. !TICK MARKS ... .TRUE. = in (KTIC = 3), .FALSE. = out (KTIC = 1)
      call gkslgl (isend, nlgl, &
                   lglval_s)
      jcol(1) = 4    !title      ... red
      jcol(2) = 1    !legends    ... blue
      jcol(3) = 2    !labels     ... green
      jcol(4) = 3    !axes       ... cyan
      jcol(5) = 7    !background ... grey
                     ! ...
      kcol(1) = 5    !data       ... magenta
      do i = 2, 12
         kcol(i) = 0 !data       ... colours for up to 12 data sets
      enddo
      call gkscol (isend, jcol, kcol, njcol, nkcol)
      titles(1) = 'User-configured Plot'
      call gks001 (l, m, n, &
                   x, y, &
                   titles(1), titles(2), titles(3))
!
! call smplot showing that advanced graphics defaults have not been changed
!
      call gettmp (i, &
                   files(1))
      call getnou (nout)
      open (unit = nout, file = files(1))
      write (nout,'(a)') 'Temporary data'
      write (nout,'(2i6)') n, 2
      do i = 1, n
         write (nout,'(2e13.5)') x(i), y(i)
      enddo
      close (unit = nout)
      jfiles(1) = 4
      lfiles(1) = l
      mfiles(1) = m
      titles(1) = 'Default Plot'
      call smplot (jfiles, lfiles, mfiles, nfiles, &
                   files, titles)
!
! alter advanced graphics defaults then call smplot again
!
      lglval_a(1) = .true.  !BOXIT      ... box round data plotted
      lglval_a(2) = .false. !FRAME      ... frame round outside edge of diagram
      lglval_a(3) = .true.  !OFFSET     ... offset intersection of axes at origin
      lglval_a(4) = .true.  !XGRID      ... grid marks at X-axis tick marks
      lglval_a(5) = .true.  !YGRID      ... grid marks at Y-axis tick marks
      lglval_a(6) = .false. !XHAIRS     ... extra axes intersecting at (0,0)
      lglval_a(7) = .false. !TICK MARKS ... .TRUE. = in (KTIC = 3), .FALSE. = out (KTIC = 1)
      lglval_a(8) = .false. !Display an information panel
      lglval_a(9) = .false. !Panel at RHS of plot
      lglval_a(10) = .true. !Display line-types in panel
      lglval_a(10) = .true. !Display symbol-types in panel
      lglval_a(12) = .false.!Border round plot
      call grflgl (isend, nlgl, &
                   lglval_a)       !Alter logical variables as for simpl  graphics
      titles(1) = 'User-configured Plot'
      call smplot (jfiles, lfiles, mfiles, nfiles, &
                   files, titles)
!
! restore all defaults, simple and advanced, then delete the temporary file
!
      call resdef (isend)
      call resdef (jsend)
      call deleet (files(1), &
                   askif, there)
      end
!
!----------------------------------------------------------------------
!
       subroutine configure_symbols
!
! This demonstrates how to use the subroutine symbol to configure the
! colours, lines, and symbols in calls to SIMFIT advanced graphics.
!
!  call symcfg (isend, jcolor, kcolor, l, m, n,
! +             sizes, thick)
!
!  isend: isend = 1 ... retrieve current defaults   ... return new values
!         isend = 2 ... edit defaults interactively ... return new values
!         isend = 3 ... restore built-in defaults   ... return new values
!         isend = 4 ... over-write current defaults ... use values supplied
! jcolor: symbol colours
! kcolor: feature colours
!      l: line styles
!      m: symbol styles
!      n: dimension
!  sizes: symbol sizes
!  thick: line thicknesses
!
! Note: The arrays can be dimensioned up to nmax = 20
!
      implicit   none
      integer    n, nmax, nout
      parameter (n = 6, nmax = 15, nout = 10)
      integer    i, isend, j
      integer    j_sav(nmax), k_sav(nmax), l_sav(nmax), m_sav(nmax)
      integer    jcolor(nmax), kcolor(nmax), l(nmax), m(nmax)
      double precision s_sav(nmax), t_sav(nmax)
      double precision sizes(nmax), thick(nmax)
      double precision const, x, y
      double precision one, two
      parameter (one = 1.0d+00, two = 2.0d+00)
      character (len = 1024) files(n)
      character (len = 20) titles(4)
      logical    askif, there
      parameter (askif = .false.)
      external   deleet, symcfg, smplot, gettmp
      intrinsic  dble
!
! create the n data sets and write n temporary files
!
      const = -one
      do i = 1, n
         call gettmp (j, &
                      files(i))
         const = const + one
         open (unit = nout, file = files(i))
         write (nout,'(a)') 'temporary file'
         write (nout,'(2i6)') n, 2
         do j = 1, n
            x = dble(j)
            y = const + x
            write (nout,'(1p,2e13.5)') x, y
         enddo
         close (unit = nout)
      enddo
!
! retrieve the current parameters for subsequent restoration
!
      isend = 1
      call symcfg (isend, j_sav, k_sav, l_sav, m_sav, n, &
                   s_sav, t_sav)
!
! set the colour, type, and size parameters interactively but
! note that this control also displays the parameter meanings
!
      isend = 2
      call symcfg (isend, jcolor, kcolor, l, m, n, &
                   sizes, thick)
!
! plot the n data sets using the current defaults
!
      titles(1) = 'Default'
      titles(2) = 'X'
      titles(3) = 'Y'
      titles(4) = ' '
      call smplot (jcolor, l, m, n, &
                   files, titles)
!
! edit the plot style parameters
!
      jcolor(1) = 4  !red for line 1
      kcolor(1) = 1  !blue title
      m(1) = 0       !suppress symbol 1
      thick(1) = two !double line thickness 2
      jcolor(2) = 0  !black for line 2
      kcolor(2) = 4  !red for axes
      l(2) = 0       !suppress line 2
      sizes(3) = two !double symbol size 3
      l(6) = 0       !suppress line 6
      m(6) = 1       !change symbol 6 to dots
      kcolor(8) = 7  !change background to grey
!
! install the edited parameters
!
      isend = 4
      call symcfg (isend, jcolor, kcolor, l, m, n, &
                   sizes, thick)
!
! plot using the new parameter values
!
      titles(1) = 'Edited'
      call smplot (jcolor, l, m, n, &
                   files, titles)
!
! restore the defaults
!
      isend = 4
      call symcfg (isend, j_sav, k_sav, l_sav, m_sav, n, &
                   s_sav, t_sav)
!
! delete the temporary files
!
      do i = 1, n
         call deleet (files(i), &
                      askif, there)
      enddo
      end
!
!----------------------------------------------------------------------
!
      subroutine configure_labels
!
! This demonstrates how to call subroutine labcfg to set defaults such as
! pie chart and bar chart colours, and fill styles for pie chart segments,
! and bar chart rectangles. It also allows you to configure the default
! labels for pie and bar charts as well as for arbitrary plots with labels
! plotted next to symbols. In addition, panel keys for pie charts, bar
! charts, or all other types of information panel can be initialised.
!
! Note: The arrays can be dimensioned up to nmax = 20
!
!  call labcfg (isend, jcolor, jfill, n,
! +             label, panel)
!
!  isend: isend = 1 ... retrieve current defaults   ... return new values
!         isend = 2 ... edit defaults interactively ... return new values
!         isend = 3 ... restore built-in defaults   ... return new values
!         isend = 4 ... over-write current defaults ... use values supplied
! jcolor: colours
!  jfill: fill styles
!      n: dimension
!  label: piechart segment or barchart labels
!  panel: information panel labels
!
      implicit   none
      integer    nmax
      parameter (nmax = 15)
      integer    i, isend, jsend, nvec
      integer    jcolor(nmax), jfill(nmax)
      integer    jcolor_sav(nmax), jfill_sav(nmax)
      double precision zero, one
      parameter (zero = 0.0d+00, one = 1.0d+00)
      double precision fact(nmax), xvec(nmax)
      character  label(nmax)*40, panel(nmax)*40
      character  label_sav(nmax)*40, panel_sav(nmax)*40
      character  title*80
      external   labcfg, pcplot
!
! retrieve and store the current parameters
!
      isend = 1
      call labcfg (isend, jcolor, jfill, nmax, &
                   label, panel)
!
! save current values just set using isend = 1
!
      do i = 1, nmax
         jcolor_sav(i) = jcolor(i)
         jfill_sav(i) = jfill(i)
         label_sav(i) = label(i)
         panel_sav(i) = panel(i)
         fact(i) = zero
         xvec(i) = one
      enddo
!
! demonstrate use of the interactive control (isend = 2)
!
      isend = 2
      call labcfg (isend, jcolor, jfill, nmax, &
                   label, panel)
!
! plot a pie chart with the current configuration
!
      nvec = 10
      jsend = 2
      title = 'Current Labels and Panel Keys'
      call pcplot (jsend, jfill, jcolor, nvec, &
                   fact, xvec, &
                   label, title)
!
! alter the configuration and displace the segments
!
      do i = 1, nvec
        fact(i) = one
        write (label(i),'(a,i3)') 'Segment',i
        write (panel(i),'(a,i3)') 'Data',i
      enddo
!
! over-write the configuration (isend = 4)
!
      isend = 4
      call labcfg (isend, jcolor, jfill, nvec, &
                   label, panel)
!
! plot a pie chart with the new labels and panel keys
!
      jsend = 2
      title = 'New Labels and Panel keys'
      call pcplot (jsend, jfill, jcolor, nvec, &
                   fact, xvec, &
                   label, title)
!
! restore the original pie chart parameters (isend = 4)
!
      call labcfg (isend, jcolor_sav, jfill_sav, nmax, &
                   label_sav, panel_sav)
      end
!
!----------------------------------------------------------------------
!
      subroutine configure_keys
!
! Demonstration of subroutine defkey
!
! Simfit uses text keys to display non-standard characters and
! subroutine defkey allows programmers to specify special Maths
! characters, subscripts, superscripts, and accents, etc. for
! individual character strings. Additionally, defkey can be used
! to install a subsidiary plot title.
!
! call defkey (isend, jsend,
!              key,
!              store)
!
! isend: integer, intent (in) acts as follows,
!        isend = 1: store/retrieve title keys
!        jsend = 1 key for main title
!        jsend = 2 key for x-legend
!        jsend = 3 key for y-legend
!        jsend = 4 key for z-legend in double plots
!        jsend = 5 key for subsidiary title
!        jsend = 6 text for subsidiary title
!        isend = 2: store/retrieve panel keys
!        isend = 3: store/retrieve label keys
! jsend: integer, intent (in) index within the array of text keys
!        specified by isend when isend = 2 or isend = 3
!   key: character, intent (inout) key that is stored or retrieved
! store: logical, intent (in) dictates if store or retrieve is required.
!
! Character keys alter the way that characters are plotted as follows:
!
! key  effect on character plotted
! ---  ---------------------------
!   0  normal font (can also use ?)
!   1  subscript
!   2  superscript
!   3  Maths/Greek
!   4  Maths/Greek subscript
!   5  Maths/Greek superscript
!   6  Bold Maths/Greek
!   7  ZapfDingbats in Postscript, Wingdings in Windows
!   8  ISOLatin1 (almost identical to Windows)
!   9  Special in PostScript, Wingding2 in Windows
!   A  Grave accent
!   B  Acute accent
!   C  Hat
!   D  Tilde
!   E  Bar
!   F  Dieresis
!   G  Maths/Greek with hat
!   H  Maths/Greek with bar
!   I  Bold Maths/Greek with hat
!   J  Bold Maths/Greek with bar
!   K  Symbol
!   L  Bold Symbol
!
! Every text string plotted has an associated text key vector to control
! the appearance as described in the documents w_manual.pdf and pscodes.pdf.
! The corresponding code pages and keyboard maps to explain what these
! parameters mean can be displayed from the SIMFIT plot text editing control,
! and extensive documentation can be found in w_manual.pdf or pscodes.pdf.
!
      external panel_keys
      call panel_keys
      end
!
!----------------------------------------------------------------------
!
      subroutine panel_keys
!
! demonstrate labels and panels with special characters
!
      implicit   none
      integer    n
      parameter (n = 9)
      integer    i, j
      integer    isend, ifill(n), ihue(n)
      double precision d(n), x(n), zero, one
      parameter (zero = 0.0d+00, one = 1.0d+00)
      character  label(n)*40, pline(n)*40, title*80
      character  label_sav(n)*40, pline_sav(n)*40
      character  lkey*40, lkey_sav(n)*40, pkey*40, pkey_sav(n)*40
      logical    store
      external   labcfg, pcplot, defkey
      intrinsic  dble
!
! save the default colours, fill styles, labels, panels, and keys
!
      isend = 1
      call labcfg (isend, ihue, ifill, n, &
                   label_sav, pline_sav)
      store = .false.
      do i = 1, n
         isend = 2
         call defkey (isend, i, &
                      pkey_sav(i), &
                      store)
         isend = 3
         call defkey (isend, i, &
                      lkey_sav(i), &
                      store)
      enddo
!
! initialise the n labels and panel as a, b, c, d, ...
!
      j = 96
      do i = 1, n
         j = j + 1
         write (label(i),'(a)') char(j)
         pline(i) = label(i)
      enddo
!
! define the segment values
!
      do i = 1, n
         d(i) = zero
         x(i) = one
      enddo
!
! define the pie chart title
!
      title = 'Maths Characters for Labels and Panel Keys'
!
! define the new panels and associated character keys
!
      store = .true.
      pkey = '3'
      lkey = '3'
      do i = 1, n
         isend = 2
         call defkey (isend, i, &
                      pkey, &
                      store)
         isend = 3
         call defkey (isend, i, &
                      lkey, &
                      store)
      enddo
!
! install the new pline to overwrite the existing panel text defaults
!
      isend = 4
      call labcfg (isend, ihue, ifill, n, &
                   label, pline)
!
! call pcplot with isend = 2 to use the arguments supplied
!
      isend = 2
      call pcplot (isend, ifill, ihue, n, &
                   d, x, label, &
                   title)
!
! clean up
!
      isend = 4
      call labcfg (isend, ihue, ifill, n, &
                   label_sav, pline_sav)
      store = .true.
      do i = 1, n
         isend = 2
         call defkey (isend, i, &
                      pkey_sav(i), &
                      store)
         isend = 3
         call defkey (isend, i, &
                      lkey_sav(i), &
                      store)
      enddo
      end
!
!----------------------------------------------------------------------
!
      subroutine configure_sizes
!
! This demonstrates how to call tsizes to adjust font sizes for titles, etc.
! which is often required, e.g. with subsidiary plot titles. Colour for
! the subsidiary title is set using subroutine labcfg.
!
! call tsizes (itype,
!              factor,
!              store)
!
!  itype: integer, intent (in)
!         indicates the type of font required as follows:
!         itype =  1: title (main)
!         itype =  2: x-legend
!         itype =  3: y-legend
!         itype =  4: z-legend
!         itype =  5: x-text-labels
!         itype =  6: y-text-labels
!         itype =  7: z-text-labels
!         itype =  8: bar chart labels
!         itype =  9: pie chart labels
!         itype = 10: panel labels
!         itype = 11: data point labels
!         itype = 12: title (subsidiary)
!         itype = 13: x-numbers
!         itype = 14: y-numbers
!         itype = 15: z-numbers
! factor: double precision, intent (inout)
!         if store = .true. store factor
!         if store = .false. return the stored value
!  store: logical, intent (in) type of action required as above
!
      external title_keys
      call title_keys
      end
!
!----------------------------------------------------------------------
!
      subroutine title_keys
!
! plot subsidiary titles with reduced size and special characters
!
      implicit   none
      integer    n, nfiles, nout
      parameter (n = 100, nfiles = 1, nout = 10)
      integer    i, j
      integer    jfiles(nfiles), lfiles(nfiles), mfiles(nfiles)
      double precision delta, factor, x, y
      character  files(nfiles)*1024, titles(4)*80, title2*80
      character  key*80, key_sav*80
      logical    askif, there
      logical    store
      external   defkey, deleet, smplot, gettmp, tsizes
!
! retrieve and save the existing default title key
!
      store = .false.
      i = 1
      j = 1
      call defkey (i, j, &
                   key_sav, &
                   store)
!
! set up data for a graph
!
      jfiles(1) = 0
      lfiles(1) = 1
      mfiles(1) = 1
      call gettmp (i, &
                   files(1))
      titles(1) = 'Order 2:2 Positive Rational Function'
      titles(2) = 'x'
      titles(3) = 'y'
      titles(4) = ' '
      open (unit = nout, file = files(1))
      write (nout,'(a)') 'temporary file'
      write (nout,'(2i6)') n, 2
      delta = 0.1d+00
      x = delta
      do i = 1, n
         y = x/(1.0d+00 + x + x**2)
         x = x + delta
         write (nout,'(2e13.5)') x, y
      enddo
      close (unit = nout)
!
! store the new subsidiary plot title and key then plot the graph
!
      title2 = '(a1x + a2x2)/(1 + b1x + b2x2)'
         key = '03100003102000000031000031020'
      store = .true.
      i = 1
      j = 5
      call defkey (i, j, &
                   key, &
                   store)
      j = 6
      call defkey (i, j, &
                   title2, &
                   store)
!
! make the font smaller for the subsidiary title
!
      i = 12
      factor = 0.75d+00
      call tsizes (i, &
                   factor, &
                   store)
      call smplot (jfiles, lfiles, mfiles, nfiles, &
                   files, titles)
!
! clean up
!
      store = .true.
      i = 1
      j = 5
      call defkey (i, j, &
                   key_sav, &
                   store)
      j = 6
      title2 = ' '
      call defkey (i, j, &
                   title2, &
                   store)
      askif = .false.
      call deleet (files(1), &
                   askif, there)
      end
!
!----------------------------------------------------------------------
!
      subroutine configure_panels
!
! subroutine deflab .. store/retrieve complete or partial vectors for the default
!                      plot-labels, panel-labels, or associated character-keys
!
! call deflab (isend, ntext,
!              text,
!              store)
!
! isend: integer, intent (in)
!        isend = 1 ... plot-labels
!        isend = 2 ... panel-labels
!        isend = 3 ... plot-label character-keys
!        isend = 4 ... panel-label character-keys
!     n: integer, intent (in)
!        number of values required 1 =< n =< nmax, nmax = 20
!  text: character, intent (inout)
!        text string corresponding to the value of isend
! store: logical, intent (in)
!        store = .true.  ... store text
!        store = .false. ... retrieve text
!
! This routine uses the same conventions as defkey except that deflab can
! store or retrieve the complete default vectors of plot-labels, panel-labels,
! plot-label character-keys or panel-label character-keys, not just the
! character-keys used by defkey.
!
! Note: k = lambda and l = mu when the corresponding character key is 3
!
      implicit none
      integer    nfiles, n, nout, ntext
      parameter (nfiles = 8, n = 10, nout = 10, ntext = nfiles)
      integer    i, isend, j, jcolor(nfiles), jsend, l(nfiles), &
                 m(nfiles)
      double precision const, slope, x, y
      double precision zero, one, epsi
      parameter (zero = 0.0d+00, one = 1.0d+00, epsi = 0.1d+00)
      character (len = 1024) files(nfiles)
      character (len = 80) titles(4), tkey, tkey_sav
      character (len = 40) pline(15), pline_sav(15), psymb(15), &
                           psymb_sav(15)
      logical    store
      external   smplot, gettmp, deltmp, deflab, defkey
!
! retrieve the default panel-labels, panel-keys, and plot_title key
!
      store = .false.
      isend = 2
      call deflab (isend, ntext, pline_sav, store)
      isend = 4
      call deflab (isend, ntext, psymb_sav, store)
      isend = 1
      jsend = 1
      call defkey (isend, jsend, tkey_sav, store)
!
! initialise new panel_labels and panel keys
!
      do i = 1, ntext
         pline(i) = pline_sav(i)
         psymb(i) = psymb_sav(i)
      enddo
!
! calculate the data
!
      const = - one
      slope = one - epsi
      do i = 1, nfiles
         jcolor(i) = i
         l(i) = 1
         m(i) = i
         call gettmp (j, &
                      files(i))
         open (unit = nout, file = files(i))
         write (nout,'(a)') 'temporary file'
         write (nout,'(2i4)') n, 2
         const = const + one
         slope = slope + epsi
         write (pline(i),100) const, slope
         write (psymb(i),200)
         x = zero
         do j = 1, n
            x = x + one
            y = const + slope*x
            write (nout,'(1p,2e11.3)') x, y
         enddo
         close(unit = nout)
      enddo
!
! define the titles, install the new panel and keys then plot
!
      titles(1) = 'y = k + lx: Please Display the Panel'
           tkey = '000030003000000000000000000000000000'
      isend = 1
      jsend = 1
      store = .true.
      call defkey (isend, jsend, tkey, store)
      titles(2) = 'x'
      titles(3) = 'y'
      titles(4) = ' '
      store = .true.
      isend = 2
      call deflab (isend, ntext, pline, store)
      isend = 4
      call deflab (isend, ntext, psymb, store)
      call smplot (jcolor, l, m, nfiles, files, titles)
!
! clean up
!
      store = .true.
      isend = 2
      call deflab (isend, ntext, pline_sav, store)
      isend = 4
      call deflab (isend, ntext, psymb_sav, store)
      isend = 1
      jsend = 1
      call defkey (isend, jsend, tkey_sav, store)
      call deltmp
  100 format ('k=',f3.1,',l=',f3.1)
  200 format ('30000030000')
      end
!
!----------------------------------------------------------------------
!
!
      subroutine configure_nsteps
!
! Subroutine nsteps allows plots to be made where it is useful to
! leave gaps and insert steps between consecutive points plotted
! to avoif over-crowding, especially with symbols.
! This is a useful way to identify data plotted in information
! panels, so this feature is also illustrated.
!
! call nsteps (isend, l_step, m_step, nfiles)
!
!  isend: isend = 1 ... retrieve current values
!         isend = 2 ... interactive control then return new values
!         isend = 3 ... install new defaults using values supplied
!         isend = 4 ... restore original defaults (all = 0)
! l_step: nstep values for lines   ... leave gaps of l_step points
! m_step: nstep values for symbols ... leave gaps of m_step points
! nfiles: number of current files for plotting
!
      implicit   none
      integer    n, nfiles, nlgl, nout, ntext
      parameter (n = 200, nfiles = 3, nlgl = 10, nout = 10, &
                 ntext = nfiles)
      integer    i, j
      integer    jfiles(nfiles), lfiles(nfiles), mfiles(nfiles)
      integer    isend, l_sav(nfiles), l_step(nfiles), m_sav(nfiles), &
                 m_step(nfiles)
      double precision const, delta, five, two, zero, x, y
      parameter (delta = 0.05d+00, five = 5.0d+00, two = 2.0d+00, &
                 zero = 0.0d+00)
      character  files(nfiles)*1024, titles(4)*80
      character  pline_sav(15)*20, pline(15)*20
      logical    lgl_sav(nlgl), lgl(nlgl)
      logical    askif, store, there
      parameter (askif = .false.)
      external   smplot, gettmp, deleet, grflgl, nsteps, deflab
!
! Save current defaults then over-write for appropriate steps between symbols
!
      isend = 1
      call nsteps (isend, l_sav, m_sav, nfiles)
      do i = 1, nfiles
         l_step(i) = l_sav(i)
      enddo
      m_step(1) = 0
      m_step(2) = 5
      m_step(3) = 20
      isend = 3
      call nsteps (isend, l_step, m_step, nfiles)
!
! save current defaults then configure graph to display a panel and a border
!
      isend = 3
      call grflgl (isend, nlgl, &
                   lgl_sav)
      do i = 1, 8
         lgl(i) = lgl_sav(i)
      enddo
      lgl(8) = .true.  !Plot a Panel
      lgl(9) = .false. !Place panel underneath graph not at side
      lgl(10) = .true. !Add a border around the graph
      isend = 1
      call grflgl (isend, nlgl, &
                   lgl)
!
! save current defaults then over-write panel labels
!
      isend = 2
      store = .false.
      call deflab (isend, ntext, &
                   pline_sav, &
                   store)
      pline(1) = 'nstep = 0'
      pline(2) = 'nstep = 5'
      pline(3) = 'nstep = 20'
      store = .true.
      call deflab (isend, ntext, &
                   pline, &
                   store)
!
! define the plot titles and symbols
!
      titles(1) = 'Damped Oscillations'
      titles(2) = 't'
      titles(3) = 'f(t) = exp(-t/2)sin(5t)'
      titles(4) = ' '
      mfiles(1) = 1
      mfiles(2) = 5
      mfiles(3) = 8
!
! generate the data
!
      const = - two
      do i = 1, nfiles
         jfiles(i) = 0
         lfiles(i) = 1
         call gettmp (j, &
                      files(i))
         open (unit = nout, file = files(i))
         write (nout,'(a)') 'temporary file'
         write (nout,'(2i6)') n, 2
         const = const + two
         x = zero
         do j = 1, n
            y = const + exp(-x/two)*sin(five*x)
            x = x + delta
            write (nout,'(2e13.5)') x, y
         enddo
         close (unit = nout)
      enddo
!
! create the graph
!
      call smplot (jfiles, lfiles, mfiles, nfiles, &
                   files, titles)
!
! clean up
!
      isend = 3
      call nsteps (isend, l_sav, m_sav, nfiles)
      isend = 2
      store = .true.
      call deflab (isend, ntext, &
                   pline_sav, &
                   store)
      isend = 1
      call grflgl (isend, nlgl, &
                   lgl_sav)
      do i = 1, nfiles
         call deleet (files(i), &
                      askif, there)
      enddo
      end
!
!----------------------------------------------------------------------
!
      subroutine replay
!
! replay a metafile stored from Simfit advanced graphics
! in order to resume editing
!
      integer    nout
      character  aux256*1024, temp*1024
      character  fname*12, title*6
      parameter (fname = 'f$simfit.tmp', &
                 title = 'simdem')
      logical    askif, there
      parameter (askif = .false.)
      external   aux256, deleet, getnou
      external   mfplot, putadv
!
! Create the simdem identifier file f$simfit.tmp so the [Demo] button will work
!
      temp = aux256(fname)
      call getnou (nout)
      open (unit = nout, file = temp)
      write (nout,'(a)') title
      close (unit = nout)
      call putadv ('Use the [Demo] file selection option for SIMDEM test files')
      call mfplot
!
! delete the identifier file
!
      call deleet (temp,
     +             askif, there)
      end
!
!----------------------------------------------------------------------
!

Back to Menu or Simfit home page


10. 64-bit Simdem and crossm compiler complications

32-bit programs using the 32-bit version of Simdem must be linked to the Simdem DLLs w_clearwin.dll, w_graphics.dll, and w_menus.dll. The 32-bit Simdem package can be demonstrated using the driver simdem.exe, and the Silverfrost run-time system salflibc.dll is required.

However, 64-bit programs must not be linked to these Dlls, they must be linked instead to the 64-bit Simdem DLLs x64_clearwin.dll, x64_graphics.dll, and x64_menus.dll. The 64-bit Simdem package can be demonstrated using the driver x64_simdem.exe and the Silverfrost run-time system clearwin64.dll as well as the NAG run-time system lib64fxy.dll is also required, where xy is the release identifier as in lib64f53.dll.

Note that in 32-bit FTN95 versions from 7.4.0 onwards the single file simdem32.dll replaces w_clearwin.dll, w_menus.dll, and w_graphics.dll, while in 64-bit versions simdem64.dll replaces x64_clearwin.dll, x64_menus.dll, and x64_graphics.dll.

Cross-compiler complications

  1. Fortran units
  2. Data input/output and file connections
  3. Run-time DLLs
  4. The one-DLL solution

1.   Fortran units

Because Simdem uses ClearWin+, one of its DLL's has to be compiled with FTN95, even in a release that is aimed at users of the NAG, gFortran or other compilers. Mixing of DLL's prepared by different Fortran compilers, works, except that I/O unit numbers used in OPEN, CLOSE, WRITE, READ, etc. do not carry over.
For example, if you open a file on unit 10 (say) within FTN95-compiled code, it will not be visible from within code compiled with other compilers.

As the Simdem library is designed to be used by any Fortran compiler there are just two possibilities:

2.   Data input/output and file-connections

The next information can be ignored if you use the same compiler for both your executables and also w_menus.dll and w_graphics.dll (or x64_menus.dll and x64_graphics.dll) as always happens with FTN95, and this will also be true for NAGfor, and gFortran, but only if the correct run-time DLLs are present locally or on the path.
Note that w_clearwin.dll and x64_clearwin.dll are always compiled using FTN95 and are designed so that they cannot be responsible for any any such cross-compiler problems.

However, there is a serious problem if you compile your executables using any compiler except FTN95, NAGfor, or gFortran. So if you intend to write code that will read from or write to files using the Simdem DLLs you should observe the following details.

Filenames passed between the native compiler and the Simdem DLLs are not affected by this complication, neither are the integers passed as unit identifiers. The problem is that the units associated with these integers may not correspond to the files supposed to be connected. This can only be circumvented by making sure that the problems with such standard Fortran functions as OPEN, CLOSE, WRITE, READ, INQUIRE, REWIND, etc. are recognised. In general, all subroutines calling the Simdem GUI with a pre-defined unit or returning a unit are involved, particularly the following ones.

CLOSER ... close a unit
GETNOU ... return an unopened unit
ISFCON ... is a file connected
ISUCON ... is a unit connected
MATOUT ... matrix output
MATTIN ... matrix input
MAT2IN ... matrix input
MAT3IN ... matrix input
OFILES ... open a file
OPENER ... open a unit
READER ... read from a unit
REVPRO ... review progress of calculations
VEC1IN ... vector input
WRITER ... write to a unit

To avoid this, Simdem has code to ensure that all input/output, etc. required by executables can consistently be called from Simdem using the following scheme.

 call opener (ios, nunit, fname) ... instead of
 open (unit = nunit, file = fname, iostat = ios)

 call closer (nunit) ... instead of
 close (unit = nunit)

 call writer (ios, nlines, nunit, text) ... instead of
 do i = 1, nlines
    write (nunit, '(a)', iostat = ios) text(i)
 enddo

 call reader (ios, nlines, nunit, text) ... instead of
 do i = 1, nlines
    read (nunit, '(a)', iostat = ios) text(i)
 enddo

 call attrib (fname, there, read_only) ... returns
 there = .true. if fname exists, and read_only = .true.
 if fname exists and has the read only attribute

 op = isfcon (fname) ... instead of
 inquire (file = fname, opened = op)

 op = isucon (nunit) ... instead of
 inquire (unit = nunit, opened = op)

 Variables are:
 integer   ios, nlines, nunit
 character fname*(*), text(nlines)*(*)
 logical   op, read_only, there

 Some test example programs demonstrating these techniques are: 
 simdem15.f95
 simdem16.f95
 simdem43.f95
 

3.   Run-time DLLs

For all executables distributed to run in the Windows operating system there must be ways for the executable to be able to communicate with the Windows API. So there has to be a run-time system in the form of one or more DLLs that have to be available to the executables as local files or on the path.

There are two types of such run-time dlls.

4.   The one-DLL solution

To remedy the problem of unavailable backward compatible run-time DLLs and to greatly simplify the use of the Simdem package with any compiler a new technique was introduced at version 7.4.0.
This is the standard way that Simdem will operate with future releases of the FTN95 compiler as follows.

In other words

simdem32.dll ≡ w_clearwin.dll + w_graphics.dll + w_menus.dll, and
simdem64.dll ≡ x64_clearwin.dll + x64_graphics.dll + x64_menus.dll

The one-DLL version will always be compatible with any compiler as long as the appropriate stdcall or cdecl 32-bit version of simdem32.dll is used.
However it will still require the use of the special subroutines described previously to be used for any functionality requiring units to be passed to the run time Simdem DLLs simdem32.dll or simdem64.dll.

Back to Menu or Simfit home page