diff options
author | William Joye <wjoye@cfa.harvard.edu> | 2017-12-08 19:30:07 (GMT) |
---|---|---|
committer | William Joye <wjoye@cfa.harvard.edu> | 2017-12-08 19:30:07 (GMT) |
commit | 9c81a48e2a38ab4487b8849d2b2db6ebbaeca9a7 (patch) | |
tree | 3de4f1c5f35381ecc749da5e05bfc3837d7cedaf /ast | |
parent | 4432c8d7e1ccb371db03e13cdb5378fceaa5ad04 (diff) | |
download | blt-9c81a48e2a38ab4487b8849d2b2db6ebbaeca9a7.zip blt-9c81a48e2a38ab4487b8849d2b2db6ebbaeca9a7.tar.gz blt-9c81a48e2a38ab4487b8849d2b2db6ebbaeca9a7.tar.bz2 |
upgrade AST
Diffstat (limited to 'ast')
-rw-r--r-- | ast/ast_link_adam | 406 | ||||
-rw-r--r-- | ast/cminpack/.deps/libast_la-dpmpar.Plo | 1 | ||||
-rw-r--r-- | ast/cminpack/.deps/libast_la-enorm.Plo | 1 | ||||
-rw-r--r-- | ast/cminpack/.deps/libast_la-lmder.Plo | 1 | ||||
-rw-r--r-- | ast/cminpack/.deps/libast_la-lmder1.Plo | 1 | ||||
-rw-r--r-- | ast/cminpack/.deps/libast_la-lmpar.Plo | 1 | ||||
-rw-r--r-- | ast/cminpack/.deps/libast_la-qrfac.Plo | 1 | ||||
-rw-r--r-- | ast/cminpack/.deps/libast_la-qrsolv.Plo | 1 | ||||
-rw-r--r-- | ast/cminpack/CopyrightMINPACK.txt | 52 | ||||
-rw-r--r-- | ast/cminpack/README.md | 128 | ||||
-rw-r--r-- | ast/cminpack/cminpack.h | 370 | ||||
-rw-r--r-- | ast/cminpack/cminpackP.h | 62 | ||||
-rw-r--r-- | ast/cminpack/dpmpar.c | 201 | ||||
-rw-r--r-- | ast/cminpack/enorm.c | 157 | ||||
-rw-r--r-- | ast/cminpack/lmder.c | 526 | ||||
-rw-r--r-- | ast/cminpack/lmder1.c | 167 | ||||
-rw-r--r-- | ast/cminpack/lmpar.c | 338 | ||||
-rw-r--r-- | ast/cminpack/qrfac.c | 285 | ||||
-rw-r--r-- | ast/cminpack/qrsolv.c | 218 | ||||
-rw-r--r-- | ast/config.h.in | 3 | ||||
-rw-r--r-- | ast/f77.h | 1096 | ||||
-rw-r--r-- | ast/object.h | 1934 |
22 files changed, 0 insertions, 5950 deletions
diff --git a/ast/ast_link_adam b/ast/ast_link_adam deleted file mode 100644 index f776bb7..0000000 --- a/ast/ast_link_adam +++ /dev/null @@ -1,406 +0,0 @@ - -# N.B. the previous line should be blank. -#++ -# Name: -# ast_link_adam - -# Purpose: -# Link an ADAM program with the AST library. - -# Type of Module: -# Shell script. - -# Description: -# This command should only be used when building Starlink ADAM programs -# which use the AST library, in order to generate the correct arguments -# to allow the ADAM ``alink'' command to link the program. The arguments -# generated are written to standard output but may be substituted into -# the ``alink'' command line in the standard UNIX way using backward -# quotes (see below). -# -# By default, it is assumed that you are building an ADAM program which -# does not produce graphical output. However, switches are provided for -# linking other types of program. This command should not be used when -# building stand-alone (non-ADAM) programs. Use the ``ast_link'' command -# instead. - -# Invocation: -#c alink program.o -L/star/lib `ast_link_adam [switches]` -#f alink program.f -L/star/lib `ast_link_adam [switches]` - -# Switches: -# The following switches may optionally be given to this command to -# modify its behaviour: -# -# - ``-csla'': Ignored. Provided for backward compatibility only. -# -# - ``-fsla'': Ignored. Provided for backward compatibility only. -# -# - ``-grf'': Requests that no arguments be generated to specify which -# 2D graphics system is used to display output from the AST library. You -# should use this option only if you have implemented an interface to a -# new graphics system yourself and wish to provide your own arguments for -# linking with it. This switch differs from the other ``grf'' switches in -# that it assumes that your graphics module implements the complete -# interface required by the current version of AST. If future versions of -# AST introduce new functions to the graphics interface, this switch will -# cause ``unresolved symbol'' errors to occur during linking, warning you -# that you need to implement new functions in your graphics module. To -# avoid such errors, you can use one of the other, version-specific, -# switches in place of the ``-grf'' switch, but these will cause run-time -# errors to be reported if any AST function is invoked which requires -# facilities not in the implemented interface. -# -# - ``-grf_v2.0'': This switch is equivalent to the ``-mygrf'' switch. -# It indicates that you want to link with your own graphics module which -# implements the 2D graphics interface required by V2.0 of AST. -# -# - ``-grf_v3.2'': Indicates that you want to link with your own graphics -# module which implements the 2D graphics interface required by V3.2 of AST. -# -# - ``-grf_v5.6'': Indicates that you want to link with your own graphics -# module which implements the 2D graphics interface required by V5.6 of AST. -# -# - ``-myerr'': Requests that no arguments be generated to specify how -# error messages produced by the AST library should be delivered. You -# should use this option only if you have implemented an interface to a -# new error delivery system yourself and wish to provide your own -# arguments for linking with it. By default, error messages are delivered -# in the standard ADAM way via the EMS Error Message Service (Starlink -# System Note SSN/4). -# -# - ``-mygrf'': This switch has been superceeded by the ``-grf'' switch, -# but is retained in order to allow applications to be linked with a -# graphics module which implements the interface used by AST V2.0. It is -# equivalent to the ``-grf_v2.0'' switch. -# -# - ``-pgp'': Requests that the program be linked so that 2D -# graphical output from the AST library is displayed via the -# Starlink version of the PGPLOT graphics package (which uses GKS -# for its output). By default, no graphics package is linked and -# this will result in an error at run time if AST routines are -# invoked that attempt to generate graphical output. -# -# - ``-pgplot'': Requests that the program be linked so that 2D -# graphical output from the AST library is displayed via the -# standard (or ``native'') version of the PGPLOT graphics -# package. By default, no graphics package is linked and this will -# result in an error at run time if AST routines are invoked that -# attempt to generate graphical output. -# -# - ``-grf3d'': Requests that no arguments be generated to specify which -# 3D graphics system is used to display output from the AST library. You -# should use this option only if you have implemented an interface to a -# new 3D graphics system yourself and wish to provide your own arguments -# for linking with it. -# -# - ``-pgp3d'': Requests that the program be linked so that 3D -# graphical output from the AST library is displayed via the -# Starlink version of the PGPLOT graphics package (which uses GKS -# for its output). By default, no 3D graphics package is linked and -# this will result in an error at run time if AST routines are -# invoked that attempt to generate graphical output. -# -# - ``-pgplot3d'': Requests that the program be linked so that 3D -# graphical output from the AST library is displayed via -# the standard (or ``native'') version of the PGPLOT graphics -# package. By default, no 3D graphics package is linked and this will -# result in an error at run time if AST routines are invoked that -# attempt to generate graphical output. - -# SLALIB: -# The AST distribution includes a cut down subset of the C version of -# the SLALIB library written by Pat Wallace. This subset contains only -# the functions needed by the AST library. It is built as part of the -# process of building AST and is distributed under GPL (and is thus -# compatible with the AST license). Previous version of this script -# allowed AST applications to be linked against external SLALIB -# libraries (either Fortran or C) rather than the internal version. -# The current version of this script does not provide this option, -# and always uses the internal SLALIB library. However, for backward -# compatibility, this script still allows the "-fsla" and "-csla" flags -# (previously used for selecting which version of SLALIB to use) to be -# specified, but they will be ignored. - -# Examples: -#c alink display.o -L/star/lib `ast_link_adam -pgplot` -#c Links an ADAM program ``display'' which uses the standard -#c version of PGPLOT for graphical output. -#c alink plotit.o -L. -L/star/lib `ast_link_adam -grf` -lgrf -#c Links an ADAM program ``plotit'', written in C. The ``-grf'' -#c switch indicates that graphical output will be delivered through -#c a graphical interface which you have implemented yourself, which -#c corresponds to the interface required by the current version of AST. -#c Here, this interface is supplied by means of the ``-lgrf'' library -#c reference. -#c alink plotit.o -L. -L/star/lib `ast_link_adam -grf_v2.0` -lgrf -#c Links an ADAM program ``plotit'', written in C. The ``-grf_v2.0'' -#c switch indicates that graphical output will be delivered through -#c a graphical interface which you have implemented yourself, which -#c corresponds to the interface required by version 2.0 of AST. Here, -#c this interface is supplied by means of the ``-lgrf'' library -#c reference. -#f alink display.f -L/star/lib `ast_link_adam -pgplot` -#f Compiles and links an ADAM Fortran program called ``display'' which -#f uses the standard version of PGPLOT for graphical output. -#f alink plotit.f -L. -L/star/lib `ast_link_adam -grf` -lgrf -#f Compiles and links an ADAM Fortran program ``plotit''. The ``-grf'' -#f switch indicates that graphical output will be delivered through -#f a graphical interface which you have implemented yourself, which -#f corresponds to the interface required by the current version of AST. -#f Here, this interface is supplied by means of the ``-lgrf'' library -#f reference. -#f alink plotit.f -L. -L/star/lib `ast_link_adam -grf_v2.0` -lgrf -#f Compiles and links an ADAM Fortran program ``plotit''. The ``-grf_v2.0'' -#f switch indicates that graphical output will be delivered through -#f a graphical interface which you have implemented yourself, which -#f corresponds to the interface required by version 2.0 of AST. -#f Here, this interface is supplied by means of the ``-lgrf'' library -#f reference. - -# Copyright: -# Copyright (C) 1997-2006 Council for the Central Laboratory of the Research Councils - -# Authors: -# RFWS: R.F. Warren-Smith (STARLINK) -# {enter_new_authors_here} - -# History: -# 11-NOV-1996 (RFWS): -# Original version. -# 18-NOV-1997 (RFWS): -# Adapted prologue for document extraction. -# 28-SEP-1998 (RFWS): -# Distinguish between -pgp and -pgplot options. -# 23-JAN-2004 (DSB): -# Added switches to support older grf implementations. -# 21-APR-2005 (DSB): -# Added "-fsla" option. -# 16-JUN-2006 (DSB): -# Ignore "-fsla" and "-clsa" options, and always use PAL. -# 22-AUG-2007 (DSB): -# Added "-grf3d", "-pgplot3d" and "-pgp3d" flags. -# 4-MAR-2011 (DSB): -# Added v5.6 grf options. -# {enter_changes_here} - -# Bugs: -# {note_any_bugs_here} - -#-- - -# This function searches the directory path specified in PATH, looking for -# an executable file which is not a directory. If found, it echos the full -# file name to standard output. Otherwise, it outputs nothing. - find() { IFS=':'; for d in $PATH; do f="${d:=.}/${1}" - test -x "${f}" -a ! -d "${f}" && echo "${f}" && break - done; - } - -# Initialise linking options. - err='' - grf='' - grf3d='' - sla='' - -# Interpret command line switches. -# -------------------------------- - while :; do - case "${1}" in - -# -csla - Previously used to request C version of SLALIB. Now ignored. - -csla) -# sla='c' - shift;; - -# -fsla - Previously used to request Fortran version of SLALIB. Now ignored. - -fsla) -# sla='f' - shift;; - -# -myerr - Requests no error reporting. - -myerr) - err='my' - shift;; - -# -grf - Requests no 2D graphics. - -grf) - grf='current' - shift;; - -# -mygrf - Requests no 2D graphics, except for null implementations of -# functions aded to the grf interface after AST V2.0. - -mygrf) - grf='v2.0' - shift;; - -# -grf_v2.0 - Requests no 2D graphics, except for null implementations of -# functions aded to the grf interface after AST V2.0. - -grf_v2.0) - grf='v2.0' - shift;; - -# -grf_v3.2 - Requests no 2D graphics, except for null implementations of -# functions aded to the grf interface after AST V3.2. - -grf_v3.2) - grf='v3.2' - shift;; - -# -grf_v5.6 - Requests no 2D graphics, except for null implementations of -# functions added to the grf interface after AST V5.6. - -grf_v5.6) - grf='v5.6' - shift;; - -# -pgp - Requests 2D graphical output through Starlink PGPLOT. - -pgp) - grf='pgp' - shift;; - -# -pgplot - Requests 2D graphical output through native PGPLOT. - -pgplot) - grf='pgplot' - shift;; - -# -grf3d - Requests no 3D graphics. - -grf3d) - grf3d='current' - shift;; - -# -pgp3d - Requests 3D graphical output through Starlink PGPLOT. - -pgp3d) - grf3d='pgp' - shift;; - -# -pgplot3d - Requests 3D graphical output through native PGPLOT. - -pgplot3d) - grf3d='pgplot' - shift;; - -# Once all switches have been read, continue with the rest of the script. - '') break;; - -# Catch unrecognised switches and report an error. - *) - echo >&2 "ast_link_adam: unknown argument \""${1}"\" given" - exit 1;; - esac - done - -# Link with the main AST library. -# ------------------------------- -# Start forming the list of arguments with the main AST library itself. - args='-last' - -# Generate arguments for linking PAL. -# ----------------------------------- - - case "0" in - -# If we configured --with-external_pal include a link option to pick up -# an external PAL library. - 1) args="${args} -lpal";; - -# Otherwise, use the internal PAL & ERFA libraries. - *) args="${args} -last_pal";; - - esac - -# Generate arguments for linking the 2D graphics system. -# ------------------------------------------------------ - case "${grf}" in - -# If using Starlink PGPLOT, link with the AST PGPLOT interface and -# the Fortran library via the PGP link script. - pgp) args="${args} -last_pgplot `pgp_link_adam`";; - -# If using native PGPLOT, link with the AST PGPLOT interface and -# the Fortran library via the PGPLOT link script. - pgplot) args="${args} -last_pgplot `pgplot_link_adam`";; - -# If using own graphics which conform to the requirements of the current -# version of AST, do not produce any arguments. - current) :;; - -# If using own graphics which conform to the requirements of version 5.6 -# of AST, produce arguments which link in dummy implementations of any -# functions which are required by the current version of AST but which were -# not required by version 5.6. - v5.6) :;; - -# If using own graphics which conform to the requirements of version 3.2 -# of AST, produce arguments which link in dummy implementations of any -# functions which are required by the current version of AST but which were -# not required by version 3.2. - v3.2) args="${args} -last_grf_5.6";; - -# If using own graphics which conform to the requirements of version 2.0 -# of AST, produce arguments which link in dummy implementations of any -# functions which are required by the current version of AST but which were -# not required by version 2.0. - v2.0) args="${args} -last_grf_3.2 -last_grf_5.6";; - -# Default graphics (none) requires linking with all the default (null) AST -# "grf" modules. - *) args="${args} -last_grf_2.0 -last_grf_3.2 -last_grf_5.6";; - esac - -# Generate arguments for linking the 3D graphics system. -# ------------------------------------------------------ - case "${grf3d}" in - -# If using Starlink PGPLOT, link with the AST 3D PGPLOT interface and -# the Fortran library via the PGP link script (if found). - pgp) args="${args} -last_pgplot3d `\`find pgp_link\``" - f77='y';; - -# If using native PGPLOT, link with the AST 3D PGPLOT interface and the -# Fortran library via the PGPLOT link script (if found). - pgplot) args="${args} -last_pgplot3d `\`find pgplot_link\``" - f77='y';; - -# If using own 3D graphics which conform to the requirements of the current -# version of AST, do not produce any arguments. - current) :;; - -# Default graphics (none) requires linking with all the default (null) AST -# "grf3d" modules. - *) args="${args} -last_grf3d";; - esac - -# Make a second pass through the AST library. -# ------------------------------------------- -# This library is a link to the main AST library and results in a second -# pass to resolve any backward references generated by the other modules -# used above. A different library name must be used to avoid the two passes -# being merged into one (either below, or by other link scripts). - args="${args} -last_pass2" - -# Generate arguments for linking the error reporting system. -# ---------------------------------------------------------- - case "${err}" in - -# If using own error reporting, do not produce any arguments. - my) :;; - -# Default error reporting requires linking with the AST EMS interface and -# the EMS library via the link script. - *) args="${args} -last_ems `ems_link_adam`";; - esac - -# Link with the maths library. -# ---------------------------- - args="${args} -lm" - -# Link with the starmem library, if available. -# -------------------------------------------- - args="${args} `\`find starmem_link\``" - -# Pass the resulting argument list through an awk script which eliminates -# all except the last reference to each library. - echo "${args}" \ - | awk 'BEGIN{RS=" ";FS="\n"} - {if($1)f[i++]=$1} - END{for(;i--;)if(!w[f[i]]++)l=f[i]" "l;print l}' - -# End of script. diff --git a/ast/cminpack/.deps/libast_la-dpmpar.Plo b/ast/cminpack/.deps/libast_la-dpmpar.Plo deleted file mode 100644 index 9ce06a8..0000000 --- a/ast/cminpack/.deps/libast_la-dpmpar.Plo +++ /dev/null @@ -1 +0,0 @@ -# dummy diff --git a/ast/cminpack/.deps/libast_la-enorm.Plo b/ast/cminpack/.deps/libast_la-enorm.Plo deleted file mode 100644 index 9ce06a8..0000000 --- a/ast/cminpack/.deps/libast_la-enorm.Plo +++ /dev/null @@ -1 +0,0 @@ -# dummy diff --git a/ast/cminpack/.deps/libast_la-lmder.Plo b/ast/cminpack/.deps/libast_la-lmder.Plo deleted file mode 100644 index 9ce06a8..0000000 --- a/ast/cminpack/.deps/libast_la-lmder.Plo +++ /dev/null @@ -1 +0,0 @@ -# dummy diff --git a/ast/cminpack/.deps/libast_la-lmder1.Plo b/ast/cminpack/.deps/libast_la-lmder1.Plo deleted file mode 100644 index 9ce06a8..0000000 --- a/ast/cminpack/.deps/libast_la-lmder1.Plo +++ /dev/null @@ -1 +0,0 @@ -# dummy diff --git a/ast/cminpack/.deps/libast_la-lmpar.Plo b/ast/cminpack/.deps/libast_la-lmpar.Plo deleted file mode 100644 index 9ce06a8..0000000 --- a/ast/cminpack/.deps/libast_la-lmpar.Plo +++ /dev/null @@ -1 +0,0 @@ -# dummy diff --git a/ast/cminpack/.deps/libast_la-qrfac.Plo b/ast/cminpack/.deps/libast_la-qrfac.Plo deleted file mode 100644 index 9ce06a8..0000000 --- a/ast/cminpack/.deps/libast_la-qrfac.Plo +++ /dev/null @@ -1 +0,0 @@ -# dummy diff --git a/ast/cminpack/.deps/libast_la-qrsolv.Plo b/ast/cminpack/.deps/libast_la-qrsolv.Plo deleted file mode 100644 index 9ce06a8..0000000 --- a/ast/cminpack/.deps/libast_la-qrsolv.Plo +++ /dev/null @@ -1 +0,0 @@ -# dummy diff --git a/ast/cminpack/CopyrightMINPACK.txt b/ast/cminpack/CopyrightMINPACK.txt deleted file mode 100644 index ae7984d..0000000 --- a/ast/cminpack/CopyrightMINPACK.txt +++ /dev/null @@ -1,52 +0,0 @@ -Minpack Copyright Notice (1999) University of Chicago. All rights reserved - -Redistribution and use in source and binary forms, with or -without modification, are permitted provided that the -following conditions are met: - -1. Redistributions of source code must retain the above -copyright notice, this list of conditions and the following -disclaimer. - -2. Redistributions in binary form must reproduce the above -copyright notice, this list of conditions and the following -disclaimer in the documentation and/or other materials -provided with the distribution. - -3. The end-user documentation included with the -redistribution, if any, must include the following -acknowledgment: - - "This product includes software developed by the - University of Chicago, as Operator of Argonne National - Laboratory. - -Alternately, this acknowledgment may appear in the software -itself, if and wherever such third-party acknowledgments -normally appear. - -4. WARRANTY DISCLAIMER. THE SOFTWARE IS SUPPLIED "AS IS" -WITHOUT WARRANTY OF ANY KIND. THE COPYRIGHT HOLDER, THE -UNITED STATES, THE UNITED STATES DEPARTMENT OF ENERGY, AND -THEIR EMPLOYEES: (1) DISCLAIM ANY WARRANTIES, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO ANY IMPLIED WARRANTIES -OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, TITLE -OR NON-INFRINGEMENT, (2) DO NOT ASSUME ANY LEGAL LIABILITY -OR RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS, OR -USEFULNESS OF THE SOFTWARE, (3) DO NOT REPRESENT THAT USE OF -THE SOFTWARE WOULD NOT INFRINGE PRIVATELY OWNED RIGHTS, (4) -DO NOT WARRANT THAT THE SOFTWARE WILL FUNCTION -UNINTERRUPTED, THAT IT IS ERROR-FREE OR THAT ANY ERRORS WILL -BE CORRECTED. - -5. LIMITATION OF LIABILITY. IN NO EVENT WILL THE COPYRIGHT -HOLDER, THE UNITED STATES, THE UNITED STATES DEPARTMENT OF -ENERGY, OR THEIR EMPLOYEES: BE LIABLE FOR ANY INDIRECT, -INCIDENTAL, CONSEQUENTIAL, SPECIAL OR PUNITIVE DAMAGES OF -ANY KIND OR NATURE, INCLUDING BUT NOT LIMITED TO LOSS OF -PROFITS OR LOSS OF DATA, FOR ANY REASON WHATSOEVER, WHETHER -SUCH LIABILITY IS ASSERTED ON THE BASIS OF CONTRACT, TORT -(INCLUDING NEGLIGENCE OR STRICT LIABILITY), OR OTHERWISE, -EVEN IF ANY OF SAID PARTIES HAS BEEN WARNED OF THE -POSSIBILITY OF SUCH LOSS OR DAMAGES. - diff --git a/ast/cminpack/README.md b/ast/cminpack/README.md deleted file mode 100644 index 66bbc6f..0000000 --- a/ast/cminpack/README.md +++ /dev/null @@ -1,128 +0,0 @@ -C/C++ Minpack [![Build Status](https://api.travis-ci.org/devernay/cminpack.png?branch=master)](https://travis-ci.org/devernay/cminpack) -========== - -This is a C version of the minpack minimization package. -It has been derived from the fortran code using f2c and -some limited manual editing. Note that you need to link -against libf2c to use this version of minpack. Extern "C" -linkage permits the package routines to be called from C++. -Check ftp://netlib.bell-labs.com/netlib/f2c for the latest -f2c version. For general minpack info and test programs, see -the accompanying readme.txt and http://www.netlib.org/minpack/. - -Type `make` to compile and `make install` to install in /usr/local -or modify the makefile to suit your needs. - -This software has been tested on a RedHat 7.3 Linux machine - -usual 'use at your own risk' warnings apply. - -Manolis Lourakis -- lourakis at ics forth gr, July 2002 - Institute of Computer Science, - Foundation for Research and Technology - Hellas - Heraklion, Crete, Greece - -Repackaging by Frederic Devernay -- frederic dot devernay at m4x dot org - -The project home page is at http://devernay.free.fr/hacks/cminpack/ - -History ------- - -* version 1.3.3 (04/02/2014):: - - Add documentation and examples abouts how to add box constraints to the variables. - - continuous integration https://travis-ci.org/devernay/cminpack - -* version 1.3.2 (27/10/2013): - - Minor change in the CMake build: also set SOVERSION. - -* version 1.3.1 (02/10/2013): - - Fix CUDA examples compilation, and remove non-free files. - -* version 1.3.0 (09/06/2012): - - Optionally use LAPACK and CBLAS in lmpar, qrfac, and qrsolv. Added - "make lapack" to build the LAPACK-based cminpack and "make - checklapack" to test it (results of the test may depend on the - underlying LAPACK and BLAS implementations). - On 64-bits architectures, the preprocessor symbol __LP64__ must be - defined (see cminpackP.h) if the LAPACK library uses the LP64 - interface (i.e. 32-bits integer, vhereas the ILP interface uses 64 - bits integers). - -* version 1.2.2 (16/05/2012): - - Update Makefiles and documentation (see "Using CMinpack" above) for - easier building and testing. - -* version 1.2.1 (15/05/2012): - - The library can now be built as double, float or half - versions. Standard tests in the "examples" directory can now be - lauched using "make check" (to run common tests, including against - the float version), "make checkhalf" (to test the half version) and - "make checkfail" (to run all the tests, even those that fail). - -* version 1.2.0 (14/05/2012): -- Added original FORTRAN sources for better testing (type "make" in - directory fortran, then "make" in examples and follow the - instructions). Added driver tests lmsdrv, chkdrv, hyjdrv, - hybdrv. Typing "make alltest" in the examples directory will run all - possible test combinations (make sure you have gfortran installed). - -* version 1.1.5 (04/05/2012): - - cminpack now works in CUDA, thanks to Jordi Bataller Mascarell, type - "make" in the "cuda" subdir (be careful, though: this is a - straightforward port from C, and each problem is solved using a - single thread). cminpack can now also be compiled with - single-precision floating point computation (define - __cminpack_real__ to float when compiling and using the - library). Fix cmake support for CMINPACK_LIB_INSTALL_DIR. Update the - reference files for tests. - -* version 1.1.4 (30/10/2011): - - Translated all the Levenberg-Marquardt code (lmder, lmdif, lmstr, - lmder1, lmdif1, lmstr1, lmpar, qrfac, qrsolv, fdjac2, chkder) to use - C-style indices. - -* version 1.1.3 (16/03/2011): - - Minor fix: Change non-standard strnstr() to strstr() in - genf77tests.c. - -* version 1.1.2 (07/01/2011): - - Fix Windows DLL building (David Graeff) and document covar in - cminpack.h. - -* version 1.1.1 (04/12/2010): - - Complete rewrite of the C functions (without trailing underscore in - the function name). Using the original FORTRAN code, the original - algorithms structure was recovered, and many goto's were converted - to if...then...else. The code should now be both more readable and - easier to optimize, both for humans and for compilers. Added lmddrv - and lmfdrv test drivers, which test a lot of difficult functions - (these functions are explained in Testing Unconstrained Optimization - Software by Moré et al.). Also added the pkg-config files to the - cmake build, as well as an "uninstall" target, contributed by - Geoffrey Biggs. - -* version 1.0.4 (18/10/2010): - - Support for shared library building using CMake, thanks to Goeffrey - Biggs and Radu Bogdan Rusu from Willow Garage. Shared libraries can be - enabled using cmake options, as in; - cmake -DUSE_FPIC=ON -DSHARED_LIBS=ON -DBUILD_EXAMPLES=OFF path_to_sources - -* version 1.0.3 (18/03/2010): - - Added CMake support. - - XCode build is now Universal. - - Added tfdjac2_ and tfdjac2c examples, which test the accuracy of a - finite-differences approximation of the Jacobian. - - Bug fix in tlmstr1 (signaled by Thomas Capricelli). - -* version 1.0.2 (27/02/2009): - - Added Xcode and Visual Studio project files - -* version 1.0.1 (17/12/2007): - - bug fix in covar() and covar_(), the computation of tolr caused a - segfault (signaled by Timo Hartmann). - -* version 1.0.0 (24/04/2007): - - Added fortran and C examples - - Added documentation from Debian man pages - - Wrote pure C version - - Added covar() and covar_(), and use it in tlmdef/tlmdif diff --git a/ast/cminpack/cminpack.h b/ast/cminpack/cminpack.h deleted file mode 100644 index 6d3f757..0000000 --- a/ast/cminpack/cminpack.h +++ /dev/null @@ -1,370 +0,0 @@ -/* Header file for cminpack, by Frederic Devernay. - The documentation for all functions can be found in the file - minpack-documentation.txt from the distribution, or in the source - code of each function. */ - -#ifndef __CMINPACK_H__ -#define __CMINPACK_H__ - -/* The default floating-point type is "double" for C/C++ and "float" for CUDA, - but you can change this by defining one of the following symbols when - compiling the library, and before including cminpack.h when using it: - __cminpack_double__ for double - __cminpack_float__ for float - __cminpack_half__ for half from the OpenEXR library (in this case, you must - compile cminpack with a C++ compiler) -*/ -#ifdef __cminpack_double__ -#define __cminpack_real__ double -#endif - -#ifdef __cminpack_float__ -#define __cminpack_real__ float -#endif - -#ifdef __cminpack_half__ -#include <OpenEXR/half.h> -#define __cminpack_real__ half -#endif - -#ifdef __cplusplus -extern "C" { -#endif /* __cplusplus */ - -/* Cmake will define cminpack_EXPORTS on Windows when it -configures to build a shared library. If you are going to use -another build system on windows or create the visual studio -projects by hand you need to define cminpack_EXPORTS when -building a DLL on windows. -*/ -#if defined (__GNUC__) -#define CMINPACK_DECLSPEC_EXPORT __declspec(__dllexport__) -#define CMINPACK_DECLSPEC_IMPORT __declspec(__dllimport__) -#endif -#if defined (_MSC_VER) || defined (__BORLANDC__) -#define CMINPACK_DECLSPEC_EXPORT __declspec(dllexport) -#define CMINPACK_DECLSPEC_IMPORT __declspec(dllimport) -#endif -#ifdef __WATCOMC__ -#define CMINPACK_DECLSPEC_EXPORT __export -#define CMINPACK_DECLSPEC_IMPORT __import -#endif -#ifdef __IBMC__ -#define CMINPACK_DECLSPEC_EXPORT _Export -#define CMINPACK_DECLSPEC_IMPORT _Import -#endif - -#if !defined(CMINPACK_NO_DLL) && (defined(__WIN32__) || defined(WIN32) || defined (_WIN32)) -#if defined(cminpack_EXPORTS) || defined(CMINPACK_EXPORTS) || defined(CMINPACK_DLL_EXPORTS) - #define CMINPACK_EXPORT CMINPACK_DECLSPEC_EXPORT - #else - #define CMINPACK_EXPORT CMINPACK_DECLSPEC_IMPORT - #endif /* cminpack_EXPORTS */ -#else /* defined (_WIN32) */ - #define CMINPACK_EXPORT -#endif - -#if defined(__CUDA_ARCH__) || defined(__CUDACC__) -#define __cminpack_attr__ __device__ -#ifndef __cminpack_real__ -#define __cminpack_float__ -#define __cminpack_real__ float -#endif -#define __cminpack_type_fcn_nn__ __cminpack_attr__ int fcn_nn -#define __cminpack_type_fcnder_nn__ __cminpack_attr__ int fcnder_nn -#define __cminpack_type_fcn_mn__ __cminpack_attr__ int fcn_mn -#define __cminpack_type_fcnder_mn__ __cminpack_attr__ int fcnder_mn -#define __cminpack_type_fcnderstr_mn__ __cminpack_attr__ int fcnderstr_mn -#define __cminpack_decl_fcn_nn__ -#define __cminpack_decl_fcnder_nn__ -#define __cminpack_decl_fcn_mn__ -#define __cminpack_decl_fcnder_mn__ -#define __cminpack_decl_fcnderstr_mn__ -#define __cminpack_param_fcn_nn__ -#define __cminpack_param_fcnder_nn__ -#define __cminpack_param_fcn_mn__ -#define __cminpack_param_fcnder_mn__ -#define __cminpack_param_fcnderstr_mn__ -#else -#define __cminpack_attr__ -#ifndef __cminpack_real__ -#define __cminpack_double__ -#define __cminpack_real__ double -#endif -#define __cminpack_type_fcn_nn__ typedef int (*cminpack_func_nn) -#define __cminpack_type_fcnder_nn__ typedef int (*cminpack_funcder_nn) -#define __cminpack_type_fcn_mn__ typedef int (*cminpack_func_mn) -#define __cminpack_type_fcnder_mn__ typedef int (*cminpack_funcder_mn) -#define __cminpack_type_fcnderstr_mn__ typedef int (*cminpack_funcderstr_mn) -#define __cminpack_decl_fcn_nn__ cminpack_func_nn fcn_nn, -#define __cminpack_decl_fcnder_nn__ cminpack_funcder_nn fcnder_nn, -#define __cminpack_decl_fcn_mn__ cminpack_func_mn fcn_mn, -#define __cminpack_decl_fcnder_mn__ cminpack_funcder_mn fcnder_mn, -#define __cminpack_decl_fcnderstr_mn__ cminpack_funcderstr_mn fcnderstr_mn, -#define __cminpack_param_fcn_nn__ fcn_nn, -#define __cminpack_param_fcnder_nn__ fcnder_nn, -#define __cminpack_param_fcn_mn__ fcn_mn, -#define __cminpack_param_fcnder_mn__ fcnder_mn, -#define __cminpack_param_fcnderstr_mn__ fcnderstr_mn, -#endif - -#ifdef __cminpack_double__ -#define __cminpack_func__(func) func -#endif - -#ifdef __cminpack_float__ -#define __cminpack_func__(func) s ## func -#endif - -#ifdef __cminpack_half__ -#define __cminpack_func__(func) h ## func -#endif - -/* Declarations for minpack */ - -/* Function types: */ -/* The first argument can be used to store extra function parameters, thus */ -/* avoiding the use of global variables. */ -/* the iflag parameter is input-only (with respect to the FORTRAN */ -/* version), the output iflag value is the return value of the function. */ -/* If iflag=0, the function shoulkd just print the current values (see */ -/* the nprint parameters below). */ - -/* for hybrd1 and hybrd: */ -/* calculate the functions at x and */ -/* return this vector in fvec. */ -/* return a negative value to terminate hybrd1/hybrd */ -__cminpack_type_fcn_nn__(void *p, int n, const __cminpack_real__ *x, __cminpack_real__ *fvec, int iflag ); - -/* for hybrj1 and hybrj */ -/* if iflag = 1 calculate the functions at x and */ -/* return this vector in fvec. do not alter fjac. */ -/* if iflag = 2 calculate the jacobian at x and */ -/* return this matrix in fjac. do not alter fvec. */ -/* return a negative value to terminate hybrj1/hybrj */ -__cminpack_type_fcnder_nn__(void *p, int n, const __cminpack_real__ *x, __cminpack_real__ *fvec, __cminpack_real__ *fjac, - int ldfjac, int iflag ); - -/* for lmdif1 and lmdif */ -/* calculate the functions at x and */ -/* return this vector in fvec. */ -/* if iflag = 1 the result is used to compute the residuals. */ -/* if iflag = 2 the result is used to compute the Jacobian by finite differences. */ -/* Jacobian computation requires exactly n function calls with iflag = 2. */ -/* return a negative value to terminate lmdif1/lmdif */ -__cminpack_type_fcn_mn__(void *p, int m, int n, const __cminpack_real__ *x, __cminpack_real__ *fvec, - int iflag ); - -/* for lmder1 and lmder */ -/* if iflag = 1 calculate the functions at x and */ -/* return this vector in fvec. do not alter fjac. */ -/* if iflag = 2 calculate the jacobian at x and */ -/* return this matrix in fjac. do not alter fvec. */ -/* return a negative value to terminate lmder1/lmder */ -__cminpack_type_fcnder_mn__(void *p, int m, int n, const __cminpack_real__ *x, __cminpack_real__ *fvec, - __cminpack_real__ *fjac, int ldfjac, int iflag ); - -/* for lmstr1 and lmstr */ -/* if iflag = 1 calculate the functions at x and */ -/* return this vector in fvec. */ -/* if iflag = i calculate the (i-1)-st row of the */ -/* jacobian at x and return this vector in fjrow. */ -/* return a negative value to terminate lmstr1/lmstr */ -__cminpack_type_fcnderstr_mn__(void *p, int m, int n, const __cminpack_real__ *x, __cminpack_real__ *fvec, - __cminpack_real__ *fjrow, int iflag ); - - - - - - -/* MINPACK functions: */ -/* the info parameter was removed from most functions: the return */ -/* value of the function is used instead. */ -/* The argument 'p' can be used to store extra function parameters, thus */ -/* avoiding the use of global variables. You can also think of it as a */ -/* 'this' pointer a la C++. */ - -/* find a zero of a system of N nonlinear functions in N variables by - a modification of the Powell hybrid method (Jacobian calculated by - a forward-difference approximation) */ -__cminpack_attr__ -int CMINPACK_EXPORT __cminpack_func__(hybrd1)( __cminpack_decl_fcn_nn__ - void *p, int n, __cminpack_real__ *x, __cminpack_real__ *fvec, __cminpack_real__ tol, - __cminpack_real__ *wa, int lwa ); - -/* find a zero of a system of N nonlinear functions in N variables by - a modification of the Powell hybrid method (Jacobian calculated by - a forward-difference approximation, more general). */ -__cminpack_attr__ -int CMINPACK_EXPORT __cminpack_func__(hybrd)( __cminpack_decl_fcn_nn__ - void *p, int n, __cminpack_real__ *x, __cminpack_real__ *fvec, __cminpack_real__ xtol, int maxfev, - int ml, int mu, __cminpack_real__ epsfcn, __cminpack_real__ *diag, int mode, - __cminpack_real__ factor, int nprint, int *nfev, - __cminpack_real__ *fjac, int ldfjac, __cminpack_real__ *r, int lr, __cminpack_real__ *qtf, - __cminpack_real__ *wa1, __cminpack_real__ *wa2, __cminpack_real__ *wa3, __cminpack_real__ *wa4); - -/* find a zero of a system of N nonlinear functions in N variables by - a modification of the Powell hybrid method (user-supplied Jacobian) */ -__cminpack_attr__ -int CMINPACK_EXPORT __cminpack_func__(hybrj1)( __cminpack_decl_fcnder_nn__ void *p, int n, __cminpack_real__ *x, - __cminpack_real__ *fvec, __cminpack_real__ *fjac, int ldfjac, __cminpack_real__ tol, - __cminpack_real__ *wa, int lwa ); - -/* find a zero of a system of N nonlinear functions in N variables by - a modification of the Powell hybrid method (user-supplied Jacobian, - more general) */ -__cminpack_attr__ -int CMINPACK_EXPORT __cminpack_func__(hybrj)( __cminpack_decl_fcnder_nn__ void *p, int n, __cminpack_real__ *x, - __cminpack_real__ *fvec, __cminpack_real__ *fjac, int ldfjac, __cminpack_real__ xtol, - int maxfev, __cminpack_real__ *diag, int mode, __cminpack_real__ factor, - int nprint, int *nfev, int *njev, __cminpack_real__ *r, - int lr, __cminpack_real__ *qtf, __cminpack_real__ *wa1, __cminpack_real__ *wa2, - __cminpack_real__ *wa3, __cminpack_real__ *wa4 ); - -/* minimize the sum of the squares of nonlinear functions in N - variables by a modification of the Levenberg-Marquardt algorithm - (Jacobian calculated by a forward-difference approximation) */ -__cminpack_attr__ -int CMINPACK_EXPORT __cminpack_func__(lmdif1)( __cminpack_decl_fcn_mn__ - void *p, int m, int n, __cminpack_real__ *x, __cminpack_real__ *fvec, __cminpack_real__ tol, - int *iwa, __cminpack_real__ *wa, int lwa ); - -/* minimize the sum of the squares of nonlinear functions in N - variables by a modification of the Levenberg-Marquardt algorithm - (Jacobian calculated by a forward-difference approximation, more - general) */ -__cminpack_attr__ -int CMINPACK_EXPORT __cminpack_func__(lmdif)( __cminpack_decl_fcn_mn__ - void *p, int m, int n, __cminpack_real__ *x, __cminpack_real__ *fvec, __cminpack_real__ ftol, - __cminpack_real__ xtol, __cminpack_real__ gtol, int maxfev, __cminpack_real__ epsfcn, - __cminpack_real__ *diag, int mode, __cminpack_real__ factor, int nprint, - int *nfev, __cminpack_real__ *fjac, int ldfjac, int *ipvt, - __cminpack_real__ *qtf, __cminpack_real__ *wa1, __cminpack_real__ *wa2, __cminpack_real__ *wa3, - __cminpack_real__ *wa4 ); - -/* minimize the sum of the squares of nonlinear functions in N - variables by a modification of the Levenberg-Marquardt algorithm - (user-supplied Jacobian) */ -__cminpack_attr__ -int CMINPACK_EXPORT __cminpack_func__(lmder1)( __cminpack_decl_fcnder_mn__ - void *p, int m, int n, __cminpack_real__ *x, __cminpack_real__ *fvec, __cminpack_real__ *fjac, - int ldfjac, __cminpack_real__ tol, int *ipvt, - __cminpack_real__ *wa, int lwa ); - -/* minimize the sum of the squares of nonlinear functions in N - variables by a modification of the Levenberg-Marquardt algorithm - (user-supplied Jacobian, more general) */ -__cminpack_attr__ -int CMINPACK_EXPORT __cminpack_func__(lmder)( __cminpack_decl_fcnder_mn__ - void *p, int m, int n, __cminpack_real__ *x, __cminpack_real__ *fvec, __cminpack_real__ *fjac, - int ldfjac, __cminpack_real__ ftol, __cminpack_real__ xtol, __cminpack_real__ gtol, - int maxfev, __cminpack_real__ *diag, int mode, __cminpack_real__ factor, - int nprint, int *nfev, int *njev, int *ipvt, - __cminpack_real__ *qtf, __cminpack_real__ *wa1, __cminpack_real__ *wa2, __cminpack_real__ *wa3, - __cminpack_real__ *wa4 ); - -/* minimize the sum of the squares of nonlinear functions in N - variables by a modification of the Levenberg-Marquardt algorithm - (user-supplied Jacobian, minimal storage) */ -__cminpack_attr__ -int CMINPACK_EXPORT __cminpack_func__(lmstr1)( __cminpack_decl_fcnderstr_mn__ void *p, int m, int n, - __cminpack_real__ *x, __cminpack_real__ *fvec, __cminpack_real__ *fjac, int ldfjac, - __cminpack_real__ tol, int *ipvt, __cminpack_real__ *wa, int lwa ); - -/* minimize the sum of the squares of nonlinear functions in N - variables by a modification of the Levenberg-Marquardt algorithm - (user-supplied Jacobian, minimal storage, more general) */ -__cminpack_attr__ -int CMINPACK_EXPORT __cminpack_func__(lmstr)( __cminpack_decl_fcnderstr_mn__ void *p, int m, - int n, __cminpack_real__ *x, __cminpack_real__ *fvec, __cminpack_real__ *fjac, - int ldfjac, __cminpack_real__ ftol, __cminpack_real__ xtol, __cminpack_real__ gtol, - int maxfev, __cminpack_real__ *diag, int mode, __cminpack_real__ factor, - int nprint, int *nfev, int *njev, int *ipvt, - __cminpack_real__ *qtf, __cminpack_real__ *wa1, __cminpack_real__ *wa2, __cminpack_real__ *wa3, - __cminpack_real__ *wa4 ); - -__cminpack_attr__ -void CMINPACK_EXPORT __cminpack_func__(chkder)( int m, int n, const __cminpack_real__ *x, __cminpack_real__ *fvec, __cminpack_real__ *fjac, - int ldfjac, __cminpack_real__ *xp, __cminpack_real__ *fvecp, int mode, - __cminpack_real__ *err ); - -__cminpack_attr__ -__cminpack_real__ CMINPACK_EXPORT __cminpack_func__(dpmpar)( int i ); - -__cminpack_attr__ -__cminpack_real__ CMINPACK_EXPORT __cminpack_func__(enorm)( int n, const __cminpack_real__ *x ); - -/* compute a forward-difference approximation to the m by n jacobian - matrix associated with a specified problem of m functions in n - variables. */ -__cminpack_attr__ -int CMINPACK_EXPORT __cminpack_func__(fdjac2)(__cminpack_decl_fcn_mn__ - void *p, int m, int n, __cminpack_real__ *x, const __cminpack_real__ *fvec, __cminpack_real__ *fjac, - int ldfjac, __cminpack_real__ epsfcn, __cminpack_real__ *wa); - -/* compute a forward-difference approximation to the n by n jacobian - matrix associated with a specified problem of n functions in n - variables. if the jacobian has a banded form, then function - evaluations are saved by only approximating the nonzero terms. */ -__cminpack_attr__ -int CMINPACK_EXPORT __cminpack_func__(fdjac1)(__cminpack_decl_fcn_nn__ - void *p, int n, __cminpack_real__ *x, const __cminpack_real__ *fvec, __cminpack_real__ *fjac, int ldfjac, - int ml, int mu, __cminpack_real__ epsfcn, __cminpack_real__ *wa1, - __cminpack_real__ *wa2); - -/* compute inverse(JtJ) after a run of lmdif or lmder. The covariance matrix is obtained - by scaling the result by enorm(y)**2/(m-n). If JtJ is singular and k = rank(J), the - pseudo-inverse is computed, and the result has to be scaled by enorm(y)**2/(m-k). */ -__cminpack_attr__ -void CMINPACK_EXPORT __cminpack_func__(covar)(int n, __cminpack_real__ *r, int ldr, - const int *ipvt, __cminpack_real__ tol, __cminpack_real__ *wa); - -/* covar1 estimates the variance-covariance matrix: - C = sigma**2 (JtJ)**+ - where (JtJ)**+ is the inverse of JtJ or the pseudo-inverse of JtJ (in case J does not have full rank), - and sigma**2 = fsumsq / (m - k) - where fsumsq is the residual sum of squares and k is the rank of J. - The function returns 0 if J has full rank, else the rank of J. -*/ -__cminpack_attr__ -int CMINPACK_EXPORT __cminpack_func__(covar1)(int m, int n, __cminpack_real__ fsumsq, __cminpack_real__ *r, int ldr, - const int *ipvt, __cminpack_real__ tol, __cminpack_real__ *wa); - -/* internal MINPACK subroutines */ -__cminpack_attr__ -void __cminpack_func__(dogleg)(int n, const __cminpack_real__ *r, int lr, - const __cminpack_real__ *diag, const __cminpack_real__ *qtb, __cminpack_real__ delta, __cminpack_real__ *x, - __cminpack_real__ *wa1, __cminpack_real__ *wa2); -__cminpack_attr__ -void __cminpack_func__(qrfac)(int m, int n, __cminpack_real__ *a, int - lda, int pivot, int *ipvt, int lipvt, __cminpack_real__ *rdiag, - __cminpack_real__ *acnorm, __cminpack_real__ *wa); -__cminpack_attr__ -void __cminpack_func__(qrsolv)(int n, __cminpack_real__ *r, int ldr, - const int *ipvt, const __cminpack_real__ *diag, const __cminpack_real__ *qtb, __cminpack_real__ *x, - __cminpack_real__ *sdiag, __cminpack_real__ *wa); -__cminpack_attr__ -void __cminpack_func__(qform)(int m, int n, __cminpack_real__ *q, int - ldq, __cminpack_real__ *wa); -__cminpack_attr__ -void __cminpack_func__(r1updt)(int m, int n, __cminpack_real__ *s, int - ls, const __cminpack_real__ *u, __cminpack_real__ *v, __cminpack_real__ *w, int *sing); -__cminpack_attr__ -void __cminpack_func__(r1mpyq)(int m, int n, __cminpack_real__ *a, int - lda, const __cminpack_real__ *v, const __cminpack_real__ *w); -__cminpack_attr__ -void __cminpack_func__(lmpar)(int n, __cminpack_real__ *r, int ldr, - const int *ipvt, const __cminpack_real__ *diag, const __cminpack_real__ *qtb, __cminpack_real__ delta, - __cminpack_real__ *par, __cminpack_real__ *x, __cminpack_real__ *sdiag, __cminpack_real__ *wa1, - __cminpack_real__ *wa2); -__cminpack_attr__ -void __cminpack_func__(rwupdt)(int n, __cminpack_real__ *r, int ldr, - const __cminpack_real__ *w, __cminpack_real__ *b, __cminpack_real__ *alpha, __cminpack_real__ *cos, - __cminpack_real__ *sin); -#ifdef __cplusplus -} -#endif /* __cplusplus */ - - -#endif /* __CMINPACK_H__ */ diff --git a/ast/cminpack/cminpackP.h b/ast/cminpack/cminpackP.h deleted file mode 100644 index 4e8ba7b..0000000 --- a/ast/cminpack/cminpackP.h +++ /dev/null @@ -1,62 +0,0 @@ -/* Internal header file for cminpack, by Frederic Devernay. */ -#ifndef __CMINPACKP_H__ -#define __CMINPACKP_H__ - -#ifndef __CMINPACK_H__ -#error "cminpackP.h in an internal cminpack header, and must be included after all other headers (including cminpack.h)" -#endif - -#if (defined (USE_CBLAS) || defined (USE_LAPACK)) && !defined (__cminpack_double__) -#error "cminpack can use cblas and lapack only in double precision mode" -#endif - -#ifdef USE_CBLAS -#ifdef __APPLE__ -#include <Accelerate/Accelerate.h> -#else -#include <cblas.h> -#endif -#define __cminpack_enorm__(n,x) cblas_dnrm2(n,x,1) -#else -#define __cminpack_enorm__(n,x) __cminpack_func__(enorm)(n,x) -#endif - -#ifdef USE_LAPACK -#ifdef __APPLE__ -#include <Accelerate/Accelerate.h> -#else -#if defined(__LP64__) /* In LP64 match sizes with the 32 bit ABI */ -typedef int __CLPK_integer; -typedef int __CLPK_logical; -typedef float __CLPK_real; -typedef double __CLPK_doublereal; -typedef __CLPK_logical (*__CLPK_L_fp)(); -typedef int __CLPK_ftnlen; -#else -typedef long int __CLPK_integer; -typedef long int __CLPK_logical; -typedef float __CLPK_real; -typedef double __CLPK_doublereal; -typedef __CLPK_logical (*__CLPK_L_fp)(); -typedef long int __CLPK_ftnlen; -#endif -//extern void dlartg_(double *f, double *g, double *cs, double *sn, double *r__); -int dlartg_(__CLPK_doublereal *f, __CLPK_doublereal *g, __CLPK_doublereal *cs, - __CLPK_doublereal *sn, __CLPK_doublereal *r__) -//extern void dgeqp3_(int *m, int *n, double *a, int *lda, int *jpvt, double *tau, double *work, int *lwork, int *info); -int dgeqp3_(__CLPK_integer *m, __CLPK_integer *n, __CLPK_doublereal *a, __CLPK_integer * - lda, __CLPK_integer *jpvt, __CLPK_doublereal *tau, __CLPK_doublereal *work, __CLPK_integer *lwork, - __CLPK_integer *info) -//extern void dgeqrf_(int *m, int *n, double *a, int *lda, double *tau, double *work, int *lwork, int *info); -int dgeqrf_(__CLPK_integer *m, __CLPK_integer *n, __CLPK_doublereal *a, __CLPK_integer * - lda, __CLPK_doublereal *tau, __CLPK_doublereal *work, __CLPK_integer *lwork, __CLPK_integer *info) -#endif -#endif - -#define real __cminpack_real__ -#define min(a,b) ((a) <= (b) ? (a) : (b)) -#define max(a,b) ((a) >= (b) ? (a) : (b)) -#define TRUE_ (1) -#define FALSE_ (0) - -#endif /* !__CMINPACKP_H__ */ diff --git a/ast/cminpack/dpmpar.c b/ast/cminpack/dpmpar.c deleted file mode 100644 index 81c6fcd..0000000 --- a/ast/cminpack/dpmpar.c +++ /dev/null @@ -1,201 +0,0 @@ -#include "cminpack.h" -#include <float.h> -#include "cminpackP.h" - -#define double_EPSILON DBL_EPSILON -#define double_MIN DBL_MIN -#define double_MAX DBL_MAX -#define float_EPSILON FLT_EPSILON -#define float_MIN FLT_MIN -#define float_MAX FLT_MAX -#define half_EPSILON HALF_EPSILON -#define half_MIN HALF_NRM_MIN -#define half_MAX HALF_MAX - -#define DPMPAR(type,X) _DPMPAR(type,X) -#define _DPMPAR(type,X) type ## _ ## X - -__cminpack_attr__ -real __cminpack_func__(dpmpar)(int i) -{ -/* ********** */ - -/* Function dpmpar */ - -/* This function provides double precision machine parameters */ -/* when the appropriate set of data statements is activated (by */ -/* removing the c from column 1) and all other data statements are */ -/* rendered inactive. Most of the parameter values were obtained */ -/* from the corresponding Bell Laboratories Port Library function. */ - -/* The function statement is */ - -/* double precision function dpmpar(i) */ - -/* where */ - -/* i is an integer input variable set to 1, 2, or 3 which */ -/* selects the desired machine parameter. If the machine has */ -/* t base b digits and its smallest and largest exponents are */ -/* emin and emax, respectively, then these parameters are */ - -/* dpmpar(1) = b**(1 - t), the machine precision, */ - -/* dpmpar(2) = b**(emin - 1), the smallest magnitude, */ - -/* dpmpar(3) = b**emax*(1 - b**(-t)), the largest magnitude. */ - -/* Argonne National Laboratory. MINPACK Project. November 1996. */ -/* Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More' */ - -/* ********** */ - -/* Machine constants for the IBM 360/370 series, */ -/* the Amdahl 470/V6, the ICL 2900, the Itel AS/6, */ -/* the Xerox Sigma 5/7/9 and the Sel systems 85/86. */ - -/* data mcheps(1),mcheps(2) / z34100000, z00000000 / */ -/* data minmag(1),minmag(2) / z00100000, z00000000 / */ -/* data maxmag(1),maxmag(2) / z7fffffff, zffffffff / */ - -/* Machine constants for the Honeywell 600/6000 series. */ - -/* data mcheps(1),mcheps(2) / o606400000000, o000000000000 / */ -/* data minmag(1),minmag(2) / o402400000000, o000000000000 / */ -/* data maxmag(1),maxmag(2) / o376777777777, o777777777777 / */ - -/* Machine constants for the CDC 6000/7000 series. */ - -/* data mcheps(1) / 15614000000000000000b / */ -/* data mcheps(2) / 15010000000000000000b / */ - -/* data minmag(1) / 00604000000000000000b / */ -/* data minmag(2) / 00000000000000000000b / */ - -/* data maxmag(1) / 37767777777777777777b / */ -/* data maxmag(2) / 37167777777777777777b / */ - -/* Machine constants for the PDP-10 (KA processor). */ - -/* data mcheps(1),mcheps(2) / "114400000000, "000000000000 / */ -/* data minmag(1),minmag(2) / "033400000000, "000000000000 / */ -/* data maxmag(1),maxmag(2) / "377777777777, "344777777777 / */ - -/* Machine constants for the PDP-10 (KI processor). */ - -/* data mcheps(1),mcheps(2) / "104400000000, "000000000000 / */ -/* data minmag(1),minmag(2) / "000400000000, "000000000000 / */ -/* data maxmag(1),maxmag(2) / "377777777777, "377777777777 / */ - -/* Machine constants for the PDP-11. */ - -/* data mcheps(1),mcheps(2) / 9472, 0 / */ -/* data mcheps(3),mcheps(4) / 0, 0 / */ - -/* data minmag(1),minmag(2) / 128, 0 / */ -/* data minmag(3),minmag(4) / 0, 0 / */ - -/* data maxmag(1),maxmag(2) / 32767, -1 / */ -/* data maxmag(3),maxmag(4) / -1, -1 / */ - -/* Machine constants for the Burroughs 6700/7700 systems. */ - -/* data mcheps(1) / o1451000000000000 / */ -/* data mcheps(2) / o0000000000000000 / */ - -/* data minmag(1) / o1771000000000000 / */ -/* data minmag(2) / o7770000000000000 / */ - -/* data maxmag(1) / o0777777777777777 / */ -/* data maxmag(2) / o7777777777777777 / */ - -/* Machine constants for the Burroughs 5700 system. */ - -/* data mcheps(1) / o1451000000000000 / */ -/* data mcheps(2) / o0000000000000000 / */ - -/* data minmag(1) / o1771000000000000 / */ -/* data minmag(2) / o0000000000000000 / */ - -/* data maxmag(1) / o0777777777777777 / */ -/* data maxmag(2) / o0007777777777777 / */ - -/* Machine constants for the Burroughs 1700 system. */ - -/* data mcheps(1) / zcc6800000 / */ -/* data mcheps(2) / z000000000 / */ - -/* data minmag(1) / zc00800000 / */ -/* data minmag(2) / z000000000 / */ - -/* data maxmag(1) / zdffffffff / */ -/* data maxmag(2) / zfffffffff / */ - -/* Machine constants for the Univac 1100 series. */ - -/* data mcheps(1),mcheps(2) / o170640000000, o000000000000 / */ -/* data minmag(1),minmag(2) / o000040000000, o000000000000 / */ -/* data maxmag(1),maxmag(2) / o377777777777, o777777777777 / */ - -/* Machine constants for the Data General Eclipse S/200. */ - -/* Note - it may be appropriate to include the following card - */ -/* static dmach(3) */ - -/* data minmag/20k,3*0/,maxmag/77777k,3*177777k/ */ -/* data mcheps/32020k,3*0/ */ - -/* Machine constants for the Harris 220. */ - -/* data mcheps(1),mcheps(2) / '20000000, '00000334 / */ -/* data minmag(1),minmag(2) / '20000000, '00000201 / */ -/* data maxmag(1),maxmag(2) / '37777777, '37777577 / */ - -/* Machine constants for the Cray-1. */ - -/* data mcheps(1) / 0376424000000000000000b / */ -/* data mcheps(2) / 0000000000000000000000b / */ - -/* data minmag(1) / 0200034000000000000000b / */ -/* data minmag(2) / 0000000000000000000000b / */ - -/* data maxmag(1) / 0577777777777777777777b / */ -/* data maxmag(2) / 0000007777777777777776b / */ - -/* Machine constants for the Prime 400. */ - -/* data mcheps(1),mcheps(2) / :10000000000, :00000000123 / */ -/* data minmag(1),minmag(2) / :10000000000, :00000100000 / */ -/* data maxmag(1),maxmag(2) / :17777777777, :37777677776 / */ - -/* Machine constants for the VAX-11. */ - -/* data mcheps(1),mcheps(2) / 9472, 0 / */ -/* data minmag(1),minmag(2) / 128, 0 / */ -/* data maxmag(1),maxmag(2) / -32769, -1 / */ - -/* Machine constants for IEEE machines. */ - -/* data dmach(1) /2.22044604926d-16/ */ -/* data dmach(2) /2.22507385852d-308/ */ -/* data dmach(3) /1.79769313485d+308/ */ - - switch(i) { - case 1: - return DPMPAR(real,EPSILON); /* 2.2204460492503131e-16 | 1.19209290e-07F */ - case 2: - return DPMPAR(real,MIN); /* 2.2250738585072014e-308 | 1.17549435e-38F */ - default: - return DPMPAR(real,MAX); /* 1.7976931348623157e+308 | 3.40282347e+38F */ - } - -/* Last card of function dpmpar. */ - -} /* dpmpar_ */ - -#undef mcheps -#undef maxmag -#undef minmag -#undef dmach - - diff --git a/ast/cminpack/enorm.c b/ast/cminpack/enorm.c deleted file mode 100644 index ad10824..0000000 --- a/ast/cminpack/enorm.c +++ /dev/null @@ -1,157 +0,0 @@ -#include "cminpack.h" -#include <math.h> -#include "cminpackP.h" - -/* - About the values for rdwarf and rgiant. - - The original values, both in signe-precision FORTRAN source code and in double-precision code were: -#define rdwarf 3.834e-20 -#define rgiant 1.304e19 - See for example: - http://www.netlib.org/slatec/src/denorm.f - http://www.netlib.org/slatec/src/enorm.f - However, rdwarf is smaller than sqrt(FLT_MIN) = 1.0842021724855044e-19, so that rdwarf**2 will - underflow. This contradicts the constraints expressed in the comments below. - - We changed these constants to be sqrt(dpmpar(2))*0.9 and sqrt(dpmpar(3))*0.9, as proposed by the - implementation found in MPFIT http://cow.physics.wisc.edu/~craigm/idl/fitting.html -*/ - -#define double_dwarf (1.4916681462400413e-154*0.9) -#define double_giant (1.3407807929942596e+154*0.9) -#define float_dwarf (1.0842021724855044e-19f*0.9f) -#define float_giant (1.8446743523953730e+19f*0.9f) -#define half_dwarf (2.4414062505039999e-4f*0.9f) -#define half_giant (255.93749236874225497222f*0.9f) - -#define dwarf(type) _dwarf(type) -#define _dwarf(type) type ## _dwarf -#define giant(type) _giant(type) -#define _giant(type) type ## _giant - -#define rdwarf dwarf(real) -#define rgiant giant(real) - -__cminpack_attr__ -real __cminpack_func__(enorm)(int n, const real *x) -{ -#ifdef USE_CBLAS - return cblas_dnrm2(n, x, 1); -#else /* !USE_CBLAS */ - /* System generated locals */ - real ret_val, d1; - - /* Local variables */ - int i; - real s1, s2, s3, xabs, x1max, x3max, agiant, floatn; - -/* ********** */ - -/* function enorm */ - -/* given an n-vector x, this function calculates the */ -/* euclidean norm of x. */ - -/* the euclidean norm is computed by accumulating the sum of */ -/* squares in three different sums. the sums of squares for the */ -/* small and large components are scaled so that no overflows */ -/* occur. non-destructive underflows are permitted. underflows */ -/* and overflows do not occur in the computation of the unscaled */ -/* sum of squares for the intermediate components. */ -/* the definitions of small, intermediate and large components */ -/* depend on two constants, rdwarf and rgiant. the main */ -/* restrictions on these constants are that rdwarf**2 not */ -/* underflow and rgiant**2 not overflow. the constants */ -/* given here are suitable for every known computer. */ - -/* the function statement is */ - -/* double precision function enorm(n,x) */ - -/* where */ - -/* n is a positive integer input variable. */ - -/* x is an input array of length n. */ - -/* subprograms called */ - -/* fortran-supplied ... dabs,dsqrt */ - -/* argonne national laboratory. minpack project. march 1980. */ -/* burton s. garbow, kenneth e. hillstrom, jorge j. more */ - -/* ********** */ - - s1 = 0.; - s2 = 0.; - s3 = 0.; - x1max = 0.; - x3max = 0.; - floatn = (real) (n); - agiant = rgiant / floatn; - for (i = 0; i < n; ++i) { - xabs = fabs(x[i]); - if (xabs <= rdwarf || xabs >= agiant) { - if (xabs > rdwarf) { - -/* sum for large components. */ - - if (xabs > x1max) { - /* Computing 2nd power */ - d1 = x1max / xabs; - s1 = 1. + s1 * (d1 * d1); - x1max = xabs; - } else { - /* Computing 2nd power */ - d1 = xabs / x1max; - s1 += d1 * d1; - } - } else { - -/* sum for small components. */ - - if (xabs > x3max) { - /* Computing 2nd power */ - d1 = x3max / xabs; - s3 = 1. + s3 * (d1 * d1); - x3max = xabs; - } else { - if (xabs != 0.) { - /* Computing 2nd power */ - d1 = xabs / x3max; - s3 += d1 * d1; - } - } - } - } else { - -/* sum for intermediate components. */ - - /* Computing 2nd power */ - s2 += xabs * xabs; - } - } - -/* calculation of norm. */ - - if (s1 != 0.) { - ret_val = x1max * sqrt(s1 + (s2 / x1max) / x1max); - } else { - if (s2 != 0.) { - if (s2 >= x3max) { - ret_val = sqrt(s2 * (1. + (x3max / s2) * (x3max * s3))); - } else { - ret_val = sqrt(x3max * ((s2 / x3max) + (x3max * s3))); - } - } else { - ret_val = x3max * sqrt(s3); - } - } - return ret_val; - -/* last card of function enorm. */ -#endif /* !USE_CBLAS */ -} /* enorm_ */ - diff --git a/ast/cminpack/lmder.c b/ast/cminpack/lmder.c deleted file mode 100644 index 7f57428..0000000 --- a/ast/cminpack/lmder.c +++ /dev/null @@ -1,526 +0,0 @@ -#include "cminpack.h" -#include <math.h> -#include "cminpackP.h" - -__cminpack_attr__ -int __cminpack_func__(lmder)(__cminpack_decl_fcnder_mn__ void *p, int m, int n, real *x, - real *fvec, real *fjac, int ldfjac, real ftol, - real xtol, real gtol, int maxfev, real * - diag, int mode, real factor, int nprint, - int *nfev, int *njev, int *ipvt, real *qtf, - real *wa1, real *wa2, real *wa3, real *wa4) -{ - /* Initialized data */ - -#define p1 .1 -#define p5 .5 -#define p25 .25 -#define p75 .75 -#define p0001 1e-4 - - /* System generated locals */ - real d1, d2; - - /* Local variables */ - int i, j, l; - real par, sum; - int iter; - real temp, temp1, temp2; - int iflag; - real delta = 0.; - real ratio; - real fnorm, gnorm, pnorm, xnorm = 0., fnorm1, actred, dirder, - epsmch, prered; - int info; - -/* ********** */ - -/* subroutine lmder */ - -/* the purpose of lmder is to minimize the sum of the squares of */ -/* m nonlinear functions in n variables by a modification of */ -/* the levenberg-marquardt algorithm. the user must provide a */ -/* subroutine which calculates the functions and the jacobian. */ - -/* the subroutine statement is */ - -/* subroutine lmder(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol, */ -/* maxfev,diag,mode,factor,nprint,info,nfev, */ -/* njev,ipvt,qtf,wa1,wa2,wa3,wa4) */ - -/* where */ - -/* fcn is the name of the user-supplied subroutine which */ -/* calculates the functions and the jacobian. fcn must */ -/* be declared in an external statement in the user */ -/* calling program, and should be written as follows. */ - -/* subroutine fcn(m,n,x,fvec,fjac,ldfjac,iflag) */ -/* integer m,n,ldfjac,iflag */ -/* double precision x(n),fvec(m),fjac(ldfjac,n) */ -/* ---------- */ -/* if iflag = 1 calculate the functions at x and */ -/* return this vector in fvec. do not alter fjac. */ -/* if iflag = 2 calculate the jacobian at x and */ -/* return this matrix in fjac. do not alter fvec. */ -/* ---------- */ -/* return */ -/* end */ - -/* the value of iflag should not be changed by fcn unless */ -/* the user wants to terminate execution of lmder. */ -/* in this case set iflag to a negative integer. */ - -/* m is a positive integer input variable set to the number */ -/* of functions. */ - -/* n is a positive integer input variable set to the number */ -/* of variables. n must not exceed m. */ - -/* x is an array of length n. on input x must contain */ -/* an initial estimate of the solution vector. on output x */ -/* contains the final estimate of the solution vector. */ - -/* fvec is an output array of length m which contains */ -/* the functions evaluated at the output x. */ - -/* fjac is an output m by n array. the upper n by n submatrix */ -/* of fjac contains an upper triangular matrix r with */ -/* diagonal elements of nonincreasing magnitude such that */ - -/* t t t */ -/* p *(jac *jac)*p = r *r, */ - -/* where p is a permutation matrix and jac is the final */ -/* calculated jacobian. column j of p is column ipvt(j) */ -/* (see below) of the identity matrix. the lower trapezoidal */ -/* part of fjac contains information generated during */ -/* the computation of r. */ - -/* ldfjac is a positive integer input variable not less than m */ -/* which specifies the leading dimension of the array fjac. */ - -/* ftol is a nonnegative input variable. termination */ -/* occurs when both the actual and predicted relative */ -/* reductions in the sum of squares are at most ftol. */ -/* therefore, ftol measures the relative error desired */ -/* in the sum of squares. */ - -/* xtol is a nonnegative input variable. termination */ -/* occurs when the relative error between two consecutive */ -/* iterates is at most xtol. therefore, xtol measures the */ -/* relative error desired in the approximate solution. */ - -/* gtol is a nonnegative input variable. termination */ -/* occurs when the cosine of the angle between fvec and */ -/* any column of the jacobian is at most gtol in absolute */ -/* value. therefore, gtol measures the orthogonality */ -/* desired between the function vector and the columns */ -/* of the jacobian. */ - -/* maxfev is a positive integer input variable. termination */ -/* occurs when the number of calls to fcn with iflag = 1 */ -/* has reached maxfev. */ - -/* diag is an array of length n. if mode = 1 (see */ -/* below), diag is internally set. if mode = 2, diag */ -/* must contain positive entries that serve as */ -/* multiplicative scale factors for the variables. */ - -/* mode is an integer input variable. if mode = 1, the */ -/* variables will be scaled internally. if mode = 2, */ -/* the scaling is specified by the input diag. other */ -/* values of mode are equivalent to mode = 1. */ - -/* factor is a positive input variable used in determining the */ -/* initial step bound. this bound is set to the product of */ -/* factor and the euclidean norm of diag*x if nonzero, or else */ -/* to factor itself. in most cases factor should lie in the */ -/* interval (.1,100.).100. is a generally recommended value. */ - -/* nprint is an integer input variable that enables controlled */ -/* printing of iterates if it is positive. in this case, */ -/* fcn is called with iflag = 0 at the beginning of the first */ -/* iteration and every nprint iterations thereafter and */ -/* immediately prior to return, with x, fvec, and fjac */ -/* available for printing. fvec and fjac should not be */ -/* altered. if nprint is not positive, no special calls */ -/* of fcn with iflag = 0 are made. */ - -/* info is an integer output variable. if the user has */ -/* terminated execution, info is set to the (negative) */ -/* value of iflag. see description of fcn. otherwise, */ -/* info is set as follows. */ - -/* info = 0 improper input parameters. */ - -/* info = 1 both actual and predicted relative reductions */ -/* in the sum of squares are at most ftol. */ - -/* info = 2 relative error between two consecutive iterates */ -/* is at most xtol. */ - -/* info = 3 conditions for info = 1 and info = 2 both hold. */ - -/* info = 4 the cosine of the angle between fvec and any */ -/* column of the jacobian is at most gtol in */ -/* absolute value. */ - -/* info = 5 number of calls to fcn with iflag = 1 has */ -/* reached maxfev. */ - -/* info = 6 ftol is too small. no further reduction in */ -/* the sum of squares is possible. */ - -/* info = 7 xtol is too small. no further improvement in */ -/* the approximate solution x is possible. */ - -/* info = 8 gtol is too small. fvec is orthogonal to the */ -/* columns of the jacobian to machine precision. */ - -/* nfev is an integer output variable set to the number of */ -/* calls to fcn with iflag = 1. */ - -/* njev is an integer output variable set to the number of */ -/* calls to fcn with iflag = 2. */ - -/* ipvt is an integer output array of length n. ipvt */ -/* defines a permutation matrix p such that jac*p = q*r, */ -/* where jac is the final calculated jacobian, q is */ -/* orthogonal (not stored), and r is upper triangular */ -/* with diagonal elements of nonincreasing magnitude. */ -/* column j of p is column ipvt(j) of the identity matrix. */ - -/* qtf is an output array of length n which contains */ -/* the first n elements of the vector (q transpose)*fvec. */ - -/* wa1, wa2, and wa3 are work arrays of length n. */ - -/* wa4 is a work array of length m. */ - -/* subprograms called */ - -/* user-supplied ...... fcn */ - -/* minpack-supplied ... dpmpar,enorm,lmpar,qrfac */ - -/* fortran-supplied ... dabs,dmax1,dmin1,dsqrt,mod */ - -/* argonne national laboratory. minpack project. march 1980. */ -/* burton s. garbow, kenneth e. hillstrom, jorge j. more */ - -/* ********** */ - -/* epsmch is the machine precision. */ - - epsmch = __cminpack_func__(dpmpar)(1); - - info = 0; - iflag = 0; - *nfev = 0; - *njev = 0; - -/* check the input parameters for errors. */ - - if (n <= 0 || m < n || ldfjac < m || ftol < 0. || xtol < 0. || - gtol < 0. || maxfev <= 0 || factor <= 0.) { - goto TERMINATE; - } - if (mode == 2) { - for (j = 0; j < n; ++j) { - if (diag[j] <= 0.) { - goto TERMINATE; - } - } - } - -/* evaluate the function at the starting point */ -/* and calculate its norm. */ - - iflag = fcnder_mn(p, m, n, x, fvec, fjac, ldfjac, 1); - *nfev = 1; - if (iflag < 0) { - goto TERMINATE; - } - fnorm = __cminpack_enorm__(m, fvec); - -/* initialize levenberg-marquardt parameter and iteration counter. */ - - par = 0.; - iter = 1; - -/* beginning of the outer loop. */ - - for (;;) { - -/* calculate the jacobian matrix. */ - - iflag = fcnder_mn(p, m, n, x, fvec, fjac, ldfjac, 2); - ++(*njev); - if (iflag < 0) { - goto TERMINATE; - } - -/* if requested, call fcn to enable printing of iterates. */ - - if (nprint > 0) { - iflag = 0; - if ((iter - 1) % nprint == 0) { - iflag = fcnder_mn(p, m, n, x, fvec, fjac, ldfjac, 0); - } - if (iflag < 0) { - goto TERMINATE; - } - } - -/* compute the qr factorization of the jacobian. */ - - __cminpack_func__(qrfac)(m, n, fjac, ldfjac, TRUE_, ipvt, n, - wa1, wa2, wa3); - -/* on the first iteration and if mode is 1, scale according */ -/* to the norms of the columns of the initial jacobian. */ - - if (iter == 1) { - if (mode != 2) { - for (j = 0; j < n; ++j) { - diag[j] = wa2[j]; - if (wa2[j] == 0.) { - diag[j] = 1.; - } - } - } - -/* on the first iteration, calculate the norm of the scaled x */ -/* and initialize the step bound delta. */ - - for (j = 0; j < n; ++j) { - wa3[j] = diag[j] * x[j]; - } - xnorm = __cminpack_enorm__(n, wa3); - delta = factor * xnorm; - if (delta == 0.) { - delta = factor; - } - } - -/* form (q transpose)*fvec and store the first n components in */ -/* qtf. */ - - for (i = 0; i < m; ++i) { - wa4[i] = fvec[i]; - } - for (j = 0; j < n; ++j) { - if (fjac[j + j * ldfjac] != 0.) { - sum = 0.; - for (i = j; i < m; ++i) { - sum += fjac[i + j * ldfjac] * wa4[i]; - } - temp = -sum / fjac[j + j * ldfjac]; - for (i = j; i < m; ++i) { - wa4[i] += fjac[i + j * ldfjac] * temp; - } - } - fjac[j + j * ldfjac] = wa1[j]; - qtf[j] = wa4[j]; - } - -/* compute the norm of the scaled gradient. */ - - gnorm = 0.; - if (fnorm != 0.) { - for (j = 0; j < n; ++j) { - l = ipvt[j]-1; - if (wa2[l] != 0.) { - sum = 0.; - for (i = 0; i <= j; ++i) { - sum += fjac[i + j * ldfjac] * (qtf[i] / fnorm); - } - /* Computing MAX */ - d1 = fabs(sum / wa2[l]); - gnorm = max(gnorm,d1); - } - } - } - -/* test for convergence of the gradient norm. */ - - if (gnorm <= gtol) { - info = 4; - } - if (info != 0) { - goto TERMINATE; - } - -/* rescale if necessary. */ - - if (mode != 2) { - for (j = 0; j < n; ++j) { - /* Computing MAX */ - d1 = diag[j], d2 = wa2[j]; - diag[j] = max(d1,d2); - } - } - -/* beginning of the inner loop. */ - - do { - -/* determine the levenberg-marquardt parameter. */ - - __cminpack_func__(lmpar)(n, fjac, ldfjac, ipvt, diag, qtf, delta, - &par, wa1, wa2, wa3, wa4); - -/* store the direction p and x + p. calculate the norm of p. */ - - for (j = 0; j < n; ++j) { - wa1[j] = -wa1[j]; - wa2[j] = x[j] + wa1[j]; - wa3[j] = diag[j] * wa1[j]; - } - pnorm = __cminpack_enorm__(n, wa3); - -/* on the first iteration, adjust the initial step bound. */ - - if (iter == 1) { - delta = min(delta,pnorm); - } - -/* evaluate the function at x + p and calculate its norm. */ - - iflag = fcnder_mn(p, m, n, wa2, wa4, fjac, ldfjac, 1); - ++(*nfev); - if (iflag < 0) { - goto TERMINATE; - } - fnorm1 = __cminpack_enorm__(m, wa4); - -/* compute the scaled actual reduction. */ - - actred = -1.; - if (p1 * fnorm1 < fnorm) { - /* Computing 2nd power */ - d1 = fnorm1 / fnorm; - actred = 1. - d1 * d1; - } - -/* compute the scaled predicted reduction and */ -/* the scaled directional derivative. */ - - for (j = 0; j < n; ++j) { - wa3[j] = 0.; - l = ipvt[j]-1; - temp = wa1[l]; - for (i = 0; i <= j; ++i) { - wa3[i] += fjac[i + j * ldfjac] * temp; - } - } - temp1 = __cminpack_enorm__(n, wa3) / fnorm; - temp2 = (sqrt(par) * pnorm) / fnorm; - prered = temp1 * temp1 + temp2 * temp2 / p5; - dirder = -(temp1 * temp1 + temp2 * temp2); - -/* compute the ratio of the actual to the predicted */ -/* reduction. */ - - ratio = 0.; - if (prered != 0.) { - ratio = actred / prered; - } - -/* update the step bound. */ - - if (ratio <= p25) { - if (actred >= 0.) { - temp = p5; - } else { - temp = p5 * dirder / (dirder + p5 * actred); - } - if (p1 * fnorm1 >= fnorm || temp < p1) { - temp = p1; - } - /* Computing MIN */ - d1 = pnorm / p1; - delta = temp * min(delta,d1); - par /= temp; - } else { - if (par == 0. || ratio >= p75) { - delta = pnorm / p5; - par = p5 * par; - } - } - -/* test for successful iteration. */ - - if (ratio >= p0001) { - -/* successful iteration. update x, fvec, and their norms. */ - - for (j = 0; j < n; ++j) { - x[j] = wa2[j]; - wa2[j] = diag[j] * x[j]; - } - for (i = 0; i < m; ++i) { - fvec[i] = wa4[i]; - } - xnorm = __cminpack_enorm__(n, wa2); - fnorm = fnorm1; - ++iter; - } - -/* tests for convergence. */ - - if (fabs(actred) <= ftol && prered <= ftol && p5 * ratio <= 1.) { - info = 1; - } - if (delta <= xtol * xnorm) { - info = 2; - } - if (fabs(actred) <= ftol && prered <= ftol && p5 * ratio <= 1. && info == 2) { - info = 3; - } - if (info != 0) { - goto TERMINATE; - } - -/* tests for termination and stringent tolerances. */ - - if (*nfev >= maxfev) { - info = 5; - } - if (fabs(actred) <= epsmch && prered <= epsmch && p5 * ratio <= 1.) { - info = 6; - } - if (delta <= epsmch * xnorm) { - info = 7; - } - if (gnorm <= epsmch) { - info = 8; - } - if (info != 0) { - goto TERMINATE; - } - -/* end of the inner loop. repeat if iteration unsuccessful. */ - - } while (ratio < p0001); - -/* end of the outer loop. */ - - } -TERMINATE: - -/* termination, either normal or user imposed. */ - - if (iflag < 0) { - info = iflag; - } - if (nprint > 0) { - fcnder_mn(p, m, n, x, fvec, fjac, ldfjac, 0); - } - return info; - -/* last card of subroutine lmder. */ - -} /* lmder_ */ - diff --git a/ast/cminpack/lmder1.c b/ast/cminpack/lmder1.c deleted file mode 100644 index 581462e..0000000 --- a/ast/cminpack/lmder1.c +++ /dev/null @@ -1,167 +0,0 @@ -#include "cminpack.h" -#include "cminpackP.h" - -__cminpack_attr__ -int __cminpack_func__(lmder1)(__cminpack_decl_fcnder_mn__ void *p, int m, int n, real *x, - real *fvec, real *fjac, int ldfjac, real tol, - int *ipvt, real *wa, int lwa) -{ - /* Initialized data */ - - const real factor = 100.; - - /* Local variables */ - int mode, nfev, njev; - real ftol, gtol, xtol; - int maxfev, nprint; - int info; - -/* ********** */ - -/* subroutine lmder1 */ - -/* the purpose of lmder1 is to minimize the sum of the squares of */ -/* m nonlinear functions in n variables by a modification of the */ -/* levenberg-marquardt algorithm. this is done by using the more */ -/* general least-squares solver lmder. the user must provide a */ -/* subroutine which calculates the functions and the jacobian. */ - -/* the subroutine statement is */ - -/* subroutine lmder1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info, */ -/* ipvt,wa,lwa) */ - -/* where */ - -/* fcn is the name of the user-supplied subroutine which */ -/* calculates the functions and the jacobian. fcn must */ -/* be declared in an external statement in the user */ -/* calling program, and should be written as follows. */ - -/* subroutine fcn(m,n,x,fvec,fjac,ldfjac,iflag) */ -/* integer m,n,ldfjac,iflag */ -/* double precision x(n),fvec(m),fjac(ldfjac,n) */ -/* ---------- */ -/* if iflag = 1 calculate the functions at x and */ -/* return this vector in fvec. do not alter fjac. */ -/* if iflag = 2 calculate the jacobian at x and */ -/* return this matrix in fjac. do not alter fvec. */ -/* ---------- */ -/* return */ -/* end */ - -/* the value of iflag should not be changed by fcn unless */ -/* the user wants to terminate execution of lmder1. */ -/* in this case set iflag to a negative integer. */ - -/* m is a positive integer input variable set to the number */ -/* of functions. */ - -/* n is a positive integer input variable set to the number */ -/* of variables. n must not exceed m. */ - -/* x is an array of length n. on input x must contain */ -/* an initial estimate of the solution vector. on output x */ -/* contains the final estimate of the solution vector. */ - -/* fvec is an output array of length m which contains */ -/* the functions evaluated at the output x. */ - -/* fjac is an output m by n array. the upper n by n submatrix */ -/* of fjac contains an upper triangular matrix r with */ -/* diagonal elements of nonincreasing magnitude such that */ - -/* t t t */ -/* p *(jac *jac)*p = r *r, */ - -/* where p is a permutation matrix and jac is the final */ -/* calculated jacobian. column j of p is column ipvt(j) */ -/* (see below) of the identity matrix. the lower trapezoidal */ -/* part of fjac contains information generated during */ -/* the computation of r. */ - -/* ldfjac is a positive integer input variable not less than m */ -/* which specifies the leading dimension of the array fjac. */ - -/* tol is a nonnegative input variable. termination occurs */ -/* when the algorithm estimates either that the relative */ -/* error in the sum of squares is at most tol or that */ -/* the relative error between x and the solution is at */ -/* most tol. */ - -/* info is an integer output variable. if the user has */ -/* terminated execution, info is set to the (negative) */ -/* value of iflag. see description of fcn. otherwise, */ -/* info is set as follows. */ - -/* info = 0 improper input parameters. */ - -/* info = 1 algorithm estimates that the relative error */ -/* in the sum of squares is at most tol. */ - -/* info = 2 algorithm estimates that the relative error */ -/* between x and the solution is at most tol. */ - -/* info = 3 conditions for info = 1 and info = 2 both hold. */ - -/* info = 4 fvec is orthogonal to the columns of the */ -/* jacobian to machine precision. */ - -/* info = 5 number of calls to fcn with iflag = 1 has */ -/* reached 100*(n+1). */ - -/* info = 6 tol is too small. no further reduction in */ -/* the sum of squares is possible. */ - -/* info = 7 tol is too small. no further improvement in */ -/* the approximate solution x is possible. */ - -/* ipvt is an integer output array of length n. ipvt */ -/* defines a permutation matrix p such that jac*p = q*r, */ -/* where jac is the final calculated jacobian, q is */ -/* orthogonal (not stored), and r is upper triangular */ -/* with diagonal elements of nonincreasing magnitude. */ -/* column j of p is column ipvt(j) of the identity matrix. */ - -/* wa is a work array of length lwa. */ - -/* lwa is a positive integer input variable not less than 5*n+m. */ - -/* subprograms called */ - -/* user-supplied ...... fcn */ - -/* minpack-supplied ... lmder */ - -/* argonne national laboratory. minpack project. march 1980. */ -/* burton s. garbow, kenneth e. hillstrom, jorge j. more */ - -/* ********** */ - -/* check the input parameters for errors. */ - - if (n <= 0 || m < n || ldfjac < m || tol < 0. || lwa < n * 5 + m) { - return 0; - } - -/* call lmder. */ - - maxfev = (n + 1) * 100; - ftol = tol; - xtol = tol; - gtol = 0.; - mode = 1; - nprint = 0; - info = __cminpack_func__(lmder)(__cminpack_param_fcnder_mn__ p, m, n, x, fvec, fjac, ldfjac, - ftol, xtol, gtol, maxfev, wa, mode, factor, nprint, - &nfev, &njev, ipvt, &wa[n], &wa[(n << 1)], & - wa[n * 3], &wa[(n << 2)], &wa[n * 5]); - if (info == 8) { - info = 4; - } - return info; - -/* last card of subroutine lmder1. */ - -} /* lmder1_ */ - diff --git a/ast/cminpack/lmpar.c b/ast/cminpack/lmpar.c deleted file mode 100644 index 108e687..0000000 --- a/ast/cminpack/lmpar.c +++ /dev/null @@ -1,338 +0,0 @@ -/* lmpar.f -- translated by f2c (version 20020621). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -*/ - -#include "cminpack.h" -#include <math.h> -#include "cminpackP.h" - -__cminpack_attr__ -void __cminpack_func__(lmpar)(int n, real *r, int ldr, - const int *ipvt, const real *diag, const real *qtb, real delta, - real *par, real *x, real *sdiag, real *wa1, - real *wa2) -{ - /* Initialized data */ - -#define p1 .1 -#define p001 .001 - - /* System generated locals */ - real d1, d2; - - /* Local variables */ - int j, l; - real fp; - real parc, parl; - int iter; - real temp, paru, dwarf; - int nsing; - real gnorm; - real dxnorm; - -/* ********** */ - -/* subroutine lmpar */ - -/* given an m by n matrix a, an n by n nonsingular diagonal */ -/* matrix d, an m-vector b, and a positive number delta, */ -/* the problem is to determine a value for the parameter */ -/* par such that if x solves the system */ - -/* a*x = b , sqrt(par)*d*x = 0 , */ - -/* in the least squares sense, and dxnorm is the euclidean */ -/* norm of d*x, then either par is zero and */ - -/* (dxnorm-delta) .le. 0.1*delta , */ - -/* or par is positive and */ - -/* abs(dxnorm-delta) .le. 0.1*delta . */ - -/* this subroutine completes the solution of the problem */ -/* if it is provided with the necessary information from the */ -/* qr factorization, with column pivoting, of a. that is, if */ -/* a*p = q*r, where p is a permutation matrix, q has orthogonal */ -/* columns, and r is an upper triangular matrix with diagonal */ -/* elements of nonincreasing magnitude, then lmpar expects */ -/* the full upper triangle of r, the permutation matrix p, */ -/* and the first n components of (q transpose)*b. on output */ -/* lmpar also provides an upper triangular matrix s such that */ - -/* t t t */ -/* p *(a *a + par*d*d)*p = s *s . */ - -/* s is employed within lmpar and may be of separate interest. */ - -/* only a few iterations are generally needed for convergence */ -/* of the algorithm. if, however, the limit of 10 iterations */ -/* is reached, then the output par will contain the best */ -/* value obtained so far. */ - -/* the subroutine statement is */ - -/* subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag, */ -/* wa1,wa2) */ - -/* where */ - -/* n is a positive integer input variable set to the order of r. */ - -/* r is an n by n array. on input the full upper triangle */ -/* must contain the full upper triangle of the matrix r. */ -/* on output the full upper triangle is unaltered, and the */ -/* strict lower triangle contains the strict upper triangle */ -/* (transposed) of the upper triangular matrix s. */ - -/* ldr is a positive integer input variable not less than n */ -/* which specifies the leading dimension of the array r. */ - -/* ipvt is an integer input array of length n which defines the */ -/* permutation matrix p such that a*p = q*r. column j of p */ -/* is column ipvt(j) of the identity matrix. */ - -/* diag is an input array of length n which must contain the */ -/* diagonal elements of the matrix d. */ - -/* qtb is an input array of length n which must contain the first */ -/* n elements of the vector (q transpose)*b. */ - -/* delta is a positive input variable which specifies an upper */ -/* bound on the euclidean norm of d*x. */ - -/* par is a nonnegative variable. on input par contains an */ -/* initial estimate of the levenberg-marquardt parameter. */ -/* on output par contains the final estimate. */ - -/* x is an output array of length n which contains the least */ -/* squares solution of the system a*x = b, sqrt(par)*d*x = 0, */ -/* for the output par. */ - -/* sdiag is an output array of length n which contains the */ -/* diagonal elements of the upper triangular matrix s. */ - -/* wa1 and wa2 are work arrays of length n. */ - -/* subprograms called */ - -/* minpack-supplied ... dpmpar,enorm,qrsolv */ - -/* fortran-supplied ... dabs,dmax1,dmin1,dsqrt */ - -/* argonne national laboratory. minpack project. march 1980. */ -/* burton s. garbow, kenneth e. hillstrom, jorge j. more */ - -/* ********** */ - -/* dwarf is the smallest positive magnitude. */ - - dwarf = __cminpack_func__(dpmpar)(2); - -/* compute and store in x the gauss-newton direction. if the */ -/* jacobian is rank-deficient, obtain a least squares solution. */ - - nsing = n; - for (j = 0; j < n; ++j) { - wa1[j] = qtb[j]; - if (r[j + j * ldr] == 0. && nsing == n) { - nsing = j; - } - if (nsing < n) { - wa1[j] = 0.; - } - } -# ifdef USE_CBLAS - cblas_dtrsv(CblasColMajor, CblasUpper, CblasNoTrans, CblasNonUnit, nsing, r, ldr, wa1, 1); -# else - if (nsing >= 1) { - int k; - for (k = 1; k <= nsing; ++k) { - j = nsing - k; - wa1[j] /= r[j + j * ldr]; - temp = wa1[j]; - if (j >= 1) { - int i; - for (i = 0; i < j; ++i) { - wa1[i] -= r[i + j * ldr] * temp; - } - } - } - } -# endif - for (j = 0; j < n; ++j) { - l = ipvt[j]-1; - x[l] = wa1[j]; - } - -/* initialize the iteration counter. */ -/* evaluate the function at the origin, and test */ -/* for acceptance of the gauss-newton direction. */ - - iter = 0; - for (j = 0; j < n; ++j) { - wa2[j] = diag[j] * x[j]; - } - dxnorm = __cminpack_enorm__(n, wa2); - fp = dxnorm - delta; - if (fp <= p1 * delta) { - goto TERMINATE; - } - -/* if the jacobian is not rank deficient, the newton */ -/* step provides a lower bound, parl, for the zero of */ -/* the function. otherwise set this bound to zero. */ - - parl = 0.; - if (nsing >= n) { - for (j = 0; j < n; ++j) { - l = ipvt[j]-1; - wa1[j] = diag[l] * (wa2[l] / dxnorm); - } -# ifdef USE_CBLAS - cblas_dtrsv(CblasColMajor, CblasUpper, CblasTrans, CblasNonUnit, n, r, ldr, wa1, 1); -# else - for (j = 0; j < n; ++j) { - real sum = 0.; - if (j >= 1) { - int i; - for (i = 0; i < j; ++i) { - sum += r[i + j * ldr] * wa1[i]; - } - } - wa1[j] = (wa1[j] - sum) / r[j + j * ldr]; - } -# endif - temp = __cminpack_enorm__(n, wa1); - parl = fp / delta / temp / temp; - } - -/* calculate an upper bound, paru, for the zero of the function. */ - - for (j = 0; j < n; ++j) { - real sum; -# ifdef USE_CBLAS - sum = cblas_ddot(j+1, &r[j*ldr], 1, qtb, 1); -# else - int i; - sum = 0.; - for (i = 0; i <= j; ++i) { - sum += r[i + j * ldr] * qtb[i]; - } -# endif - l = ipvt[j]-1; - wa1[j] = sum / diag[l]; - } - gnorm = __cminpack_enorm__(n, wa1); - paru = gnorm / delta; - if (paru == 0.) { - paru = dwarf / min(delta,(real)p1) /* / p001 ??? */; - } - -/* if the input par lies outside of the interval (parl,paru), */ -/* set par to the closer endpoint. */ - - *par = max(*par,parl); - *par = min(*par,paru); - if (*par == 0.) { - *par = gnorm / dxnorm; - } - -/* beginning of an iteration. */ - - for (;;) { - ++iter; - -/* evaluate the function at the current value of par. */ - - if (*par == 0.) { - /* Computing MAX */ - d1 = dwarf, d2 = p001 * paru; - *par = max(d1,d2); - } - temp = sqrt(*par); - for (j = 0; j < n; ++j) { - wa1[j] = temp * diag[j]; - } - __cminpack_func__(qrsolv)(n, r, ldr, ipvt, wa1, qtb, x, sdiag, wa2); - for (j = 0; j < n; ++j) { - wa2[j] = diag[j] * x[j]; - } - dxnorm = __cminpack_enorm__(n, wa2); - temp = fp; - fp = dxnorm - delta; - -/* if the function is small enough, accept the current value */ -/* of par. also test for the exceptional cases where parl */ -/* is zero or the number of iterations has reached 10. */ - - if (fabs(fp) <= p1 * delta || (parl == 0. && fp <= temp && temp < 0.) || iter == 10) { - goto TERMINATE; - } - -/* compute the newton correction. */ - -# ifdef USE_CBLAS - for (j = 0; j < nsing; ++j) { - l = ipvt[j]-1; - wa1[j] = diag[l] * (wa2[l] / dxnorm); - } - for (j = nsing; j < n; ++j) { - wa1[j] = 0.; - } - /* exchange the diagonal of r with sdiag */ - cblas_dswap(n, r, ldr+1, sdiag, 1); - /* solve lower(r).x = wa1, result id put in wa1 */ - cblas_dtrsv(CblasColMajor, CblasLower, CblasNoTrans, CblasNonUnit, nsing, r, ldr, wa1, 1); - /* exchange the diagonal of r with sdiag */ - cblas_dswap( n, r, ldr+1, sdiag, 1); -# else /* !USE_CBLAS */ - for (j = 0; j < n; ++j) { - l = ipvt[j]-1; - wa1[j] = diag[l] * (wa2[l] / dxnorm); - } - for (j = 0; j < n; ++j) { - wa1[j] /= sdiag[j]; - temp = wa1[j]; - if (n > j+1) { - int i; - for (i = j+1; i < n; ++i) { - wa1[i] -= r[i + j * ldr] * temp; - } - } - } -# endif /* !USE_CBLAS */ - temp = __cminpack_enorm__(n, wa1); - parc = fp / delta / temp / temp; - -/* depending on the sign of the function, update parl or paru. */ - - if (fp > 0.) { - parl = max(parl,*par); - } - if (fp < 0.) { - paru = min(paru,*par); - } - -/* compute an improved estimate for par. */ - - /* Computing MAX */ - d1 = parl, d2 = *par + parc; - *par = max(d1,d2); - -/* end of an iteration. */ - - } -TERMINATE: - -/* termination. */ - - if (iter == 0) { - *par = 0.; - } - -/* last card of subroutine lmpar. */ - -} /* lmpar_ */ - diff --git a/ast/cminpack/qrfac.c b/ast/cminpack/qrfac.c deleted file mode 100644 index 1573772..0000000 --- a/ast/cminpack/qrfac.c +++ /dev/null @@ -1,285 +0,0 @@ -#include "cminpack.h" -#include <math.h> -#ifdef USE_LAPACK -#include <stdlib.h> -#include <string.h> -#include <assert.h> -#endif -#include "cminpackP.h" - -__cminpack_attr__ -void __cminpack_func__(qrfac)(int m, int n, real *a, int - lda, int pivot, int *ipvt, int lipvt, real *rdiag, - real *acnorm, real *wa) -{ -#ifdef USE_LAPACK - __CLPK_integer m_ = m; - __CLPK_integer n_ = n; - __CLPK_integer lda_ = lda; - __CLPK_integer *jpvt; - - int i, j, k; - double t; - double* tau = wa; - const __CLPK_integer ltau = m > n ? n : m; - __CLPK_integer lwork = -1; - __CLPK_integer info = 0; - double* work; - - if (pivot) { - assert( lipvt >= n ); - if (sizeof(__CLPK_integer) != sizeof(ipvt[0])) { - jpvt = malloc(n*sizeof(__CLPK_integer)); - } else { - /* __CLPK_integer is actually an int, just do a cast */ - jpvt = (__CLPK_integer *)ipvt; - } - /* set all columns free */ - memset(jpvt, 0, sizeof(int)*n); - } - - /* query optimal size of work */ - lwork = -1; - if (pivot) { - dgeqp3_(&m_,&n_,a,&lda_,jpvt,tau,tau,&lwork,&info); - lwork = (int)tau[0]; - assert( lwork >= 3*n+1 ); - } else { - dgeqrf_(&m_,&n_,a,&lda_,tau,tau,&lwork,&info); - lwork = (int)tau[0]; - assert( lwork >= 1 && lwork >= n ); - } - - assert( info == 0 ); - - /* alloc work area */ - work = (double *)malloc(sizeof(double)*lwork); - assert(work != NULL); - - /* set acnorm first (from the doc of qrfac, acnorm may point to the same area as rdiag) */ - if (acnorm != rdiag) { - for (j = 0; j < n; ++j) { - acnorm[j] = __cminpack_enorm__(m, &a[j * lda]); - } - } - - /* QR decomposition */ - if (pivot) { - dgeqp3_(&m_,&n_,a,&lda_,jpvt,tau,work,&lwork,&info); - } else { - dgeqrf_(&m_,&n_,a,&lda_,tau,work,&lwork,&info); - } - assert(info == 0); - - /* set rdiag, before the diagonal is replaced */ - memset(rdiag, 0, sizeof(double)*n); - for(i=0 ; i<n ; ++i) { - rdiag[i] = a[i*lda+i]; - } - - /* modify lower trinagular part to look like qrfac's output */ - for(i=0 ; i<ltau ; ++i) { - k = i*lda+i; - t = tau[i]; - a[k] = t; - for(j=i+1 ; j<m ; j++) { - k++; - a[k] *= t; - } - } - - free(work); - if (pivot) { - /* convert back jpvt to ipvt */ - if (sizeof(__CLPK_integer) != sizeof(ipvt[0])) { - for(i=0; i<n; ++i) { - ipvt[i] = jpvt[i]; - } - free(jpvt); - } - } -#else /* !USE_LAPACK */ - /* Initialized data */ - -#define p05 .05 - - /* System generated locals */ - real d1; - - /* Local variables */ - int i, j, k, jp1; - real sum; - real temp; - int minmn; - real epsmch; - real ajnorm; - -/* ********** */ - -/* subroutine qrfac */ - -/* this subroutine uses householder transformations with column */ -/* pivoting (optional) to compute a qr factorization of the */ -/* m by n matrix a. that is, qrfac determines an orthogonal */ -/* matrix q, a permutation matrix p, and an upper trapezoidal */ -/* matrix r with diagonal elements of nonincreasing magnitude, */ -/* such that a*p = q*r. the householder transformation for */ -/* column k, k = 1,2,...,min(m,n), is of the form */ - -/* t */ -/* i - (1/u(k))*u*u */ - -/* where u has zeros in the first k-1 positions. the form of */ -/* this transformation and the method of pivoting first */ -/* appeared in the corresponding linpack subroutine. */ - -/* the subroutine statement is */ - -/* subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa) */ - -/* where */ - -/* m is a positive integer input variable set to the number */ -/* of rows of a. */ - -/* n is a positive integer input variable set to the number */ -/* of columns of a. */ - -/* a is an m by n array. on input a contains the matrix for */ -/* which the qr factorization is to be computed. on output */ -/* the strict upper trapezoidal part of a contains the strict */ -/* upper trapezoidal part of r, and the lower trapezoidal */ -/* part of a contains a factored form of q (the non-trivial */ -/* elements of the u vectors described above). */ - -/* lda is a positive integer input variable not less than m */ -/* which specifies the leading dimension of the array a. */ - -/* pivot is a logical input variable. if pivot is set true, */ -/* then column pivoting is enforced. if pivot is set false, */ -/* then no column pivoting is done. */ - -/* ipvt is an integer output array of length lipvt. ipvt */ -/* defines the permutation matrix p such that a*p = q*r. */ -/* column j of p is column ipvt(j) of the identity matrix. */ -/* if pivot is false, ipvt is not referenced. */ - -/* lipvt is a positive integer input variable. if pivot is false, */ -/* then lipvt may be as small as 1. if pivot is true, then */ -/* lipvt must be at least n. */ - -/* rdiag is an output array of length n which contains the */ -/* diagonal elements of r. */ - -/* acnorm is an output array of length n which contains the */ -/* norms of the corresponding columns of the input matrix a. */ -/* if this information is not needed, then acnorm can coincide */ -/* with rdiag. */ - -/* wa is a work array of length n. if pivot is false, then wa */ -/* can coincide with rdiag. */ - -/* subprograms called */ - -/* minpack-supplied ... dpmpar,enorm */ - -/* fortran-supplied ... dmax1,dsqrt,min0 */ - -/* argonne national laboratory. minpack project. march 1980. */ -/* burton s. garbow, kenneth e. hillstrom, jorge j. more */ - -/* ********** */ - (void)lipvt; - -/* epsmch is the machine precision. */ - - epsmch = __cminpack_func__(dpmpar)(1); - -/* compute the initial column norms and initialize several arrays. */ - - for (j = 0; j < n; ++j) { - acnorm[j] = __cminpack_enorm__(m, &a[j * lda + 0]); - rdiag[j] = acnorm[j]; - wa[j] = rdiag[j]; - if (pivot) { - ipvt[j] = j+1; - } - } - -/* reduce a to r with householder transformations. */ - - minmn = min(m,n); - for (j = 0; j < minmn; ++j) { - if (pivot) { - -/* bring the column of largest norm into the pivot position. */ - - int kmax = j; - for (k = j; k < n; ++k) { - if (rdiag[k] > rdiag[kmax]) { - kmax = k; - } - } - if (kmax != j) { - for (i = 0; i < m; ++i) { - temp = a[i + j * lda]; - a[i + j * lda] = a[i + kmax * lda]; - a[i + kmax * lda] = temp; - } - rdiag[kmax] = rdiag[j]; - wa[kmax] = wa[j]; - k = ipvt[j]; - ipvt[j] = ipvt[kmax]; - ipvt[kmax] = k; - } - } - -/* compute the householder transformation to reduce the */ -/* j-th column of a to a multiple of the j-th unit vector. */ - - ajnorm = __cminpack_enorm__(m - (j+1) + 1, &a[j + j * lda]); - if (ajnorm != 0.) { - if (a[j + j * lda] < 0.) { - ajnorm = -ajnorm; - } - for (i = j; i < m; ++i) { - a[i + j * lda] /= ajnorm; - } - a[j + j * lda] += 1.; - -/* apply the transformation to the remaining columns */ -/* and update the norms. */ - - jp1 = j + 1; - if (n > jp1) { - for (k = jp1; k < n; ++k) { - sum = 0.; - for (i = j; i < m; ++i) { - sum += a[i + j * lda] * a[i + k * lda]; - } - temp = sum / a[j + j * lda]; - for (i = j; i < m; ++i) { - a[i + k * lda] -= temp * a[i + j * lda]; - } - if (pivot && rdiag[k] != 0.) { - temp = a[j + k * lda] / rdiag[k]; - /* Computing MAX */ - d1 = 1. - temp * temp; - rdiag[k] *= sqrt((max((real)0.,d1))); - /* Computing 2nd power */ - d1 = rdiag[k] / wa[k]; - if (p05 * (d1 * d1) <= epsmch) { - rdiag[k] = __cminpack_enorm__(m - (j+1), &a[jp1 + k * lda]); - wa[k] = rdiag[k]; - } - } - } - } - } - rdiag[j] = -ajnorm; - } - -/* last card of subroutine qrfac. */ -#endif /* !USE_LAPACK */ -} /* qrfac_ */ - diff --git a/ast/cminpack/qrsolv.c b/ast/cminpack/qrsolv.c deleted file mode 100644 index 6ab9e98..0000000 --- a/ast/cminpack/qrsolv.c +++ /dev/null @@ -1,218 +0,0 @@ -#include "cminpack.h" -#include <math.h> -#include "cminpackP.h" - -__cminpack_attr__ -void __cminpack_func__(qrsolv)(int n, real *r, int ldr, - const int *ipvt, const real *diag, const real *qtb, real *x, - real *sdiag, real *wa) -{ - /* Initialized data */ - -#define p5 .5 -#define p25 .25 - - /* Local variables */ - int i, j, k, l; - real cos, sin, sum, temp; - int nsing; - real qtbpj; - -/* ********** */ - -/* subroutine qrsolv */ - -/* given an m by n matrix a, an n by n diagonal matrix d, */ -/* and an m-vector b, the problem is to determine an x which */ -/* solves the system */ - -/* a*x = b , d*x = 0 , */ - -/* in the least squares sense. */ - -/* this subroutine completes the solution of the problem */ -/* if it is provided with the necessary information from the */ -/* qr factorization, with column pivoting, of a. that is, if */ -/* a*p = q*r, where p is a permutation matrix, q has orthogonal */ -/* columns, and r is an upper triangular matrix with diagonal */ -/* elements of nonincreasing magnitude, then qrsolv expects */ -/* the full upper triangle of r, the permutation matrix p, */ -/* and the first n components of (q transpose)*b. the system */ -/* a*x = b, d*x = 0, is then equivalent to */ - -/* t t */ -/* r*z = q *b , p *d*p*z = 0 , */ - -/* where x = p*z. if this system does not have full rank, */ -/* then a least squares solution is obtained. on output qrsolv */ -/* also provides an upper triangular matrix s such that */ - -/* t t t */ -/* p *(a *a + d*d)*p = s *s . */ - -/* s is computed within qrsolv and may be of separate interest. */ - -/* the subroutine statement is */ - -/* subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa) */ - -/* where */ - -/* n is a positive integer input variable set to the order of r. */ - -/* r is an n by n array. on input the full upper triangle */ -/* must contain the full upper triangle of the matrix r. */ -/* on output the full upper triangle is unaltered, and the */ -/* strict lower triangle contains the strict upper triangle */ -/* (transposed) of the upper triangular matrix s. */ - -/* ldr is a positive integer input variable not less than n */ -/* which specifies the leading dimension of the array r. */ - -/* ipvt is an integer input array of length n which defines the */ -/* permutation matrix p such that a*p = q*r. column j of p */ -/* is column ipvt(j) of the identity matrix. */ - -/* diag is an input array of length n which must contain the */ -/* diagonal elements of the matrix d. */ - -/* qtb is an input array of length n which must contain the first */ -/* n elements of the vector (q transpose)*b. */ - -/* x is an output array of length n which contains the least */ -/* squares solution of the system a*x = b, d*x = 0. */ - -/* sdiag is an output array of length n which contains the */ -/* diagonal elements of the upper triangular matrix s. */ - -/* wa is a work array of length n. */ - -/* subprograms called */ - -/* fortran-supplied ... dabs,dsqrt */ - -/* argonne national laboratory. minpack project. march 1980. */ -/* burton s. garbow, kenneth e. hillstrom, jorge j. more */ - -/* ********** */ - -/* copy r and (q transpose)*b to preserve input and initialize s. */ -/* in particular, save the diagonal elements of r in x. */ - - for (j = 0; j < n; ++j) { - for (i = j; i < n; ++i) { - r[i + j * ldr] = r[j + i * ldr]; - } - x[j] = r[j + j * ldr]; - wa[j] = qtb[j]; - } - -/* eliminate the diagonal matrix d using a givens rotation. */ - - for (j = 0; j < n; ++j) { - -/* prepare the row of d to be eliminated, locating the */ -/* diagonal element using p from the qr factorization. */ - - l = ipvt[j]-1; - if (diag[l] != 0.) { - for (k = j; k < n; ++k) { - sdiag[k] = 0.; - } - sdiag[j] = diag[l]; - -/* the transformations to eliminate the row of d */ -/* modify only a single element of (q transpose)*b */ -/* beyond the first n, which is initially zero. */ - - qtbpj = 0.; - for (k = j; k < n; ++k) { - -/* determine a givens rotation which eliminates the */ -/* appropriate element in the current row of d. */ - - if (sdiag[k] != 0.) { -# ifdef USE_LAPACK - dlartg_( &r[k + k * ldr], &sdiag[k], &cos, &sin, &temp ); -# else /* !USE_LAPACK */ - if (fabs(r[k + k * ldr]) < fabs(sdiag[k])) { - real cotan; - cotan = r[k + k * ldr] / sdiag[k]; - sin = p5 / sqrt(p25 + p25 * (cotan * cotan)); - cos = sin * cotan; - } else { - real tan; - tan = sdiag[k] / r[k + k * ldr]; - cos = p5 / sqrt(p25 + p25 * (tan * tan)); - sin = cos * tan; - } - -/* compute the modified diagonal element of r and */ -/* the modified element of ((q transpose)*b,0). */ - -# endif /* !USE_LAPACK */ - temp = cos * wa[k] + sin * qtbpj; - qtbpj = -sin * wa[k] + cos * qtbpj; - wa[k] = temp; - -/* accumulate the tranformation in the row of s. */ -# ifdef USE_CBLAS - cblas_drot( n-k, &r[k + k * ldr], 1, &sdiag[k], 1, cos, sin ); -# else /* !USE_CBLAS */ - r[k + k * ldr] = cos * r[k + k * ldr] + sin * sdiag[k]; - if (n > k+1) { - for (i = k+1; i < n; ++i) { - temp = cos * r[i + k * ldr] + sin * sdiag[i]; - sdiag[i] = -sin * r[i + k * ldr] + cos * sdiag[i]; - r[i + k * ldr] = temp; - } - } -# endif /* !USE_CBLAS */ - } - } - } - -/* store the diagonal element of s and restore */ -/* the corresponding diagonal element of r. */ - - sdiag[j] = r[j + j * ldr]; - r[j + j * ldr] = x[j]; - } - -/* solve the triangular system for z. if the system is */ -/* singular, then obtain a least squares solution. */ - - nsing = n; - for (j = 0; j < n; ++j) { - if (sdiag[j] == 0. && nsing == n) { - nsing = j; - } - if (nsing < n) { - wa[j] = 0.; - } - } - if (nsing >= 1) { - for (k = 1; k <= nsing; ++k) { - j = nsing - k; - sum = 0.; - if (nsing > j+1) { - for (i = j+1; i < nsing; ++i) { - sum += r[i + j * ldr] * wa[i]; - } - } - wa[j] = (wa[j] - sum) / sdiag[j]; - } - } - -/* permute the components of z back to components of x. */ - - for (j = 0; j < n; ++j) { - l = ipvt[j]-1; - x[l] = wa[j]; - } - return; - -/* last card of subroutine qrsolv. */ - -} /* qrsolv_ */ - diff --git a/ast/config.h.in b/ast/config.h.in index 5e1b304..a61a84a 100644 --- a/ast/config.h.in +++ b/ast/config.h.in @@ -44,9 +44,6 @@ /* The sscanf shows the non-ANSI behaviour reported by Bill Joye */ #undef HAVE_NONANSI_SSCANF -/* Define to 1 if the Fortran compiler supports the VAX %LOC extension */ -#undef HAVE_PERCENTLOC - /* Use the starmem library for memory management */ #undef HAVE_STAR_MEM_H diff --git a/ast/f77.h b/ast/f77.h deleted file mode 100644 index 7f1a728..0000000 --- a/ast/f77.h +++ /dev/null @@ -1,1096 +0,0 @@ -/* -*+ -* Name: -* f77.h and cnf.h - -* Purpose: -* C - FORTRAN interace macros and prototypes - -* Language: -* C (part ANSI, part not) - -* Type of Module: -* C include file - -* Description: -* For historical reasons two files, F77.h and cnf.h are required -* but the have now been combined and for new code, only one is -* necessary. -* -* This file defines the macros needed to write C functions that are -* designed to be called from FORTRAN programs, and to do so in a -* portable way. Arguments are normally passed by reference from a -* FORTRAN program, and so the F77 macros arrange for a pointer to -* all arguments to be available. This requires no work on most -* machines, but will actually generate the pointers on a machine -* that passes FORTRAN arguments by value. - -* Notes: -* - Macros are provided to handle the conversion of logical data -* values between the way that FORTRAN represents a value and the -* way that C represents it. -* - Macros are provided to convert variables between the FORTRAN and -* C method of representing them. In most cases there is no -* conversion required, the macros just arrange for a pointer to -* the FORTRAN variable to be set appropriately. The possibility that -* FORTRAN and C might use different ways of representing integer -* and floating point values is considered remote, the macros are -* really only there for completeness and to assist in the automatic -* generation of C interfaces. -* - For character variables the macros convert between -* the FORTRAN method of representing them (fixed length, blank -* filled strings) and the C method (variable length, null -* terminated strings) using calls to the CNF functions. - -* Implementation Deficiencies: -* - The macros support the K&R style of function definition, but -* this file may not work with all K&R compilers as it contains -* "#if defined" statements. These could be replaced with #ifdef's -* if necessary. This has not been done as is would make the code -* less clear and the need for support for K&R sytle definitions -* should disappear as ANSI compilers become the default. - -* Copyright: -* Copyright (C) 1991, 1993 Science & Engineering Research Council. -* Copyright (C) 2006 Particle Physics and Astronomy Research Council. -* Copyright (C) 2007,2008 Science and Technology Facilities Council. -* All Rights Reserved. - -* Licence: -* This program is free software; you can redistribute it and/or -* modify it under the terms of the GNU General Public License as -* published by the Free Software Foundation; either version 2 of -* the License, or (at your option) any later version. -* -* This program is distributed in the hope that it will be -* useful,but WITHOUT ANY WARRANTY; without even the implied -* warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -* PURPOSE. See the GNU General Public License for more details. -* -* You should have received a copy of the GNU General Public License -* along with this program; if not, write to the Free Software -* Foundation, Inc., 51 Franklin Street,Fifth Floor, Boston, MA -* 02110-1301, USA - -* Authors: -* PMA: Peter Allan (Starlink, RAL) -* AJC: Alan Chipperfield (Starlink, RAL) -* TIMJ: Tim Jenness (JAC) -* PWD: Peter W. Draper (JAC, Durham University) -* {enter_new_authors_here} - -* History: -* 23-MAY-1991 (PMA): -* Original version. -* 19-JUN-1991 (PMA): -* Removed VMS versions of IM(EX)PORT_LOGICAL macros that tried -* to convert data representations. -* 24-JUN-1991 (PMA): -* Changed the names of IMPORT macros to GENPTR. -* Removed the EXPORT macros. -* 27-JUN-1991 (PMA): -* Modified DECstation specific stuff to allow use of the c89 -* compiler. -* 8-JUL-1991 (PMA): -* Added macros to call FORTRAN from C. -* 16-OCT-1991 (PMA): -* Remove type_ARRAY2 definitions. -* Remove the length argument from CHARACTER_ARRAY and the -* dimension specifier from GENPTR_type_ARRAY. -* Add extra brackets to F77_ISFALSE and F77_ISTRUE. -* 25-OCT-1991 (PMA): -* Changed "if defined(sun4)" to "if defined(sun)" -* 2-JUN-1992 (PMA): -* Changed "if defined(mips)" to "if defined(ultrix)" to prevent -* those definitions being used on a Silicon Graphics machine. -* 11-JUN-1992 (PMA): -* Changed "if defined(ultrix)" back to "if defined(mips)" so that -* it still works on OSF/1 on a DECstation. -* Add support for general non-ANSI compilers, but not basic K&R -* ones. -* 12-JUN-1992 (PMA): -* Change declaration of dummy scalar arguments to be const -* pointers. Change declaration of dummy array arguments to be -* const pointers. -* 5-JAN-1993 (PMA): -* Changed "if defined(mips)" so that it will recognise a -* DECstation running Ultrix or OSF/1, but not a Silicon Graphics -* workstation. -* Change the definition of F77_BYTE_TYPE to add "signed". -* Redefine this on VMS where signed is invalid syntax. -* Add new types of UBYTE and UWORD. -* 8-JAN-1993 (PMA): -* Fix bug in the definition of CHARACTER_RETURN_VALUE. There was -* an extraneous space. -* Add a macro F77_POINTER_TYPE and use it to define POINTER. -* 13-JAN-1993 (PMA): -* Start to add support for K&R function definitions. These are -* done on a per machine basis. -* 16-APR-1993 (PMA): -* Change the definition of F77_POINTER_TYPE from int to unsigned -* int. -* 7-MAY-1993 (PMA): -* Change from using a null comment as a token concatenation -* operator to using the internal macro _f77_x on non-ANSI -* systems. -* 10-MAY-1993 (PMA): -* Finish adding K&R support. This will form version 2.0 of F77. -* 10-MAY-1993 (PMA): -* Add support for Alpha OSF/1. -* 9-JUL-1993 (PMA): -* Add further POINTER macros: POINTER_ARRAY, -* GENPTR_POINTER_ARRAY, DECLARE_POINTER, DECLARE_POINTER_ARRAY, -* POINTER_ARG, POINTER_ARRAY_ARG, F77_POINTER_FUNCTION, -* KR_POINTER_ARRAY. -* 24-AUG-1993 (PMA): -* Add const to the VMS definitions of CHARACTER and CHARACTER_ARRAY. -* 3-NOV-1993 (PMA): -* Remove K&R stuff to a separate file. -* Released on Unix as version 2.0 of CNF. -* 11-NOV-1993 (PMA): -* Return to using the null comment to concatenate text on non-ANSI -* systems as _f77_x caused problems with the c89 -common flag on -* DECstations. -* 23-JAN-1996 (AJC): -* Add SUBROUTINE, type_FUNCTION, SUBROUTINE_ARG, -* type_FUNCTION_ARG, GENPTR_SUBROUTINE and GENPTR_type_FUNCTION -* required for passed subroutine and function name. -* 29-JAN-1996 (AJC): -* Add the dynamic CHARACTER_ macros -* and CHARACTER_ARG_TYPE -* 22-FEB-1996 (AJC): -* Add CHARACTER_RETURN_ARG -* 23-MAY-1996 (AJC): -* Add DECLARE_CHARACTER_ARRAY_DYN -* F77_CREATE_CHARACTER_ARRAY -* F77_CHARACTER_ARG_TYPE -* 14-JUN-1996 (AJC): -* Add DECLARE_LOGICAL_ARRAY_DYN -* F77_CREATE_LOGICAL_ARRAY -* 21-JUN-1996 (AJC): -* Add cast to _ARRAY_ARGs to allow multidimensional arrays -* 17-MAR-1998 (AJC): -* Add DECLARE, CREATE and FREE dynamic array macros for all types -* Changed CREATE_CHARACTER_ARRAY and CREATE_LOGICAL_ARRAY to use -* number of elements rather than dimensions. -* Add IMPORT, EXPORT and ASSOC macros -* 22-JUL-1998 (AJC): -* Combined F77.h and cnf.h -* 23-SEP-1998 (AJC): -* Input strings for cnf -> const char * -* Input int arrays for cnf -> const int * -* 4-NOV-1998 (AJC): -* Bring cnf prototypes in line with .c routines -* 8-FEB-1999 (AJC): -* Added cnf_mem stuff -* 9-FEB-1999 (AJC): -* Use cnf_cptr/fptr for IMPORT/EXPORT_POINTER -* 16-FEB-1999 (AJC): -* Added missing cnf_fptr prototype -* 23-JUN-1999 (AJC): -* Change cnf_name to cnfName -* and add macros for cnf_name -* 1-DEC-1999 (AJC): -* Add define cnf_free -* 7-JAN-2000 (AJC): -* Correct omission of F77_ASSOC_UBYTE_ARRAY -* Correct F77_EXPORT_UWORD_ARRAY -* 25-AUG-2005 (TIMJ): -* Add cnfInitRTL -* 23-FEB-2006 (TIMJ): -* Add cnfRealloc -* Use starMalloc rather than malloc in F77_CREATE_POINTER_ARRAY -* (since it needs to match what goes on in cnfFree) -* 21-JUN-2006 (PWD): -* Changed to use a different return type for REAL functions. This -* effects g77 under 64-bit, when the f2c bindings expect the return -* value of a REAL function to be a double, not a float. -* 25-SEP-2006 (PWD): -* Introduced F77_CREATE_IMPORT_CHARACTER. Match length of -* F77_CREATE_CHARACTER to result from cnfCref. -* 13-JUL-2007 (PWD): -* Parameterise the type of Fortran character string lengths. Can -* be long. -* 7-OCT-2008 (TIMJ): -* Initialise pointers. -* 11-MAY-2011 (DSB): -* Added F77_LOCK -* {enter_further_changes_here} -* - -* Bugs: -* {note_any_bugs_here} - -*- ------------------------------------------------------------------------------- -*/ -#if !defined(CNF_MACROS) -#define CNF_MACROS - -#include <stdlib.h> -#include <string.h> -/* This initial sections defines values for all macros. These are the */ -/* values that are generally appropriate to an ANSI C compiler on Unix. */ -/* For macros that have different values on other systems, the macros */ -/* should be undefined and then redefined in the system specific sections. */ -/* At the end of this section, some macros are redefined if the compiler */ -/* is non-ANSI. */ - -#if defined(__STDC__) || defined(VMS) -#define CNF_CONST const -#else -#define CNF_CONST -#endif - -/* ----- Macros common to calling C from FORTRAN and FORTRAN from C ---- */ - - -/* --- External Names --- */ - -/* Macro to define the name of a Fortran routine or common block. This */ -/* ends in an underscore on many Unix systems. */ - -#define F77_EXTERNAL_NAME(X) X ## _ - - -/* --- Logical Values --- */ - -/* Define the values that are used to represent the logical values TRUE */ -/* and FALSE in Fortran. */ - -#define F77_TRUE 1 -#define F77_FALSE 0 - -/* Define macros that evaluate to C logical values, given a FORTRAN */ -/* logical value. */ - -#define F77_ISTRUE(X) ( X ) -#define F77_ISFALSE(X) ( !( X ) ) - - -/* --- Common Blocks --- */ - -/* Macros used in referring to FORTRAN common blocks. */ - -#define F77_BLANK_COMMON @BLANK_COMMON_SYMBOL@ -#define F77_NAMED_COMMON(B) F77_EXTERNAL_NAME(B) - - - -/* ------------------ Calling C from FORTRAN --------------------------- */ - - -/* --- Data Types --- */ - -/* Define macros for all the Fortran data types (except COMPLEX, which is */ -/* not handled by this package). */ - -#define F77_INTEGER_TYPE int -#define F77_REAL_TYPE float -#define F77_REAL_FUNCTION_TYPE float -#define F77_DOUBLE_TYPE double -#define F77_LOGICAL_TYPE int -#define F77_CHARACTER_TYPE char -#define F77_BYTE_TYPE signed char -#define F77_WORD_TYPE short int -#define F77_UBYTE_TYPE unsigned char -#define F77_UWORD_TYPE unsigned short int - -/* Define macros for the type of a CHARACTER and CHARACTER_ARRAY argument */ -#define F77_CHARACTER_ARG_TYPE char -#define F77_CHARACTER_ARRAY_ARG_TYPE char - -/* Define a macro to use when passing arguments that STARLINK FORTRAN */ -/* treats as a pointer. From the point of view of C, this type should be */ -/* (void *), but it is declared as type unsigned int as we actually pass */ -/* an INTEGER from the FORTRAN routine. The distinction is important for */ -/* architectures where the size of an INTEGER is not the same as the size */ -/* of a pointer. */ - -#define F77_POINTER_TYPE unsigned int - - -/* --- Subroutine Names --- */ - -/* This declares that the C function returns a value of void. */ - -#define F77_SUBROUTINE(X) void F77_EXTERNAL_NAME(X) - - -/* --- Function Names --- */ - -/* Macros to define the types and names of functions that return values. */ -/* Due the the different ways that function return values could be */ -/* implemented, it is better not to use functions, but to stick to using */ -/* subroutines. */ - -/* Character functions are implemented, but in a way that cannot be */ -/* guaranteed to be portable although it will work on VMS, SunOS, Ultrix */ -/* and DEC OSF/1. It would be better to return the character value as a */ -/* subroutine argument where possible, rather than use a character */ -/* function. */ - -#define F77_INTEGER_FUNCTION(X) F77_INTEGER_TYPE F77_EXTERNAL_NAME(X) -#define F77_REAL_FUNCTION(X) F77_REAL_FUNCTION_TYPE F77_EXTERNAL_NAME(X) -#define F77_DOUBLE_FUNCTION(X) F77_DOUBLE_TYPE F77_EXTERNAL_NAME(X) -#define F77_LOGICAL_FUNCTION(X) F77_LOGICAL_TYPE F77_EXTERNAL_NAME(X) -#define F77_CHARACTER_FUNCTION(X) void F77_EXTERNAL_NAME(X) -#define F77_BYTE_FUNCTION(X) F77_BYTE_TYPE F77_EXTERNAL_NAME(X) -#define F77_WORD_FUNCTION(X) F77_WORD_TYPE F77_EXTERNAL_NAME(X) -#define F77_UBYTE_FUNCTION(X) F77_UBYTE_TYPE F77_EXTERNAL_NAME(X) -#define F77_UWORD_FUNCTION(X) F77_UWORD_TYPE F77_EXTERNAL_NAME(X) -#define F77_POINTER_FUNCTION(X) F77_POINTER_TYPE F77_EXTERNAL_NAME(X) - - -/* --- Character return value for a function --- */ - -#define CHARACTER_RETURN_VALUE(X) CHARACTER(X) TRAIL(X) -#define CHARACTER_RETURN_ARG(X) CHARACTER_ARG(X) TRAIL_ARG(X) - -/* --- Dummy Arguments --- */ - -/* Macros for defining subroutine arguments. All these macros take a */ -/* single argument; the name of the parameter. On most systems, a numeric */ -/* argument is passed as a pointer. */ - -#define INTEGER(X) F77_INTEGER_TYPE *CNF_CONST X -#define REAL(X) F77_REAL_TYPE *CNF_CONST X -#define DOUBLE(X) F77_DOUBLE_TYPE *CNF_CONST X -#define LOGICAL(X) F77_LOGICAL_TYPE *CNF_CONST X -#define BYTE(X) F77_BYTE_TYPE *CNF_CONST X -#define WORD(X) F77_WORD_TYPE *CNF_CONST X -#define UBYTE(X) F77_UBYTE_TYPE *CNF_CONST X -#define UWORD(X) F77_UWORD_TYPE *CNF_CONST X - -/* Pointer arguments. Define a pointer type for passing pointer values */ -/* between subroutines. */ - -#define POINTER(X) F77_POINTER_TYPE *CNF_CONST X - -/* EXTERNAL arguments. Define a passed subroutine or function name */ -#define SUBROUTINE(X) void (*X)() -#define INTEGER_FUNCTION(X) F77_INTEGER_TYPE (*X)() -#define REAL_FUNCTION(X) F77_REAL_TYPE (*X)() -#define DOUBLE_FUNCTION(X) F77_DOUBLE_TYPE (*X)() -#define LOGICAL_FUNCTION(X) F77_LOGICAL_TYPE (*X)() -#define CHARACTER_FUNCTION(X) F77_CHARACTER_TYPE (*X)() -#define BYTE_FUNCTION(X) F77_BYTE_TYPE (*X)() -#define WORD_FUNCTION(X) F77_WORD_TYPE (*X)() -#define UBYTE_FUNCTION(X) F77_UBYTE_TYPE (*X)() -#define UWORD_FUNCTION(X) F77_UWORD_TYPE (*X)() -#define POINTER_FUNCTION(X) F77_POINTER_TYPE (*X)() - -/* Array arguments. */ - -#define INTEGER_ARRAY(X) F77_INTEGER_TYPE *CNF_CONST X -#define REAL_ARRAY(X) F77_REAL_TYPE *CNF_CONST X -#define DOUBLE_ARRAY(X) F77_DOUBLE_TYPE *CNF_CONST X -#define LOGICAL_ARRAY(X) F77_LOGICAL_TYPE *CNF_CONST X -#define BYTE_ARRAY(X) F77_BYTE_TYPE *CNF_CONST X -#define WORD_ARRAY(X) F77_WORD_TYPE *CNF_CONST X -#define UBYTE_ARRAY(X) F77_UBYTE_TYPE *CNF_CONST X -#define UWORD_ARRAY(X) F77_UWORD_TYPE *CNF_CONST X - -#define POINTER_ARRAY(X) F77_POINTER_TYPE *CNF_CONST X - -/* Macros to handle character arguments. */ - -/* Character arguments can be passed in many ways. The purpose of these */ -/* macros and the GENPTR_CHARACTER macro (defined in the next section) is */ -/* to generate a pointer to a character variable called ARG and an integer */ -/* ARG_length containing the length of ARG. If these two variables are */ -/* available directly from the argument list of the routine, then the */ -/* GENPTR_CHARACTER macro is null, otherwise it works on intermediate */ -/* variables. */ - -#define CHARACTER(X) F77_CHARACTER_TYPE *CNF_CONST X -#define TRAIL(X) ,int X ## _length -#define CHARACTER_ARRAY(X) F77_CHARACTER_TYPE *CNF_CONST X - - -/* --- Getting Pointers to Arguments --- */ - -/* Macros that ensure that a pointer to each argument is available for the */ -/* programmer to use. Usually this means that these macros are null. On */ -/* VMS, a pointer to a character variable has to be generated. If a */ -/* particular machine were to pass arguments by reference, rather than by */ -/* value, then these macros would construct the appropriate pointers. */ - -#define GENPTR_INTEGER(X) -#define GENPTR_REAL(X) -#define GENPTR_DOUBLE(X) -#define GENPTR_CHARACTER(X) -#define GENPTR_LOGICAL(X) -#define GENPTR_BYTE(X) -#define GENPTR_WORD(X) -#define GENPTR_UBYTE(X) -#define GENPTR_UWORD(X) -#define GENPTR_POINTER(X) - -#define GENPTR_INTEGER_ARRAY(X) -#define GENPTR_REAL_ARRAY(X) -#define GENPTR_DOUBLE_ARRAY(X) -#define GENPTR_CHARACTER_ARRAY(X) -#define GENPTR_LOGICAL_ARRAY(X) -#define GENPTR_BYTE_ARRAY(X) -#define GENPTR_WORD_ARRAY(X) -#define GENPTR_UBYTE_ARRAY(X) -#define GENPTR_UWORD_ARRAY(X) -#define GENPTR_POINTER_ARRAY(X) - -#define GENPTR_SUBROUTINE(X) -#define GENPTR_INTEGER_FUNCTION(X) -#define GENPTR_REAL_FUNCTION(X) -#define GENPTR_DOUBLE_FUNCTION(X) -#define GENPTR_CHARACTER_FUNCTION(X) -#define GENPTR_LOGICAL_FUNCTION(X) -#define GENPTR_BYTE_FUNCTION(X) -#define GENPTR_WORD_FUNCTION(X) -#define GENPTR_UBYTE_FUNCTION(X) -#define GENPTR_UWORD_FUNCTION(X) -#define GENPTR_POINTER_FUNCTION(X) - - - -/* ------------------ Calling FORTRAN from C --------------------------- */ - - -/* --- Declare variables --- */ - -#define DECLARE_INTEGER(X) F77_INTEGER_TYPE X -#define DECLARE_REAL(X) F77_REAL_TYPE X -#define DECLARE_DOUBLE(X) F77_DOUBLE_TYPE X -#define DECLARE_LOGICAL(X) F77_LOGICAL_TYPE X -#define DECLARE_BYTE(X) F77_BYTE_TYPE X -#define DECLARE_WORD(X) F77_WORD_TYPE X -#define DECLARE_UBYTE(X) F77_UBYTE_TYPE X -#define DECLARE_UWORD(X) F77_UWORD_TYPE X - -#define DECLARE_POINTER(X) F77_POINTER_TYPE X - -#define DECLARE_CHARACTER(X,L) F77_CHARACTER_TYPE X[L]; \ - const int X##_length = L - - -/* --- Declare arrays --- */ - -#define DECLARE_INTEGER_ARRAY(X,D) F77_INTEGER_TYPE X[D] -#define DECLARE_REAL_ARRAY(X,D) F77_REAL_TYPE X[D] -#define DECLARE_DOUBLE_ARRAY(X,D) F77_DOUBLE_TYPE X[D] -#define DECLARE_LOGICAL_ARRAY(X,D) F77_LOGICAL_TYPE X[D] -#define DECLARE_BYTE_ARRAY(X,D) F77_BYTE_TYPE X[D] -#define DECLARE_WORD_ARRAY(X,D) F77_WORD_TYPE X[D] -#define DECLARE_UBYTE_ARRAY(X,D) F77_UBYTE_TYPE X[D] -#define DECLARE_UWORD_ARRAY(X,D) F77_UWORD_TYPE X[D] -#define DECLARE_POINTER_ARRAY(X,D) F77_POINTER_TYPE X[D] -#define DECLARE_CHARACTER_ARRAY(X,L,D) F77_CHARACTER_TYPE X[D][L]; \ - const int X##_length = L - -/* --- Declare and construct dynamic CHARACTER arguments --- */ -#define DECLARE_CHARACTER_DYN(X) F77_CHARACTER_TYPE *X = NULL;\ - int X##_length = 0 -#define F77_CREATE_CHARACTER(X,L) X=cnfCref(L);\ - X##_length = (L>0?L:1) - -/* Declare Dynamic Fortran arrays */ -#define DECLARE_INTEGER_ARRAY_DYN(X) F77_INTEGER_TYPE *X = NULL -#define DECLARE_REAL_ARRAY_DYN(X) F77_REAL_TYPE *X = NULL -#define DECLARE_DOUBLE_ARRAY_DYN(X) F77_DOUBLE_TYPE *X = NULL -#define DECLARE_LOGICAL_ARRAY_DYN(X) F77_LOGICAL_TYPE *X = NULL -#define DECLARE_BYTE_ARRAY_DYN(X) F77_BYTE_TYPE *X = NULL -#define DECLARE_WORD_ARRAY_DYN(X) F77_WORD_TYPE *X = NULL -#define DECLARE_UBYTE_ARRAY_DYN(X) F77_UBYTE_TYPE *X = NULL -#define DECLARE_UWORD_ARRAY_DYN(X) F77_UWORD_TYPE *X = NULL -#define DECLARE_POINTER_ARRAY_DYN(X) F77_POINTER_TYPE *X = NULL -#define DECLARE_CHARACTER_ARRAY_DYN(X) F77_CHARACTER_TYPE *X = NULL;\ - int X##_length = 0 - -/* Create arrays dynamic Fortran arrays for those types which require */ -/* Separate space for Fortran and C arrays */ -/* Character and logical are already defined */ -/* For most types there is nothing to do */ -#define F77_CREATE_CHARACTER_ARRAY(X,L,N) \ - {int f77dims[1];f77dims[0]=N;X=cnfCrefa(L,1,f77dims);X##_length=L;} -#define F77_CREATE_CHARACTER_ARRAY_M(X,L,N,D) X=cnfCrefa(L,N,D);\ - X##_length = L -#define F77_CREATE_LOGICAL_ARRAY(X,N) \ - {int f77dims[1];f77dims[0]=N;X=cnfCrela(1,f77dims);} -#define F77_CREATE_LOGICAL_ARRAY_M(X,N,D) X=cnfCrela(N,D) -#define F77_CREATE_INTEGER_ARRAY(X,N) -#define F77_CREATE_REAL_ARRAY(X,N) -#define F77_CREATE_DOUBLE_ARRAY(X,N) -#define F77_CREATE_BYTE_ARRAY(X,N) -#define F77_CREATE_UBYTE_ARRAY(X,N) -#define F77_CREATE_WORD_ARRAY(X,N) -#define F77_CREATE_UWORD_ARRAY(X,N) -#define F77_CREATE_POINTER_ARRAY(X,N)\ - X=(F77_POINTER_TYPE *) malloc(N*sizeof(F77_POINTER_TYPE)) - -/* Associate Fortran arrays with C arrays */ -/* These macros ensure that there is space somewhere for the Fortran */ -/* array. They are complemetary to the CREATE_type_ARRAY macros */ -#define F77_ASSOC_CHARACTER_ARRAY(F,C) -#define F77_ASSOC_LOGICAL_ARRAY(F,C) -#define F77_ASSOC_INTEGER_ARRAY(F,C) F=C -#define F77_ASSOC_REAL_ARRAY(F,C) F=C -#define F77_ASSOC_DOUBLE_ARRAY(F,C) F=C -#define F77_ASSOC_BYTE_ARRAY(F,C) F=C -#define F77_ASSOC_UBYTE_ARRAY(F,C) F=C -#define F77_ASSOC_WORD_ARRAY(F,C) F=C -#define F77_ASSOC_UWORD_ARRAY(F,C) F=C -#define F77_ASSOC_POINTER_ARRAY(F,C) - -/* Free created dynamic arrays */ -/* Character and logical are already defined */ -/* For most types there is nothing to do */ -#define F77_FREE_INTEGER(X) -#define F77_FREE_REAL(X) -#define F77_FREE_DOUBLE(X) -#define F77_FREE_BYTE(X) -#define F77_FREE_UBYTE(X) -#define F77_FREE_WORD(X) -#define F77_FREE_UWORD(X) -#define F77_FREE_POINTER(X) cnfFree((void *)X); -#define F77_FREE_CHARACTER(X) cnfFreef( X ) -#define F77_FREE_LOGICAL(X) cnfFree( (char *)X ) - -/* --- IMPORT and EXPORT of values --- */ -/* Export C variables to Fortran variables */ -#define F77_EXPORT_CHARACTER(C,F,L) cnfExprt(C,F,L) -#define F77_EXPORT_DOUBLE(C,F) F=C -#define F77_EXPORT_INTEGER(C,F) F=C -#define F77_EXPORT_LOGICAL(C,F) F=C?F77_TRUE:F77_FALSE -#define F77_EXPORT_REAL(C,F) F=C -#define F77_EXPORT_BYTE(C,F) F=C -#define F77_EXPORT_WORD(C,F) F=C -#define F77_EXPORT_UBYTE(C,F) F=C -#define F77_EXPORT_UWORD(C,F) F=C -#define F77_EXPORT_POINTER(C,F) F=cnfFptr(C) -#define F77_EXPORT_LOCATOR(C,F) cnfExpch(C,F,DAT__SZLOC) - -/* Allow for character strings to be NULL, protects strlen. Note this - * does not allow lengths to differ. */ -#define F77_CREATE_EXPORT_CHARACTER(C,F) \ - if (C) { \ - F77_CREATE_CHARACTER(F,strlen(C)); \ - F77_EXPORT_CHARACTER(C,F,F##_length); \ - } else { \ - F77_CREATE_CHARACTER(F,1); \ - F77_EXPORT_CHARACTER(" ",F,F##_length); \ - } - -/* Export C arrays to Fortran */ -/* Arrays are assumed to be 1-d so just the number of elements is given */ -/* This may be OK for n-d arrays also */ -/* CHARACTER arrays may be represented in C as arrays of arrays of char or */ -/* as arrays of pointers to char (the _P variant) */ -#define F77_EXPORT_CHARACTER_ARRAY(C,LC,F,LF,N) \ - {int f77dims[1];f77dims[0]=N;cnfExprta(C,LC,F,LF,1,f77dims);} -#define F77_EXPORT_CHARACTER_ARRAY_P(C,F,LF,N) \ - {int f77dims[1];f77dims[0]=N;cnfExprtap(C,F,LF,1,f77dims);} -#define F77_EXPORT_DOUBLE_ARRAY(C,F,N) F=(F77_DOUBLE_TYPE *)C -#define F77_EXPORT_INTEGER_ARRAY(C,F,N) F=(F77_INTEGER_TYPE *)C -#define F77_EXPORT_LOGICAL_ARRAY(C,F,N) \ - {int f77dims[1];f77dims[0]=N;cnfExpla(C,F,1,f77dims);} -#define F77_EXPORT_REAL_ARRAY(C,F,N) F=(F77_REAL_TYPE *)C -#define F77_EXPORT_BYTE_ARRAY(C,F,N) F=(F77_BYTE_TYPE *)C -#define F77_EXPORT_WORD_ARRAY(C,F,N) F=(F77_WORD_TYPE *)C -#define F77_EXPORT_UBYTE_ARRAY(C,F,N) F=(F77_UBYTE_TYPE *)C -#define F77_EXPORT_UWORD_ARRAY(C,F,N) F=(F77_UWORD_TYPE * )C -#define F77_EXPORT_POINTER_ARRAY(C,F,N) \ - {int f77i;for (f77i=0;f77i<N;f77i++)F[f77i]=cnfFptr(C[f77i]);} -#define F77_EXPORT_LOCATOR_ARRAY(C,F,N) \ - {int f77i;for (f77i=0;f77i<N;f77i++)cnfExpch(C,F,DAT__SZLOC);} - -/* Import Fortran variables to C */ -#define F77_IMPORT_CHARACTER(F,L,C) cnfImprt(F,L,C) -#define F77_IMPORT_DOUBLE(F,C) C=F -#define F77_IMPORT_INTEGER(F,C) C=F -#define F77_IMPORT_LOGICAL(F,C) C=F77_ISTRUE(F) -#define F77_IMPORT_REAL(F,C) C=F -#define F77_IMPORT_BYTE(F,C) C=F -#define F77_IMPORT_WORD(F,C) C=F -#define F77_IMPORT_UBYTE(F,C) C=F -#define F77_IMPORT_UWORD(F,C) C=F -#define F77_IMPORT_POINTER(F,C) C=cnfCptr(F) -#define F77_IMPORT_LOCATOR(F,C) cnfImpch(F,DAT__SZLOC,C) - -/* Import Fortran arrays to C */ -/* Arrays are assumed to be 1-d so just the number of elements is given */ -/* This may be OK for n-d arrays also */ -/* CHARACTER arrays may be represented in C as arrays of arrays of char or */ -/* as arrays of pointers to char (the _P variant) */ -#define F77_IMPORT_CHARACTER_ARRAY(F,LF,C,LC,N) \ - {int f77dims[1];f77dims[0]=N;cnfImprta(F,LF,C,LC,1,f77dims);} -#define F77_IMPORT_CHARACTER_ARRAY_P(F,LF,C,LC,N) \ - {int f77dims[1];f77dims[0]=N;cnfImprtap(F,LF,C,LC,1,f77dims);} -#define F77_IMPORT_DOUBLE_ARRAY(F,C,N) -#define F77_IMPORT_INTEGER_ARRAY(F,C,N) -#define F77_IMPORT_LOGICAL_ARRAY(F,C,N) \ - {int f77dims[1];f77dims[0]=N;cnfImpla(F,C,1,f77dims);} -#define F77_IMPORT_REAL_ARRAY(F,C,N) -#define F77_IMPORT_BYTE_ARRAY(F,C,N) -#define F77_IMPORT_WORD_ARRAY(F,C,N) -#define F77_IMPORT_UBYTE_ARRAY(F,C,N) -#define F77_IMPORT_UWORD_ARRAY(F,C,N) -#define F77_IMPORT_POINTER_ARRAY(F,C,N) \ - {int f77i;for (f77i=0;f77i<N;f77i++)C[f77i]=cnfCptr(F[f77i]);} -#define F77_IMPORT_LOCATOR_ARRAY(F,C,N) \ - {int f77i;for (f77i=0;f77i<N;f77i++)cnfImpch(F,DAT__SZLOC,C);} - -/* --- Call a FORTRAN routine --- */ - -#define F77_CALL(X) F77_EXTERNAL_NAME(X) - - -/* --- Execute code synchronised by the CNF global mutex */ -#define F77_LOCK(code) \ - cnfLock(); \ - code \ - cnfUnlock(); - -/* --- Pass arguments to a FORTRAN routine --- */ - -#define INTEGER_ARG(X) X -#define REAL_ARG(X) X -#define DOUBLE_ARG(X) X -#define LOGICAL_ARG(X) X -#define BYTE_ARG(X) X -#define WORD_ARG(X) X -#define UBYTE_ARG(X) X -#define UWORD_ARG(X) X -#define POINTER_ARG(X) X -#define CHARACTER_ARG(X) X -#define TRAIL_ARG(X) ,X##_length - -#define SUBROUTINE_ARG(X) X -#define INTEGER_FUNCTION_ARG(X) X -#define REAL_FUNCTION_ARG(X) X -#define DOUBLE_FUNCTION_ARG(X) X -#define LOGICAL_FUNCTION_ARG(X) X -#define CHARACTER_FUNCTION_ARG(X) X -#define BYTE_FUNCTION_ARG(X) X -#define WORD_FUNCTION_ARG(X) X -#define UBYTE_FUNCTION_ARG(X) X -#define UWORD_FUNCTION_ARG(X) X -#define POINTER_FUNCTION_ARG(X) X - -#define INTEGER_ARRAY_ARG(X) (F77_INTEGER_TYPE *)X -#define REAL_ARRAY_ARG(X) (F77_REAL_TYPE *)X -#define DOUBLE_ARRAY_ARG(X) (F77_DOUBLE_TYPE *)X -#define LOGICAL_ARRAY_ARG(X) (F77_LOGICAL_TYPE *)X -#define BYTE_ARRAY_ARG(X) (F77_BYTE_TYPE *)X -#define WORD_ARRAY_ARG(X) (F77_WORD_TYPE *)X -#define UBYTE_ARRAY_ARG(X) (F77_UBYTE_TYPE *)X -#define UWORD_ARRAY_ARG(X) (F77_UWORD_TYPE *)X -#define POINTER_ARRAY_ARG(X) (F77_POINTER_TYPE *)X -#define CHARACTER_ARRAY_ARG(X) (F77_CHARACTER_ARRAY_ARG_TYPE *)X - -/* Put the 64-bit INT support in one place */ -#define F77_INTEGER8_TYPE int64_t -#define F77_INTEGER8_FUNCTION(X) F77_INTEGER8_TYPE F77_EXTERNAL_NAME(X) -#define INTEGER8(X) F77_INTEGER8_TYPE *CNF_CONST X -#define INTEGER8_FUNCTION(X) F77_INTEGER8_TYPE (*X)() -#define INTEGER8_ARRAY(X) F77_INTEGER8_TYPE *CNF_CONST X -#define GENPTR_INTEGER8(X) -#define GENPTR_INTEGER8_ARRAY(X) -#define GENPTR_INTEGER8_FUNCTION(X) -#define DECLARE_INTEGER8(X) F77_INTEGER8_TYPE X -#define DECLARE_INTEGER8_ARRAY(X,D) F77_INTEGER8_TYPE X[D] -#define DECLARE_INTEGER8_ARRAY_DYN(X) F77_INTEGER8_TYPE *X = NULL -#define F77_CREATE_INTEGER8_ARRAY(X,N) -#define F77_ASSOC_INTEGER8_ARRAY(F,C) F=C -#define F77_FREE_INTEGER8(X) -#define F77_EXPORT_INTEGER8(C,F) F=C -#define F77_EXPORT_INTEGER8_ARRAY(C,F,N) F=(F77_INTEGER8_TYPE *)C -#define F77_IMPORT_INTEGER8(F,C) C=F -#define F77_IMPORT_INTEGER8_ARRAY(F,C,N) -#define INTEGER8_ARG(X) X -#define INTEGER8_FUNCTION_ARG(X) X -#define INTEGER8_ARRAY_ARG(X) (F77_INTEGER8_TYPE *)X - -/* ------------------------ Non-ansi section ------------------------------ */ - -/* The difference between ANSI and non-ANSI compilers, as far as macro */ -/* definition is concerned, is that non-ANSI compilers do not support the */ -/* token concatenation operator (##). To work around this, we use the fact */ -/* that the null comment is preprocessed to produce no characters at all */ -/* by our non-ANSI compilers. */ -/* This section does not deal with the fact that some non-ANSI compilers */ -/* cannot handle function prototypes. That is handled in the machine */ -/* specific sections. */ - -#if !defined(__STDC__) - -/* --- External Name --- */ - -/* Macro to define the name of a Fortran routine or common block. This */ -/* ends in an underscore on many Unix systems. */ - -#undef F77_EXTERNAL_NAME -#define F77_EXTERNAL_NAME(X) X/**/_ - - -/* --- Dummy Arguments --- */ - -/* Macros to handle character dummy arguments. */ - -#undef TRAIL -#define TRAIL(X) ,int X/**/_length - - -/* --- Declare variables --- */ - -#undef DECLARE_CHARACTER -#define DECLARE_CHARACTER(X,L) F77_CHARACTER_TYPE X[L]; \ - const int X/**/_length = L -#undef DECLARE_CHARACTER_ARRAY -#define DECLARE_CHARACTER_ARRAY(X,L,D) F77_CHARACTER_TYPE X[D][L]; \ - const int X/**/_length = L -#undef DECLARE_CHARACTER_DYN -#define DECLARE_CHARACTER_DYN(X) F77_CHARACTER_TYPE *X;\ - int X/**/_length -#undef DECLARE_CHARACTER_ARRAY_DYN -#define DECLARE_CHARACTER_ARRAY_DYN(X) F77_CHARACTER_TYPE *X;\ - int X/**/_length -#undef F77_CREATE_CHARACTER -#define F77_CREATE_CHARACTER(X,L) X=cnfCref(L);\ - X/**/_length = L -#undef F77_CREATE_CHARACTER_ARRAY -#define F77_CREATE_CHARACTER_ARRAY(X,L,N) \ - {int f77dims[1];f77dims[0]=N;X=cnfCrefa(L,1,f77dims);X/**/_length=L;} - -/* --- Pass arguments to a FORTRAN routine --- */ - -#undef TRAIL_ARG -#define TRAIL_ARG(X) ,X/**/_length - - -#endif /* of non ANSI redefinitions */ - - -/* ----------------------------------------------------------------------- */ - -/* The standard macros defined above are known to work with the following */ -/* systems: */ - -/*-------- -| Sun | ----------*/ - -/* On SunOS, the ANSI definitions work with the acc and gcc compilers. */ -/* The cc compiler uses the non ANSI definitions. It also needs the K&R */ -/* definitions in the file kr.h. */ -/* On Solaris, the standard definitions work with the cc compiler. */ - -#if defined(sun) - -#if !defined(__STDC__) -#if !defined(_F77_KR) -#define _F77_KR -#endif -#endif - -#endif /* Sun */ - -/* -------------------- System dependent sections ------------------------- */ - -/*------------ -| VAX/VMS | --------------*/ - -/* Many macros need to be changed due to the way that VMS handles external */ -/* names, passes character arguments and handles logical values. */ - - -#if defined(VMS) - -/* --- Data Types --- */ - -/* Redefine the macro for the byte data type as signed is not valid syntax */ -/* as the VMS compiler is not ANSI compliant. */ - -#undef F77_BYTE_TYPE -#define F77_BYTE_TYPE char - - -/* --- External Names --- */ - -/* Macro to define the name of a Fortran routine or common block. */ -/* Fortran and C routines names are the same on VMS. */ - -#undef F77_EXTERNAL_NAME -#define F77_EXTERNAL_NAME(X) X - - -/* --- Dummy Arguments --- */ - -/* Macros to handle character arguments. */ -/* Character string arguments are pointers to character string descriptors */ -/* and there are no trailing arguments. */ - -#if( VMS != 0 ) -#include <descrip.h> -#endif - - -#undef F77_CHARACTER_ARG_TYPE -#define F77_CHARACTER_ARG_TYPE struct dsc$descriptor_s -#undef F77_CHARACTER_ARRAY_ARG_TYPE -#define F77_CHARACTER_ARRAY_ARG_TYPE struct dsc$descriptor_a -#undef CHARACTER -#define CHARACTER(X) F77_CHARACTER_ARG_TYPE *CNF_CONST X/**/_arg -#undef TRAIL -#define TRAIL(X) -#undef CHARACTER_ARRAY -#define CHARACTER_ARRAY(X) F77_CHARACTER_ARRAY_ARG_TYPE *CNF_CONST X/**/_arg -#undef GENPTR_CHARACTER -#define GENPTR_CHARACTER(X) \ - F77_CHARACTER_TYPE *X = X/**/_arg->dsc$a_pointer; \ - int X/**/_length = X/**/_arg->dsc$w_length; -#undef GENPTR_CHARACTER_ARRAY -#define GENPTR_CHARACTER_ARRAY(X) GENPTR_CHARACTER(X) - - -/* --- Logical Values --- */ - -#undef F77_TRUE -#define F77_TRUE -1 -#undef F77_ISTRUE -#define F77_ISTRUE(X) ( (X)&1 ) -#undef F77_ISFALSE -#define F77_ISFALSE(X) ( ! ( (X)&1 ) ) - - -/* --- Common Blocks --- */ - -#undef F77_BLANK_COMMON -#define F77_BLANK_COMMON $BLANK - - -/* --- Declare Variables --- */ - -#undef DECLARE_CHARACTER -#define DECLARE_CHARACTER(X,L) \ - F77_CHARACTER_TYPE X[L]; const int X/**/_length = L; \ - F77_CHARACTER_ARG_TYPE X/**/_descr = \ - { L, DSC$K_DTYPE_T, DSC$K_CLASS_S, X }; \ - F77_CHARACTER_ARG_TYPE *X/**/_arg = &X/**/_descr -#undef DECLARE_CHARACTER_ARRAY -#define DECLARE_CHARACTER_ARRAY(X,L,D) \ - F77_CHARACTER_TYPE X[D][L]; const int X/**/_length = L; \ - F77_CHARACTER_ARRAY_ARG_TYPE X/**/_descr = \ - { L, DSC$K_DTYPE_T, DSC$K_CLASS_S, X }; \ - F77_CHARACTER_ARRAY_ARG_TYPE *X/**/_arg = &X/**/_descr - - -/* --- The dynamic allocation of character arguments --- */ -#undef DECLARE_CHARACTER_DYN -#define DECLARE_CHARACTER_DYN(X) int X/**/_length;\ - F77_CHARACTER_ARG_TYPE *X/**/_arg;\ - F77_CHARACTER_TYPE *X -#undef DECLARE_CHARACTER_ARRAY_DYN -#define DECLARE_CHARACTER_ARRAY_DYN(X) int X/**/_length;\ - F77_CHARACTER_ARRAY_ARG_TYPE *X/**/_arg;\ - F77_CHARACTER_TYPE *X -#undef F77_CREATE_CHARACTER -#define F77_CREATE_CHARACTER(X,L) X/**/_arg = cnfCref(L);\ - X = X/**/_arg->dsc$a_pointer; \ - X/**/_length = X/**/_arg->dsc$w_length -#undef F77_CREATE_CHARACTER_ARRAY -#define F77_CREATE_CHARACTER_ARRAY(X,L,N) \ - {int f77dims[1];f77dims[0]=N;X/**/_arg=cnfCrefa(L,1,f77dims);X/**/_length=L;} -#define F77_CREATE_CHARACTER_ARRAY_M(X,L,N,D) X/**/_arg = cnfCrefa(L,N,D);\ - X = X/**/_arg->dsc$a_pointer; \ - X/**/_length = X/**/_arg->dsc$w_length -#undef F77_FREE_CHARACTER -#define F77_FREE_CHARACTER(X) cnfFreef( X/**/_arg ) - -/* --- Pass arguments to a FORTRAN routine --- */ - -#undef CHARACTER_ARG -#define CHARACTER_ARG(X) X/**/_arg -#undef CHARACTER_ARRAY_ARG -#define CHARACTER_ARRAY_ARG(X) X/**/_arg -#undef TRAIL_ARG -#define TRAIL_ARG(X) - -#endif /* VMS */ - -/* ----------------------------------------------------------------------- */ - -/*-------------------------- -| DECstation Ultrix (cc) | -| DECstation Ultrix (c89) | -| DECstation OSF/1 | -| Alpha OSF/1 | - --------------------------*/ - -/* Do this complicated set of definitions as a single #if cannot be */ -/* continued across multiple lines. */ - -#if defined(mips) && defined(ultrix) -#define _dec_unix 1 -#endif -#if defined(__mips) && defined(__ultrix) -#define _dec_unix 1 -#endif -#if defined(__mips__) && defined(__osf__) -#define _dec_unix 1 -#endif -#if defined(__alpha) && defined(__osf__) -#define _dec_unix 1 -#endif - -#if _dec_unix - -/* The macros for Ultrix are the same as the standard ones except for ones */ -/* dealing with logical values. The ANSI definitions work with the c89 */ -/* compiler, and the non ANSI definitions work with the cc compiler. */ -/* The same applies to DEC OSF/1, except that its cc compiler is ANSI */ -/* compliant. */ - - -/* --- Logical Values --- */ - -/* Redefine macros that evaluate to a C logical value, given a FORTRAN */ -/* logical value. These definitions are only valid when used with the DEC */ -/* FORTRAN for RISC compiler. If you are using the earlier FORTRAN for */ -/* RISC compiler from MIPS, then these macros should be deleted. */ - -#undef F77_TRUE -#define F77_TRUE -1 -#undef F77_ISTRUE -#define F77_ISTRUE(X) ( (X)&1 ) -#undef F77_ISFALSE -#define F77_ISFALSE(X) ( ! ( (X)&1 ) ) - - -#endif /* DEC Unix */ - -/* -*+ -* Name: -* cnf.h - -* Purpose: -* Function prototypes for cnf routines - -* Language: -* ANSI C - -* Type of Module: -* C include file - -* Description: -* These are the prototype definitions for the functions in the CNF -* library. They are used used in mixing C and FORTRAN programs. - -* Copyright: -* Copyright (C) 1991 Science & Engineering Research Council - -* Authors: -* PMA: Peter Allan (Starlink, RAL) -* AJC: Alan Chipperfield (Starlink, RAL) -* {enter_new_authors_here} - -* History: -* 23-MAY-1991 (PMA): -* Original version. -* 12-JAN-1996 (AJC): -* Add cnf_cref and cnf_freef -* 14-JUN-1996 (AJC): -* Add cnf_crefa, imprta, exprta -* crela, impla, expla -* 18-JUL-1996 (AJC): -* Add impch and expch -* 17-MAR-1998 (AJC): -* Add imprtap and exprtap -* {enter_changes_here} - -* Bugs: -* {note_any_bugs_here} - -*- ------------------------------------------------------------------------------- -*/ -void cnfInitRTL( int, char** ); -void *cnfCalloc( size_t, size_t ); -void cnfCopyf( const char *source_f, int source_len, char *dest_f, - int dest_len ); -void *cnfCptr( F77_POINTER_TYPE ); -char *cnfCreat( int length ); -F77_CHARACTER_ARG_TYPE *cnfCref( int length ); -F77_CHARACTER_ARG_TYPE *cnfCrefa( int length, int ndims, const int *dims ); -char *cnfCreib( const char *source_f, int source_len ); -char *cnfCreim( const char *source_f, int source_len ); -F77_LOGICAL_TYPE *cnfCrela( int ndims, const int *dims ); -void cnfExpch( const char *source_c, char *dest_f, int nchars ); -void cnfExpla( const int *source_c, F77_LOGICAL_TYPE *dest_f, int ndims, - const int *dims ); -void cnfExpn( const char *source_c, int max, char *dest_f, int dest_len ); -void cnfExprt( const char *source_c, char *dest_f, int dest_len ); -void cnfExprta( const char *source_c, int source_len, char *dest_f, - int dest_len, int ndims, const int *dims ); -void cnfExprtap( char *const *source_c, char *dest_f, int dest_len, - int ndims, const int *dims ); -F77_POINTER_TYPE cnfFptr( void *cpointer ); -void cnfFree( void * ); -void cnfFreef( F77_CHARACTER_ARG_TYPE *temp ); -void cnfImpb( const char *source_f, int source_len, char *dest_c ); -void cnfImpbn( const char *source_f, int source_len, int max, char *dest_c ); -void cnfImpch( const char *source_f, int nchars, char *dest_c ); -void cnfImpla( const F77_LOGICAL_TYPE *source_f, int *dest_c, - int ndims, const int *dims ); -void cnfImpn( const char *source_f, int source_len, int max, char *dest_c ); -void cnfImprt( const char *source_f, int source_len, char *dest_c ); -void cnfImprta( const char *source_f, int source_len, char *dest_c, - int dest_len, int ndims, const int *dims ); -void cnfImprtap( const char *source_f, int source_len, char *const *dest_c, - int dest_len, int ndims, const int *dims ); -int cnfLenc( const char *source_c ); -int cnfLenf( const char *source_f, int source_len ); -void *cnfMalloc( size_t ); -void *cnfRealloc( void *, size_t ); -int cnfRegp( void * ); -void cnfUregp( void * ); -void cnfLock( void ); -void cnfUnlock( void ); -#endif - -#ifndef CNF_OLD_DEFINED -#define CNF_OLD_DEFINED -/* Define old names to be new names */ -#define cnf_calloc cnfCalloc -#define cnf_copyf cnfCopyf -#define cnf_cptr cnfCptr -#define cnf_creat cnfCreat -#define cnf_cref cnfCref -#define cnf_crefa cnfCrefa -#define cnf_creib cnfCreib -#define cnf_creim cnfCreim -#define cnf_crela cnfCrela -#define cnf_expch cnfExpch -#define cnf_expla cnfExpla -#define cnf_expn cnfExpn -#define cnf_exprt cnfExprt -#define cnf_exprta cnfExprta -#define cnf_exprtap cnfExprtap -#define cnf_fptr cnfFptr -#define cnf_free cnfFree -#define cnf_freef cnfFreef -#define cnf_impb cnfImpb -#define cnf_impbn cnfImpbn -#define cnf_impch cnfImpch -#define cnf_impla cnfImpla -#define cnf_impn cnfImpn -#define cnf_imprt cnfImprt -#define cnf_imprta cnfImprta -#define cnf_imprtap cnfImprtap -#define cnf_lenc cnfLenc -#define cnf_lenf cnfLenf -#define cnf_malloc cnfMalloc -#define cnf_regp cnfRegp -#define cnf_uregp cnfUregp - -#endif /* CNF_MACROS */ diff --git a/ast/object.h b/ast/object.h deleted file mode 100644 index b2c2d1f..0000000 --- a/ast/object.h +++ /dev/null @@ -1,1934 +0,0 @@ -#if !defined( OBJECT_INCLUDED ) /* Include this file only once */ -#define OBJECT_INCLUDED -/* -*++ -* Name: -* object.h - -* Type: -* C include file. - -* Purpose: -* Define the interface to the Object class. - -* Invocation: -* #include "object.h" - -* Description: -* This include file defines the interface to the Object class and -* provides the type definitions, function prototypes and macros, -* etc. needed to use this class. - -* The Object class is the base class from which all other classes -* in the AST library are derived. This class provides all the -* basic Object behaviour and Object manipulation facilities -* required throughout the library. There is no Object constructor, -* however, as Objects on their own are not of much use. - -* Inheritance: -* The Object base class does not inherit from any other class. - -* Attributes Over-Ridden: -* None. - -* New Attributes Defined: -* Class (string) -* This is a read-only attribute containing the name of the -* class to which an Object belongs. -* ID (string) -* An identification string which may be used to identify the -* Object (e.g.) in debugging output, or when stored in an -* external medium such as a data file. There is no restriction -* on the string's contents. The default is an empty string. -* Ident (string) -* Like ID, this is an identification string which may be used -* to identify the Object. Unlike ID, Ident is transferred when an -* Object is copied. -* UseDefs (int) -* Should default values be used for unset attributes? -* Nobject (integer) -* This is a read-only attribute which gives the total number of -* Objects currently in existence in the same class as the -* Object given. It does not include Objects which belong to -* derived (more specialised) classes. This value is mainly -* intended for debugging, as it can be used to show whether -* Objects which should have been deleted have, in fact, been -* deleted. -* ObjSize (int) -* The in-memory size of the Object in bytes. -* RefCount (integer) -* This is a read-only Attribute which gives the "reference -* count" (the number of active pointers) associated with an -* Object. It is modified whenever pointers are created or -* annulled (by astClone or astAnnul/astEnd for example) and -* includes the initial pointer issued when the Object was -* created. If the reference count for an Object falls to zero -* as the result of annulling a pointer to it, then the Object -* will be deleted. - -* Methods Over-Ridden: -* None. - -* New Methods Defined: -* Public: -* astAnnul -* Annul a pointer to an Object. -* astClear -* Clear attribute values for an Object. -* astClone -* Clone a pointer to an Object. -* astCopy -* Copy an Object. -* astDelete -* Delete an Object. -* astExempt -* Exempt an Object pointer from AST context handling -* astExport -* Export an Object pointer to an outer context. -* astGet<X>, where <X> = C, D, F, I, L -* Get an attribute value for an Object. -* astImport -* Import an Object pointer into the current context. -* astSame -* Return true if two pointers refer to the same object. -* astSet -* Set attribute values for an Object. -* astSet<X>, where <X> = C, D, F, I, L -* Set an attribute value for an Object. -* astShow -* Display a textual representation of an Object on standard output. -* astTest -* Test if an attribute value is set for an Object. -* astTune -* Get or set the value of a global AST tuning parameter. -* -* Protected: -* astAnnulId -* Annul an external ID for an Object (for use from protected code -* which must handle external IDs). -* astClearAttrib -* Clear the value of a specified attribute for an Object. -* astClearID -* Clear the value of the ID attribute for an Object. -* astClearIdent -* Clear the value of the Ident attribute for an Object. -* astCast -* Return a deep copy of an object, cast into an instance of a -* parent class. -* astDump -* Write an Object to a Channel. -* astEqual -* Are two Objects equivalent? -* astGetAttrib -* Get the value of a specified attribute for an Object. -* astGetClass (deprecated synonym astClass) -* Obtain the value of the Class attribute for an Object. -* astGetID -* Obtain the value of the ID attribute for an Object. -* astGetIdent -* Obtain the value of the Ident attribute for an Object. -* astGetNobject -* Obtain the value of the Nobject attribute for an Object. -* astGetRefCount -* Obtain the value of the RefCount attribute for an Object. -* astSetAttrib -* Set the value of a specified attribute for an Object. -* astSetCopy -* Declare a copy constructor for an Object. -* astSetDelete -* Declare a destructor for an Object. -* astSetDump -* Declare a dump function for an Object. -* astSetVtab -* Chaneg the virtual function table associated with an Object. -* astSetID -* Set the value of the ID attribute for an Object. -* astSetIdent -* Set the value of the Ident attribute for an Object. -* astTestAttrib -* Test if a specified attribute value is set for an Object. -* astTestID -* Test whether the ID attribute for an Object is set. -* astTestIdent -* Test whether the Ident attribute for an Object is set. -* astVSet -* Set values for an Object's attributes. - -* Other Class Functions: -* Public: -* astBegin -* Begin a new AST context. -* astEnd -* End an AST context. -* astIsAObject -* Test class membership. -* astVersion -* Returns the AST library version number. -* astEscapes -* Remove escape sequences from returned text strings? -* astP2I -* Retrieve an int from a pointer. -* astI2P -* Pack an int into a pointer. -* -* Protected: -* astCheckObject -* Validate class membership. -* astInitObject -* Initialise an Object. -* astInitObjectVtab -* Initialise the virtual function table for the Object class. -* astLoadObject -* Load an Object. -* astMakeId -* Issue an identifier for an Object. -* astMakePointer -* Obtain a true C pointer from an Object identifier. - -* Macros: -* Public: -* AST__NULL -* Null Object pointer value. -* AST__VMAJOR -* The AST library major version number. -* AST__VMINOR -* The AST library minor version number. -* AST__RELEASE -* The AST library release number. -* -* Protected: -* astEQUAL -* Compare two doubles for equality. -* astMAX -* Return maximum of two values. -* astMIN -* Return minimum of two values. -* astMAKE_CHECK -* Implement the astCheck<Class>_ function for a class. -* astMAKE_CLEAR -* Implement a method to clear an attribute value for a class. -* astMAKE_GET -* Implement a method to get an attribute value for a class. -* astMAKE_ISA -* Implement the astIsA<Class>_ function for a class. -* astMAKE_SET -* Implement a method to set an attribute value for a class. -* astMAKE_TEST -* Implement a method to test if an attribute has been set for a -* class. -* astMEMBER -* Locate a member function. - -* Type Definitions: -* Public: -* AstObject -* Object type. -* -* Protected: -* AstObjectVtab -* Object virtual function table type. - -* Feature Test Macros: -* AST_CHECK_CLASS -* If the AST_CHECK_CLASS macro is defined, then Object class -* checking is enabled for all internal function invocations -* within the AST library. Otherwise, this checking is -* omitted. This macro should normally be defined as a compiler -* option during library development and debugging, but left -* undefined for software releases, so as to improve -* peformance. Class checking by the AST public interface is not -* affected by this macro. -* astCLASS -* If the astCLASS macro is undefined, only public symbols are -* made available, otherwise protected symbols (for use in other -* class implementations) are defined. This macro also affects -* the reporting of error context information, which is only -* provided for external calls to the AST library. -* astFORTRAN77 -* If the astFORTRAN77 macro is defined, reporting of error -* context information is suppressed. This is necessary when -* implementing foreign language interfaces to the AST library, as -* otherwise the file names and line numbers given would refer -* to the interface implementation rather than the user's own -* code. - -* Copyright: -* Copyright (C) 1997-2006 Council for the Central Laboratory of the -* Research Councils -* Copyright (C) 2010 Science & Technology Facilities Council. -* All Rights Reserved. - -* Licence: -* This program is free software: you can redistribute it and/or -* modify it under the terms of the GNU Lesser General Public -* License as published by the Free Software Foundation, either -* version 3 of the License, or (at your option) any later -* version. -* -* This program is distributed in the hope that it will be useful, -* but WITHOUT ANY WARRANTY; without even the implied warranty of -* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -* GNU Lesser General Public License for more details. -* -* You should have received a copy of the GNU Lesser General -* License along with this program. If not, see -* <http://www.gnu.org/licenses/>. - -* Authors: -* RFWS: R.F. Warren-Smith (Starlink) -* DSB: David S. Berry (Starlink) - -* History: -* 30-JAN-1996 (RFWS): -* Original version. -* 19-APR-1996 (RFWS): -* Added macros for implementing attribute access methods. -* 3-JUL-1996 (RFWS): -* Added new definitions to support the external interface. -* 10-SEP-1996 (RFWS): -* Added loader and related facilities. -* 30-MAY-1997 (RFWS): -* Add the ID attribute. -* 14-JUL-1997 (RFWS): -* Add astExempt function. -* 20-JAN-1998 (RFWS): -* Make the astClear and astVSet methods virtual. -* 15-SEP-1999 (RFWS): -* Made the astAnnulId function accessible to protected code. -* 3-APR-2001 (DSB): -* Added Ident attribute. -* 8-JAN-2003 (DSB): -* Added protected astInitObjectVtab method. -* 30-APR-2003 (DSB): -* Added macros AST__VMAJOR, AST__VMINOR and AST__RELEASE. -* Added astVersion function. -* 7-FEB-2004 (DSB): -* Added astEscapes function. -* 11-MAR-2005 (DSB): -* Added UseDefs attribute. -* 7-FEB-2006 (DSB): -* Added astTune function. -* 14-FEB-2006 (DSB): -* Added ObjSize attribute. -* 23-FEB-2006 (DSB): -* Moved AST__TUNULL from this file to memory.h. -* 10-MAY-2006 (DSB): -* Added astEQUAL, astMAX and astMIN. -* 26-MAY-2006 (DSB): -* Make all system includes unconditional, so that makeh is not -* confused when creating ast.h. -* 22-JUN-2007 (DSB): -* - Make astVSet return a pointer to dynamic memory holding the -* expanded setting string. -* - Add ast astSetVtab and astCast. -* 22-APR-2008 (DSB): -* Added astSame. -* 7-APR-2010 (DSB): -* Added astHasAttribute. -*-- -*/ - -/* Include files. */ -/* ============== */ -/* Configuration results. */ -/* ---------------------- */ -#if HAVE_CONFIG_H -#include <config.h> -#endif - -/* Interface definitions. */ -/* ---------------------- */ -#include "error.h" /* Error reporting facilities */ -#include "version.h" /* Version number macros */ - -/* C header files. */ -/* --------------- */ -#include <stddef.h> -#include <stdarg.h> -#include <float.h> -#include <stdio.h> - -#if defined(THREAD_SAFE) -#include <pthread.h> -#endif - -/* Macros. */ -/* ======= */ -#if defined(astCLASS) || defined(astFORTRAN77) -#define STATUS_PTR status -#else -#define STATUS_PTR astGetStatusPtr -#endif - -/* Define a dummy __attribute__ macro for use on non-GNU compilers. */ -#ifndef __GNUC__ -# define __attribute__(x) /*NOTHING*/ -#endif - -/* Set to "1" (yes) or "0" (no) to indicate if AST was build with threads - support. */ -#define AST__THREADSAFE 1 - -#if defined(astCLASS ) -#define AST__GETATTRIB_BUFF_LEN 50 /* Length of string returned by GetAttrib. */ -#define AST__ASTGETC_MAX_STRINGS 50 /* Number of string values to buffer within astGetC */ - -/* Values supplied to astManageLock */ -#define AST__LOCK 1 /* Lock the object */ -#define AST__UNLOCK 2 /* Unlock the object */ -#define AST__CHECKLOCK 3 /* Check if the object is locked */ - -/* Values returned by astThread */ -#define AST__UNLOCKED 1 /* Object is unlocked */ -#define AST__RUNNING 2 /* Object is locked by the running thread */ -#define AST__OTHER 3 /* Object is locked by another thread */ - -#endif - -/* Value that indicates that two classes are not in direct line from each - other. */ -#if defined(astCLASS ) -#define AST__COUSIN -1000000 -#endif - -/* -*+ -* Name: -* astINVOKE - -* Type: -* Protected macro. - -* Purpose: -* Invoke an AST function. - -* Synopsis: -* #include "object.h" -* astINVOKE(rettype,function) - -* Class Membership: -* Defined by the Object class. - -* Description: -* This macro expands to an invocation of an AST function, together -* with any additional actions required to support it. The actual -* expansion depends on whether the macro is expanded in internal -* code (astCLASS defined) or external code (astCLASS undefined) -* and it therefore hides the differences between these two -* interfaces. - -* Parameters: -* rettype -* A character to indicate the type of result returned by the function: -* -* V -* The function returns a value (including void or a pointer -* value, but excluding an Object pointer). astINVOKE will -* return the value unchanged. -* O -* The function returns an Object pointer. astINVOKE will -* convert it to an Object identifier if necessary. -* F -* The function returns a function pointer. astINVOKE will -* return it unchanged. This is typically used when the -* function has a variable argument list. In this case the -* function name is passed to astINVOKE without its argument -* list and a pointer to the function is returned which can -* then be supplied with an argument list. This avoids the -* need to define a macro with a variable number of arguments -* (which isn't allowed). -* function -* A normal invocation of the function returning the required -* result. In the case of a variable argument list, the -* argument list should be omitted so that the function is not -* invoked but a function pointer is returned that may then be -* used to invoke it. - -* Examples: -* #define astGetNobject(this) \ -* astINVOKE(V,astGetNobject_(astCheckObject(this))) -* Defines a macro to invoke the astGetNobject_ function which -* returns an int. -* #define astClone(this) \ -* astINVOKE(O,astClone_(astCheckObject(this))) -* Defines a macro to invoke the astClone_ function which -* returns an Object pointer. -* #define astSet astINVOKE(F,astSet_) -* Defines a macro to invoke the astSet_ function which has a -* variable argument list and returns void. The macro result is -* a pointer to the astSet_ function. This function must perform -* its own argument validation, as (e.g) astCheckObject cannot -* be invoked on its arguments via a macro. - -* Notes: -* - To avoid problems with some compilers, you should not leave -* any white space around the macro arguments. -*- -*/ - -/* Define astINVOKE, which records the current file and line number - (in case of error) using astAt, and then invokes the function - supplied as an argument of the astRetV_, astRetO_ or astRetF_ - macro. - - Suppress reporting of the file and line number from internal code - and from foreign language interfaces by not using astAt in these - cases. */ -#if defined(astCLASS) || defined(astFORTRAN77) -#define astINVOKE(rettype,function) astRet##rettype##_(function) -#else -#define astINVOKE(rettype,function) \ -astERROR_INVOKE(astRet##rettype##_(function)) -#endif - -/* astRetF_ and astRetV_ currently do nothing. */ -#define astRetF_(x) (x) -#define astRetV_(x) (x) - -/* However, astRetO_ converts a pointer to an ID if necessary. */ -#if defined(astCLASS) -#define astRetO_(x) ((void *)(x)) -#else -#define astRetO_(x) ((void *)astMakeId_((AstObject *)(x),STATUS_PTR)) -#endif - -/* -*+ -* Name: -* astINVOKE_CHECK -* astINVOKE_ISA - -* Type: -* Protected macros. - -* Purpose: -* Invoke the astCheck<Class>_ and astIsA<Class>_ functions. - -* Synopsis: -* #include "object.h" -* astINVOKE_CHECK(class,this,force) -* astINVOKE_ISA(class,this) - -* Class Membership: -* Defined by the Object class. - -* Description: -* These macros expand to invocations of the standard -* astCheck<Class>_ and astIsA<Class>_ functions for a class. - -* Parameters: -* class -* The name (not the type) of the class for which the function -* is to be invoked. -* this -* The "this" argument (the Object pointer) to be passed to the -* function. -* force -* Type checking takes time, and so can be disabled within the -* protected context in order to save time. Setting "force" to -* zero causes the astINVOKE_CHECK macro to skip the class check -* in a protected context (it assumes that AST "knows what it is -* doing"). Setting "force" to a non-zero value forces the class -* check even in a protected context. - -* Notes: -* - To avoid problems with some compilers, you should not leave -* any white space around the macro arguments. -*- -*/ - -/* For the public interface (and also internally if AST_CHECK_CLASS is - defined), define astINVOKE_CHECK to invoke the astCheck<Class> - function. */ -#if !defined(astCLASS) || defined(AST_CHECK_CLASS) -#define astINVOKE_CHECK(class,this,force) \ -astCheck##class##_((Ast##class *)astEnsurePointer_(this),astGetStatusPtr) - -/* For the internal interface, astINVOKE_CHECK omits the - astCheck<class> function (unless AST_CHECK_CLASS is defined). */ -#else - -#define astINVOKE_CHECK(class,this,force) ( (force) ? \ - ( astCheck##class##_((Ast##class *)astEnsurePointer_(this),astGetStatusPtr) ) : \ - ( (Ast##class *) astEnsurePointer_(this) ) ) - -#endif - -/* Define astINVOKE_ISA to invoke the astIsA<Class> function. */ -#if defined(astCLASS) /* Protected */ -#define astINVOKE_ISA(class,this) \ -astIsA##class##_((const Ast##class *)(this),status) -#else /* Public */ -#define astINVOKE_ISA(class,this) \ -astINVOKE(V,astIsA##class##_((const Ast##class *)astEnsurePointer_(this),astGetStatusPtr)) -#endif - -/* The astEnsurePointer_ macro ensures a true C pointer, converting - from an ID if necessary. */ -#if defined(astCLASS) /* Protected */ -#define astEnsurePointer_(x) ((void *)(x)) -#else /* Public */ -#define astEnsurePointer_(x) ((void *)astCheckLock_(astMakePointer_((AstObject *)(x),STATUS_PTR),STATUS_PTR)) -#endif - -#if defined(astCLASS) /* Protected */ -/* -*+ -* Name: -* astMAKE_CHECK - -* Type: -* Protected macro. - -* Purpose: -* Implement the astCheck<Class>_ function for a class. - -* Synopsis: -* #include "object.h" -* astMAKE_CHECK(class) - -* Class Membership: -* Defined by the Object class. - -* Description: -* This macro expands to an implementation of the public astCheck<Class>_ -* function (q.v.) which validates membership of a specified class. - -* Parameters: -* class -* The name (not the type) of the class whose membership is to be -* validated. - -* Notes: -* - This macro is provided so that class definitions can easiy -* implement the astCheck<Class>_ function, which is essentially the same -* for each class apart for a change of name. -* - To avoid problems with some compilers, you should not leave any white -* space around the macro arguments. -*- -*/ - -#ifndef MEM_DEBUG - -/* Define the macro. */ -#define astMAKE_CHECK(class) \ -\ -/* Declare the function (see the object.c file for a prologue). */ \ -Ast##class *astCheck##class##_( Ast##class *this, int *status ) { \ -\ -/* Check the inherited error status. */ \ - if ( !astOK ) return this; \ -\ -/* Check if the object is a class member. */ \ - if ( !astIsA##class( this ) ) { \ -\ -/* If not, but the pointer was valid (which means it identifies an Object \ - of some sort), then report more information about why this Object is \ - unsuitable. */ \ - if ( astOK ) { \ - astError( AST__OBJIN, "Pointer to " #class " required, but pointer " \ - "to %s given.", status, astGetClass( this ) ); \ - } \ - } \ -\ -/* Return the pointer value supplied. */ \ - return this; \ -} - -/* Define the macro with memory debugging facilities. */ -#else - -#define astMAKE_CHECK(class) \ -\ -/* Declare the function (see the object.c file for a prologue). */ \ -Ast##class *astCheck##class##_( Ast##class *this, int *status ) { \ -\ - char buf[100]; \ -\ -/* Check the inherited error status. */ \ - if ( !astOK ) return this; \ -\ -/* Check if the object is a class member. */ \ - if ( !astIsA##class( this ) ) { \ -\ -/* If not, but the pointer was valid (which means it identifies an Object \ - of some sort), then report more information about why this Object is \ - unsuitable. */ \ - if ( astOK ) { \ - astError( AST__OBJIN, "Pointer to " #class " required, but pointer " \ - "to %s given.", status, astGetClass( this ) ); \ - }\ -\ - } else { \ -\ -/* Call the astMemoryUse function to report it if the memory block is \ - being watched. */ \ - sprintf( buf, "checked (refcnt: %d)", astGetRefCount_( (AstObject *) this, status ) ); \ - astMemoryUse( this, buf ); \ - } \ -\ -/* Return the pointer value supplied. */ \ - return this; \ -} -#endif -#endif - -#if defined(astCLASS) /* Protected */ -/* -*+ -* Name: -* astMAKE_CLEAR - -* Purpose: -* Implement a method to clear an attribute value for a class. - -* Type: -* Protected macro. - -* Synopsis: -* #include "object.h" -* astMAKE_CLEAR(class,attribute,component,assign) - -* Class Membership: -* Defined by the Object class. - -* Description: -* This macro expands to an implementation of a private member function of -* the form: -* -* static void Clear<Attribute>( Ast<Class> *this ) -* -* and an external interface function of the form: -* -* void astClear<Attribute>_( Ast<Class> *this ) -* -* which implement a method for clearing a specified attribute value for -* a class. - -* Parameters: -* class -* The name (not the type) of the class to which the attribute belongs. -* attribute -* The name of the attribute to be cleared, as it appears in the function -* name (e.g. Label in "astClearLabel"). -* component -* The name of the class structure component that holds the attribute -* value. -* assign -* An expression that evaluates to the value to assign to the component -* to clear its value. - -* Examples: -* astMAKE_CLEAR(MyStuff,Flag,flag,-1) -* Implements the astClearFlag method for the MyStuff class which -* operates by setting the "flag" structure component to -1 to indicate -* that it has no value. - -* Notes: -* - To avoid problems with some compilers, you should not leave any white -* space around the macro arguments. -*- -*/ - -/* Define the macro. */ -#define astMAKE_CLEAR(class,attribute,component,assign) \ -\ -/* Private member function. */ \ -/* ------------------------ */ \ -static void Clear##attribute( Ast##class *this, int *status ) { \ -\ -/* Check the inherited error status. */ \ - if ( !astOK ) return; \ -\ -/* Assign the "clear" value. */ \ - this->component = (assign); \ -} \ -\ -/* External interface. */ \ -/* ------------------- */ \ -void astClear##attribute##_( Ast##class *this, int *status ) { \ -\ -/* Check the inherited error status. */ \ - if ( !astOK ) return; \ -\ -/* Invoke the required method via the virtual function table. */ \ - (**astMEMBER(this,class,Clear##attribute))( this, status ); \ -} -#endif - -#if defined(astCLASS) /* Protected */ -/* -*+ -* Name: -* astMAKE_CLEAR1 - -* Purpose: -* Implement a method to clear an attribute value for a class, reporting -* an error if the object has more than one reference. - -* Type: -* Protected macro. - -* Synopsis: -* #include "object.h" -* astMAKE_CLEAR1(class,attribute,component,assign) - -* Class Membership: -* Defined by the Object class. - -* Description: -* This macro expands to an implementation of a private member function of -* the form: -* -* static void Clear<Attribute>( Ast<Class> *this ) -* -* and an external interface function of the form: -* -* void astClear<Attribute>_( Ast<Class> *this ) -* -* which implement a method for clearing a specified attribute value for -* a class. An error is reported if the object has a reference count that -* is greater than one. - -* Parameters: -* class -* The name (not the type) of the class to which the attribute belongs. -* attribute -* The name of the attribute to be cleared, as it appears in the function -* name (e.g. Label in "astClearLabel"). -* component -* The name of the class structure component that holds the attribute -* value. -* assign -* An expression that evaluates to the value to assign to the component -* to clear its value. - -* Notes: -* - To avoid problems with some compilers, you should not leave any white -* space around the macro arguments. -*- -*/ - -/* Define the macro. */ -#define astMAKE_CLEAR1(class,attribute,component,assign) \ -\ -/* Private member function. */ \ -/* ------------------------ */ \ -static void Clear##attribute( Ast##class *this, int *status ) { \ -\ -/* Check the inherited error status. */ \ - if ( !astOK ) return; \ -\ -/* Report an error if the object has been cloned (i.e. has a reference \ - count that is greater than one). */ \ - if( astGetRefCount( this ) > 1 ) { \ - astError( AST__IMMUT, "astClear(%s): The " #attribute "attribute of " \ - "the supplied %s cannot be cleared because the %s has " \ - "been cloned (programming error).", status, \ - astGetClass(this), astGetClass(this), astGetClass(this) ); \ -\ -/* Otherwise, assign the "clear" value in the structure component. */ \ - } else { \ - this->component = (assign); \ - } \ -} \ -\ -/* External interface. */ \ -/* ------------------- */ \ -void astClear##attribute##_( Ast##class *this, int *status ) { \ -\ -/* Check the inherited error status. */ \ - if ( !astOK ) return; \ -\ -/* Invoke the required method via the virtual function table. */ \ - (**astMEMBER(this,class,Clear##attribute))( this, status ); \ -} -#endif - -#if defined(astCLASS) /* Protected */ -/* -*+ -* Name: -* astMAKE_GET - -* Purpose: -* Implement a method to get an attribute value for a class. - -* Type: -* Protected macro. - -* Synopsis: -* #include "object.h" -* astMAKE_GET(class,attribute,type,bad_value,assign) - -* Class Membership: -* Defined by the Object class. - -* Description: -* This macro expands to an implementation of a private member function of -* the form: -* -* static <Type> Get<Attribute>( Ast<Class> *this ) -* -* and an external interface function of the form: -* -* <Type> astGet<Attribute>_( Ast<Class> *this ) -* -* which implement a method for getting a specified attribute value for a -* class. - -* Parameters: -* class -* The name (not the type) of the class to which the attribute belongs. -* attribute -* The name of the attribute whose value is to be obtained, as it -* appears in the function name (e.g. Label in "astGetLabel"). -* type -* The C type of the attribute. -* bad_value -* A constant value to return if the inherited error status is set, or if -* the function fails. -* assign -* An expression that evaluates to the value to be returned. - -* Examples: -* astMAKE_GET(MyStuff,Flag,int,0,( this->flag == 1 )) -* Implements the astGetFlag method for the MyStuff class which operates -* by examining the integer "flag" structure component and comparing it -* with the value 1 to see if it is set. A value of 0 is returned if the -* method fails to complete successfully. - -* Notes: -* - To avoid problems with some compilers, you should not leave any white -* space around the macro arguments. -*- -*/ - -/* Define the macro. */ -#define astMAKE_GET(class,attribute,type,bad_value,assign) \ -\ -/* Private member function. */ \ -/* ------------------------ */ \ -static type Get##attribute( Ast##class *this, int *status ) { \ - type result; /* Result to be returned */ \ -\ -/* Check the inherited error status. */ \ - if ( !astOK ) return (bad_value); \ -\ -/* Assign the result value. */ \ - result = (assign); \ -\ -/* Check for errors and clear the result if necessary. */ \ - if ( !astOK ) result = (bad_value); \ -\ -/* Return the result. */ \ - return result; \ -} \ -/* External interface. */ \ -/* ------------------- */ \ -type astGet##attribute##_( Ast##class *this, int *status ) { \ -\ -/* Check the inherited error status. */ \ - if ( !astOK ) return (bad_value); \ -\ -/* Invoke the required method via the virtual function table. */ \ - return (**astMEMBER(this,class,Get##attribute))( this, status ); \ -} -#endif - -#if defined(astCLASS) /* Protected */ -/* -*+ -* Name: -* astMAKE_ISA - -* Type: -* Protected macro. - -* Purpose: -* Implement the astIsA<Class>_ function for a class. - -* Synopsis: -* #include "object.h" -* astMAKE_ISA(class,parent) - -* Class Membership: -* Defined by the Object class. - -* Description: -* This macro expands to an implementation of the public -* astIsA<Class>_ function (q.v.) which checks membership of a -* specified class. - -* Parameters: -* class -* The name (not the type) of the class whose membership is to be -* tested. -* parent -* The name of the parent class. - -* Notes: -* - This macro is provided so that class definitions can easiy -* implement the astIsA<Class>_ function, which is essentially the -* same for each class apart for a change of name. -* - To avoid problems with some compilers, you should not leave -* any white space around the macro arguments. -*- -*/ - -/* Define the macro. */ -#define astMAKE_ISA(class,parent) \ -\ -/* Declare the function (see the object.c file for a prologue). */ \ -int astIsA##class##_( const Ast##class *this, int *status ) { \ -\ -/* Local Variables: */ \ - int isa = 0; /* Is object a member? */ \ -\ -/* To test if the object is correctly constructed, we first test if it is a \ - member of the parent class. This improves the security of the test by \ - checking the object structure from the base Object class downwards \ - (without this, the "magic numbers" that identify classes might be \ - encountered by accident or we might address parts of the Object which \ - don't exist). */ \ - if ( astIsA##parent( this ) ) { \ -\ -/* Obtain the Object's size and check it is adequate for an object of the \ - proposed type (this avoids any attempt to access derived class data that \ - doesn't exist and therefore lies outside the memory allocated for the \ - object). */ \ - if ( ( (AstObject *) this )->size >= sizeof( Ast##class ) ) { \ -\ -/* If OK, see whether the check component in the object's virtual function \ - table matches the expected "magic" value. */ \ - isa = ( *astMEMBER(this,class,id.check) == &class_check ); \ - } \ - } \ -\ -/* Return the result. */ \ - return isa; \ -} -#endif - -#if defined(astCLASS) /* Protected */ -/* -*+ -* Name: -* astMAKE_SET - -* Purpose: -* Implement a method to set an attribute value for a class. - -* Type: -* Protected macro. - -* Synopsis: -* #include "object.h" -* astMAKE_SET(class,attribute,type,component,assign) - -* Class Membership: -* Defined by the Object class. - -* Description: -* This macro expands to an implementation of a private member function of -* the form: -* -* static void Set<Attribute>( Ast<Class> *this, <Type> value ) -* -* and an external interface function of the form: -* -* void astSet<Attribute>_( Ast<Class> *this, <Type> value ) -* -* which implement a method for setting a specified attribute value for a -* class. - -* Parameters: -* class -* The name (not the type) of the class to which the attribute belongs. -* attribute -* The name of the attribute to be set, as it appears in the function -* name (e.g. Label in "astSetLabel"). -* type -* The C type of the attribute. -* component -* The name of the class structure component that holds the attribute -* value. -* assign -* An expression that evaluates to the value to be assigned to the -* component. - -* Examples: -* astMAKE_SET(MyStuff,Flag,int,flag,( value != 0 )) -* Implements the astSetFlag method for the MyStuff class which operates -* by setting the "flag" structure component to 0 or 1 depending on -* whether the "value" parameter is non-zero or not. - -* Notes: -* - To avoid problems with some compilers, you should not leave -* any white space around the macro arguments. -*- -*/ - -/* Define the macro. */ -#define astMAKE_SET(class,attribute,type,component,assign) \ -\ -/* Private member function. */ \ -/* ------------------------ */ \ -static void Set##attribute( Ast##class *this, type value, int *status ) { \ -\ -/* Check the inherited error status. */ \ - if ( !astOK ) return; \ -\ -/* Store the new value in the structure component. */ \ - this->component = (assign); \ -} \ -\ -/* External interface. */ \ -/* ------------------- */ \ -void astSet##attribute##_( Ast##class *this, type value, int *status ) { \ -\ -/* Check the inherited error status. */ \ - if ( !astOK ) return; \ -\ -/* Invoke the required method via the virtual function table. */ \ - (**astMEMBER(this,class,Set##attribute))( this, value, status ); \ -} -#endif - -#if defined(astCLASS) /* Protected */ -/* -*+ -* Name: -* astMAKE_SET1 - -* Purpose: -* Implement a method to set an attribute value for a class, reporting -* an error if the object has more than one reference. - -* Type: -* Protected macro. - -* Synopsis: -* #include "object.h" -* astMAKE_SET1(class,attribute,type,component,assign) - -* Class Membership: -* Defined by the Object class. - -* Description: -* This macro expands to an implementation of a private member function of -* the form: -* -* static void Set<Attribute>( Ast<Class> *this, <Type> value ) -* -* and an external interface function of the form: -* -* void astSet<Attribute>_( Ast<Class> *this, <Type> value ) -* -* which implement a method for setting a specified attribute value for a -* class. An error is reported if the object has a reference count that -* is greater than one. - -* Parameters: -* class -* The name (not the type) of the class to which the attribute belongs. -* attribute -* The name of the attribute to be set, as it appears in the function -* name (e.g. Label in "astSetLabel"). -* type -* The C type of the attribute. -* component -* The name of the class structure component that holds the attribute -* value. -* assign -* An expression that evaluates to the value to be assigned to the -* component. - -*- -*/ - -/* Define the macro. */ -#define astMAKE_SET1(class,attribute,type,component,assign) \ -\ -/* Private member function. */ \ -/* ------------------------ */ \ -static void Set##attribute( Ast##class *this, type value, int *status ) { \ -\ -/* Check the inherited error status. */ \ - if ( !astOK ) return; \ -\ -/* Report an error if the object has been cloned (i.e. has a reference \ - count that is greater than one). */ \ - if( astGetRefCount( this ) > 1 ) { \ - astError( AST__IMMUT, "astSet(%s): The " #attribute "attribute of " \ - "the supplied %s cannot be changed because the %s has " \ - "been cloned (programming error).", status, \ - astGetClass(this), astGetClass(this), astGetClass(this) ); \ -\ -/* Otherwise, store the new value in the structure component. */ \ - } else { \ - this->component = (assign); \ - } \ -} \ -\ -/* External interface. */ \ -/* ------------------- */ \ -void astSet##attribute##_( Ast##class *this, type value, int *status ) { \ -\ -/* Check the inherited error status. */ \ - if ( !astOK ) return; \ -\ -/* Invoke the required method via the virtual function table. */ \ - (**astMEMBER(this,class,Set##attribute))( this, value, status ); \ -} -#endif - -#if defined(astCLASS) /* Protected */ -/* -*+ -* Name: -* astMAKE_TEST - -* Purpose: -* Implement a method to test if an attribute has been set for a class. - -* Type: -* Protected macro. - -* Synopsis: -* #include "object.h" -* astMAKE_TEST(class,attribute,assign) - -* Class Membership: -* Defined by the Object class. - -* Description: -* This macro expands to an implementation of a private member function of -* the form: -* -* static int Test<Attribute>( Ast<Class> *this ) -* -* and an external interface function of the form: -* -* int astTest<Attribute>_( Ast<Class> *this ) -* -* which implement a method for testing if a specified attribute has been -* set for a class. - -* Parameters: -* class -* The name (not the type) of the class to which the attribute belongs. -* attribute -* The name of the attribute to be tested, as it appears in the function -* name (e.g. Label in "astTestLabel"). -* assign -* An expression that evaluates to 0 or 1, to be used as the returned -* value. - -* Examples: -* astMAKE_TEST(MyStuff,Flag,( this->flag != -1 )) -* Implements the astTestFlag method for the MyStuff class which operates -* by testing the "flag" structure component to see if it is set to a -* value other than -1. - -* Notes: -* - To avoid problems with some compilers, you should not leave any white -* space around the macro arguments. -*- -*/ - -/* Define the macro. */ -#define astMAKE_TEST(class,attribute,assign) \ -\ -/* Private member function. */ \ -/* ------------------------ */ \ -static int Test##attribute( Ast##class *this, int *status ) { \ - int result; /* Value to return */ \ -\ -/* Check the inherited error status. */ \ - if ( !astOK ) return 0; \ -\ -/* Assign the result value. */ \ - result = (assign); \ -\ -/* Check for errors and clear the result if necessary. */ \ - if ( !astOK ) result = 0; \ -\ -/* Return the result. */ \ - return result; \ -} \ -/* External interface. */ \ -/* ------------------- */ \ -int astTest##attribute##_( Ast##class *this, int *status ) { \ -\ -/* Check the inherited error status. */ \ - if ( !astOK ) return 0; \ -\ -/* Invoke the required method via the virtual function table. */ \ - return (**astMEMBER(this,class,Test##attribute))( this, status ); \ -} -#endif - -#if defined(astCLASS) /* Protected */ -/* -*+ -* Name: -* astMEMBER - -* Purpose: -* Locate a member function. - -* Type: -* Protected macro. - -* Synopsis: -* #include "object.h" -* astMEMBER(this,class,method) - -* Class Membership: -* Defined by the Object class. - -* Description: -* This macro evaluates to the address where the pointer to a -* specified Object member function is stored. Typically, this will -* be used to obtain a pointer to the member function so that it -* can be invoked. It may also be used to assign a new function -* pointer so that a derived class can re-define a virtual function -* and hence over-ride an inherited method. - -* Parameters: -* this -* Pointer to an Object belonging to the class for which the -* virtual function is required. This must either be the class -* that originally defined the method, or one derived from it. -* class -* Name of the class that originally defined the method. This -* may differ from (i.e. be an ancestor of) the class to which -* "this" belongs. -* method -* Name of the method whose member function is to be located. - -* Returned Value: -* The address where the member function pointer is stored (the -* type of the result is determined by the type of the member -* function itself). - -* Examples: -* astMEMBER(this,Gnome,astFish) -* Returns the address where the pointer to the function that -* implements the astFish method for the "this" object is -* stored. The Gnome class should be where the astFish method -* was first defined (i.e. from where it was inherited by -* "this"). -* (**astMEMBER(this,Gnome,astFish))( this, arg1, arg2 ); -* Invokes the virtual function that implements the astFish -* method for object "this" and passes it additional arguments -* "arg2" and "arg2". Again, Gnome should be the class that -* originally defined the astFish method. -* *astMEMBER(this,Gnome,astFish) = myFish; -* Stores a pointer to the myFish function so that it replaces -* the virtual function that previously implemented the astFish -* method for the "this" object. Note that all objects in the -* same class as "this" are affected, but objects in class -* "class" are not affected (unless it happens to be the class -* to which "this" belongs). - -* Notes: -* - To avoid problems with some compilers, you should not leave -* any white space around the macro arguments. -*- -*/ - -/* A subsiduary macro that returns a pointer to the vtab of an object, - cast to an AstObjectVtab. */ -#define astVTAB(this) (((AstObject*)(this))->vtab) - -/* Define the macro. This functions by (a) casting the Object pointer - to type (AstObject *) and locating the Object's virtual function - table (b) casting the table pointer to the correct type - (AstClassVtab *) for the class in which the method pointer resides, - (c) locating the component holding the member function pointer, and - (d) taking its address. */ -#define astMEMBER(this,class,method) \ -(&((Ast##class##Vtab*)astVTAB(this))->method) - -#endif - -/* -*+ -* Name: -* astPROTO_CHECK -* astPROTO_ISA - -* Type: -* Protected macros. - -* Purpose: -* Prototype the astCheck<Class>_ and astIsA<Class>_ functions. - -* Synopsis: -* #include "object.h" -* astPROTO_CHECK(class) -* astPROTO_ISA(class) - -* Class Membership: -* Defined by the Object class. - -* Description: -* These macros expands to function prototypes for the -* astCheck<Class>_ and astIsA<Class>_ functions (q.v.) which -* validate and test for membership of a specified class. - -* Parameters: -* class -* The name (not the type) of the class whose membership is to -* be validated. - -* Notes: -* - To avoid problems with some compilers, you should not leave -* any white space around the macro arguments. -*- -*/ - -/* Define the macros. */ -#define astPROTO_CHECK(class) Ast##class *astCheck##class##_( Ast##class *, int * ); -#define astPROTO_ISA(class) int astIsA##class##_( const Ast##class *, int * ); - -/* Macros which return the maximum and minimum of two values. */ -#define astMAX(aa,bb) ((aa)>(bb)?(aa):(bb)) -#define astMIN(aa,bb) ((aa)<(bb)?(aa):(bb)) - -/* Check for equality of floating point values. We cannot compare bad values - directly because of the danger of floating point exceptions, so bad - values are dealt with explicitly. */ -#define astEQUALS(aa,bb,tol) (((aa)==AST__BAD)?(((bb)==AST__BAD)?1:0):(((bb)==AST__BAD)?0:(fabs((aa)-(bb))<=(tol)*astMAX((fabs(aa)+fabs(bb))*DBL_EPSILON,DBL_MIN)))) -#define astEQUAL(aa,bb) astEQUALS(aa,bb,1.0E5) - - -/* AST__NULL. */ -/* ---------- */ -/* Define the AST__NULL macro, which evaluates to a null Object - pointer. */ -#define AST__NULL (astI2P(0)) - - -#if defined(astCLASS) /* Protected */ - -/* Test the validy of an attribute value */ -/* ------------------------------------- */ -/* If the set attribute value is invalid, clear it. These macros should - be used in a context in which error reporting has been deferred by - calling astReporting( 0 ). */ - -#define astCLEAN_ATTRIB(attr) \ - if( astTest##attr(this) ) { \ - astSet##attr( this, astGet##attr( this ) ); \ - if( !astOK ) { \ - astClearStatus; \ - astClear##attr( this ); \ - } \ - } - -#define astCLEAN_INDEXED_ATTRIB(attr,index) \ - if( astTest##attr(this,index) ) { \ - astSet##attr( this, index, astGet##attr( this, index ) ); \ - if( !astOK ) { \ - astClearStatus; \ - astClear##attr( this, index ); \ - } \ - } - -#endif - - -#if defined(astCLASS) /* Protected */ -#define astSetVtabClassIdentifier(vtab,id_ptr) \ - ((AstObjectVtab *)(vtab))->top_id = (id_ptr) -#endif - -/* Type Definitions. */ -/* ================= */ - -/* Object structure. */ -/* ----------------- */ -/* This structure contains all information that is unique to each object in - the class (e.g. its instance variables). */ -typedef struct AstObject { - -/* Attributes specific to objects in this class. */ - unsigned long check; /* Check value to identify Objects */ - size_t size; /* Amount of memory used by Object */ - struct AstObjectVtab *vtab; /* Pointer to virtual function table */ - char dynamic; /* Memory allocated dynamically? */ - int ref_count; /* Number of active pointers to the Object */ - char *id; /* Pointer to ID string */ - char *ident; /* Pointer to Ident string */ - char usedefs; /* Use default attribute values? */ - int iref; /* Object index (unique within class) */ - void *proxy; /* A pointer to an external object that - acts as a foreign language proxy for the - AST object */ -#if defined(THREAD_SAFE) - int locker; /* Thread that has locked this Object */ - pthread_mutex_t mutex1; /* Guards access to all elements of the - Object except for the "locker" and - "ref_count" components */ - pthread_mutex_t mutex2; /* Guards access to the "locker" and - "ref_count" components */ - struct AstGlobals *globals; /* Pointer to thread-specific global data */ -#endif - -} AstObject; - -/* Class identifier structure */ -typedef struct AstClassIdentifier { - int *check; - struct AstClassIdentifier *parent; -} AstClassIdentifier; - -/* Virtual function table. */ -/* ----------------------- */ -/* The virtual function table makes a forward reference to the - AstChannel structure which is not defined until "channel.h" is - included (below). Hence make a preliminary definition available - now. */ -struct AstChannel; - -/* This table contains all information that is the same for all - objects in the class (e.g. pointers to its virtual functions). */ -#if defined(astCLASS) /* Protected */ -typedef struct AstObjectVtab { - -/* A unique identifier for this class. */ - AstClassIdentifier id; - -/* Pointer to the structure that identifies the top-level class described - by the whole vtab (of which the AstObjectVtab is just the first, - lowest-level, component). */ - AstClassIdentifier *top_id; - -/* Pointer to a dynamically allocated string holding the default - attribute values to use when creating new objects. These are read from - environment variables of the form "<CLASSNAME>_OPTIONS". */ - const char *defaults; - -/* Properties specific to this class. */ - void ( *CleanAttribs )( AstObject *, int * ); - AstObject *( *Cast )( AstObject *, AstObject *, int * ); - const char *( *GetID )( AstObject *, int * ); - const char *( *GetIdent )( AstObject *, int * ); - const char *(* GetAttrib)( AstObject *, const char *, int * ); - int (* TestAttrib)( AstObject *, const char *, int * ); - int (* TestID)( AstObject *, int * ); - int (* Same)( AstObject *, AstObject *, int * ); - int (* HasAttribute)( AstObject *, const char *, int * ); - int (* TestIdent)( AstObject *, int * ); - void (* Clear)( AstObject *, const char *, int * ); - void (* ClearAttrib)( AstObject *, const char *, int * ); - void (* ClearID)( AstObject *, int * ); - void (* ClearIdent)( AstObject *, int * ); - void (* Dump)( AstObject *, struct AstChannel *, int * ); - int (* Equal)( AstObject *, AstObject *, int * ); - void (* SetAttrib)( AstObject *, const char *, int * ); - void (* SetID)( AstObject *, const char *, int * ); - void (* SetIdent)( AstObject *, const char *, int * ); - void (* Show)( AstObject *, int * ); - void (* VSet)( AstObject *, const char *, char **, va_list, int * ); - void (* EnvSet)( AstObject *, int * ); - - void *(* GetProxy)( AstObject *, int * ); - void (* SetProxy)( AstObject *, void *, int * ); - - int (* GetObjSize)( AstObject *, int * ); - - int (* TestUseDefs)( AstObject *, int * ); - int (* GetUseDefs)( AstObject *, int * ); - void (* SetUseDefs)( AstObject *, int, int * ); - void (* ClearUseDefs)( AstObject *, int * ); - - const char *class; /* Pointer to class name string */ - void (** delete)( AstObject *, int * ); /* Pointer to array of destructors */ - void (** copy)( const AstObject *, AstObject *, int * ); /* Copy constructors */ - void (** dump)( AstObject *, struct AstChannel *, int * ); /* Dump functions */ - const char **dump_class; /* Dump function class string pointers */ - const char **dump_comment; /* Dump function comment string pointers */ - int ndelete; /* Number of destructors */ - int ncopy; /* Number of copy constructors */ - int ndump; /* Number of dump functions */ - int nobject; /* Number of active objects in the class */ - int nfree; /* No. of entries in "free_list" */ - AstObject **free_list; /* List of pointers for freed Objects */ - -#if defined(THREAD_SAFE) - int (* ManageLock)( AstObject *, int, int, AstObject **, int * ); -#endif - -} AstObjectVtab; -#endif - -#if defined(THREAD_SAFE) && defined(astCLASS) - -/* Define a structure holding all data items that are global within the - object.c file. */ - -typedef struct AstObjectGlobals { - AstObjectVtab Class_Vtab; - int Class_Init; - int Retain_Esc; - int Context_Level; - int *Active_Handles; - char GetAttrib_Buff[ AST__GETATTRIB_BUFF_LEN + 1 ]; - char *AstGetC_Strings[ AST__ASTGETC_MAX_STRINGS ]; - int AstGetC_Istr; - int AstGetC_Init; - int Nvtab; - AstObjectVtab **Known_Vtabs; -} AstObjectGlobals; - -#endif - -/* More include files. */ -/* =================== */ -/* The interface to the Channel class must be included here (after the - type definitions for the Object class) because "channel.h" itself - includes this file ("object.h"), although "object.h" refers to the - AstChannel structure above. This seems a little strange at first, - but is simply analogous to making a forward reference to a - structure type when recursively defining a normal C structure - (except that here the definitions happen to be in separate include - files). */ -#include "channel.h" - -/* Function prototypes. */ -/* ==================== */ -/* Prototypes for standard class functions. */ -/* ---------------------------------------- */ -astPROTO_CHECK(Object) /* Validate class membership */ -astPROTO_ISA(Object) /* Test class membership */ - -/* NB. There is no constructor function for this class. */ - -#if defined(astCLASS) /* Protected */ - -/* Initialiser. */ -AstObject *astInitObject_( void *, size_t, int, AstObjectVtab *, - const char *, int * ); - -/* Vtab Initialiser. */ -void astInitObjectVtab_( AstObjectVtab *, const char *, int * ); - -/* Loader. */ -AstObject *astLoadObject_( void *, size_t, AstObjectVtab *, - const char *, AstChannel *channel, int * ); - -#if defined(THREAD_SAFE) -void astInitObjectGlobals_( AstObjectGlobals * ); -#endif - -#endif - -/* Prototypes for other class functions. */ -/* ------------------------------------- */ -#if !defined(astCLASS) /* Public */ -void astBegin_( void ); -void astEnd_( int * ); -#endif - -AstObject *astI2P_( int, int * ); -AstObject *astMakeId_( AstObject *, int * ); -AstObject *astMakePointer_( AstObject *, int * ); -AstObject *astMakePointer_NoLockCheck_( AstObject *, int * ); -int astP2I_( AstObject *, int * ); -int astVersion_( int * ); -int astEscapes_( int, int * ); -int astTune_( const char *, int, int * ); -void astTuneC_( const char *, const char *, char *, int, int * ); - -/* Prototypes for member functions. */ -/* -------------------------------- */ -#if defined(astCLASS) /* Protected */ -AstObject *astAnnul_( AstObject *, int * ); -AstObject *astDelete_( AstObject *, int * ); -void astSet_( void *, const char *, int *, ... ); - -#else /* Public */ -AstObject *astDeleteId_( AstObject *, int * ); -int astThreadId_( AstObject *, int, int * ); -void astExportId_( AstObject *, int * ); -void astImportId_( AstObject *, int * ); -void astSetId_( void *, const char *, ... )__attribute__((format(printf,2,3))); -#endif - -AstObject *astAnnulId_( AstObject *, int * ); -AstObject *astCheckLock_( AstObject *, int * ); -AstObject *astClone_( AstObject *, int * ); -AstObject *astCopy_( const AstObject *, int * ); -AstObject *astFromString_( const char *, int * ); -char *astToString_( AstObject *, int * ); -const char *astGetC_( AstObject *, const char *, int * ); -double astGetD_( AstObject *, const char *, int * ); -float astGetF_( AstObject *, const char *, int * ); -int astEqual_( AstObject *, AstObject *, int * ); -int astGetI_( AstObject *, const char *, int * ); -int astHasAttribute_( AstObject *, const char *, int * ); -int astSame_( AstObject *, AstObject *, int * ); -int astTest_( AstObject *, const char *, int * ); -long astGetL_( AstObject *, const char *, int * ); -void *astGetProxy_( AstObject *, int * ); -void astClear_( AstObject *, const char *, int * ); -void astExemptId_( AstObject *, int * ); -void astLockId_( AstObject *, int, int * ); -void astSetC_( AstObject *, const char *, const char *, int * ); -void astSetD_( AstObject *, const char *, double, int * ); -void astSetF_( AstObject *, const char *, float, int * ); -void astSetI_( AstObject *, const char *, int, int * ); -void astSetL_( AstObject *, const char *, long, int * ); -void astSetProxy_( AstObject *, void *, int * ); -void astShow_( AstObject *, int * ); -void astUnlockId_( AstObject *, int, int * ); - -#if defined(astCLASS) /* Protected */ - -void astCleanAttribs_( AstObject *, int * ); -AstObject *astCast_( AstObject *, AstObject *, int * ); -AstObject *astCastCopy_( AstObject *, AstObject *, int * ); - -#if defined(THREAD_SAFE) -int astManageLock_( AstObject *, int, int, AstObject **, int * ); -#endif - -int astGetObjSize_( AstObject *, int * ); - -int astTestUseDefs_( AstObject *, int * ); -int astGetUseDefs_( AstObject *, int * ); -void astSetUseDefs_( AstObject *, int, int * ); -void astClearUseDefs_( AstObject *, int * ); - -const char *astGetAttrib_( AstObject *, const char *, int * ); -const char *astGetClass_( const AstObject *, int * ); -const char *astGetID_( AstObject *, int * ); -const char *astGetIdent_( AstObject *, int * ); -int astClassCompare_( AstObjectVtab *, AstObjectVtab *, int * ); -int astGetNobject_( const AstObject *, int * ); -int astGetRefCount_( AstObject *, int * ); -int astTestAttrib_( AstObject *, const char *, int * ); -int astTestID_( AstObject *, int * ); -int astTestIdent_( AstObject *, int * ); -void astClearAttrib_( AstObject *, const char *, int * ); -void astClearID_( AstObject *, int * ); -void astClearIdent_( AstObject *, int * ); -void astDump_( AstObject *, AstChannel *, int * ); -void astSetAttrib_( AstObject *, const char *, int * ); -void astSetCopy_( AstObjectVtab *, void (*)( const AstObject *, AstObject *, int * ), int * ); -void astSetDelete_( AstObjectVtab *, void (*)( AstObject *, int * ), int * ); -void astSetDump_( AstObjectVtab *, void (*)( AstObject *, AstChannel *, int * ), const char *, const char *, int * ); -void astSetVtab_( AstObject *, AstObjectVtab *, int * ); -void astSetID_( AstObject *, const char *, int * ); -void astSetIdent_( AstObject *, const char *, int * ); -void astEnvSet_( AstObject *, int * ); -void astVSet_( AstObject *, const char *, char **, va_list, int * ); - -#endif - - -/* Function interfaces. */ -/* ==================== */ -/* These macros are wrap-ups for the functions defined by this class - to make them easier to invoke (e.g. to avoid type mis-matches when - passing pointers to objects from derived classes). */ - -/* Interfaces to standard class functions. */ -/* --------------------------------------- */ -/* Check class membership. */ -#define astCheckObject(this) astINVOKE_CHECK(Object,this,0) -#define astVerifyObject(this) astINVOKE_CHECK(Object,this,1) - -/* Test class membership. */ -#define astIsAObject(this) astINVOKE_ISA(Object,this) - -/* NB. There is no constructor function for this class. */ - -#if defined(astCLASS) /* Protected */ - -/* Initialiser. */ -#define astInitObject(mem,size,init,vtab,name) \ -astINVOKE(O,astInitObject_(mem,size,init,vtab,name,STATUS_PTR)) - -/* Vtab Initialiser. */ -#define astInitObjectVtab(vtab,name) astINVOKE(V,astInitObjectVtab_(vtab,name,STATUS_PTR)) - -/* Loader. */ -#define astLoadObject(mem,size,vtab,name,channel) \ -astINVOKE(O,astLoadObject_(mem,size,vtab,name,astCheckChannel(channel),STATUS_PTR)) -#endif - -/* Interfaces to other class functions. */ -/* ------------------------------------ */ -#if !defined(astCLASS) /* Public */ -#define astBegin astBegin_() -#define astEnd astINVOKE(V,astEnd_(STATUS_PTR)) -#else /* Protected */ -#define astMakePointer_NoLockCheck(id) ((void *)astMakePointer_NoLockCheck_((AstObject *)(id),STATUS_PTR)) -#endif - -#define astVersion astVersion_(STATUS_PTR) -#define astEscapes(int) astEscapes_(int,STATUS_PTR) -#define astTune(name,val) astTune_(name,val,STATUS_PTR) -#define astTuneC(name,value,buff,bufflen) astTuneC_(name,value,buff,bufflen,STATUS_PTR) -#define astI2P(integer) ((void *)astI2P_(integer,STATUS_PTR)) -#define astMakeId(pointer) ((void *)astMakeId_((AstObject *)(pointer),STATUS_PTR)) -#define astP2I(pointer) astP2I_((AstObject *)(pointer),STATUS_PTR) -#define astMakePointer(id) ((void *)astCheckLock_(astMakePointer_((AstObject *)(id),STATUS_PTR),STATUS_PTR)) -#define astToString(this) astINVOKE(V,astToString_(astCheckObject(this),STATUS_PTR)) -#define astFromString(string) astINVOKE(O,astFromString_(string,STATUS_PTR)) - -/* Interfaces to member functions. */ -/* ------------------------------- */ -/* Here we make use of astCheckObject (et al.) to validate Object - pointers before use. This provides a contextual error report if a - pointer to the wrong sort of object is supplied. In the case of an - external caller, it also performs the required conversion from an - Object identifier to a true C pointer. */ - -/* These functions require special treatment for external use because - they handle Object identifiers and their resources explicitly, and - must therefore be passed identifier values without conversion to C - pointers. */ - -#if defined(astCLASS) || defined(astFORTRAN77) /* Protected or Fotran interface */ -#define astAnnulId(this) astINVOKE(O,astAnnulId_((AstObject *)(this),STATUS_PTR)) -#endif - -#if defined(astCLASS) /* Protected only */ -#define astAnnul(this) astINVOKE(O,astAnnul_(astCheckObject(this),STATUS_PTR)) -#define astDelete(this) astINVOKE(O,astDelete_(astCheckObject(this),STATUS_PTR)) -#define astSet astINVOKE(F,astSet_) - -#else /* Public only */ -#define astAnnul(this) astINVOKE(O,astAnnulId_((AstObject *)(this),STATUS_PTR)) -#define astDelete(this) astINVOKE(O,astDeleteId_((AstObject *)(this),STATUS_PTR)) -#define astExport(this) astINVOKE(V,astExportId_((AstObject *)(this),STATUS_PTR)) -#define astImport(this) astINVOKE(V,astImportId_((AstObject *)(this),STATUS_PTR)) -#define astSet astINVOKE(F,astSetId_) -#define astThread(this,ptr) astINVOKE(V,astThreadId_((AstObject *)(this),ptr,STATUS_PTR)) -#endif - -/* Both.... */ -#define astLock(this,wait) astINVOKE(V,astLockId_((AstObject *)(this),wait,STATUS_PTR)) -#define astUnlock(this,report) astINVOKE(V,astUnlockId_((AstObject *)(this),report,STATUS_PTR)) -#define astEqual(this,that) astINVOKE(V,(((AstObject*)this==(AstObject*)that)||astEqual_(astCheckObject(this),astCheckObject(that),STATUS_PTR))) -#define astExempt(this) astINVOKE(V,astExemptId_((AstObject *)(this),STATUS_PTR)) -#define astClear(this,attrib) astINVOKE(V,astClear_(astCheckObject(this),attrib,STATUS_PTR)) -#define astClone(this) astINVOKE(O,astClone_(astCheckObject(this),STATUS_PTR)) -#define astCopy(this) astINVOKE(O,astCopy_(astCheckObject(this),STATUS_PTR)) -#define astGetC(this,attrib) astINVOKE(V,astGetC_(astCheckObject(this),attrib,STATUS_PTR)) -#define astGetD(this,attrib) astINVOKE(V,astGetD_(astCheckObject(this),attrib,STATUS_PTR)) -#define astGetF(this,attrib) astINVOKE(V,astGetF_(astCheckObject(this),attrib,STATUS_PTR)) -#define astGetI(this,attrib) \ -astINVOKE(V,astGetI_(astCheckObject(this),attrib,STATUS_PTR)) -#define astGetL(this,attrib) \ -astINVOKE(V,astGetL_(astCheckObject(this),attrib,STATUS_PTR)) -#define astSetC(this,attrib,value) \ -astINVOKE(V,astSetC_(astCheckObject(this),attrib,value,STATUS_PTR)) -#define astSetD(this,attrib,value) \ -astINVOKE(V,astSetD_(astCheckObject(this),attrib,value,STATUS_PTR)) -#define astSetF(this,attrib,value) \ -astINVOKE(V,astSetF_(astCheckObject(this),attrib,value,STATUS_PTR)) -#define astSetI(this,attrib,value) \ -astINVOKE(V,astSetI_(astCheckObject(this),attrib,value,STATUS_PTR)) -#define astSetL(this,attrib,value) \ -astINVOKE(V,astSetL_(astCheckObject(this),attrib,value,STATUS_PTR)) -#define astShow(this) \ -astINVOKE(V,astShow_(astCheckObject(this),STATUS_PTR)) -#define astTest(this,attrib) \ -astINVOKE(V,astTest_(astCheckObject(this),attrib,STATUS_PTR)) -#define astSame(this,that) \ -astINVOKE(V,astSame_(astCheckObject(this),astCheckObject(that),STATUS_PTR)) -#define astHasAttribute(this,attrib) \ -astINVOKE(V,astHasAttribute_(astCheckObject(this),attrib,STATUS_PTR)) -#define astGetProxy(this) \ -astINVOKE(V,astGetProxy_(astCheckObject(this),STATUS_PTR)) -#define astSetProxy(this,proxy) \ -astINVOKE(V,astSetProxy_(astCheckObject(this),proxy,STATUS_PTR)) - - -#if defined(astCLASS) /* Protected */ - -#if defined(THREAD_SAFE) -#define astManageLock(this,mode,extra,fail) \ -astINVOKE(V,astManageLock_(astCheckObject(this),mode, extra,fail,STATUS_PTR)) -#else -#define astManageLock(this,mode,extra,fail) -#endif - -#define astCleanAttribs(this) astINVOKE(V,astCleanAttribs_(astCheckObject(this),STATUS_PTR)) -#define astGetObjSize(this) astINVOKE(V,astGetObjSize_(astCheckObject(this),STATUS_PTR)) -#define astCast(this,obj) astINVOKE(O,astCast_(astCheckObject(this),astCheckObject(obj),STATUS_PTR)) -#define astCastCopy(this,obj) astCastCopy_((AstObject*)this,(AstObject*)obj,STATUS_PTR) - -#define astClearUseDefs(this) astINVOKE(V,astClearUseDefs_(astCheckObject(this),STATUS_PTR)) -#define astTestUseDefs(this) astINVOKE(V,astTestUseDefs_(astCheckObject(this),STATUS_PTR)) -#define astGetUseDefs(this) astINVOKE(V,astGetUseDefs_(astCheckObject(this),STATUS_PTR)) -#define astSetUseDefs(this,val) astINVOKE(V,astSetUseDefs_(astCheckObject(this),val,STATUS_PTR)) - -#define astClearAttrib(this,attrib) \ -astINVOKE(V,astClearAttrib_(astCheckObject(this),attrib,STATUS_PTR)) -#define astClearID(this) astINVOKE(V,astClearID_(astCheckObject(this),STATUS_PTR)) -#define astClearIdent(this) astINVOKE(V,astClearIdent_(astCheckObject(this),STATUS_PTR)) -#define astDump(this,channel) \ -astINVOKE(V,astDump_(astCheckObject(this),astCheckChannel(channel),STATUS_PTR)) - -#define astGetAttrib(this,attrib) \ -astINVOKE(V,astGetAttrib_(astCheckObject(this),attrib,STATUS_PTR)) -#define astGetClass(this) astINVOKE(V,astGetClass_((const AstObject *)(this),STATUS_PTR)) -#define astGetID(this) astINVOKE(V,astGetID_(astCheckObject(this),STATUS_PTR)) -#define astGetIdent(this) astINVOKE(V,astGetIdent_(astCheckObject(this),STATUS_PTR)) -#define astGetNobject(this) astINVOKE(V,astGetNobject_(astCheckObject(this),STATUS_PTR)) -#define astClassCompare(class1,class2) astClassCompare_(class1,class2,STATUS_PTR) -#define astGetRefCount(this) astINVOKE(V,astGetRefCount_(astCheckObject(this),STATUS_PTR)) -#define astSetAttrib(this,setting) \ -astINVOKE(V,astSetAttrib_(astCheckObject(this),setting,STATUS_PTR)) -#define astSetCopy(vtab,copy) \ -astINVOKE(V,astSetCopy_((AstObjectVtab *)(vtab),copy,STATUS_PTR)) -#define astSetDelete(vtab,delete) \ -astINVOKE(V,astSetDelete_((AstObjectVtab *)(vtab),delete,STATUS_PTR)) -#define astSetDump(vtab,dump,class,comment) \ -astINVOKE(V,astSetDump_((AstObjectVtab *)(vtab),dump,class,comment,STATUS_PTR)) -#define astSetVtab(object,vtab) \ -astINVOKE(V,astSetVtab_((AstObject *)object,(AstObjectVtab *)(vtab),STATUS_PTR)) -#define astSetID(this,id) astINVOKE(V,astSetID_(astCheckObject(this),id,STATUS_PTR)) -#define astSetIdent(this,id) astINVOKE(V,astSetIdent_(astCheckObject(this),id,STATUS_PTR)) -#define astVSet(this,settings,text,args) \ -astINVOKE(V,astVSet_(astCheckObject(this),settings,text,args,STATUS_PTR)) -#define astEnvSet(this) \ -astINVOKE(V,astEnvSet_(astCheckObject(this),STATUS_PTR)) -#define astTestAttrib(this,attrib) \ -astINVOKE(V,astTestAttrib_(astCheckObject(this),attrib,STATUS_PTR)) -#define astTestID(this) astINVOKE(V,astTestID_(astCheckObject(this),STATUS_PTR)) -#define astTestIdent(this) astINVOKE(V,astTestIdent_(astCheckObject(this),STATUS_PTR)) - -/* Deprecated synonym. */ -#define astClass(this) astGetClass(this) -#endif - -/* Extra stuff for debuging probnlems with object handles and memory usage */ -#ifdef MEM_DEBUG - -void astWatchHandle_( int ); -void astHandleUse_( int, const char *, ... ); -void astHandleAlarm_( const char *, va_list ); - -#define astWatchHandle astWatchHandle_ -#define astHandleUse astHandleUse_ -#define astHandleAlarm astHandleAlarm_ - -#else - -#define astWatchHandle -#define astHandleUse -#define astHandleAlarm - -#endif - -#endif - |