The Simdem package
- Using Fortran to write Windows programs
- Description of the Simdem package
- Technical details
- Programs: Brief descriptions
- Programs: Source codes in numerical order
- Programs: Source codes in subject order
- Subroutines: Descriptions in program numerical order
- Subroutines: Descriptions in program subject order
- Subroutines: Descriptions in alphabetical order
- 64-bit Simdem and cross compiler complications
- 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
- Introduction
- The Simfit package
- Salford-Software/Silverfrost Win32 compilers and Clearwin+
- The aim of the Smdem programs
- How to use the Simdem programs
- Printing and viewing PostScript files
- The Simfit calling convention
- Input/Output/File-access across different compilers
- 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.
- Data files conform to the ASCII text file convention
- Line 1 must be a title up to 80 characters wide
- Line 2 must have two integers, i.e. n rows and m columns
- 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.
- Line n + 3 may optionally be k if k extra lines are to be used
- If k is greater than 0 then lines n + 4 to n + 3 + k may be added, e.g. for labels
- 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 driverThe 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 helpsimdem02: 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 usersimdem06: 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 list01simdem08: Simple table in a window
table1 ... create a table from text supplied to table1simdem09: 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 arraysimdem12: Integer editing
editi1 ... edit an integer arraysimdem13: Text editing
edittx ... edit a text arraysimdem14: Viewing data values
viewit ... scrolled viewing of double precision or integer arrayssimdem15: 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.dllsimdem16: Viewing text files
viewer ... view a supplied file or view a file selected by browsingsimdem17: 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 menusimdem19: Create a question and answer window
answer ... display text and a summary questionsimdem20: Create a tabbing list box window
tbox01 ... tab above, inside and below a list boxsimdem21: Create/transform up to 4 x,y plots
gkst04 ... plotting with interactive linearising transformationssimdem22: Plot surfaces and contours
surd2s .. surfaces, contours, projections and skyscraperssimdem23: Plot curves in space
space0 .. x(t), y(t), z(t) parametric curve in 3D spacesimdem24: Plot vector field
gksvf1 ... plot a vector flow field of arrowssimdem25: Plot error bars
gkseb4 ... up to two sets of data/error bars plus two best fit curvessimdem26: Display/file a matrix
dsplay ... display a matrix but also write to results file if requiredsimdem27: Create a coloured table
table2 ... use colours for a individual letters in a tablesimdem28: Create a background window
window ... plant code inside a background windowsimdem29: Return a text string
linein ... plant a text edit box inside a windowsimdem30: Title page and tutorial
titles ... Display a title with menu tutor1 ... Display a tutorialsimdem31: Get n integers
geti0n ... input n integers then return n edited valuessimdem32: Get n double precisions
getr0n ... input n double precision variables then retrun n edited valuessimdem33: Get n character strings
gets0n ... input n character strings then return n edited valuessimdem34: Get n logical valriables
getl0n ... input n logical variables then return n edited valuessimdem35: Get n variables of any types
get00n ... input n variables of any type then return n edited valuessimdem36: Button boxes
bbox01 ... split style vbox01 ... vertical hbox01 ... horizontalsimdem37: Ganged radio/tick boxes
rbox01 ... ganged radio or tick boxessimdem38: Planting a function call in a window
table4 ... interactive calculations in real timesimdem39: Wait ... calculations in progress
waiter ... inform users when a slow process is taking placesimdem40: Configure the Simfit DLLs
config ... show users how to configure the Simdem environmentsimdem41: Use vec1in to get a vector from the user
vec1in ... read in a vector from console, clipboard or filesimdem42: Use mattin to get a matrix from the user
mattin ... read in a matrix from console, clipboard or filesimdem43: 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 unitsimdem44: 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 filesimdem45: Print a text file
fprint ... print a text filesimdem46: Plot n data sets
smplot ... overlay n graphs deltmp ... delete Simfit temporary filessimdem47: Create a pie chart
pcplot ... plot a vector as a pie chartsimdem48: Create a bar chart
bcplot ... plot a matrix as a bar chartsimdem49: Create a box and whisker plot
bwplot ... plot a vector as a box and whisker plotsimdem50: Plot as bars or symbols plus error bars
ebplot ... plot a vector as a bar chart with error barssimdem51: 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.dllsimdem52: Retrieve a colour number from the palette
palett ... edit or retrieve the Simfit colourssimdem53: 2D scatter plot with labels
lbplot ... plot symbols with labelssimdem54: Plot sample cumulative and best-fit cdf
cdplot ... display best-fit cdf on sample cumulative distributionsimdem55: Plot sample histogram and best-fit pdf
pdplot ... display best fit pdf on sample histogramsimdem56: Plot histogram with error bars
hist01 ... display a histogram with error barssimdem57: Plot a dendrogram
dgplot ... display a dendrogram with a thresholdsimdem58: Scrolling check boxes
chkbox ... toggle tick boxessimdem59: Multiple file selection
mfiles ... select a set of filessimdem60: Comprehensive list box
lstbox ... list box with header and trailersimdem61: Half normal and normal scores plots
hnplot ... plot a vector as half or normal scoressimdem62: Bivariate normal contour ellipses
g02cafg ... fit a straight line elips1 ... data and mean 95% confidence regionsimdem63: Plot rows and columns from a matrix
mtplot ... interpret rows or columns as x,y coordinatessimdem64: Plot parameteric curve r = r(theta)
rtplot ... interpret r(theta) in x,y space x01aafg ... pisimdem65: Select files for viewing or opening
vuopen ... choose a file from a list to view or opensimdem66: 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 filesimdem67: Matrices ... editing and transforming
mattrn ... input then edit and/or transform a matrixsimdem68: 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 matrixsimdem69: Plot a vector field with labels, e.g. a biplot
gksvf3 ... display a vector field with arbitrary arrows and labelssimdem70: 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
- Fortran units
- Data input/output and file connections
- Run-time DLLs
- 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
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.