👁 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.

• The program simdem.exe

  This is a driver program which shows you the source codes and also runs the 70 demonstration programs called simdem01, simdem02, ..., simdem70, each demonstrating a different aspect of the way Windows features can be called. You can toggle between viewing the source code and executing the programs. There are simple demonstrations of most of the controls Simfit uses for input/output and graphics. The source code for the DLLs can also be browsed to appreciate that there are many more user-callable functions than are demonstrated by the simdem package. However users must download the version that is consistent with their compiler.

• The versions of simdem.exe and x64_simdem.exe

  The file simdem_setup_x.exe will install the 32-bit and 64-bit versions of the simdem package for users of Salford-Software/Silverfrost FTN95. The 32-bit binaries conform the cdecl calling convention.

  The file NAG_simdem_setup_x.exe will install an alternative version where w_clearwin.dll has been compiled using Salford FTN95 with the /f_stdcall option so as to be consistent with the STDCALL calling convention. The other 32-bit binaries have been compiled using the NAGfor compiler with the -f77 option. In the 64-bit version x64_clearwin.dll has been compiled using FTN95 but the others have been compiled using NAGfor.

• The source codes

  Each of the 70 source codes is available for study and development, and each is fully commented to explain the argument lists. The codes are written in standard fixed format Fortran and use no non-standard compiler extensions. Users are completely isolated from any direct interaction with the Win32 operating system. The full set of source codes for the dynamic link libraries used by the simdem package can be extracted from the source codes for the Simfit package. Note that any Simfit source code that calls the Windows operating system has a w_ prefix. For instance, patch1 is in standard Fortran but it passes the argument list on to w_patch1, which uses non-standard calls.

• The documentation

  A file called simdem.chm summarises the package, and this should be read in conjunction with the file source.pdf, also available from the Simfit website, that explains how to compile the Simfit package.

• The NAG Fortran Builder

  The Simdem package is integrated into the NAG Fortran Builder, an IDE for developing Fortran programs that can be compiled and linked using the NAGfor compiler, creating programs that can call the NAG library DLLs for numerical analysis. By also linking in the Simdem package, stand-alone Windows type executables can be created with menus, tables, edit boxes, and graphics, etc.

• The Silverfrost Plato IDE

  The Simdem package is also integrated into the Silverfrost FTN95 package, so programs linked to the Simdem GUI can be created using Plato or the command line.

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:

• Only use a situation where the same compiler is used for the executables and the Simdem menus and graphics DLLs; or
• Use special commands instead of OPEN, CLOSE, WRITE, and READ, etc.

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.

• The DLLS always have the same name.
  
  This is the case with the Windows operating system where DLLs are simply over-written on upgrade by new DLLs with the same name but with additional internal code, and it has the advantage of backward compatibility.
  The Silverfrost FTN95 compiler behaves in this way
  
  
• The names of the DLLs change with each upgrade.
  
  This does not allow backward compatibility and leads to executables issuing error messages when the current run-time DLLs cannot be found.
  This is the technique used by the NAGfor and gFortran compilers.
  It can only be rectified by adding the missing DLLs as a local copy or placing them on the path.

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.

• The 32-bit version of Simdem will only require simdem32.dll
• The 64-bit version of Simdem will only require simdem64.dll

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